Skip to content

Commit

Permalink
Merge pull request #27 from bruderj15/partial-links
Browse files Browse the repository at this point in the history 
Partial links
  • Loading branch information
@bruderj15
bruderj15 authored Dec 28, 2024
2 parents 43d1297 + a0b0ca7 commit df7571d
Show file tree
Hide file tree
Showing 4 changed files with 161 additions and 63 deletions.
8 changes: 8 additions & 0 deletions CHANGELOG.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,14 @@ file.
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
Expand Down
3 changes: 2 additions & 1 deletion servant-hateoas.cabal
View file
Original file line number Diff line number Diff line change
@@ -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.
Expand Down Expand Up @@ -52,6 +52,7 @@ library
, 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
Expand Down
157 changes: 103 additions & 54 deletions src/Servant/Hateoas/Layer/Build.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@ module Servant.Hateoas.Layer.Build
where

import Servant
import Servant.API.ContentTypes
import Servant.Hateoas.Resource
import Servant.Hateoas.RelationLink
import Servant.Hateoas.Layer.Type
Expand Down Expand Up @@ -60,97 +61,145 @@ instance
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
56 changes: 48 additions & 8 deletions src/Servant/Hateoas/RelationLink.hs
View file
Original file line number Diff line number Diff line change
@@ -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

Expand Down Expand Up @@ -51,6 +64,33 @@ appendPath :: Text -> Text -> Text
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
Expand Down Expand Up @@ -146,7 +186,7 @@ instance (ReflectMethod m, AllMime cts) => HasRelationLink (Verb m s cts a) wher
{ _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)
Expand All @@ -157,7 +197,7 @@ instance ReflectMethod m => HasRelationLink (NoContentVerb m) where
{ _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
Expand All @@ -168,7 +208,7 @@ instance (ReflectMethod m, AllMime cts) => HasRelationLink (UVerb m cts as) wher
{ _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)
Expand All @@ -179,7 +219,7 @@ instance (ReflectMethod m, Accept ct) => HasRelationLink (Stream m s f ct a) whe
{ _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)
Expand Down

0 comments on commit df7571d

Please sign in to comment.