Merge pull request #1117 from haskell-servant/servant-http-streams

WIP: servant-http-streams

.travis.yml

@@ -69,12 +69,12 @@ install:
   - rm -fv cabal.project cabal.project.local
   - "if [ $HCNUMVER -ge 70800 ]; then sed -i.bak 's/-- ghc-options:.*/ghc-options: -j2/' ${HOME}/.cabal/config; fi"
   - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
-  - "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"servant-machines\" \"servant-conduit\" \"servant-pipes\" \"doc/cookbook/basic-auth\" \"doc/cookbook/curl-mock\" \"doc/cookbook/basic-streaming\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/file-upload\" \"doc/cookbook/generic\" \"doc/cookbook/hoist-server-with-context\" \"doc/cookbook/https\" \"doc/cookbook/jwt-and-basic-auth\" \"doc/cookbook/testing\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\" \"doc/cookbook/using-free-client\"\\n' > cabal.project"
+  - "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-http-streams\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"servant-machines\" \"servant-conduit\" \"servant-pipes\" \"doc/cookbook/basic-auth\" \"doc/cookbook/curl-mock\" \"doc/cookbook/basic-streaming\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/file-upload\" \"doc/cookbook/generic\" \"doc/cookbook/hoist-server-with-context\" \"doc/cookbook/https\" \"doc/cookbook/jwt-and-basic-auth\" \"doc/cookbook/testing\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\" \"doc/cookbook/using-free-client\"\\n' > cabal.project"
   - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
   - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
   - "echo 'allow-newer: servant-js:base, servant-quickcheck:servant, servant-quickcheck:servant-client, servant-quickcheck:servant-server,servant-quickcheck:hspec,servant-quickcheck:http-client' >> cabal.project"
   - touch cabal.project.local
-  - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg  | grep -vw -- servant | grep -vw -- servant-client | grep -vw -- servant-client-core | grep -vw -- servant-docs | grep -vw -- servant-foreign | grep -vw -- servant-server | grep -vw -- tutorial | grep -vw -- servant-machines | grep -vw -- servant-conduit | grep -vw -- servant-pipes | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-basic-streaming | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-hoist-server-with-context | grep -vw -- cookbook-https | grep -vw -- cookbook-jwt-and-basic-auth | grep -vw -- cookbook-testing | grep -vw -- cookbook-structuring-apis | grep -vw -- cookbook-using-custom-monad | grep -vw -- cookbook-using-free-client | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
+  - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg  | grep -vw -- servant | grep -vw -- servant-client | grep -vw -- servant-client-core | grep -vw -- servant-http-streams | grep -vw -- servant-docs | grep -vw -- servant-foreign | grep -vw -- servant-server | grep -vw -- tutorial | grep -vw -- servant-machines | grep -vw -- servant-conduit | grep -vw -- servant-pipes | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-basic-streaming | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-hoist-server-with-context | grep -vw -- cookbook-https | grep -vw -- cookbook-jwt-and-basic-auth | grep -vw -- cookbook-testing | grep -vw -- cookbook-structuring-apis | grep -vw -- cookbook-using-custom-monad | grep -vw -- cookbook-using-free-client | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
   - cat cabal.project || true
   - cat cabal.project.local || true
   - if [ -f "servant/configure.ac" ]; then
@@ -86,6 +86,9 @@ install:
   - if [ -f "servant-client-core/configure.ac" ]; then
       (cd "servant-client-core" && autoreconf -i);
     fi
+  - if [ -f "servant-http-streams/configure.ac" ]; then
+      (cd "servant-http-streams" && autoreconf -i);
+    fi
   - if [ -f "servant-docs/configure.ac" ]; then
       (cd "servant-docs" && autoreconf -i);
     fi
@@ -150,7 +153,7 @@ install:
       (cd "doc/cookbook/using-free-client" && autoreconf -i);
     fi
   - rm -f cabal.project.freeze
-  - rm -rf .ghc.environment.* "servant"/dist "servant-client"/dist "servant-client-core"/dist "servant-docs"/dist "servant-foreign"/dist "servant-server"/dist "doc/tutorial"/dist "servant-machines"/dist "servant-conduit"/dist "servant-pipes"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/curl-mock"/dist "doc/cookbook/basic-streaming"/dist "doc/cookbook/db-postgres-pool"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/file-upload"/dist "doc/cookbook/generic"/dist "doc/cookbook/hoist-server-with-context"/dist "doc/cookbook/https"/dist "doc/cookbook/jwt-and-basic-auth"/dist "doc/cookbook/testing"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist "doc/cookbook/using-free-client"/dist
+  - rm -rf .ghc.environment.* "servant"/dist "servant-client"/dist "servant-client-core"/dist "servant-http-streams"/dist "servant-docs"/dist "servant-foreign"/dist "servant-server"/dist "doc/tutorial"/dist "servant-machines"/dist "servant-conduit"/dist "servant-pipes"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/curl-mock"/dist "doc/cookbook/basic-streaming"/dist "doc/cookbook/db-postgres-pool"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/file-upload"/dist "doc/cookbook/generic"/dist "doc/cookbook/hoist-server-with-context"/dist "doc/cookbook/https"/dist "doc/cookbook/jwt-and-basic-auth"/dist "doc/cookbook/testing"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist "doc/cookbook/using-free-client"/dist
   - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
 
 # Here starts the actual work to be performed for the package under test;
@@ -164,12 +167,12 @@ script:
   - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
   - cd ${DISTDIR} || false
   - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
-  - "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal servant-machines-*/*.cabal servant-conduit-*/*.cabal servant-pipes-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-curl-mock-*/*.cabal cookbook-basic-streaming-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-file-upload-*/*.cabal cookbook-generic-*/*.cabal cookbook-hoist-server-with-context-*/*.cabal cookbook-https-*/*.cabal cookbook-jwt-and-basic-auth-*/*.cabal cookbook-testing-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal cookbook-using-free-client-*/*.cabal\\n' > cabal.project"
+  - "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-http-streams-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal servant-machines-*/*.cabal servant-conduit-*/*.cabal servant-pipes-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-curl-mock-*/*.cabal cookbook-basic-streaming-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-file-upload-*/*.cabal cookbook-generic-*/*.cabal cookbook-hoist-server-with-context-*/*.cabal cookbook-https-*/*.cabal cookbook-jwt-and-basic-auth-*/*.cabal cookbook-testing-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal cookbook-using-free-client-*/*.cabal\\n' > cabal.project"
   - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
   - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
   - "echo 'allow-newer: servant-js:base, servant-quickcheck:servant, servant-quickcheck:servant-client, servant-quickcheck:servant-server,servant-quickcheck:hspec,servant-quickcheck:http-client' >> cabal.project"
   - touch cabal.project.local
-  - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg  | grep -vw -- servant | grep -vw -- servant-client | grep -vw -- servant-client-core | grep -vw -- servant-docs | grep -vw -- servant-foreign | grep -vw -- servant-server | grep -vw -- tutorial | grep -vw -- servant-machines | grep -vw -- servant-conduit | grep -vw -- servant-pipes | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-basic-streaming | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-hoist-server-with-context | grep -vw -- cookbook-https | grep -vw -- cookbook-jwt-and-basic-auth | grep -vw -- cookbook-testing | grep -vw -- cookbook-structuring-apis | grep -vw -- cookbook-using-custom-monad | grep -vw -- cookbook-using-free-client | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
+  - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg  | grep -vw -- servant | grep -vw -- servant-client | grep -vw -- servant-client-core | grep -vw -- servant-http-streams | grep -vw -- servant-docs | grep -vw -- servant-foreign | grep -vw -- servant-server | grep -vw -- tutorial | grep -vw -- servant-machines | grep -vw -- servant-conduit | grep -vw -- servant-pipes | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-basic-streaming | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-hoist-server-with-context | grep -vw -- cookbook-https | grep -vw -- cookbook-jwt-and-basic-auth | grep -vw -- cookbook-testing | grep -vw -- cookbook-structuring-apis | grep -vw -- cookbook-using-custom-monad | grep -vw -- cookbook-using-free-client | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
   - cat cabal.project || true
   - cat cabal.project.local || true
   - echo -en 'travis_fold:end:unpack\\r'

cabal.project

@@ -1,6 +1,8 @@
-packages: servant/
+packages:
+  servant/
   servant-client/
   servant-client-core/
+  servant-http-streams/
   servant-docs/
   servant-foreign/
   servant-server/

doc/cookbook/using-free-client/UsingFreeClient.lhs

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

servant-client-core/servant-client-core.cabal

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

servant-client-core/src/Servant/Client/Core.hs

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

servant-client-core/src/Servant/Client/Core/Internal/ClientError.hs

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

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

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

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

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

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

@@ -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)
+                 (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
-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)
 
 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
+  | RequestBodySource (SourceIO LBS.ByteString)
-  | RequestBodyStream Int64 ((IO BS.ByteString -> IO ()) -> IO ())
-  | RequestBodyStreamChunked ((IO BS.ByteString -> IO ()) -> IO ())
-  | RequestBodyIO (IO RequestBody)
   deriving (Generic, Typeable)
 
-data GenResponse a = Response
+instance Show RequestBody where
-  { responseStatusCode  :: Status
+    showsPrec d (RequestBodyLBS lbs) = showParen (d > 10)
-  , responseHeaders     :: Seq.Seq Header
+        $ showString "RequestBodyLBS "
-  , responseHttpVersion :: HttpVersion
+        . showsPrec 11 lbs
-  , 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)
 
 -- A GET request to the top-level path
 defaultRequest :: Request

servant-client-core/src/Servant/Client/Core/Internal/Response.hs

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

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

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

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

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

servant-client/src/Servant/Client/Internal/HttpClient.hs

@@ -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 :: (a -> b) -> Client.Response a -> ResponseF b
-clientResponseToResponse r = Response
+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'
+        RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper
-      RequestBodyStream size body' -> Client.RequestBodyStream size body'
+          where
-      RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body'
+            givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
-      RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body')
+            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)
+        Nothing           -> (Client.RequestBodyBS "", Nothing)
-      Just (body', typ)
+        Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))
-        -> (convertBody body', Just (hContentType, renderHeader typ))
 
     isSecure = case baseUrlScheme burl of
         Http -> False

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

@@ -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,
+                 clientResponseToResponse, mkClientEnv, mkFailureResponse,
-                 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

servant-http-streams/CHANGELOG.md

@@ -0,0 +1,2 @@
+  [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-http-streams/CHANGELOG.md)
+[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)

servant-http-streams/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Zalora South East Asia Pte Ltd nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

servant-http-streams/README.lhs

@@ -0,0 +1 @@
+README.md

servant-http-streams/README.md

@@ -0,0 +1,44 @@
+# servant-client
+
+![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
+
+This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice.
+
+## Example
+
+``` haskell
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+import Data.Proxy
+import Data.Text
+import Servant.API
+import Servant.HttpStreams
+
+
+type Book = Text
+
+type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
+        :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
+
+myApi :: Proxy MyApi
+myApi = Proxy
+
+-- 'client' allows you to produce operations to query an API from a client.
+postNewBook :: Book -> ClientM Book
+getAllBooks :: ClientM [Book]
+(getAllBooks :<|> postNewBook) = client myApi
+
+-- the IOException happens already in withClientEnvIO
+main' :: IO ()
+main' = do
+    let burl = BaseUrl Http "localhost" 8081 ""
+    withClientEnvIO burl $ \env -> do
+        res <- runClientM getAllBooks env
+        case res of
+            Left err -> putStrLn $ "Error: " ++ show err
+            Right books -> print books
+
+main :: IO ()
+main = return ()
+```

servant-http-streams/Setup.hs

@@ -0,0 +1,2 @@
+import           Distribution.Simple
+main = defaultMain

servant-http-streams/servant-http-streams.cabal

@@ -0,0 +1,137 @@
+cabal-version:       >=1.10
+name:                servant-http-streams
+version:             0.15
+
+synopsis:            Automatic derivation of querying functions for servant
+category:            Servant, Web
+description:
+  This library lets you derive automatically Haskell functions that
+  let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
+  .
+  See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.
+  .
+  <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
+
+homepage:            http://haskell-servant.readthedocs.org/
+bug-reports:         http://github.com/haskell-servant/servant/issues
+license:             BSD3
+license-file:        LICENSE
+author:              Servant Contributors
+maintainer:          haskell-servant-maintainers@googlegroups.com
+copyright:           2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
+build-type:          Simple
+tested-with:
+  GHC ==8.0.2
+   || ==8.2.2
+   || ==8.4.4
+   || ==8.6.2
+
+extra-source-files:
+  CHANGELOG.md
+  README.md
+
+source-repository head
+  type: git
+  location: http://github.com/haskell-servant/servant.git
+
+library
+  exposed-modules:
+    Servant.HttpStreams
+    Servant.HttpStreams.Internal
+
+  -- Bundled with GHC: Lower bound to not force re-installs
+  -- text and mtl are bundled starting with GHC-8.4
+  build-depends:
+      base                  >= 4.9      && < 4.13
+    , bytestring            >= 0.10.8.1 && < 0.11
+    , containers            >= 0.5.7.1  && < 0.7
+    , deepseq               >= 1.4.2.0  && < 1.5
+    , mtl                   >= 2.2.2    && < 2.3
+    , text                  >= 1.2.3.0  && < 1.3
+    , time                  >= 1.6.0.1  && < 1.9
+    , transformers          >= 0.5.2.0  && < 0.6
+
+  if !impl(ghc >= 8.2)
+    build-depends:
+      bifunctors >= 5.5.3 && < 5.6
+
+  -- Servant dependencies.
+  -- Strict dependency on `servant-client-core` as we re-export things.
+  build-depends:
+      servant               == 0.15.*
+    , servant-client-core   >= 0.15 && <0.15.1
+
+  -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
+  -- Here can be exceptions if we really need features from the newer versions.
+  build-depends:
+      base-compat           >= 0.10.5   && < 0.11
+    , case-insensitive
+    , http-streams          >= 0.8.6.1  && < 0.9
+    , http-media            >= 0.7.1.3  && < 0.8
+    , io-streams            >=1.5.0.1   && < 1.6
+    , http-types            >= 0.12.2   && < 0.13
+    , http-common           >= 0.8.2.0  && < 0.9
+    , exceptions            >= 0.10.0   && < 0.11
+    , kan-extensions        >= 5.2      && < 5.3
+    , monad-control         >= 1.0.2.3  && < 1.1
+    , semigroupoids         >= 5.3.1    && < 5.4
+    , transformers-base     >= 0.4.5.2  && < 0.5
+    , transformers-compat   >= 0.6.2    && < 0.7
+
+  hs-source-dirs: src
+  default-language: Haskell2010
+  ghc-options: -Wall -Wno-redundant-constraints
+
+test-suite spec
+  type: exitcode-stdio-1.0
+  ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"
+  default-language: Haskell2010
+  hs-source-dirs: test
+  main-is: Spec.hs
+  other-modules:
+      Servant.ClientSpec
+      Servant.StreamSpec
+
+  -- Dependencies inherited from the library. No need to specify bounds.
+  build-depends:
+      base
+    , aeson
+    , base-compat
+    , bytestring
+    , http-api-data
+    , http-streams
+    , deepseq
+    , http-types
+    , mtl
+    , kan-extensions
+    , servant-http-streams
+    , servant-client-core
+    , stm
+    , text
+    , transformers
+    , transformers-compat
+    , wai
+    , warp
+
+  -- 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
+    , QuickCheck        >= 2.12.6.1 && < 2.13
+    , servant           == 0.15.*
+    , servant-server    == 0.15.*
+    , tdigest           >= 0.2     && < 0.3
+
+  build-tool-depends:
+    hspec-discover:hspec-discover >= 2.6.0 && < 2.7
+
+test-suite readme
+  type:           exitcode-stdio-1.0
+  main-is:        README.lhs
+  build-depends:  base, servant, http-streams, text, servant-http-streams, markdown-unlit
+  build-tool-depends: markdown-unlit:markdown-unlit
+  ghc-options:    -pgmL markdown-unlit
+  default-language: Haskell2010

servant-http-streams/src/Servant/HttpStreams.hs

@@ -0,0 +1,19 @@
+
+
+-- | This module provides 'client' which can automatically generate
+-- querying functions for each endpoint just from the type representing your
+-- API.
+module Servant.HttpStreams
+  ( client
+  , ClientM
+  , withClientM
+  , runClientM
+  , ClientEnv(..)
+  , mkClientEnv
+  , withClientEnvIO
+  , hoistClient
+  , module Servant.Client.Core.Reexport
+  ) where
+
+import           Servant.Client.Core.Reexport
+import           Servant.HttpStreams.Internal

servant-http-streams/src/Servant/HttpStreams/Internal.hs

@@ -0,0 +1,254 @@
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeFamilies               #-}
+module Servant.HttpStreams.Internal where
+
+import           Prelude ()
+import           Prelude.Compat
+
+import           Control.DeepSeq
+                 (NFData, force)
+import           Control.Exception
+                 (IOException, SomeException (..), catch, evaluate, throwIO)
+import           Control.Monad.Base
+                 (MonadBase (..))
+import           Control.Monad.Codensity
+                 (Codensity (..))
+import           Control.Monad.Error.Class
+                 (MonadError (..))
+import           Control.Monad.IO.Class
+                 (liftIO)
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Except
+import           Data.Bifunctor
+                 (bimap, first)
+import           Data.ByteString.Builder
+                 (toLazyByteString)
+import qualified Data.ByteString.Builder    as B
+import qualified Data.ByteString.Lazy       as BSL
+import qualified Data.CaseInsensitive       as CI
+import           Data.Foldable
+                 (for_, toList)
+import           Data.Functor.Alt
+                 (Alt (..))
+import           Data.Maybe
+                 (maybeToList)
+import           Data.Proxy
+                 (Proxy (..))
+import           Data.Semigroup
+                 ((<>))
+import           Data.Sequence
+                 (fromList)
+import           Data.String
+                 (fromString)
+import           GHC.Generics
+import           Network.HTTP.Media
+                 (renderHeader)
+import           Network.HTTP.Types
+                 (Status (..), hContentType, http11, renderQuery)
+import           Servant.Client.Core
+
+import qualified Network.Http.Client        as Client
+import qualified Network.Http.Types         as Client
+import qualified Servant.Types.SourceT      as S
+import qualified System.IO.Streams          as Streams
+
+-- | The environment in which a request is run.
+--
+-- 'ClientEnv' carries an open connection. See 'withClientEnvIO'.
+--
+data ClientEnv
+    = ClientEnv
+    { baseUrl    :: BaseUrl
+    , connection :: Client.Connection
+    }
+
+-- | 'ClientEnv' smart constructor.
+mkClientEnv :: BaseUrl -> Client.Connection -> ClientEnv
+mkClientEnv = ClientEnv
+
+-- | Open a connection to 'BaseUrl'.
+withClientEnvIO :: BaseUrl -> (ClientEnv -> IO r) -> IO r
+withClientEnvIO burl k = Client.withConnection open $ \conn ->
+    k (mkClientEnv burl conn)
+  where
+    open = Client.openConnection (fromString $ baseUrlHost burl) (fromIntegral $ baseUrlPort burl)
+
+-- | Generates a set of client functions for an API.
+--
+-- Example:
+--
+-- > type API = Capture "no" Int :> Get '[JSON] Int
+-- >        :<|> Get '[JSON] [Bool]
+-- >
+-- > api :: Proxy API
+-- > api = Proxy
+-- >
+-- > getInt :: Int -> ClientM Int
+-- > getBools :: ClientM [Bool]
+-- > getInt :<|> getBools = client api
+client :: HasClient ClientM api => Proxy api -> Client ClientM api
+client api = api `clientIn` (Proxy :: Proxy ClientM)
+
+-- | Change the monad the client functions live in, by
+--   supplying a conversion function
+--   (a natural transformation to be precise).
+--
+--   For example, assuming you have some @manager :: 'Manager'@ and
+--   @baseurl :: 'BaseUrl'@ around:
+--
+--   > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
+--   > api :: Proxy API
+--   > api = Proxy
+--   > getInt :: IO Int
+--   > postInt :: Int -> IO Int
+--   > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)
+--   >   where cenv = mkClientEnv manager baseurl
+hoistClient
+    :: HasClient ClientM api
+    => Proxy api
+    -> (forall a. m a -> n a)
+    -> Client m api
+    -> Client n api
+hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)
+
+-- | @ClientM@ is the monad in which client functions run. Contains the
+-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
+newtype ClientM a = ClientM
+    { unClientM :: ReaderT ClientEnv (ExceptT ServantError (Codensity IO)) a }
+  deriving ( Functor, Applicative, Monad, MonadIO, Generic
+           , MonadReader ClientEnv, MonadError ServantError)
+
+instance MonadBase IO ClientM where
+    liftBase = ClientM . liftIO
+
+-- | Try clients in order, last error is preserved.
+instance Alt ClientM where
+    a <!> b = a `catchError` \_ -> b
+
+instance RunClient ClientM where
+    runRequest = performRequest
+    throwServantError = throwError
+
+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)
+
+withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b
+withClientM cm env k =
+    let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
+    in f k
+
+performRequest :: Request -> ClientM Response
+performRequest req = do
+    ClientEnv burl conn <- ask
+    let (req', body) = requestToClientRequest burl req
+    x <- ClientM $ lift $ lift $ Codensity $ \k -> do
+        Client.sendRequest conn req' body
+        Client.receiveResponse conn $ \res' body' -> do
+            let sc = Client.getStatusCode res'
+            lbs <- BSL.fromChunks <$> Streams.toList body'
+            let res'' = clientResponseToResponse res' lbs
+            if sc >= 200 && sc < 300
+            then k (Right res'')
+            else k (Left (mkFailureResponse burl req res''))
+
+    either throwError pure x
+
+performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
+performWithStreamingRequest req k = do
+    ClientEnv burl conn <- ask
+    let (req', body) = requestToClientRequest burl req
+    ClientM $ lift $ lift $ Codensity $ \k1 -> do
+        Client.sendRequest conn req' body
+        Client.receiveResponseRaw conn $ \res' body' -> do
+            -- check status code
+            let sc = Client.getStatusCode res'
+            unless (sc >= 200 && sc < 300) $ do
+                lbs <- BSL.fromChunks <$> Streams.toList body'
+                throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)
+
+            x <- k (clientResponseToResponse res' (fromInputStream body'))
+            k1 x
+
+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 -> body -> ResponseF body
+clientResponseToResponse r body = Response
+    { responseStatusCode  = Status (Client.getStatusCode r) (Client.getStatusMessage r)
+    , responseBody        = body
+    , responseHeaders     = fromList $ map (first CI.mk) $ Client.retrieveHeaders $ Client.getHeaders r
+    , responseHttpVersion = http11 -- guess
+    }
+
+requestToClientRequest :: BaseUrl -> Request -> (Client.Request, Streams.OutputStream B.Builder -> IO ())
+requestToClientRequest burl r = (request, body)
+  where
+    request = Client.buildRequest1 $ do
+        Client.http (Client.Method $ requestMethod r)
+            $ fromString (baseUrlPath burl)
+            <> BSL.toStrict (toLazyByteString (requestPath r))
+            <> renderQuery True (toList (requestQueryString r))
+        -- We are connected, but we still need to know what we try to query
+        Client.setHostname (fromString $ baseUrlHost burl) (fromIntegral $ baseUrlPort burl)
+        for_ (maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers) $ \(hn, hv) ->
+            Client.setHeader (CI.original hn) hv
+
+        -- body is always chunked
+        Client.setTransferEncoding
+
+    -- Content-Type and Accept are specified by requestBody and requestAccept
+    headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
+        toList $ requestHeaders r
+
+    acceptHdr
+        | null hs   = Nothing
+        | otherwise = Just ("Accept", renderHeader hs)
+      where
+        hs = toList $ requestAccept r
+
+    convertBody bd os = case bd of
+        RequestBodyLBS body' ->
+            Streams.writeTo os (Just (B.lazyByteString body'))
+        RequestBodyBS body' ->
+            Streams.writeTo os (Just (B.byteString body'))
+        RequestBodySource sourceIO ->
+            toOutputStream sourceIO os
+
+    (body, contentTypeHdr) = case requestBody r of
+        Nothing           -> (Client.emptyBody, Nothing)
+        Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))
+
+catchConnectionError :: IO a -> IO (Either ServantError a)
+catchConnectionError action =
+  catch (Right <$> action) $ \e ->
+    pure . Left . ConnectionError $ SomeException (e :: IOException)
+
+fromInputStream :: Streams.InputStream b -> S.SourceT IO b
+fromInputStream is = S.SourceT $ \k -> k loop where
+    loop = S.Effect $ maybe S.Stop (flip S.Yield loop) <$> Streams.read is
+
+toOutputStream :: S.SourceT IO BSL.ByteString -> Streams.OutputStream B.Builder -> IO ()
+toOutputStream (S.SourceT k) os = k loop where
+    loop S.Stop        = return ()
+    loop (S.Error err) = fail err
+    loop (S.Skip s)    = loop s
+    loop (S.Effect mx) = mx >>= loop
+    loop (S.Yield x s) = Streams.write (Just (B.lazyByteString x)) os >> loop s

servant-http-streams/test/Servant/ClientSpec.hs

@@ -0,0 +1,571 @@
+{-# LANGUAGE CPP                    #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE DeriveGeneric          #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs                  #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE RecordWildCards        #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE StandaloneDeriving     #-}
+{-# LANGUAGE TypeApplications       #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
+{-# OPTIONS_GHC -freduction-depth=100 #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where
+
+import           Prelude ()
+import           Prelude.Compat
+
+import           Control.Arrow
+                 (left)
+import           Control.Concurrent
+                 (ThreadId, forkIO, killThread)
+import           Control.DeepSeq
+                 (NFData (..))
+import           Control.Exception
+                 (bracket, fromException, IOException)
+import           Control.Monad.Error.Class
+                 (throwError)
+import           Data.Aeson
+import           Data.Char
+                 (chr, isPrint)
+import           Data.Foldable
+                 (forM_, toList)
+import           Data.Maybe
+                 (isJust)
+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
+import           Network.Socket
+import qualified Network.Wai                          as Wai
+import           Network.Wai.Handler.Warp
+import           Test.Hspec
+import           Test.Hspec.QuickCheck
+import           Test.HUnit
+import           Test.QuickCheck
+import           Web.FormUrlEncoded
+                 (FromForm, ToForm)
+
+import           Servant.API
+                 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
+                 BasicAuthData (..), Capture, CaptureAll, Delete,
+                 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           Servant.HttpStreams
+import           Servant.Server
+import           Servant.Server.Experimental.Auth
+import           Servant.Test.ComprehensiveAPI
+
+-- This declaration simply checks that all instances are in place.
+_ = client comprehensiveAPIWithoutStreaming
+
+spec :: Spec
+spec = describe "Servant.HttpStreams" $ do
+    sucessSpec
+    failSpec
+    wrappedApiSpec
+    basicAuthSpec
+    genAuthSpec
+    genericClientSpec
+    hoistClientSpec
+    connectionErrorSpec
+
+-- * test data types
+
+data Person = Person
+  { _name :: String
+  , _age  :: Integer
+  } deriving (Eq, Show, Generic)
+
+instance NFData Person where
+    rnf (Person n a) = rnf n `seq` rnf a
+
+instance ToJSON Person
+instance FromJSON Person
+
+instance ToForm Person
+instance FromForm Person
+
+instance Arbitrary Person where
+  arbitrary = Person <$> arbitrary <*> arbitrary
+
+alice :: Person
+alice = Person "Alice" 42
+
+carol :: Person
+carol = Person "Carol" 17
+
+type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
+
+type Api =
+  Get '[JSON] Person
+  :<|> "get" :> Get '[JSON] Person
+  :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
+  :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
+  :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
+  :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
+  :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
+  :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
+  :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
+  :<|> "rawSuccess" :> Raw
+  :<|> "rawFailure" :> Raw
+  :<|> "multiple" :>
+            Capture "first" String :>
+            QueryParam "second" Int :>
+            QueryFlag "third" :>
+            ReqBody '[JSON] [(String, [Rational])] :>
+            Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
+  :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
+  :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
+  :<|> "redirectWithCookie" :> Raw
+  :<|> "empty" :> EmptyAPI
+
+api :: Proxy Api
+api = Proxy
+
+getRoot         :: ClientM Person
+getGet          :: ClientM Person
+getDeleteEmpty  :: ClientM NoContent
+getCapture      :: String -> ClientM Person
+getCaptureAll   :: [String] -> ClientM [Person]
+getBody         :: Person -> ClientM Person
+getQueryParam   :: Maybe String -> ClientM Person
+getQueryParams  :: [String] -> ClientM [Person]
+getQueryFlag    :: Bool -> ClientM Bool
+getRawSuccess   :: HTTP.Method -> ClientM Response
+getRawFailure   :: HTTP.Method -> ClientM Response
+getMultiple     :: String -> Maybe Int -> Bool -> [(String, [Rational])]
+  -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
+getRespHeaders  :: ClientM (Headers TestHeaders Bool)
+getDeleteContentType :: ClientM NoContent
+_getRedirectWithCookie :: HTTP.Method -> ClientM Response
+
+getRoot
+  :<|> getGet
+  :<|> getDeleteEmpty
+  :<|> getCapture
+  :<|> getCaptureAll
+  :<|> getBody
+  :<|> getQueryParam
+  :<|> getQueryParams
+  :<|> getQueryFlag
+  :<|> getRawSuccess
+  :<|> getRawFailure
+  :<|> getMultiple
+  :<|> getRespHeaders
+  :<|> getDeleteContentType
+  :<|> _getRedirectWithCookie
+  :<|> EmptyClient = client api
+
+server :: Application
+server = serve api (
+       return carol
+  :<|> return alice
+  :<|> return NoContent
+  :<|> (\ name -> return $ Person name 0)
+  :<|> (\ names -> return (zipWith Person names [0..]))
+  :<|> return
+  :<|> (\ name -> case name of
+                   Just "alice" -> return alice
+                   Just n -> throwError $ ServantErr 400 (n ++ " not found") "" []
+                   Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])
+  :<|> (\ names -> return (zipWith Person names [0..]))
+  :<|> return
+  :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
+  :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
+  :<|> (\ a b c d -> return (a, b, c, d))
+  :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
+  :<|> return NoContent
+  :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
+  :<|> emptyServer)
+
+type FailApi =
+       "get" :> Raw
+  :<|> "capture" :> Capture "name" String :> Raw
+  :<|> "body" :> Raw
+failApi :: Proxy FailApi
+failApi = Proxy
+
+failServer :: Application
+failServer = serve failApi (
+       (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")
+  :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
+  :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
+ )
+
+-- * basic auth stuff
+
+type BasicAuthAPI =
+       BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
+
+basicAuthAPI :: Proxy BasicAuthAPI
+basicAuthAPI = Proxy
+
+basicAuthHandler :: BasicAuthCheck ()
+basicAuthHandler =
+  let check (BasicAuthData username password) =
+        if username == "servant" && password == "server"
+        then return (Authorized ())
+        else return Unauthorized
+  in BasicAuthCheck check
+
+basicServerContext :: Context '[ BasicAuthCheck () ]
+basicServerContext = basicAuthHandler :. EmptyContext
+
+basicAuthServer :: Application
+basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
+
+-- * general auth stuff
+
+type GenAuthAPI =
+  AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person
+
+genAuthAPI :: Proxy GenAuthAPI
+genAuthAPI = Proxy
+
+type instance AuthServerData (AuthProtect "auth-tag") = ()
+type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()
+
+genAuthHandler :: AuthHandler Wai.Request ()
+genAuthHandler =
+  let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
+        Nothing -> throwError (err401 { errBody = "Missing auth header" })
+        Just _ -> return ()
+  in mkAuthHandler handler
+
+genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
+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)
+
+runClientUnsafe :: ClientM a -> BaseUrl -> IO (Either ServantError a)
+runClientUnsafe x burl = withClientEnvIO burl (runClientMUnsafe x)
+  where
+    runClientMUnsafe x env = withClientM x env return
+
+sucessSpec :: Spec
+sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
+    it "Servant.API.Get root" $ \(_, baseUrl) -> do
+      left show <$> runClient getRoot baseUrl  `shouldReturn` Right carol
+
+    it "Servant.API.Get" $ \(_, baseUrl) -> do
+      left show <$> runClient getGet baseUrl  `shouldReturn` Right alice
+
+    describe "Servant.API.Delete" $ do
+      it "allows empty content type" $ \(_, baseUrl) -> do
+        left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent
+
+      it "allows content type" $ \(_, baseUrl) -> do
+        left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent
+
+    it "Servant.API.Capture" $ \(_, baseUrl) -> do
+      left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0)
+
+    it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
+      let expected = [(Person "Paula" 0), (Person "Peta" 1)]
+      left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected
+
+    it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
+      let p = Person "Clara" 42
+      left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
+
+    it "Servant.API FailureResponse" $ \(_, baseUrl) -> do
+      left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
+      Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl
+      Req.requestPath req `shouldBe` (baseUrl, "/param")
+      toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")]
+      Req.requestMethod req `shouldBe` HTTP.methodGet
+
+    it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
+      left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
+      Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
+      responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
+
+    it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
+      left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
+      left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
+        `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
+
+    context "Servant.API.QueryParam.QueryFlag" $
+      forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
+        left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
+
+    it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
+      res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
+      case res of
+        Left e -> assertFailure $ show e
+        Right r -> do
+          responseStatusCode r `shouldBe` HTTP.status200
+          responseBody r `shouldBe` "rawSuccess"
+
+    it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
+      res <- runClient (getRawFailure HTTP.methodGet) baseUrl
+      case res of
+        Right _ -> assertFailure "expected Left, but got Right"
+        Left (FailureResponse _ r) -> do
+          responseStatusCode r `shouldBe` HTTP.status400
+          responseBody r `shouldBe` "rawFailure"
+        Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
+
+    it "Returns headers appropriately" $ \(_, baseUrl) -> do
+      res <- runClient getRespHeaders baseUrl
+      case res of
+        Left e -> assertFailure $ show e
+        Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
+
+    modifyMaxSuccess (const 20) $ do
+      it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
+        property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
+          ioProperty $ do
+            result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
+            return $
+              result === Right (cap, num, flag, body)
+
+
+wrappedApiSpec :: Spec
+wrappedApiSpec = describe "error status codes" $ do
+  let serveW api = serve api $ throwError $ ServantErr 500 "error message" "" []
+  context "are correctly handled by the client" $
+    let test :: (WrappedApi, String) -> Spec
+        test (WrappedApi api, desc) =
+          it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
+            let getResponse :: ClientM ()
+                getResponse = client api
+            Left (FailureResponse _ r) <- runClient getResponse baseUrl
+            responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")
+    in mapM_ test $
+        (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
+        (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
+        (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
+        (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
+        []
+
+failSpec :: Spec
+failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
+
+    context "client returns errors appropriately" $ do
+      it "reports FailureResponse" $ \(_, baseUrl) -> do
+        let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
+        Left res <- runClient getDeleteEmpty baseUrl
+        case res of
+          FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
+          _ -> fail $ "expected 404 response, but got " <> show res
+
+      it "reports DecodeFailure" $ \(_, baseUrl) -> do
+        let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
+        Left res <- runClient (getCapture "foo") baseUrl
+        case res of
+          DecodeFailure _ _ -> return ()
+          _ -> fail $ "expected DecodeFailure, but got " <> show res
+
+      -- we don't catch IOException's
+      xit "reports ConnectionError" $ \_ -> do
+        let (getGetWrongHost :<|> _) = client api
+        Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
+        case res of
+          ConnectionError _ -> return ()
+          _ -> fail $ "expected ConnectionError, but got " <> show res
+
+      it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
+        let (_ :<|> getGet :<|> _ ) = client api
+        Left res <- runClient getGet baseUrl
+        case res of
+          UnsupportedContentType ("application/octet-stream") _ -> return ()
+          _ -> fail $ "expected UnsupportedContentType, but got " <> show res
+
+      it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
+        let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
+        Left res <- runClient (getBody alice) baseUrl
+        case res of
+          InvalidContentTypeHeader _ -> return ()
+          _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
+
+data WrappedApi where
+  WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
+                 HasClient ClientM api, Client ClientM api ~ ClientM ()) =>
+    Proxy api -> WrappedApi
+
+basicAuthSpec :: Spec
+basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
+  context "Authentication works when requests are properly authenticated" $ do
+
+    it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
+      let getBasic = client basicAuthAPI
+      let basicAuthData = BasicAuthData "servant" "server"
+      left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice
+
+  context "Authentication is rejected when requests are not authenticated properly" $ do
+
+    it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
+      let getBasic = client basicAuthAPI
+      let basicAuthData = BasicAuthData "not" "password"
+      Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl
+      responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
+
+genAuthSpec :: Spec
+genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
+  context "Authentication works when requests are properly authenticated" $ do
+
+    it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
+      let getProtected = client genAuthAPI
+      let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)
+      left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice
+
+  context "Authentication is rejected when requests are not authenticated properly" $ do
+
+    it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
+      let getProtected = client genAuthAPI
+      let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
+      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
+
+hoistClientAPI :: Proxy HoistClientAPI
+hoistClientAPI = Proxy
+
+hoistClientServer :: Application -- implements HoistClientAPI
+hoistClientServer = serve hoistClientAPI $ return 5 :<|> (\n -> return n)
+
+hoistClientSpec :: Spec
+hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do
+  describe "Servant.Client.hoistClient" $ do
+    it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do
+      let (getInt :<|> postInt)
+            = hoistClient hoistClientAPI
+                          (fmap (either (error . show) id) . flip runClientUnsafe baseUrl)
+                          (client hoistClientAPI)
+
+      getInt `shouldReturn` 5
+      postInt 5 `shouldReturn` 5
+
+-- * ConnectionError
+type ConnectionErrorAPI = Get '[JSON] Int
+
+connectionErrorAPI :: Proxy ConnectionErrorAPI
+connectionErrorAPI = Proxy
+
+connectionErrorSpec :: Spec
+connectionErrorSpec = describe "Servant.Client.ServantError" $
+    xit "correctly catches ConnectionErrors when the HTTP request can't go through" $ do
+        let getInt = client connectionErrorAPI
+        let baseUrl' = BaseUrl Http "example.invalid" 80 ""
+        let isHttpError (Left (ConnectionError e)) = isJust $ fromException @IOException e
+            isHttpError _ = False
+        (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True
+
+-- * utils
+
+startWaiApp :: Application -> IO (ThreadId, BaseUrl)
+startWaiApp app = do
+    (port, socket) <- openTestSocket
+    let settings = setPort port $ defaultSettings
+    thread <- forkIO $ runSettingsSocket settings socket app
+    return (thread, BaseUrl Http "localhost" port "")
+
+
+endWaiApp :: (ThreadId, BaseUrl) -> IO ()
+endWaiApp (thread, _) = killThread thread
+
+openTestSocket :: IO (Port, Socket)
+openTestSocket = do
+  s <- socket AF_INET Stream defaultProtocol
+  let localhost = tupleToHostAddress (127, 0, 0, 1)
+  bind s (SockAddrInet defaultPort localhost)
+  listen s 1
+  port <- socketPort s
+  return (fromIntegral port, s)
+
+pathGen :: Gen (NonEmptyList Char)
+pathGen = fmap NonEmpty path
+ where
+  path = listOf1 $ elements $
+    filter (not . (`elem` ("?%[]/#;" :: String))) $
+    filter isPrint $
+    map chr [0..127]

servant-http-streams/test/Servant/StreamSpec.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE CPP                    #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE DeriveGeneric          #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs                  #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE RecordWildCards        #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE StandaloneDeriving     #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
+{-# OPTIONS_GHC -freduction-depth=100 #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.StreamSpec (spec) where
+
+import           Control.Monad.Trans.Except
+import qualified Data.ByteString               as BS
+import           Data.Proxy
+import           Prelude ()
+import           Prelude.Compat
+import           Servant.API
+                 ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming,
+                 NewlineFraming, NoFraming, OctetStream, SourceIO, StreamBody,
+                 StreamGet)
+import           Servant.ClientSpec
+                 (Person (..))
+import qualified Servant.ClientSpec            as CS
+import           Servant.HttpStreams
+import           Servant.Server
+import           Servant.Types.SourceT
+import           System.Entropy
+                 (getEntropy, getHardwareEntropy)
+import           Test.Hspec
+
+
+spec :: Spec
+spec = describe "Servant.HttpStreams streaming" $ do
+    streamSpec
+
+type StreamApi =
+         "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)
+    :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)
+    :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
+    :<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
+
+api :: Proxy StreamApi
+api = Proxy
+
+getGetNL, getGetNS :: ClientM (SourceIO Person)
+_getGetALot :: ClientM (SourceIO BS.ByteString)
+getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString)
+getGetNL :<|> getGetNS :<|> _getGetALot :<|> getStreamBody = client api
+
+alice :: Person
+alice = Person "Alice" 42
+
+bob :: Person
+bob = Person "Bob" 25
+
+server :: Application
+server = serve api
+    $    return (source [alice, bob, alice])
+    :<|> return (source [alice, bob, alice])
+    -- 2 ^ (18 + 10) = 256M
+    :<|> return (SourceT ($ lots (powerOfTwo 18)))
+    :<|> return
+  where
+    lots n
+        | n < 0     = Stop
+        | otherwise = Effect $ do
+            let size = powerOfTwo 10
+            mbs <- getHardwareEntropy size
+            bs <- maybe (getEntropy size) pure mbs
+            return (Yield bs (lots (n - 1)))
+
+powerOfTwo :: Int -> Int
+powerOfTwo = (2 ^)
+
+withClient :: ClientM a -> BaseUrl -> (Either ServantError a -> IO r) -> IO r
+withClient x burl k = do
+    withClientEnvIO burl $ \env -> withClientM x env k
+
+testRunSourceIO :: SourceIO a
+    -> IO (Either String [a])
+testRunSourceIO = runExceptT . runSourceT
+
+streamSpec :: Spec
+streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
+    it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
+        withClient getGetNL baseUrl $ \(Right res) ->
+            testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
+
+    it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
+        withClient getGetNS baseUrl $ \(Right res) ->
+            testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
+
+    it "works with Servant.API.StreamBody" $ \(_, baseUrl) -> do
+        withClient (getStreamBody (source input)) baseUrl $ \(Right res) ->
+            testRunSourceIO res `shouldReturn` Right output
+        where
+          input = ["foo", "", "bar"]
+          output = ["foo", "bar"]

servant-http-streams/test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant/src/Servant/API/ResponseHeaders.hs

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