servant-hateoas 0.2.2 → 0.3.0

raw patch · 17 files changed

+992/−249 lines, 17 filesdep +singleton-booldep +textPVP ok

version bump matches the API change (PVP)

Dependencies added: singleton-bool, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• README.md +78/−49
• servant-hateoas.cabal +25/−11
• src/Servant/Hateoas.hs +9/−3
• src/Servant/Hateoas/ContentType/Collection.hs +35/−31
• src/Servant/Hateoas/ContentType/HAL.hs +24/−32
• src/Servant/Hateoas/Example.hs +40/−15
• src/Servant/Hateoas/HasHandler.hs +32/−0
• src/Servant/Hateoas/Internal/Polyvariadic.hs +66/−0
• src/Servant/Hateoas/Internal/Sym.hs +39/−0
• src/Servant/Hateoas/Layer.hs +69/−0
• src/Servant/Hateoas/Layer/Build.hs +90/−0
• src/Servant/Hateoas/Layer/Merge.hs +38/−0
• src/Servant/Hateoas/Layer/Type.hs +112/−0
• src/Servant/Hateoas/RelationLink.hs +176/−0
• src/Servant/Hateoas/Resource.hs +50/−108
• src/Servant/Hateoas/ResourceServer.hs +98/−0

@@ -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

@@ -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!

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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 _ _ = '[]

@@ -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

@@ -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'

@@ -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 ()

@@ -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)

@@ -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]

@@ -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)