Skip to content

Commit

Permalink
Merge pull request #5 from bruderj15/main
Browse files Browse the repository at this point in the history
Publish v0.2.0
  • Loading branch information
bruderj15 authored Oct 29, 2024
2 parents b3c9764 + 82b4662 commit 3d7ba7a
Show file tree
Hide file tree
Showing 8 changed files with 177 additions and 35 deletions.
10 changes: 10 additions & 0 deletions CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,16 @@ file.
The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
and this project adheres to [PVP versioning](https://pvp.haskell.org/).

## v0.2.0 _(2024-10-29)_

### Added
- Support for Content-Type `application/collection+json`
- Classes `EmbeddingResource res` & `CollectingResource res` for resource-modification

### Changed

- *(breaking change)* Renamed class `HasResource` to `Resource`, removed associated type and Content-Type param

## v0.1.1 _(2024-10-25)_

### Changed
Expand Down
39 changes: 23 additions & 16 deletions README.md
Original file line number Diff line number Diff line change
Expand Up @@ -12,10 +12,11 @@ Currently in infant state.
Final goal is something similar to what has been proposed [here](https://www.servant.dev/extending.html#other-directions).

## What can we do already?
Define an instance for class `ToResource ct api a` where `ct` is the Content-Type, `a` is the datatype you want to have a resty Api for and
`api` is the type of your Servant-Api within which the resty representation of your datatype `a` lives.
Define an instance for class `ToResource api res a` where `api` is the type of your Servant-Api within which the resty representation
of your datatype `a` lives and `res` is the resource-representation to create.

When providing some extra information with an instance for `Related a` we can derive related links.
When providing some extra information with an instance for `Related a` there are stock instances which derive the links
based on the relations in your instance.
## Example
```haskell
data User = User { usrId :: Int, addressId :: Int, income :: Double }
Expand All @@ -33,43 +34,49 @@ type AddressGetOne = "address" :> Capture "id" Int :> Get '[HAL JSON] (HALResour

type UserApi = UserGetOne :<|> UserGetAll
type UserGetOne = "user" :> Capture "id" Int :> Get '[HAL JSON] (HALResource User)
type UserGetAll = "user" :> Get '[HAL JSON] (HALResource [User])
type UserGetAll = "user" :> Get '[Collection JSON] (CollectionResource User)

instance Related User where
type IdSelName User = "usrId" -- This is type-safe because of using class HasField
type GetOneApi User = UserGetOne
type IdSelName User = "usrId"
type GetOneApi User = UserGetOne
type CollectionName User = "users"
type Relations User =
'[ 'HRel "address" "addressId" AddressGetOne -- Also type-safe
type Relations User =
'[ 'HRel "address" "addressId" AddressGetOne
]

```
```haskell
>>> mimeRender (Proxy @JSON) $ toResource (Proxy @(HAL JSON)) (Proxy @CompleteApi) $ User 1 100 100000
>>> mimeRender (Proxy @(HAL JSON)) $ toResource @CompleteApi @HALResource $ User 1 42 100000
```
```json
{
"_links": {
"address": {
"href": "address/100"
"href": "address/42"
},
"self": {
"href": "user/1"
}
},
"addressId": 100,
"addressId": 42,
"income": 100000,
"usrId": 1
}
```

## Goals
- [x] Deriving links where possible
- [x] Deriving simple links for self and relations
- [ ] Deriving links for paging, ...
- [ ] Type-level rewriting of APIs like `CompleteAPI` to make API HATEOAS-compliant

## Media-Types
Currently we only serve Content-Type `application/hal+json`.
Support for others such as `application/vnd.collection+json` or `application/vnd.amundsen-uber+json` can easily be added
with instances for `Accept` and `MimeRender`.
- [x] `application/hal+json`
- [x] `application/collection+json`
- [ ] Others: Easily extensible

Client usage with `MimeUnrender` is not yet supported.

## Contact information
Contributions, critics and bug reports are welcome!

Client usage with `MimeUnrender` is not yet supported but easily extensible.
Please feel free to contact me through GitHub.
5 changes: 4 additions & 1 deletion servant-hateoas.cabal
Original file line number Diff line number Diff line change
@@ -1,11 +1,13 @@
cabal-version: 3.0
name: servant-hateoas
version: 0.1.1
version: 0.2.0
synopsis: HATEOAS extension for servant
description: Create Resource-Representations for your types and make your API HATEOAS-compliant.
Resource construction is generic where possible and manually adjustable where required.
Currently HAL+JSON is the only supported Content-Type, work for more is in progress.
The ultimate goal is to generate an entirely HATEOAS-compliant API generically.
homepage: https://github.com/bruderj15/servant-hateoas
bug-reports: https://github.com/bruderj15/servant-hateoas/issues
license: BSD-3-Clause
license-file: LICENSE
author: Julian Bruder
Expand All @@ -29,6 +31,7 @@ library
, Servant.Hateoas.Some
, Servant.Hateoas.Resource
, Servant.Hateoas.ContentType.HAL
, Servant.Hateoas.ContentType.Collection

other-modules: Servant.Hateoas.Example

Expand Down
6 changes: 4 additions & 2 deletions src/Servant/Hateoas.hs
Original file line number Diff line number Diff line change
@@ -1,9 +1,11 @@
module Servant.Hateoas
( module Servant.Hateoas.ContentType.HAL
( module Servant.Hateoas.ContentType.Collection
, module Servant.Hateoas.ContentType.HAL
, module Servant.Hateoas.Resource
, module Servant.Hateoas.Some
) where

import Servant.Hateoas.ContentType.HAL
import Servant.Hateoas.ContentType.Collection (Collection, CollectionResource)
import Servant.Hateoas.ContentType.HAL (HAL, HALResource)
import Servant.Hateoas.Resource
import Servant.Hateoas.Some
81 changes: 81 additions & 0 deletions src/Servant/Hateoas/ContentType/Collection.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,81 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ViewPatterns #-}

module Servant.Hateoas.ContentType.Collection
( Collection
, CollectionResource(..)
)
where

import Servant.Hateoas.Resource
import Servant.API.ContentTypes
import qualified Network.HTTP.Media as M
import Servant.Links
import qualified Data.Foldable as Foldable
import Data.Kind
import Data.Aeson
import Data.Proxy
import GHC.Exts
import GHC.Records
import GHC.Generics

-- | Data-Kind representing Content-Types of HATEOAS collections.
--
-- Type parameter @t@ is the Mime-Type suffix in @application/vnd.collection+t@.
data Collection (t :: Type)

-- | Resource wrapper for 'Collection'.
data CollectionResource a = CollectionResource
{ href :: Maybe Link
, items :: [CollectionItem a]
, links :: [(String, Link)]
} deriving (Show, Generic)

-- | A single item inside a 'CollectionResource'.
data CollectionItem a = CollectionItem
{ item :: a
, itemLinks :: [(String, Link)]
} deriving (Show, Generic)

instance Resource CollectionResource where
addLink l (CollectionResource h r ls) = CollectionResource h r (l:ls)

instance Resource CollectionItem where
addLink l (CollectionItem i ls) = CollectionItem i (l:ls)

instance Accept (Collection JSON) where
contentType _ = "application" M.// "vnd.collection+json"

instance ToJSON a => MimeRender (Collection JSON) (CollectionResource a) where
mimeRender _ = encode

collectionLinks :: [(String, Link)] -> Value
collectionLinks = Array . Foldable.foldl' (\xs (rel, l) -> pure (object ["name" .= rel, "value" .= linkURI l]) <> xs) mempty

instance ToJSON a => ToJSON (CollectionItem a) where
toJSON (CollectionItem (toJSON -> Object m) ls) = object ["data" .= itemData, "links" .= collectionLinks ls]
where
itemData = Array $ Foldable.foldl' (\xs (k, v) -> pure (object ["name" .= k, "value" .= v]) <> xs) mempty $ toList m
toJSON (CollectionItem (toJSON -> v) _) = v

instance {-# OVERLAPPABLE #-} ToJSON a => ToJSON (CollectionResource a) where
toJSON (CollectionResource mHref is ls) = object ["collection" .= collection]
where
collection = object $ ["version" .= ("1.0" :: String), "links" .= collectionLinks ls, "items" .= is'] <> maybe [] (pure . ("href" .=) . linkURI) mHref
is' = Array $ Foldable.foldl' (\xs i -> pure (toJSON i) <> xs) mempty is

instance CollectingResource CollectionResource where
collect i (CollectionResource mHref is ls) = CollectionResource mHref (CollectionItem i mempty : is) ls

instance {-# OVERLAPPABLE #-}
( Related a, HasField (IdSelName a) a id, IsElem (GetOneApi a) api
, HasLink (GetOneApi a), MkLink (GetOneApi a) Link ~ (id -> Link)
, BuildRels api (Relations a) a
, Resource CollectionResource
)
=> ToCollection api CollectionResource a where
toCollection is = CollectionResource Nothing is' mempty
where
is' = Foldable.foldl' (\xs x -> CollectionItem x (defaultLinks (Proxy @api) x) : xs) mempty is
18 changes: 12 additions & 6 deletions src/Servant/Hateoas/ContentType/HAL.hs
Original file line number Diff line number Diff line change
Expand Up @@ -35,12 +35,15 @@ data HALResource a = HALResource
, embedded :: [(String, SomeToJSON HALResource)]
} deriving (Generic)

instance HasResource (HAL t) where
type Resource (HAL t) = HALResource
instance Resource HALResource where
addLink l (HALResource r ls es) = HALResource r (l:ls) es

instance Accept (HAL JSON) where
contentType _ = "application" M.// "hal+json"

instance ToJSON a => MimeRender (HAL JSON) (HALResource a) where
mimeRender _ = encode

instance {-# OVERLAPPABLE #-} ToJSON a => ToJSON (HALResource a) where
toJSON (HALResource res ls es) = case toJSON res of
Object kvm -> Object $ (singleton "_links" ls') <> (singleton "_embedded" es') <> kvm
Expand All @@ -49,18 +52,21 @@ instance {-# OVERLAPPABLE #-} ToJSON a => ToJSON (HALResource a) where
ls' = object [fromString rel .= object ["href" .= linkURI href] | (rel, href) <- ls]
es' = object [fromString name .= toJSON e | (name, e) <- es]

instance {-# OVERLAPPING #-} (ToJSON a, Related a, KnownSymbol (CollectionName a)) => ToJSON ([HALResource a]) where
instance {-# OVERLAPPING #-} (ToJSON a, Related a, KnownSymbol (CollectionName a)) => ToJSON [HALResource a] where
toJSON xs = object ["_links" .= (mempty :: Object), "_embedded" .= es]
where
es = object $
[ fromString (symbolVal (Proxy @(CollectionName a)))
.= (Array $ Foldable.foldl' (\xs' x -> xs' <> pure (toJSON x)) mempty xs)
]

instance EmbeddingResource HALResource where
embed e (HALResource r ls es) = HALResource r ls $ fmap SomeToJSON e : es

instance {-# OVERLAPPABLE #-}
( Related a, HasField (IdSelName a) a id, IsElem (GetOneApi a) api
, HasLink (GetOneApi a), MkLink (GetOneApi a) Link ~ (id -> Link)
, BuildRels api (Relations a) a
, HasResource (HAL t)
) => ToResource (HAL t) api a where
toResource _ api x = HALResource x (defaultLinks api x) mempty
, Resource HALResource
) => ToResource api HALResource a where
toResource x = HALResource x (defaultLinks (Proxy @api) x) mempty
2 changes: 1 addition & 1 deletion src/Servant/Hateoas/Example.hs
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,7 @@ type AddressGetOne = "address" :> Capture "id" Int :> Get '[HAL JSON] (HALResour

type UserApi = UserGetOne :<|> UserGetAll
type UserGetOne = "user" :> Capture "id" Int :> Get '[HAL JSON] (HALResource User)
type UserGetAll = "user" :> Get '[HAL JSON] (HALResource [User])
type UserGetAll = "user" :> Get '[Collection JSON] (CollectionResource User)

instance Related User where
type IdSelName User = "usrId"
Expand Down
51 changes: 42 additions & 9 deletions src/Servant/Hateoas/Resource.hs
Original file line number Diff line number Diff line change
@@ -1,10 +1,15 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module Servant.Hateoas.Resource
(
-- * Resource
HasResource(..)
, ToResource(..)
-- ** Construction
ToResource(..)
, ToCollection(..)

-- ** Modification
, Resource(..), EmbeddingResource(..), CollectingResource(..)

-- * Hypermedia-Relations
-- ** Type
Expand All @@ -21,18 +26,46 @@ where

import Servant
import Data.Kind
import Data.Aeson
import GHC.TypeLits
import GHC.Records

-- | Class that indicates that a Content-Type has a specific Resource-Representation.
class HasResource ct where
-- | Associated type for this Content-Type
type Resource ct :: Type -> Type
-- | Class for resources that carry Hypermedia-Relations.
class Resource res where
-- | Add a relation @(rel, link)@ to a resource.
addLink :: (String, Link) -> res a -> res a

-- | Class for 'Resource's that can embed other resources.
class Resource res => EmbeddingResource res where
-- | Embed a resource @b@ with its relation @rel@ as tuple @(rel, b)@.
embed :: ToJSON b => (String, b) -> res a -> res a

-- | Class for 'Resource's that can collect multiple resources.
class Resource res => CollectingResource res where
-- | Collect a resource into the collection.
collect :: a -> res a -> res a

-- | Class for converting values of @a@ to their respective Resource-Representation.
class HasResource ct => ToResource ct api a where
class ToResource api res a where
-- | Converts a value into it's Resource-Representation.
toResource :: Proxy ct -> Proxy api -> a -> Resource ct a
toResource :: a -> res a
toResource = toResource' (Proxy @api) (Proxy @res)

-- | Like 'toResource' but takes proxies for ambiguity.
toResource' :: Proxy api -> Proxy res -> a -> res a
toResource' _ _ = toResource @api @res
{-# MINIMAL toResource | toResource' #-}

-- | Class for converting multiple values of @a@ to their respective collection-like representation.
class ToCollection api res a where
-- | Converts many values into their Collection-Representation.
toCollection :: Foldable f => f a -> res a
toCollection = toCollection' (Proxy @api) (Proxy @res)

-- | Like 'toCollection' but takes proxies for ambiguity.
toCollection' :: Foldable f => Proxy api -> Proxy res -> f a -> res a
toCollection' _ _ = toCollection @api @res
{-# MINIMAL toCollection | toCollection' #-}

-- | Data-Kind for Hypermedia-Relations.
data HRel = HRel
Expand Down Expand Up @@ -78,7 +111,7 @@ instance
relatedLinks :: forall api a. (Related a, BuildRels api (Relations a) a) => Proxy api -> a -> [(String, Link)]
relatedLinks = buildRels (Proxy @(Relations a))

-- | Generates the pair (\"self\", link) where @link@ is the 'Link' to @a@ itself.
-- | Generates the pair @(\"self\", link)@ where @link@ is the 'Link' to @a@ itself.
selfLink :: forall api a id.
( Related a, HasField (IdSelName a) a id
, IsElem (GetOneApi a) api, HasLink (GetOneApi a)
Expand Down

0 comments on commit 3d7ba7a

Please sign in to comment.