Merge pull request #1130 from phadej/refactor-servant-client
Refactor servant-client-core
This commit is contained in:
commit
e922b9898c
33 changed files with 252 additions and 509 deletions
2
.gitignore
vendored
2
.gitignore
vendored
|
@ -1,5 +1,5 @@
|
||||||
**/*/dist
|
**/*/dist
|
||||||
dist-newstyle
|
dist-*
|
||||||
.ghc.environment.*
|
.ghc.environment.*
|
||||||
/bin
|
/bin
|
||||||
/lib
|
/lib
|
||||||
|
|
|
@ -103,6 +103,7 @@ install:
|
||||||
- "echo 'allow-newer: servant-quickcheck:servant-server' >> cabal.project"
|
- "echo 'allow-newer: servant-quickcheck:servant-server' >> cabal.project"
|
||||||
- "echo 'allow-newer: servant-quickcheck:hspec' >> cabal.project"
|
- "echo 'allow-newer: servant-quickcheck:hspec' >> cabal.project"
|
||||||
- "echo 'allow-newer: servant-quickcheck:http-client' >> cabal.project"
|
- "echo 'allow-newer: servant-quickcheck:http-client' >> cabal.project"
|
||||||
|
- "echo 'reorder-goals: True' >> cabal.project"
|
||||||
- "echo 'optimization: False' >> cabal.project "
|
- "echo 'optimization: False' >> cabal.project "
|
||||||
- touch cabal.project.local
|
- touch cabal.project.local
|
||||||
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-db-sqlite-simple|cookbook-file-upload|cookbook-generic|cookbook-hoist-server-with-context|cookbook-https|cookbook-jwt-and-basic-auth|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-db-sqlite-simple|cookbook-file-upload|cookbook-generic|cookbook-hoist-server-with-context|cookbook-https|cookbook-jwt-and-basic-auth|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
||||||
|
@ -184,6 +185,7 @@ script:
|
||||||
- "echo 'allow-newer: servant-quickcheck:servant-server' >> cabal.project"
|
- "echo 'allow-newer: servant-quickcheck:servant-server' >> cabal.project"
|
||||||
- "echo 'allow-newer: servant-quickcheck:hspec' >> cabal.project"
|
- "echo 'allow-newer: servant-quickcheck:hspec' >> cabal.project"
|
||||||
- "echo 'allow-newer: servant-quickcheck:http-client' >> cabal.project"
|
- "echo 'allow-newer: servant-quickcheck:http-client' >> cabal.project"
|
||||||
|
- "echo 'reorder-goals: True' >> cabal.project"
|
||||||
- "echo 'optimization: False' >> cabal.project "
|
- "echo 'optimization: False' >> cabal.project "
|
||||||
- touch cabal.project.local
|
- touch cabal.project.local
|
||||||
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-db-sqlite-simple|cookbook-file-upload|cookbook-generic|cookbook-hoist-server-with-context|cookbook-https|cookbook-jwt-and-basic-auth|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-db-sqlite-simple|cookbook-file-upload|cookbook-generic|cookbook-hoist-server-with-context|cookbook-https|cookbook-jwt-and-basic-auth|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
||||||
|
|
13
Makefile
Normal file
13
Makefile
Normal file
|
@ -0,0 +1,13 @@
|
||||||
|
# With common maintenance tasks
|
||||||
|
|
||||||
|
all :
|
||||||
|
@echo "Don't try to make all at once!"
|
||||||
|
|
||||||
|
build-ghc :
|
||||||
|
cabal v2-build all
|
||||||
|
|
||||||
|
build-ghcjs :
|
||||||
|
cabal v2-build --builddir=dist-newstyle-ghcjs --project-file=cabal.ghcjs.project all
|
||||||
|
|
||||||
|
packdeps :
|
||||||
|
packdeps */*.cabal
|
|
@ -1,6 +1,4 @@
|
||||||
-- Using https://launchpad.net/~hvr/+archive/ubuntu/ghcjs
|
-- Using https://launchpad.net/~hvr/+archive/ubuntu/ghcjs
|
||||||
--
|
|
||||||
-- $ cabal new-build --project-file cabal.ghcjs.project all -w /opt/ghcjs/8.4/bin/ghcjs
|
|
||||||
|
|
||||||
packages:
|
packages:
|
||||||
servant/
|
servant/
|
||||||
|
@ -9,16 +7,3 @@ packages:
|
||||||
|
|
||||||
-- we need to tell cabal we are using GHCJS
|
-- we need to tell cabal we are using GHCJS
|
||||||
compiler: ghcjs
|
compiler: ghcjs
|
||||||
|
|
||||||
-- https://github.com/ghcjs/ghcjs/issues/665
|
|
||||||
constraints: primitive <0.6.4
|
|
||||||
|
|
||||||
-- ghcjs-base wants old aeson
|
|
||||||
allow-newer: ghcjs-base:aeson
|
|
||||||
|
|
||||||
-- https://github.com/nomeata/hackage-ghcjs-overlay
|
|
||||||
repository ghcjs-overlay
|
|
||||||
url: http://hackage-ghcjs-overlay.nomeata.de/
|
|
||||||
secure: True
|
|
||||||
root-keys:
|
|
||||||
key-threshold: 0
|
|
||||||
|
|
|
@ -33,6 +33,7 @@ packages:
|
||||||
|
|
||||||
tests: True
|
tests: True
|
||||||
optimization: False
|
optimization: False
|
||||||
|
reorder-goals: True
|
||||||
|
|
||||||
allow-newer:
|
allow-newer:
|
||||||
servant-js:base
|
servant-js:base
|
||||||
|
|
|
@ -99,8 +99,6 @@ test = case getSquare 42 of
|
||||||
putStrLn $ "ERROR: got pure result: " ++ show n
|
putStrLn $ "ERROR: got pure result: " ++ show n
|
||||||
Free (Throw err) ->
|
Free (Throw err) ->
|
||||||
putStrLn $ "ERROR: got error right away: " ++ show err
|
putStrLn $ "ERROR: got error right away: " ++ show err
|
||||||
Free (StreamingRequest _req _k) ->
|
|
||||||
putStrLn $ "ERROR: need to do streaming request" -- TODO: no Show Req :(
|
|
||||||
```
|
```
|
||||||
|
|
||||||
We are interested in `RunRequest`, that's what client should block on:
|
We are interested in `RunRequest`, that's what client should block on:
|
||||||
|
|
|
@ -36,16 +36,17 @@ library
|
||||||
Servant.Client.Free
|
Servant.Client.Free
|
||||||
Servant.Client.Generic
|
Servant.Client.Generic
|
||||||
Servant.Client.Core.Reexport
|
Servant.Client.Core.Reexport
|
||||||
Servant.Client.Core.Internal.Auth
|
Servant.Client.Core.Auth
|
||||||
Servant.Client.Core.Internal.BaseUrl
|
Servant.Client.Core.BaseUrl
|
||||||
Servant.Client.Core.Internal.BasicAuth
|
Servant.Client.Core.BasicAuth
|
||||||
Servant.Client.Core.Internal.ClientError
|
Servant.Client.Core.ClientError
|
||||||
Servant.Client.Core.Internal.ClientF
|
Servant.Client.Core.HasClient
|
||||||
Servant.Client.Core.Internal.Generic
|
Servant.Client.Core.Request
|
||||||
Servant.Client.Core.Internal.HasClient
|
Servant.Client.Core.Response
|
||||||
Servant.Client.Core.Internal.Request
|
Servant.Client.Core.RunClient
|
||||||
Servant.Client.Core.Internal.Response
|
|
||||||
Servant.Client.Core.Internal.RunClient
|
other-modules:
|
||||||
|
Servant.Client.Core.Internal
|
||||||
|
|
||||||
-- Bundled with GHC: Lower bound to not force re-installs
|
-- Bundled with GHC: Lower bound to not force re-installs
|
||||||
-- text and mtl are bundled starting with GHC-8.4
|
-- text and mtl are bundled starting with GHC-8.4
|
||||||
|
@ -76,7 +77,6 @@ library
|
||||||
, base64-bytestring >= 1.0.0.1 && < 1.1
|
, base64-bytestring >= 1.0.0.1 && < 1.1
|
||||||
, exceptions >= 0.10.0 && < 0.11
|
, exceptions >= 0.10.0 && < 0.11
|
||||||
, free >= 5.1 && < 5.2
|
, free >= 5.1 && < 5.2
|
||||||
, generics-sop >= 0.4.0.1 && < 0.5
|
|
||||||
, http-media >= 0.7.1.3 && < 0.8
|
, http-media >= 0.7.1.3 && < 0.8
|
||||||
, http-types >= 0.12.2 && < 0.13
|
, http-types >= 0.12.2 && < 0.13
|
||||||
, network-uri >= 2.6.1.0 && < 2.7
|
, network-uri >= 2.6.1.0 && < 2.7
|
||||||
|
|
|
@ -32,18 +32,20 @@ module Servant.Client.Core
|
||||||
, AuthClientData
|
, AuthClientData
|
||||||
|
|
||||||
-- * Generic Client
|
-- * Generic Client
|
||||||
, ClientLike(..)
|
|
||||||
, genericMkClientL
|
|
||||||
, genericMkClientP
|
|
||||||
, ServantError(..)
|
, ServantError(..)
|
||||||
, EmptyClient(..)
|
, EmptyClient(..)
|
||||||
|
|
||||||
|
|
||||||
-- * Response
|
-- * Response
|
||||||
, Response
|
, Response
|
||||||
, ResponseF (..)
|
, ResponseF (..)
|
||||||
, RunClient(..)
|
, RunClient(..)
|
||||||
, module Servant.Client.Core.Internal.BaseUrl
|
-- * BaseUrl
|
||||||
|
, BaseUrl (..)
|
||||||
|
, Scheme (..)
|
||||||
|
, showBaseUrl
|
||||||
|
, parseBaseUrl
|
||||||
|
, InvalidBaseUrlException (..)
|
||||||
|
|
||||||
-- ** Streaming
|
-- ** Streaming
|
||||||
, RunStreamingClient(..)
|
, RunStreamingClient(..)
|
||||||
, StreamingResponse
|
, StreamingResponse
|
||||||
|
@ -56,14 +58,13 @@ module Servant.Client.Core
|
||||||
, setRequestBodyLBS
|
, setRequestBodyLBS
|
||||||
, setRequestBody
|
, setRequestBody
|
||||||
) where
|
) where
|
||||||
import Servant.Client.Core.Internal.Auth
|
import Servant.Client.Core.Auth
|
||||||
import Servant.Client.Core.Internal.BaseUrl
|
import Servant.Client.Core.BaseUrl
|
||||||
(BaseUrl (..), InvalidBaseUrlException, Scheme (..),
|
(BaseUrl (..), InvalidBaseUrlException (..), Scheme (..),
|
||||||
parseBaseUrl, showBaseUrl)
|
parseBaseUrl, showBaseUrl)
|
||||||
import Servant.Client.Core.Internal.BasicAuth
|
import Servant.Client.Core.BasicAuth
|
||||||
import Servant.Client.Core.Internal.Generic
|
import Servant.Client.Core.ClientError
|
||||||
import Servant.Client.Core.Internal.HasClient
|
import Servant.Client.Core.HasClient
|
||||||
import Servant.Client.Core.Internal.Request
|
import Servant.Client.Core.Request
|
||||||
import Servant.Client.Core.Internal.Response
|
import Servant.Client.Core.Response
|
||||||
import Servant.Client.Core.Internal.ClientError
|
import Servant.Client.Core.RunClient
|
||||||
import Servant.Client.Core.Internal.RunClient
|
|
||||||
|
|
|
@ -4,9 +4,13 @@
|
||||||
|
|
||||||
-- | Authentication for clients
|
-- | Authentication for clients
|
||||||
|
|
||||||
module Servant.Client.Core.Internal.Auth where
|
module Servant.Client.Core.Auth (
|
||||||
|
AuthClientData,
|
||||||
|
AuthenticatedRequest (..),
|
||||||
|
mkAuthenticatedRequest,
|
||||||
|
) where
|
||||||
|
|
||||||
import Servant.Client.Core.Internal.Request
|
import Servant.Client.Core.Request
|
||||||
(Request)
|
(Request)
|
||||||
|
|
||||||
-- | For a resource protected by authentication (e.g. AuthProtect), we need
|
-- | For a resource protected by authentication (e.g. AuthProtect), we need
|
|
@ -2,7 +2,13 @@
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE DeriveLift #-}
|
{-# LANGUAGE DeriveLift #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
module Servant.Client.Core.Internal.BaseUrl where
|
module Servant.Client.Core.BaseUrl (
|
||||||
|
BaseUrl (..),
|
||||||
|
Scheme (..),
|
||||||
|
showBaseUrl,
|
||||||
|
parseBaseUrl,
|
||||||
|
InvalidBaseUrlException (..),
|
||||||
|
) where
|
||||||
|
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
(NFData (..))
|
(NFData (..))
|
|
@ -3,8 +3,9 @@
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
{-# LANGUAGE TypeSynonymInstances #-}
|
||||||
|
|
||||||
-- | Basic Authentication for clients
|
-- | Basic Authentication for clients
|
||||||
|
module Servant.Client.Core.BasicAuth (
|
||||||
module Servant.Client.Core.Internal.BasicAuth where
|
basicAuthReq,
|
||||||
|
) where
|
||||||
|
|
||||||
import Data.ByteString.Base64
|
import Data.ByteString.Base64
|
||||||
(encode)
|
(encode)
|
||||||
|
@ -14,7 +15,7 @@ import Data.Text.Encoding
|
||||||
(decodeUtf8)
|
(decodeUtf8)
|
||||||
import Servant.API.BasicAuth
|
import Servant.API.BasicAuth
|
||||||
(BasicAuthData (BasicAuthData))
|
(BasicAuthData (BasicAuthData))
|
||||||
import Servant.Client.Core.Internal.Request
|
import Servant.Client.Core.Request
|
||||||
(Request, addHeader)
|
(Request, addHeader)
|
||||||
|
|
||||||
-- | Authenticate a request using Basic Authentication
|
-- | Authenticate a request using Basic Authentication
|
|
@ -8,7 +8,9 @@
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
module Servant.Client.Core.Internal.ClientError where
|
module Servant.Client.Core.ClientError (
|
||||||
|
ServantError (..),
|
||||||
|
) where
|
||||||
|
|
||||||
import Prelude ()
|
import Prelude ()
|
||||||
import Prelude.Compat
|
import Prelude.Compat
|
||||||
|
@ -26,13 +28,15 @@ import Data.Typeable
|
||||||
(Typeable, typeOf)
|
(Typeable, typeOf)
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
(Generic)
|
(Generic)
|
||||||
import Network.HTTP.Media (MediaType)
|
import Network.HTTP.Media
|
||||||
|
(MediaType)
|
||||||
import Network.HTTP.Types ()
|
import Network.HTTP.Types ()
|
||||||
|
|
||||||
import Servant.Client.Core.Internal.BaseUrl
|
import Servant.Client.Core.BaseUrl
|
||||||
import Servant.Client.Core.Internal.Request
|
import Servant.Client.Core.Internal
|
||||||
import Servant.Client.Core.Internal.Response
|
(mediaTypeRnf)
|
||||||
|
import Servant.Client.Core.Request
|
||||||
|
import Servant.Client.Core.Response
|
||||||
|
|
||||||
|
|
||||||
-- | A type representing possible errors in a request
|
-- | A type representing possible errors in a request
|
|
@ -11,11 +11,17 @@
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
module Servant.Client.Core.Internal.HasClient where
|
module Servant.Client.Core.HasClient (
|
||||||
|
clientIn,
|
||||||
|
HasClient (..),
|
||||||
|
EmptyClient (..),
|
||||||
|
) where
|
||||||
|
|
||||||
import Prelude ()
|
import Prelude ()
|
||||||
import Prelude.Compat
|
import Prelude.Compat
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
|
(unless)
|
||||||
import qualified Data.ByteString.Lazy as BL
|
import qualified Data.ByteString.Lazy as BL
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
(toList)
|
(toList)
|
||||||
|
@ -25,6 +31,9 @@ import Data.Proxy
|
||||||
(Proxy (Proxy))
|
(Proxy (Proxy))
|
||||||
import Data.Sequence
|
import Data.Sequence
|
||||||
(fromList)
|
(fromList)
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import Network.HTTP.Media
|
||||||
|
(MediaType, matches, parseAccept, (//))
|
||||||
import Data.String
|
import Data.String
|
||||||
(fromString)
|
(fromString)
|
||||||
import Data.Text
|
import Data.Text
|
||||||
|
@ -48,12 +57,12 @@ import Servant.API.ContentTypes
|
||||||
import Servant.API.Modifiers
|
import Servant.API.Modifiers
|
||||||
(FoldRequired, RequiredArgument, foldRequiredArgument)
|
(FoldRequired, RequiredArgument, foldRequiredArgument)
|
||||||
|
|
||||||
import Servant.Client.Core.Internal.Auth
|
import Servant.Client.Core.Auth
|
||||||
import Servant.Client.Core.Internal.BasicAuth
|
import Servant.Client.Core.BasicAuth
|
||||||
import Servant.Client.Core.Internal.ClientError
|
import Servant.Client.Core.ClientError
|
||||||
import Servant.Client.Core.Internal.Request
|
import Servant.Client.Core.Request
|
||||||
import Servant.Client.Core.Internal.Response
|
import Servant.Client.Core.Response
|
||||||
import Servant.Client.Core.Internal.RunClient
|
import Servant.Client.Core.RunClient
|
||||||
|
|
||||||
-- * Accessing APIs as a Client
|
-- * Accessing APIs as a Client
|
||||||
|
|
||||||
|
@ -627,6 +636,7 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
|
||||||
hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
|
hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
{- Note [Non-Empty Content Types]
|
{- Note [Non-Empty Content Types]
|
||||||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||||
Rather than have
|
Rather than have
|
||||||
|
@ -642,3 +652,27 @@ non-empty lists, but is otherwise more specific, no instance will be overall
|
||||||
more specific. This in turn generally means adding yet another instance (one
|
more specific. This in turn generally means adding yet another instance (one
|
||||||
for empty and one for non-empty lists).
|
for empty and one for non-empty lists).
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
|
-- helpers
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
checkContentTypeHeader :: RunClient m => Response -> m MediaType
|
||||||
|
checkContentTypeHeader response =
|
||||||
|
case lookup "Content-Type" $ toList $ responseHeaders response of
|
||||||
|
Nothing -> return $ "application"//"octet-stream"
|
||||||
|
Just t -> case parseAccept t of
|
||||||
|
Nothing -> throwServantError $ InvalidContentTypeHeader response
|
||||||
|
Just t' -> return t'
|
||||||
|
|
||||||
|
decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
|
||||||
|
=> Response -> Proxy ct -> m a
|
||||||
|
decodedAs response ct = do
|
||||||
|
responseContentType <- checkContentTypeHeader response
|
||||||
|
unless (any (matches responseContentType) accept) $
|
||||||
|
throwServantError $ UnsupportedContentType responseContentType response
|
||||||
|
case mimeUnrender ct $ responseBody response of
|
||||||
|
Left err -> throwServantError $ DecodeFailure (T.pack err) response
|
||||||
|
Right val -> return val
|
||||||
|
where
|
||||||
|
accept = toList $ contentTypes ct
|
12
servant-client-core/src/Servant/Client/Core/Internal.hs
Normal file
12
servant-client-core/src/Servant/Client/Core/Internal.hs
Normal file
|
@ -0,0 +1,12 @@
|
||||||
|
module Servant.Client.Core.Internal where
|
||||||
|
|
||||||
|
import Control.DeepSeq
|
||||||
|
(rnf)
|
||||||
|
import Network.HTTP.Media
|
||||||
|
(MediaType, mainType, parameters, subType)
|
||||||
|
|
||||||
|
mediaTypeRnf :: MediaType -> ()
|
||||||
|
mediaTypeRnf mt =
|
||||||
|
rnf (mainType mt) `seq`
|
||||||
|
rnf (subType mt) `seq`
|
||||||
|
rnf (parameters mt)
|
|
@ -1,12 +0,0 @@
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
module Servant.Client.Core.Internal.ClientF where
|
|
||||||
|
|
||||||
import Servant.Client.Core.Internal.Request
|
|
||||||
import Servant.Client.Core.Internal.Response
|
|
||||||
import Servant.Client.Core.Internal.ClientError
|
|
||||||
|
|
||||||
data ClientF a
|
|
||||||
= RunRequest Request (Response -> a)
|
|
||||||
| StreamingRequest Request (StreamingResponse -> a)
|
|
||||||
| Throw ServantError
|
|
||||||
deriving (Functor)
|
|
|
@ -1,155 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DefaultSignatures #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
|
|
||||||
module Servant.Client.Core.Internal.Generic where
|
|
||||||
|
|
||||||
import Generics.SOP
|
|
||||||
(Code, Generic, I (..), NP (..), NS (Z), SOP (..), to)
|
|
||||||
import Servant.API
|
|
||||||
((:<|>) (..))
|
|
||||||
|
|
||||||
-- | This class allows us to match client structure with client functions
|
|
||||||
-- produced with 'client' without explicit pattern-matching.
|
|
||||||
--
|
|
||||||
-- The client structure needs a 'Generics.SOP.Generic' instance.
|
|
||||||
--
|
|
||||||
-- Example:
|
|
||||||
--
|
|
||||||
-- > type API
|
|
||||||
-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int
|
|
||||||
-- > :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int]
|
|
||||||
-- > :<|> Capture "nested" Int :> NestedAPI
|
|
||||||
-- >
|
|
||||||
-- > type NestedAPI
|
|
||||||
-- > = Get '[JSON] String
|
|
||||||
-- > :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] ()
|
|
||||||
-- >
|
|
||||||
-- > data APIClient = APIClient
|
|
||||||
-- > { getFoo :: Int -> ClientM Int
|
|
||||||
-- > , postBar :: Maybe Char -> Maybe String -> ClientM [Int]
|
|
||||||
-- > , mkNestedClient :: Int -> NestedClient
|
|
||||||
-- > } deriving GHC.Generic
|
|
||||||
-- >
|
|
||||||
-- > instance Generics.SOP.Generic APIClient
|
|
||||||
-- > instance (Client API ~ client) => ClientLike client APIClient
|
|
||||||
-- >
|
|
||||||
-- > data NestedClient = NestedClient
|
|
||||||
-- > { getString :: ClientM String
|
|
||||||
-- > , postBaz :: Maybe Char -> ClientM ()
|
|
||||||
-- > } deriving GHC.Generic
|
|
||||||
-- >
|
|
||||||
-- > instance Generics.SOP.Generic NestedClient
|
|
||||||
-- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient
|
|
||||||
-- >
|
|
||||||
-- > mkAPIClient :: APIClient
|
|
||||||
-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
|
|
||||||
--
|
|
||||||
-- By default, left-nested alternatives are expanded:
|
|
||||||
--
|
|
||||||
-- > type API1
|
|
||||||
-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int
|
|
||||||
-- > :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String
|
|
||||||
-- >
|
|
||||||
-- > type API2
|
|
||||||
-- > = "baz" :> QueryParam "c" Char :> Post '[JSON] ()
|
|
||||||
-- >
|
|
||||||
-- > type API = API1 :<|> API2
|
|
||||||
-- >
|
|
||||||
-- > data APIClient = APIClient
|
|
||||||
-- > { getFoo :: Int -> ClientM Int
|
|
||||||
-- > , postBar :: Maybe Char -> ClientM String
|
|
||||||
-- > , postBaz :: Maybe Char -> ClientM ()
|
|
||||||
-- > } deriving GHC.Generic
|
|
||||||
-- >
|
|
||||||
-- > instance Generics.SOP.Generic APIClient
|
|
||||||
-- > instance (Client API ~ client) => ClientLike client APIClient
|
|
||||||
-- >
|
|
||||||
-- > mkAPIClient :: APIClient
|
|
||||||
-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
|
|
||||||
--
|
|
||||||
-- If you want to define client for @API1@ as a separate data structure,
|
|
||||||
-- you can use 'genericMkClientP':
|
|
||||||
--
|
|
||||||
-- > data APIClient1 = APIClient1
|
|
||||||
-- > { getFoo :: Int -> ClientM Int
|
|
||||||
-- > , postBar :: Maybe Char -> ClientM String
|
|
||||||
-- > } deriving GHC.Generic
|
|
||||||
-- >
|
|
||||||
-- > instance Generics.SOP.Generic APIClient1
|
|
||||||
-- > instance (Client API1 ~ client) => ClientLike client APIClient1
|
|
||||||
-- >
|
|
||||||
-- > data APIClient = APIClient
|
|
||||||
-- > { mkAPIClient1 :: APIClient1
|
|
||||||
-- > , postBaz :: Maybe Char -> ClientM ()
|
|
||||||
-- > } deriving GHC.Generic
|
|
||||||
-- >
|
|
||||||
-- > instance Generics.SOP.Generic APIClient
|
|
||||||
-- > instance (Client API ~ client) => ClientLike client APIClient where
|
|
||||||
-- > mkClient = genericMkClientP
|
|
||||||
-- >
|
|
||||||
-- > mkAPIClient :: APIClient
|
|
||||||
-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
|
|
||||||
class ClientLike client custom where
|
|
||||||
mkClient :: client -> custom
|
|
||||||
default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)
|
|
||||||
=> client -> custom
|
|
||||||
mkClient = genericMkClientL
|
|
||||||
|
|
||||||
instance ClientLike client custom
|
|
||||||
=> ClientLike (a -> client) (a -> custom) where
|
|
||||||
mkClient c = mkClient . c
|
|
||||||
|
|
||||||
-- | Match client structure with client functions, regarding left-nested API clients
|
|
||||||
-- as separate data structures.
|
|
||||||
class GClientLikeP client xs where
|
|
||||||
gMkClientP :: client -> NP I xs
|
|
||||||
|
|
||||||
instance (GClientLikeP b (y ': xs), ClientLike a x)
|
|
||||||
=> GClientLikeP (a :<|> b) (x ': y ': xs) where
|
|
||||||
gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b
|
|
||||||
|
|
||||||
instance ClientLike a x => GClientLikeP a '[x] where
|
|
||||||
gMkClientP a = I (mkClient a) :* Nil
|
|
||||||
|
|
||||||
-- | Match client structure with client functions, expanding left-nested API clients
|
|
||||||
-- in the same structure.
|
|
||||||
class GClientLikeL (xs :: [*]) (ys :: [*]) where
|
|
||||||
gMkClientL :: NP I xs -> NP I ys
|
|
||||||
|
|
||||||
instance GClientLikeL '[] '[] where
|
|
||||||
gMkClientL Nil = Nil
|
|
||||||
|
|
||||||
instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where
|
|
||||||
gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs
|
|
||||||
|
|
||||||
type family ClientList (client :: *) (acc :: [*]) :: [*] where
|
|
||||||
ClientList (a :<|> b) acc = ClientList a (ClientList b acc)
|
|
||||||
ClientList a acc = a ': acc
|
|
||||||
|
|
||||||
class GClientList client (acc :: [*]) where
|
|
||||||
gClientList :: client -> NP I acc -> NP I (ClientList client acc)
|
|
||||||
|
|
||||||
instance (GClientList b acc, GClientList a (ClientList b acc))
|
|
||||||
=> GClientList (a :<|> b) acc where
|
|
||||||
gClientList (a :<|> b) acc = gClientList a (gClientList b acc)
|
|
||||||
|
|
||||||
instance {-# OVERLAPPABLE #-} (ClientList client acc ~ (client ': acc))
|
|
||||||
=> GClientList client acc where
|
|
||||||
gClientList c acc = I c :* acc
|
|
||||||
|
|
||||||
-- | Generate client structure from client type, expanding left-nested API (done by default).
|
|
||||||
genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)
|
|
||||||
=> client -> custom
|
|
||||||
genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil
|
|
||||||
|
|
||||||
-- | Generate client structure from client type, regarding left-nested API clients as separate data structures.
|
|
||||||
genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs)
|
|
||||||
=> client -> custom
|
|
||||||
genericMkClientP = to . SOP . Z . gMkClientP
|
|
||||||
|
|
|
@ -1,67 +0,0 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
-- | Types for possible backends to run client-side `Request` queries
|
|
||||||
module Servant.Client.Core.Internal.RunClient where
|
|
||||||
|
|
||||||
import Prelude ()
|
|
||||||
import Prelude.Compat
|
|
||||||
|
|
||||||
import Control.Monad
|
|
||||||
(unless)
|
|
||||||
import Control.Monad.Free
|
|
||||||
(Free (..), liftF)
|
|
||||||
import Data.Foldable
|
|
||||||
(toList)
|
|
||||||
import Data.Proxy
|
|
||||||
(Proxy)
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Network.HTTP.Media
|
|
||||||
(MediaType, matches, parseAccept, (//))
|
|
||||||
import Servant.API
|
|
||||||
(MimeUnrender, contentTypes, mimeUnrender)
|
|
||||||
|
|
||||||
import Servant.Client.Core.Internal.ClientF
|
|
||||||
import Servant.Client.Core.Internal.Request
|
|
||||||
import Servant.Client.Core.Internal.Response
|
|
||||||
import Servant.Client.Core.Internal.ClientError
|
|
||||||
|
|
||||||
class Monad m => RunClient m where
|
|
||||||
-- | How to make a request.
|
|
||||||
runRequest :: Request -> m Response
|
|
||||||
throwServantError :: ServantError -> m a
|
|
||||||
|
|
||||||
class RunClient m => RunStreamingClient m where
|
|
||||||
withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a
|
|
||||||
|
|
||||||
checkContentTypeHeader :: RunClient m => Response -> m MediaType
|
|
||||||
checkContentTypeHeader response =
|
|
||||||
case lookup "Content-Type" $ toList $ responseHeaders response of
|
|
||||||
Nothing -> return $ "application"//"octet-stream"
|
|
||||||
Just t -> case parseAccept t of
|
|
||||||
Nothing -> throwServantError $ InvalidContentTypeHeader response
|
|
||||||
Just t' -> return t'
|
|
||||||
|
|
||||||
decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
|
|
||||||
=> Response -> Proxy ct -> m a
|
|
||||||
decodedAs response contentType = do
|
|
||||||
responseContentType <- checkContentTypeHeader response
|
|
||||||
unless (any (matches responseContentType) accept) $
|
|
||||||
throwServantError $ UnsupportedContentType responseContentType response
|
|
||||||
case mimeUnrender contentType $ responseBody response of
|
|
||||||
Left err -> throwServantError $ DecodeFailure (T.pack err) response
|
|
||||||
Right val -> return val
|
|
||||||
where
|
|
||||||
accept = toList $ contentTypes contentType
|
|
||||||
|
|
||||||
instance ClientF ~ f => RunClient (Free f) where
|
|
||||||
runRequest req = liftF (RunRequest req id)
|
|
||||||
throwServantError = liftF . Throw
|
|
||||||
|
|
||||||
{-
|
|
||||||
Free and streaming?
|
|
||||||
instance ClientF ~ f => RunStreamingClient (Free f) where
|
|
||||||
streamingRequest req = liftF (StreamingRequest req id)
|
|
||||||
-}
|
|
|
@ -11,10 +11,7 @@ module Servant.Client.Core.Reexport
|
||||||
, StreamingResponse
|
, StreamingResponse
|
||||||
, ResponseF(..)
|
, ResponseF(..)
|
||||||
|
|
||||||
-- * Generic Client
|
-- * Data types
|
||||||
, ClientLike(..)
|
|
||||||
, genericMkClientL
|
|
||||||
, genericMkClientP
|
|
||||||
, ServantError(..)
|
, ServantError(..)
|
||||||
, EmptyClient(..)
|
, EmptyClient(..)
|
||||||
|
|
||||||
|
@ -27,8 +24,7 @@ module Servant.Client.Core.Reexport
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
|
||||||
import Servant.Client.Core.Internal.BaseUrl
|
import Servant.Client.Core.BaseUrl
|
||||||
import Servant.Client.Core.Internal.Generic
|
import Servant.Client.Core.HasClient
|
||||||
import Servant.Client.Core.Internal.HasClient
|
import Servant.Client.Core.Response
|
||||||
import Servant.Client.Core.Internal.Response
|
import Servant.Client.Core.ClientError
|
||||||
import Servant.Client.Core.Internal.ClientError
|
|
||||||
|
|
|
@ -8,8 +8,18 @@
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
module Servant.Client.Core.Request (
|
||||||
module Servant.Client.Core.Internal.Request where
|
Request,
|
||||||
|
RequestF (..),
|
||||||
|
RequestBody (..),
|
||||||
|
defaultRequest,
|
||||||
|
-- ** Modifiers
|
||||||
|
addHeader,
|
||||||
|
appendToPath,
|
||||||
|
appendToQueryString,
|
||||||
|
setRequestBody,
|
||||||
|
setRequestBodyLBS,
|
||||||
|
) where
|
||||||
|
|
||||||
import Prelude ()
|
import Prelude ()
|
||||||
import Prelude.Compat
|
import Prelude.Compat
|
||||||
|
@ -37,18 +47,14 @@ import Data.Typeable
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
(Generic)
|
(Generic)
|
||||||
import Network.HTTP.Media
|
import Network.HTTP.Media
|
||||||
(MediaType, mainType, parameters, subType)
|
(MediaType)
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
(Header, HeaderName, HttpVersion (..), Method, QueryItem,
|
(Header, HeaderName, HttpVersion (..), Method, QueryItem,
|
||||||
http11, methodGet)
|
http11, methodGet)
|
||||||
import Servant.API
|
import Servant.API
|
||||||
(ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
|
(ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
|
||||||
|
|
||||||
mediaTypeRnf :: MediaType -> ()
|
import Servant.Client.Core.Internal (mediaTypeRnf)
|
||||||
mediaTypeRnf mt =
|
|
||||||
rnf (mainType mt) `seq`
|
|
||||||
rnf (subType mt) `seq`
|
|
||||||
rnf (parameters mt)
|
|
||||||
|
|
||||||
data RequestF body path = Request
|
data RequestF body path = Request
|
||||||
{ requestPath :: path
|
{ requestPath :: path
|
||||||
|
@ -84,7 +90,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where
|
||||||
|
|
||||||
type Request = RequestF RequestBody Builder.Builder
|
type Request = RequestF RequestBody Builder.Builder
|
||||||
|
|
||||||
-- | The request body. A replica of the @http-client@ @RequestBody@.
|
-- | The request body. R replica of the @http-client@ @RequestBody@.
|
||||||
data RequestBody
|
data RequestBody
|
||||||
= RequestBodyLBS LBS.ByteString
|
= RequestBodyLBS LBS.ByteString
|
||||||
| RequestBodyBS BS.ByteString
|
| RequestBodyBS BS.ByteString
|
||||||
|
@ -95,6 +101,11 @@ instance Show RequestBody where
|
||||||
showsPrec d (RequestBodyLBS lbs) = showParen (d > 10)
|
showsPrec d (RequestBodyLBS lbs) = showParen (d > 10)
|
||||||
$ showString "RequestBodyLBS "
|
$ showString "RequestBodyLBS "
|
||||||
. showsPrec 11 lbs
|
. showsPrec 11 lbs
|
||||||
|
showsPrec d (RequestBodyBS bs) = showParen (d > 10)
|
||||||
|
$ showString "RequestBodyBS "
|
||||||
|
. showsPrec 11 bs
|
||||||
|
showsPrec d (RequestBodySource _) = showParen (d > 10)
|
||||||
|
$ showString "RequestBodySource <IO>"
|
||||||
|
|
||||||
-- A GET request to the top-level path
|
-- A GET request to the top-level path
|
||||||
defaultRequest :: Request
|
defaultRequest :: Request
|
|
@ -8,7 +8,11 @@
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
module Servant.Client.Core.Internal.Response where
|
module Servant.Client.Core.Response (
|
||||||
|
Response,
|
||||||
|
StreamingResponse,
|
||||||
|
ResponseF (..),
|
||||||
|
) where
|
||||||
|
|
||||||
import Prelude ()
|
import Prelude ()
|
||||||
import Prelude.Compat
|
import Prelude.Compat
|
46
servant-client-core/src/Servant/Client/Core/RunClient.hs
Normal file
46
servant-client-core/src/Servant/Client/Core/RunClient.hs
Normal file
|
@ -0,0 +1,46 @@
|
||||||
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
-- | Types for possible backends to run client-side `Request` queries
|
||||||
|
module Servant.Client.Core.RunClient (
|
||||||
|
RunClient (..),
|
||||||
|
RunStreamingClient (..),
|
||||||
|
ClientF (..),
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Prelude ()
|
||||||
|
import Prelude.Compat
|
||||||
|
|
||||||
|
import Control.Monad.Free
|
||||||
|
(Free (..), liftF)
|
||||||
|
|
||||||
|
import Servant.Client.Core.ClientError
|
||||||
|
import Servant.Client.Core.Request
|
||||||
|
import Servant.Client.Core.Response
|
||||||
|
|
||||||
|
class Monad m => RunClient m where
|
||||||
|
-- | How to make a request.
|
||||||
|
runRequest :: Request -> m Response
|
||||||
|
throwServantError :: ServantError -> m a
|
||||||
|
|
||||||
|
class RunClient m => RunStreamingClient m where
|
||||||
|
withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
|
-- Free
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | 'ClientF' cannot stream.
|
||||||
|
--
|
||||||
|
-- Compare to 'RunClient'.
|
||||||
|
data ClientF a
|
||||||
|
= RunRequest Request (Response -> a)
|
||||||
|
| Throw ServantError
|
||||||
|
deriving (Functor)
|
||||||
|
|
||||||
|
instance ClientF ~ f => RunClient (Free f) where
|
||||||
|
runRequest req = liftF (RunRequest req id)
|
||||||
|
throwServantError = liftF . Throw
|
|
@ -11,8 +11,8 @@ import Control.Monad.Free
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
(Proxy (..))
|
(Proxy (..))
|
||||||
import Servant.Client.Core
|
import Servant.Client.Core
|
||||||
import Servant.Client.Core.Internal.ClientF
|
|
||||||
import Servant.Client.Core.Reexport
|
import Servant.Client.Core.Reexport
|
||||||
|
import Servant.Client.Core.RunClient
|
||||||
|
|
||||||
client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api
|
client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api
|
||||||
client api = api `clientIn` (Proxy :: Proxy (Free ClientF))
|
client api = api `clientIn` (Proxy :: Proxy (Free ClientF))
|
||||||
|
|
|
@ -8,7 +8,7 @@ import Prelude.Compat
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
|
|
||||||
import Servant.Client.Core.Internal.BaseUrl
|
import Servant.Client.Core.BaseUrl
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
|
|
|
@ -36,10 +36,10 @@ library
|
||||||
Servant.Client.Ghcjs
|
Servant.Client.Ghcjs
|
||||||
Servant.Client.Internal.XhrClient
|
Servant.Client.Internal.XhrClient
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.7 && < 4.12
|
base >= 4.11 && < 4.12
|
||||||
, bytestring >= 0.10 && < 0.11
|
, bytestring >= 0.10 && < 0.11
|
||||||
, case-insensitive >= 1.2.0.0 && < 1.3.0.0
|
, case-insensitive >= 1.2.0.0 && < 1.3.0.0
|
||||||
, containers >= 0.5 && < 0.6
|
, containers >= 0.5 && < 0.7
|
||||||
, exceptions >= 0.8 && < 0.11
|
, exceptions >= 0.8 && < 0.11
|
||||||
, ghcjs-base >= 0.2.0.0 && < 0.3.0.0
|
, ghcjs-base >= 0.2.0.0 && < 0.3.0.0
|
||||||
, ghcjs-prim >= 0.1.0.0 && < 0.2.0.0
|
, ghcjs-prim >= 0.1.0.0 && < 0.2.0.0
|
||||||
|
@ -47,7 +47,7 @@ library
|
||||||
, http-types >= 0.12 && < 0.13
|
, http-types >= 0.12 && < 0.13
|
||||||
, monad-control >= 1.0.0.4 && < 1.1
|
, monad-control >= 1.0.0.4 && < 1.1
|
||||||
, mtl >= 2.2.2 && < 2.3
|
, mtl >= 2.2.2 && < 2.3
|
||||||
, semigroupoids >= 4.3 && < 5.3
|
, semigroupoids >= 5.3 && < 5.4
|
||||||
, string-conversions >= 0.3 && < 0.5
|
, string-conversions >= 0.3 && < 0.5
|
||||||
, transformers >= 0.3 && < 0.6
|
, transformers >= 0.3 && < 0.6
|
||||||
, transformers-base >= 0.4.4 && < 0.5
|
, transformers-base >= 0.4.4 && < 0.5
|
||||||
|
@ -55,10 +55,9 @@ library
|
||||||
|
|
||||||
-- strict, as we re-export stuff
|
-- strict, as we re-export stuff
|
||||||
build-depends:
|
build-depends:
|
||||||
servant-client-core == 0.15
|
servant == 0.15.*,
|
||||||
|
servant-client-core == 0.15.*
|
||||||
|
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall -Wno-redundant-constraints
|
||||||
if impl(ghc >= 8.0)
|
|
||||||
ghc-options: -Wno-redundant-constraints
|
|
||||||
|
|
|
@ -18,35 +18,48 @@ import Control.Arrow
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Base (MonadBase (..))
|
import Control.Monad.Base
|
||||||
import Control.Monad.Catch (MonadCatch, MonadThrow)
|
(MonadBase (..))
|
||||||
import Control.Monad.Error.Class (MonadError (..))
|
import Control.Monad.Catch
|
||||||
|
(MonadCatch, MonadThrow)
|
||||||
|
import Control.Monad.Error.Class
|
||||||
|
(MonadError (..))
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
import Control.Monad.Trans.Control
|
||||||
|
(MonadBaseControl (..))
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Data.ByteString.Builder (toLazyByteString)
|
import Data.Bifunctor
|
||||||
|
(bimap)
|
||||||
|
import Data.ByteString.Builder
|
||||||
|
(toLazyByteString)
|
||||||
import qualified Data.ByteString.Char8 as BS
|
import qualified Data.ByteString.Char8 as BS
|
||||||
import qualified Data.ByteString.Lazy as BL
|
import qualified Data.ByteString.Lazy as BL
|
||||||
import Data.CaseInsensitive
|
import Data.CaseInsensitive
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Foldable (toList)
|
import Data.Foldable
|
||||||
import Data.Functor.Alt (Alt (..))
|
(toList)
|
||||||
import Data.IORef (modifyIORef, newIORef, readIORef)
|
import Data.Functor.Alt
|
||||||
import Data.Proxy (Proxy (..))
|
(Alt (..))
|
||||||
|
import Data.Proxy
|
||||||
|
(Proxy (..))
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
import Data.String.Conversions
|
import Data.String.Conversions
|
||||||
import Data.Typeable (Typeable)
|
import Data.Typeable
|
||||||
|
(Typeable)
|
||||||
import Foreign.StablePtr
|
import Foreign.StablePtr
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import qualified GHCJS.Buffer as Buffer
|
import qualified GHCJS.Buffer as Buffer
|
||||||
import GHCJS.Foreign.Callback
|
import GHCJS.Foreign.Callback
|
||||||
import GHCJS.Prim
|
import GHCJS.Prim
|
||||||
import GHCJS.Types
|
import GHCJS.Types
|
||||||
import JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer )
|
import JavaScript.TypedArray.ArrayBuffer
|
||||||
|
(ArrayBuffer)
|
||||||
import JavaScript.Web.Location
|
import JavaScript.Web.Location
|
||||||
import Network.HTTP.Media (renderHeader)
|
import Network.HTTP.Media
|
||||||
|
(renderHeader)
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Servant.Client.Core
|
import Servant.Client.Core
|
||||||
|
import qualified Servant.Types.SourceT as S
|
||||||
|
|
||||||
newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
|
newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
|
||||||
|
|
||||||
|
@ -110,9 +123,6 @@ instance RunClient ClientM where
|
||||||
runRequest = performRequest
|
runRequest = performRequest
|
||||||
throwServantError = throwError
|
throwServantError = throwError
|
||||||
|
|
||||||
instance ClientLike (ClientM a) (ClientM a) where
|
|
||||||
mkClient = id
|
|
||||||
|
|
||||||
runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a)
|
runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a)
|
||||||
runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm
|
runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm
|
||||||
|
|
||||||
|
@ -150,8 +160,9 @@ performRequest req = do
|
||||||
resp <- toResponse xhr
|
resp <- toResponse xhr
|
||||||
|
|
||||||
let status = statusCode (responseStatusCode resp)
|
let status = statusCode (responseStatusCode resp)
|
||||||
unless (status >= 200 && status < 300) $
|
unless (status >= 200 && status < 300) $ do
|
||||||
throwError $ FailureResponse resp
|
let f b = (burl, BL.toStrict $ toLazyByteString b)
|
||||||
|
throwError $ FailureResponse (bimap (const ()) f req) resp
|
||||||
|
|
||||||
pure resp
|
pure resp
|
||||||
|
|
||||||
|
@ -272,24 +283,15 @@ toBody request = case requestBody request of
|
||||||
go x = case x of
|
go x = case x of
|
||||||
RequestBodyLBS x -> return $ mBody $ BL.toStrict x
|
RequestBodyLBS x -> return $ mBody $ BL.toStrict x
|
||||||
RequestBodyBS x -> return $ mBody x
|
RequestBodyBS x -> return $ mBody x
|
||||||
RequestBodyBuilder _ x -> return $ mBody $ BL.toStrict $ toLazyByteString x
|
RequestBodySource xs -> runExceptT (S.runSourceT xs) >>= \e -> case e of
|
||||||
RequestBodyStream _ x -> mBody <$> readBody x
|
Left err -> fail err
|
||||||
RequestBodyStreamChunked x -> mBody <$> readBody x
|
Right bss -> return $ mBody $ BL.toStrict $ mconcat bss
|
||||||
RequestBodyIO x -> x >>= go
|
|
||||||
|
|
||||||
mBody :: BS.ByteString -> ArrayBuffer
|
mBody :: BS.ByteString -> ArrayBuffer
|
||||||
mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer
|
mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer
|
||||||
where
|
where
|
||||||
(buffer, offset, len) = Buffer.fromByteString bs
|
(buffer, offset, len) = Buffer.fromByteString bs
|
||||||
|
|
||||||
readBody :: ((IO BS.ByteString -> IO ()) -> IO a) -> IO BS.ByteString
|
|
||||||
readBody writer = do
|
|
||||||
m <- newIORef mempty
|
|
||||||
_ <- writer (\bsAct -> do
|
|
||||||
bs <- bsAct
|
|
||||||
modifyIORef m (<> bs))
|
|
||||||
readIORef m
|
|
||||||
|
|
||||||
foreign import javascript unsafe "$3.slice($1, $1 + $2)"
|
foreign import javascript unsafe "$3.slice($1, $1 + $2)"
|
||||||
js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer
|
js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer
|
||||||
|
|
||||||
|
@ -301,7 +303,7 @@ toResponse :: JSXMLHttpRequest -> ClientM Response
|
||||||
toResponse xhr = do
|
toResponse xhr = do
|
||||||
status <- liftIO $ getStatus xhr
|
status <- liftIO $ getStatus xhr
|
||||||
case status of
|
case status of
|
||||||
0 -> throwError $ ConnectionError "connection error"
|
0 -> throwError $ ConnectionError (SomeException (userError "connection error"))
|
||||||
_ -> liftIO $ do
|
_ -> liftIO $ do
|
||||||
statusText <- cs <$> getStatusText xhr
|
statusText <- cs <$> getStatusText xhr
|
||||||
headers <- parseHeaders <$> getAllResponseHeaders xhr
|
headers <- parseHeaders <$> getAllResponseHeaders xhr
|
||||||
|
|
|
@ -116,7 +116,6 @@ test-suite spec
|
||||||
-- Additonal dependencies
|
-- Additonal dependencies
|
||||||
build-depends:
|
build-depends:
|
||||||
entropy >= 0.4.1.3 && < 0.5
|
entropy >= 0.4.1.3 && < 0.5
|
||||||
, generics-sop >= 0.4.0.1 && < 0.5
|
|
||||||
, hspec >= 2.6.0 && < 2.7
|
, hspec >= 2.6.0 && < 2.7
|
||||||
, HUnit >= 1.6.0.0 && < 1.7
|
, HUnit >= 1.6.0.0 && < 1.7
|
||||||
, network >= 2.8.0.0 && < 3.1
|
, network >= 2.8.0.0 && < 3.1
|
||||||
|
|
|
@ -143,9 +143,6 @@ instance RunClient ClientM where
|
||||||
runRequest = performRequest
|
runRequest = performRequest
|
||||||
throwServantError = throwError
|
throwServantError = throwError
|
||||||
|
|
||||||
instance ClientLike (ClientM a) (ClientM a) where
|
|
||||||
mkClient = id
|
|
||||||
|
|
||||||
runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
|
runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
|
||||||
runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
|
runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
|
||||||
|
|
||||||
|
|
|
@ -118,9 +118,6 @@ instance RunClient ClientM where
|
||||||
instance RunStreamingClient ClientM where
|
instance RunStreamingClient ClientM where
|
||||||
withStreamingRequest = performWithStreamingRequest
|
withStreamingRequest = performWithStreamingRequest
|
||||||
|
|
||||||
instance ClientLike (ClientM a) (ClientM a) where
|
|
||||||
mkClient = id
|
|
||||||
|
|
||||||
withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b
|
withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b
|
||||||
withClientM cm env k =
|
withClientM cm env k =
|
||||||
let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
|
let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
|
||||||
|
|
|
@ -48,7 +48,6 @@ import Data.Monoid ()
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import Data.Semigroup
|
import Data.Semigroup
|
||||||
((<>))
|
((<>))
|
||||||
import qualified Generics.SOP as SOP
|
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
(Generic)
|
(Generic)
|
||||||
import qualified Network.HTTP.Client as C
|
import qualified Network.HTTP.Client as C
|
||||||
|
@ -72,8 +71,8 @@ import Servant.API
|
||||||
Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
|
Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
|
||||||
QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
|
QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
|
||||||
import Servant.Client
|
import Servant.Client
|
||||||
import qualified Servant.Client.Core.Internal.Auth as Auth
|
import qualified Servant.Client.Core.Auth as Auth
|
||||||
import qualified Servant.Client.Core.Internal.Request as Req
|
import qualified Servant.Client.Core.Request as Req
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
import Servant.Server.Experimental.Auth
|
import Servant.Server.Experimental.Auth
|
||||||
import Servant.Test.ComprehensiveAPI
|
import Servant.Test.ComprehensiveAPI
|
||||||
|
@ -88,7 +87,6 @@ spec = describe "Servant.Client" $ do
|
||||||
wrappedApiSpec
|
wrappedApiSpec
|
||||||
basicAuthSpec
|
basicAuthSpec
|
||||||
genAuthSpec
|
genAuthSpec
|
||||||
genericClientSpec
|
|
||||||
hoistClientSpec
|
hoistClientSpec
|
||||||
connectionErrorSpec
|
connectionErrorSpec
|
||||||
|
|
||||||
|
@ -258,53 +256,6 @@ genAuthServerContext = genAuthHandler :. EmptyContext
|
||||||
genAuthServer :: Application
|
genAuthServer :: Application
|
||||||
genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
|
genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
|
||||||
|
|
||||||
-- * generic client stuff
|
|
||||||
|
|
||||||
type GenericClientAPI
|
|
||||||
= QueryParam "sqr" Int :> Get '[JSON] Int
|
|
||||||
:<|> Capture "foo" String :> NestedAPI1
|
|
||||||
|
|
||||||
data GenericClient = GenericClient
|
|
||||||
{ getSqr :: Maybe Int -> ClientM Int
|
|
||||||
, mkNestedClient1 :: String -> NestedClient1
|
|
||||||
} deriving Generic
|
|
||||||
instance SOP.Generic GenericClient
|
|
||||||
instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient
|
|
||||||
|
|
||||||
type NestedAPI1
|
|
||||||
= QueryParam "int" Int :> NestedAPI2
|
|
||||||
:<|> QueryParam "id" Char :> Get '[JSON] Char
|
|
||||||
|
|
||||||
data NestedClient1 = NestedClient1
|
|
||||||
{ mkNestedClient2 :: Maybe Int -> NestedClient2
|
|
||||||
, idChar :: Maybe Char -> ClientM Char
|
|
||||||
} deriving Generic
|
|
||||||
instance SOP.Generic NestedClient1
|
|
||||||
instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1
|
|
||||||
|
|
||||||
type NestedAPI2
|
|
||||||
= "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int
|
|
||||||
:<|> "void" :> Post '[JSON] ()
|
|
||||||
|
|
||||||
data NestedClient2 = NestedClient2
|
|
||||||
{ getSum :: Int -> Int -> ClientM Int
|
|
||||||
, doNothing :: ClientM ()
|
|
||||||
} deriving Generic
|
|
||||||
instance SOP.Generic NestedClient2
|
|
||||||
instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2
|
|
||||||
|
|
||||||
genericClientServer :: Application
|
|
||||||
genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
|
|
||||||
(\ mx -> case mx of
|
|
||||||
Just x -> return (x*x)
|
|
||||||
Nothing -> throwError $ ServantErr 400 "missing parameter" "" []
|
|
||||||
)
|
|
||||||
:<|> nestedServer1
|
|
||||||
)
|
|
||||||
where
|
|
||||||
nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)
|
|
||||||
nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()
|
|
||||||
|
|
||||||
{-# NOINLINE manager' #-}
|
{-# NOINLINE manager' #-}
|
||||||
manager' :: C.Manager
|
manager' :: C.Manager
|
||||||
manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
||||||
|
@ -495,22 +446,6 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
|
||||||
Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
|
Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
|
||||||
responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
|
responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
|
||||||
|
|
||||||
genericClientSpec :: Spec
|
|
||||||
genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do
|
|
||||||
describe "Servant.Client.Generic" $ do
|
|
||||||
|
|
||||||
let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI))
|
|
||||||
NestedClient1{..} = mkNestedClient1 "example"
|
|
||||||
NestedClient2{..} = mkNestedClient2 (Just 42)
|
|
||||||
|
|
||||||
it "works for top-level client inClientM function" $ \(_, baseUrl) -> do
|
|
||||||
left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25
|
|
||||||
|
|
||||||
it "works for nested clients" $ \(_, baseUrl) -> do
|
|
||||||
left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c'
|
|
||||||
left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7
|
|
||||||
left show <$> runClient doNothing baseUrl `shouldReturn` Right ()
|
|
||||||
|
|
||||||
-- * hoistClient
|
-- * hoistClient
|
||||||
|
|
||||||
type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
|
type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
|
||||||
|
|
|
@ -68,7 +68,7 @@ library
|
||||||
, case-insensitive
|
, case-insensitive
|
||||||
, http-streams >= 0.8.6.1 && < 0.9
|
, http-streams >= 0.8.6.1 && < 0.9
|
||||||
, http-media >= 0.7.1.3 && < 0.8
|
, http-media >= 0.7.1.3 && < 0.8
|
||||||
, io-streams >=1.5.0.1 && < 1.6
|
, io-streams >= 1.5.0.1 && < 1.6
|
||||||
, http-types >= 0.12.2 && < 0.13
|
, http-types >= 0.12.2 && < 0.13
|
||||||
, http-common >= 0.8.2.0 && < 0.9
|
, http-common >= 0.8.2.0 && < 0.9
|
||||||
, exceptions >= 0.10.0 && < 0.11
|
, exceptions >= 0.10.0 && < 0.11
|
||||||
|
@ -116,7 +116,6 @@ test-suite spec
|
||||||
-- Additonal dependencies
|
-- Additonal dependencies
|
||||||
build-depends:
|
build-depends:
|
||||||
entropy >= 0.4.1.3 && < 0.5
|
entropy >= 0.4.1.3 && < 0.5
|
||||||
, generics-sop >= 0.4.0.1 && < 0.5
|
|
||||||
, hspec >= 2.6.0 && < 2.7
|
, hspec >= 2.6.0 && < 2.7
|
||||||
, HUnit >= 1.6.0.0 && < 1.7
|
, HUnit >= 1.6.0.0 && < 1.7
|
||||||
, network >= 2.8.0.0 && < 3.1
|
, network >= 2.8.0.0 && < 3.1
|
||||||
|
|
|
@ -141,9 +141,6 @@ instance RunClient ClientM where
|
||||||
instance RunStreamingClient ClientM where
|
instance RunStreamingClient ClientM where
|
||||||
withStreamingRequest = performWithStreamingRequest
|
withStreamingRequest = performWithStreamingRequest
|
||||||
|
|
||||||
instance ClientLike (ClientM a) (ClientM a) where
|
|
||||||
mkClient = id
|
|
||||||
|
|
||||||
runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a)
|
runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a)
|
||||||
runClientM cm env = withClientM cm env (evaluate . force)
|
runClientM cm env = withClientM cm env (evaluate . force)
|
||||||
|
|
||||||
|
|
|
@ -46,7 +46,6 @@ import Data.Monoid ()
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import Data.Semigroup
|
import Data.Semigroup
|
||||||
((<>))
|
((<>))
|
||||||
import qualified Generics.SOP as SOP
|
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
(Generic)
|
(Generic)
|
||||||
import qualified Network.HTTP.Types as HTTP
|
import qualified Network.HTTP.Types as HTTP
|
||||||
|
@ -66,8 +65,8 @@ import Servant.API
|
||||||
DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
|
DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
|
||||||
Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
|
Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
|
||||||
QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
|
QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
|
||||||
import qualified Servant.Client.Core.Internal.Auth as Auth
|
import qualified Servant.Client.Core.Auth as Auth
|
||||||
import qualified Servant.Client.Core.Internal.Request as Req
|
import qualified Servant.Client.Core.Request as Req
|
||||||
import Servant.HttpStreams
|
import Servant.HttpStreams
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
import Servant.Server.Experimental.Auth
|
import Servant.Server.Experimental.Auth
|
||||||
|
@ -83,7 +82,6 @@ spec = describe "Servant.HttpStreams" $ do
|
||||||
wrappedApiSpec
|
wrappedApiSpec
|
||||||
basicAuthSpec
|
basicAuthSpec
|
||||||
genAuthSpec
|
genAuthSpec
|
||||||
genericClientSpec
|
|
||||||
hoistClientSpec
|
hoistClientSpec
|
||||||
connectionErrorSpec
|
connectionErrorSpec
|
||||||
|
|
||||||
|
@ -256,53 +254,6 @@ genAuthServerContext = genAuthHandler :. EmptyContext
|
||||||
genAuthServer :: Application
|
genAuthServer :: Application
|
||||||
genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
|
genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
|
||||||
|
|
||||||
-- * generic client stuff
|
|
||||||
|
|
||||||
type GenericClientAPI
|
|
||||||
= QueryParam "sqr" Int :> Get '[JSON] Int
|
|
||||||
:<|> Capture "foo" String :> NestedAPI1
|
|
||||||
|
|
||||||
data GenericClient = GenericClient
|
|
||||||
{ getSqr :: Maybe Int -> ClientM Int
|
|
||||||
, mkNestedClient1 :: String -> NestedClient1
|
|
||||||
} deriving Generic
|
|
||||||
instance SOP.Generic GenericClient
|
|
||||||
instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient
|
|
||||||
|
|
||||||
type NestedAPI1
|
|
||||||
= QueryParam "int" Int :> NestedAPI2
|
|
||||||
:<|> QueryParam "id" Char :> Get '[JSON] Char
|
|
||||||
|
|
||||||
data NestedClient1 = NestedClient1
|
|
||||||
{ mkNestedClient2 :: Maybe Int -> NestedClient2
|
|
||||||
, idChar :: Maybe Char -> ClientM Char
|
|
||||||
} deriving Generic
|
|
||||||
instance SOP.Generic NestedClient1
|
|
||||||
instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1
|
|
||||||
|
|
||||||
type NestedAPI2
|
|
||||||
= "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int
|
|
||||||
:<|> "void" :> Post '[JSON] ()
|
|
||||||
|
|
||||||
data NestedClient2 = NestedClient2
|
|
||||||
{ getSum :: Int -> Int -> ClientM Int
|
|
||||||
, doNothing :: ClientM ()
|
|
||||||
} deriving Generic
|
|
||||||
instance SOP.Generic NestedClient2
|
|
||||||
instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2
|
|
||||||
|
|
||||||
genericClientServer :: Application
|
|
||||||
genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
|
|
||||||
(\ mx -> case mx of
|
|
||||||
Just x -> return (x*x)
|
|
||||||
Nothing -> throwError $ ServantErr 400 "missing parameter" "" []
|
|
||||||
)
|
|
||||||
:<|> nestedServer1
|
|
||||||
)
|
|
||||||
where
|
|
||||||
nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)
|
|
||||||
nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()
|
|
||||||
|
|
||||||
runClient :: NFData a => ClientM a -> BaseUrl -> IO (Either ServantError a)
|
runClient :: NFData a => ClientM a -> BaseUrl -> IO (Either ServantError a)
|
||||||
runClient x burl = withClientEnvIO burl (runClientM x)
|
runClient x burl = withClientEnvIO burl (runClientM x)
|
||||||
|
|
||||||
|
@ -487,22 +438,6 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
|
||||||
Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
|
Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
|
||||||
responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
|
responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
|
||||||
|
|
||||||
genericClientSpec :: Spec
|
|
||||||
genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do
|
|
||||||
describe "Servant.Client.Generic" $ do
|
|
||||||
|
|
||||||
let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI))
|
|
||||||
NestedClient1{..} = mkNestedClient1 "example"
|
|
||||||
NestedClient2{..} = mkNestedClient2 (Just 42)
|
|
||||||
|
|
||||||
it "works for top-level client inClientM function" $ \(_, baseUrl) -> do
|
|
||||||
left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25
|
|
||||||
|
|
||||||
it "works for nested clients" $ \(_, baseUrl) -> do
|
|
||||||
left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c'
|
|
||||||
left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7
|
|
||||||
left show <$> runClient doNothing baseUrl `shouldReturn` Right ()
|
|
||||||
|
|
||||||
-- * hoistClient
|
-- * hoistClient
|
||||||
|
|
||||||
type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
|
type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
|
||||||
|
|
|
@ -18,7 +18,6 @@ packages:
|
||||||
extra-deps:
|
extra-deps:
|
||||||
- base-compat-0.10.5
|
- base-compat-0.10.5
|
||||||
- conduit-1.3.1
|
- conduit-1.3.1
|
||||||
- generics-sop-0.4.0.1
|
|
||||||
- hspec-2.6.0
|
- hspec-2.6.0
|
||||||
- hspec-core-2.6.0
|
- hspec-core-2.6.0
|
||||||
- hspec-discover-2.6.0
|
- hspec-discover-2.6.0
|
||||||
|
|
Loading…
Reference in a new issue