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

Add servant-http-streams

Browse source
This commit is contained in:
Oleg Grenrus 2019-02-06 12:15:30 +02:00
parent 4fab471c29
commit b44335ab69
13 changed files with 1182 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
.travis.yml
View file

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

4
cabal.project
View file

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

2
servant-http-streams/CHANGELOG.md Normal file
View file

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

30
servant-http-streams/LICENSE Normal file
View file

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

1
servant-http-streams/README.lhs Symbolic link
View file

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

44
servant-http-streams/README.md Normal file
View file

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

2
servant-http-streams/Setup.hs Normal file
View file

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

137
servant-http-streams/servant-http-streams.cabal Normal file
View file

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

19
servant-http-streams/src/Servant/HttpStreams.hs Normal file
View file

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

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

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

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

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

110
servant-http-streams/test/Servant/StreamSpec.hs Normal file
View file

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

1
servant-http-streams/test/Spec.hs Normal file
View file

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