servant-client-namedargs (empty) → 0.1.0.0
raw patch · 6 files changed
+402/−0 lines, 6 filesdep +QuickCheckdep +asyncdep +base
Dependencies added: QuickCheck, async, base, hspec, http-client, named, servant, servant-client, servant-client-core, servant-client-namedargs, servant-namedargs, servant-server, servant-server-namedargs, text, warp
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +1/−0
- servant-client-namedargs.cabal +45/−0
- src/Servant/Client/NamedArgs.hs +152/−0
- test/ClientServerEquivalency.hs +169/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for servant-client-named++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ 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 package provides the `HasClient` instances needed by [servant-client](http://hackage.haskell.org/package/servant-client) to produce functions with named parameters using the combinators in [servant-namedargs](https://hackage.haskell.org/package/servant-namedargs). See [named](http://hackage.haskell.org/package/named) for more information on how the named parameters work, and the haddocks for the behavior of specific combinators.
+ servant-client-namedargs.cabal view
@@ -0,0 +1,45 @@+name: servant-client-namedargs+version: 0.1.0.0+synopsis: Automatically derive API client functions with named and optional parameters+-- description:+-- homepage: +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.Client.NamedArgs+ -- other-modules:+ -- other-extensions:+ build-depends: base >= 4.11 && < 4.13+ , servant >= 0.14.1 && < 0.16+ , servant-client-core >= 0.14.1 && < 0.16+ , servant-namedargs >= 0.1 && < 0.2+ , 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/ClientServerEquivalency.hs+ build-depends: base+ , servant+ , named+ , servant-namedargs == 0.1.0.1+ , servant-server-namedargs == 0.1.0.0+ , servant-client-namedargs+ , servant-server+ , servant-client+ , hspec >= 2.7 && < 2.8+ , http-client >= 0.6.1 && < 0.7+ , QuickCheck >= 2.12.6.1 && < 2.13+ , async >= 2.2.1 && < 2.3+ , warp >= 3.2.25 && < 3.3+ default-language: Haskell2010
+ src/Servant/Client/NamedArgs.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}++-- | Provides instances to be able to use combinators from+-- "Servant.API.NamedArgs" with "Servant.Client", returning functions+-- using named parameters from "Named"+module Servant.Client.NamedArgs where++import Named ((:!), (:?), arg, argF, argDef, Name(..))+import Data.Text (pack, Text)+import Data.Functor.Identity (Identity)+import Data.List (foldl')+import Servant.API ((:>), SBoolI, ToHttpApiData, toQueryParam, toUrlPiece)+import Servant.API.Modifiers (FoldRequired)+import Servant.API.NamedArgs ( foldRequiredNamedArgument, NamedCapture', NamedFlag+ , NamedParam, NamedParams, RequiredNamedArgument+ , NamedCaptureAll, NamedHeader')+import Servant.Client.Core.Internal.HasClient (HasClient(..))+import Servant.Client.Core.Internal.Request ( appendToPath, appendToQueryString, Request+ , addHeader)++import Data.String (fromString)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Data.Proxy (Proxy(..))++-- | 'NamedCapture''s become required named arguments+instance (KnownSymbol name, ToHttpApiData a, HasClient m api)+ => HasClient m (NamedCapture' mods name a :> api) where++ type Client m (NamedCapture' mods name a :> api) =+ (name :! a) -> Client m api++ clientWithRoute pm _ req (arg (Name @name) -> capture) =+ clientWithRoute pm (Proxy @api) (appendToPath (toUrlPiece capture) req)+ + hoistClientMonad pm _ f cl = \a ->+ hoistClientMonad pm (Proxy @api) f (cl a)++-- | 'NamedCaptureAll's become optional named arguments taking a list and+-- defaulting to an empty list+instance (KnownSymbol name, ToHttpApiData a, HasClient m api)+ => HasClient m (NamedCaptureAll name a :> api) where++ type Client m (NamedCaptureAll name a :> api) =+ (name :? [a]) -> Client m api++ clientWithRoute pm _ req (argDef (Name @name) [] -> captures) =+ clientWithRoute pm (Proxy @api) (foldl' (flip appendToPath) req ps)+ where+ ps = map toUrlPiece captures+ + hoistClientMonad pm _ f cl = \as ->+ hoistClientMonad pm (Proxy @api) f (cl as)++-- | 'NamedFlag's become optional named arguments, defaulting to 'False'+instance (KnownSymbol name, HasClient m api)+ => HasClient m (NamedFlag name :> api) where++ type Client m (NamedFlag name :> api) =+ (name :? Bool) -> Client m api++ clientWithRoute pm _ req (argDef (Name @name) False -> mflag) =+ clientWithRoute pm (Proxy @api) $+ if mflag+ then appendToQueryString pname Nothing req+ else req+ where+ pname :: Text+ pname = pack $ symbolVal (Proxy @name)++ hoistClientMonad pm _ f cl = \b ->+ hoistClientMonad pm (Proxy @api) f (cl b)++-- | 'NamedHeader''s become either required or optional named arguments+-- depending on if 'Servant.API.Modifiers.Required' or+-- 'Servant.API.Modifiers.Optional' are in the modifiers+instance (KnownSymbol name, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))+ => HasClient m (NamedHeader' mods name a :> api) where++ type Client m (NamedHeader' mods name a :> api) =+ RequiredNamedArgument mods name a -> Client m api++ clientWithRoute pm _ req mval =+ clientWithRoute pm (Proxy @api) $+ foldRequiredNamedArgument @mods @name+ add+ (maybe req add)+ mval++ where+ add :: a -> Request+ add value = addHeader hname value req++ hname = fromString $ symbolVal (Proxy @name)++ hoistClientMonad pm _ f cl = \a ->+ hoistClientMonad pm (Proxy @api) f (cl a)++-- | 'NamedParam's become either required or optional named arguments+-- depending on if 'Servant.API.Modifiers.Required' or+-- 'Servant.API.Modifiers.Optional' are in the modifiers+instance (KnownSymbol name, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))+ => HasClient m (NamedParam mods name a :> api) where++ type Client m (NamedParam mods name a :> api) =+ RequiredNamedArgument mods name a -> Client m api++ clientWithRoute pm _ req mparam =+ clientWithRoute pm (Proxy @api) $+ foldRequiredNamedArgument @mods @name+ add+ (maybe req add)+ mparam++ where+ add :: a -> Request+ add param = appendToQueryString pname (Just $ toQueryParam param) req++ pname :: Text+ pname = pack $ symbolVal (Proxy @name)++ hoistClientMonad pm _ f cl = \a ->+ hoistClientMonad pm (Proxy @api) f (cl a)++-- | 'NamedParams's become optional named arguments taking a list and+-- defaulting to an empty list+instance (KnownSymbol name, ToHttpApiData a, HasClient m api)+ => HasClient m (NamedParams name a :> api) where++ type Client m (NamedParams name a :> api) =+ (name :? [a]) -> Client m api++ clientWithRoute pm _ req (argDef (Name @name) [] -> mparams) =+ clientWithRoute pm (Proxy @api) $+ case mparams of+ [] -> req+ ls -> foldl'+ (\req' param -> appendToQueryString pname (Just $ toQueryParam param) req')+ req+ ls+ where+ pname :: Text+ pname = pack $ symbolVal (Proxy :: Proxy name)++ hoistClientMonad pm _ f cl = \as ->+ hoistClientMonad pm (Proxy @api) f (cl as)
+ test/ClientServerEquivalency.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE FlexibleContexts #-}++import Test.Hspec+import Test.QuickCheck.Monadic+import Test.QuickCheck (property)+import Servant.Server+import Servant.API+import Servant.API.NamedArgs+import Servant.Client.NamedArgs+import Servant.Server.NamedArgs+import Servant.Client+import Data.Proxy+import Data.Functor.Identity+import Named+import Named.Internal+import Data.Function ((&))+import Network.HTTP.Client (Manager(..), newManager, defaultManagerSettings)+import Control.Concurrent.Async+import qualified Network.Wai.Handler.Warp as W++type All = [ NameCaptures+ , NameCaptureAlls+ , NameFlags+ , NameParams+ , NameMultiParams+ , NameHeaders+ ]++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++unnamedServer :: Server TestApi+unnamedServer = pure+ :<|> pure+ :<|> pure+ :<|> pure+ :<|> pure . def 19+ :<|> pure+ :<|> pure+ :<|> pure . def 19++namedServer :: Server (Transform All TestApi)+namedServer = pureI+ :<|> pureI+ :<|> pureI+ :<|> pureI+ :<|> pureM+ :<|> pureI+ :<|> pureI+ :<|> pureM+ where+ pureI (Arg v) = pure v+ pureM (ArgF mv) = maybe (pure 19) pure mv++unnamedApp = serve (Proxy @TestApi) unnamedServer+namedApp = serve (Proxy @(Transform All TestApi)) namedServer++uCapture+ :<|> uCaptureAll+ :<|> uFlag+ :<|> uRParam+ :<|> uOParam+ :<|> uParams+ :<|> uRHeader+ :<|> uOHeader = client (Proxy @TestApi)++nCapture+ :<|> nCaptureAll+ :<|> nFlag+ :<|> nRParam+ :<|> nOParam+ :<|> nParams+ :<|> nRHeader+ :<|> nOHeader = client (Proxy @(Transform All TestApi))++clientServerEq+ :: (Eq r)+ => Manager+ -> BaseUrl+ -> BaseUrl+ -> f a+ -> (f a -> ClientM r)+ -> (f a -> ClientM r)+ -> IO Bool+clientServerEq man ub nb val uf nf+ = (runUs uf') `meq` (runUs nf')+ `mand` (runNs uf') `meq` (runUs nf')+ `mand` (runNs uf') `meq` (runNs nf')+ `mand` (runUs uf') `meq` (runNs nf')+ where+ unnamedServer = mkClientEnv man ub+ namedServer = mkClientEnv man nb+ runUs c = runClientM c unnamedServer+ runNs c = runClientM c namedServer+ uf' = uf val+ nf' = nf val+ l `meq` r = (==) <$> l <*> r+ l `mand` r = (&&) <$> l <*> r+ infix 4 `meq`+ infixr 3 `mand`++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++-- we make sure that all permutations of the named or unnamed server being+-- queried by the named or unnamed clients return the same+main :: IO ()+main = do+ let uh = 11008+ nh = 11009+ man <- newManager defaultManagerSettings+ us <- async $ W.run uh unnamedApp+ ns <- async $ W.run nh namedApp+ let+ ub = BaseUrl Http "localhost" uh ""+ nb = BaseUrl Http "localhost" nh ""+ doComp :: (Eq r)+ => f a+ -> (f a -> ClientM r)+ -> (f a -> ClientM r)+ -> IO Bool+ doComp = clientServerEq man ub nb+ ioprop = monadicIO . run + hspec $ do+ describe "Named and unnamed equivalency (client/server)" $ do+ it "Capture and NamedCapture are equivalent" $ do+ property $ \x -> ioprop $ doComp x (uCapture . runIdentity) (nCapture . ArgF)+ it "CaptureAll and NamedCaptureAll are equivalent" $ do+ property $ \x -> ioprop $ doComp x (uCaptureAll . def []) (nCaptureAll . ArgF)+ it "QueryFlag and NamedFlag are equivalent" $ do+ property $ \x -> ioprop $ doComp x (uFlag . def False) (nFlag . ArgF)+ it "Required QueryParam and NamedParam are equivalent" $ do+ property $ \x -> ioprop $ doComp x (uRParam . runIdentity) (nRParam . ArgF)+ it "Optional QueryParam and NamedParam are equivalent" $ do+ property $ \x -> ioprop $ doComp x (uOParam) (nOParam . ArgF)+ it "Required QueryHeader and NamedHeader are equivalent" $ do+ property $ \x -> ioprop $ doComp x (uRHeader . runIdentity) (nRHeader . ArgF)+ it "Optional QueryHeader and NamedHeader are equivalent" $ do+ property $ \x -> ioprop $ doComp x (uOHeader) (nOHeader . ArgF)+ cancel us+ cancel ns