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

Fix some tests

Browse source
This commit is contained in:
Julian K. Arni 2017-09-12 12:38:52 -04:00
parent 6995e39427
commit 75ea91c34d
10 changed files with 173 additions and 137 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
servant-client-core/README.md Normal file
View file

@ -0,0 +1,5 @@
# servant-client-core
![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
HTTP-client-agnostic client functions for servant APIs.

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

@ -65,5 +65,3 @@ test-suite spec
, QuickCheck >= 2.7 && < 2.10 , QuickCheck >= 2.7 && < 2.10
other-modules: other-modules:
Servant.Client.Core.Internal.BaseUrlSpec Servant.Client.Core.Internal.BaseUrlSpec
build-depends:
base == 4.*

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

@ -19,7 +19,7 @@
module Servant.Client.Core module Servant.Client.Core
( AuthClientData ( AuthClientData
, AuthenticateReq(..) , AuthenticateReq(..)
, client , clientIn
, HasClient(..) , HasClient(..)
, mkAuthenticateReq , mkAuthenticateReq
, ServantError(..) , ServantError(..)
@ -29,6 +29,15 @@ module Servant.Client.Core
, Response(..) , Response(..)
, RequestBody(..) , RequestBody(..)
, module Servant.Client.Core.Internal.BaseUrl , module Servant.Client.Core.Internal.BaseUrl
, ClientLike(..)
, genericMkClientL
, genericMkClientP
-- * Writing instances
, addHeader
, appendToQueryString
, appendToPath
, setRequestBodyLBS
, setRequestBody
) where ) where
import Control.Monad.Error.Class (throwError) import Control.Monad.Error.Class (throwError)
@ -67,10 +76,15 @@ import Servant.API ((:<|>) ((:<|>)), (:>),
import Servant.API.ContentTypes (contentTypes) import Servant.API.ContentTypes (contentTypes)
import Servant.Client.Core.Internal.Auth import Servant.Client.Core.Internal.Auth
import Servant.Client.Core.Internal.BaseUrl import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..),
InvalidBaseUrlException,
Scheme (..),
parseBaseUrl,
showBaseUrl)
import Servant.Client.Core.Internal.BasicAuth import Servant.Client.Core.Internal.BasicAuth
import Servant.Client.Core.Internal.Class import Servant.Client.Core.Internal.Class
import Servant.Client.Core.Internal.Request import Servant.Client.Core.Internal.Request
import Servant.Client.Core.Internal.Generic
-- * Accessing APIs as a Client -- * Accessing APIs as a Client
@ -88,9 +102,9 @@ import Servant.Client.Core.Internal.Request
-- > -- >
-- > getAllBooks :: ClientM [Book] -- > getAllBooks :: ClientM [Book]
-- > postNewBook :: Book -> ClientM Book -- > postNewBook :: Book -> ClientM Book
-- > (getAllBooks :<|> postNewBook) = client clientM myApi -- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM
client :: HasClient m api => Proxy m -> Proxy api -> Client m api clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api
client pm p = clientWithRoute pm p defaultRequest clientIn p pm = clientWithRoute pm p defaultRequest
-- | This class lets us define how each API combinator -- | This class lets us define how each API combinator

6
servant-client-core/src/Servant/Client/Core/Internal/Auth.hs
View file

@ -1,12 +1,12 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
-- | Authentication for clients -- | Authentication for clients
module Servant.Client.Core.Internal.Auth where module Servant.Client.Core.Internal.Auth where
import Servant.Client.Core.Internal.Request (Request) import Servant.Client.Core.Internal.Request (Request)
-- | For a resource protected by authentication (e.g. AuthProtect), we need -- | For a resource protected by authentication (e.g. AuthProtect), we need
-- to provide the client with some data used to add authentication data -- to provide the client with some data used to add authentication data

12
servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs
View file

@ -1,21 +1,13 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
module Servant.Client.Core.Internal.BaseUrl ( module Servant.Client.Core.Internal.BaseUrl where
-- * types
BaseUrl (..)
, InvalidBaseUrlException
, Scheme (..)
-- * functions
, parseBaseUrl
, showBaseUrl
) where
import Control.Monad.Catch (Exception, MonadThrow, throwM) import Control.Monad.Catch (Exception, MonadThrow, throwM)
import Data.List import Data.List
import Data.Typeable import Data.Typeable
import GHC.Generics import GHC.Generics
import Network.URI hiding (path) import Network.URI hiding (path)
import Safe import Safe
import Text.Read import Text.Read

6
servant-client-core/src/Servant/Client/Core/Internal/Generic.hs
View file

@ -10,11 +10,7 @@
#include "overlapping-compat.h" #include "overlapping-compat.h"
module Servant.Client.Core.Internal.Generic module Servant.Client.Core.Internal.Generic where
( ClientLike(..)
, genericMkClientL
, genericMkClientP
) where
import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to) import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to)
import Servant.API ((:<|>)(..)) import Servant.API ((:<|>)(..))

6
servant-client/servant-client.cabal
View file

@ -12,7 +12,7 @@ license: BSD3
license-file: LICENSE license-file: LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors copyright: 2014-2017 Zalora South East Asia Pte Ltd, Servant Contributors
category: Servant, Web category: Servant, Web
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
@ -29,7 +29,8 @@ source-repository head
library library
exposed-modules: exposed-modules:
Servant.Client.HttpClient Servant.Client
Servant.Client.Internal.HttpClient
build-depends: build-depends:
base >= 4.7 && < 4.11 base >= 4.7 && < 4.11
, base-compat >= 0.9.1 && < 0.10 , base-compat >= 0.9.1 && < 0.10
@ -67,7 +68,6 @@ test-suite spec
main-is: Spec.hs main-is: Spec.hs
other-modules: other-modules:
Servant.ClientSpec Servant.ClientSpec
, Servant.Common.BaseUrlSpec
build-depends: build-depends:
base == 4.* base == 4.*
, aeson , aeson

10
servant-client/src/Servant/Client.hs Normal file
View file

@ -0,0 +1,10 @@
module Servant.Client
( ClientEnv(..)
, ClientM
, runClientM
, client
, module X
) where
import Servant.Client.Internal.HttpClient
import Servant.Client.Core as X

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

@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
@ -9,7 +10,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-| http-client based client requests executor -} {-| http-client based client requests executor -}
module Servant.Client.HttpClient where module Servant.Client.Internal.HttpClient where
import Prelude () import Prelude ()
@ -28,6 +29,7 @@ import qualified Data.ByteString.Lazy as BSL
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.Functor.Alt (Alt (..)) import Data.Functor.Alt (Alt (..))
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Proxy (Proxy (..))
import Data.String (fromString) import Data.String (fromString)
import qualified Data.Text as T import qualified Data.Text as T
import GHC.Exts (fromList) import GHC.Exts (fromList)
@ -45,6 +47,8 @@ data ClientEnv
, baseUrl :: BaseUrl , baseUrl :: BaseUrl
} }
client :: HasClient ClientM api => Proxy api -> Client ClientM api
client api = api `clientIn` (Proxy :: Proxy ClientM)
-- | @ClientM@ is the monad in which client functions run. Contains the -- | @ClientM@ is the monad in which client functions run. Contains the
-- 'Manager' and 'BaseUrl' used for requests in the reader environment. -- 'Manager' and 'BaseUrl' used for requests in the reader environment.

233
servant-client/test/Servant/ClientSpec.hs
View file

@ -26,44 +26,59 @@
#include "overlapping-compat.h" #include "overlapping-compat.h"
module Servant.ClientSpec where module Servant.ClientSpec where
import Control.Arrow (left) import Control.Arrow (left)
import Control.Concurrent (forkIO, killThread, ThreadId) import Control.Concurrent (ThreadId, forkIO,
import Control.Exception (bracket) killThread)
import Control.Monad.Error.Class (throwError ) import Control.Exception (bracket)
import Control.Monad.Error.Class (throwError)
import Data.Aeson import Data.Aeson
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
import Data.Char (chr, isPrint) import Data.Char (chr, isPrint)
import Data.Foldable (forM_) import Data.Foldable (forM_)
import Data.Monoid hiding (getLast) import Data.Monoid hiding (getLast)
import Data.Proxy import Data.Proxy
import qualified Generics.SOP as SOP import qualified Generics.SOP as SOP
import GHC.Generics (Generic) import GHC.Generics (Generic)
import qualified Network.HTTP.Client as C import qualified Network.HTTP.Client as C
import Network.HTTP.Media import Network.HTTP.Media
import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types as HTTP
import Network.Socket import Network.Socket
import Network.Wai (Request, requestHeaders, responseLBS) import qualified Network.Wai as Wai
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Test.HUnit
import Test.Hspec import Test.Hspec
import Test.Hspec.QuickCheck import Test.Hspec.QuickCheck
import Test.HUnit
import Test.QuickCheck import Test.QuickCheck
import Web.FormUrlEncoded (FromForm, ToForm) import Web.FormUrlEncoded (FromForm, ToForm)
import Servant.API import Servant.API ((:<|>) ((:<|>)),
(:>), AuthProtect,
BasicAuth,
BasicAuthData (..),
Capture,
CaptureAll, Delete,
DeleteNoContent,
EmptyAPI,
FormUrlEncoded,
Get, Header,
Headers, JSON,
NoContent, Post,
Put, QueryFlag,
QueryParam,
QueryParams,
ReqBody)
import Servant.API.Internal.Test.ComprehensiveAPI import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Client import Servant.Client
import Servant.Client.Generic {-import qualified Servant.Common.Req as SCR-}
import qualified Servant.Common.Req as SCR {-import qualified Servant.Client.HttpClient as SCR-}
import qualified Servant.Client.HttpClient as SCR
import Servant.Server import Servant.Server
import Servant.Server.Experimental.Auth import Servant.Server.Experimental.Auth
-- This declaration simply checks that all instances are in place. -- This declaration simply checks that all instances are in place.
_ = client inClientM comprehensiveAPI _ = client comprehensiveAPI
spec :: Spec spec :: Spec
spec = describe "Servant.Client" $ do spec = describe "Servant.Client" $ do
@ -76,17 +91,16 @@ spec = describe "Servant.Client" $ do
-- * test data types -- * test data types
data Person = Person { data Person = Person
name :: String, { name :: String
age :: Integer , age :: Integer
} } deriving (Eq, Show, Generic)
deriving (Eq, Show, Generic)
instance ToJSON Person instance ToJSON Person
instance FromJSON Person instance FromJSON Person
instance ToForm Person where instance ToForm Person
instance FromForm Person where instance FromForm Person
alice :: Person alice :: Person
alice = Person "Alice" 42 alice = Person "Alice" 42
@ -117,22 +131,22 @@ type Api =
api :: Proxy Api api :: Proxy Api
api = Proxy api = Proxy
getGet :: SCR.ClientM Person getGet :: ClientM Person
getDeleteEmpty :: SCR.ClientM NoContent getDeleteEmpty :: ClientM NoContent
getCapture :: String -> SCR.ClientM Person getCapture :: String -> ClientM Person
getCaptureAll :: [String] -> SCR.ClientM [Person] getCaptureAll :: [String] -> ClientM [Person]
getBody :: Person -> SCR.ClientM Person getBody :: Person -> ClientM Person
getQueryParam :: Maybe String -> SCR.ClientM Person getQueryParam :: Maybe String -> ClientM Person
getQueryParams :: [String] -> SCR.ClientM [Person] getQueryParams :: [String] -> ClientM [Person]
getQueryFlag :: Bool -> SCR.ClientM Bool getQueryFlag :: Bool -> ClientM Bool
getRawSuccess :: HTTP.Method getRawSuccess :: HTTP.Method
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) -> ClientM Response
getRawFailure :: HTTP.Method getRawFailure :: HTTP.Method
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) -> ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
-> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])]) -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool) getRespHeaders :: ClientM (Headers TestHeaders Bool)
getDeleteContentType :: SCR.ClientM NoContent getDeleteContentType :: ClientM NoContent
getGet getGet
:<|> getDeleteEmpty :<|> getDeleteEmpty
@ -147,7 +161,7 @@ getGet
:<|> getMultiple :<|> getMultiple
:<|> getRespHeaders :<|> getRespHeaders
:<|> getDeleteContentType :<|> getDeleteContentType
:<|> EmptyClient = client inClientM api :<|> EmptyClient = client api
server :: Application server :: Application
server = serve api ( server = serve api (
@ -162,8 +176,8 @@ server = serve api (
Nothing -> throwError $ ServantErr 400 "missing parameter" "" []) Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])
:<|> (\ names -> return (zipWith Person names [0..])) :<|> (\ names -> return (zipWith Person names [0..]))
:<|> return :<|> return
:<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
:<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d)) :<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> return NoContent :<|> return NoContent
@ -179,9 +193,9 @@ failApi = Proxy
failServer :: Application failServer :: Application
failServer = serve failApi ( failServer = serve failApi (
(Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "") (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")
:<|> (\ _capture -> Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
:<|> (Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "") :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
) )
-- * basic auth stuff -- * basic auth stuff
@ -237,7 +251,7 @@ type GenericClientAPI
:<|> Capture "foo" String :> NestedAPI1 :<|> Capture "foo" String :> NestedAPI1
data GenericClient = GenericClient data GenericClient = GenericClient
{ getSqr :: Maybe Int -> SCR.ClientM Int { getSqr :: Maybe Int -> ClientM Int
, mkNestedClient1 :: String -> NestedClient1 , mkNestedClient1 :: String -> NestedClient1
} deriving Generic } deriving Generic
instance SOP.Generic GenericClient instance SOP.Generic GenericClient
@ -249,7 +263,7 @@ type NestedAPI1
data NestedClient1 = NestedClient1 data NestedClient1 = NestedClient1
{ mkNestedClient2 :: Maybe Int -> NestedClient2 { mkNestedClient2 :: Maybe Int -> NestedClient2
, idChar :: Maybe Char -> SCR.ClientM Char , idChar :: Maybe Char -> ClientM Char
} deriving Generic } deriving Generic
instance SOP.Generic NestedClient1 instance SOP.Generic NestedClient1
instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1 instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1
@ -259,8 +273,8 @@ type NestedAPI2
:<|> "void" :> Post '[JSON] () :<|> "void" :> Post '[JSON] ()
data NestedClient2 = NestedClient2 data NestedClient2 = NestedClient2
{ getSum :: Int -> Int -> SCR.ClientM Int { getSum :: Int -> Int -> ClientM Int
, doNothing :: SCR.ClientM () , doNothing :: ClientM ()
} deriving Generic } deriving Generic
instance SOP.Generic NestedClient2 instance SOP.Generic NestedClient2
instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2 instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2
@ -277,50 +291,52 @@ genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return) nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)
nestedServer2 _int = (\ x y -> return (x + y)) :<|> return () nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()
{-# NOINLINE manager #-} {-# NOINLINE manager' #-}
manager :: C.Manager manager' :: C.Manager
manager = unsafePerformIO $ C.newManager C.defaultManagerSettings manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
runClient x = runClientM x (ClientEnv manager' baseUrl)
sucessSpec :: Spec sucessSpec :: Spec
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Servant.API.Get" $ \(_, baseUrl) -> do it "Servant.API.Get" $ \(_, baseUrl) -> do
(left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice (left show <$> runClient getGet) `shouldReturn` Right alice
describe "Servant.API.Delete" $ do describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do it "allows empty content type" $ \(_, baseUrl) -> do
(left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent (left show <$> (runClient getDeleteEmpty)) `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do it "allows content type" $ \(_, baseUrl) -> do
(left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent (left show <$> (runClient getDeleteContentType)) `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do it "Servant.API.Capture" $ \(_, baseUrl) -> do
(left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0) (left show <$> (runClient (getCapture "Paula"))) `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
let expected = [(Person "Paula" 0), (Person "Peta" 1)] let expected = [(Person "Paula" 0), (Person "Peta" 1)]
(left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected (left show <$> (runClient (getCaptureAll ["Paula", "Peta"]))) `shouldReturn` Right expected
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
let p = Person "Clara" 42 let p = Person "Clara" 42
(left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p (left show <$> runClient (getBody p)) `shouldReturn` Right p
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice left show <$> runClient (getQueryParam (Just "alice")) `shouldReturn` Right alice
Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl) Left (FailureResponse r) <- runClient (getQueryParam (Just "bob"))
responseStatus `shouldBe` HTTP.Status 400 "bob not found" responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
(left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right [] (left show <$> runClient (getQueryParams [])) `shouldReturn` Right []
(left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl)) (left show <$> runClient (getQueryParams ["alice", "bob"]))
`shouldReturn` Right [Person "alice" 0, Person "bob" 1] `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $ context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
(left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag (left show <$> runClient (getQueryFlag flag)) `shouldReturn` Right flag
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl) res <- runClient (getRawSuccess HTTP.methodGet)
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right (code, body, ct, _, response) -> do Right (code, body, ct, _, response) -> do
@ -329,15 +345,16 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
C.responseStatus response `shouldBe` HTTP.ok200 C.responseStatus response `shouldBe` HTTP.ok200
it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl) res <- runClient (getRawFailure HTTP.methodGet)
case res of case res of
Right _ -> assertFailure "expected Left, but got Right" Right _ -> assertFailure "expected Left, but got Right"
Left e -> do Left (FailureResponse r) -> do
Servant.Client.responseStatus e `shouldBe` HTTP.status400 responseStatusCode r `shouldBe` HTTP.status400
Servant.Client.responseBody e `shouldBe` "rawFailure" responseBody r `shouldBe` "rawFailure"
Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
it "Returns headers appropriately" $ \(_, baseUrl) -> do it "Returns headers appropriately" $ \(_, baseUrl) -> do
res <- runClientM getRespHeaders (ClientEnv manager baseUrl) res <- runClient getRespHeaders
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
@ -346,7 +363,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
ioProperty $ do ioProperty $ do
result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl) result <- left show <$> runClient (getMultiple cap num flag body)
return $ return $
result === Right (cap, num, flag, body) result === Right (cap, num, flag, body)
@ -358,10 +375,10 @@ wrappedApiSpec = describe "error status codes" $ do
let test :: (WrappedApi, String) -> Spec let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) = test (WrappedApi api, desc) =
it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
let getResponse :: SCR.ClientM () let getResponse :: ClientM ()
getResponse = client inClientM api getResponse = client api
Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl) Left (FailureResponse r) <- runClient getResponse
responseStatus `shouldBe` (HTTP.Status 500 "error message") responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")
in mapM_ test $ in mapM_ test $
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
@ -374,43 +391,43 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
context "client returns errors appropriately" $ do context "client returns errors appropriately" $ do
it "reports FailureResponse" $ \(_, baseUrl) -> do it "reports FailureResponse" $ \(_, baseUrl) -> do
let (_ :<|> getDeleteEmpty :<|> _) = client inClientM api let (_ :<|> getDeleteEmpty :<|> _) = client api
Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl) Left res <- runClient getDeleteEmpty
case res of case res of
FailureResponse _ (HTTP.Status 404 "Not Found") _ _ -> return () FailureResponse r | responseStatusCode r == 404 -> return ()
_ -> fail $ "expected 404 response, but got " <> show res _ -> fail $ "expected 404 response, but got " <> show res
it "reports DecodeFailure" $ \(_, baseUrl) -> do it "reports DecodeFailure" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> getCapture :<|> _) = client inClientM api let (_ :<|> _ :<|> getCapture :<|> _) = client api
Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl) Left res <- runClient (getCapture "foo") (ClientEnv manager baseUrl)
case res of case res of
DecodeFailure _ ("application/json") _ -> return () DecodeFailure _ _ -> return ()
_ -> fail $ "expected DecodeFailure, but got " <> show res _ -> fail $ "expected DecodeFailure, but got " <> show res
it "reports ConnectionError" $ \_ -> do it "reports ConnectionError" $ \_ -> do
let (getGetWrongHost :<|> _) = client inClientM api let (getGetWrongHost :<|> _) = client api
Left res <- runClientM getGetWrongHost (ClientEnv manager (BaseUrl Http "127.0.0.1" 19872 "")) Left res <- runClientM getGetWrongHost (ClientEnv manager (BaseUrl Http "127.0.0.1" 19872 ""))
case res of case res of
ConnectionError _ -> return () ConnectionError _ -> return ()
_ -> fail $ "expected ConnectionError, but got " <> show res _ -> fail $ "expected ConnectionError, but got " <> show res
it "reports UnsupportedContentType" $ \(_, baseUrl) -> do it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
let (getGet :<|> _ ) = client inClientM api let (getGet :<|> _ ) = client api
Left res <- runClientM getGet (ClientEnv manager baseUrl) Left res <- runClient getGet
case res of case res of
UnsupportedContentType ("application/octet-stream") _ -> return () UnsupportedContentType ("application/octet-stream") _ -> return ()
_ -> fail $ "expected UnsupportedContentType, but got " <> show res _ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client inClientM api let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl) Left res <- runClient (getBody alice)
case res of case res of
InvalidContentTypeHeader "fooooo" _ -> return () InvalidContentTypeHeader _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where data WrappedApi where
WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
HasClient ClientM api, Client ClientM api ~ SCR.ClientM ()) => HasClient ClientM api, Client ClientM api ~ ClientM ()) =>
Proxy api -> WrappedApi Proxy api -> WrappedApi
basicAuthSpec :: Spec basicAuthSpec :: Spec
@ -418,50 +435,50 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
context "Authentication works when requests are properly authenticated" $ do context "Authentication works when requests are properly authenticated" $ do
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client inClientM basicAuthAPI let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "servant" "server" let basicAuthData = BasicAuthData "servant" "server"
(left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice (left show <$> runClient (getBasic basicAuthData)) `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client inClientM basicAuthAPI let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "not" "password" let basicAuthData = BasicAuthData "not" "password"
Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl) Left (FailureResponse r) <- runClient (getBasic basicAuthData)
responseStatus `shouldBe` HTTP.Status 403 "Forbidden" responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
genAuthSpec :: Spec genAuthSpec :: Spec
genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
context "Authentication works when requests are properly authenticated" $ do context "Authentication works when requests are properly authenticated" $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
let getProtected = client inClientM genAuthAPI let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) let authRequest = mkAuthenticateReq () (\_ req -> addHeader "AuthHeader" ("cool" :: String) req)
(left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice (left show <$> runClient (getProtected authRequest) ) `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
let getProtected = client inClientM genAuthAPI let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req) let authRequest = mkAuthenticateReq () (\_ req -> addHeader "Wrong" ("header" :: String) req)
Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl) Left (FailureResponse r) <- runClient (getProtected authRequest)
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
genericClientSpec :: Spec genericClientSpec :: Spec
genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do
describe "Servant.Client.Generic" $ do describe "Servant.Client.Generic" $ do
let GenericClient{..} = mkClient (client inClientM (Proxy :: Proxy GenericClientAPI)) let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI))
NestedClient1{..} = mkNestedClient1 "example" NestedClient1{..} = mkNestedClient1 "example"
NestedClient2{..} = mkNestedClient2 (Just 42) NestedClient2{..} = mkNestedClient2 (Just 42)
it "works for top-level client inClientM function" $ \(_, baseUrl) -> do it "works for top-level client inClientM function" $ \(_, baseUrl) -> do
(left show <$> (runClientM (getSqr (Just 5)) (ClientEnv manager baseUrl))) `shouldReturn` Right 25 (left show <$> (runClient (getSqr (Just 5)))) `shouldReturn` Right 25
it "works for nested clients" $ \(_, baseUrl) -> do it "works for nested clients" $ \(_, baseUrl) -> do
(left show <$> (runClientM (idChar (Just 'c')) (ClientEnv manager baseUrl))) `shouldReturn` Right 'c' (left show <$> (runClient (idChar (Just 'c')))) `shouldReturn` Right 'c'
(left show <$> (runClientM (getSum 3 4) (ClientEnv manager baseUrl))) `shouldReturn` Right 7 (left show <$> (runClient (getSum 3 4))) `shouldReturn` Right 7
(left show <$> (runClientM doNothing (ClientEnv manager baseUrl))) `shouldReturn` Right () (left show <$> (runClient doNothing )) `shouldReturn` Right ()
-- * utils -- * utils