diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,16 @@ 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,10 +12,11 @@ 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 } @@ -33,43 +34,49 @@ 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 but easily extensible. +Client usage with `MimeUnrender` is not yet supported. + +## Contact information +Contributions, critics and bug reports are welcome! + +Please feel free to contact me through GitHub. diff --git a/servant-hateoas.cabal b/servant-hateoas.cabal --- a/servant-hateoas.cabal +++ b/servant-hateoas.cabal @@ -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 @@ -29,6 +31,7 @@ , Servant.Hateoas.Some , Servant.Hateoas.Resource , Servant.Hateoas.ContentType.HAL + , Servant.Hateoas.ContentType.Collection other-modules: Servant.Hateoas.Example diff --git a/src/Servant/Hateoas.hs b/src/Servant/Hateoas.hs --- a/src/Servant/Hateoas.hs +++ b/src/Servant/Hateoas.hs @@ -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 diff --git a/src/Servant/Hateoas/ContentType/Collection.hs b/src/Servant/Hateoas/ContentType/Collection.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Hateoas/ContentType/Collection.hs @@ -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 diff --git a/src/Servant/Hateoas/ContentType/HAL.hs b/src/Servant/Hateoas/ContentType/HAL.hs --- a/src/Servant/Hateoas/ContentType/HAL.hs +++ b/src/Servant/Hateoas/ContentType/HAL.hs @@ -35,12 +35,15 @@ , 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 @@ -49,7 +52,7 @@ 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 $ @@ -57,10 +60,13 @@ .= (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 diff --git a/src/Servant/Hateoas/Example.hs b/src/Servant/Hateoas/Example.hs --- a/src/Servant/Hateoas/Example.hs +++ b/src/Servant/Hateoas/Example.hs @@ -23,7 +23,7 @@ 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" diff --git a/src/Servant/Hateoas/Resource.hs b/src/Servant/Hateoas/Resource.hs --- a/src/Servant/Hateoas/Resource.hs +++ b/src/Servant/Hateoas/Resource.hs @@ -1,11 +1,16 @@ {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Servant.Hateoas.Resource ( -- * Resource - HasResource(..) -, ToResource(..) + -- ** Construction + ToResource(..) +, ToCollection(..) + -- ** Modification +, Resource(..), EmbeddingResource(..), CollectingResource(..) + -- * Hypermedia-Relations -- ** Type , HRel(..) @@ -21,19 +26,47 @@ 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 { relName :: Symbol -- ^ Name of the relation @@ -78,7 +111,7 @@ 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)