diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,3 +7,7 @@ ## 0.1.0.1 -- 2019-01-25 * Relaxation of base constraint and some minor documentation fixes; had to be done as a new version to be able to build on Hackage + +## 0.1.1.0 -- 2019-02-25 + +* Introduction of NamedBody' combinator diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,1 +1,3 @@ -This library provides combinators to add named arguments to servant endpoints. These combinators are all isomorphic to existing servant combinators, and so a type family `Transform` is also provided for converting namedargs combinators to and from default servant combinators. Following the pattern of servant itself, this library *only* adds the combinators and instances for link generation: for the instances to actually use them with servant-client and servant-server, look at servant-client-namedargs and servant-server-namedargs. +This library provides combinators to add named arguments to servant endpoints. These combinators are all isomorphic to existing servant combinators\*, and so a type family `Transform` is also provided for converting namedargs combinators to and from default servant combinators. Following the pattern of servant itself, this library *only* adds the combinators and instances for link generation: for the instances to actually use them with servant-client and servant-server, look at servant-client-namedargs and servant-server-namedargs. + +\* NamedBody' is NOT isomorphic to ReqBody', because ReqBody' doesn't have a name. Conversions are still provided, but going from a NamedBody' to a ReqBody' will lose the associated name of the NamedBody', and going from a ReqBody' to a NamedBody' requires a default name which will be applied. diff --git a/servant-namedargs.cabal b/servant-namedargs.cabal --- a/servant-namedargs.cabal +++ b/servant-namedargs.cabal @@ -1,7 +1,9 @@ name: servant-namedargs -version: 0.1.0.1 +version: 0.1.1.0 synopsis: Combinators for servant providing named parameters -- description: +homepage: https://gitlab.com/sciencei/servant-namedargs +bug-reports: https://gitlab.com/sciencei/servant-namedargs/issues license: BSD3 license-file: LICENSE author: Cullin Poresky diff --git a/src/Servant/API/NamedArgs.hs b/src/Servant/API/NamedArgs.hs --- a/src/Servant/API/NamedArgs.hs +++ b/src/Servant/API/NamedArgs.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ExistentialQuantification #-} -- | This module provides combinators to represent named arguments -- to endpoints. Note that only link generation instances are provided @@ -27,7 +28,7 @@ import Servant.API ((:>), (:<|>)(..), Capture', If, QueryFlag, QueryParam' , QueryParams, SBoolI(..), SBool(..), HasLink(..) , ToHttpApiData(..), CaptureAll(..), AddHeader(..), Headers(..) - , Header'(..)) + , Header'(..), ReqBody') import Servant.API.Modifiers (FoldRequired, Optional, Required, Strict, FoldLenient) import Servant.API.Generic (GenericMode(..), AsApi, ToServant) import Servant.Links (Param(..), Link(..), linkQueryParams) @@ -125,6 +126,20 @@ type MkLink (NamedHeader' mods name a :> sub) r = MkLink sub r toLink toA _ = toLink toA (Proxy :: Proxy sub) +-- | Named /equivalent/ but /not isomorphism/ of 'ReqBody''. 'ReqBody'' doesn't +-- have an associated name, so if you convert from a 'NamedBody'' to a 'ReqBody'' +-- you will /lose the associated name/. Converting from a 'ReqBody'' to a 'NamedBody'' +-- requires a default name be passed in. Like 'ReqBody'', 'NamedBody'' is always +-- 'Required'. +data NamedBody' (mods :: [*]) (sym :: Symbol) (contentTypes :: [*]) (a :: *) deriving Typeable + +type NamedBody = NamedBody' '[Required, Strict] + +-- | Has no effect on the resulting link +instance (HasLink sub) => HasLink (NamedBody' mods name ct a :> sub) where + type MkLink (NamedBody' mods name ct a :> sub) r = MkLink sub r + toLink toA _ = toLink toA (Proxy :: Proxy sub) + -- | Returns the type name ':!' a if given a list including 'Required' -- and name ':?' a otherwise type RequiredNamedArgument mods name a = If (FoldRequired mods) (name :! a) (name :? a) @@ -200,6 +215,8 @@ = NamedCaptureAll sym a Transform (NameHeaders:_) (Header' mods sym a) = NamedHeader' mods sym a + Transform (NameBodies name:_) (ReqBody' mods ct a) + = NamedBody' mods name ct a -- unnaming rules Transform (UnnameParams:_) (NamedParam mods sym a) = QueryParam' mods sym a @@ -213,6 +230,8 @@ = CaptureAll sym a Transform (UnnameHeaders:_) (NamedHeader' mods sym a) = Header' mods sym a + Transform (UnnameBodies:_) (NamedBody' mods sym ct a) + = ReqBody' mods ct a -- if the current transformation doesn't match, try the next one Transform (_:ts) a = Transform ts a -- if none of them match, leave it unchanged @@ -232,10 +251,11 @@ | NameCaptureAlls -- ^ Replace 'CaptureAll's with 'NamedCaptureAll's | NameFlags -- ^ Replace 'QueryFlag's with 'NamedFlag's | NameHeaders -- ^ Replace 'Header''s with 'NamedHeader''s + | forall name. NameBodies name -- ^ Replace 'ReqBody''s with 'NamedBody''s with the default name @name@ | UnnameParams -- ^ Replace 'NamedParam's with 'QueryParam''s | UnnameMultiParams -- ^ Replace 'NamedParams's with 'QueryParams's | UnnameCaptures -- ^ Replace 'NamedCapture''s with 'Capture''s | UnnameCaptureAlls -- ^ Replace 'NamedCaptureAll's with 'CaptureAll's | UnnameFlags -- ^ Replace 'NamedFlag's with 'QueryFlag's | UnnameHeaders -- ^ Replace 'NamedHeader''s with 'Header''s - deriving (Show, Read, Eq, Enum) + | UnnameBodies -- ^ Replace 'NamedBody''s with 'ReqBody''s -- WILL LOSE THE ASSOCIATED NAME diff --git a/test/LinkEquivalency.hs b/test/LinkEquivalency.hs --- a/test/LinkEquivalency.hs +++ b/test/LinkEquivalency.hs @@ -23,6 +23,7 @@ , NameFlags , NameParams , NameMultiParams + , NameBodies "reqBody" ] type CaptureEndpoint = "capture" :> Capture "x" Int :> Get '[JSON] Int @@ -33,6 +34,7 @@ type ParamsEndpoint = "params" :> QueryParams "ps" Int :> Get '[JSON] [Int] type ReqHeaderEndpoint = "requiredHeader" :> Header' [Required, Strict] "rh" Int :> Get '[JSON] Int type OpHeaderEndpoint = "optionalHeader" :> Header' [Optional, Strict] "oh" Int :> Get '[JSON] Int +type BodyEndpoint = "reqBody" :> ReqBody '[JSON] Int :> Get '[JSON] Int type TestApi = CaptureEndpoint :<|> CaptureAllEndpoint @@ -42,6 +44,7 @@ :<|> ParamsEndpoint :<|> ReqHeaderEndpoint :<|> OpHeaderEndpoint + :<|> BodyEndpoint cmpLinks :: forall endpoint a n. ( IsElem endpoint TestApi @@ -83,3 +86,5 @@ cmpLinks @ReqHeaderEndpoint Nothing (flip const) (flip const) it "Optional QueryHeader and NamedHeader are equivalent" $ do cmpLinks @OpHeaderEndpoint Nothing (flip const) (flip const) + it "ReqBody and NamedBody are equivalent" $ do + cmpLinks @BodyEndpoint Nothing (flip const) (flip const)