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

Refactor servant-client(-core)

Browse source 
- Rename GenResponse to ResponseF (analogous to RequestF)
- add NFData Headers
- Make Request and Response bodies be SourceIO,
  i.e. move conversions into specific implementations
This commit is contained in:
Oleg Grenrus 2019-02-06 12:12:56 +02:00
parent 2071042ebb
commit 4fab471c29
13 changed files with 236 additions and 155 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -137,7 +137,7 @@ And we continue by turning http-client's `Response` into servant's `Response`,
and calling the continuation. We should get a `Pure` value.
```haskell
let res = I.clientResponseToResponse res'
let res = I.clientResponseToResponse id res'
case k res of
Pure n ->

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

@ -39,10 +39,12 @@ library
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
-- Bundled with GHC: Lower bound to not force re-installs

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

@ -41,7 +41,7 @@ module Servant.Client.Core
-- * Response
, Response
, GenResponse (..)
, ResponseF (..)
, RunClient(..)
, module Servant.Client.Core.Internal.BaseUrl
-- ** Streaming
@ -64,4 +64,6 @@ 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

82
servant-client-core/src/Servant/Client/Core/Internal/ClientError.hs Normal file
View file

@ -0,0 +1,82 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Servant.Client.Core.Internal.ClientError where
import Prelude ()
import Prelude.Compat
import Control.DeepSeq
(NFData (..))
import Control.Exception
(SomeException (..))
import Control.Monad.Catch
(Exception)
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.Types ()
import Servant.Client.Core.Internal.BaseUrl
import Servant.Client.Core.Internal.Request
import Servant.Client.Core.Internal.Response
-- | A type representing possible errors in a request
--
-- Note that this type substantially changed in 0.12.
data ServantError =
-- | The server returned an error response including the
-- failing request. 'requestPath' includes the 'BaseUrl' and the
-- path of the request.
FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response
-- | The body could not be decoded at the expected type
| DecodeFailure Text Response
-- | The content-type of the response is not supported
| UnsupportedContentType MediaType Response
-- | The content-type header is invalid
| InvalidContentTypeHeader Response
-- | There was a connection error, and no response was received
| ConnectionError SomeException
deriving (Show, Generic, Typeable)
instance Eq ServantError where
FailureResponse req res == FailureResponse req' res' = req == req' && res == res'
DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r'
UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r'
InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r'
ConnectionError exc == ConnectionError exc' = eqSomeException exc exc'
where
-- returns true, if type of exception is the same
eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b
-- prevent wild card blindness
FailureResponse {} == _ = False
DecodeFailure {} == _ = False
UnsupportedContentType {} == _ = False
InvalidContentTypeHeader {} == _ = False
ConnectionError {} == _ = False
instance Exception ServantError
-- | Note: an exception in 'ConnectionError' might not be evaluated fully,
-- We only 'rnf' its 'show'ed value.
instance NFData ServantError where
rnf (FailureResponse req res) = rnf req `seq` rnf res
rnf (DecodeFailure err res) = rnf err `seq` rnf res
rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res
rnf (InvalidContentTypeHeader res) = rnf res
rnf (ConnectionError err) = err `seq` rnf (show err)

2
servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs
View file

@ -2,6 +2,8 @@
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)

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

@ -16,9 +16,6 @@ module Servant.Client.Core.Internal.HasClient where
import Prelude ()
import Prelude.Compat
import Control.Concurrent.MVar
(modifyMVar, newMVar)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Foldable
(toList)
@ -50,11 +47,12 @@ import Servant.API.ContentTypes
(contentTypes)
import Servant.API.Modifiers
(FoldRequired, RequiredArgument, foldRequiredArgument)
import qualified Servant.Types.SourceT as S
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
-- * Accessing APIs as a Client
@ -283,7 +281,7 @@ instance {-# OVERLAPPABLE #-}
clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
return $ fromSourceIO $ framingUnrender' $ S.fromAction BS.null (responseBody gres)
return $ fromSourceIO $ framingUnrender' $ responseBody gres
where
req' = req
{ requestAccept = fromList [contentType (Proxy :: Proxy ct)]
@ -552,7 +550,7 @@ instance
clientWithRoute pm Proxy req body
= clientWithRoute pm (Proxy :: Proxy api)
$ setRequestBody (RequestBodyStreamChunked givesPopper) (contentType ctypeP) req
$ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req
where
ctypeP = Proxy :: Proxy ctype
framingP = Proxy :: Proxy framing
@ -562,28 +560,6 @@ instance
(mimeRender ctypeP :: chunk -> BL.ByteString)
(toSourceIO body)
-- not pretty.
givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do
ref <- newMVar step0
-- Note sure we need locking, but it's feels safer.
let popper :: IO BS.ByteString
popper = modifyMVar ref nextBs
needsPopper popper
nextBs S.Stop = return (S.Stop, BS.empty)
nextBs (S.Error err) = fail err
nextBs (S.Skip s) = nextBs s
nextBs (S.Effect ms) = ms >>= nextBs
nextBs (S.Yield lbs s) = case BL.toChunks lbs of
[] -> nextBs s
(x:xs) | BS.null x -> nextBs step'
| otherwise -> return (step', x)
where
step' = S.Yield (BL.fromChunks xs) s
-- | Make the querying function append @path@ to the request path.
instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
type Client m (path :> api) = Client m api

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

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
@ -17,10 +16,6 @@ import Prelude.Compat
import Control.DeepSeq
(NFData (..))
import Control.Exception
(SomeException (..))
import Control.Monad.Catch
(Exception)
import Data.Bifoldable
(Bifoldable (..))
import Data.Bifunctor
@ -30,8 +25,6 @@ import Data.Bitraversable
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Lazy as LBS
import Data.Int
(Int64)
import Data.Semigroup
((<>))
import qualified Data.Sequence as Seq
@ -40,64 +33,16 @@ import Data.Text
import Data.Text.Encoding
(encodeUtf8)
import Data.Typeable
(Typeable, typeOf)
(Typeable)
import GHC.Generics
(Generic)
import Network.HTTP.Media
(MediaType, mainType, parameters, subType)
import Network.HTTP.Types
(Header, HeaderName, HttpVersion (..), Method, QueryItem,
Status (..), http11, methodGet)
http11, methodGet)
import Servant.API
(ToHttpApiData, toEncodedUrlPiece, toHeader)
import Servant.Client.Core.Internal.BaseUrl
(BaseUrl)
-- | A type representing possible errors in a request
--
-- Note that this type substantially changed in 0.12.
data ServantError =
-- | The server returned an error response including the
-- failing request. 'requestPath' includes the 'BaseUrl' and the
-- path of the request.
FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response
-- | The body could not be decoded at the expected type
| DecodeFailure Text Response
-- | The content-type of the response is not supported
| UnsupportedContentType MediaType Response
-- | The content-type header is invalid
| InvalidContentTypeHeader Response
-- | There was a connection error, and no response was received
| ConnectionError SomeException
deriving (Show, Generic, Typeable)
instance Eq ServantError where
FailureResponse req res == FailureResponse req' res' = req == req' && res == res'
DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r'
UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r'
InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r'
ConnectionError exc == ConnectionError exc' = eqSomeException exc exc'
where
-- returns true, if type of exception is the same
eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b
-- prevent wild card blindness
FailureResponse {} == _ = False
DecodeFailure {} == _ = False
UnsupportedContentType {} == _ = False
InvalidContentTypeHeader {} == _ = False
ConnectionError {} == _ = False
instance Exception ServantError
-- | Note: an exception in 'ConnectionError' might not be evaluated fully,
-- We only 'rnf' its 'show'ed value.
instance NFData ServantError where
rnf (FailureResponse req res) = rnf req `seq` rnf res
rnf (DecodeFailure err res) = rnf err `seq` rnf res
rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res
rnf (InvalidContentTypeHeader res) = rnf res
rnf (ConnectionError err) = err `seq` rnf (show err)
(ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
mediaTypeRnf :: MediaType -> ()
mediaTypeRnf mt =
@ -143,31 +88,13 @@ type Request = RequestF RequestBody Builder.Builder
data RequestBody
= RequestBodyLBS LBS.ByteString
| RequestBodyBS BS.ByteString
| RequestBodyBuilder Int64 Builder.Builder
| RequestBodyStream Int64 ((IO BS.ByteString -> IO ()) -> IO ())
| RequestBodyStreamChunked ((IO BS.ByteString -> IO ()) -> IO ())
| RequestBodyIO (IO RequestBody)
| RequestBodySource (SourceIO LBS.ByteString)
deriving (Generic, Typeable)
data GenResponse a = Response
{ responseStatusCode :: Status
, responseHeaders :: Seq.Seq Header
, responseHttpVersion :: HttpVersion
, responseBody :: a
} deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)
instance NFData a => NFData (GenResponse a) where
rnf (Response sc hs hv body) =
rnfStatus sc `seq`
rnf hs `seq`
rnfHttpVersion hv `seq`
rnf body
where
rnfStatus (Status code msg) = rnf code `seq` rnf msg
rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict
type Response = GenResponse LBS.ByteString
type StreamingResponse = GenResponse (IO BS.ByteString)
instance Show RequestBody where
showsPrec d (RequestBodyLBS lbs) = showParen (d > 10)
$ showString "RequestBodyLBS "
. showsPrec 11 lbs
-- A GET request to the top-level path
defaultRequest :: Request

49
servant-client-core/src/Servant/Client/Core/Internal/Response.hs Normal file
View file

@ -0,0 +1,49 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Servant.Client.Core.Internal.Response where
import Prelude ()
import Prelude.Compat
import Control.DeepSeq
(NFData (..))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Sequence as Seq
import Data.Typeable
(Typeable)
import GHC.Generics
(Generic)
import Network.HTTP.Types
(Header, HttpVersion (..), Status (..))
import Servant.API.Stream
(SourceIO)
data ResponseF a = Response
{ responseStatusCode :: Status
, responseHeaders :: Seq.Seq Header
, responseHttpVersion :: HttpVersion
, responseBody :: a
} deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)
instance NFData a => NFData (ResponseF a) where
rnf (Response sc hs hv body) =
rnfStatus sc `seq`
rnf hs `seq`
rnfHttpVersion hv `seq`
rnf body
where
rnfStatus (Status code msg) = rnf code `seq` rnf msg
rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict
type Response = ResponseF LBS.ByteString
type StreamingResponse = ResponseF (SourceIO BS.ByteString)

4
servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs
View file

@ -25,8 +25,8 @@ import Servant.API
import Servant.Client.Core.Internal.ClientF
import Servant.Client.Core.Internal.Request
(GenResponse (..), Request, Response, ServantError (..),
StreamingResponse)
import Servant.Client.Core.Internal.Response
import Servant.Client.Core.Internal.ClientError
class Monad m => RunClient m where
-- | How to make a request.

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

@ -9,7 +9,7 @@ module Servant.Client.Core.Reexport
-- * Response (for @Raw@)
, Response
, StreamingResponse
, GenResponse(..)
, ResponseF(..)
-- * Generic Client
, ClientLike(..)
@ -30,4 +30,5 @@ module Servant.Client.Core.Reexport
import Servant.Client.Core.Internal.BaseUrl
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

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

@ -14,6 +14,9 @@ module Servant.Client.Internal.HttpClient where
import Prelude ()
import Prelude.Compat
import Control.Concurrent.MVar
(modifyMVar, newMVar)
import qualified Data.ByteString as BS
import Control.Concurrent.STM.TVar
import Control.Exception
import Control.Monad
@ -52,7 +55,6 @@ import Data.Sequence
(fromList)
import Data.String
(fromString)
import qualified Data.Text as T
import Data.Time.Clock
(UTCTime, getCurrentTime)
import GHC.Generics
@ -62,6 +64,7 @@ import Network.HTTP.Types
(hContentType, renderQuery, statusCode)
import Servant.Client.Core
import qualified Servant.Types.SourceT as S
import qualified Network.HTTP.Client as Client
-- | The environment in which a request is run.
@ -167,7 +170,7 @@ performRequest req = do
response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
let status = Client.responseStatus response
status_code = statusCode status
ourResponse = clientResponseToResponse response
ourResponse = clientResponseToResponse id response
unless (status_code >= 200 && status_code < 300) $
throwError $ mkFailureResponse burl req ourResponse
return ourResponse
@ -197,16 +200,16 @@ performRequest req = do
fReq = Client.hrFinalRequest responses
fRes = Client.hrFinalResponse responses
mkFailureResponse :: BaseUrl -> Request -> GenResponse BSL.ByteString -> ServantError
mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ServantError
mkFailureResponse burl request =
FailureResponse (bimap (const ()) f request)
where
f b = (burl, BSL.toStrict $ toLazyByteString b)
clientResponseToResponse :: Client.Response a -> GenResponse a
clientResponseToResponse r = Response
clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b
clientResponseToResponse f r = Response
{ responseStatusCode = Client.responseStatus r
, responseBody = Client.responseBody r
, responseBody = f (Client.responseBody r)
, responseHeaders = fromList $ Client.responseHeaders r
, responseHttpVersion = Client.responseVersion r
}
@ -239,15 +242,32 @@ requestToClientRequest burl r = Client.defaultRequest
convertBody bd = case bd of
RequestBodyLBS body' -> Client.RequestBodyLBS body'
RequestBodyBS body' -> Client.RequestBodyBS body'
RequestBodyBuilder size body' -> Client.RequestBodyBuilder size body'
RequestBodyStream size body' -> Client.RequestBodyStream size body'
RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body'
RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body')
RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper
where
givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do
ref <- newMVar step0
-- Note sure we need locking, but it's feels safer.
let popper :: IO BS.ByteString
popper = modifyMVar ref nextBs
needsPopper popper
nextBs S.Stop = return (S.Stop, BS.empty)
nextBs (S.Error err) = fail err
nextBs (S.Skip s) = nextBs s
nextBs (S.Effect ms) = ms >>= nextBs
nextBs (S.Yield lbs s) = case BSL.toChunks lbs of
[] -> nextBs s
(x:xs) | BS.null x -> nextBs step'
| otherwise -> return (step', x)
where
step' = S.Yield (BSL.fromChunks xs) s
(body, contentTypeHdr) = case requestBody r of
Nothing -> (Client.RequestBodyLBS "", Nothing)
Just (body', typ)
-> (convertBody body', Just (hContentType, renderHeader typ))
Nothing -> (Client.RequestBodyBS "", Nothing)
Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))
isSecure = case baseUrlScheme burl of
Http -> False

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

@ -35,6 +35,7 @@ import Control.Monad.Reader
import Control.Monad.STM
(atomically)
import Control.Monad.Trans.Except
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Foldable
(for_)
@ -53,8 +54,9 @@ import qualified Network.HTTP.Client as Client
import Servant.Client.Core
import Servant.Client.Internal.HttpClient
(ClientEnv (..), catchConnectionError,
clientResponseToResponse, mkClientEnv, requestToClientRequest,
mkFailureResponse)
clientResponseToResponse, mkClientEnv, mkFailureResponse,
requestToClientRequest)
import qualified Servant.Types.SourceT as S
-- | Generates a set of client functions for an API.
@ -165,7 +167,7 @@ performRequest req = do
atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
let status = Client.responseStatus response
status_code = statusCode status
ourResponse = clientResponseToResponse response
ourResponse = clientResponseToResponse id response
unless (status_code >= 200 && status_code < 300) $
throwError $ mkFailureResponse burl req ourResponse
return ourResponse
@ -183,7 +185,7 @@ performWithStreamingRequest req k = do
-- we throw FailureResponse in IO :(
unless (status_code >= 200 && status_code < 300) $ do
b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
throwIO $ mkFailureResponse burl req (clientResponseToResponse res { Client.responseBody = b })
throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
x <- k (clientResponseToResponse res)
x <- k (clientResponseToResponse (S.fromAction BS.null) res)
k1 x

18
servant/src/Servant/API/ResponseHeaders.hs
View file

@ -35,6 +35,8 @@ module Servant.API.ResponseHeaders
, HList(..)
) where
import Control.DeepSeq
(NFData (..))
import Data.ByteString.Char8 as BS
(ByteString, init, pack, unlines)
import qualified Data.CaseInsensitive as CI
@ -60,16 +62,32 @@ data Headers ls a = Headers { getResponse :: a
-- ^ HList of headers.
} deriving (Functor)
instance (NFDataHList ls, NFData a) => NFData (Headers ls a) where
rnf (Headers x hdrs) = rnf x `seq` rnf hdrs
data ResponseHeader (sym :: Symbol) a
= Header a
| MissingHeader
| UndecodableHeader ByteString
deriving (Typeable, Eq, Show, Functor)
instance NFData a => NFData (ResponseHeader sym a) where
rnf MissingHeader = ()
rnf (UndecodableHeader bs) = rnf bs
rnf (Header x) = rnf x
data HList a where
HNil :: HList '[]
HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs)
class NFDataHList xs where rnfHList :: HList xs -> ()
instance NFDataHList '[] where rnfHList HNil = ()
instance (y ~ Header h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where
rnfHList (HCons h xs) = rnf h `seq` rnfHList xs
instance NFDataHList xs => NFData (HList xs) where
rnf = rnfHList
type family HeaderValMap (f :: * -> *) (xs :: [*]) where
HeaderValMap f '[] = '[]
HeaderValMap f (Header h x ': xs) = Header h (f x) ': HeaderValMap f xs