servant-namedargs (empty) → 0.1.0.0
raw patch · 6 files changed
+397/−0 lines, 6 filesdep +QuickCheckdep +basedep +hspec
Dependencies added: QuickCheck, base, hspec, named, servant, servant-namedargs, text
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +1/−0
- servant-namedargs.cabal +35/−0
- src/Servant/API/NamedArgs.hs +241/−0
- test/LinkEquivalency.hs +85/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for servant-namedargs++## 0.1.0.0 -- 2019-01-23++* First version.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Cullin Poresky++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Cullin Poresky nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+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.
+ servant-namedargs.cabal view
@@ -0,0 +1,35 @@+name: servant-namedargs+version: 0.1.0.0+synopsis: Combinators for servant providing named parameters+-- description:+license: BSD3+license-file: LICENSE+author: Cullin Poresky+maintainer: cporeskydev@gmail.com+-- copyright:+category: Web+build-type: Simple+extra-source-files: CHANGELOG.md, README.md+cabal-version: >=1.10++library+ exposed-modules: Servant.API.NamedArgs+ -- other-modules:+ -- other-extensions:+ build-depends: base >= 4.11 && < 4.12+ , servant >= 0.14.1 && < 0.16+ , named >= 0.2 && < 0.3+ , text >= 1.2 && < 1.3+ hs-source-dirs: src+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: test/LinkEquivalency.hs+ build-depends: base+ , servant+ , named+ , servant-namedargs+ , hspec >= 2.7 && < 2.8+ , QuickCheck >= 2.12.6.1 && < 2.13+ default-language: Haskell2010
+ src/Servant/API/NamedArgs.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PatternSynonyms #-}++-- | This module provides combinators to represent named arguments+-- to endpoints. Note that only link generation instances are provided+-- here:+-- you will most likely want one or both of "Servant.Client.NamedArgs" and+-- "Servant.Server.NamedArgs"+module Servant.API.NamedArgs where++import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)+import Data.Functor.Identity (Identity)+import Data.Proxy (Proxy(..))+import Data.Text (Text)+import Named ((:!), (:?), arg, argF, Name(..), (!), NamedF(..), pattern Arg+ , argDef)+import Servant.API ((:>), (:<|>)(..), Capture', If, QueryFlag, QueryParam'+ , QueryParams, SBoolI(..), SBool(..), HasLink(..)+ , ToHttpApiData(..), CaptureAll(..), AddHeader(..), Headers(..)+ , Header'(..))+import Servant.API.Modifiers (FoldRequired, Optional, Required, Strict, FoldLenient)+import Servant.API.Generic (GenericMode(..), AsApi, ToServant)+import Servant.Links (Param(..), Link(..), linkQueryParams)+import Type.Reflection (Typeable)+import GHC.Generics++-- | Isomorphism of 'Servant.API.Capture'' +data NamedCapture' (mods :: [*]) (sym :: Symbol) (a :: *)+ deriving Typeable++-- | Isomorphism of 'Servant.API.Capture'+type NamedCapture = NamedCapture' '[]++-- | Becomes a named required argument+instance (ToHttpApiData v, HasLink sub, KnownSymbol name)+ => HasLink (NamedCapture' mods name v :> sub) where+ type MkLink (NamedCapture' mods name v :> sub) a = (name :! v) -> MkLink sub a++ toLink toA _ l (arg (Name @name) -> capture)+ = (toLink toA (Proxy @(Capture' mods name v :> sub)) l) capture++-- | Isomorphism of 'Servant.API.CaptureAll'+data NamedCaptureAll (sym :: Symbol) (a :: *)+ deriving Typeable++-- | Becomes a named optional argument, taking a list and defaulting to an+-- empty list+instance (ToHttpApiData v, HasLink sub, KnownSymbol name)+ => HasLink (NamedCaptureAll name v :> sub) where+ type MkLink (NamedCaptureAll name v :> sub) a = (name :? [v]) -> MkLink sub a++ toLink toA _ l (argDef (Name @name) [] -> capture)+ = (toLink toA (Proxy @(CaptureAll name v :> sub)) l) capture++-- | Isomorphism of 'Servant.API.QueryParam''+data NamedParam (mods :: [*]) (sym :: Symbol) (a :: *)+ deriving Typeable++-- | Shorthand for a required param, isomorphic to+-- 'QueryParam'' \'['Required', 'Strict'] from Servant+type RequiredNamedParam = NamedParam '[Required, Strict]++-- | Shorthand for an optional param, isomorphic to+-- 'QueryParam'' \'['Optional', 'Strict'] from Servant+type OptionalNamedParam = NamedParam '[Optional, Strict]++-- | Becomes either a required or optional named argument depending on+-- whether it is set as 'Required' or 'Optional' (defaults to optional if+-- neither is specified)+instance (KnownSymbol name, HasLink sub, ToHttpApiData v, SBoolI (FoldRequired mods))+ => HasLink (NamedParam mods name v :> sub) where++ type MkLink (NamedParam mods name v :> sub) a+ = RequiredNamedArgument mods name v -> MkLink sub a++ toLink toA _ l = + foldRequiredAdapter @mods @name @v (toLink toA (Proxy @(QueryParam' mods name v :> sub)) l)++-- | Isomorphism of 'Servant.API.QueryParams'+data NamedParams (sym :: Symbol) (a :: *)+ deriving Typeable++-- | Becomes a required named argument, taking a list+instance (KnownSymbol name, HasLink sub, ToHttpApiData v)+ => HasLink (NamedParams name v :> sub) where++ type MkLink (NamedParams name v :> sub) a = (name :! [v]) -> MkLink sub a++ toLink toA _ l (arg (Name @name) -> vs)+ = (toLink toA (Proxy @(QueryParams name v :> sub)) l) vs++-- | Isomorphism of 'Servant.API.QueryFlag'+data NamedFlag (sym :: Symbol)+ deriving Typeable++-- | Becomes an optional named argument, defaulting to False+instance (KnownSymbol name, HasLink sub)+ => HasLink (NamedFlag name :> sub) where++ type MkLink (NamedFlag name :> sub) a =+ (name :? Bool) -> MkLink sub a++ toLink toA _ l (argDef (Name @name) False -> v) =+ (toLink toA (Proxy @(QueryFlag name :> sub)) l) v++-- | Isomorphism of 'Header''+data NamedHeader' (mods :: [*]) (sym :: Symbol) (a :: *)+ deriving Typeable++-- | Shorthand for a required Header; Isomorphism of 'Header'+type NamedHeader = NamedHeader' '[Optional, Strict]++-- | Has no effect on the resulting link+instance (HasLink sub) => HasLink (NamedHeader' mods name a :> sub) where+ type MkLink (NamedHeader' mods name 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)++-- | Returns either a `NamedF Identity` or `NamedF Maybe` depending on if+-- required/optional, wrapping an `Either Text a` or an `a` depending on if+-- lenient/strict+type RequestNamedArgument mods name a + = If (FoldRequired mods) + (name :! If (FoldLenient mods) (Either Text a) a)+ (name :? (If (FoldLenient mods) (Either Text a) a)) ++-- | Apply either the function 'f' which operates on 'a'+-- or 'g' which operates on 'Maybe' a depending on if the +-- mods include `Required`+foldRequiredNamedArgument+ :: forall mods name a r. (SBoolI (FoldRequired mods), KnownSymbol name)+ => (a -> r) -- ^ Function to apply if the mods includes 'Required'+ -> (Maybe a -> r) -- ^ Function to apply if the mods do not include 'Required'+ -> RequiredNamedArgument mods name a -- ^ Argument to either 'f' or 'g'+ -> r+foldRequiredNamedArgument f g mx =+ case (sbool :: SBool (FoldRequired mods), mx) of+ (STrue, (arg (Name :: Name name) -> x)) -> f x+ (SFalse, (argF (Name :: Name name) -> x)) -> g x++-- | Adapt a function supposed to take a or 'Maybe' a to take name +-- ':!'+-- a or name ':?' a instead+foldRequiredAdapter+ :: forall mods name a r. (SBoolI (FoldRequired mods), KnownSymbol name)+ => (If (FoldRequired mods) a (Maybe a) -> r) -- ^ Version of functions without named arguments+ -> RequiredNamedArgument mods name a -- ^ Argument to either 'f' or 'g'+ -> r+foldRequiredAdapter f mv = + case (sbool :: SBool (FoldRequired mods), mv) of+ (STrue, (arg (Name :: Name name) -> x)) -> f x+ (SFalse, (argF (Name :: Name name) -> x)) -> f x++-- | Unfold a value into a 'RequestNamedArgument'.+unfoldRequestNamedArgument+ :: forall mods name m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))+ => m (RequestNamedArgument mods name a) -- ^ error when argument is required+ -> (Text -> m (RequestNamedArgument mods name a)) -- ^ error when argument is strictly parsed+ -> Maybe (Either Text a) -- ^ value+ -> m (RequestNamedArgument mods name a)+unfoldRequestNamedArgument errReq errSt mex =+ case (sbool :: SBool (FoldRequired mods), mex, sbool :: SBool (FoldLenient mods)) of+ (STrue, Nothing, _) -> errReq+ (SFalse, Nothing, _) -> pure $ ArgF Nothing+ (STrue, Just ex, STrue) -> pure $ Arg ex+ (STrue, Just ex, SFalse) -> either errSt pure (Arg <$> ex)+ (SFalse, Just ex, STrue) -> pure $ ArgF $ Just ex+ (SFalse, Just ex, SFalse) -> either errSt (pure . ArgF . Just) ex++-- | 'Transform' is used to transform back and forth between APIs +-- using the "Named" combinators and APIs not using the "Named" combinators+-- by applying the listed transformations to the api+type family Transform (t :: [Transformation]) (api :: k) :: k where+ -- recurse on binary operators+ Transform t (a :<|> b) = Transform t a :<|> Transform t b+ Transform t (a :> b) = Transform t a :> Transform t b + -- naming rules+ Transform (NameParams:_) (QueryParam' mods sym a)+ = NamedParam mods sym a+ Transform (NameMultiParams:_) (QueryParams sym a)+ = NamedParams sym a+ Transform (NameFlags:_) (QueryFlag sym)+ = NamedFlag sym+ Transform (NameCaptures:_) (Capture' mods sym a)+ = NamedCapture' mods sym a+ Transform (NameCaptureAlls:_) (CaptureAll sym a)+ = NamedCaptureAll sym a+ Transform (NameHeaders:_) (Header' mods sym a)+ = NamedHeader' mods sym a+ -- unnaming rules+ Transform (UnnameParams:_) (NamedParam mods sym a)+ = QueryParam' mods sym a+ Transform (UnnameMultiParams:_) (NamedParams sym a)+ = QueryParams sym a+ Transform (UnnameFlags:_) (NamedFlag sym)+ = QueryFlag sym+ Transform (UnnameCaptures:_) (NamedCapture' mods sym a)+ = Capture' mods sym a+ Transform (UnnameCaptureAlls:_) (NamedCaptureAll sym a)+ = CaptureAll sym a+ Transform (UnnameHeaders:_) (NamedHeader' mods sym a)+ = Header' mods sym 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+ Transform '[] a = a++-- | 'AsTransformed' can be used to transform back and forth while using+-- Servant's generic programming (see "Servant.API.Generic")+data AsTransformed (t :: [Transformation]) (m :: *)++instance (GenericMode mode) => GenericMode (AsTransformed t mode) where+ type AsTransformed t mode :- api = mode :- Transform t api++-- | Possible transformations 'Transform' can apply+data Transformation = NameParams -- ^ Replace 'QueryParam''s with 'NamedParam''s+ | NameMultiParams -- ^ Replace 'QueryParams's with 'NamedParams's+ | NameCaptures -- ^ Replace 'Capture''s with 'NamedCapture''s+ | NameCaptureAlls -- ^ Replace 'CaptureAll's with 'NamedCaptureAll's+ | NameFlags -- ^ Replace 'QueryFlag's with 'NamedFlag's+ | NameHeaders -- ^ Replace 'Header''s with 'NamedHeader''s+ | 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)
+ test/LinkEquivalency.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE FlexibleContexts #-}++import Test.Hspec+import Test.QuickCheck+import Servant.API+import Servant.API.NamedArgs+import Data.Proxy+import Data.Functor.Identity+import Named+import Named.Internal+import Data.Function ((&))++type All = [ NameCaptures+ , NameCaptureAlls+ , NameFlags+ , NameParams+ , NameMultiParams+ ]++type CaptureEndpoint = "capture" :> Capture "x" Int :> Get '[JSON] Int+type CaptureAllEndpoint = "captureAll" :> CaptureAll "xs" Int :> Get '[JSON] [Int]+type FlagEndpoint = "flag" :> QueryFlag "f" :> Get '[JSON] Bool+type ReqParamEndpoint = "requiredParam" :> QueryParam' [Required, Strict] "r" Int :> Get '[JSON] Int+type OpParamEndpoint = "optionalParam" :> QueryParam' [Optional, Strict] "o" Int :> Get '[JSON] Int+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 TestApi = CaptureEndpoint+ :<|> CaptureAllEndpoint+ :<|> FlagEndpoint+ :<|> ReqParamEndpoint+ :<|> OpParamEndpoint+ :<|> ParamsEndpoint+ :<|> ReqHeaderEndpoint+ :<|> OpHeaderEndpoint++cmpLinks+ :: forall endpoint a n. ( IsElem endpoint TestApi+ , IsElem (Transform All endpoint) (Transform All TestApi)+ , HasLink endpoint+ , HasLink (Transform All endpoint)+ )+ => a+ -> (a -> (MkLink endpoint Link) -> Link)+ -> (a -> (MkLink (Transform All endpoint) Link) -> Link)+ -> Bool+cmpLinks val uf nf = toUrlPiece (uf val unnamed) == toUrlPiece (nf val named)+ where+ unnamed = safeLink (Proxy @TestApi) (Proxy @endpoint)+ named = safeLink (Proxy @(Transform All TestApi)) (Proxy @(Transform All endpoint))++withF :: forall l p f a fn fn'. (p ~ NamedF f a l, WithParam p fn fn')+ => f a -> fn -> fn'+withF p fn = with (Param $ ArgF @_ @_ @l p) fn++def :: a -> Maybe a -> a+def a Nothing = a+def _ (Just b) = b++main :: IO ()+main = hspec $ do+ describe "Named and unnamed equivalency" $ do+ it "Capture and NamedCapture are equivalent" $ do+ property $ \x -> cmpLinks @CaptureEndpoint x ((&) . runIdentity) ((withF @"x"))+ it "CaptureAll and NamedCaptureAll are equivalent" $ do+ property $ \x -> cmpLinks @CaptureAllEndpoint x ((&) . def []) (withF @"xs")+ it "QueryFlag and NamedFlag are equivalent" $ do+ property $ \x -> cmpLinks @FlagEndpoint x ((&) . def False) (withF @"f")+ it "Required QueryParam and NamedParam are equivalent" $ do+ property $ \x -> cmpLinks @ReqParamEndpoint x ((&) . runIdentity) (withF @"r")+ it "Optional QueryParam and NamedParam are equivalent" $ do+ property $ \x -> cmpLinks @OpParamEndpoint x ((&)) (withF @"o")+ it "Required QueryHeader and NamedHeader are equivalent" $ do+ cmpLinks @ReqHeaderEndpoint Nothing (flip const) (flip const)+ it "Optional QueryHeader and NamedHeader are equivalent" $ do+ cmpLinks @OpHeaderEndpoint Nothing (flip const) (flip const)