diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,17 @@ 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.3.0 _(2024-12-24)_ + +### Added +- Added functionality to derive a HATEOAS Layer-Api and rewritten HATEOAS API from your API and their respective server-implementations. + +### Changed +- Removed argument `api` from class `ToResource` + +### Removed +- Temporarily removed support for content-type `application/vnd.collection+json` + ## v0.2.2 _(2024-12-01)_ ### Changed diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,77 +5,106 @@ # servant-hateoas HATEOAS support for [servant](https://hackage.haskell.org/package/servant). -## State -This is not affiliated with the official `servant` maintainers. +Infant state, highly experimental. -Currently in infant state. -Final goal is something similar to what has been proposed [here](https://www.servant.dev/extending.html#other-directions). +Find a motivating example further down this README. ## What can we do already? -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. +- [x] Derive a layered HATEOAS-API and a server-implementation from an API, basically what has been touched on [here](https://www.servant.dev/extending.html#other-directions). +- [x] Derive a HATEOAS-API from an API by rewriting the API and its server-implementation + - [x] Wrapping the response types of your API with Resource-Representations + - [x] Automatically adding the self-link to every resource + - [x] Adding custom links to resources via instances for type-class `ToResource` +- [x] Directly write a HATEOAS-API yourself -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. +## What can we do better? +Deriving the layered HATEOAS-API from your API does not require your API to be structured in a certain way. + +However, for rewriting your API we need you to specify your server-implementation as an instance of class `HasHandler` (bad name, should be `HasServer` - exists already). + +This currently makes it tricky for APIs which have shared path segments, e.g. `"api" :> (UserApi :<|> AddressApi)` + +Therefore we currently need an instance on each flattened endpoint of the API, e.g. for `"api :> UserApi"` and `"api :> AddressApi"`. + +## What's on the horizon? +A lot. There are plenty of opportunities. +- [ ] Merging the derived HATEOAS Layer-API with the rewritten HATEOAS API. +- [ ] Automatically adding links for [servant-pagination](https://hackage.haskell.org/package/servant-pagination) +- [ ] Adding rich descriptions for Hypermedia-relations for content-types such as `application/prs.hal-forms+json` +- [ ] ... + +## Media-Types +- [x] `application/hal+json` +- [ ] `application/vnd.collection+json`: Work in progrress +- [ ] `application/prs.hal-forms+json`: Soon +- [ ] Others: Maybe + +Client usage with `MimeUnrender` is not yet supported. + ## Example + +Suppose we have users and addresses, where each user has an address: ```haskell data User = User { usrId :: Int, addressId :: Int, income :: Double } deriving stock (Generic, Show, Eq, Ord) - deriving anyclass ToJSON + deriving anyclass (ToJSON) -data Address = Address { addrId :: Int, street :: String, number :: Int} +data Address = Address { addrId :: Int, street :: String, city :: String } deriving stock (Generic, Show, Eq, Ord) - deriving anyclass ToJSON + deriving anyclass (ToJSON) +``` -type CompleteApi = AddressApi :<|> UserApi +We need to define how their resource-representation looks like: +```haskell +-- default just wrapps an address to a resource +instance ToResource res Address -type AddressApi = AddressGetOne -type AddressGetOne = "address" :> Capture "id" Int :> Get '[HAL JSON] (HALResource Address) +-- add a link to the address-resource with the relation "address" for the user-resource +instance Resource res => ToResource res User where + toResource _ usr = addRel ("address", CompleteLink $ mkAddrLink $ addressId usr) $ wrap usr + where + mkAddrLink = safeLink (Proxy @AddressGetOne) (Proxy @AddressGetOne) +``` -type UserApi = UserGetOne :<|> UserGetAll -type UserGetOne = "user" :> Capture "id" Int :> Get '[HAL JSON] (HALResource User) -type UserGetAll = "user" :> Get '[Collection JSON] (CollectionResource User) +Further we define our API as usual: +```haskell +type Api = UserApi :<|> AddressApi -instance Related User where - type IdSelName User = "usrId" - type GetOneApi User = UserGetOne - type CollectionName User = "users" - type Relations User = - '[ 'HRel "address" "addressId" AddressGetOne - ] +type UserApi = UserGetOne :<|> UserGetAll :<|> UserGetAllCool +type UserGetOne = "api" :> "user" :> Capture "id" Int :> Get '[JSON] User +type UserGetAll = "api" :> "user" :> Get '[JSON] [User] +type AddressApi = AddressGetOne +type AddressGetOne = "api" :> "address" :> Capture "id" Int :> Get '[JSON] Address ``` + +Getting all the layers of the API in a HATEOAS way now is as simple as: ```haskell ->>> mimeRender (Proxy @(HAL JSON)) $ toResource @CompleteApi @HALResource $ User 1 42 100000 +layerServer :: Server (Resourcify (MkLayers Api) (HAL JSON)) +layerServer = getResourceServer (Proxy @Handler) (Proxy @(HAL JSON)) (Proxy @(MkLayers Api)) ``` -```json -{ - "_links": { - "address": { - "href": "address/42" - }, - "self": { - "href": "user/1" - } - }, - "addressId": 42, - "income": 100000, - "usrId": 1 -} + +If we further want to rewrite our API to a HATEOAS-API, we need to define the server-implementation as an instance of `HasHandler`. + +This is nothing but the usual servant-server implementation, just that the implementation is not floating around in the source code and instead is bound to a class instance. +```haskell +instance HasHandler UserGetOne where + getHandler _ _ = \uId -> return $ User uId 1 1000 +instance HasHandler UserGetAll where + getHandler _ _ = return [User 1 1 1000, User 2 2 2000, User 42 3 3000] +instance HasHandler AddressGetOne where + getHandler _ _ = \aId -> return $ Address aId "Foo St" "BarBaz" ``` -## Goals -- [x] Deriving simple links for self and relations -- [ ] Deriving more complex links...? -- [ ] Type-level rewriting of APIs like `CompleteAPI` to make API HATEOAS-compliant +Getting the rewritten HATEOAS-API and it's server-implementation is as simple as: +```haskell +apiServer :: Server (Resourcify Api (HAL JSON)) +apiServer = getResourceServer (Proxy @Handler) (Proxy @(HAL JSON)) (Proxy @Api) +``` -## Media-Types -- [x] `application/hal+json` -- [x] `application/collection+json` -- [ ] `application/hal-forms+json` soon -- [ ] Others: Maybe +For now `apiServer` and `layerServer` exist in isolation, but the goal is to merge them into one. -Client usage with `MimeUnrender` is not yet supported. +The complete example can be found [here](https://github.com/bruderj15/servant-hateoas/blob/main/src/Servant/Hateoas/Example.hs). ## Contact information Contributions, critics and bug reports are welcome! diff --git a/servant-hateoas.cabal b/servant-hateoas.cabal --- a/servant-hateoas.cabal +++ b/servant-hateoas.cabal @@ -1,11 +1,14 @@ cabal-version: 3.0 name: servant-hateoas -version: 0.2.2 +version: 0.3.0 synopsis: HATEOAS extension for servant description: Create Resource-Representations for your types and make your API HATEOAS-compliant. - Automatically derive hypermedia-links where possible. - Currently HAL+JSON and Collection+JSON are the only supported Content-Types. - The ultimate goal is to generate an entirely HATEOAS-compliant API generically. + Automatically derive a HATEOAS-API and server-implementation from your API or straight up define a HATEOAS-API yourself. + Currently HAL+JSON is the only supported Content-Type. Work for further is on progress. + For now only basic hypermedia-link derivations such as the self-link are automatically generated. + Expect more sophisticated link-derivation e.g. for paging in the future. + This library is highly experimental and subject to change. + homepage: https://github.com/bruderj15/servant-hateoas bug-reports: https://github.com/bruderj15/servant-hateoas/issues license: BSD-3-Clause @@ -30,17 +33,28 @@ exposed-modules: Servant.Hateoas , Servant.Hateoas.Resource + , Servant.Hateoas.HasHandler + , Servant.Hateoas.RelationLink + , Servant.Hateoas.ResourceServer + , Servant.Hateoas.Layer + , Servant.Hateoas.Layer.Type + , Servant.Hateoas.Layer.Build + , Servant.Hateoas.Layer.Merge , Servant.Hateoas.ContentType.HAL - , Servant.Hateoas.ContentType.Collection + , Servant.Hateoas.Internal.Sym + , Servant.Hateoas.Internal.Polyvariadic other-modules: Servant.Hateoas.Example + , Servant.Hateoas.ContentType.Collection - build-depends: base >= 4.17.2 && < 5 - , aeson >= 2.2.3 && < 2.3 - , http-media >= 0.8.1 && < 0.9 - , servant >= 0.20.2 && < 0.21 - , servant-server >= 0.20.2 && < 0.21 - , constrained-some >= 0.1.0 && < 0.2 + build-depends: base >= 4.17.2 && < 5 + , aeson >= 2.2.3 && < 2.3 + , text >= 1.2.3.0 && < 2.2 + , http-media >= 0.8.1 && < 0.9 + , servant >= 0.20.2 && < 0.21 + , servant-server >= 0.20.2 && < 0.21 + , singleton-bool >= 0.1.4 && < 0.2 + , constrained-some >= 0.1.0 && < 0.2 hs-source-dirs: src default-language: GHC2021 default-extensions: DataKinds, TypeFamilies 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,15 @@ module Servant.Hateoas -( module Servant.Hateoas.ContentType.Collection -, module Servant.Hateoas.ContentType.HAL +( module Servant.Hateoas.ContentType.HAL +, module Servant.Hateoas.ResourceServer +, module Servant.Hateoas.RelationLink +, module Servant.Hateoas.HasHandler , module Servant.Hateoas.Resource +, module Servant.Hateoas.Layer ) where -import Servant.Hateoas.ContentType.Collection (Collection, CollectionResource) import Servant.Hateoas.ContentType.HAL (HAL, HALResource) +import Servant.Hateoas.ResourceServer +import Servant.Hateoas.RelationLink +import Servant.Hateoas.HasHandler import Servant.Hateoas.Resource +import Servant.Hateoas.Layer diff --git a/src/Servant/Hateoas/ContentType/Collection.hs b/src/Servant/Hateoas/ContentType/Collection.hs --- a/src/Servant/Hateoas/ContentType/Collection.hs +++ b/src/Servant/Hateoas/ContentType/Collection.hs @@ -1,7 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE ViewPatterns #-} module Servant.Hateoas.ContentType.Collection ( Collection @@ -17,9 +14,7 @@ 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. @@ -27,56 +22,65 @@ -- Type parameter @t@ is the Mime-Type suffix in @application/vnd.collection+t@. data Collection (t :: Type) +type instance MkResource (Collection t) = CollectionResource + -- | Resource wrapper for 'Collection'. data CollectionResource a = CollectionResource - { href :: Maybe Link -- ^ Link to the collection - , items :: [CollectionItem a] -- ^ All items in the collection - , links :: [(String, Link)] -- ^ Pairs @(rel, link)@ for relations - } deriving (Show, Generic) + { href :: Maybe URI -- ^ Link to the collection + , items :: [CollectionItem a] -- ^ All items in the collection + , rels :: [(String, ResourceLink)] -- ^ Pairs @(rel, link)@ for relations + } deriving (Show, Generic, Functor) +instance Semigroup (CollectionResource a) where + (CollectionResource _ is ls) <> (CollectionResource _ is' ls') = CollectionResource Nothing (is <> is') (ls <> ls') + +instance Monoid (CollectionResource a) where + mempty = CollectionResource Nothing [] [] + -- | A single item inside a 'CollectionResource'. data CollectionItem a = CollectionItem { item :: a -- ^ Wrapped item - , itemLinks :: [(String, Link)] -- ^ Links for the wrapped item - } deriving (Show, Generic) + , itemLinks :: [(String, ResourceLink)] -- ^ Links for the wrapped item + } deriving (Show, Generic, Functor) instance Resource CollectionResource where - addLink l (CollectionResource h r ls) = CollectionResource h r (l:ls) + wrap x = CollectionResource Nothing [wrap x] [] + addRel l (CollectionResource h r ls) = CollectionResource h r (l:ls) instance Resource CollectionItem where - addLink l (CollectionItem i ls) = CollectionItem i (l:ls) + wrap x = CollectionItem x [] + addRel 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 +instance ToJSON (CollectionResource 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 +collectionLinks :: [(String, ResourceLink)] -> Value +collectionLinks = Array . Foldable.foldl' (\xs (rel, l) -> pure (object ["name" .= rel, "value" .= l]) <> xs) mempty +-- TODO: I dont like this at all +-- CollectionResource a represents [a] +-- So CollectionResource [a] represents [[a]] +-- This is bad, when rewriting [Foo] in for the ResourceServer we get CollectionResource [Foo] but we want CollectionResource Foo +-- Best would be to handle this when rewriting but does this result in bloat? +-- It actually may not because we can match specialized cases in type families Resourcify and ResourcifyServer +-- How does this affect other parts of the procedure? +-- Ideally we do not have to adjust any HasResourceServer/BuildLayerLink instances at all + instance ToJSON a => ToJSON (CollectionItem a) where - toJSON (CollectionItem (toJSON -> Object m) ls) = object ["data" .= itemData, "links" .= collectionLinks ls] + toJSON (CollectionItem x 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 + itemData = Array + $ Foldable.foldl' (\xs (k, v) -> pure (object ["name" .= k, "value" .= v]) <> xs) mempty + $ case toJSON x of Object o -> toList o ; _ -> mempty 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 + collection = object $ ["version" .= ("1.0" :: String), "links" .= collectionLinks ls, "items" .= is'] <> maybe [] (pure . ("href" .=)) 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 @@ -1,9 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DefaultSignatures #-} module Servant.Hateoas.ContentType.HAL -( HAL +( + -- * Content-Type + HAL + + -- * Resource-Type , HALResource(..) ) where @@ -11,62 +13,52 @@ 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.Some.Constraint import Data.Kind -import Data.Proxy import Data.Aeson import Data.Aeson.KeyMap (singleton) import GHC.Exts -import GHC.TypeLits import GHC.Generics -import GHC.Records --- | Data-Kind representing Content-Types of Hypertext Application Language (HAL). +-- | Type representing Content-Types of Hypertext Application Language (HAL). -- -- Type parameter @t@ is the mime type suffix in @application/hal+t@. data HAL (t :: Type) --- | Resource wrapper for HAL. +type instance MkResource (HAL t) = HALResource + +-- | HAL-resource representation. data HALResource a = HALResource { resource :: a -- ^ Wrapped resource - , links :: [(String, Link)] -- ^ Pairs @(rel, link)@ for relations + , rels :: [(String, ResourceLink)] -- ^ Pairs @(rel, link)@ for hypermedia relations , embedded :: [(String, SomeF HALResource ToJSON)] -- ^ Pairs @(rel, resource)@ for embedded resources - } deriving (Generic) + } deriving (Generic, Functor) instance Resource HALResource where - addLink l (HALResource r ls es) = HALResource r (l:ls) es + wrap x = HALResource x [] [] + addRel 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 +instance ToJSON (HALResource 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 - v -> v + toJSON (HALResource res ls es) = Object $ (singleton "_links" ls') <> (singleton "_embedded" es') <> (case toJSON res of Object kvm -> kvm ; _ -> mempty) where - ls' = object [fromString rel .= object ["href" .= linkURI href] | (rel, href) <- ls] + ls' = object [fromString rel .= object ["href" .= href] | (rel, href) <- ls] es' = object [fromString name .= toJSON e | (name, (Some1 e)) <- es] -instance {-# OVERLAPPING #-} (ToJSON a, Related a, KnownSymbol (CollectionName a)) => ToJSON [HALResource a] where - toJSON xs = object ["_links" .= (mempty :: Object), "_embedded" .= es] +instance {-# OVERLAPPING #-} ToJSON a => ToJSON (HALResource [a]) where + toJSON (HALResource xs ls es) = object ["_links" .= ls', "_embedded" .= object (exs <> es')] where - es = object $ - [ fromString (symbolVal (Proxy @(CollectionName a))) - .= (Array $ Foldable.foldl' (\xs' x -> xs' <> pure (toJSON x)) mempty xs) - ] + ls' = object [fromString rel .= object ["href" .= href] | (rel, href) <- ls] + es' = fmap (\(eName, (Some1 e)) -> fromString eName .= toJSON e) es + exs = [ "items" + .= (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 (\res -> Some1 $ HALResource res [] []) 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 - , Resource HALResource - ) => ToResource api HALResource a where - toResource x = HALResource x (defaultLinks (Proxy @api) x) mempty + embed e (HALResource r ls es) = HALResource r ls $ fmap Some1 e : es 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 @@ -10,25 +10,50 @@ data User = User { usrId :: Int, addressId :: Int, income :: Double } deriving stock (Generic, Show, Eq, Ord) - deriving anyclass ToJSON + deriving anyclass (ToJSON) -data Address = Address { addrId :: Int, street :: String, number :: Int} +data Address = Address { addrId :: Int, street :: String, city :: String } deriving stock (Generic, Show, Eq, Ord) - deriving anyclass ToJSON + deriving anyclass (ToJSON, ToResource res) -type CompleteApi = AddressApi :<|> UserApi +instance Resource res => ToResource res User where + toResource _ usr = addRel ("address", CompleteLink $ mkAddrLink $ addressId usr) $ wrap usr + where + mkAddrLink = safeLink (Proxy @AddressGetOne) (Proxy @AddressGetOne) +type Api = UserApi :<|> AddressApi + +type UserApi = UserGetOne :<|> UserGetAll :<|> UserGetAllCool +type UserGetOne = "api" :> "user" :> Capture "id" Int :> Get '[JSON] User +type UserGetAll = "api" :> "user" :> Get '[JSON] [User] +type UserGetAllCool = "api" :> "user" :> "cool-guys" :> Get '[JSON] [User] + type AddressApi = AddressGetOne -type AddressGetOne = "address" :> Capture "id" Int :> Get '[HAL JSON] (HALResource Address) +type AddressGetOne = "api" :> "address" :> Capture "id" Int :> Get '[JSON] Address -type UserApi = UserGetOne :<|> UserGetAll -type UserGetOne = "user" :> Capture "id" Int :> Get '[HAL JSON] (HALResource User) -type UserGetAll = "user" :> Get '[Collection JSON] (CollectionResource User) +instance HasHandler UserGetOne where + getHandler _ _ = \uId -> return $ User uId 1 1000 -instance Related User where - type IdSelName User = "usrId" - type GetOneApi User = UserGetOne - type CollectionName User = "users" - type Relations User = - '[ 'HRel "address" "addressId" AddressGetOne - ] +instance HasHandler UserGetAll where + getHandler _ _ = return [User 1 1 1000, User 2 2 2000, User 42 3 3000] + +instance HasHandler UserGetAllCool where + getHandler _ _ = return [User 42 3 3000] + +instance HasHandler AddressGetOne where + getHandler _ _ = \aId -> return $ Address aId "Foo St" "BarBaz" + +userApiServer :: Server UserApi +userApiServer = getHandler (Proxy @Handler) (Proxy @UserApi) + +layerServer :: Server (Resourcify (MkLayers Api) (HAL JSON)) +layerServer = getResourceServer (Proxy @Handler) (Proxy @(HAL JSON)) (Proxy @(MkLayers Api)) + +layerApp :: Application +layerApp = serve (Proxy @((Resourcify (MkLayers Api)) (HAL JSON))) layerServer + +apiServer :: Server (Resourcify Api (HAL JSON)) +apiServer = getResourceServer (Proxy @Handler) (Proxy @(HAL JSON)) (Proxy @Api) + +apiApp :: Application +apiApp = serve (Proxy @((Resourcify Api) (HAL JSON))) apiServer diff --git a/src/Servant/Hateoas/HasHandler.hs b/src/Servant/Hateoas/HasHandler.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Hateoas/HasHandler.hs @@ -0,0 +1,32 @@ +module Servant.Hateoas.HasHandler +( + -- * Class + HasHandler(..) +) +where + +import Servant +import Control.Monad.IO.Class +import GHC.TypeLits + +-- | Typeclass for extracting the handler of an API. +class HasHandler api where + getHandler :: MonadIO m => Proxy m -> Proxy api -> ServerT api m + +instance {-# OVERLAPPABLE #-} (HasHandler a, HasHandler b) => HasHandler (a :<|> b) where + getHandler m _ = getHandler m (Proxy @a) :<|> getHandler m (Proxy @b) + +instance {-# OVERLAPPABLE #-} HasHandler b => HasHandler ((a :: Symbol) :> b) where + getHandler m _ = getHandler m (Proxy @b) + +instance {-# OVERLAPPABLE #-} HasHandler b => HasHandler (Description sym :> b) where + getHandler m _ = getHandler m (Proxy @b) + +instance {-# OVERLAPPABLE #-} HasHandler b => HasHandler (Summary sym :> b) where + getHandler m _ = getHandler m (Proxy @b) + +instance {-# OVERLAPPABLE #-} HasHandler b => HasHandler (Fragment a :> b) where + getHandler m _ = getHandler m (Proxy @b) + +instance HasHandler EmptyAPI where + getHandler _ _ = emptyServer diff --git a/src/Servant/Hateoas/Internal/Polyvariadic.hs b/src/Servant/Hateoas/Internal/Polyvariadic.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Hateoas/Internal/Polyvariadic.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Servant.Hateoas.Internal.Polyvariadic +( + -- * IsFunction + IsFun, + + -- * Simple Polyvariadic composition + PolyvariadicComp(..), + (...), + + -- * Polyvariadic composition with two functions + PolyvariadicComp2(..), +) +where + +import Data.Kind + +-- | Type-level function to determine if a 'Type' is a function. +type family IsFun f where + IsFun (_ -> _) = 'True + IsFun _ = 'False + +-- | Class for polyvariadic composition. +-- +-- This is copied from the package @erisco/control-dotdotdot@. +class (b ~ IsFun f) => PolyvariadicComp f b where + type Return f b :: Type + type Replace f r b :: Type + -- | @pcomp f g@ has @g@ consume all arguments and then has @f@ consume the result of @g@. + pcomp :: (Return f b -> r) -> f -> Replace f r b + +instance (False ~ IsFun a) => PolyvariadicComp a 'False where + type Return a 'False = a + type Replace a r 'False = r + pcomp f a = f a + +instance (PolyvariadicComp b (IsFun b)) => PolyvariadicComp (a -> b) 'True where + type Return (a -> b) 'True = Return b (IsFun b) + type Replace (a -> b) r 'True = a -> Replace b r (IsFun b) + pcomp final f = \x -> final `pcomp` f x + +-- | Infix for 'pcomp'. +(...) :: (PolyvariadicComp f b, IsFun f ~ b) => (Return f b -> r) -> f -> Replace f r b +(...) = pcomp +infixr 9 ... + +-- | Like 'PolyvariadicComp' but allows to consume all arguments twice, +-- by two functions with the exact same arguments but potentially different return types. +class (b ~ IsFun f, b ~ IsFun g) => PolyvariadicComp2 f g b where + type Return2 f g b :: Type + type Replace2 f g r b :: Type + -- | @pcomp2 f g h@ has each @g@ and @h@ consume all arguments and then has @f@ consume the result of @g@ and @h@. + -- + -- This is highly similar to '(&&&)' from 'Control.Arrow' but for polyvariadic composition. + pcomp2 :: (Return2 f g b -> r) -> f -> g -> Replace2 f g r b + +instance (False ~ IsFun a, IsFun b ~ False) => PolyvariadicComp2 a b 'False where + type Return2 a b 'False = (a, b) + type Replace2 a b r 'False = r + pcomp2 f a b = f (a, b) + +instance (IsFun b ~ IsFun c, PolyvariadicComp2 b c (IsFun b)) => PolyvariadicComp2 (a -> b) (a -> c) 'True where + type Return2 (a -> b) (a -> c) 'True = Return2 b c (IsFun b) + type Replace2 (a -> b) (a -> c) r 'True = a -> Replace2 b c r (IsFun b) + pcomp2 final f g = \x -> pcomp2 final (f x) (g x) diff --git a/src/Servant/Hateoas/Internal/Sym.hs b/src/Servant/Hateoas/Internal/Sym.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Hateoas/Internal/Sym.hs @@ -0,0 +1,39 @@ +module Servant.Hateoas.Internal.Sym +( + -- * Type + Sym, + + -- * Type family + Symify +) +where + +import Servant +import Servant.Hateoas.HasHandler +import Servant.Hateoas.RelationLink +import GHC.TypeLits + +-- | A wrapper for path segments of kind 'Symbol'. +data Sym (sym :: Symbol) + +instance (HasServer api context, KnownSymbol sym) => HasServer (Sym sym :> api) context where + type ServerT (Sym sym :> api) m = ServerT (sym :> api) m + route _ = route (Proxy @(sym :> api)) + hoistServerWithContext _ = hoistServerWithContext (Proxy @(sym :> api)) + +instance (HasLink api, KnownSymbol sym) => HasLink (Sym sym :> api) where + type MkLink (Sym sym :> api) link = MkLink (sym :> api) link + toLink f _ = toLink f (Proxy @(sym :> api)) + +instance (HasRelationLink api, KnownSymbol sym) => HasRelationLink (Sym sym :> api) where + toRelationLink _ = toRelationLink (Proxy @(sym :> api)) + +instance (HasHandler api, KnownSymbol sym) => HasHandler (Sym sym :> api) where + getHandler m _ = getHandler m (Proxy @(sym :> api)) + +-- | A type family that wraps all path segments of kind 'Symbol' in an API with 'Sym'. +type family Symify api where + Symify (a :<|> b) = Symify a :<|> Symify b + Symify ((sym :: Symbol) :> b) = Sym sym :> Symify b + Symify (a :> b) = a :> Symify b + Symify a = a diff --git a/src/Servant/Hateoas/Layer.hs b/src/Servant/Hateoas/Layer.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Hateoas/Layer.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Servant.Hateoas.Layer +( + -- * Create + MkLayers, + + -- * Type + module Servant.Hateoas.Layer.Type, + + -- * Build + module Servant.Hateoas.Layer.Build, + + -- * Merge + module Servant.Hateoas.Layer.Merge, + + -- * Utilities + GoLayers, + Normalize, +) +where + +import Servant +import Servant.Hateoas.Layer.Type +import Servant.Hateoas.Layer.Merge +import Servant.Hateoas.Layer.Build +import Servant.Hateoas.Internal.Sym +import Data.Kind + +-- | Given an API, create a list of 'Layer's that represents the HATEOAS structure of the API. +-- +-- This is done by: +-- +-- 1. Rewriting every @(sym :: Symbol) :> b@ into @Sym sym :> b@ so all subsets of the API have kind 'Type', see 'Symify'. +-- +-- 2. Normalizing the API to make every node-choice unambiguous, see 'Normalize'. +-- +-- 3. Creating all intermediate layers of the API and their immediate next layers, see 'GoLayers'. +-- +-- 4. Merging the immediate next layers of all layers that share the same API, see 'MergeLayers'. +-- +type MkLayers :: p -> [Layer] +type family MkLayers api where + MkLayers api = MergeLayers (GoLayers (Normalize (Symify api)) '[]) '[] + +-- | Rewrite the API pulling out every shared prefix between all branches of the API. +-- +-- This results in a tree-structure where every path from the root of the API to every node or leaf is unique. +type family Normalize api where + Normalize ((prefix :> a) :<|> (prefix :> b)) = Normalize (prefix :> (Normalize a :<|> Normalize b)) + Normalize (a :<|> b) = Normalize a :<|> Normalize b -- | TODO: Here we also need to apply 'Normalize' again! How? + Normalize ((prefix :> a) :> (prefix :> b)) = Normalize (prefix :> (Normalize a :> Normalize b)) + Normalize (a :> b) = a :> Normalize b + Normalize a = a + +-- | Creates all intermediate layers of the API and their immediate next layers. +-- +-- This is done by traversing the API-Tree where in @GoLayers api stand@, @api@ is the API seen below from @stand@. +-- +-- Argument @stand@ therefore also represents an API, but due to the right-associative nature of ':>' we model it as a list here, +-- which can be turned into an API by folding it with ':>', see 'MkPrefix'. +type GoLayers :: p -> [Type] -> [Layer] +type family GoLayers api stand where + GoLayers (a :<|> b) prefix = GoLayers a prefix ++ GoLayers b prefix + GoLayers (Sym a :> b) prefix = '[ 'Layer prefix '[Sym a] GetIntermediate ] ++ GoLayers b (prefix ++ '[Sym a]) + GoLayers (Capture' mods sym a :> b) prefix = '[ 'Layer prefix '[Capture' mods sym a] GetIntermediate ] ++ GoLayers b (prefix ++ '[Capture' mods sym a]) + GoLayers (CaptureAll sym a :> b) prefix = '[ 'Layer prefix '[CaptureAll sym a] GetIntermediate ] ++ GoLayers b (prefix ++ '[CaptureAll sym a]) + GoLayers (a :> b) prefix = GoLayers b (prefix ++ '[a]) + GoLayers _ _ = '[] diff --git a/src/Servant/Hateoas/Layer/Build.hs b/src/Servant/Hateoas/Layer/Build.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Hateoas/Layer/Build.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Servant.Hateoas.Layer.Build +( + -- * Type family + ReplaceHandler, + + -- * Class + BuildLayerLinks(..), + + -- * Utility Constraint + LayerLinkable +) +where + +import Servant +import Servant.Hateoas.Resource +import Servant.Hateoas.RelationLink +import Servant.Hateoas.Layer.Type +import Servant.Hateoas.Internal.Sym +import Servant.Hateoas.Internal.Polyvariadic +import Data.Kind +import Control.Monad.IO.Class +import GHC.TypeLits + +-- | Replace the result 'Type' of a function with a new 'Type'. +type family ReplaceHandler server replacement where + ReplaceHandler (a :<|> b) replacement = ReplaceHandler a replacement :<|> ReplaceHandler b replacement + ReplaceHandler (a -> b) replacement = a -> ReplaceHandler b replacement + ReplaceHandler _ replacement = replacement + +-- | Create all 'ResourceLink's to a 'Layer's 'RelativeChildren'. +type BuildLayerLinks :: Layer -> (Type -> Type) -> Constraint +class BuildLayerLinks l m where + buildLayerLinks :: MonadIO m => Proxy l -> Proxy m -> ReplaceHandler (ServerT l m) [(String, ResourceLink)] + +instance + ( api ~ MkPrefix apiCs verb + , HasLink api, IsElem api api + , mkSelf ~ MkLink api Link + , PolyvariadicComp mkSelf (IsFun mkSelf) + , Return mkSelf (IsFun mkSelf) ~ Link + , Replace mkSelf [(String, ResourceLink)] (IsFun mkSelf) ~ ReplaceHandler (ServerT api m) [(String, ResourceLink)] + ) => BuildLayerLinks ('Layer apiCs '[] verb) m where + buildLayerLinks _ _ = (pure @[] . ("self", ) . CompleteLink) ... mkSelf + where + mkSelf = safeLink (Proxy @api) (Proxy @api) + +-- | Convenience alias 'Constraint' for 'Layer's that can be linked. +type LayerLinkable api cs verb m mkLink = + ( BuildLayerLinks ('Layer api cs verb) m + , PolyvariadicComp mkLink (IsFun mkLink) + , ReplaceHandler (ServerT (MkPrefix api verb) m) [(String, ResourceLink)] ~ [(String, ResourceLink)] + , Replace mkLink [(String, ResourceLink)] (IsFun mkLink) ~ [(String, ResourceLink)] + , Return mkLink (IsFun mkLink) ~ Link + ) + +instance + ( LayerLinkable apiCs cs verb m mkLink + , c ~ MkPrefix (apiCs ++ '[Sym sym]) verb + , HasLink c, IsElem c c + , mkLink ~ MkLink c Link + , KnownSymbol sym + ) => BuildLayerLinks ('Layer apiCs (Sym sym ': cs) verb) m where + buildLayerLinks _ m = ((: ls) . (symbolVal (Proxy @sym),) . CompleteLink) ... mkLink + where + mkLink = safeLink (Proxy @c) (Proxy @c) + ls = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m + +instance + ( LayerLinkable apiCs cs verb m mkLink + , c ~ MkPrefix (apiCs ++ '[Capture' mods sym x]) verb + , HasRelationLink c + , (x -> mkLink) ~ MkLink c Link + , KnownSymbol sym + ) => BuildLayerLinks ('Layer apiCs (Capture' mods sym x ': cs) verb) m where + buildLayerLinks _ m = ((: ls) . (symbolVal (Proxy @sym),) . TemplateLink) ... toRelationLink (Proxy @c) + where + ls = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m + +instance + ( LayerLinkable apiCs cs verb m mkLink + , c ~ MkPrefix (apiCs ++ '[CaptureAll sym x]) verb + , HasRelationLink c + , (x -> mkLink) ~ MkLink c Link + , KnownSymbol sym + ) => BuildLayerLinks ('Layer apiCs (CaptureAll sym x ': cs) verb) m where + buildLayerLinks _ m = ((: ls) . (symbolVal (Proxy @sym),) . TemplateLink) ... toRelationLink (Proxy @c) + where + ls = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m diff --git a/src/Servant/Hateoas/Layer/Merge.hs b/src/Servant/Hateoas/Layer/Merge.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Hateoas/Layer/Merge.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Servant.Hateoas.Layer.Merge +( + -- * Merge + MergeLayers, + + -- ** Utilities + ContainsLayerApi, + WithAllChildrenOfLayerApi +) +where + +import Servant.Hateoas.Layer.Type +import Data.Type.Bool + +-- | Given two lists of 'Layer's, merges them into one list by combining all 'RelativeChildren' of 'Layer's with the exact same API. +type MergeLayers :: [Layer] -> [Layer] -> [Layer] +type family MergeLayers ls acc where + MergeLayers '[] acc = acc + MergeLayers (l ': ls) acc = MergeLayers ls ( + If (ContainsLayerApi acc (LayerApiCs l)) + (WithAllChildrenOfLayerApi acc l) + (l ': acc) + ) + +-- | Returns 'True' iff the given list of 'Layer's contains a 'Layer' with the given API. +type family ContainsLayerApi ls api where + ContainsLayerApi '[] _ = 'False + ContainsLayerApi ('Layer api _ _ ': ls) api = 'True + ContainsLayerApi (_ ': ls) api = ContainsLayerApi ls api + +-- | If a list of 'Layer's contains a 'Layer' with the API of the given 'Layer', +-- merge the first matching 'Layer' with the given 'Layer' by combining their 'RelativeChildren'. +type family WithAllChildrenOfLayerApi ls l where + WithAllChildrenOfLayerApi '[] _ = '[] + WithAllChildrenOfLayerApi (('Layer api cs verb) ': ls) ('Layer api cs' verb) = 'Layer api (cs ++ cs') verb ': ls + WithAllChildrenOfLayerApi (l ': ls) l' = l ': WithAllChildrenOfLayerApi ls l' diff --git a/src/Servant/Hateoas/Layer/Type.hs b/src/Servant/Hateoas/Layer/Type.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Hateoas/Layer/Type.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Servant.Hateoas.Layer.Type +( + -- * Type + Layer(..), + + -- ** Getter + LayerApiCs, RelativeChildren, LayerVerb, + + -- * API-construction + LayerApi, MkPrefix, type (++), + + -- * Intermediate + Intermediate(..), GetIntermediate +) +where + +import Servant +import Servant.Server.Internal.Router +import Servant.Hateoas.Internal.Sym +import Servant.Hateoas.Resource +import Data.Aeson +import Data.Kind + +-- | Convenience alias for 'AppendList'. +type (++) xs ys = AppendList xs ys + +-- | Data-kind for a layer in an API. +-- +-- ==== __Example__ +-- +-- @ +-- ''Layer' '['Sym' \"api\", 'Sym' \"user\"] '['Capture' \"id\" 'Int', 'Sym' \"vip\"] 'GetIntermediate' +-- @ +-- +-- Represents the API +-- +-- @ +-- \"api\" :> \"user\" :> 'GetIntermediate' +-- @ with children +-- +-- @ +-- \"api\" :> \"user\" :> 'Capture' \"id\" 'Int' :> 'GetIntermediate' +-- @ and +-- +-- @ +-- \"api\" :> \"user\" :> \"vip\" :> 'GetIntermediate' +-- @ +data Layer = Layer + { api :: [Type] -- ^ The API of this layer represented as list. Folding it with ':>' results in the actual API, see 'MkPrefix'. + , relativeChildren :: [Type] -- ^ All immediate children of this layer. + , verb :: Type -- ^ The 'Verb' for this layer. + } + +-- | Type-level getter for the API of a 'Layer'. +type family LayerApiCs (a :: Layer) where + LayerApiCs ('Layer api _ _) = api + +-- | Type-level getter for the children of a 'Layer'. +type family RelativeChildren (a :: Layer) where + RelativeChildren ('Layer _ children _) = children + +-- | Type-level getter for the verb of a 'Layer'. +type family LayerVerb (a :: Layer) where + LayerVerb ('Layer _ _ verb) = verb + +-- | Constructs the actual API of a 'Layer'. +type family LayerApi (a :: Layer) where + LayerApi ('Layer api _ verb) = MkPrefix api verb + +-- | Folds a list of path segments into an API by intercalating '(:>)'. +-- +-- ==== __Example__ +-- +-- @ +-- 'MkPrefix' '['Sym' \"api\", 'Sym' \"user\"] 'GetIntermediate' +-- @ resolves to +-- +-- @ +-- 'Sym' \"api\" :> 'Sym' \"user\" :> 'GetIntermediate' +-- @ +type MkPrefix :: [Type] -> Type -> Type +type family MkPrefix prefix api where + MkPrefix (Sym x ': xs) api = x :> MkPrefix xs api + MkPrefix (x ': xs) api = x :> MkPrefix xs api + MkPrefix '[] api = api + +instance HasServer (MkPrefix apiCs verb) context => HasServer ('Layer apiCs cs verb) context where + type ServerT ('Layer apiCs cs verb) m = ServerT (MkPrefix apiCs verb) m + route _ = route (Proxy @(MkPrefix apiCs verb)) + hoistServerWithContext _ = hoistServerWithContext (Proxy @(MkPrefix apiCs verb)) + +instance HasServer ('[] :: [Layer]) context where + type ServerT '[] m = ServerT EmptyAPI m + route _ = route (Proxy @EmptyAPI) + hoistServerWithContext _ = hoistServerWithContext (Proxy @EmptyAPI) + +instance (HasServer l context, HasServer ls context) => HasServer (l ': ls :: [Layer]) context where + type ServerT (l ': ls) m = ServerT l m :<|> ServerT ls m + route _ ctx delayed = route (Proxy @l) ctx ((\(sl :<|> _) -> sl) <$> delayed) `choice` route (Proxy @ls) ctx ((\(_ :<|> sls) -> sls) <$> delayed) + hoistServerWithContext _ ctx f (sl :<|> sls) = hoistServerWithContext (Proxy @l) ctx f sl :<|> hoistServerWithContext (Proxy @ls) ctx f sls + +-- | A response type for a 'Layer' that does not contain any data. +newtype Intermediate = Intermediate () + deriving newtype (Show, Eq, Ord, ToJSON) + +type GetIntermediate = Get '[] Intermediate + +instance Resource res => ToResource res Intermediate where + toResource _ _ = wrap $ Intermediate () diff --git a/src/Servant/Hateoas/RelationLink.hs b/src/Servant/Hateoas/RelationLink.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Hateoas/RelationLink.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +module Servant.Hateoas.RelationLink +( + -- * Type + RelationLink(..), + RelationParam(..), + mkPlaceHolder, + appendPath, + + -- * Class + HasRelationLink(..) +) +where + +import Servant +import GHC.TypeLits +import Data.String (fromString) +import Data.Kind +import Data.Aeson +import Data.Text (Text, intercalate) +import Data.Text.Encoding +import Data.Singletons.Bool + +-- | Link data-type for hypermedia-links in HATEOAS with potentially templated URIs. +data RelationLink = RelationLink + { _path :: Text + , _params :: [RelationParam] + , _templated :: Bool + , _method :: Text + } deriving (Show, Eq) + +-- | Parameter data-type for hypermedia-links in HATEOAS. +data RelationParam = RelationParam + { _name :: Text + , _required :: Bool + } deriving (Show, Eq) + +-- | Create a placeholder for a URI template parameter. +mkPlaceHolder :: Text -> Text +mkPlaceHolder s = "{" <> s <> "}" + +-- | Append a path to a URI. +appendPath :: Text -> Text -> Text +appendPath l "" = l +appendPath l r = l <> "/" <> r + +instance ToJSON RelationLink where + toJSON (RelationLink path params templated _) = String $ + if templated + then path <> "{?" <> intercalate "," (_name <$> params) <> "}" + else path + +-- | Class for creating a 'RelationLink' to an API. +class HasRelationLink endpoint where + toRelationLink :: Proxy endpoint -> RelationLink + +instance HasRelationLink b => HasRelationLink (EmptyAPI :> b) where + toRelationLink _ = toRelationLink (Proxy @b) + +instance (KnownSymbol sym, HasRelationLink b) => HasRelationLink ((sym :: Symbol) :> b) where + toRelationLink _ = let rl = toRelationLink (Proxy @b) in rl { _path = prefix `appendPath` _path rl } + where + prefix = fromString $ symbolVal (Proxy @sym) + +instance (KnownSymbol sym, HasRelationLink b) => HasRelationLink (Capture' mods sym a :> b) where + toRelationLink _ = let rl = toRelationLink (Proxy @b) in rl { _path = prefix `appendPath` _path rl } + where + prefix = mkPlaceHolder $ fromString $ symbolVal (Proxy @sym) + +instance (KnownSymbol sym, HasRelationLink b) => HasRelationLink (CaptureAll sym a :> b) where + toRelationLink _ = let rl = toRelationLink (Proxy @b) in rl { _path = prefix `appendPath` _path rl } + where + prefix = mkPlaceHolder $ fromString $ symbolVal (Proxy @sym) + +instance HasRelationLink b => HasRelationLink (Header' mods sym a :> b) where + toRelationLink _ = toRelationLink (Proxy @b) + +instance HasRelationLink b => HasRelationLink (HttpVersion :> b) where + toRelationLink _ = toRelationLink (Proxy @b) + +type family IsRequired (mods :: [Type]) :: Bool where + IsRequired (Required ': mods) = 'True + IsRequired (Optional ': mods) = 'False + IsRequired (mod ': mods) = IsRequired mods + IsRequired '[] = 'False + +instance (HasRelationLink b, KnownSymbol sym, SBoolI (IsRequired mods)) => HasRelationLink (QueryParam' mods sym a :> b) where + toRelationLink _ = let rl = toRelationLink (Proxy @b) in rl { _params = param : _params rl, _templated = True } + where + param = RelationParam + { _name = fromString $ symbolVal (Proxy @sym) + , _required = fromSBool $ sbool @(IsRequired mods) + } + +instance (HasRelationLink b, KnownSymbol sym) => HasRelationLink (QueryParams sym a :> b) where + toRelationLink _ = let rl = toRelationLink (Proxy @b) in rl { _params = param : _params rl, _templated = True } + where + param = RelationParam + { _name = fromString $ symbolVal (Proxy @sym) + , _required = False + } + +instance HasRelationLink b => HasRelationLink (QueryString :> b) where + toRelationLink _ = toRelationLink (Proxy @b) + +instance (HasRelationLink b, KnownSymbol sym) => HasRelationLink (DeepQuery sym a :> b) where + toRelationLink _ = let rl = toRelationLink (Proxy @b) in rl { _params = param : _params rl, _templated = True } + where + param = RelationParam + { _name = fromString $ symbolVal (Proxy @sym) + , _required = False + } + +instance HasRelationLink b => HasRelationLink (Fragment a :> b) where + toRelationLink _ = toRelationLink (Proxy @b) + +instance HasRelationLink b => HasRelationLink (ReqBody' mods cts a :> b) where + toRelationLink _ = toRelationLink (Proxy @b) + +instance HasRelationLink b => HasRelationLink (RemoteHost :> b) where + toRelationLink _ = toRelationLink (Proxy @b) + +instance HasRelationLink b => HasRelationLink (IsSecure :> b) where + toRelationLink _ = toRelationLink (Proxy @b) + +instance HasRelationLink b => HasRelationLink (Vault :> b) where + toRelationLink _ = toRelationLink (Proxy @b) + +instance HasRelationLink b => HasRelationLink (WithNamedContext name subs sub :> b) where + toRelationLink _ = toRelationLink (Proxy @b) + +instance HasRelationLink b => HasRelationLink (WithResource res :> b) where + toRelationLink _ = toRelationLink (Proxy @b) + +instance ReflectMethod m => HasRelationLink (Verb m s cts a) where + toRelationLink _ = RelationLink + { _path = "" + , _params = [] + , _templated = False + , _method = decodeUtf8 $ reflectMethod (Proxy @m) + } + +instance ReflectMethod m => HasRelationLink (NoContentVerb m) where + toRelationLink _ = RelationLink + { _path = "" + , _params = [] + , _templated = False + , _method = decodeUtf8 $ reflectMethod (Proxy @m) + } + +instance ReflectMethod m => HasRelationLink (UVerb m cts as) where + toRelationLink _ = RelationLink + { _path = "" + , _params = [] + , _templated = False + , _method = decodeUtf8 $ reflectMethod (Proxy @m) + } + +instance ReflectMethod m => HasRelationLink (Stream m s f ct a) where + toRelationLink _ = RelationLink + { _path = "" + , _params = [] + , _templated = False + , _method = decodeUtf8 $ reflectMethod (Proxy @m) + } + +instance HasRelationLink b => HasRelationLink (BasicAuth realm userData :> b) where + toRelationLink _ = toRelationLink (Proxy @b) + +instance HasRelationLink b => HasRelationLink (Description sym :> b) where + toRelationLink _ = toRelationLink (Proxy @b) + +instance HasRelationLink b => HasRelationLink (Summary sym :> b) where + toRelationLink _ = toRelationLink (Proxy @b) 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,44 +1,62 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE OverloadedStrings #-} module Servant.Hateoas.Resource ( - -- * Resource - -- ** Construction - ToResource(..) -, ToCollection(..) + -- * ResourceLink + ResourceLink(..), - -- ** Modification -, Resource(..), EmbeddingResource(..), CollectingResource(..) + -- * Resource + -- ** MkResource + MkResource, --- * Hypermedia-Relations --- ** Type -, HRel(..) + -- ** Base Class + Resource(..), + addSelfRel, --- ** Class -, Related(..) + -- ** Specialized classes + EmbeddingResource(..), + CollectingResource(..), --- ** Construction -, BuildRels(..) -, selfLink, relatedLinks, defaultLinks -) -where + -- * Creation + ToResource(..) +) where import Servant +import Servant.Hateoas.RelationLink import Data.Kind import Data.Aeson -import GHC.TypeLits -import GHC.Records +-- | Type family computing the Resource-Type belonging to this Content-Type. +type family MkResource ct :: (Type -> Type) + +-- | Type for Hypermedia-Links. +-- +data ResourceLink = + CompleteLink Link -- ^ A complete 'Link' with all information. + | TemplateLink RelationLink -- ^ A 'RelationLink' that can be used as a template for URIs. + deriving (Show) + +instance ToJSON ResourceLink where + toJSON (CompleteLink l) = let uri = linkURI l in toJSON $ uri { uriPath = "/" <> uriPath uri } + toJSON (TemplateLink l) = toJSON $ l { _path = "/" <> _path l } + -- | 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 + -- | Wrap a value into a 'Resource'. + wrap :: a -> res a + -- | Add a hypermedia relation @(rel, link)@ to a 'Resource'. + addRel :: (String, ResourceLink) -> res a -> res a + +-- | Add the self-relation to a 'Resource'. +addSelfRel :: Resource res => ResourceLink -> res a -> res a +addSelfRel l = addRel ("self", l) + -- | 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 e => (String, e) -> res a -> res a + embed :: ToJSON e => (String, res e) -> res a -> res a -- | Class for 'Resource's that can collect multiple resources. class Resource res => CollectingResource res where @@ -46,89 +64,13 @@ collect :: a -> res a -> res a -- | Class for converting values of @a@ to their respective Resource-Representation. -class ToResource api res a where - -- | Converts a value into it's Resource-Representation. - 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 - , selName :: Symbol -- ^ Record selectors field name - , endpoint :: Type -- ^ Servant-Endpoint to use for retrieving one value for relation @relName@ - } - --- | Types that have Hypermedia-Relations. -class Related a where - -- | Name of the record selector that holds the resources identifier - type IdSelName a :: Symbol - -- | Servant-Endpoint for retrieving one @a@ by its identifier - type GetOneApi a :: Type - -- | Name for collected values - type CollectionName a :: Symbol - type CollectionName a = "items" - -- | List of all relations @a@ has - type Relations a :: [HRel] - --- | Class for deriving Hypermedia-Relations for types. -type BuildRels :: Type -> [HRel] -> Type -> Constraint -class BuildRels api rs a where - buildRels :: Proxy rs -> Proxy api -> a -> [(String, Link)] - -instance BuildRels api '[] a where - buildRels _ _ _ = [] - -instance - ( KnownSymbol relName - , HasField selName a id - , HasLink endpoint - , IsElem endpoint api - , MkLink endpoint Link ~ (id -> Link) - , BuildRels api rs a - ) => BuildRels api (('HRel relName selName endpoint) ': rs) a where - buildRels _ api x = l : buildRels (Proxy @rs) api x - where - mkLink = safeLink api (Proxy @endpoint) - l = (symbolVal (Proxy @relName), mkLink $ getField @selName x) - --- | Generates pairs @(rel, link)@ for all related resources as defined with 'Relations'. -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. -selfLink :: forall api a id. - ( Related a, HasField (IdSelName a) a id - , IsElem (GetOneApi a) api, HasLink (GetOneApi a) - , MkLink (GetOneApi a) Link ~ (id -> Link) - ) => Proxy api -> a -> (String, Link) -selfLink api x = ("self", mkSelf $ getField @(IdSelName a) x) - where - mkSelf = safeLink api (Proxy @(GetOneApi a)) - --- | Generate Hypermedia-Links by default. -- --- @ --- defaultLinks api x = selfLink api x : relatedLinks api x --- @ -defaultLinks :: forall api a id. - ( 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 - ) => Proxy api -> a -> [(String, Link)] -defaultLinks api x = selfLink api x : relatedLinks api x +-- The default implementation wraps the value into a 'Resource' without adding any further information. +-- Therefore you can derive an instance for this class. +class ToResource res a where + -- | Describes how a value @a@ can be converted to a 'Resource'. + toResource :: Proxy res -> a -> res a + default toResource :: Resource res => Proxy res -> a -> res a + toResource _ = wrap + +instance Resource res => ToResource res [a] diff --git a/src/Servant/Hateoas/ResourceServer.hs b/src/Servant/Hateoas/ResourceServer.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Hateoas/ResourceServer.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Servant.Hateoas.ResourceServer +( + -- * Type-Class + HasResourceServer(..), + + -- * Type-Families + Resourcify, + ResourcifyServer +) +where + +import Servant +import Servant.Hateoas.Layer +import Servant.Hateoas.Resource +import Servant.Hateoas.HasHandler +import Servant.Hateoas.Internal.Polyvariadic +import Data.Kind +import Control.Monad.IO.Class + +-- | Turns an API into a resourceful API by replacing the response type of each endpoint with a resource type. +type Resourcify :: k -> Type -> k +type family Resourcify api ct where + Resourcify EmptyAPI ct = EmptyAPI + Resourcify (a :<|> b) ct = Resourcify a ct :<|> Resourcify b ct + Resourcify (a :> b) ct = a :> Resourcify b ct + Resourcify (Verb m s _ a) ct = Verb m s '[ct] (MkResource ct a) + Resourcify ('Layer api cs verb) ct = 'Layer (Resourcify api ct) (Resourcify cs ct) (Resourcify verb ct) + Resourcify (x:xs) ct = Resourcify x ct : Resourcify xs ct + Resourcify a _ = a + +-- | Turns a 'ServerT' into a resourceful 'ServerT' by replacing the result type @m a@ of the function @server@ with @m (res a)@ where +-- @res := 'MkResource' ct@. +-- +-- Together with 'Resourcify' the following 'Constraint' holds: +-- +-- @ +-- forall api ct m. ServerT (Resourcify api) ct m ~ ResourcifyServer (ServerT api m) ct m +-- @ +type ResourcifyServer :: k -> Type -> (Type -> Type) -> Type +type family ResourcifyServer server ct m where + ResourcifyServer EmptyServer ct m = EmptyServer + ResourcifyServer (a :<|> b) ct m = ResourcifyServer a ct m :<|> ResourcifyServer b ct m + ResourcifyServer (a -> b) ct m = a -> ResourcifyServer b ct m + ResourcifyServer (m a) ct m = m (MkResource ct a) + ResourcifyServer (f a) ct m = f (ResourcifyServer a ct m) -- needed for stepping into containers like [Foo] + +-- | A typeclass providing a function to turn an API into a resourceful API. +class HasResourceServer api m ct where + getResourceServer :: MonadIO m => Proxy m -> Proxy ct -> Proxy api -> ServerT (Resourcify api ct) m + +instance {-# OVERLAPPING #-} (HasResourceServer a m ct, HasResourceServer b m ct) => HasResourceServer (a :<|> b) m ct where + getResourceServer m ct _ = getResourceServer m ct (Proxy @a) :<|> getResourceServer m ct (Proxy @b) + +-- | Adds a self-link to the resource. +instance {-# OVERLAPPABLE #-} + ( server ~ ServerT api m + , ServerT (Resourcify api ct) m ~ ResourcifyServer server ct m + , mkLink ~ MkLink api Link + , res ~ MkResource ct + , Resource res + , ToResource res a + , HasHandler api + , HasLink api, IsElem api api + , PolyvariadicComp2 server mkLink (IsFun server) + , Return2 server mkLink (IsFun server) ~ (m a, Link) + , Replace2 server mkLink (m (res a)) (IsFun mkLink) ~ ResourcifyServer server ct m + ) => HasResourceServer (api :: Type) m ct where + getResourceServer m _ api = pcomp2 ((\(ma, self) -> (addSelfRel (CompleteLink self) . toResource (Proxy @res)) <$> ma)) (getHandler m api) mkSelf + where + mkSelf = safeLink api api + +instance + ( api ~ LayerApi l + , rApi ~ Resourcify api ct + , ServerT (Resourcify l ct) m ~ ResourcifyServer (ServerT l m) ct m + , rServer ~ ResourcifyServer (ServerT l m) ct m + , res ~ MkResource ct + , buildFun ~ ReplaceHandler rServer [(String, ResourceLink)] + , Resource res + , BuildLayerLinks (Resourcify l ct) m + , PolyvariadicComp buildFun (IsFun buildFun) + , Return buildFun (IsFun buildFun) ~ [(String, ResourceLink)] + , Replace buildFun (m (res Intermediate)) (IsFun buildFun) ~ rServer + ) => HasResourceServer l m ct where + getResourceServer m _ _ = (return @m . foldr addRel (wrap @res $ Intermediate ())) ... buildLayerLinks (Proxy @(Resourcify l ct)) m + +instance HasResourceServer ('[] :: [Layer]) m ct where + getResourceServer _ _ _ = emptyServer + +instance + ( MonadIO m + , HasResourceServer ls m ct + , HasResourceServer l m ct + , BuildLayerLinks (Resourcify l ct) m + ) => HasResourceServer (l ': ls) m ct where + getResourceServer m ct _ = getResourceServer m ct (Proxy @l) :<|> getResourceServer m ct (Proxy @ls)