diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for servant-client-named + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/servant-client-namedargs.cabal b/servant-client-namedargs.cabal new file mode 100644 --- /dev/null +++ b/servant-client-namedargs.cabal @@ -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 diff --git a/src/Servant/Client/NamedArgs.hs b/src/Servant/Client/NamedArgs.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/NamedArgs.hs @@ -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) diff --git a/test/ClientServerEquivalency.hs b/test/ClientServerEquivalency.hs new file mode 100644 --- /dev/null +++ b/test/ClientServerEquivalency.hs @@ -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