Merge pull request #1130 from phadej/refactor-servant-client

Refactor servant-client-core
This commit is contained in:
Oleg Grenrus 2019-02-18 19:44:49 +02:00 committed by GitHub
commit e922b9898c
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
33 changed files with 252 additions and 509 deletions

2
.gitignore vendored
View file

@ -1,5 +1,5 @@
**/*/dist **/*/dist
dist-newstyle dist-*
.ghc.environment.* .ghc.environment.*
/bin /bin
/lib /lib

View file

@ -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
View 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

View file

@ -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

View file

@ -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

View file

@ -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:

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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 (..))

View file

@ -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

View file

@ -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

View file

@ -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

View 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)

View file

@ -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)

View file

@ -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

View file

@ -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)
-}

View file

@ -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

View file

@ -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

View file

@ -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

View 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

View file

@ -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))

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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