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-newstyle
|
||||
dist-*
|
||||
.ghc.environment.*
|
||||
/bin
|
||||
/lib
|
||||
|
|
|
@ -103,6 +103,7 @@ install:
|
|||
- "echo 'allow-newer: servant-quickcheck:servant-server' >> cabal.project"
|
||||
- "echo 'allow-newer: servant-quickcheck:hspec' >> cabal.project"
|
||||
- "echo 'allow-newer: servant-quickcheck:http-client' >> cabal.project"
|
||||
- "echo 'reorder-goals: True' >> cabal.project"
|
||||
- "echo 'optimization: False' >> cabal.project "
|
||||
- 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"
|
||||
|
@ -184,6 +185,7 @@ script:
|
|||
- "echo 'allow-newer: servant-quickcheck:servant-server' >> cabal.project"
|
||||
- "echo 'allow-newer: servant-quickcheck:hspec' >> cabal.project"
|
||||
- "echo 'allow-newer: servant-quickcheck:http-client' >> cabal.project"
|
||||
- "echo 'reorder-goals: True' >> cabal.project"
|
||||
- "echo 'optimization: False' >> cabal.project "
|
||||
- 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"
|
||||
|
|
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
|
||||
--
|
||||
-- $ cabal new-build --project-file cabal.ghcjs.project all -w /opt/ghcjs/8.4/bin/ghcjs
|
||||
|
||||
packages:
|
||||
servant/
|
||||
|
@ -9,16 +7,3 @@ packages:
|
|||
|
||||
-- we need to tell cabal we are using 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
|
||||
optimization: False
|
||||
reorder-goals: True
|
||||
|
||||
allow-newer:
|
||||
servant-js:base
|
||||
|
|
|
@ -99,8 +99,6 @@ test = case getSquare 42 of
|
|||
putStrLn $ "ERROR: got pure result: " ++ show n
|
||||
Free (Throw 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:
|
||||
|
|
|
@ -36,16 +36,17 @@ library
|
|||
Servant.Client.Free
|
||||
Servant.Client.Generic
|
||||
Servant.Client.Core.Reexport
|
||||
Servant.Client.Core.Internal.Auth
|
||||
Servant.Client.Core.Internal.BaseUrl
|
||||
Servant.Client.Core.Internal.BasicAuth
|
||||
Servant.Client.Core.Internal.ClientError
|
||||
Servant.Client.Core.Internal.ClientF
|
||||
Servant.Client.Core.Internal.Generic
|
||||
Servant.Client.Core.Internal.HasClient
|
||||
Servant.Client.Core.Internal.Request
|
||||
Servant.Client.Core.Internal.Response
|
||||
Servant.Client.Core.Internal.RunClient
|
||||
Servant.Client.Core.Auth
|
||||
Servant.Client.Core.BaseUrl
|
||||
Servant.Client.Core.BasicAuth
|
||||
Servant.Client.Core.ClientError
|
||||
Servant.Client.Core.HasClient
|
||||
Servant.Client.Core.Request
|
||||
Servant.Client.Core.Response
|
||||
Servant.Client.Core.RunClient
|
||||
|
||||
other-modules:
|
||||
Servant.Client.Core.Internal
|
||||
|
||||
-- Bundled with GHC: Lower bound to not force re-installs
|
||||
-- text and mtl are bundled starting with GHC-8.4
|
||||
|
@ -76,7 +77,6 @@ library
|
|||
, base64-bytestring >= 1.0.0.1 && < 1.1
|
||||
, exceptions >= 0.10.0 && < 0.11
|
||||
, free >= 5.1 && < 5.2
|
||||
, generics-sop >= 0.4.0.1 && < 0.5
|
||||
, http-media >= 0.7.1.3 && < 0.8
|
||||
, http-types >= 0.12.2 && < 0.13
|
||||
, network-uri >= 2.6.1.0 && < 2.7
|
||||
|
|
|
@ -32,18 +32,20 @@ module Servant.Client.Core
|
|||
, AuthClientData
|
||||
|
||||
-- * Generic Client
|
||||
, ClientLike(..)
|
||||
, genericMkClientL
|
||||
, genericMkClientP
|
||||
, ServantError(..)
|
||||
, EmptyClient(..)
|
||||
|
||||
|
||||
-- * Response
|
||||
, Response
|
||||
, ResponseF (..)
|
||||
, RunClient(..)
|
||||
, module Servant.Client.Core.Internal.BaseUrl
|
||||
-- * BaseUrl
|
||||
, BaseUrl (..)
|
||||
, Scheme (..)
|
||||
, showBaseUrl
|
||||
, parseBaseUrl
|
||||
, InvalidBaseUrlException (..)
|
||||
|
||||
-- ** Streaming
|
||||
, RunStreamingClient(..)
|
||||
, StreamingResponse
|
||||
|
@ -56,14 +58,13 @@ module Servant.Client.Core
|
|||
, setRequestBodyLBS
|
||||
, setRequestBody
|
||||
) where
|
||||
import Servant.Client.Core.Internal.Auth
|
||||
import Servant.Client.Core.Internal.BaseUrl
|
||||
(BaseUrl (..), InvalidBaseUrlException, Scheme (..),
|
||||
import Servant.Client.Core.Auth
|
||||
import Servant.Client.Core.BaseUrl
|
||||
(BaseUrl (..), InvalidBaseUrlException (..), Scheme (..),
|
||||
parseBaseUrl, showBaseUrl)
|
||||
import Servant.Client.Core.Internal.BasicAuth
|
||||
import Servant.Client.Core.Internal.Generic
|
||||
import Servant.Client.Core.Internal.HasClient
|
||||
import Servant.Client.Core.Internal.Request
|
||||
import Servant.Client.Core.Internal.Response
|
||||
import Servant.Client.Core.Internal.ClientError
|
||||
import Servant.Client.Core.Internal.RunClient
|
||||
import Servant.Client.Core.BasicAuth
|
||||
import Servant.Client.Core.ClientError
|
||||
import Servant.Client.Core.HasClient
|
||||
import Servant.Client.Core.Request
|
||||
import Servant.Client.Core.Response
|
||||
import Servant.Client.Core.RunClient
|
||||
|
|
|
@ -4,9 +4,13 @@
|
|||
|
||||
-- | 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)
|
||||
|
||||
-- | For a resource protected by authentication (e.g. AuthProtect), we need
|
|
@ -2,7 +2,13 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
module Servant.Client.Core.Internal.BaseUrl where
|
||||
module Servant.Client.Core.BaseUrl (
|
||||
BaseUrl (..),
|
||||
Scheme (..),
|
||||
showBaseUrl,
|
||||
parseBaseUrl,
|
||||
InvalidBaseUrlException (..),
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
(NFData (..))
|
|
@ -3,8 +3,9 @@
|
|||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
-- | Basic Authentication for clients
|
||||
|
||||
module Servant.Client.Core.Internal.BasicAuth where
|
||||
module Servant.Client.Core.BasicAuth (
|
||||
basicAuthReq,
|
||||
) where
|
||||
|
||||
import Data.ByteString.Base64
|
||||
(encode)
|
||||
|
@ -14,7 +15,7 @@ import Data.Text.Encoding
|
|||
(decodeUtf8)
|
||||
import Servant.API.BasicAuth
|
||||
(BasicAuthData (BasicAuthData))
|
||||
import Servant.Client.Core.Internal.Request
|
||||
import Servant.Client.Core.Request
|
||||
(Request, addHeader)
|
||||
|
||||
-- | Authenticate a request using Basic Authentication
|
|
@ -8,7 +8,9 @@
|
|||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Servant.Client.Core.Internal.ClientError where
|
||||
module Servant.Client.Core.ClientError (
|
||||
ServantError (..),
|
||||
) where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
@ -19,20 +21,22 @@ import Control.Exception
|
|||
(SomeException (..))
|
||||
import Control.Monad.Catch
|
||||
(Exception)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Text
|
||||
(Text)
|
||||
import Data.Typeable
|
||||
(Typeable, typeOf)
|
||||
import GHC.Generics
|
||||
(Generic)
|
||||
import Network.HTTP.Media (MediaType)
|
||||
import Network.HTTP.Media
|
||||
(MediaType)
|
||||
import Network.HTTP.Types ()
|
||||
|
||||
import Servant.Client.Core.Internal.BaseUrl
|
||||
import Servant.Client.Core.Internal.Request
|
||||
import Servant.Client.Core.Internal.Response
|
||||
|
||||
import Servant.Client.Core.BaseUrl
|
||||
import Servant.Client.Core.Internal
|
||||
(mediaTypeRnf)
|
||||
import Servant.Client.Core.Request
|
||||
import Servant.Client.Core.Response
|
||||
|
||||
|
||||
-- | A type representing possible errors in a request
|
|
@ -11,11 +11,17 @@
|
|||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Servant.Client.Core.Internal.HasClient where
|
||||
module Servant.Client.Core.HasClient (
|
||||
clientIn,
|
||||
HasClient (..),
|
||||
EmptyClient (..),
|
||||
) where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Monad
|
||||
(unless)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Foldable
|
||||
(toList)
|
||||
|
@ -25,6 +31,9 @@ import Data.Proxy
|
|||
(Proxy (Proxy))
|
||||
import Data.Sequence
|
||||
(fromList)
|
||||
import qualified Data.Text as T
|
||||
import Network.HTTP.Media
|
||||
(MediaType, matches, parseAccept, (//))
|
||||
import Data.String
|
||||
(fromString)
|
||||
import Data.Text
|
||||
|
@ -48,12 +57,12 @@ import Servant.API.ContentTypes
|
|||
import Servant.API.Modifiers
|
||||
(FoldRequired, RequiredArgument, foldRequiredArgument)
|
||||
|
||||
import Servant.Client.Core.Internal.Auth
|
||||
import Servant.Client.Core.Internal.BasicAuth
|
||||
import Servant.Client.Core.Internal.ClientError
|
||||
import Servant.Client.Core.Internal.Request
|
||||
import Servant.Client.Core.Internal.Response
|
||||
import Servant.Client.Core.Internal.RunClient
|
||||
import Servant.Client.Core.Auth
|
||||
import Servant.Client.Core.BasicAuth
|
||||
import Servant.Client.Core.ClientError
|
||||
import Servant.Client.Core.Request
|
||||
import Servant.Client.Core.Response
|
||||
import Servant.Client.Core.RunClient
|
||||
|
||||
-- * 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)
|
||||
|
||||
|
||||
|
||||
{- Note [Non-Empty Content Types]
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
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
|
||||
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
|
||||
, ResponseF(..)
|
||||
|
||||
-- * Generic Client
|
||||
, ClientLike(..)
|
||||
, genericMkClientL
|
||||
, genericMkClientP
|
||||
-- * Data types
|
||||
, ServantError(..)
|
||||
, EmptyClient(..)
|
||||
|
||||
|
@ -27,8 +24,7 @@ module Servant.Client.Core.Reexport
|
|||
) where
|
||||
|
||||
|
||||
import Servant.Client.Core.Internal.BaseUrl
|
||||
import Servant.Client.Core.Internal.Generic
|
||||
import Servant.Client.Core.Internal.HasClient
|
||||
import Servant.Client.Core.Internal.Response
|
||||
import Servant.Client.Core.Internal.ClientError
|
||||
import Servant.Client.Core.BaseUrl
|
||||
import Servant.Client.Core.HasClient
|
||||
import Servant.Client.Core.Response
|
||||
import Servant.Client.Core.ClientError
|
||||
|
|
|
@ -8,8 +8,18 @@
|
|||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Servant.Client.Core.Internal.Request where
|
||||
module Servant.Client.Core.Request (
|
||||
Request,
|
||||
RequestF (..),
|
||||
RequestBody (..),
|
||||
defaultRequest,
|
||||
-- ** Modifiers
|
||||
addHeader,
|
||||
appendToPath,
|
||||
appendToQueryString,
|
||||
setRequestBody,
|
||||
setRequestBodyLBS,
|
||||
) where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
@ -37,18 +47,14 @@ import Data.Typeable
|
|||
import GHC.Generics
|
||||
(Generic)
|
||||
import Network.HTTP.Media
|
||||
(MediaType, mainType, parameters, subType)
|
||||
(MediaType)
|
||||
import Network.HTTP.Types
|
||||
(Header, HeaderName, HttpVersion (..), Method, QueryItem,
|
||||
http11, methodGet)
|
||||
import Servant.API
|
||||
(ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
|
||||
|
||||
mediaTypeRnf :: MediaType -> ()
|
||||
mediaTypeRnf mt =
|
||||
rnf (mainType mt) `seq`
|
||||
rnf (subType mt) `seq`
|
||||
rnf (parameters mt)
|
||||
import Servant.Client.Core.Internal (mediaTypeRnf)
|
||||
|
||||
data RequestF body path = Request
|
||||
{ requestPath :: path
|
||||
|
@ -84,7 +90,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where
|
|||
|
||||
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
|
||||
= RequestBodyLBS LBS.ByteString
|
||||
| RequestBodyBS BS.ByteString
|
||||
|
@ -95,6 +101,11 @@ instance Show RequestBody where
|
|||
showsPrec d (RequestBodyLBS lbs) = showParen (d > 10)
|
||||
$ showString "RequestBodyLBS "
|
||||
. 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
|
||||
defaultRequest :: Request
|
|
@ -8,7 +8,11 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Servant.Client.Core.Internal.Response where
|
||||
module Servant.Client.Core.Response (
|
||||
Response,
|
||||
StreamingResponse,
|
||||
ResponseF (..),
|
||||
) where
|
||||
|
||||
import Prelude ()
|
||||
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
|
||||
(Proxy (..))
|
||||
import Servant.Client.Core
|
||||
import Servant.Client.Core.Internal.ClientF
|
||||
import Servant.Client.Core.Reexport
|
||||
import Servant.Client.Core.RunClient
|
||||
|
||||
client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api
|
||||
client api = api `clientIn` (Proxy :: Proxy (Free ClientF))
|
||||
|
|
|
@ -8,7 +8,7 @@ import Prelude.Compat
|
|||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
import Servant.Client.Core.Internal.BaseUrl
|
||||
import Servant.Client.Core.BaseUrl
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
|
|
|
@ -36,10 +36,10 @@ library
|
|||
Servant.Client.Ghcjs
|
||||
Servant.Client.Internal.XhrClient
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.12
|
||||
base >= 4.11 && < 4.12
|
||||
, bytestring >= 0.10 && < 0.11
|
||||
, 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
|
||||
, ghcjs-base >= 0.2.0.0 && < 0.3.0.0
|
||||
, ghcjs-prim >= 0.1.0.0 && < 0.2.0.0
|
||||
|
@ -47,7 +47,7 @@ library
|
|||
, http-types >= 0.12 && < 0.13
|
||||
, monad-control >= 1.0.0.4 && < 1.1
|
||||
, mtl >= 2.2.2 && < 2.3
|
||||
, semigroupoids >= 4.3 && < 5.3
|
||||
, semigroupoids >= 5.3 && < 5.4
|
||||
, string-conversions >= 0.3 && < 0.5
|
||||
, transformers >= 0.3 && < 0.6
|
||||
, transformers-base >= 0.4.4 && < 0.5
|
||||
|
@ -55,10 +55,9 @@ library
|
|||
|
||||
-- strict, as we re-export stuff
|
||||
build-depends:
|
||||
servant-client-core == 0.15
|
||||
servant == 0.15.*,
|
||||
servant-client-core == 0.15.*
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
if impl(ghc >= 8.0)
|
||||
ghc-options: -Wno-redundant-constraints
|
||||
ghc-options: -Wall -Wno-redundant-constraints
|
||||
|
|
|
@ -18,35 +18,48 @@ import Control.Arrow
|
|||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.Base (MonadBase (..))
|
||||
import Control.Monad.Catch (MonadCatch, MonadThrow)
|
||||
import Control.Monad.Error.Class (MonadError (..))
|
||||
import Control.Monad.Base
|
||||
(MonadBase (..))
|
||||
import Control.Monad.Catch
|
||||
(MonadCatch, MonadThrow)
|
||||
import Control.Monad.Error.Class
|
||||
(MonadError (..))
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
import Control.Monad.Trans.Control
|
||||
(MonadBaseControl (..))
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.ByteString.Builder (toLazyByteString)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Bifunctor
|
||||
(bimap)
|
||||
import Data.ByteString.Builder
|
||||
(toLazyByteString)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.CaseInsensitive
|
||||
import Data.Char
|
||||
import Data.Foldable (toList)
|
||||
import Data.Functor.Alt (Alt (..))
|
||||
import Data.IORef (modifyIORef, newIORef, readIORef)
|
||||
import Data.Proxy (Proxy (..))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Foldable
|
||||
(toList)
|
||||
import Data.Functor.Alt
|
||||
(Alt (..))
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.String.Conversions
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Typeable
|
||||
(Typeable)
|
||||
import Foreign.StablePtr
|
||||
import GHC.Generics
|
||||
import qualified GHCJS.Buffer as Buffer
|
||||
import qualified GHCJS.Buffer as Buffer
|
||||
import GHCJS.Foreign.Callback
|
||||
import GHCJS.Prim
|
||||
import GHCJS.Types
|
||||
import JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer )
|
||||
import JavaScript.TypedArray.ArrayBuffer
|
||||
(ArrayBuffer)
|
||||
import JavaScript.Web.Location
|
||||
import Network.HTTP.Media (renderHeader)
|
||||
import Network.HTTP.Media
|
||||
(renderHeader)
|
||||
import Network.HTTP.Types
|
||||
import Servant.Client.Core
|
||||
import qualified Servant.Types.SourceT as S
|
||||
|
||||
newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
|
||||
|
||||
|
@ -110,9 +123,6 @@ instance RunClient ClientM where
|
|||
runRequest = performRequest
|
||||
throwServantError = throwError
|
||||
|
||||
instance ClientLike (ClientM a) (ClientM a) where
|
||||
mkClient = id
|
||||
|
||||
runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a)
|
||||
runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm
|
||||
|
||||
|
@ -150,8 +160,9 @@ performRequest req = do
|
|||
resp <- toResponse xhr
|
||||
|
||||
let status = statusCode (responseStatusCode resp)
|
||||
unless (status >= 200 && status < 300) $
|
||||
throwError $ FailureResponse resp
|
||||
unless (status >= 200 && status < 300) $ do
|
||||
let f b = (burl, BL.toStrict $ toLazyByteString b)
|
||||
throwError $ FailureResponse (bimap (const ()) f req) resp
|
||||
|
||||
pure resp
|
||||
|
||||
|
@ -270,26 +281,17 @@ toBody request = case requestBody request of
|
|||
where
|
||||
go :: RequestBody -> IO ArrayBuffer
|
||||
go x = case x of
|
||||
RequestBodyLBS x -> return $ mBody $ BL.toStrict x
|
||||
RequestBodyBS x -> return $ mBody x
|
||||
RequestBodyBuilder _ x -> return $ mBody $ BL.toStrict $ toLazyByteString x
|
||||
RequestBodyStream _ x -> mBody <$> readBody x
|
||||
RequestBodyStreamChunked x -> mBody <$> readBody x
|
||||
RequestBodyIO x -> x >>= go
|
||||
RequestBodyLBS x -> return $ mBody $ BL.toStrict x
|
||||
RequestBodyBS x -> return $ mBody x
|
||||
RequestBodySource xs -> runExceptT (S.runSourceT xs) >>= \e -> case e of
|
||||
Left err -> fail err
|
||||
Right bss -> return $ mBody $ BL.toStrict $ mconcat bss
|
||||
|
||||
mBody :: BS.ByteString -> ArrayBuffer
|
||||
mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer
|
||||
where
|
||||
(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)"
|
||||
js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer
|
||||
|
||||
|
@ -301,7 +303,7 @@ toResponse :: JSXMLHttpRequest -> ClientM Response
|
|||
toResponse xhr = do
|
||||
status <- liftIO $ getStatus xhr
|
||||
case status of
|
||||
0 -> throwError $ ConnectionError "connection error"
|
||||
0 -> throwError $ ConnectionError (SomeException (userError "connection error"))
|
||||
_ -> liftIO $ do
|
||||
statusText <- cs <$> getStatusText xhr
|
||||
headers <- parseHeaders <$> getAllResponseHeaders xhr
|
||||
|
|
|
@ -116,7 +116,6 @@ test-suite spec
|
|||
-- Additonal dependencies
|
||||
build-depends:
|
||||
entropy >= 0.4.1.3 && < 0.5
|
||||
, generics-sop >= 0.4.0.1 && < 0.5
|
||||
, hspec >= 2.6.0 && < 2.7
|
||||
, HUnit >= 1.6.0.0 && < 1.7
|
||||
, network >= 2.8.0.0 && < 3.1
|
||||
|
|
|
@ -143,9 +143,6 @@ instance RunClient ClientM where
|
|||
runRequest = performRequest
|
||||
throwServantError = throwError
|
||||
|
||||
instance ClientLike (ClientM a) (ClientM a) where
|
||||
mkClient = id
|
||||
|
||||
runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
|
||||
runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
|
||||
|
||||
|
|
|
@ -118,9 +118,6 @@ instance RunClient ClientM where
|
|||
instance RunStreamingClient ClientM where
|
||||
withStreamingRequest = performWithStreamingRequest
|
||||
|
||||
instance ClientLike (ClientM a) (ClientM a) where
|
||||
mkClient = id
|
||||
|
||||
withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b
|
||||
withClientM cm env k =
|
||||
let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
|
||||
|
|
|
@ -48,7 +48,6 @@ import Data.Monoid ()
|
|||
import Data.Proxy
|
||||
import Data.Semigroup
|
||||
((<>))
|
||||
import qualified Generics.SOP as SOP
|
||||
import GHC.Generics
|
||||
(Generic)
|
||||
import qualified Network.HTTP.Client as C
|
||||
|
@ -72,8 +71,8 @@ import Servant.API
|
|||
Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
|
||||
QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
|
||||
import Servant.Client
|
||||
import qualified Servant.Client.Core.Internal.Auth as Auth
|
||||
import qualified Servant.Client.Core.Internal.Request as Req
|
||||
import qualified Servant.Client.Core.Auth as Auth
|
||||
import qualified Servant.Client.Core.Request as Req
|
||||
import Servant.Server
|
||||
import Servant.Server.Experimental.Auth
|
||||
import Servant.Test.ComprehensiveAPI
|
||||
|
@ -88,7 +87,6 @@ spec = describe "Servant.Client" $ do
|
|||
wrappedApiSpec
|
||||
basicAuthSpec
|
||||
genAuthSpec
|
||||
genericClientSpec
|
||||
hoistClientSpec
|
||||
connectionErrorSpec
|
||||
|
||||
|
@ -258,53 +256,6 @@ genAuthServerContext = genAuthHandler :. EmptyContext
|
|||
genAuthServer :: Application
|
||||
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' #-}
|
||||
manager' :: C.Manager
|
||||
manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
||||
|
@ -495,22 +446,6 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
|
|||
Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
|
||||
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
|
||||
|
||||
type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
|
||||
|
|
|
@ -68,7 +68,7 @@ library
|
|||
, case-insensitive
|
||||
, http-streams >= 0.8.6.1 && < 0.9
|
||||
, 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-common >= 0.8.2.0 && < 0.9
|
||||
, exceptions >= 0.10.0 && < 0.11
|
||||
|
@ -116,7 +116,6 @@ test-suite spec
|
|||
-- Additonal dependencies
|
||||
build-depends:
|
||||
entropy >= 0.4.1.3 && < 0.5
|
||||
, generics-sop >= 0.4.0.1 && < 0.5
|
||||
, hspec >= 2.6.0 && < 2.7
|
||||
, HUnit >= 1.6.0.0 && < 1.7
|
||||
, network >= 2.8.0.0 && < 3.1
|
||||
|
|
|
@ -141,9 +141,6 @@ instance RunClient ClientM where
|
|||
instance RunStreamingClient ClientM where
|
||||
withStreamingRequest = performWithStreamingRequest
|
||||
|
||||
instance ClientLike (ClientM a) (ClientM a) where
|
||||
mkClient = id
|
||||
|
||||
runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a)
|
||||
runClientM cm env = withClientM cm env (evaluate . force)
|
||||
|
||||
|
|
|
@ -46,7 +46,6 @@ import Data.Monoid ()
|
|||
import Data.Proxy
|
||||
import Data.Semigroup
|
||||
((<>))
|
||||
import qualified Generics.SOP as SOP
|
||||
import GHC.Generics
|
||||
(Generic)
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
|
@ -66,8 +65,8 @@ import Servant.API
|
|||
DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
|
||||
Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
|
||||
QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
|
||||
import qualified Servant.Client.Core.Internal.Auth as Auth
|
||||
import qualified Servant.Client.Core.Internal.Request as Req
|
||||
import qualified Servant.Client.Core.Auth as Auth
|
||||
import qualified Servant.Client.Core.Request as Req
|
||||
import Servant.HttpStreams
|
||||
import Servant.Server
|
||||
import Servant.Server.Experimental.Auth
|
||||
|
@ -83,7 +82,6 @@ spec = describe "Servant.HttpStreams" $ do
|
|||
wrappedApiSpec
|
||||
basicAuthSpec
|
||||
genAuthSpec
|
||||
genericClientSpec
|
||||
hoistClientSpec
|
||||
connectionErrorSpec
|
||||
|
||||
|
@ -256,53 +254,6 @@ genAuthServerContext = genAuthHandler :. EmptyContext
|
|||
genAuthServer :: Application
|
||||
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 x burl = withClientEnvIO burl (runClientM x)
|
||||
|
||||
|
@ -487,22 +438,6 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
|
|||
Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
|
||||
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
|
||||
|
||||
type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
|
||||
|
|
|
@ -18,7 +18,6 @@ packages:
|
|||
extra-deps:
|
||||
- base-compat-0.10.5
|
||||
- conduit-1.3.1
|
||||
- generics-sop-0.4.0.1
|
||||
- hspec-2.6.0
|
||||
- hspec-core-2.6.0
|
||||
- hspec-discover-2.6.0
|
||||
|
|
Loading…
Reference in a new issue