servant/servant-client/test/Servant/ClientSpec.hs

515 lines
20 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
2016-01-14 23:43:48 +01:00
{-# 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 #-}
2016-04-22 08:32:39 +02:00
{-# OPTIONS_GHC -freduction-depth=100 #-}
2015-03-08 23:59:40 +01:00
{-# OPTIONS_GHC -fno-warn-orphans #-}
2015-10-09 00:02:43 +02:00
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2017-11-04 05:10:29 +01:00
module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where
2018-06-29 21:08:26 +02:00
import Prelude ()
2017-09-12 20:43:16 +02:00
import Prelude.Compat
2018-06-29 21:08:26 +02:00
import Control.Arrow
(left)
import Control.Concurrent
(ThreadId, forkIO, killThread)
import Control.Concurrent.STM
(atomically)
import Control.Concurrent.STM.TVar
(newTVar, readTVar)
2018-06-29 21:08:26 +02:00
import Control.Exception
(bracket, fromException)
2018-06-29 21:08:26 +02:00
import Control.Monad.Error.Class
(throwError)
2015-04-19 18:31:23 +02:00
import Data.Aeson
2018-06-29 21:08:26 +02:00
import Data.Char
(chr, isPrint)
import Data.Foldable
(forM_, toList)
import Data.Maybe
(isJust, listToMaybe)
2018-06-29 21:08:26 +02:00
import Data.Monoid ()
2015-04-19 18:31:23 +02:00
import Data.Proxy
2018-06-29 21:08:26 +02:00
import Data.Semigroup
((<>))
import GHC.Generics
(Generic)
import qualified Network.HTTP.Client as C
import qualified Network.HTTP.Types as HTTP
2015-04-19 18:31:23 +02:00
import Network.Socket
import qualified Network.Wai as Wai
2015-04-19 18:31:23 +02:00
import Network.Wai.Handler.Warp
2018-06-29 21:08:26 +02:00
import System.IO.Unsafe
(unsafePerformIO)
2015-04-19 18:31:23 +02:00
import Test.Hspec
import Test.Hspec.QuickCheck
2017-09-12 18:38:52 +02:00
import Test.HUnit
2015-04-19 18:31:23 +02:00
import Test.QuickCheck
2018-06-29 21:08:26 +02:00
import Web.FormUrlEncoded
(FromForm, ToForm)
2017-09-12 18:38:52 +02:00
2018-06-29 21:08:26 +02:00
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)
2015-04-19 18:31:23 +02:00
import Servant.Client
import qualified Servant.Client.Core.Auth as Auth
import qualified Servant.Client.Core.Request as Req
2015-04-19 18:31:23 +02:00
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.Client" $ do
sucessSpec
failSpec
wrappedApiSpec
basicAuthSpec
genAuthSpec
2018-04-04 01:14:18 +02:00
hoistClientSpec
connectionErrorSpec
-- * test data types
2017-09-12 18:38:52 +02:00
data Person = Person
2017-09-13 01:49:55 +02:00
{ _name :: String
, _age :: Integer
2017-09-12 18:38:52 +02:00
} deriving (Eq, Show, Generic)
instance ToJSON Person
instance FromJSON Person
2017-09-12 18:38:52 +02:00
instance ToForm Person
instance FromForm Person
2015-02-24 23:56:06 +01:00
instance Arbitrary Person where
arbitrary = Person <$> arbitrary <*> arbitrary
alice :: Person
alice = Person "Alice" 42
carol :: Person
carol = Person "Carol" 17
2015-05-02 03:21:03 +02:00
type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
type Api =
Get '[JSON] Person
:<|> "get" :> Get '[JSON] Person
:<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
2015-02-24 23:56:06 +01:00
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
:<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
2015-02-24 23:56:06 +01:00
:<|> "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])])
2015-05-02 03:21:03 +02:00
:<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
:<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
:<|> "redirectWithCookie" :> Raw
:<|> "empty" :> EmptyAPI
api :: Proxy Api
api = Proxy
getRoot :: ClientM Person
2017-09-12 18:38:52 +02:00
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
2017-09-12 20:43:16 +02:00
getRawSuccess :: HTTP.Method -> ClientM Response
getRawFailure :: HTTP.Method -> ClientM Response
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
2017-09-12 18:38:52 +02:00
-> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: ClientM (Headers TestHeaders Bool)
getDeleteContentType :: ClientM NoContent
getRedirectWithCookie :: HTTP.Method -> ClientM Response
getRoot
:<|> getGet
:<|> getDeleteEmpty
:<|> getCapture
2016-05-26 18:10:33 +02:00
:<|> getCaptureAll
:<|> getBody
:<|> getQueryParam
:<|> getQueryParams
:<|> getQueryFlag
:<|> getRawSuccess
:<|> getRawFailure
:<|> getMultiple
:<|> getRespHeaders
:<|> getDeleteContentType
:<|> getRedirectWithCookie
2017-09-12 18:38:52 +02:00
:<|> 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
2017-01-16 10:44:25 +01:00
Just n -> throwError $ ServantErr 400 (n ++ " not found") "" []
Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])
:<|> (\ names -> return (zipWith Person names [0..]))
:<|> return
2017-09-12 18:38:52 +02:00
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
2015-05-02 03:21:03 +02:00
:<|> (\ a b c d -> return (a, b, c, d))
2017-09-13 18:36:20 +02:00
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> return NoContent
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
2017-05-16 17:59:41 +02:00
:<|> emptyServer)
2015-03-09 04:38:32 +01:00
type FailApi =
"get" :> Raw
:<|> "capture" :> Capture "name" String :> Raw
:<|> "body" :> Raw
failApi :: Proxy FailApi
failApi = Proxy
failServer :: Application
failServer = serve failApi (
2017-09-12 18:38:52 +02:00
(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")] "")
2015-03-09 04:38:32 +01:00
)
-- * 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") = ()
2017-09-13 18:36:20 +02:00
type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()
2017-09-13 01:49:55 +02:00
genAuthHandler :: AuthHandler Wai.Request ()
genAuthHandler =
2017-09-13 01:49:55 +02:00
let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
2017-01-16 10:44:25 +01:00
Nothing -> throwError (err401 { errBody = "Missing auth header" })
Just _ -> return ()
in mkAuthHandler handler
2017-09-13 01:49:55 +02:00
genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
genAuthServerContext = genAuthHandler :. EmptyContext
genAuthServer :: Application
genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
2017-09-12 18:38:52 +02:00
{-# NOINLINE manager' #-}
manager' :: C.Manager
manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
2017-09-13 01:49:55 +02:00
runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
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
2017-09-12 20:43:16 +02:00
left show <$> runClient getGet baseUrl `shouldReturn` Right alice
describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do
2017-09-12 20:43:16 +02:00
left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do
2017-09-12 20:43:16 +02:00
left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do
2017-09-12 20:43:16 +02:00
left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0)
2016-05-26 18:10:33 +02:00
it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
let expected = [(Person "Paula" 0), (Person "Peta" 1)]
2017-09-12 20:43:16 +02:00
left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected
2016-05-26 18:10:33 +02:00
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
let p = Person "Clara" 42
2017-09-12 20:43:16 +02:00
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
2017-09-12 20:43:16 +02:00
left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
2017-09-12 18:38:52 +02:00
responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
2017-09-12 20:43:16 +02:00
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
2017-09-12 20:43:16 +02:00
left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
2015-10-13 21:45:22 +02:00
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
2017-09-12 20:43:16 +02:00
res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
2015-03-08 23:59:40 +01:00
case res of
Left e -> assertFailure $ show e
2017-09-12 20:43:16 +02:00
Right r -> do
responseStatusCode r `shouldBe` HTTP.status200
responseBody r `shouldBe` "rawSuccess"
2015-10-11 21:47:31 +02:00
it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
2017-09-12 20:43:16 +02:00
res <- runClient (getRawFailure HTTP.methodGet) baseUrl
2015-03-09 04:38:32 +01:00
case res of
Right _ -> assertFailure "expected Left, but got Right"
Left (FailureResponse _ r) -> do
2017-09-12 18:38:52 +02:00
responseStatusCode r `shouldBe` HTTP.status400
responseBody r `shouldBe` "rawFailure"
Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
it "Returns headers appropriately" $ \(_, baseUrl) -> do
2017-09-12 20:43:16 +02:00
res <- runClient getRespHeaders baseUrl
2015-03-08 23:59:40 +01:00
case res of
Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
mgr <- C.newManager C.defaultManagerSettings
cj <- atomically . newTVar $ C.createCookieJar []
_ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj))
cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj)
C.cookie_name <$> cookie `shouldBe` Just "testcookie"
C.cookie_value <$> cookie `shouldBe` Just "test"
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
2017-09-12 20:43:16 +02:00
result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
return $
result === Right (cap, num, flag, body)
2015-03-09 04:38:32 +01:00
wrappedApiSpec :: Spec
wrappedApiSpec = describe "error status codes" $ do
2017-01-16 10:44:25 +01:00
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
2017-09-12 18:38:52 +02:00
let getResponse :: ClientM ()
getResponse = client api
Left (FailureResponse _ r) <- runClient getResponse baseUrl
2017-09-12 18:38:52 +02:00
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
2017-09-12 20:43:16 +02:00
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
2017-09-12 20:43:16 +02:00
Left res <- runClient (getCapture "foo") baseUrl
case res of
2017-09-12 18:38:52 +02:00
DecodeFailure _ _ -> return ()
_ -> fail $ "expected DecodeFailure, but got " <> show res
it "reports ConnectionError" $ \_ -> do
2017-09-12 18:38:52 +02:00
let (getGetWrongHost :<|> _) = client api
2017-09-12 20:43:16 +02:00
Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
case res of
2015-05-25 09:51:35 +02:00
ConnectionError _ -> return ()
_ -> fail $ "expected ConnectionError, but got " <> show res
it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
let (_ :<|> getGet :<|> _ ) = client api
2017-09-12 20:43:16 +02:00
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
2017-09-12 20:43:16 +02:00
Left res <- runClient (getBody alice) baseUrl
case res of
2017-09-12 18:38:52 +02:00
InvalidContentTypeHeader _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
2015-03-08 23:59:40 +01:00
data WrappedApi where
WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
2017-09-12 18:38:52 +02:00
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
2017-09-12 18:38:52 +02:00
let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "servant" "server"
2017-09-12 20:43:16 +02:00
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
2017-09-12 18:38:52 +02:00
let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "not" "password"
Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl
2017-09-12 18:38:52 +02:00
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
2017-09-12 18:38:52 +02:00
let getProtected = client genAuthAPI
2017-09-13 18:36:20 +02:00
let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)
2017-09-12 20:43:16 +02:00
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
2017-09-12 18:38:52 +02:00
let getProtected = client genAuthAPI
2017-09-13 18:36:20 +02:00
let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
2017-09-12 18:38:52 +02:00
responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
2018-04-04 01:14:18 +02:00
-- * 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 runClient 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" $
it "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 @C.HttpException 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
2019-01-22 14:24:16 +01:00
let localhost = tupleToHostAddress (127, 0, 0, 1)
bind s (SockAddrInet defaultPort localhost)
listen s 1
port <- socketPort s
return (fromIntegral port, s)
2015-02-02 03:35:10 +01:00
pathGen :: Gen (NonEmptyList Char)
pathGen = fmap NonEmpty path
where
path = listOf1 $ elements $
2015-04-20 19:52:29 +02:00
filter (not . (`elem` ("?%[]/#;" :: String))) $
2015-02-02 03:35:10 +01:00
filter isPrint $
map chr [0..127]