git.iko.soy/typeable/servant
on master help sign in
Merge pull request #1117 from haskell-servant/servant-http-streams
ccaa73fOleg Grenrus
.travis.yml+8−5
compare with master
unifiedsplit
@@ -69,12 +69,12 @@ install:
69 - rm -fv cabal.project cabal.project.local
69 - rm -fv cabal.project cabal.project.local
70 - "if [ $HCNUMVER -ge 70800 ]; then sed -i.bak 's/-- ghc-options:.*/ghc-options: -j2/' ${HOME}/.cabal/config; fi"
70 - "if [ $HCNUMVER -ge 70800 ]; then sed -i.bak 's/-- ghc-options:.*/ghc-options: -j2/' ${HOME}/.cabal/config; fi"
71 - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
71 - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
72− - "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"
72+ - "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"
73 - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
73 - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
74 - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
74 - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
75 - "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"
75 - "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"
76 - touch cabal.project.local
76 - touch cabal.project.local
77− - "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"
77+ - "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"
78 - cat cabal.project || true
78 - cat cabal.project || true
79 - cat cabal.project.local || true
79 - cat cabal.project.local || true
80 - if [ -f "servant/configure.ac" ]; then
80 - if [ -f "servant/configure.ac" ]; then
@@ -86,6 +86,9 @@ install:
86 - if [ -f "servant-client-core/configure.ac" ]; then
86 - if [ -f "servant-client-core/configure.ac" ]; then
87 (cd "servant-client-core" && autoreconf -i);
87 (cd "servant-client-core" && autoreconf -i);
88 fi
88 fi
89+ - if [ -f "servant-http-streams/configure.ac" ]; then
90+ (cd "servant-http-streams" && autoreconf -i);
91+ fi
89 - if [ -f "servant-docs/configure.ac" ]; then
92 - if [ -f "servant-docs/configure.ac" ]; then
90 (cd "servant-docs" && autoreconf -i);
93 (cd "servant-docs" && autoreconf -i);
91 fi
94 fi
@@ -150,7 +153,7 @@ install:
150 (cd "doc/cookbook/using-free-client" && autoreconf -i);
153 (cd "doc/cookbook/using-free-client" && autoreconf -i);
151 fi
154 fi
152 - rm -f cabal.project.freeze
155 - rm -f cabal.project.freeze
153− - 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
156+ - 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
154 - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
157 - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
155
158
156# Here starts the actual work to be performed for the package under test;
159# Here starts the actual work to be performed for the package under test;
@@ -164,12 +167,12 @@ script:
164 - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
167 - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
165 - cd ${DISTDIR} || false
168 - cd ${DISTDIR} || false
166 - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
169 - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
167− - "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"
170+ - "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"
168 - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
171 - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
169 - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
172 - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
170 - "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"
173 - "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"
171 - touch cabal.project.local
174 - touch cabal.project.local
172− - "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"
175+ - "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"
173 - cat cabal.project || true
176 - cat cabal.project || true
174 - cat cabal.project.local || true
177 - cat cabal.project.local || true
175 - echo -en 'travis_fold:end:unpack\\r'
178 - echo -en 'travis_fold:end:unpack\\r'
cabal.project+3−1
@@ -1,6 +1,8 @@
1−packages: servant/
1+packages:
2+ servant/
2 servant-client/
3 servant-client/
3 servant-client-core/
4 servant-client-core/
5+ servant-http-streams/
4 servant-docs/
6 servant-docs/
5 servant-foreign/
7 servant-foreign/
6 servant-server/
8 servant-server/
doc/cookbook/using-free-client/UsingFreeClient.lhs+1−1
@@ -137,7 +137,7 @@ And we continue by turning http-client's `Response` into servant's `Response`,
137and calling the continuation. We should get a `Pure` value.
137and calling the continuation. We should get a `Pure` value.
138
138
139```haskell
139```haskell
140− let res = I.clientResponseToResponse res'
140+ let res = I.clientResponseToResponse id res'
141
141
142 case k res of
142 case k res of
143 Pure n ->
143 Pure n ->
servant-client-core/servant-client-core.cabal+2
@@ -39,10 +39,12 @@ library
39 Servant.Client.Core.Internal.Auth
39 Servant.Client.Core.Internal.Auth
40 Servant.Client.Core.Internal.BaseUrl
40 Servant.Client.Core.Internal.BaseUrl
41 Servant.Client.Core.Internal.BasicAuth
41 Servant.Client.Core.Internal.BasicAuth
42+ Servant.Client.Core.Internal.ClientError
42 Servant.Client.Core.Internal.ClientF
43 Servant.Client.Core.Internal.ClientF
43 Servant.Client.Core.Internal.Generic
44 Servant.Client.Core.Internal.Generic
44 Servant.Client.Core.Internal.HasClient
45 Servant.Client.Core.Internal.HasClient
45 Servant.Client.Core.Internal.Request
46 Servant.Client.Core.Internal.Request
47+ Servant.Client.Core.Internal.Response
46 Servant.Client.Core.Internal.RunClient
48 Servant.Client.Core.Internal.RunClient
47
49
48 -- Bundled with GHC: Lower bound to not force re-installs
50 -- Bundled with GHC: Lower bound to not force re-installs
servant-client-core/src/Servant/Client/Core.hs+3−1
@@ -41,7 +41,7 @@ module Servant.Client.Core
41
41
42 -- * Response
42 -- * Response
43 , Response
43 , Response
44− , GenResponse (..)
44+ , ResponseF (..)
45 , RunClient(..)
45 , RunClient(..)
46 , module Servant.Client.Core.Internal.BaseUrl
46 , module Servant.Client.Core.Internal.BaseUrl
47 -- ** Streaming
47 -- ** Streaming
@@ -64,4 +64,6 @@ import Servant.Client.Core.Internal.BasicAuth
64import Servant.Client.Core.Internal.Generic
64import Servant.Client.Core.Internal.Generic
65import Servant.Client.Core.Internal.HasClient
65import Servant.Client.Core.Internal.HasClient
66import Servant.Client.Core.Internal.Request
66import Servant.Client.Core.Internal.Request
67+import Servant.Client.Core.Internal.Response
68+import Servant.Client.Core.Internal.ClientError
67import Servant.Client.Core.Internal.RunClient
69import Servant.Client.Core.Internal.RunClient
servant-client-core/src/Servant/Client/Core/Internal/ClientError.hsnew file+82
@@ -0,0 +1,82 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DeriveFoldable #-}
3+{-# LANGUAGE DeriveFunctor #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE DeriveTraversable #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeFamilies #-}
11+module Servant.Client.Core.Internal.ClientError where
12+
13+import Prelude ()
14+import Prelude.Compat
15+
16+import Control.DeepSeq
17+ (NFData (..))
18+import Control.Exception
19+ (SomeException (..))
20+import Control.Monad.Catch
21+ (Exception)
22+import qualified Data.ByteString as BS
23+import Data.Text
24+ (Text)
25+import Data.Typeable
26+ (Typeable, typeOf)
27+import GHC.Generics
28+ (Generic)
29+import Network.HTTP.Media (MediaType)
30+import Network.HTTP.Types ()
31+
32+import Servant.Client.Core.Internal.BaseUrl
33+import Servant.Client.Core.Internal.Request
34+import Servant.Client.Core.Internal.Response
35+
36+
37+
38+-- | A type representing possible errors in a request
39+--
40+-- Note that this type substantially changed in 0.12.
41+data ServantError =
42+ -- | The server returned an error response including the
43+ -- failing request. 'requestPath' includes the 'BaseUrl' and the
44+ -- path of the request.
45+ FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response
46+ -- | The body could not be decoded at the expected type
47+ | DecodeFailure Text Response
48+ -- | The content-type of the response is not supported
49+ | UnsupportedContentType MediaType Response
50+ -- | The content-type header is invalid
51+ | InvalidContentTypeHeader Response
52+ -- | There was a connection error, and no response was received
53+ | ConnectionError SomeException
54+ deriving (Show, Generic, Typeable)
55+
56+instance Eq ServantError where
57+ FailureResponse req res == FailureResponse req' res' = req == req' && res == res'
58+ DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r'
59+ UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r'
60+ InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r'
61+ ConnectionError exc == ConnectionError exc' = eqSomeException exc exc'
62+ where
63+ -- returns true, if type of exception is the same
64+ eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b
65+
66+ -- prevent wild card blindness
67+ FailureResponse {} == _ = False
68+ DecodeFailure {} == _ = False
69+ UnsupportedContentType {} == _ = False
70+ InvalidContentTypeHeader {} == _ = False
71+ ConnectionError {} == _ = False
72+
73+instance Exception ServantError
74+
75+-- | Note: an exception in 'ConnectionError' might not be evaluated fully,
76+-- We only 'rnf' its 'show'ed value.
77+instance NFData ServantError where
78+ rnf (FailureResponse req res) = rnf req `seq` rnf res
79+ rnf (DecodeFailure err res) = rnf err `seq` rnf res
80+ rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res
81+ rnf (InvalidContentTypeHeader res) = rnf res
82+ rnf (ConnectionError err) = err `seq` rnf (show err)
servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs+2
@@ -2,6 +2,8 @@
2module Servant.Client.Core.Internal.ClientF where
2module Servant.Client.Core.Internal.ClientF where
3
3
4import Servant.Client.Core.Internal.Request
4import Servant.Client.Core.Internal.Request
5+import Servant.Client.Core.Internal.Response
6+import Servant.Client.Core.Internal.ClientError
5
7
6data ClientF a
8data ClientF a
7 = RunRequest Request (Response -> a)
9 = RunRequest Request (Response -> a)
servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+6−30
@@ -16,10 +16,7 @@ module Servant.Client.Core.Internal.HasClient where
16import Prelude ()
16import Prelude ()
17import Prelude.Compat
17import Prelude.Compat
18
18
19−import Control.Concurrent.MVar
20− (modifyMVar, newMVar)
21−import qualified Data.ByteString as BS
22−import qualified Data.ByteString.Lazy as BL
19+import qualified Data.ByteString.Lazy as BL
23import Data.Foldable
20import Data.Foldable
24 (toList)
21 (toList)
25import Data.List
22import Data.List
@@ -34,7 +31,7 @@ import Data.Text
34 (Text, pack)
31 (Text, pack)
35import GHC.TypeLits
32import GHC.TypeLits
36 (KnownSymbol, symbolVal)
33 (KnownSymbol, symbolVal)
37−import qualified Network.HTTP.Types as H
34+import qualified Network.HTTP.Types as H
38import Servant.API
35import Servant.API
39 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
36 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
40 BuildHeadersTo (..), Capture', CaptureAll, Description,
37 BuildHeadersTo (..), Capture', CaptureAll, Description,
@@ -50,11 +47,12 @@ import Servant.API.ContentTypes
50 (contentTypes)
47 (contentTypes)
51import Servant.API.Modifiers
48import Servant.API.Modifiers
52 (FoldRequired, RequiredArgument, foldRequiredArgument)
49 (FoldRequired, RequiredArgument, foldRequiredArgument)
53−import qualified Servant.Types.SourceT as S
54
50
55import Servant.Client.Core.Internal.Auth
51import Servant.Client.Core.Internal.Auth
56import Servant.Client.Core.Internal.BasicAuth
52import Servant.Client.Core.Internal.BasicAuth
53+import Servant.Client.Core.Internal.ClientError
57import Servant.Client.Core.Internal.Request
54import Servant.Client.Core.Internal.Request
55+import Servant.Client.Core.Internal.Response
58import Servant.Client.Core.Internal.RunClient
56import Servant.Client.Core.Internal.RunClient
59
57
60-- * Accessing APIs as a Client
58-- * Accessing APIs as a Client
@@ -283,7 +281,7 @@ instance {-# OVERLAPPABLE #-}
283 clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
281 clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
284 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
282 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
285 framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
283 framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
286− return $ fromSourceIO $ framingUnrender' $ S.fromAction BS.null (responseBody gres)
284+ return $ fromSourceIO $ framingUnrender' $ responseBody gres
287 where
285 where
288 req' = req
286 req' = req
289 { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
287 { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
@@ -552,7 +550,7 @@ instance
552
550
553 clientWithRoute pm Proxy req body
551 clientWithRoute pm Proxy req body
554 = clientWithRoute pm (Proxy :: Proxy api)
552 = clientWithRoute pm (Proxy :: Proxy api)
555− $ setRequestBody (RequestBodyStreamChunked givesPopper) (contentType ctypeP) req
553+ $ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req
556 where
554 where
557 ctypeP = Proxy :: Proxy ctype
555 ctypeP = Proxy :: Proxy ctype
558 framingP = Proxy :: Proxy framing
556 framingP = Proxy :: Proxy framing
@@ -562,28 +560,6 @@ instance
562 (mimeRender ctypeP :: chunk -> BL.ByteString)
560 (mimeRender ctypeP :: chunk -> BL.ByteString)
563 (toSourceIO body)
561 (toSourceIO body)
564
562
565− -- not pretty.
566− givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
567− givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do
568− ref <- newMVar step0
569−
570− -- Note sure we need locking, but it's feels safer.
571− let popper :: IO BS.ByteString
572− popper = modifyMVar ref nextBs
573−
574− needsPopper popper
575−
576− nextBs S.Stop = return (S.Stop, BS.empty)
577− nextBs (S.Error err) = fail err
578− nextBs (S.Skip s) = nextBs s
579− nextBs (S.Effect ms) = ms >>= nextBs
580− nextBs (S.Yield lbs s) = case BL.toChunks lbs of
581− [] -> nextBs s
582− (x:xs) | BS.null x -> nextBs step'
583− | otherwise -> return (step', x)
584− where
585− step' = S.Yield (BL.fromChunks xs) s
586−
587-- | Make the querying function append @path@ to the request path.
563-- | Make the querying function append @path@ to the request path.
588instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
564instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
589 type Client m (path :> api) = Client m api
565 type Client m (path :> api) = Client m api
servant-client-core/src/Servant/Client/Core/Internal/Request.hs+8−81
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveFoldable #-}
2{-# LANGUAGE DeriveFoldable #-}
4{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveFunctor #-}
@@ -17,10 +16,6 @@ import Prelude.Compat
17
16
18import Control.DeepSeq
17import Control.DeepSeq
19 (NFData (..))
18 (NFData (..))
20−import Control.Exception
21− (SomeException (..))
22−import Control.Monad.Catch
23− (Exception)
24import Data.Bifoldable
19import Data.Bifoldable
25 (Bifoldable (..))
20 (Bifoldable (..))
26import Data.Bifunctor
21import Data.Bifunctor
@@ -30,8 +25,6 @@ import Data.Bitraversable
30import qualified Data.ByteString as BS
25import qualified Data.ByteString as BS
31import qualified Data.ByteString.Builder as Builder
26import qualified Data.ByteString.Builder as Builder
32import qualified Data.ByteString.Lazy as LBS
27import qualified Data.ByteString.Lazy as LBS
33−import Data.Int
34− (Int64)
35import Data.Semigroup
28import Data.Semigroup
36 ((<>))
29 ((<>))
37import qualified Data.Sequence as Seq
30import qualified Data.Sequence as Seq
@@ -40,64 +33,16 @@ import Data.Text
40import Data.Text.Encoding
33import Data.Text.Encoding
41 (encodeUtf8)
34 (encodeUtf8)
42import Data.Typeable
35import Data.Typeable
43− (Typeable, typeOf)
36+ (Typeable)
44import GHC.Generics
37import GHC.Generics
45 (Generic)
38 (Generic)
46import Network.HTTP.Media
39import Network.HTTP.Media
47 (MediaType, mainType, parameters, subType)
40 (MediaType, mainType, parameters, subType)
48import Network.HTTP.Types
41import Network.HTTP.Types
49 (Header, HeaderName, HttpVersion (..), Method, QueryItem,
42 (Header, HeaderName, HttpVersion (..), Method, QueryItem,
50− Status (..), http11, methodGet)
43+ http11, methodGet)
51import Servant.API
44import Servant.API
52− (ToHttpApiData, toEncodedUrlPiece, toHeader)
45+ (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
53−import Servant.Client.Core.Internal.BaseUrl
54− (BaseUrl)
55−
56−-- | A type representing possible errors in a request
57−--
58−-- Note that this type substantially changed in 0.12.
59−data ServantError =
60− -- | The server returned an error response including the
61− -- failing request. 'requestPath' includes the 'BaseUrl' and the
62− -- path of the request.
63− FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response
64− -- | The body could not be decoded at the expected type
65− | DecodeFailure Text Response
66− -- | The content-type of the response is not supported
67− | UnsupportedContentType MediaType Response
68− -- | The content-type header is invalid
69− | InvalidContentTypeHeader Response
70− -- | There was a connection error, and no response was received
71− | ConnectionError SomeException
72− deriving (Show, Generic, Typeable)
73−
74−instance Eq ServantError where
75− FailureResponse req res == FailureResponse req' res' = req == req' && res == res'
76− DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r'
77− UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r'
78− InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r'
79− ConnectionError exc == ConnectionError exc' = eqSomeException exc exc'
80− where
81− -- returns true, if type of exception is the same
82− eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b
83−
84− -- prevent wild card blindness
85− FailureResponse {} == _ = False
86− DecodeFailure {} == _ = False
87− UnsupportedContentType {} == _ = False
88− InvalidContentTypeHeader {} == _ = False
89− ConnectionError {} == _ = False
90−
91−instance Exception ServantError
92−
93−-- | Note: an exception in 'ConnectionError' might not be evaluated fully,
94−-- We only 'rnf' its 'show'ed value.
95−instance NFData ServantError where
96− rnf (FailureResponse req res) = rnf req `seq` rnf res
97− rnf (DecodeFailure err res) = rnf err `seq` rnf res
98− rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res
99− rnf (InvalidContentTypeHeader res) = rnf res
100− rnf (ConnectionError err) = err `seq` rnf (show err)
101
46
102mediaTypeRnf :: MediaType -> ()
47mediaTypeRnf :: MediaType -> ()
103mediaTypeRnf mt =
48mediaTypeRnf mt =
@@ -143,31 +88,13 @@ type Request = RequestF RequestBody Builder.Builder
143data RequestBody
88data RequestBody
144 = RequestBodyLBS LBS.ByteString
89 = RequestBodyLBS LBS.ByteString
145 | RequestBodyBS BS.ByteString
90 | RequestBodyBS BS.ByteString
146− | RequestBodyBuilder Int64 Builder.Builder
91+ | RequestBodySource (SourceIO LBS.ByteString)
147− | RequestBodyStream Int64 ((IO BS.ByteString -> IO ()) -> IO ())
148− | RequestBodyStreamChunked ((IO BS.ByteString -> IO ()) -> IO ())
149− | RequestBodyIO (IO RequestBody)
150 deriving (Generic, Typeable)
92 deriving (Generic, Typeable)
151
93
152−data GenResponse a = Response
94+instance Show RequestBody where
153− { responseStatusCode :: Status
95+ showsPrec d (RequestBodyLBS lbs) = showParen (d > 10)
154− , responseHeaders :: Seq.Seq Header
96+ $ showString "RequestBodyLBS "
155− , responseHttpVersion :: HttpVersion
97+ . showsPrec 11 lbs
156− , responseBody :: a
157− } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)
158−
159−instance NFData a => NFData (GenResponse a) where
160− rnf (Response sc hs hv body) =
161− rnfStatus sc `seq`
162− rnf hs `seq`
163− rnfHttpVersion hv `seq`
164− rnf body
165− where
166− rnfStatus (Status code msg) = rnf code `seq` rnf msg
167− rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict
168−
169−type Response = GenResponse LBS.ByteString
170−type StreamingResponse = GenResponse (IO BS.ByteString)
171
98
172-- A GET request to the top-level path
99-- A GET request to the top-level path
173defaultRequest :: Request
100defaultRequest :: Request
servant-client-core/src/Servant/Client/Core/Internal/Response.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DeriveFoldable #-}
3+{-# LANGUAGE DeriveFunctor #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE DeriveTraversable #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeFamilies #-}
10+
11+module Servant.Client.Core.Internal.Response where
12+
13+import Prelude ()
14+import Prelude.Compat
15+
16+import Control.DeepSeq
17+ (NFData (..))
18+import qualified Data.ByteString as BS
19+import qualified Data.ByteString.Lazy as LBS
20+import qualified Data.Sequence as Seq
21+import Data.Typeable
22+ (Typeable)
23+import GHC.Generics
24+ (Generic)
25+import Network.HTTP.Types
26+ (Header, HttpVersion (..), Status (..))
27+
28+import Servant.API.Stream
29+ (SourceIO)
30+
31+data ResponseF a = Response
32+ { responseStatusCode :: Status
33+ , responseHeaders :: Seq.Seq Header
34+ , responseHttpVersion :: HttpVersion
35+ , responseBody :: a
36+ } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)
37+
38+instance NFData a => NFData (ResponseF a) where
39+ rnf (Response sc hs hv body) =
40+ rnfStatus sc `seq`
41+ rnf hs `seq`
42+ rnfHttpVersion hv `seq`
43+ rnf body
44+ where
45+ rnfStatus (Status code msg) = rnf code `seq` rnf msg
46+ rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict
47+
48+type Response = ResponseF LBS.ByteString
49+type StreamingResponse = ResponseF (SourceIO BS.ByteString)
servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs+2−2
@@ -25,8 +25,8 @@ import Servant.API
25
25
26import Servant.Client.Core.Internal.ClientF
26import Servant.Client.Core.Internal.ClientF
27import Servant.Client.Core.Internal.Request
27import Servant.Client.Core.Internal.Request
28− (GenResponse (..), Request, Response, ServantError (..),
28+import Servant.Client.Core.Internal.Response
29− StreamingResponse)
29+import Servant.Client.Core.Internal.ClientError
30
30
31class Monad m => RunClient m where
31class Monad m => RunClient m where
32 -- | How to make a request.
32 -- | How to make a request.
servant-client-core/src/Servant/Client/Core/Reexport.hs+3−2
@@ -9,7 +9,7 @@ module Servant.Client.Core.Reexport
9 -- * Response (for @Raw@)
9 -- * Response (for @Raw@)
10 , Response
10 , Response
11 , StreamingResponse
11 , StreamingResponse
12− , GenResponse(..)
12+ , ResponseF(..)
13
13
14 -- * Generic Client
14 -- * Generic Client
15 , ClientLike(..)
15 , ClientLike(..)
@@ -30,4 +30,5 @@ module Servant.Client.Core.Reexport
30import Servant.Client.Core.Internal.BaseUrl
30import Servant.Client.Core.Internal.BaseUrl
31import Servant.Client.Core.Internal.Generic
31import Servant.Client.Core.Internal.Generic
32import Servant.Client.Core.Internal.HasClient
32import Servant.Client.Core.Internal.HasClient
33−import Servant.Client.Core.Internal.Request
33+import Servant.Client.Core.Internal.Response
34+import Servant.Client.Core.Internal.ClientError
servant-client/src/Servant/Client/Internal/HttpClient.hs+53−33
@@ -14,6 +14,9 @@ module Servant.Client.Internal.HttpClient where
14import Prelude ()
14import Prelude ()
15import Prelude.Compat
15import Prelude.Compat
16
16
17+import Control.Concurrent.MVar
18+ (modifyMVar, newMVar)
19+import qualified Data.ByteString as BS
17import Control.Concurrent.STM.TVar
20import Control.Concurrent.STM.TVar
18import Control.Exception
21import Control.Exception
19import Control.Monad
22import Control.Monad
@@ -52,7 +55,6 @@ import Data.Sequence
52 (fromList)
55 (fromList)
53import Data.String
56import Data.String
54 (fromString)
57 (fromString)
55−import qualified Data.Text as T
56import Data.Time.Clock
58import Data.Time.Clock
57 (UTCTime, getCurrentTime)
59 (UTCTime, getCurrentTime)
58import GHC.Generics
60import GHC.Generics
@@ -62,6 +64,7 @@ import Network.HTTP.Types
62 (hContentType, renderQuery, statusCode)
64 (hContentType, renderQuery, statusCode)
63import Servant.Client.Core
65import Servant.Client.Core
64
66
67+import qualified Servant.Types.SourceT as S
65import qualified Network.HTTP.Client as Client
68import qualified Network.HTTP.Client as Client
66
69
67-- | The environment in which a request is run.
70-- | The environment in which a request is run.
@@ -167,7 +170,7 @@ performRequest req = do
167 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
170 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
168 let status = Client.responseStatus response
171 let status = Client.responseStatus response
169 status_code = statusCode status
172 status_code = statusCode status
170− ourResponse = clientResponseToResponse response
173+ ourResponse = clientResponseToResponse id response
171 unless (status_code >= 200 && status_code < 300) $
174 unless (status_code >= 200 && status_code < 300) $
172 throwError $ mkFailureResponse burl req ourResponse
175 throwError $ mkFailureResponse burl req ourResponse
173 return ourResponse
176 return ourResponse
@@ -197,34 +200,34 @@ performRequest req = do
197 fReq = Client.hrFinalRequest responses
200 fReq = Client.hrFinalRequest responses
198 fRes = Client.hrFinalResponse responses
201 fRes = Client.hrFinalResponse responses
199
202
200−mkFailureResponse :: BaseUrl -> Request -> GenResponse BSL.ByteString -> ServantError
203+mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ServantError
201mkFailureResponse burl request =
204mkFailureResponse burl request =
202 FailureResponse (bimap (const ()) f request)
205 FailureResponse (bimap (const ()) f request)
203 where
206 where
204 f b = (burl, BSL.toStrict $ toLazyByteString b)
207 f b = (burl, BSL.toStrict $ toLazyByteString b)
205
208
206−clientResponseToResponse :: Client.Response a -> GenResponse a
209+clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b
207−clientResponseToResponse r = Response
210+clientResponseToResponse f r = Response
208− { responseStatusCode = Client.responseStatus r
211+ { responseStatusCode = Client.responseStatus r
209− , responseBody = Client.responseBody r
212+ , responseBody = f (Client.responseBody r)
210− , responseHeaders = fromList $ Client.responseHeaders r
213+ , responseHeaders = fromList $ Client.responseHeaders r
211− , responseHttpVersion = Client.responseVersion r
214+ , responseHttpVersion = Client.responseVersion r
212− }
215+ }
213
216
214requestToClientRequest :: BaseUrl -> Request -> Client.Request
217requestToClientRequest :: BaseUrl -> Request -> Client.Request
215requestToClientRequest burl r = Client.defaultRequest
218requestToClientRequest burl r = Client.defaultRequest
216− { Client.method = requestMethod r
219+ { Client.method = requestMethod r
217− , Client.host = fromString $ baseUrlHost burl
220+ , Client.host = fromString $ baseUrlHost burl
218− , Client.port = baseUrlPort burl
221+ , Client.port = baseUrlPort burl
219− , Client.path = BSL.toStrict
222+ , Client.path = BSL.toStrict
220− $ fromString (baseUrlPath burl)
223+ $ fromString (baseUrlPath burl)
221− <> toLazyByteString (requestPath r)
224+ <> toLazyByteString (requestPath r)
222− , Client.queryString = renderQuery True . toList $ requestQueryString r
225+ , Client.queryString = renderQuery True . toList $ requestQueryString r
223− , Client.requestHeaders =
226+ , Client.requestHeaders =
224− maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
227+ maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
225− , Client.requestBody = body
228+ , Client.requestBody = body
226− , Client.secure = isSecure
229+ , Client.secure = isSecure
227− }
230+ }
228 where
231 where
229 -- Content-Type and Accept are specified by requestBody and requestAccept
232 -- Content-Type and Accept are specified by requestBody and requestAccept
230 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
233 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
@@ -237,21 +240,38 @@ requestToClientRequest burl r = Client.defaultRequest
237 hs = toList $ requestAccept r
240 hs = toList $ requestAccept r
238
241
239 convertBody bd = case bd of
242 convertBody bd = case bd of
240− RequestBodyLBS body' -> Client.RequestBodyLBS body'
243+ RequestBodyLBS body' -> Client.RequestBodyLBS body'
241− RequestBodyBS body' -> Client.RequestBodyBS body'
244+ RequestBodyBS body' -> Client.RequestBodyBS body'
242− RequestBodyBuilder size body' -> Client.RequestBodyBuilder size body'
245+ RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper
243− RequestBodyStream size body' -> Client.RequestBodyStream size body'
246+ where
244− RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body'
247+ givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
245− RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body')
248+ givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do
249+ ref <- newMVar step0
250+
251+ -- Note sure we need locking, but it's feels safer.
252+ let popper :: IO BS.ByteString
253+ popper = modifyMVar ref nextBs
254+
255+ needsPopper popper
256+
257+ nextBs S.Stop = return (S.Stop, BS.empty)
258+ nextBs (S.Error err) = fail err
259+ nextBs (S.Skip s) = nextBs s
260+ nextBs (S.Effect ms) = ms >>= nextBs
261+ nextBs (S.Yield lbs s) = case BSL.toChunks lbs of
262+ [] -> nextBs s
263+ (x:xs) | BS.null x -> nextBs step'
264+ | otherwise -> return (step', x)
265+ where
266+ step' = S.Yield (BSL.fromChunks xs) s
246
267
247 (body, contentTypeHdr) = case requestBody r of
268 (body, contentTypeHdr) = case requestBody r of
248− Nothing -> (Client.RequestBodyLBS "", Nothing)
269+ Nothing -> (Client.RequestBodyBS "", Nothing)
249− Just (body', typ)
250− -> (convertBody body', Just (hContentType, renderHeader typ))
270+ Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))
251
271
252 isSecure = case baseUrlScheme burl of
272 isSecure = case baseUrlScheme burl of
253− Http -> False
273+ Http -> False
254− Https -> True
274+ Https -> True
255
275
256catchConnectionError :: IO a -> IO (Either ServantError a)
276catchConnectionError :: IO a -> IO (Either ServantError a)
257catchConnectionError action =
277catchConnectionError action =
servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+7−5
@@ -35,6 +35,7 @@ import Control.Monad.Reader
35import Control.Monad.STM
35import Control.Monad.STM
36 (atomically)
36 (atomically)
37import Control.Monad.Trans.Except
37import Control.Monad.Trans.Except
38+import qualified Data.ByteString as BS
38import qualified Data.ByteString.Lazy as BSL
39import qualified Data.ByteString.Lazy as BSL
39import Data.Foldable
40import Data.Foldable
40 (for_)
41 (for_)
@@ -53,8 +54,9 @@ import qualified Network.HTTP.Client as Client
53import Servant.Client.Core
54import Servant.Client.Core
54import Servant.Client.Internal.HttpClient
55import Servant.Client.Internal.HttpClient
55 (ClientEnv (..), catchConnectionError,
56 (ClientEnv (..), catchConnectionError,
56− clientResponseToResponse, mkClientEnv, requestToClientRequest,
57+ clientResponseToResponse, mkClientEnv, mkFailureResponse,
57− mkFailureResponse)
58+ requestToClientRequest)
59+import qualified Servant.Types.SourceT as S
58
60
59
61
60-- | Generates a set of client functions for an API.
62-- | Generates a set of client functions for an API.
@@ -165,7 +167,7 @@ performRequest req = do
165 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
167 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
166 let status = Client.responseStatus response
168 let status = Client.responseStatus response
167 status_code = statusCode status
169 status_code = statusCode status
168− ourResponse = clientResponseToResponse response
170+ ourResponse = clientResponseToResponse id response
169 unless (status_code >= 200 && status_code < 300) $
171 unless (status_code >= 200 && status_code < 300) $
170 throwError $ mkFailureResponse burl req ourResponse
172 throwError $ mkFailureResponse burl req ourResponse
171 return ourResponse
173 return ourResponse
@@ -183,7 +185,7 @@ performWithStreamingRequest req k = do
183 -- we throw FailureResponse in IO :(
185 -- we throw FailureResponse in IO :(
184 unless (status_code >= 200 && status_code < 300) $ do
186 unless (status_code >= 200 && status_code < 300) $ do
185 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
187 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
186− throwIO $ mkFailureResponse burl req (clientResponseToResponse res { Client.responseBody = b })
188+ throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
187
189
188− x <- k (clientResponseToResponse res)
190+ x <- k (clientResponseToResponse (S.fromAction BS.null) res)
189 k1 x
191 k1 x
servant-http-streams/CHANGELOG.mdnew file+2
@@ -0,0 +1,2 @@
1+ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-http-streams/CHANGELOG.md)
2+[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/LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Zalora South East Asia Pte Ltd nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
servant-http-streams/README.lhsnew file+1
@@ -0,0 +1 @@
1+README.md
servant-http-streams/README.mdnew file+44
@@ -0,0 +1,44 @@
1+# servant-client
2+
3+![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
4+
5+This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice.
6+
7+## Example
8+
9+``` haskell
10+{-# LANGUAGE DataKinds #-}
11+{-# LANGUAGE TypeOperators #-}
12+
13+import Data.Proxy
14+import Data.Text
15+import Servant.API
16+import Servant.HttpStreams
17+
18+
19+type Book = Text
20+
21+type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
22+ :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
23+
24+myApi :: Proxy MyApi
25+myApi = Proxy
26+
27+-- 'client' allows you to produce operations to query an API from a client.
28+postNewBook :: Book -> ClientM Book
29+getAllBooks :: ClientM [Book]
30+(getAllBooks :<|> postNewBook) = client myApi
31+
32+-- the IOException happens already in withClientEnvIO
33+main' :: IO ()
34+main' = do
35+ let burl = BaseUrl Http "localhost" 8081 ""
36+ withClientEnvIO burl $ \env -> do
37+ res <- runClientM getAllBooks env
38+ case res of
39+ Left err -> putStrLn $ "Error: " ++ show err
40+ Right books -> print books
41+
42+main :: IO ()
43+main = return ()
44+```
servant-http-streams/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
servant-http-streams/servant-http-streams.cabalnew file+137
@@ -0,0 +1,137 @@
1+cabal-version: >=1.10
2+name: servant-http-streams
3+version: 0.15
4+
5+synopsis: Automatic derivation of querying functions for servant
6+category: Servant, Web
7+description:
8+ This library lets you derive automatically Haskell functions that
9+ let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
10+ .
11+ See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.
12+ .
13+ <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
14+
15+homepage: http://haskell-servant.readthedocs.org/
16+bug-reports: http://github.com/haskell-servant/servant/issues
17+license: BSD3
18+license-file: LICENSE
19+author: Servant Contributors
20+maintainer: haskell-servant-maintainers@googlegroups.com
21+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
22+build-type: Simple
23+tested-with:
24+ GHC ==8.0.2
25+ || ==8.2.2
26+ || ==8.4.4
27+ || ==8.6.2
28+
29+extra-source-files:
30+ CHANGELOG.md
31+ README.md
32+
33+source-repository head
34+ type: git
35+ location: http://github.com/haskell-servant/servant.git
36+
37+library
38+ exposed-modules:
39+ Servant.HttpStreams
40+ Servant.HttpStreams.Internal
41+
42+ -- Bundled with GHC: Lower bound to not force re-installs
43+ -- text and mtl are bundled starting with GHC-8.4
44+ build-depends:
45+ base >= 4.9 && < 4.13
46+ , bytestring >= 0.10.8.1 && < 0.11
47+ , containers >= 0.5.7.1 && < 0.7
48+ , deepseq >= 1.4.2.0 && < 1.5
49+ , mtl >= 2.2.2 && < 2.3
50+ , text >= 1.2.3.0 && < 1.3
51+ , time >= 1.6.0.1 && < 1.9
52+ , transformers >= 0.5.2.0 && < 0.6
53+
54+ if !impl(ghc >= 8.2)
55+ build-depends:
56+ bifunctors >= 5.5.3 && < 5.6
57+
58+ -- Servant dependencies.
59+ -- Strict dependency on `servant-client-core` as we re-export things.
60+ build-depends:
61+ servant == 0.15.*
62+ , servant-client-core >= 0.15 && <0.15.1
63+
64+ -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
65+ -- Here can be exceptions if we really need features from the newer versions.
66+ build-depends:
67+ base-compat >= 0.10.5 && < 0.11
68+ , case-insensitive
69+ , http-streams >= 0.8.6.1 && < 0.9
70+ , http-media >= 0.7.1.3 && < 0.8
71+ , io-streams >=1.5.0.1 && < 1.6
72+ , http-types >= 0.12.2 && < 0.13
73+ , http-common >= 0.8.2.0 && < 0.9
74+ , exceptions >= 0.10.0 && < 0.11
75+ , kan-extensions >= 5.2 && < 5.3
76+ , monad-control >= 1.0.2.3 && < 1.1
77+ , semigroupoids >= 5.3.1 && < 5.4
78+ , transformers-base >= 0.4.5.2 && < 0.5
79+ , transformers-compat >= 0.6.2 && < 0.7
80+
81+ hs-source-dirs: src
82+ default-language: Haskell2010
83+ ghc-options: -Wall -Wno-redundant-constraints
84+
85+test-suite spec
86+ type: exitcode-stdio-1.0
87+ ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"
88+ default-language: Haskell2010
89+ hs-source-dirs: test
90+ main-is: Spec.hs
91+ other-modules:
92+ Servant.ClientSpec
93+ Servant.StreamSpec
94+
95+ -- Dependencies inherited from the library. No need to specify bounds.
96+ build-depends:
97+ base
98+ , aeson
99+ , base-compat
100+ , bytestring
101+ , http-api-data
102+ , http-streams
103+ , deepseq
104+ , http-types
105+ , mtl
106+ , kan-extensions
107+ , servant-http-streams
108+ , servant-client-core
109+ , stm
110+ , text
111+ , transformers
112+ , transformers-compat
113+ , wai
114+ , warp
115+
116+ -- Additonal dependencies
117+ build-depends:
118+ entropy >= 0.4.1.3 && < 0.5
119+ , generics-sop >= 0.4.0.1 && < 0.5
120+ , hspec >= 2.6.0 && < 2.7
121+ , HUnit >= 1.6.0.0 && < 1.7
122+ , network >= 2.8.0.0 && < 3.1
123+ , QuickCheck >= 2.12.6.1 && < 2.13
124+ , servant == 0.15.*
125+ , servant-server == 0.15.*
126+ , tdigest >= 0.2 && < 0.3
127+
128+ build-tool-depends:
129+ hspec-discover:hspec-discover >= 2.6.0 && < 2.7
130+
131+test-suite readme
132+ type: exitcode-stdio-1.0
133+ main-is: README.lhs
134+ build-depends: base, servant, http-streams, text, servant-http-streams, markdown-unlit
135+ build-tool-depends: markdown-unlit:markdown-unlit
136+ ghc-options: -pgmL markdown-unlit
137+ default-language: Haskell2010
servant-http-streams/src/Servant/HttpStreams.hsnew file+19
@@ -0,0 +1,19 @@
1+
2+
3+-- | This module provides 'client' which can automatically generate
4+-- querying functions for each endpoint just from the type representing your
5+-- API.
6+module Servant.HttpStreams
7+ ( client
8+ , ClientM
9+ , withClientM
10+ , runClientM
11+ , ClientEnv(..)
12+ , mkClientEnv
13+ , withClientEnvIO
14+ , hoistClient
15+ , module Servant.Client.Core.Reexport
16+ ) where
17+
18+import Servant.Client.Core.Reexport
19+import Servant.HttpStreams.Internal
servant-http-streams/src/Servant/HttpStreams/Internal.hsnew file+254
@@ -0,0 +1,254 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
12+module Servant.HttpStreams.Internal where
13+
14+import Prelude ()
15+import Prelude.Compat
16+
17+import Control.DeepSeq
18+ (NFData, force)
19+import Control.Exception
20+ (IOException, SomeException (..), catch, evaluate, throwIO)
21+import Control.Monad.Base
22+ (MonadBase (..))
23+import Control.Monad.Codensity
24+ (Codensity (..))
25+import Control.Monad.Error.Class
26+ (MonadError (..))
27+import Control.Monad.IO.Class
28+ (liftIO)
29+import Control.Monad.Reader
30+import Control.Monad.Trans.Except
31+import Data.Bifunctor
32+ (bimap, first)
33+import Data.ByteString.Builder
34+ (toLazyByteString)
35+import qualified Data.ByteString.Builder as B
36+import qualified Data.ByteString.Lazy as BSL
37+import qualified Data.CaseInsensitive as CI
38+import Data.Foldable
39+ (for_, toList)
40+import Data.Functor.Alt
41+ (Alt (..))
42+import Data.Maybe
43+ (maybeToList)
44+import Data.Proxy
45+ (Proxy (..))
46+import Data.Semigroup
47+ ((<>))
48+import Data.Sequence
49+ (fromList)
50+import Data.String
51+ (fromString)
52+import GHC.Generics
53+import Network.HTTP.Media
54+ (renderHeader)
55+import Network.HTTP.Types
56+ (Status (..), hContentType, http11, renderQuery)
57+import Servant.Client.Core
58+
59+import qualified Network.Http.Client as Client
60+import qualified Network.Http.Types as Client
61+import qualified Servant.Types.SourceT as S
62+import qualified System.IO.Streams as Streams
63+
64+-- | The environment in which a request is run.
65+--
66+-- 'ClientEnv' carries an open connection. See 'withClientEnvIO'.
67+--
68+data ClientEnv
69+ = ClientEnv
70+ { baseUrl :: BaseUrl
71+ , connection :: Client.Connection
72+ }
73+
74+-- | 'ClientEnv' smart constructor.
75+mkClientEnv :: BaseUrl -> Client.Connection -> ClientEnv
76+mkClientEnv = ClientEnv
77+
78+-- | Open a connection to 'BaseUrl'.
79+withClientEnvIO :: BaseUrl -> (ClientEnv -> IO r) -> IO r
80+withClientEnvIO burl k = Client.withConnection open $ \conn ->
81+ k (mkClientEnv burl conn)
82+ where
83+ open = Client.openConnection (fromString $ baseUrlHost burl) (fromIntegral $ baseUrlPort burl)
84+
85+-- | Generates a set of client functions for an API.
86+--
87+-- Example:
88+--
89+-- > type API = Capture "no" Int :> Get '[JSON] Int
90+-- > :<|> Get '[JSON] [Bool]
91+-- >
92+-- > api :: Proxy API
93+-- > api = Proxy
94+-- >
95+-- > getInt :: Int -> ClientM Int
96+-- > getBools :: ClientM [Bool]
97+-- > getInt :<|> getBools = client api
98+client :: HasClient ClientM api => Proxy api -> Client ClientM api
99+client api = api `clientIn` (Proxy :: Proxy ClientM)
100+
101+-- | Change the monad the client functions live in, by
102+-- supplying a conversion function
103+-- (a natural transformation to be precise).
104+--
105+-- For example, assuming you have some @manager :: 'Manager'@ and
106+-- @baseurl :: 'BaseUrl'@ around:
107+--
108+-- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
109+-- > api :: Proxy API
110+-- > api = Proxy
111+-- > getInt :: IO Int
112+-- > postInt :: Int -> IO Int
113+-- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)
114+-- > where cenv = mkClientEnv manager baseurl
115+hoistClient
116+ :: HasClient ClientM api
117+ => Proxy api
118+ -> (forall a. m a -> n a)
119+ -> Client m api
120+ -> Client n api
121+hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)
122+
123+-- | @ClientM@ is the monad in which client functions run. Contains the
124+-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
125+newtype ClientM a = ClientM
126+ { unClientM :: ReaderT ClientEnv (ExceptT ServantError (Codensity IO)) a }
127+ deriving ( Functor, Applicative, Monad, MonadIO, Generic
128+ , MonadReader ClientEnv, MonadError ServantError)
129+
130+instance MonadBase IO ClientM where
131+ liftBase = ClientM . liftIO
132+
133+-- | Try clients in order, last error is preserved.
134+instance Alt ClientM where
135+ a <!> b = a `catchError` \_ -> b
136+
137+instance RunClient ClientM where
138+ runRequest = performRequest
139+ throwServantError = throwError
140+
141+instance RunStreamingClient ClientM where
142+ withStreamingRequest = performWithStreamingRequest
143+
144+instance ClientLike (ClientM a) (ClientM a) where
145+ mkClient = id
146+
147+runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a)
148+runClientM cm env = withClientM cm env (evaluate . force)
149+
150+withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b
151+withClientM cm env k =
152+ let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
153+ in f k
154+
155+performRequest :: Request -> ClientM Response
156+performRequest req = do
157+ ClientEnv burl conn <- ask
158+ let (req', body) = requestToClientRequest burl req
159+ x <- ClientM $ lift $ lift $ Codensity $ \k -> do
160+ Client.sendRequest conn req' body
161+ Client.receiveResponse conn $ \res' body' -> do
162+ let sc = Client.getStatusCode res'
163+ lbs <- BSL.fromChunks <$> Streams.toList body'
164+ let res'' = clientResponseToResponse res' lbs
165+ if sc >= 200 && sc < 300
166+ then k (Right res'')
167+ else k (Left (mkFailureResponse burl req res''))
168+
169+ either throwError pure x
170+
171+performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
172+performWithStreamingRequest req k = do
173+ ClientEnv burl conn <- ask
174+ let (req', body) = requestToClientRequest burl req
175+ ClientM $ lift $ lift $ Codensity $ \k1 -> do
176+ Client.sendRequest conn req' body
177+ Client.receiveResponseRaw conn $ \res' body' -> do
178+ -- check status code
179+ let sc = Client.getStatusCode res'
180+ unless (sc >= 200 && sc < 300) $ do
181+ lbs <- BSL.fromChunks <$> Streams.toList body'
182+ throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)
183+
184+ x <- k (clientResponseToResponse res' (fromInputStream body'))
185+ k1 x
186+
187+mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ServantError
188+mkFailureResponse burl request =
189+ FailureResponse (bimap (const ()) f request)
190+ where
191+ f b = (burl, BSL.toStrict $ toLazyByteString b)
192+
193+clientResponseToResponse :: Client.Response -> body -> ResponseF body
194+clientResponseToResponse r body = Response
195+ { responseStatusCode = Status (Client.getStatusCode r) (Client.getStatusMessage r)
196+ , responseBody = body
197+ , responseHeaders = fromList $ map (first CI.mk) $ Client.retrieveHeaders $ Client.getHeaders r
198+ , responseHttpVersion = http11 -- guess
199+ }
200+
201+requestToClientRequest :: BaseUrl -> Request -> (Client.Request, Streams.OutputStream B.Builder -> IO ())
202+requestToClientRequest burl r = (request, body)
203+ where
204+ request = Client.buildRequest1 $ do
205+ Client.http (Client.Method $ requestMethod r)
206+ $ fromString (baseUrlPath burl)
207+ <> BSL.toStrict (toLazyByteString (requestPath r))
208+ <> renderQuery True (toList (requestQueryString r))
209+ -- We are connected, but we still need to know what we try to query
210+ Client.setHostname (fromString $ baseUrlHost burl) (fromIntegral $ baseUrlPort burl)
211+ for_ (maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers) $ \(hn, hv) ->
212+ Client.setHeader (CI.original hn) hv
213+
214+ -- body is always chunked
215+ Client.setTransferEncoding
216+
217+ -- Content-Type and Accept are specified by requestBody and requestAccept
218+ headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
219+ toList $ requestHeaders r
220+
221+ acceptHdr
222+ | null hs = Nothing
223+ | otherwise = Just ("Accept", renderHeader hs)
224+ where
225+ hs = toList $ requestAccept r
226+
227+ convertBody bd os = case bd of
228+ RequestBodyLBS body' ->
229+ Streams.writeTo os (Just (B.lazyByteString body'))
230+ RequestBodyBS body' ->
231+ Streams.writeTo os (Just (B.byteString body'))
232+ RequestBodySource sourceIO ->
233+ toOutputStream sourceIO os
234+
235+ (body, contentTypeHdr) = case requestBody r of
236+ Nothing -> (Client.emptyBody, Nothing)
237+ Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))
238+
239+catchConnectionError :: IO a -> IO (Either ServantError a)
240+catchConnectionError action =
241+ catch (Right <$> action) $ \e ->
242+ pure . Left . ConnectionError $ SomeException (e :: IOException)
243+
244+fromInputStream :: Streams.InputStream b -> S.SourceT IO b
245+fromInputStream is = S.SourceT $ \k -> k loop where
246+ loop = S.Effect $ maybe S.Stop (flip S.Yield loop) <$> Streams.read is
247+
248+toOutputStream :: S.SourceT IO BSL.ByteString -> Streams.OutputStream B.Builder -> IO ()
249+toOutputStream (S.SourceT k) os = k loop where
250+ loop S.Stop = return ()
251+ loop (S.Error err) = fail err
252+ loop (S.Skip s) = loop s
253+ loop (S.Effect mx) = mx >>= loop
254+ loop (S.Yield x s) = Streams.write (Just (B.lazyByteString x)) os >> loop s
servant-http-streams/test/Servant/ClientSpec.hsnew file+571
@@ -0,0 +1,571 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE GADTs #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE OverloadedStrings #-}
11+{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE RecordWildCards #-}
13+{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE StandaloneDeriving #-}
15+{-# LANGUAGE TypeApplications #-}
16+{-# LANGUAGE TypeFamilies #-}
17+{-# LANGUAGE TypeOperators #-}
18+{-# LANGUAGE UndecidableInstances #-}
19+{-# OPTIONS_GHC -freduction-depth=100 #-}
20+{-# OPTIONS_GHC -fno-warn-orphans #-}
21+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
22+
23+module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where
24+
25+import Prelude ()
26+import Prelude.Compat
27+
28+import Control.Arrow
29+ (left)
30+import Control.Concurrent
31+ (ThreadId, forkIO, killThread)
32+import Control.DeepSeq
33+ (NFData (..))
34+import Control.Exception
35+ (bracket, fromException, IOException)
36+import Control.Monad.Error.Class
37+ (throwError)
38+import Data.Aeson
39+import Data.Char
40+ (chr, isPrint)
41+import Data.Foldable
42+ (forM_, toList)
43+import Data.Maybe
44+ (isJust)
45+import Data.Monoid ()
46+import Data.Proxy
47+import Data.Semigroup
48+ ((<>))
49+import qualified Generics.SOP as SOP
50+import GHC.Generics
51+ (Generic)
52+import qualified Network.HTTP.Types as HTTP
53+import Network.Socket
54+import qualified Network.Wai as Wai
55+import Network.Wai.Handler.Warp
56+import Test.Hspec
57+import Test.Hspec.QuickCheck
58+import Test.HUnit
59+import Test.QuickCheck
60+import Web.FormUrlEncoded
61+ (FromForm, ToForm)
62+
63+import Servant.API
64+ ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
65+ BasicAuthData (..), Capture, CaptureAll, Delete,
66+ DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
67+ Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
68+ QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
69+import qualified Servant.Client.Core.Internal.Auth as Auth
70+import qualified Servant.Client.Core.Internal.Request as Req
71+import Servant.HttpStreams
72+import Servant.Server
73+import Servant.Server.Experimental.Auth
74+import Servant.Test.ComprehensiveAPI
75+
76+-- This declaration simply checks that all instances are in place.
77+_ = client comprehensiveAPIWithoutStreaming
78+
79+spec :: Spec
80+spec = describe "Servant.HttpStreams" $ do
81+ sucessSpec
82+ failSpec
83+ wrappedApiSpec
84+ basicAuthSpec
85+ genAuthSpec
86+ genericClientSpec
87+ hoistClientSpec
88+ connectionErrorSpec
89+
90+-- * test data types
91+
92+data Person = Person
93+ { _name :: String
94+ , _age :: Integer
95+ } deriving (Eq, Show, Generic)
96+
97+instance NFData Person where
98+ rnf (Person n a) = rnf n `seq` rnf a
99+
100+instance ToJSON Person
101+instance FromJSON Person
102+
103+instance ToForm Person
104+instance FromForm Person
105+
106+instance Arbitrary Person where
107+ arbitrary = Person <$> arbitrary <*> arbitrary
108+
109+alice :: Person
110+alice = Person "Alice" 42
111+
112+carol :: Person
113+carol = Person "Carol" 17
114+
115+type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
116+
117+type Api =
118+ Get '[JSON] Person
119+ :<|> "get" :> Get '[JSON] Person
120+ :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
121+ :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
122+ :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
123+ :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
124+ :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
125+ :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
126+ :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
127+ :<|> "rawSuccess" :> Raw
128+ :<|> "rawFailure" :> Raw
129+ :<|> "multiple" :>
130+ Capture "first" String :>
131+ QueryParam "second" Int :>
132+ QueryFlag "third" :>
133+ ReqBody '[JSON] [(String, [Rational])] :>
134+ Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
135+ :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
136+ :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
137+ :<|> "redirectWithCookie" :> Raw
138+ :<|> "empty" :> EmptyAPI
139+
140+api :: Proxy Api
141+api = Proxy
142+
143+getRoot :: ClientM Person
144+getGet :: ClientM Person
145+getDeleteEmpty :: ClientM NoContent
146+getCapture :: String -> ClientM Person
147+getCaptureAll :: [String] -> ClientM [Person]
148+getBody :: Person -> ClientM Person
149+getQueryParam :: Maybe String -> ClientM Person
150+getQueryParams :: [String] -> ClientM [Person]
151+getQueryFlag :: Bool -> ClientM Bool
152+getRawSuccess :: HTTP.Method -> ClientM Response
153+getRawFailure :: HTTP.Method -> ClientM Response
154+getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
155+ -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
156+getRespHeaders :: ClientM (Headers TestHeaders Bool)
157+getDeleteContentType :: ClientM NoContent
158+_getRedirectWithCookie :: HTTP.Method -> ClientM Response
159+
160+getRoot
161+ :<|> getGet
162+ :<|> getDeleteEmpty
163+ :<|> getCapture
164+ :<|> getCaptureAll
165+ :<|> getBody
166+ :<|> getQueryParam
167+ :<|> getQueryParams
168+ :<|> getQueryFlag
169+ :<|> getRawSuccess
170+ :<|> getRawFailure
171+ :<|> getMultiple
172+ :<|> getRespHeaders
173+ :<|> getDeleteContentType
174+ :<|> _getRedirectWithCookie
175+ :<|> EmptyClient = client api
176+
177+server :: Application
178+server = serve api (
179+ return carol
180+ :<|> return alice
181+ :<|> return NoContent
182+ :<|> (\ name -> return $ Person name 0)
183+ :<|> (\ names -> return (zipWith Person names [0..]))
184+ :<|> return
185+ :<|> (\ name -> case name of
186+ Just "alice" -> return alice
187+ Just n -> throwError $ ServantErr 400 (n ++ " not found") "" []
188+ Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])
189+ :<|> (\ names -> return (zipWith Person names [0..]))
190+ :<|> return
191+ :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
192+ :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
193+ :<|> (\ a b c d -> return (a, b, c, d))
194+ :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
195+ :<|> return NoContent
196+ :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
197+ :<|> emptyServer)
198+
199+type FailApi =
200+ "get" :> Raw
201+ :<|> "capture" :> Capture "name" String :> Raw
202+ :<|> "body" :> Raw
203+failApi :: Proxy FailApi
204+failApi = Proxy
205+
206+failServer :: Application
207+failServer = serve failApi (
208+ (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")
209+ :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
210+ :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
211+ )
212+
213+-- * basic auth stuff
214+
215+type BasicAuthAPI =
216+ BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
217+
218+basicAuthAPI :: Proxy BasicAuthAPI
219+basicAuthAPI = Proxy
220+
221+basicAuthHandler :: BasicAuthCheck ()
222+basicAuthHandler =
223+ let check (BasicAuthData username password) =
224+ if username == "servant" && password == "server"
225+ then return (Authorized ())
226+ else return Unauthorized
227+ in BasicAuthCheck check
228+
229+basicServerContext :: Context '[ BasicAuthCheck () ]
230+basicServerContext = basicAuthHandler :. EmptyContext
231+
232+basicAuthServer :: Application
233+basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
234+
235+-- * general auth stuff
236+
237+type GenAuthAPI =
238+ AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person
239+
240+genAuthAPI :: Proxy GenAuthAPI
241+genAuthAPI = Proxy
242+
243+type instance AuthServerData (AuthProtect "auth-tag") = ()
244+type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()
245+
246+genAuthHandler :: AuthHandler Wai.Request ()
247+genAuthHandler =
248+ let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
249+ Nothing -> throwError (err401 { errBody = "Missing auth header" })
250+ Just _ -> return ()
251+ in mkAuthHandler handler
252+
253+genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
254+genAuthServerContext = genAuthHandler :. EmptyContext
255+
256+genAuthServer :: Application
257+genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
258+
259+-- * generic client stuff
260+
261+type GenericClientAPI
262+ = QueryParam "sqr" Int :> Get '[JSON] Int
263+ :<|> Capture "foo" String :> NestedAPI1
264+
265+data GenericClient = GenericClient
266+ { getSqr :: Maybe Int -> ClientM Int
267+ , mkNestedClient1 :: String -> NestedClient1
268+ } deriving Generic
269+instance SOP.Generic GenericClient
270+instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient
271+
272+type NestedAPI1
273+ = QueryParam "int" Int :> NestedAPI2
274+ :<|> QueryParam "id" Char :> Get '[JSON] Char
275+
276+data NestedClient1 = NestedClient1
277+ { mkNestedClient2 :: Maybe Int -> NestedClient2
278+ , idChar :: Maybe Char -> ClientM Char
279+ } deriving Generic
280+instance SOP.Generic NestedClient1
281+instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1
282+
283+type NestedAPI2
284+ = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int
285+ :<|> "void" :> Post '[JSON] ()
286+
287+data NestedClient2 = NestedClient2
288+ { getSum :: Int -> Int -> ClientM Int
289+ , doNothing :: ClientM ()
290+ } deriving Generic
291+instance SOP.Generic NestedClient2
292+instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2
293+
294+genericClientServer :: Application
295+genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
296+ (\ mx -> case mx of
297+ Just x -> return (x*x)
298+ Nothing -> throwError $ ServantErr 400 "missing parameter" "" []
299+ )
300+ :<|> nestedServer1
301+ )
302+ where
303+ nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)
304+ nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()
305+
306+runClient :: NFData a => ClientM a -> BaseUrl -> IO (Either ServantError a)
307+runClient x burl = withClientEnvIO burl (runClientM x)
308+
309+runClientUnsafe :: ClientM a -> BaseUrl -> IO (Either ServantError a)
310+runClientUnsafe x burl = withClientEnvIO burl (runClientMUnsafe x)
311+ where
312+ runClientMUnsafe x env = withClientM x env return
313+
314+sucessSpec :: Spec
315+sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
316+ it "Servant.API.Get root" $ \(_, baseUrl) -> do
317+ left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
318+
319+ it "Servant.API.Get" $ \(_, baseUrl) -> do
320+ left show <$> runClient getGet baseUrl `shouldReturn` Right alice
321+
322+ describe "Servant.API.Delete" $ do
323+ it "allows empty content type" $ \(_, baseUrl) -> do
324+ left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent
325+
326+ it "allows content type" $ \(_, baseUrl) -> do
327+ left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent
328+
329+ it "Servant.API.Capture" $ \(_, baseUrl) -> do
330+ left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0)
331+
332+ it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
333+ let expected = [(Person "Paula" 0), (Person "Peta" 1)]
334+ left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected
335+
336+ it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
337+ let p = Person "Clara" 42
338+ left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
339+
340+ it "Servant.API FailureResponse" $ \(_, baseUrl) -> do
341+ left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
342+ Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl
343+ Req.requestPath req `shouldBe` (baseUrl, "/param")
344+ toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")]
345+ Req.requestMethod req `shouldBe` HTTP.methodGet
346+
347+ it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
348+ left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
349+ Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
350+ responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
351+
352+ it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
353+ left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
354+ left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
355+ `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
356+
357+ context "Servant.API.QueryParam.QueryFlag" $
358+ forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
359+ left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
360+
361+ it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
362+ res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
363+ case res of
364+ Left e -> assertFailure $ show e
365+ Right r -> do
366+ responseStatusCode r `shouldBe` HTTP.status200
367+ responseBody r `shouldBe` "rawSuccess"
368+
369+ it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
370+ res <- runClient (getRawFailure HTTP.methodGet) baseUrl
371+ case res of
372+ Right _ -> assertFailure "expected Left, but got Right"
373+ Left (FailureResponse _ r) -> do
374+ responseStatusCode r `shouldBe` HTTP.status400
375+ responseBody r `shouldBe` "rawFailure"
376+ Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
377+
378+ it "Returns headers appropriately" $ \(_, baseUrl) -> do
379+ res <- runClient getRespHeaders baseUrl
380+ case res of
381+ Left e -> assertFailure $ show e
382+ Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
383+
384+ modifyMaxSuccess (const 20) $ do
385+ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
386+ property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
387+ ioProperty $ do
388+ result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
389+ return $
390+ result === Right (cap, num, flag, body)
391+
392+
393+wrappedApiSpec :: Spec
394+wrappedApiSpec = describe "error status codes" $ do
395+ let serveW api = serve api $ throwError $ ServantErr 500 "error message" "" []
396+ context "are correctly handled by the client" $
397+ let test :: (WrappedApi, String) -> Spec
398+ test (WrappedApi api, desc) =
399+ it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
400+ let getResponse :: ClientM ()
401+ getResponse = client api
402+ Left (FailureResponse _ r) <- runClient getResponse baseUrl
403+ responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")
404+ in mapM_ test $
405+ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
406+ (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
407+ (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
408+ (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
409+ []
410+
411+failSpec :: Spec
412+failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
413+
414+ context "client returns errors appropriately" $ do
415+ it "reports FailureResponse" $ \(_, baseUrl) -> do
416+ let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
417+ Left res <- runClient getDeleteEmpty baseUrl
418+ case res of
419+ FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
420+ _ -> fail $ "expected 404 response, but got " <> show res
421+
422+ it "reports DecodeFailure" $ \(_, baseUrl) -> do
423+ let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
424+ Left res <- runClient (getCapture "foo") baseUrl
425+ case res of
426+ DecodeFailure _ _ -> return ()
427+ _ -> fail $ "expected DecodeFailure, but got " <> show res
428+
429+ -- we don't catch IOException's
430+ xit "reports ConnectionError" $ \_ -> do
431+ let (getGetWrongHost :<|> _) = client api
432+ Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
433+ case res of
434+ ConnectionError _ -> return ()
435+ _ -> fail $ "expected ConnectionError, but got " <> show res
436+
437+ it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
438+ let (_ :<|> getGet :<|> _ ) = client api
439+ Left res <- runClient getGet baseUrl
440+ case res of
441+ UnsupportedContentType ("application/octet-stream") _ -> return ()
442+ _ -> fail $ "expected UnsupportedContentType, but got " <> show res
443+
444+ it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
445+ let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
446+ Left res <- runClient (getBody alice) baseUrl
447+ case res of
448+ InvalidContentTypeHeader _ -> return ()
449+ _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
450+
451+data WrappedApi where
452+ WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
453+ HasClient ClientM api, Client ClientM api ~ ClientM ()) =>
454+ Proxy api -> WrappedApi
455+
456+basicAuthSpec :: Spec
457+basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
458+ context "Authentication works when requests are properly authenticated" $ do
459+
460+ it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
461+ let getBasic = client basicAuthAPI
462+ let basicAuthData = BasicAuthData "servant" "server"
463+ left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice
464+
465+ context "Authentication is rejected when requests are not authenticated properly" $ do
466+
467+ it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
468+ let getBasic = client basicAuthAPI
469+ let basicAuthData = BasicAuthData "not" "password"
470+ Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl
471+ responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
472+
473+genAuthSpec :: Spec
474+genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
475+ context "Authentication works when requests are properly authenticated" $ do
476+
477+ it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
478+ let getProtected = client genAuthAPI
479+ let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)
480+ left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice
481+
482+ context "Authentication is rejected when requests are not authenticated properly" $ do
483+
484+ it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
485+ let getProtected = client genAuthAPI
486+ let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
487+ Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
488+ responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
489+
490+genericClientSpec :: Spec
491+genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do
492+ describe "Servant.Client.Generic" $ do
493+
494+ let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI))
495+ NestedClient1{..} = mkNestedClient1 "example"
496+ NestedClient2{..} = mkNestedClient2 (Just 42)
497+
498+ it "works for top-level client inClientM function" $ \(_, baseUrl) -> do
499+ left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25
500+
501+ it "works for nested clients" $ \(_, baseUrl) -> do
502+ left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c'
503+ left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7
504+ left show <$> runClient doNothing baseUrl `shouldReturn` Right ()
505+
506+-- * hoistClient
507+
508+type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
509+
510+hoistClientAPI :: Proxy HoistClientAPI
511+hoistClientAPI = Proxy
512+
513+hoistClientServer :: Application -- implements HoistClientAPI
514+hoistClientServer = serve hoistClientAPI $ return 5 :<|> (\n -> return n)
515+
516+hoistClientSpec :: Spec
517+hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do
518+ describe "Servant.Client.hoistClient" $ do
519+ it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do
520+ let (getInt :<|> postInt)
521+ = hoistClient hoistClientAPI
522+ (fmap (either (error . show) id) . flip runClientUnsafe baseUrl)
523+ (client hoistClientAPI)
524+
525+ getInt `shouldReturn` 5
526+ postInt 5 `shouldReturn` 5
527+
528+-- * ConnectionError
529+type ConnectionErrorAPI = Get '[JSON] Int
530+
531+connectionErrorAPI :: Proxy ConnectionErrorAPI
532+connectionErrorAPI = Proxy
533+
534+connectionErrorSpec :: Spec
535+connectionErrorSpec = describe "Servant.Client.ServantError" $
536+ xit "correctly catches ConnectionErrors when the HTTP request can't go through" $ do
537+ let getInt = client connectionErrorAPI
538+ let baseUrl' = BaseUrl Http "example.invalid" 80 ""
539+ let isHttpError (Left (ConnectionError e)) = isJust $ fromException @IOException e
540+ isHttpError _ = False
541+ (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True
542+
543+-- * utils
544+
545+startWaiApp :: Application -> IO (ThreadId, BaseUrl)
546+startWaiApp app = do
547+ (port, socket) <- openTestSocket
548+ let settings = setPort port $ defaultSettings
549+ thread <- forkIO $ runSettingsSocket settings socket app
550+ return (thread, BaseUrl Http "localhost" port "")
551+
552+
553+endWaiApp :: (ThreadId, BaseUrl) -> IO ()
554+endWaiApp (thread, _) = killThread thread
555+
556+openTestSocket :: IO (Port, Socket)
557+openTestSocket = do
558+ s <- socket AF_INET Stream defaultProtocol
559+ let localhost = tupleToHostAddress (127, 0, 0, 1)
560+ bind s (SockAddrInet defaultPort localhost)
561+ listen s 1
562+ port <- socketPort s
563+ return (fromIntegral port, s)
564+
565+pathGen :: Gen (NonEmptyList Char)
566+pathGen = fmap NonEmpty path
567+ where
568+ path = listOf1 $ elements $
569+ filter (not . (`elem` ("?%[]/#;" :: String))) $
570+ filter isPrint $
571+ map chr [0..127]
servant-http-streams/test/Servant/StreamSpec.hsnew file+110
@@ -0,0 +1,110 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE GADTs #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE OverloadedStrings #-}
11+{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE RecordWildCards #-}
13+{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE StandaloneDeriving #-}
15+{-# LANGUAGE TypeFamilies #-}
16+{-# LANGUAGE TypeOperators #-}
17+{-# LANGUAGE UndecidableInstances #-}
18+{-# OPTIONS_GHC -freduction-depth=100 #-}
19+{-# OPTIONS_GHC -fno-warn-orphans #-}
20+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
21+
22+module Servant.StreamSpec (spec) where
23+
24+import Control.Monad.Trans.Except
25+import qualified Data.ByteString as BS
26+import Data.Proxy
27+import Prelude ()
28+import Prelude.Compat
29+import Servant.API
30+ ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming,
31+ NewlineFraming, NoFraming, OctetStream, SourceIO, StreamBody,
32+ StreamGet)
33+import Servant.ClientSpec
34+ (Person (..))
35+import qualified Servant.ClientSpec as CS
36+import Servant.HttpStreams
37+import Servant.Server
38+import Servant.Types.SourceT
39+import System.Entropy
40+ (getEntropy, getHardwareEntropy)
41+import Test.Hspec
42+
43+
44+spec :: Spec
45+spec = describe "Servant.HttpStreams streaming" $ do
46+ streamSpec
47+
48+type StreamApi =
49+ "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)
50+ :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)
51+ :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
52+ :<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
53+
54+api :: Proxy StreamApi
55+api = Proxy
56+
57+getGetNL, getGetNS :: ClientM (SourceIO Person)
58+_getGetALot :: ClientM (SourceIO BS.ByteString)
59+getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString)
60+getGetNL :<|> getGetNS :<|> _getGetALot :<|> getStreamBody = client api
61+
62+alice :: Person
63+alice = Person "Alice" 42
64+
65+bob :: Person
66+bob = Person "Bob" 25
67+
68+server :: Application
69+server = serve api
70+ $ return (source [alice, bob, alice])
71+ :<|> return (source [alice, bob, alice])
72+ -- 2 ^ (18 + 10) = 256M
73+ :<|> return (SourceT ($ lots (powerOfTwo 18)))
74+ :<|> return
75+ where
76+ lots n
77+ | n < 0 = Stop
78+ | otherwise = Effect $ do
79+ let size = powerOfTwo 10
80+ mbs <- getHardwareEntropy size
81+ bs <- maybe (getEntropy size) pure mbs
82+ return (Yield bs (lots (n - 1)))
83+
84+powerOfTwo :: Int -> Int
85+powerOfTwo = (2 ^)
86+
87+withClient :: ClientM a -> BaseUrl -> (Either ServantError a -> IO r) -> IO r
88+withClient x burl k = do
89+ withClientEnvIO burl $ \env -> withClientM x env k
90+
91+testRunSourceIO :: SourceIO a
92+ -> IO (Either String [a])
93+testRunSourceIO = runExceptT . runSourceT
94+
95+streamSpec :: Spec
96+streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
97+ it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
98+ withClient getGetNL baseUrl $ \(Right res) ->
99+ testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
100+
101+ it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
102+ withClient getGetNS baseUrl $ \(Right res) ->
103+ testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
104+
105+ it "works with Servant.API.StreamBody" $ \(_, baseUrl) -> do
106+ withClient (getStreamBody (source input)) baseUrl $ \(Right res) ->
107+ testRunSourceIO res `shouldReturn` Right output
108+ where
109+ input = ["foo", "", "bar"]
110+ output = ["foo", "bar"]
servant-http-streams/test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant/src/Servant/API/ResponseHeaders.hs+18
@@ -35,6 +35,8 @@ module Servant.API.ResponseHeaders
35 , HList(..)
35 , HList(..)
36 ) where
36 ) where
37
37
38+import Control.DeepSeq
39+ (NFData (..))
38import Data.ByteString.Char8 as BS
40import Data.ByteString.Char8 as BS
39 (ByteString, init, pack, unlines)
41 (ByteString, init, pack, unlines)
40import qualified Data.CaseInsensitive as CI
42import qualified Data.CaseInsensitive as CI
@@ -60,16 +62,32 @@ data Headers ls a = Headers { getResponse :: a
60 -- ^ HList of headers.
62 -- ^ HList of headers.
61 } deriving (Functor)
63 } deriving (Functor)
62
64
65+instance (NFDataHList ls, NFData a) => NFData (Headers ls a) where
66+ rnf (Headers x hdrs) = rnf x `seq` rnf hdrs
67+
63data ResponseHeader (sym :: Symbol) a
68data ResponseHeader (sym :: Symbol) a
64 = Header a
69 = Header a
65 | MissingHeader
70 | MissingHeader
66 | UndecodableHeader ByteString
71 | UndecodableHeader ByteString
67 deriving (Typeable, Eq, Show, Functor)
72 deriving (Typeable, Eq, Show, Functor)
68
73
74+instance NFData a => NFData (ResponseHeader sym a) where
75+ rnf MissingHeader = ()
76+ rnf (UndecodableHeader bs) = rnf bs
77+ rnf (Header x) = rnf x
78+
69data HList a where
79data HList a where
70 HNil :: HList '[]
80 HNil :: HList '[]
71 HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs)
81 HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs)
72
82
83+class NFDataHList xs where rnfHList :: HList xs -> ()
84+instance NFDataHList '[] where rnfHList HNil = ()
85+instance (y ~ Header h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where
86+ rnfHList (HCons h xs) = rnf h `seq` rnfHList xs
87+
88+instance NFDataHList xs => NFData (HList xs) where
89+ rnf = rnfHList
90+
73type family HeaderValMap (f :: * -> *) (xs :: [*]) where
91type family HeaderValMap (f :: * -> *) (xs :: [*]) where
74 HeaderValMap f '[] = '[]
92 HeaderValMap f '[] = '[]
75 HeaderValMap f (Header h x ': xs) = Header h (f x) ': HeaderValMap f xs
93 HeaderValMap f (Header h x ': xs) = Header h (f x) ': HeaderValMap f xs