servant-hateoas 0.3.2 → 0.3.3

raw patch · 4 files changed

+161/−63 lines, 4 filesdep +network-uriPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: network-uri

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• servant-hateoas.cabal +2/−1
• src/Servant/Hateoas/Layer/Build.hs +103/−54
• src/Servant/Hateoas/RelationLink.hs +48/−8

@@ -6,6 +6,14 @@ 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.3 _(2024-12-28)_++### Added+- Added function `fromURI` for creating `RelationLink` from an `URI`++### Changed+- Replaced fully templated links with partially templated links for layers whose endpoints take arguments+ ## v0.3.2 _(2024-12-27)_  ### Changed

@@ -1,6 +1,6 @@ cabal-version:           3.0 name:                    servant-hateoas-version:                 0.3.2+version:                 0.3.3 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.@@ -52,6 +52,7 @@                        , text                          >= 1.2.3.0  && < 2.2                        , http-types                    >= 0.12.2   && < 0.13                        , http-media                    >= 0.8.1    && < 0.9+                       , network-uri                   >= 2.6.1.0  && < 2.7                        , servant                       >= 0.20.2   && < 0.21                        , servant-server                >= 0.20.2   && < 0.21                        , singleton-bool                >= 0.1.4    && < 0.2

@@ -11,6 +11,7 @@ where  import Servant+import Servant.API.ContentTypes import Servant.Hateoas.Resource import Servant.Hateoas.RelationLink import Servant.Hateoas.Layer.Type@@ -60,97 +61,145 @@       mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m  instance-  ( c ~ MkPrefix (apiCs ++ '[Capture' mods sym x]) verb-  , HasRelationLink c+  ( verb ~ Verb method status cts a+  , AllMime cts, ReflectMethod method+  , api ~ MkPrefix apiCs verb   , KnownSymbol sym+  , HasRelationLink (MkPrefix '[Capture' mods sym x] verb)+  , IsElem api api, HasLink api   , BuildLayerLinks ('Layer apiCs cs verb) m-  , buildLinksFun ~ (ReplaceHandler (ServerT (MkPrefix apiCs verb) m) [(String, ResourceLink)])-  , PolyvariadicComp buildLinksFun (IsFun buildLinksFun)-  , Replace buildLinksFun [(String, ResourceLink)] (IsFun buildLinksFun) ~ buildLinksFun-  , Return buildLinksFun (IsFun buildLinksFun) ~ [(String, ResourceLink)]+  , 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   ) => BuildLayerLinks ('Layer apiCs (Capture' mods sym x ': cs) verb) m where-  buildLayerLinks _ m = ((relName, l) :) ... mkLinks+  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, mkTemplatedNext self) : ls) mkSelf mkLinks     where-      mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m       relName = symbolVal (Proxy @sym)-      l = TemplateLink $ toRelationLink (Proxy @c)+      mkSelf = safeLink (Proxy @api) (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  instance-  ( c ~ MkPrefix (apiCs ++ '[CaptureAll sym x]) verb-  , HasRelationLink c+  ( verb ~ Verb method status cts a+  , AllMime cts, ReflectMethod method+  , api ~ MkPrefix apiCs verb   , KnownSymbol sym+  , HasRelationLink (MkPrefix '[CaptureAll sym x] verb)+  , IsElem api api, HasLink api   , BuildLayerLinks ('Layer apiCs cs verb) m-  , buildLinksFun ~ (ReplaceHandler (ServerT (MkPrefix apiCs verb) m) [(String, ResourceLink)])-  , PolyvariadicComp buildLinksFun (IsFun buildLinksFun)-  , Replace buildLinksFun [(String, ResourceLink)] (IsFun buildLinksFun) ~ buildLinksFun-  , Return buildLinksFun (IsFun buildLinksFun) ~ [(String, ResourceLink)]+  , 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   ) => BuildLayerLinks ('Layer apiCs (CaptureAll sym x ': cs) verb) m where-  buildLayerLinks _ m = ((relName, l) :) ... mkLinks+  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, mkTemplatedNext self) : ls) mkSelf mkLinks     where-      mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m       relName = symbolVal (Proxy @sym)-      l = TemplateLink $ toRelationLink (Proxy @c)+      mkSelf = safeLink (Proxy @api) (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  instance-  ( c ~ MkPrefix (apiCs ++ '[QueryParam' mods sym x]) verb-  , HasRelationLink c+  ( verb ~ Verb method status cts a+  , AllMime cts, ReflectMethod method+  , api ~ MkPrefix apiCs verb   , KnownSymbol sym+  , HasRelationLink (MkPrefix '[QueryParam' mods sym x] verb)+  , IsElem api api, HasLink api   , BuildLayerLinks ('Layer apiCs cs verb) m-  , buildLinksFun ~ (ReplaceHandler (ServerT (MkPrefix apiCs verb) m) [(String, ResourceLink)])-  , PolyvariadicComp buildLinksFun (IsFun buildLinksFun)-  , Replace buildLinksFun [(String, ResourceLink)] (IsFun buildLinksFun) ~ buildLinksFun-  , Return buildLinksFun (IsFun buildLinksFun) ~ [(String, ResourceLink)]+  , 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   ) => BuildLayerLinks ('Layer apiCs (QueryParam' mods sym x ': cs) verb) m where-  buildLayerLinks _ m = ((relName, l) :) ... mkLinks+  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, mkTemplatedNext self) : ls) mkSelf mkLinks     where-      mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m       relName = symbolVal (Proxy @sym)-      l = TemplateLink $ toRelationLink (Proxy @c)+      mkSelf = safeLink (Proxy @api) (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  instance-  ( c ~ MkPrefix (apiCs ++ '[QueryParams sym x]) verb-  , HasRelationLink c+  ( verb ~ Verb method status cts a+  , AllMime cts, ReflectMethod method+  , api ~ MkPrefix apiCs verb   , KnownSymbol sym+  , HasRelationLink (MkPrefix '[QueryParams sym x] verb)+  , IsElem api api, HasLink api   , BuildLayerLinks ('Layer apiCs cs verb) m-  , buildLinksFun ~ (ReplaceHandler (ServerT (MkPrefix apiCs verb) m) [(String, ResourceLink)])-  , PolyvariadicComp buildLinksFun (IsFun buildLinksFun)-  , Replace buildLinksFun [(String, ResourceLink)] (IsFun buildLinksFun) ~ buildLinksFun-  , Return buildLinksFun (IsFun buildLinksFun) ~ [(String, ResourceLink)]+  , 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   ) => BuildLayerLinks ('Layer apiCs (QueryParams sym x ': cs) verb) m where-  buildLayerLinks _ m = ((relName, l) :) ... mkLinks+  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, mkTemplatedNext self) : ls) mkSelf mkLinks     where-      mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m       relName = symbolVal (Proxy @sym)-      l = TemplateLink $ toRelationLink (Proxy @c)+      mkSelf = safeLink (Proxy @api) (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  instance-  ( c ~ MkPrefix (apiCs ++ '[DeepQuery sym x]) verb-  , HasRelationLink c+  ( verb ~ Verb method status cts a+  , AllMime cts, ReflectMethod method+  , api ~ MkPrefix apiCs verb   , KnownSymbol sym+  , HasRelationLink (MkPrefix '[DeepQuery sym x] verb)+  , IsElem api api, HasLink api   , BuildLayerLinks ('Layer apiCs cs verb) m-  , buildLinksFun ~ (ReplaceHandler (ServerT (MkPrefix apiCs verb) m) [(String, ResourceLink)])-  , PolyvariadicComp buildLinksFun (IsFun buildLinksFun)-  , Replace buildLinksFun [(String, ResourceLink)] (IsFun buildLinksFun) ~ buildLinksFun-  , Return buildLinksFun (IsFun buildLinksFun) ~ [(String, ResourceLink)]+  , 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   ) => BuildLayerLinks ('Layer apiCs (DeepQuery sym x ': cs) verb) m where-  buildLayerLinks _ m = ((relName, l) :) ... mkLinks+  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, mkTemplatedNext self) : ls) mkSelf mkLinks     where-      mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m       relName = symbolVal (Proxy @sym)-      l = TemplateLink $ toRelationLink (Proxy @c)+      mkSelf = safeLink (Proxy @api) (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  instance-  ( c ~ MkPrefix (apiCs ++ '[QueryFlag sym]) verb-  , HasRelationLink c+  ( verb ~ Verb method status cts a+  , AllMime cts, ReflectMethod method+  , api ~ MkPrefix apiCs verb   , KnownSymbol sym+  , HasRelationLink (MkPrefix '[QueryFlag sym] verb)+  , IsElem api api, HasLink api   , BuildLayerLinks ('Layer apiCs cs verb) m-  , buildLinksFun ~ (ReplaceHandler (ServerT (MkPrefix apiCs verb) m) [(String, ResourceLink)])-  , PolyvariadicComp buildLinksFun (IsFun buildLinksFun)-  , Replace buildLinksFun [(String, ResourceLink)] (IsFun buildLinksFun) ~ buildLinksFun-  , Return buildLinksFun (IsFun buildLinksFun) ~ [(String, ResourceLink)]+  , 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   ) => BuildLayerLinks ('Layer apiCs (QueryFlag sym ': cs) verb) m where-  buildLayerLinks _ m = ((relName, l) :) ... mkLinks+  buildLayerLinks _ m = pcomp2 (\(self, ls) -> (relName, mkTemplatedNext self) : ls) mkSelf mkLinks     where-      mkLinks = buildLayerLinks (Proxy @('Layer apiCs cs verb)) m       relName = symbolVal (Proxy @sym)-      l = TemplateLink $ toRelationLink (Proxy @c)+      mkSelf = safeLink (Proxy @api) (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

@@ -1,27 +1,40 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}  module Servant.Hateoas.RelationLink (-  -- * Type+  -- * RelationLink+  -- ** Type   RelationLink(..),   RelationParam(..),++  -- *** Creation+  fromURI,++  -- *** Operations   mkPlaceHolder,   appendPath, -  -- * Class+  -- ** Class   HasRelationLink(..),++  -- * Utility+  -- ** ReflectStdMethod+  reflectStdMethod, ) where +import Prelude hiding (dropWhile, break) import Servant import Servant.API.ContentTypes (AllMime(..)) import Servant.API.Modifiers (FoldRequired)+import Network.URI (unEscapeString) import Network.HTTP.Media (MediaType)-import Network.HTTP.Types (parseMethod)+import Network.HTTP.Types (parseMethod, Method) import Data.String (fromString) import Data.Aeson-import Data.Text (Text, intercalate)+import Data.Text (Text, intercalate, dropWhile, split, break) import Data.Singletons.Bool import GHC.TypeLits @@ -51,6 +64,33 @@ appendPath l "" = l appendPath l r = l <> "/" <> r +-- | Creates a 'RelationLink' from an 'URI'.+fromURI :: [MediaType] -> StdMethod -> URI -> RelationLink+fromURI cts m (URI _ _ path query _) = RelationLink+  { _path = fromString path+  , _params = params+  , _templated = False+  , _method = m+  , _contentTypes = cts+  , _summary = Nothing+  , _description = Nothing+  }+  where+    params = filter ((/= "") . _name)+      $ fmap (\kv -> RelationParam (fst $ break (== '=') kv) False)+      $ split (== '&')+      $ dropWhile (== '?')+      $ fromString+      $ unEscapeString query++-- | Like 'reflectMethod' but returns a 'StdMethod'.+reflectStdMethod :: ReflectMethod method => Proxy method -> StdMethod+reflectStdMethod = unsafeMethodToStdMethod . reflectMethod++unsafeMethodToStdMethod :: Method -> StdMethod+unsafeMethodToStdMethod (parseMethod -> Right m) = m+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@@ -146,7 +186,7 @@     { _path = mempty     , _params = []     , _templated = False-    , _method = case parseMethod $ reflectMethod (Proxy @m) of Right m -> m; Left _ -> error "Invalid method"+    , _method = reflectStdMethod (Proxy @m)     , _summary = Nothing     , _description = Nothing     , _contentTypes = allMime (Proxy @cts)@@ -157,7 +197,7 @@     { _path = mempty     , _params = []     , _templated = False-    , _method = case parseMethod $ reflectMethod (Proxy @m) of Right m -> m; Left _ -> error "Invalid method"+    , _method = reflectStdMethod (Proxy @m)     , _summary = Nothing     , _description = Nothing     , _contentTypes = mempty@@ -168,7 +208,7 @@     { _path = mempty     , _params = []     , _templated = False-    , _method = case parseMethod $ reflectMethod (Proxy @m) of Right m -> m; Left _ -> error "Invalid method"+    , _method = reflectStdMethod (Proxy @m)     , _summary = Nothing     , _description = Nothing     , _contentTypes = allMime (Proxy @cts)@@ -179,7 +219,7 @@     { _path = mempty     , _params = []     , _templated = False-    , _method = case parseMethod $ reflectMethod (Proxy @m) of Right m -> m; Left _ -> error "Invalid method"+    , _method = reflectStdMethod (Proxy @m)     , _summary = Nothing     , _description = Nothing     , _contentTypes = pure $ contentType (Proxy @ct)