packages feed

servant-hateoas 0.3.3 → 0.3.4

raw patch · 14 files changed

+510/−217 lines, 14 files

Files

CHANGELOG.md view
@@ -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.4 _(2024-12-30)_++### Added+- Added class `HasTemplateLink` for fully templated links to endpoints+- Added combinator `data Title (sym :: Symbol)` for human-readable titles of resources++### Changed+- Class `HasRelationLink` now returns complete links instead of partially templated ones+- Replaced all usages of `Link` with `RelationLink`, allowing more flexibility when gathering information about the resource the link refers to+- Extended the rendering of `HALResource` by props `type` (Content-Type) and `title`+ ## v0.3.3 _(2024-12-28)_  ### Added
README.md view
@@ -61,18 +61,19 @@  -- 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+  toResource _ ct usr = addRel ("address", mkAddrLink $ addressId usr) $ wrap usr     where-      mkAddrLink = safeLink (Proxy @AddressGetOne) (Proxy @AddressGetOne)+      mkAddrLink = toRelationLink $ resourcifyProxy (Proxy @AddressGetOne) ct ```  Further we define our API as usual: ```haskell 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 UserApi = UserGetOne :<|> UserGetAll :<|> UserGetQuery+type UserGetOne    = "api" :> "user" :> Title "The user with the given id" :> Capture "id" Int :> Get '[JSON] User+type UserGetAll    = "api" :> "user" :> Get '[JSON] [User]+type UserGetQuery  = "api" :> "user" :> "query" :> QueryParam "addrId" Int :> QueryParam "income" Double :> Get '[JSON] User  type AddressApi = AddressGetOne type AddressGetOne = "api" :> "address" :> Capture "id" Int :> Get '[JSON] Address@@ -89,9 +90,11 @@ 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+  getHandler _ _ = \uId -> return $ User uId 0 0 instance HasHandler UserGetAll where   getHandler _ _ = return [User 1 1 1000, User 2 2 2000, User 42 3 3000]+instance HasHandler UserGetQuery where+  getHandler _ _ = \mAddrId mIncome -> return $ User 42 (maybe 0 id mAddrId) (maybe 0 id mIncome) instance HasHandler AddressGetOne where   getHandler _ _ = \aId -> return $ Address aId "Foo St" "BarBaz" ```@@ -103,6 +106,50 @@ ```  For now `apiServer` and `layerServer` exist in isolation, but the goal is to merge them into one.++When we now run the `layerServer` and request `GET http://host:port/api/user/query`, we get:+```json+{+    "_embedded": {},+    "_links": {+        "addrId": {+            "href": "/api/user/query{?addrId}",+            "templated": true,+            "type": "application/hal+json"+        },+        "income": {+            "href": "/api/user/query{?income}",+            "templated": true,+            "type": "application/hal+json"+        },+        "self": {+            "href": "/api/user/query",+            "type": "application/hal+json"+        }+    }+}+```++Similar for `userServer` and `GET http://host:port/api/user/42`:+```json+{+    "_embedded": {},+    "_links": {+        "address": {+            "href": "/api/address/0",+            "type": "application/hal+json"+        },+        "self": {+            "href": "/api/user/42",+            "title": "The user with the given id",+            "type": "application/hal+json"+        }+    },+    "addressId": 0,+    "income": 0,+    "usrId": 42+}+```  The complete example can be found [here](https://github.com/bruderj15/servant-hateoas/blob/main/src/Servant/Hateoas/Example.hs).
servant-hateoas.cabal view
@@ -1,6 +1,6 @@ cabal-version:           3.0 name:                    servant-hateoas-version:                 0.3.3+version:                 0.3.4 synopsis:                HATEOAS extension for servant description:             Create Resource-Representations for your types and make your API HATEOAS-compliant.   Automatically derive a HATEOAS-API and server-implementation from your API or straight up define a HATEOAS-API yourself.@@ -41,6 +41,7 @@                        , Servant.Hateoas.Layer.Build                        , Servant.Hateoas.Layer.Merge                        , Servant.Hateoas.ContentType.HAL+                       , Servant.Hateoas.Combinator.Title                        , Servant.Hateoas.Internal.Sym                        , Servant.Hateoas.Internal.Polyvariadic
src/Servant/Hateoas.hs view
@@ -1,5 +1,6 @@ module Servant.Hateoas-( module Servant.Hateoas.ContentType.HAL+( module Servant.Hateoas.Combinator.Title+, module Servant.Hateoas.ContentType.HAL , module Servant.Hateoas.ResourceServer , module Servant.Hateoas.RelationLink , module Servant.Hateoas.HasHandler@@ -7,6 +8,7 @@ , module Servant.Hateoas.Layer ) where +import Servant.Hateoas.Combinator.Title import Servant.Hateoas.ContentType.HAL (HAL, HALResource) import Servant.Hateoas.ResourceServer import Servant.Hateoas.RelationLink
+ src/Servant/Hateoas/Combinator/Title.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE UndecidableInstances #-}++module Servant.Hateoas.Combinator.Title where++import Servant+import Servant.Hateoas.HasHandler+import Servant.Hateoas.RelationLink+import Servant.Hateoas.Internal.Polyvariadic+import Data.String (fromString)+import Control.Applicative ((<|>))+import GHC.TypeLits++-- | Combinator similar to 'Summary' and 'Description' but for the human readable title of the resource a 'RelationLink' refers to.+data Title (sym :: Symbol)++instance HasLink b => HasLink (Title sym :> b) where+  type MkLink (Title sym :> b) link = MkLink b link+  toLink f _ = toLink f (Proxy @b)++instance HasServer api ctx => HasServer (Title desc :> api) ctx where+  type ServerT (Title desc :> api) m = ServerT api m+  route _ = route (Proxy @api)+  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt s++instance HasHandler api => HasHandler (Title desc :> api) where+  getHandler m _ = getHandler m (Proxy @api)++instance (KnownSymbol title, HasTemplatedLink api) => HasTemplatedLink (Title title :> api) where+  toTemplatedLink _  = (\l -> l { _title = _title l <|> Just title }) $ toTemplatedLink (Proxy @api)+    where+      title = fromString $ symbolVal (Proxy @title)++instance (KnownSymbol title, RightLink api) => HasRelationLink (Title title :> api) where+  toRelationLink _  = (\l -> l { _title = _title l <|> Just title }) ... toRelationLink (Proxy @api)+    where+      title = fromString $ symbolVal (Proxy @title)
src/Servant/Hateoas/ContentType/Collection.hs view
@@ -8,6 +8,7 @@ where  import Servant.Hateoas.Resource+import Servant.Hateoas.RelationLink import Servant.API.ContentTypes import qualified Network.HTTP.Media as M import Servant.Links@@ -28,7 +29,7 @@ data CollectionResource a = CollectionResource   { href  :: Maybe URI                   -- ^ Link to the collection   , items :: [CollectionItem a]          -- ^ All items in the collection-  , rels  :: [(String, ResourceLink)]    -- ^ Pairs @(rel, link)@ for relations+  , rels  :: [(String, RelationLink)]    -- ^ Pairs @(rel, link)@ for relations   } deriving (Show, Generic, Functor)  instance Semigroup (CollectionResource a) where@@ -40,7 +41,7 @@ -- | A single item inside a 'CollectionResource'. data CollectionItem a = CollectionItem   { item :: a                             -- ^ Wrapped item-  , itemLinks :: [(String, ResourceLink)]         -- ^ Links for the wrapped item+  , itemLinks :: [(String, RelationLink)]         -- ^ Links for the wrapped item   } deriving (Show, Generic, Functor)  instance Resource CollectionResource where@@ -57,7 +58,7 @@ instance ToJSON (CollectionResource a) => MimeRender (Collection JSON) (CollectionResource a) where   mimeRender _ = encode -collectionLinks :: [(String, ResourceLink)] -> Value+collectionLinks :: [(String, RelationLink)] -> Value collectionLinks = Array . Foldable.foldl' (\xs (rel, l) -> pure (object ["name" .= rel, "value" .= l]) <> xs) mempty  -- TODO: I dont like this at all
src/Servant/Hateoas/ContentType/HAL.hs view
@@ -19,6 +19,7 @@ import Data.Kind import Data.Aeson import Data.Aeson.KeyMap (singleton)+import qualified Data.Text as Text import GHC.Exts import GHC.Generics @@ -32,7 +33,7 @@ -- | HAL-resource representation. data HALResource a = HALResource   { resource :: a                                       -- ^ Wrapped resource-  , rels     :: [(String, ResourceLink)]                -- ^ Pairs @(rel, link)@ for hypermedia relations+  , rels     :: [(String, RelationLink)]                -- ^ Pairs @(rel, link)@ for hypermedia relations   , embedded :: [(String, SomeF HALResource ToJSON)]    -- ^ Pairs @(rel, resource)@ for embedded resources   } deriving (Generic, Functor) @@ -46,9 +47,12 @@ instance ToJSON (HALResource a) => MimeRender (HAL JSON) (HALResource a) where   mimeRender _ = encode -renderHalLink :: ResourceLink -> Value-renderHalLink (CompleteLink l) = let uri = linkURI l in object ["href" .= uri { uriPath = "/" <> uriPath uri }]-renderHalLink (TemplateLink l) = object $ ["href" .= l {_path  = "/" <> _path l } ] <> if _templated l then ["templated" .= True] else []+renderHalLink :: RelationLink -> Value+renderHalLink l = object $+  [ "href" .= getHref l+  , "type" .= Text.intercalate "|" (fromString . show <$> _contentTypes l)+  ] <> if _templated l then ["templated" .= True] else []+    <> maybe mempty (\t -> ["title" .= t]) (_title l)  instance {-# OVERLAPPABLE #-} ToJSON a => ToJSON (HALResource a) where   toJSON (HALResource res ls es) = Object $ (singleton "_links" ls') <> (singleton "_embedded" es') <> (case toJSON res of Object kvm -> kvm ; _ -> mempty)
src/Servant/Hateoas/Example.hs view
@@ -17,16 +17,16 @@   deriving anyclass (ToJSON, ToResource res)  instance Resource res => ToResource res User where-  toResource _ usr = addRel ("address", CompleteLink $ mkAddrLink $ addressId usr) $ wrap usr+  toResource _ ct usr = addRel ("address", mkAddrLink $ addressId usr) $ wrap usr     where-      mkAddrLink = safeLink (Proxy @AddressGetOne) (Proxy @AddressGetOne)+      mkAddrLink = toRelationLink $ resourcifyProxy (Proxy @AddressGetOne) ct  type Api = UserApi :<|> AddressApi  type UserApi = UserGetOne :<|> UserGetAll :<|> UserGetQuery-type UserGetOne      = "api" :> "user" :> Capture "id" Int :> Get '[JSON] User-type UserGetAll      = "api" :> "user" :> Get '[JSON] [User]-type UserGetQuery  = "api" :> "user" :> "querying" :> QueryParam "addrId" Int :> QueryParam "income" Double :> Get '[JSON] User+type UserGetOne    = "api" :> "user" :> Title "The user with the given id" :> Capture "id" Int :> Get '[JSON] User+type UserGetAll    = "api" :> "user" :> Get '[JSON] [User]+type UserGetQuery  = "api" :> "user" :> "query" :>QueryParam "addrId" Int :> QueryParam "income" Double :> Get '[JSON] User  type AddressApi = AddressGetOne type AddressGetOne = "api" :> "address" :> Capture "id" Int :> Get '[JSON] Address
src/Servant/Hateoas/Internal/Sym.hs view
@@ -25,7 +25,10 @@   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+instance (HasTemplatedLink api, KnownSymbol sym) => HasTemplatedLink (Sym sym :> api) where+  toTemplatedLink _ = toTemplatedLink (Proxy @(sym :> api))++instance (KnownSymbol sym, HasRelationLink (sym :> api), HasLink api) => HasRelationLink (Sym sym :> api) where   toRelationLink _ = toRelationLink (Proxy @(sym :> api))  instance (HasHandler api, KnownSymbol sym) => HasHandler (Sym sym :> api) where
src/Servant/Hateoas/Layer/Build.hs view
@@ -12,7 +12,6 @@  import Servant import Servant.API.ContentTypes-import Servant.Hateoas.Resource import Servant.Hateoas.RelationLink import Servant.Hateoas.Layer.Type import Servant.Hateoas.Internal.Sym@@ -27,179 +26,155 @@   ReplaceHandler (a -> b)    replacement = a -> ReplaceHandler b replacement   ReplaceHandler _           replacement = replacement --- | Create all 'ResourceLink's to a 'Layer's 'RelativeChildren'.+-- | Create all 'RelationLink'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)]+  buildLayerLinks :: MonadIO m => Proxy l -> Proxy m -> ReplaceHandler (ServerT l m) [(String, RelationLink)]  instance   ( api ~ MkPrefix apiCs verb-  , HasLink api, IsElem api api-  , mkSelf ~ MkLink api Link+  , HasRelationLink api+  , mkSelf ~ MkLink api RelationLink   , PolyvariadicComp mkSelf (IsFun mkSelf)-  , Return mkSelf (IsFun mkSelf) ~ Link-  , Replace mkSelf [(String, ResourceLink)] (IsFun mkSelf) ~ ReplaceHandler (ServerT api m) [(String, ResourceLink)]+  , Return mkSelf (IsFun mkSelf) ~ RelationLink+  , Replace mkSelf [(String, RelationLink)] (IsFun mkSelf) ~ ReplaceHandler (ServerT api m) [(String, RelationLink)]   ) => BuildLayerLinks ('Layer apiCs '[] verb) m where-  buildLayerLinks _ _ = (pure @[] . ("self", ) . CompleteLink) ... mkSelf+  buildLayerLinks _ _ = (pure @[] . ("self", )) ... mkSelf     where-      mkSelf = safeLink (Proxy @api) (Proxy @api)+      mkSelf = toRelationLink (Proxy @api)  instance   ( c ~ MkPrefix (apiCs ++ '[Sym sym]) verb-  , HasLink c, IsElem c c-  , mkLink ~ MkLink c Link+  , HasRelationLink c+  , mkLink ~ MkLink c RelationLink   , KnownSymbol sym   , BuildLayerLinks ('Layer apiCs cs verb) m-  , buildLinksFun ~ (ReplaceHandler (ServerT (MkPrefix apiCs verb) m) [(String, ResourceLink)])+  , buildLinksFun ~ (ReplaceHandler (ServerT (MkPrefix apiCs verb) m) [(String, RelationLink)])   , PolyvariadicComp2 mkLink buildLinksFun (IsFun mkLink)-  , Return2 mkLink buildLinksFun (IsFun mkLink) ~ (Link, [(String, ResourceLink)])-  , Replace2 mkLink buildLinksFun [(String, ResourceLink)] (IsFun mkLink) ~ buildLinksFun+  , Return2 mkLink buildLinksFun (IsFun mkLink) ~ (RelationLink, [(String, RelationLink)])+  , Replace2 mkLink buildLinksFun [(String, RelationLink)] (IsFun mkLink) ~ buildLinksFun   ) => BuildLayerLinks ('Layer apiCs (Sym sym ': cs) verb) m where-  buildLayerLinks _ m = pcomp2 (\(l, ls) -> (symbolVal (Proxy @sym), CompleteLink l) : ls) mkLink mkLinks+  buildLayerLinks _ m = pcomp2 (\(l, ls) -> (symbolVal (Proxy @sym), l) : ls) mkLink mkLinks     where-      mkLink = safeLink (Proxy @c) (Proxy @c)+      mkLink = toRelationLink (Proxy @c)       mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m  instance   ( verb ~ Verb method status cts a   , AllMime cts, ReflectMethod method   , api ~ MkPrefix apiCs verb+  , HasRelationLink api   , KnownSymbol sym-  , HasRelationLink (MkPrefix '[Capture' mods sym x] verb)-  , IsElem api api, HasLink api+  , HasTemplatedLink (MkPrefix '[Capture' mods sym x] verb)   , BuildLayerLinks ('Layer apiCs cs verb) m-  , buildLinksFun ~ (ReplaceHandler (ServerT api m) [(String, ResourceLink)])-  , PolyvariadicComp2 (MkLink api Link) buildLinksFun (IsFun buildLinksFun)-  , Return2 (MkLink api Link) buildLinksFun (IsFun buildLinksFun) ~ (Link, [(String, ResourceLink)])-  , Replace2 (MkLink api Link) buildLinksFun [(String, ResourceLink)] (IsFun buildLinksFun) ~ buildLinksFun+  , buildLinksFun ~ (ReplaceHandler (ServerT api m) [(String, RelationLink)])+  , PolyvariadicComp2 (MkLink api RelationLink) buildLinksFun (IsFun buildLinksFun)+  , Return2 (MkLink api RelationLink) buildLinksFun (IsFun buildLinksFun) ~ (RelationLink, [(String, RelationLink)])+  , Replace2 (MkLink api RelationLink) buildLinksFun [(String, RelationLink)] (IsFun buildLinksFun) ~ buildLinksFun   ) => BuildLayerLinks ('Layer apiCs (Capture' mods sym x ': cs) verb) m where-  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, mkTemplatedNext self) : ls) mkSelf mkLinks+  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, self <<< child) : ls) mkSelf mkLinks     where       relName = symbolVal (Proxy @sym)-      mkSelf = safeLink (Proxy @api) (Proxy @api)+      mkSelf = toRelationLink (Proxy @api)       mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m-      child = toRelationLink (Proxy @(MkPrefix '[Capture' mods sym x] verb))-      mkTemplatedNext = TemplateLink-        . (\rl -> rl { _path = _path rl `appendPath` _path child, _templated = True })-        . fromURI (allMime $ Proxy @cts) (reflectStdMethod (Proxy @method))-        . linkURI+      child = toTemplatedLink (Proxy @(MkPrefix '[Capture' mods sym x] verb))  instance   ( verb ~ Verb method status cts a   , AllMime cts, ReflectMethod method   , api ~ MkPrefix apiCs verb+  , HasRelationLink api   , KnownSymbol sym-  , HasRelationLink (MkPrefix '[CaptureAll sym x] verb)-  , IsElem api api, HasLink api+  , HasTemplatedLink (MkPrefix '[CaptureAll sym x] verb)   , BuildLayerLinks ('Layer apiCs cs verb) m-  , buildLinksFun ~ (ReplaceHandler (ServerT api m) [(String, ResourceLink)])-  , PolyvariadicComp2 (MkLink api Link) buildLinksFun (IsFun buildLinksFun)-  , Return2 (MkLink api Link) buildLinksFun (IsFun buildLinksFun) ~ (Link, [(String, ResourceLink)])-  , Replace2 (MkLink api Link) buildLinksFun [(String, ResourceLink)] (IsFun buildLinksFun) ~ buildLinksFun+  , buildLinksFun ~ (ReplaceHandler (ServerT api m) [(String, RelationLink)])+  , PolyvariadicComp2 (MkLink api RelationLink) buildLinksFun (IsFun buildLinksFun)+  , Return2 (MkLink api RelationLink) buildLinksFun (IsFun buildLinksFun) ~ (RelationLink, [(String, RelationLink)])+  , Replace2 (MkLink api RelationLink) buildLinksFun [(String, RelationLink)] (IsFun buildLinksFun) ~ buildLinksFun   ) => BuildLayerLinks ('Layer apiCs (CaptureAll sym x ': cs) verb) m where-  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, mkTemplatedNext self) : ls) mkSelf mkLinks+  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, self <<< child) : ls) mkSelf mkLinks     where       relName = symbolVal (Proxy @sym)-      mkSelf = safeLink (Proxy @api) (Proxy @api)+      mkSelf = toRelationLink (Proxy @api)       mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m-      child = toRelationLink (Proxy @(MkPrefix '[CaptureAll sym x] verb))-      mkTemplatedNext = TemplateLink-        . (\rl -> rl { _path = _path rl `appendPath` _path child, _templated = True })-        . fromURI (allMime $ Proxy @cts) (reflectStdMethod (Proxy @method))-        . linkURI+      child = toTemplatedLink (Proxy @(MkPrefix '[CaptureAll sym x] verb))  instance   ( verb ~ Verb method status cts a   , AllMime cts, ReflectMethod method   , api ~ MkPrefix apiCs verb+  , HasRelationLink api   , KnownSymbol sym-  , HasRelationLink (MkPrefix '[QueryParam' mods sym x] verb)-  , IsElem api api, HasLink api+  , HasTemplatedLink (MkPrefix '[QueryParam' mods sym x] verb)   , BuildLayerLinks ('Layer apiCs cs verb) m-  , buildLinksFun ~ (ReplaceHandler (ServerT api m) [(String, ResourceLink)])-  , PolyvariadicComp2 (MkLink api Link) buildLinksFun (IsFun buildLinksFun)-  , Return2 (MkLink api Link) buildLinksFun (IsFun buildLinksFun) ~ (Link, [(String, ResourceLink)])-  , Replace2 (MkLink api Link) buildLinksFun [(String, ResourceLink)] (IsFun buildLinksFun) ~ buildLinksFun+  , buildLinksFun ~ (ReplaceHandler (ServerT api m) [(String, RelationLink)])+  , PolyvariadicComp2 (MkLink api RelationLink) buildLinksFun (IsFun buildLinksFun)+  , Return2 (MkLink api RelationLink) buildLinksFun (IsFun buildLinksFun) ~ (RelationLink, [(String, RelationLink)])+  , Replace2 (MkLink api RelationLink) buildLinksFun [(String, RelationLink)] (IsFun buildLinksFun) ~ buildLinksFun   ) => BuildLayerLinks ('Layer apiCs (QueryParam' mods sym x ': cs) verb) m where-  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, mkTemplatedNext self) : ls) mkSelf mkLinks+  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, self <<< child) : ls) mkSelf mkLinks     where       relName = symbolVal (Proxy @sym)-      mkSelf = safeLink (Proxy @api) (Proxy @api)+      mkSelf = toRelationLink (Proxy @api)       mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m-      child = toRelationLink (Proxy @(MkPrefix '[QueryParam' mods sym x] verb))-      mkTemplatedNext = TemplateLink-        . (\rl -> rl { _params = _params rl ++ _params child, _templated = True })-        . fromURI (allMime $ Proxy @cts) (reflectStdMethod (Proxy @method))-        . linkURI+      child = toTemplatedLink (Proxy @(MkPrefix '[QueryParam' mods sym x] verb))  instance   ( verb ~ Verb method status cts a   , AllMime cts, ReflectMethod method   , api ~ MkPrefix apiCs verb+  , HasRelationLink api   , KnownSymbol sym-  , HasRelationLink (MkPrefix '[QueryParams sym x] verb)-  , IsElem api api, HasLink api+  , HasTemplatedLink (MkPrefix '[QueryParams sym x] verb)   , BuildLayerLinks ('Layer apiCs cs verb) m-  , buildLinksFun ~ (ReplaceHandler (ServerT api m) [(String, ResourceLink)])-  , PolyvariadicComp2 (MkLink api Link) buildLinksFun (IsFun buildLinksFun)-  , Return2 (MkLink api Link) buildLinksFun (IsFun buildLinksFun) ~ (Link, [(String, ResourceLink)])-  , Replace2 (MkLink api Link) buildLinksFun [(String, ResourceLink)] (IsFun buildLinksFun) ~ buildLinksFun+  , buildLinksFun ~ (ReplaceHandler (ServerT api m) [(String, RelationLink)])+  , PolyvariadicComp2 (MkLink api RelationLink) buildLinksFun (IsFun buildLinksFun)+  , Return2 (MkLink api RelationLink) buildLinksFun (IsFun buildLinksFun) ~ (RelationLink, [(String, RelationLink)])+  , Replace2 (MkLink api RelationLink) buildLinksFun [(String, RelationLink)] (IsFun buildLinksFun) ~ buildLinksFun   ) => BuildLayerLinks ('Layer apiCs (QueryParams sym x ': cs) verb) m where-  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, mkTemplatedNext self) : ls) mkSelf mkLinks+  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, self <<< child) : ls) mkSelf mkLinks     where       relName = symbolVal (Proxy @sym)-      mkSelf = safeLink (Proxy @api) (Proxy @api)+      mkSelf = toRelationLink (Proxy @api)       mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m-      child = toRelationLink (Proxy @(MkPrefix '[QueryParams sym x] verb))-      mkTemplatedNext = TemplateLink-        . (\rl -> rl { _params = _params rl ++ _params child, _templated = True })-        . fromURI (allMime $ Proxy @cts) (reflectStdMethod (Proxy @method))-        . linkURI+      child = toTemplatedLink (Proxy @(MkPrefix '[QueryParams sym x] verb))  instance   ( verb ~ Verb method status cts a   , AllMime cts, ReflectMethod method   , api ~ MkPrefix apiCs verb+  , HasRelationLink api   , KnownSymbol sym-  , HasRelationLink (MkPrefix '[DeepQuery sym x] verb)-  , IsElem api api, HasLink api+  , HasTemplatedLink (MkPrefix '[DeepQuery sym x] verb)   , BuildLayerLinks ('Layer apiCs cs verb) m-  , buildLinksFun ~ (ReplaceHandler (ServerT api m) [(String, ResourceLink)])-  , PolyvariadicComp2 (MkLink api Link) buildLinksFun (IsFun buildLinksFun)-  , Return2 (MkLink api Link) buildLinksFun (IsFun buildLinksFun) ~ (Link, [(String, ResourceLink)])-  , Replace2 (MkLink api Link) buildLinksFun [(String, ResourceLink)] (IsFun buildLinksFun) ~ buildLinksFun+  , buildLinksFun ~ (ReplaceHandler (ServerT api m) [(String, RelationLink)])+  , PolyvariadicComp2 (MkLink api RelationLink) buildLinksFun (IsFun buildLinksFun)+  , Return2 (MkLink api RelationLink) buildLinksFun (IsFun buildLinksFun) ~ (RelationLink, [(String, RelationLink)])+  , Replace2 (MkLink api RelationLink) buildLinksFun [(String, RelationLink)] (IsFun buildLinksFun) ~ buildLinksFun   ) => BuildLayerLinks ('Layer apiCs (DeepQuery sym x ': cs) verb) m where-  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, mkTemplatedNext self) : ls) mkSelf mkLinks+  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, self <<< child) : ls) mkSelf mkLinks     where       relName = symbolVal (Proxy @sym)-      mkSelf = safeLink (Proxy @api) (Proxy @api)+      mkSelf = toRelationLink (Proxy @api)       mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m-      child = toRelationLink (Proxy @(MkPrefix '[DeepQuery sym x] verb))-      mkTemplatedNext = TemplateLink-        . (\rl -> rl { _params = _params rl ++ _params child, _templated = True })-        . fromURI (allMime $ Proxy @cts) (reflectStdMethod (Proxy @method))-        . linkURI+      child = toTemplatedLink (Proxy @(MkPrefix '[DeepQuery sym x] verb))  instance   ( verb ~ Verb method status cts a   , AllMime cts, ReflectMethod method   , api ~ MkPrefix apiCs verb+  , HasRelationLink api   , KnownSymbol sym-  , HasRelationLink (MkPrefix '[QueryFlag sym] verb)-  , IsElem api api, HasLink api+  , HasTemplatedLink (MkPrefix '[QueryFlag sym] verb)   , BuildLayerLinks ('Layer apiCs cs verb) m-  , buildLinksFun ~ (ReplaceHandler (ServerT api m) [(String, ResourceLink)])-  , PolyvariadicComp2 (MkLink api Link) buildLinksFun (IsFun buildLinksFun)-  , Return2 (MkLink api Link) buildLinksFun (IsFun buildLinksFun) ~ (Link, [(String, ResourceLink)])-  , Replace2 (MkLink api Link) buildLinksFun [(String, ResourceLink)] (IsFun buildLinksFun) ~ buildLinksFun+  , buildLinksFun ~ (ReplaceHandler (ServerT api m) [(String, RelationLink)])+  , PolyvariadicComp2 (MkLink api RelationLink) buildLinksFun (IsFun buildLinksFun)+  , Return2 (MkLink api RelationLink) buildLinksFun (IsFun buildLinksFun) ~ (RelationLink, [(String, RelationLink)])+  , Replace2 (MkLink api RelationLink) buildLinksFun [(String, RelationLink)] (IsFun buildLinksFun) ~ buildLinksFun   ) => BuildLayerLinks ('Layer apiCs (QueryFlag sym ': cs) verb) m where-  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, mkTemplatedNext self) : ls) mkSelf mkLinks+  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, self <<< child) : ls) mkSelf mkLinks     where       relName = symbolVal (Proxy @sym)-      mkSelf = safeLink (Proxy @api) (Proxy @api)+      mkSelf = toRelationLink (Proxy @api)       mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m-      child = toRelationLink (Proxy @(MkPrefix '[QueryFlag sym] verb))-      mkTemplatedNext = TemplateLink-        . (\rl -> rl { _params = _params rl ++ _params child, _templated = True })-        . fromURI (allMime $ Proxy @cts) (reflectStdMethod (Proxy @method))-        . linkURI+      child = toTemplatedLink (Proxy @(MkPrefix '[QueryFlag sym] verb))
src/Servant/Hateoas/Layer/Type.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveAnyClass #-}  module Servant.Hateoas.Layer.Type (@@ -105,8 +106,6 @@ -- | A response type for a 'Layer' that does not contain any data. newtype Intermediate = Intermediate ()   deriving newtype (Show, Eq, Ord, ToJSON)+  deriving anyclass (ToResource res)  type GetIntermediate = Get '[] Intermediate--instance Resource res => ToResource res Intermediate where-  toResource _ _ = wrap $ Intermediate ()
src/Servant/Hateoas/RelationLink.hs view
@@ -10,14 +10,24 @@   RelationParam(..),    -- *** Creation+  fromLink,   fromURI,    -- *** Operations+  (<<<),+  getHref,+  getPath,+  getParams,+  prependSeg,+  prependSegs,+  addParam,+  addParams,   mkPlaceHolder,-  appendPath,    -- ** Class+  HasTemplatedLink(..),   HasRelationLink(..),+  RightLink,    -- * Utility   -- ** ReflectStdMethod@@ -25,59 +35,131 @@ ) where -import Prelude hiding (dropWhile, break)+import Prelude hiding (drop, dropWhile, break) import Servant import Servant.API.ContentTypes (AllMime(..)) import Servant.API.Modifiers (FoldRequired)-import Network.URI (unEscapeString)+import Servant.Hateoas.Internal.Polyvariadic+import Network.URI (unEscapeString, pathSegments) import Network.HTTP.Media (MediaType) import Network.HTTP.Types (parseMethod, Method)+import Data.Foldable (foldl')+import Data.Maybe import Data.String (fromString) import Data.Aeson-import Data.Text (Text, intercalate, dropWhile, split, break)+import Data.Text (Text, intercalate, dropWhile, split, break, drop, isPrefixOf, isSuffixOf) import Data.Singletons.Bool+import Control.Applicative ((<|>)) import GHC.TypeLits  -- | Link data-type for hypermedia-links in HATEOAS with potentially templated URIs. data RelationLink = RelationLink-  { _path         :: Text+  { _segs         :: [Text]   , _params       :: [RelationParam]+  , _fragment     :: Maybe Text   , _templated    :: Bool   , _method       :: StdMethod   , _contentTypes :: [MediaType]   , _summary      :: Maybe Text   , _description  :: Maybe Text+  , _title        :: Maybe Text   } deriving (Show, Eq)  -- | Parameter data-type for hypermedia-links in HATEOAS. data RelationParam = RelationParam   { _name        :: Text   , _required    :: Bool+  , _value       :: Maybe Text   } deriving (Show, Eq) --- | Create a placeholder for a URI template parameter.+-- | Shifting append-operator for 'RelationLink'.+--+-- This operator can be seen as a monoidal append for 'RelationLink' with a right-bias for meta information+-- e.g. '_method', '_contentTypes', '_summary' and '_description'.+(<<<) :: RelationLink -> RelationLink -> RelationLink+l1 <<< l2 =+  l1 { _segs         = _segs         l1  <> _segs        l2+     , _params       = _params       l1  <> _params      l2+     , _fragment     = _fragment     l1 <|> _fragment    l2+     , _templated    = _templated    l1  || _templated   l2+     , _method       = _method       l2+     , _contentTypes = _contentTypes l2+     , _summary      = _summary      l2 <|> _summary     l1+     , _description  = _description  l2 <|> _description l1+     }++-- | Get the hypermedia-reference of a 'RelationLink'.+getHref :: RelationLink -> Text+getHref l = getPath l <> getParams l <> maybe "" (\f -> "#" <> f) (_fragment l)++-- | Get the path of a 'RelationLink' as in 'getHref'.+getPath :: RelationLink -> Text+getPath = ("/" <>) .  intercalate "/" . _segs++-- | Get the parameters of a 'RelationLink' as in 'getHref'.+getParams :: RelationLink -> Text+getParams link =+     (if filledParams == [] then "" else "?" <> intercalate "&" (fmap (\(k,v) -> k <> "=" <> v) filledParams))+  <> (if templatedParams == [] then "" else "{?" <> intercalate "," templatedParams <> "}")+  where+    (filledParams, templatedParams) =+      foldl'+        (\(fs, ts) l -> case _value l of Nothing -> (fs, _name l : ts) ; Just v -> ((_name l, v) : fs, ts))+        ([], []) $+        _params link++-- | Prepend a path segment to a 'RelationLink'.+--+-- Takes care of potential templating.+prependSeg :: Text -> RelationLink -> RelationLink+prependSeg seg l+  | "{" `isPrefixOf` seg && "}" `isSuffixOf` seg = l { _segs = seg : _segs l, _templated = True }+  | otherwise = l { _segs = seg : _segs l }++-- | Prepend path segments to a 'RelationLink'.+--+-- Takes care of potential templating.+prependSegs :: [Text] -> RelationLink -> RelationLink+prependSegs segs l+  | any (\seg -> "{" `isPrefixOf` seg && "}" `isSuffixOf` seg) segs = l { _segs = segs <> _segs l, _templated = True }+  | otherwise                                                       = l { _segs = segs <> _segs l }++-- | Add a parameter to a 'RelationLink'.+--+-- Takes care of potential templating.+addParam :: RelationParam -> RelationLink -> RelationLink+addParam p l = l { _params = p : _params l, _templated = _templated l || isNothing (_value p) }++-- | Add parameters to a 'RelationLink'.+--+-- Takes care of potential templating.+addParams :: [RelationParam] -> RelationLink -> RelationLink+addParams ps l = l { _params = ps <> _params l, _templated = _templated l || any (isNothing . _value) ps }++-- | Create a placeholder for a template path segment. mkPlaceHolder :: Text -> Text mkPlaceHolder s = "{" <> s <> "}" --- | Append a path to a URI.-appendPath :: Text -> Text -> Text-appendPath l "" = l-appendPath l r = l <> "/" <> r+-- | Creates a 'RelationLink' from a 'Link'.+fromLink :: [MediaType] -> StdMethod -> Link -> RelationLink+fromLink cts m = fromURI cts m . linkURI  -- | Creates a 'RelationLink' from an 'URI'. fromURI :: [MediaType] -> StdMethod -> URI -> RelationLink-fromURI cts m (URI _ _ path query _) = RelationLink-  { _path = fromString path+fromURI cts m uri@(URI _ _ _ query frag) = RelationLink+  { _segs = fromString <$> pathSegments uri   , _params = params+  , _fragment = if frag == "" then Nothing else Just (fromString frag)   , _templated = False   , _method = m   , _contentTypes = cts   , _summary = Nothing   , _description = Nothing+  , _title = Nothing   }   where     params = filter ((/= "") . _name)-      $ fmap (\kv -> RelationParam (fst $ break (== '=') kv) False)+      $ fmap (\kv -> let (k, drop 1 -> v) = break (== '=') kv in RelationParam k False $ if v == "" then Nothing else Just v)       $ split (== '&')       $ dropWhile (== '?')       $ fromString@@ -92,148 +174,287 @@ unsafeMethodToStdMethod (parseMethod -> Left  m) = error $ "Cannot convert " <> show m <> " to StdMethod"  instance ToJSON RelationLink where-  toJSON (RelationLink path params templated _ _ _ _) = String $-    if not (null params) && templated-    then path <> "{?" <> intercalate "," (_name <$> params) <> "}"-    else path+  toJSON = String . getHref --- | Class for creating a 'RelationLink' to an API.-class HasRelationLink endpoint where-  toRelationLink :: Proxy endpoint -> RelationLink+-- | Class for creating a templated 'RelationLink' to an endpoint.+class HasTemplatedLink endpoint where+  toTemplatedLink :: Proxy endpoint -> RelationLink -instance HasRelationLink b => HasRelationLink (EmptyAPI :> b) where-  toRelationLink _ = toRelationLink (Proxy @b)+instance HasTemplatedLink b => HasTemplatedLink (EmptyAPI :> b) where+  toTemplatedLink _ = toTemplatedLink (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 }+instance (KnownSymbol sym, HasTemplatedLink b) => HasTemplatedLink ((sym :: Symbol) :> b) where+  toTemplatedLink _ = prependSeg prefix $ toTemplatedLink (Proxy @b)     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, _templated = True }+instance (KnownSymbol sym, HasTemplatedLink b) => HasTemplatedLink (Capture' mods sym a :> b) where+  toTemplatedLink _ = prependSeg prefix $ toTemplatedLink (Proxy @b)     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, _templated = True }+instance (KnownSymbol sym, HasTemplatedLink b) => HasTemplatedLink (CaptureAll sym a :> b) where+  toTemplatedLink _ = prependSeg prefix $ toTemplatedLink (Proxy @b)     where       prefix = mkPlaceHolder $ fromString $ symbolVal (Proxy @sym) -instance HasRelationLink b => HasRelationLink (Header' mods sym a :> b) where-  toRelationLink _ = toRelationLink (Proxy @b)+instance HasTemplatedLink b => HasTemplatedLink (Header' mods sym a :> b) where+  toTemplatedLink _ = toTemplatedLink (Proxy @b) -instance HasRelationLink b => HasRelationLink (HttpVersion :> b) where-  toRelationLink _ = toRelationLink (Proxy @b)+instance HasTemplatedLink b => HasTemplatedLink (HttpVersion :> b) where+  toTemplatedLink _ = toTemplatedLink (Proxy @b) -instance (HasRelationLink b, KnownSymbol sym, SBoolI (FoldRequired mods)) => HasRelationLink (QueryParam' mods sym a :> b) where-  toRelationLink _ = let rl = toRelationLink (Proxy @b) in rl { _params = param : _params rl, _templated = True }+instance (HasTemplatedLink b, KnownSymbol sym, SBoolI (FoldRequired mods)) => HasTemplatedLink (QueryParam' mods sym a :> b) where+  toTemplatedLink _ = let rl = toTemplatedLink (Proxy @b) in rl { _params = param : _params rl, _templated = True }     where       param = RelationParam         { _name = fromString $ symbolVal (Proxy @sym)         , _required = fromSBool $ sbool @(FoldRequired mods)+        , _value = Nothing         } -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 }+instance (HasTemplatedLink b, KnownSymbol sym) => HasTemplatedLink (QueryParams sym a :> b) where+  toTemplatedLink _ = let rl = toTemplatedLink (Proxy @b) in rl { _params = param : _params rl, _templated = True }     where       param = RelationParam         { _name = fromString $ symbolVal (Proxy @sym)         , _required = False+        , _value = Nothing         } -instance (HasRelationLink b, KnownSymbol sym) => HasRelationLink (QueryFlag sym :> b) where-  toRelationLink _ = let rl = toRelationLink (Proxy @b) in rl { _params = param : _params rl, _templated = True }+instance (HasTemplatedLink b, KnownSymbol sym) => HasTemplatedLink (QueryFlag sym :> b) where+  toTemplatedLink _ = let rl = toTemplatedLink (Proxy @b) in rl { _params = param : _params rl, _templated = True }     where       param = RelationParam         { _name = fromString $ symbolVal (Proxy @sym)         , _required = False+        , _value = Nothing         } -instance HasRelationLink b => HasRelationLink (QueryString :> b) where-  toRelationLink _ = toRelationLink (Proxy @b)+instance HasTemplatedLink b => HasTemplatedLink (QueryString :> b) where+  toTemplatedLink _ = toTemplatedLink (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 }+instance (HasTemplatedLink b, KnownSymbol sym) => HasTemplatedLink (DeepQuery sym a :> b) where+  toTemplatedLink _ = let rl = toTemplatedLink (Proxy @b) in rl { _params = param : _params rl, _templated = True }     where       param = RelationParam         { _name = fromString $ symbolVal (Proxy @sym)         , _required = False+        , _value = Nothing         } -instance HasRelationLink b => HasRelationLink (Fragment a :> b) where-  toRelationLink _ = toRelationLink (Proxy @b)+instance HasTemplatedLink b => HasTemplatedLink (Fragment a :> b) where+  toTemplatedLink _ = toTemplatedLink (Proxy @b) -instance HasRelationLink b => HasRelationLink (ReqBody' mods cts a :> b) where-  toRelationLink _ = toRelationLink (Proxy @b)+instance HasTemplatedLink b => HasTemplatedLink (ReqBody' mods cts a :> b) where+  toTemplatedLink _ = toTemplatedLink (Proxy @b) -instance HasRelationLink b => HasRelationLink (RemoteHost :> b) where-  toRelationLink _ = toRelationLink (Proxy @b)+instance HasTemplatedLink b => HasTemplatedLink (RemoteHost :> b) where+  toTemplatedLink _ = toTemplatedLink (Proxy @b) -instance HasRelationLink b => HasRelationLink (IsSecure :> b) where-  toRelationLink _ = toRelationLink (Proxy @b)+instance HasTemplatedLink b => HasTemplatedLink (IsSecure :> b) where+  toTemplatedLink _ = toTemplatedLink (Proxy @b) -instance HasRelationLink b => HasRelationLink (Vault :> b) where-  toRelationLink _ = toRelationLink (Proxy @b)+instance HasTemplatedLink b => HasTemplatedLink (Vault :> b) where+  toTemplatedLink _ = toTemplatedLink (Proxy @b) -instance HasRelationLink b => HasRelationLink (WithNamedContext name subs sub :> b) where-  toRelationLink _ = toRelationLink (Proxy @b)+instance HasTemplatedLink b => HasTemplatedLink (WithNamedContext name subs sub :> b) where+  toTemplatedLink _ = toTemplatedLink (Proxy @b) -instance HasRelationLink b => HasRelationLink (WithResource res :> b) where-  toRelationLink _ = toRelationLink (Proxy @b)+instance HasTemplatedLink b => HasTemplatedLink (WithResource res :> b) where+  toTemplatedLink _ = toTemplatedLink (Proxy @b) -instance (ReflectMethod m, AllMime cts) => HasRelationLink (Verb m s cts a) where-  toRelationLink _ = RelationLink-    { _path = mempty+instance (ReflectMethod m, AllMime cts) => HasTemplatedLink (Verb m s cts a) where+  toTemplatedLink _ = RelationLink+    { _segs = mempty     , _params = []+    , _fragment = Nothing     , _templated = False+    , _contentTypes = allMime (Proxy @cts)     , _method = reflectStdMethod (Proxy @m)     , _summary = Nothing     , _description = Nothing+    , _title = Nothing+    }++instance ReflectMethod m => HasTemplatedLink (NoContentVerb m) where+  toTemplatedLink _ = RelationLink+    { _segs = mempty+    , _params = []+    , _fragment = Nothing+    , _templated = False+    , _contentTypes = mempty+    , _method = reflectStdMethod (Proxy @m)+    , _summary = Nothing+    , _description = Nothing+    , _title = Nothing+    }++instance (ReflectMethod m, AllMime cts) => HasTemplatedLink (UVerb m cts as) where+  toTemplatedLink _ = RelationLink+    { _segs = mempty+    , _params = []+    , _fragment = Nothing+    , _templated = False     , _contentTypes = allMime (Proxy @cts)+    , _method = reflectStdMethod (Proxy @m)+    , _summary = Nothing+    , _description = Nothing+    , _title = Nothing     } -instance ReflectMethod m => HasRelationLink (NoContentVerb m) where-  toRelationLink _ = RelationLink-    { _path = mempty+instance (ReflectMethod m, Accept ct) => HasTemplatedLink (Stream m s f ct a) where+  toTemplatedLink _ = RelationLink+    { _segs = mempty     , _params = []+    , _fragment = Nothing     , _templated = False+    , _contentTypes = pure $ contentType (Proxy @ct)     , _method = reflectStdMethod (Proxy @m)     , _summary = Nothing     , _description = Nothing-    , _contentTypes = mempty+    , _title = Nothing     } -instance (ReflectMethod m, AllMime cts) => HasRelationLink (UVerb m cts as) where+instance HasTemplatedLink b => HasTemplatedLink (BasicAuth realm userData :> b) where+  toTemplatedLink _ = toTemplatedLink (Proxy @b)++instance (KnownSymbol sym, HasTemplatedLink b) => HasTemplatedLink (Description sym :> b) where+  toTemplatedLink _ = let rl = toTemplatedLink (Proxy @b) in rl { _description = _description rl <|> Just descr }+    where+      descr = fromString $ symbolVal (Proxy @sym)++instance (KnownSymbol sym, HasTemplatedLink b) => HasTemplatedLink (Summary sym :> b) where+  toTemplatedLink _ = let rl = toTemplatedLink (Proxy @b) in rl { _summary = _summary rl <|> Just summary }+    where+      summary = fromString $ symbolVal (Proxy @sym)++-- | Class for creating a 'RelationLink' to an endpoint.+--+-- This is highly similar to 'HasLink' but it also gathers HATEOAS meta-information for the resource a link refers to.+class HasLink endpoint => HasRelationLink endpoint where+  toRelationLink :: Proxy endpoint -> MkLink endpoint RelationLink++-- | Convenience alias-constraint for right-hand sides of @a ':>' b@ where b is some function producing a 'RelationLink'.+type RightLink b =+  ( HasRelationLink b+  , PolyvariadicComp (MkLink b RelationLink) (IsFun (MkLink b RelationLink))+  , Return (MkLink b RelationLink) (IsFun (MkLink b RelationLink)) ~ RelationLink+  , Replace (MkLink b RelationLink) RelationLink (IsFun (MkLink b RelationLink)) ~ MkLink b RelationLink+  )++instance (AllMime cts, ReflectMethod m) => HasRelationLink (Verb m s cts a) where   toRelationLink _ = RelationLink-    { _path = mempty+    { _segs = mempty     , _params = []+    , _fragment = Nothing     , _templated = False+    , _contentTypes = allMime (Proxy @cts)     , _method = reflectStdMethod (Proxy @m)     , _summary = Nothing     , _description = Nothing+    , _title = Nothing+    }++instance (AllMime cts, ReflectMethod m) => HasRelationLink (UVerb m cts as) where+  toRelationLink _ = RelationLink+    { _segs = mempty+    , _params = []+    , _fragment = Nothing+    , _templated = False     , _contentTypes = allMime (Proxy @cts)+    , _method = reflectStdMethod (Proxy @m)+    , _summary = Nothing+    , _description = Nothing+    , _title = Nothing     } -instance (ReflectMethod m, Accept ct) => HasRelationLink (Stream m s f ct a) where+instance ReflectMethod m => HasRelationLink (NoContentVerb m) where   toRelationLink _ = RelationLink-    { _path = mempty+    { _segs = mempty     , _params = []+    , _fragment = Nothing     , _templated = False+    , _contentTypes = mempty     , _method = reflectStdMethod (Proxy @m)     , _summary = Nothing     , _description = Nothing+    , _title = Nothing+    }++instance (ReflectMethod m, Accept ct) => HasRelationLink (Stream m s f ct a) where+  toRelationLink _ = RelationLink+    { _segs = mempty+    , _params = []+    , _fragment = Nothing+    , _templated = False     , _contentTypes = pure $ contentType (Proxy @ct)+    , _method = reflectStdMethod (Proxy @m)+    , _summary = Nothing+    , _description = Nothing+    , _title = Nothing     } +instance (KnownSymbol sym, RightLink b) => HasRelationLink ((sym :: Symbol) :> b) where+  toRelationLink _ = prependSeg seg ... toRelationLink (Proxy @b)+    where+      seg = fromString $ symbolVal (Proxy @sym)++instance (KnownSymbol sym, RightLink b) => HasRelationLink (Summary sym :> b) where+  toRelationLink _ = (\rl -> rl { _summary = _summary rl <|> Just summary }) ... toRelationLink (Proxy @b)+    where+      summary = fromString $ symbolVal (Proxy @sym)++instance (KnownSymbol sym, RightLink b) => HasRelationLink (Description sym :> b) where+  toRelationLink _ = (\rl -> rl { _description = _description rl <|> Just descr }) ... toRelationLink (Proxy @b)+    where+      descr = fromString $ symbolVal (Proxy @sym)++instance HasRelationLink b => HasRelationLink (HttpVersion :> b) where+  toRelationLink _ = toRelationLink (Proxy @b)+ instance HasRelationLink b => HasRelationLink (BasicAuth realm userData :> b) where   toRelationLink _ = toRelationLink (Proxy @b) -instance (KnownSymbol sym, HasRelationLink b) => HasRelationLink (Description sym :> b) where-  toRelationLink _ = let rl = toRelationLink (Proxy @b) in rl { _description = Just descr }+instance (KnownSymbol sym, RightLink b, ToHttpApiData a) => HasRelationLink (Capture' mods sym a :> b) where+  toRelationLink _ x = prependSeg (toUrlPiece x) ... toRelationLink (Proxy @b)++instance (KnownSymbol sym, RightLink b, ToHttpApiData a) => HasRelationLink (CaptureAll sym a :> b) where+  toRelationLink _ xs = prependSegs (toUrlPiece <$> xs) ... toRelationLink (Proxy @b)++instance (RightLink b, ToHttpApiData a) => HasRelationLink (Fragment a :> b) where+  toRelationLink _ x = (\l -> l { _fragment = Just $ toQueryParam x }) ... toRelationLink (Proxy @b)++instance HasRelationLink b => HasRelationLink (Header' mods sym a :> b) where+  toRelationLink _ = toRelationLink (Proxy @b)++instance HasRelationLink b => HasRelationLink (IsSecure :> b) where+  toRelationLink _ = toRelationLink (Proxy @b)++instance (KnownSymbol sym, RightLink b) => HasRelationLink (QueryFlag sym :> b) where+  toRelationLink _ False = addParam (RelationParam (fromString $ symbolVal $ Proxy @sym) False (Just "false")) ... toRelationLink (Proxy @b)+  toRelationLink _ True  = addParam (RelationParam (fromString $ symbolVal $ Proxy @sym) False (Just "true")) ... toRelationLink (Proxy @b)++instance (KnownSymbol sym, ToHttpApiData a, RightLink b, SBoolI (FoldRequired mods)) => HasRelationLink (QueryParam' mods sym a :> b) where+  toRelationLink _ mv = addParam param ... toRelationLink (Proxy @b)     where-      descr = fromString $ symbolVal (Proxy @sym)+      param = case sbool :: SBool (FoldRequired mods) of+        STrue  -> RelationParam (fromString $ symbolVal $ Proxy @sym) True    (Just $ toQueryParam mv)+        SFalse -> RelationParam (fromString $ symbolVal $ Proxy @sym) False $ toQueryParam <$> mv -instance (KnownSymbol sym, HasRelationLink b) => HasRelationLink (Summary sym :> b) where-  toRelationLink _ = let rl = toRelationLink (Proxy @b) in rl { _summary = Just summary }+instance (KnownSymbol sym, RightLink b, ToHttpApiData a) => HasRelationLink (QueryParams sym a :> b) where+  toRelationLink _ xs = addParams params ... toRelationLink (Proxy @b)     where-      summary = fromString $ symbolVal (Proxy @sym)+      params = (\x -> RelationParam (fromString $ symbolVal $ Proxy @sym) False (Just $ toQueryParam x)) <$> xs++instance RightLink b => HasRelationLink (RemoteHost :> b) where+  toRelationLink _ = toRelationLink (Proxy @b)++instance RightLink b => HasRelationLink (ReqBody' mods cts a :> b) where+  toRelationLink _ = toRelationLink (Proxy @b)++instance RightLink b => HasRelationLink (WithResource res :> b) where+  toRelationLink _ = toRelationLink (Proxy @b)++instance RightLink b => HasRelationLink (Vault :> b) where+  toRelationLink _ = toRelationLink (Proxy @b)
src/Servant/Hateoas/Resource.hs view
@@ -3,9 +3,6 @@  module Servant.Hateoas.Resource (-  -- * ResourceLink-  ResourceLink(..),-   -- * Resource   -- ** MkResource   MkResource,@@ -30,27 +27,16 @@ -- | 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   -- | 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+  addRel :: (String, RelationLink) -> res a -> res a  -- | Add the self-relation to a 'Resource'.-addSelfRel :: Resource res => ResourceLink -> res a -> res a+addSelfRel :: Resource res => RelationLink -> res a -> res a addSelfRel l = addRel ("self", l)  -- | Class for 'Resource's that can embed other resources.@@ -69,8 +55,8 @@ -- 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+  toResource :: (res ~ MkResource ct, Accept ct) => Proxy res -> Proxy ct -> a -> res a+  default toResource :: (res ~ MkResource ct, Resource res) => Proxy res -> Proxy ct -> a -> res a+  toResource _ _ = wrap  instance Resource res => ToResource res [a]
src/Servant/Hateoas/ResourceServer.hs view
@@ -7,6 +7,7 @@    -- * Type-Families   Resourcify,+  resourcifyProxy,   ResourcifyServer ) where@@ -15,6 +16,7 @@ import Servant.Hateoas.Layer import Servant.Hateoas.Resource import Servant.Hateoas.HasHandler+import Servant.Hateoas.RelationLink import Servant.Hateoas.Internal.Polyvariadic import Data.Kind import Control.Monad.IO.Class@@ -30,6 +32,10 @@   Resourcify (x:xs)          ct = Resourcify x ct : Resourcify xs ct   Resourcify a               _  = a +-- | A proxy function for 'Resourcify'.+resourcifyProxy :: forall api ct. Proxy api -> Proxy ct -> Proxy (Resourcify api ct)+resourcifyProxy _ _ = Proxy @(Resourcify api ct)+ -- | 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@. --@@ -57,19 +63,20 @@ instance {-# OVERLAPPABLE #-}   ( server ~ ServerT api m   , ServerT (Resourcify api ct) m ~ ResourcifyServer server ct m-  , mkLink ~ MkLink api Link+  , mkLink ~ MkLink (Resourcify api ct) RelationLink+  , Accept ct   , res ~ MkResource ct   , Resource res   , ToResource res a   , HasHandler api-  , HasLink api, IsElem api api+  , HasRelationLink (Resourcify api ct)   , PolyvariadicComp2 server mkLink (IsFun server)-  , Return2 server mkLink (IsFun server) ~ (m a, Link)+  , Return2 server mkLink (IsFun server) ~ (m a, RelationLink)   , 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+  getResourceServer m _ api = pcomp2 ((\(ma, self) -> (addSelfRel self . toResource (Proxy @res) (Proxy @ct)) <$> ma)) (getHandler m api) mkSelf     where-      mkSelf = safeLink api api+      mkSelf = toRelationLink (Proxy @(Resourcify api ct))  instance   ( api ~ LayerApi l@@ -77,11 +84,11 @@   , 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)]+  , buildFun ~ ReplaceHandler rServer [(String, RelationLink)]   , Resource res   , BuildLayerLinks (Resourcify l ct) m   , PolyvariadicComp buildFun (IsFun buildFun)-  , Return buildFun (IsFun buildFun) ~ [(String, ResourceLink)]+  , Return buildFun (IsFun buildFun) ~ [(String, RelationLink)]   , 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