eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

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

Browse source 
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
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

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

2
.travis.yml
View file

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

15
cabal.ghcjs.project
View file

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

1
cabal.project
View file

@ -33,6 +33,7 @@ packages:
tests: True
optimization: False
reorder-goals: True
allow-newer:
servant-js:base

2
doc/cookbook/using-free-client/UsingFreeClient.lhs
View file

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

22
servant-client-core/servant-client-core.cabal
View file

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

31
servant-client-core/src/Servant/Client/Core.hs
View file

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

8
servant-client-core/src/Servant/Client/Core/Internal/Auth.hs → servant-client-core/src/Servant/Client/Core/Auth.hs
View file

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

8
servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs → servant-client-core/src/Servant/Client/Core/BaseUrl.hs
View file

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

7
servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs → servant-client-core/src/Servant/Client/Core/BasicAuth.hs
View file

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

16
servant-client-core/src/Servant/Client/Core/Internal/ClientError.hs → servant-client-core/src/Servant/Client/Core/ClientError.hs
View file

@ -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
@ -26,13 +28,15 @@ 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

48
servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs → servant-client-core/src/Servant/Client/Core/HasClient.hs
View file

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

12
servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs
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)

155
servant-client-core/src/Servant/Client/Core/Internal/Generic.hs
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

67
servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs
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)
-}

14
servant-client-core/src/Servant/Client/Core/Reexport.hs
View file

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

29
servant-client-core/src/Servant/Client/Core/Internal/Request.hs → servant-client-core/src/Servant/Client/Core/Request.hs
View file

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

6
servant-client-core/src/Servant/Client/Core/Internal/Response.hs → servant-client-core/src/Servant/Client/Core/Response.hs
View file

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

2
servant-client-core/src/Servant/Client/Free.hs
View file

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

2
servant-client-core/test/Servant/Client/Core/Internal/BaseUrlSpec.hs
View file

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

13
servant-client-ghcjs/servant-client-ghcjs.cabal
View file

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

62
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
View file

@ -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 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 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 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
@ -272,24 +283,15 @@ toBody request = case requestBody request of
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
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

1
servant-client/servant-client.cabal
View file

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

3
servant-client/src/Servant/Client/Internal/HttpClient.hs
View file

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

3
servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs
View file

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

69
servant-client/test/Servant/ClientSpec.hs
View file

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

1
servant-http-streams/servant-http-streams.cabal
View file

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

3
servant-http-streams/src/Servant/HttpStreams/Internal.hs
View file

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

69
servant-http-streams/test/Servant/ClientSpec.hs
View file

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

1
stack.yaml
View file

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