git.iko.soy/typeable/servant
on master help sign in
Add servant-http-streams
commitb44335ab696ea04ec38b027895d13fa635153453 authorOleg Grenrus <oleg.grenrus@iki.fi> dateWed 6 Feb 2019, 12:15 (8 years ago) parent4fab471
13 files changed+1182−6
compare with master
unifiedsplit
.travis.yml+8−5 cabal.project+3−1 servant-http-streams/CHANGELOG.md+2 servant-http-streams/LICENSE+30 servant-http-streams/README.lhs+1 servant-http-streams/README.md+44 servant-http-streams/Setup.hs+2 servant-http-streams/servant-http-streams.cabal+137 servant-http-streams/src/Servant/HttpStreams.hs+19 servant-http-streams/src/Servant/HttpStreams/Internal.hs+254 servant-http-streams/test/Servant/ClientSpec.hs+571 servant-http-streams/test/Servant/StreamSpec.hs+110 servant-http-streams/test/Spec.hs+1
.travis.yml+8−5
@@ -69,12 +69,12 @@ install:
6969 - rm -fv cabal.project cabal.project.local
7070 - "if [ $HCNUMVER -ge 70800 ]; then sed -i.bak 's/-- ghc-options:.*/ghc-options: -j2/' ${HOME}/.cabal/config; fi"
7171 - 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"
7373 - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
7474 - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
7575 - "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"
7676 - 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"
7878 - cat cabal.project || true
7979 - cat cabal.project.local || true
8080 - if [ -f "servant/configure.ac" ]; then
@@ -86,6 +86,9 @@ install:
8686 - if [ -f "servant-client-core/configure.ac" ]; then
8787 (cd "servant-client-core" && autoreconf -i);
8888 fi
89+ - if [ -f "servant-http-streams/configure.ac" ]; then
90+ (cd "servant-http-streams" && autoreconf -i);
91+ fi
8992 - if [ -f "servant-docs/configure.ac" ]; then
9093 (cd "servant-docs" && autoreconf -i);
9194 fi
@@ -150,7 +153,7 @@ install:
150153 (cd "doc/cookbook/using-free-client" && autoreconf -i);
151154 fi
152155 - 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
154157 - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
155158
156159# Here starts the actual work to be performed for the package under test;
@@ -164,12 +167,12 @@ script:
164167 - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
165168 - cd ${DISTDIR} || false
166169 - 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"
168171 - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
169172 - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
170173 - "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"
171174 - 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"
173176 - cat cabal.project || true
174177 - cat cabal.project.local || true
175178 - echo -en 'travis_fold:end:unpack\\r'
cabal.project+3−1
@@ -1,6 +1,8 @@
1−packages: servant/
1+packages:
2+ servant/
23 servant-client/
34 servant-client-core/
5+ servant-http-streams/
46 servant-docs/
57 servant-foreign/
68 servant-server/
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 #-}