Merge pull request #1154 from mhcurylo/ClientSpec_split
ClientSpec split into multiple modules
This commit is contained in:
Oleg Grenrus
GitHub
commit
3c9af80cb9
11 changed files with 771 additions and 519 deletions
|
|
@ -89,8 +89,15 @@ test-suite spec
|
||||||
hs-source-dirs: test
|
hs-source-dirs: test
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
Servant.ClientSpec
|
Servant.BasicAuthSpec
|
||||||
|
Servant.ClientTestUtils
|
||||||
|
Servant.ConnectionErrorSpec
|
||||||
|
Servant.FailSpec
|
||||||
|
Servant.GenAuthSpec
|
||||||
|
Servant.HoistClientSpec
|
||||||
Servant.StreamSpec
|
Servant.StreamSpec
|
||||||
|
Servant.SuccessSpec
|
||||||
|
Servant.WrappedApiSpec
|
||||||
|
|
||||||
-- Dependencies inherited from the library. No need to specify bounds.
|
-- Dependencies inherited from the library. No need to specify bounds.
|
||||||
build-depends:
|
build-depends:
|
||||||
|
|
|
||||||
53
servant-client/test/Servant/BasicAuthSpec.hs
Normal file
53
servant-client/test/Servant/BasicAuthSpec.hs
Normal file
|
|
@ -0,0 +1,53 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||||
|
|
||||||
|
module Servant.BasicAuthSpec (spec) where
|
||||||
|
|
||||||
|
import Prelude ()
|
||||||
|
import Prelude.Compat
|
||||||
|
|
||||||
|
import Control.Arrow
|
||||||
|
(left)
|
||||||
|
import Data.Monoid ()
|
||||||
|
import qualified Network.HTTP.Types as HTTP
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
|
import Servant.API
|
||||||
|
(BasicAuthData (..))
|
||||||
|
import Servant.Client
|
||||||
|
import Servant.ClientTestUtils
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = describe "Servant.BasicAuthSpec" $ do
|
||||||
|
basicAuthSpec
|
||||||
|
|
||||||
|
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"
|
||||||
|
|
@ -1,514 +0,0 @@
|
||||||
{-# 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.Concurrent.STM
|
|
||||||
(atomically)
|
|
||||||
import Control.Concurrent.STM.TVar
|
|
||||||
(newTVar, readTVar)
|
|
||||||
import Control.Exception
|
|
||||||
(bracket, fromException)
|
|
||||||
import Control.Monad.Error.Class
|
|
||||||
(throwError)
|
|
||||||
import Data.Aeson
|
|
||||||
import Data.Char
|
|
||||||
(chr, isPrint)
|
|
||||||
import Data.Foldable
|
|
||||||
(forM_, toList)
|
|
||||||
import Data.Maybe
|
|
||||||
(isJust, listToMaybe)
|
|
||||||
import Data.Monoid ()
|
|
||||||
import Data.Proxy
|
|
||||||
import Data.Semigroup
|
|
||||||
((<>))
|
|
||||||
import GHC.Generics
|
|
||||||
(Generic)
|
|
||||||
import qualified Network.HTTP.Client as C
|
|
||||||
import qualified Network.HTTP.Types as HTTP
|
|
||||||
import Network.Socket
|
|
||||||
import qualified Network.Wai as Wai
|
|
||||||
import Network.Wai.Handler.Warp
|
|
||||||
import System.IO.Unsafe
|
|
||||||
(unsafePerformIO)
|
|
||||||
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 Servant.Client
|
|
||||||
import qualified Servant.Client.Core.Auth as Auth
|
|
||||||
import qualified Servant.Client.Core.Request as Req
|
|
||||||
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
|
|
||||||
hoistClientSpec
|
|
||||||
connectionErrorSpec
|
|
||||||
|
|
||||||
-- * test data types
|
|
||||||
|
|
||||||
data Person = Person
|
|
||||||
{ _name :: String
|
|
||||||
, _age :: Integer
|
|
||||||
} deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
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 $ ServerError 400 (n ++ " not found") "" []
|
|
||||||
Nothing -> throwError $ ServerError 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))
|
|
||||||
|
|
||||||
{-# NOINLINE manager' #-}
|
|
||||||
manager' :: C.Manager
|
|
||||||
manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
|
||||||
|
|
||||||
runClient :: ClientM a -> BaseUrl -> IO (Either ClientError 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
|
|
||||||
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")]
|
|
||||||
|
|
||||||
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
|
|
||||||
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 $ ServerError 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
|
|
||||||
|
|
||||||
it "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")
|
|
||||||
|
|
||||||
-- * 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.ClientError" $
|
|
||||||
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
|
|
||||||
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]
|
|
||||||
262
servant-client/test/Servant/ClientTestUtils.hs
Normal file
262
servant-client/test/Servant/ClientTestUtils.hs
Normal file
|
|
@ -0,0 +1,262 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||||
|
|
||||||
|
module Servant.ClientTestUtils where
|
||||||
|
|
||||||
|
import Prelude ()
|
||||||
|
import Prelude.Compat
|
||||||
|
|
||||||
|
import Control.Concurrent
|
||||||
|
(ThreadId, forkIO, killThread)
|
||||||
|
import Control.Monad.Error.Class
|
||||||
|
(throwError)
|
||||||
|
import Data.Aeson
|
||||||
|
import Data.Char
|
||||||
|
(chr, isPrint)
|
||||||
|
import Data.Monoid ()
|
||||||
|
import Data.Proxy
|
||||||
|
import GHC.Generics
|
||||||
|
(Generic)
|
||||||
|
import qualified Network.HTTP.Client as C
|
||||||
|
import qualified Network.HTTP.Types as HTTP
|
||||||
|
import Network.Socket
|
||||||
|
import qualified Network.Wai as Wai
|
||||||
|
import Network.Wai.Handler.Warp
|
||||||
|
import System.IO.Unsafe
|
||||||
|
(unsafePerformIO)
|
||||||
|
import Test.QuickCheck
|
||||||
|
import Web.FormUrlEncoded
|
||||||
|
(FromForm, ToForm)
|
||||||
|
|
||||||
|
import Servant.API
|
||||||
|
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
|
||||||
|
BasicAuthData (..), Capture, CaptureAll,
|
||||||
|
DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
|
||||||
|
Headers, JSON, NoContent (NoContent), Post, QueryFlag,
|
||||||
|
QueryParam, QueryParams, Raw, ReqBody, addHeader)
|
||||||
|
import Servant.Client
|
||||||
|
import qualified Servant.Client.Core.Auth as Auth
|
||||||
|
import Servant.Server
|
||||||
|
import Servant.Server.Experimental.Auth
|
||||||
|
import Servant.Test.ComprehensiveAPI
|
||||||
|
|
||||||
|
-- This declaration simply checks that all instances are in place.
|
||||||
|
_ = client comprehensiveAPIWithoutStreaming
|
||||||
|
|
||||||
|
-- * test data types
|
||||||
|
|
||||||
|
data Person = Person
|
||||||
|
{ _name :: String
|
||||||
|
, _age :: Integer
|
||||||
|
} deriving (Eq, Show, Generic)
|
||||||
|
|
||||||
|
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 $ ServerError 400 (n ++ " not found") "" []
|
||||||
|
Nothing -> throwError $ ServerError 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))
|
||||||
|
|
||||||
|
{-# NOINLINE manager' #-}
|
||||||
|
manager' :: C.Manager
|
||||||
|
manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
||||||
|
|
||||||
|
runClient :: ClientM a -> BaseUrl -> IO (Either ClientError a)
|
||||||
|
runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
|
||||||
|
|
||||||
|
-- * 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]
|
||||||
55
servant-client/test/Servant/ConnectionErrorSpec.hs
Normal file
55
servant-client/test/Servant/ConnectionErrorSpec.hs
Normal file
|
|
@ -0,0 +1,55 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# 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.ConnectionErrorSpec (spec) where
|
||||||
|
|
||||||
|
import Prelude ()
|
||||||
|
import Prelude.Compat
|
||||||
|
|
||||||
|
import Control.Exception
|
||||||
|
(fromException)
|
||||||
|
import Data.Maybe
|
||||||
|
(isJust)
|
||||||
|
import Data.Monoid ()
|
||||||
|
import Data.Proxy
|
||||||
|
import qualified Network.HTTP.Client as C
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
|
import Servant.API
|
||||||
|
(Get, JSON)
|
||||||
|
import Servant.Client
|
||||||
|
import Servant.ClientTestUtils
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = describe "Servant.ConnectionErrorSpec" $ do
|
||||||
|
connectionErrorSpec
|
||||||
|
|
||||||
|
type ConnectionErrorAPI = Get '[JSON] Int
|
||||||
|
|
||||||
|
connectionErrorAPI :: Proxy ConnectionErrorAPI
|
||||||
|
connectionErrorAPI = Proxy
|
||||||
|
|
||||||
|
connectionErrorSpec :: Spec
|
||||||
|
connectionErrorSpec = describe "Servant.Client.ClientError" $
|
||||||
|
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
|
||||||
75
servant-client/test/Servant/FailSpec.hs
Normal file
75
servant-client/test/Servant/FailSpec.hs
Normal file
|
|
@ -0,0 +1,75 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||||
|
|
||||||
|
module Servant.FailSpec (spec) where
|
||||||
|
|
||||||
|
import Prelude ()
|
||||||
|
import Prelude.Compat
|
||||||
|
|
||||||
|
import Data.Monoid ()
|
||||||
|
import Data.Semigroup
|
||||||
|
((<>))
|
||||||
|
import qualified Network.HTTP.Types as HTTP
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
|
import Servant.API
|
||||||
|
((:<|>) ((:<|>)))
|
||||||
|
import Servant.Client
|
||||||
|
import Servant.ClientTestUtils
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = describe "Servant.FailSpec" $ do
|
||||||
|
failSpec
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
it "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
|
||||||
54
servant-client/test/Servant/GenAuthSpec.hs
Normal file
54
servant-client/test/Servant/GenAuthSpec.hs
Normal file
|
|
@ -0,0 +1,54 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||||
|
|
||||||
|
module Servant.GenAuthSpec (spec) where
|
||||||
|
|
||||||
|
import Prelude ()
|
||||||
|
import Prelude.Compat
|
||||||
|
|
||||||
|
import Control.Arrow
|
||||||
|
(left)
|
||||||
|
import Data.Monoid ()
|
||||||
|
import qualified Network.HTTP.Types as HTTP
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
|
import Servant.Client
|
||||||
|
import qualified Servant.Client.Core.Auth as Auth
|
||||||
|
import qualified Servant.Client.Core.Request as Req
|
||||||
|
import Servant.ClientTestUtils
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = describe "Servant.GenAuthSpec" $ do
|
||||||
|
genAuthSpec
|
||||||
|
|
||||||
|
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"
|
||||||
|
|
||||||
58
servant-client/test/Servant/HoistClientSpec.hs
Normal file
58
servant-client/test/Servant/HoistClientSpec.hs
Normal file
|
|
@ -0,0 +1,58 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||||
|
|
||||||
|
module Servant.HoistClientSpec (spec) where
|
||||||
|
|
||||||
|
import Prelude ()
|
||||||
|
import Prelude.Compat
|
||||||
|
|
||||||
|
import Data.Monoid ()
|
||||||
|
import Data.Proxy
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
|
import Servant.API
|
||||||
|
((:<|>) ((:<|>)), (:>), Capture,
|
||||||
|
Get, JSON, Post)
|
||||||
|
import Servant.Client
|
||||||
|
import Servant.Server
|
||||||
|
import Servant.ClientTestUtils
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = describe "Servant.HoistClientSpec" $ do
|
||||||
|
hoistClientSpec
|
||||||
|
|
||||||
|
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 :<|> return
|
||||||
|
|
||||||
|
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
|
||||||
|
|
@ -39,9 +39,6 @@ import Servant.API
|
||||||
NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet,
|
NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet,
|
||||||
)
|
)
|
||||||
import Servant.Client.Streaming
|
import Servant.Client.Streaming
|
||||||
import Servant.ClientSpec
|
|
||||||
(Person (..))
|
|
||||||
import qualified Servant.ClientSpec as CS
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
import Servant.Test.ComprehensiveAPI
|
import Servant.Test.ComprehensiveAPI
|
||||||
import Servant.Types.SourceT
|
import Servant.Types.SourceT
|
||||||
|
|
@ -52,6 +49,8 @@ import System.IO.Unsafe
|
||||||
import System.Mem
|
import System.Mem
|
||||||
(performGC)
|
(performGC)
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
import Servant.ClientTestUtils (Person(..))
|
||||||
|
import qualified Servant.ClientTestUtils as CT
|
||||||
|
|
||||||
#if MIN_VERSION_base(4,10,0)
|
#if MIN_VERSION_base(4,10,0)
|
||||||
import GHC.Stats
|
import GHC.Stats
|
||||||
|
|
@ -120,7 +119,7 @@ testRunSourceIO :: SourceIO a
|
||||||
testRunSourceIO = runExceptT . runSourceT
|
testRunSourceIO = runExceptT . runSourceT
|
||||||
|
|
||||||
streamSpec :: Spec
|
streamSpec :: Spec
|
||||||
streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
|
streamSpec = beforeAll (CT.startWaiApp server) $ afterAll CT.endWaiApp $ do
|
||||||
it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
|
it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
|
||||||
withClient getGetNL baseUrl $ \(Right res) ->
|
withClient getGetNL baseUrl $ \(Right res) ->
|
||||||
testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
|
testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
|
||||||
|
|
|
||||||
140
servant-client/test/Servant/SuccessSpec.hs
Normal file
140
servant-client/test/Servant/SuccessSpec.hs
Normal file
|
|
@ -0,0 +1,140 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||||
|
|
||||||
|
module Servant.SuccessSpec (spec) where
|
||||||
|
|
||||||
|
import Prelude ()
|
||||||
|
import Prelude.Compat
|
||||||
|
|
||||||
|
import Control.Arrow
|
||||||
|
(left)
|
||||||
|
import Control.Concurrent.STM
|
||||||
|
(atomically)
|
||||||
|
import Control.Concurrent.STM.TVar
|
||||||
|
(newTVar, readTVar)
|
||||||
|
import Data.Foldable
|
||||||
|
(forM_, toList)
|
||||||
|
import Data.Maybe
|
||||||
|
(listToMaybe)
|
||||||
|
import Data.Monoid ()
|
||||||
|
import qualified Network.HTTP.Client as C
|
||||||
|
import qualified Network.HTTP.Types as HTTP
|
||||||
|
import Test.Hspec
|
||||||
|
import Test.Hspec.QuickCheck
|
||||||
|
import Test.HUnit
|
||||||
|
import Test.QuickCheck
|
||||||
|
|
||||||
|
import Servant.API
|
||||||
|
(NoContent (NoContent), getHeaders)
|
||||||
|
import Servant.Client
|
||||||
|
import qualified Servant.Client.Core.Request as Req
|
||||||
|
import Servant.Test.ComprehensiveAPI
|
||||||
|
import Servant.ClientTestUtils
|
||||||
|
|
||||||
|
-- This declaration simply checks that all instances are in place.
|
||||||
|
_ = client comprehensiveAPIWithoutStreaming
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = describe "Servant.SuccessSpec" $ do
|
||||||
|
successSpec
|
||||||
|
|
||||||
|
successSpec :: Spec
|
||||||
|
successSpec = 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")]
|
||||||
|
|
||||||
|
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
|
||||||
|
result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
|
||||||
|
return $
|
||||||
|
result === Right (cap, num, flag, body)
|
||||||
|
|
||||||
63
servant-client/test/Servant/WrappedApiSpec.hs
Normal file
63
servant-client/test/Servant/WrappedApiSpec.hs
Normal file
|
|
@ -0,0 +1,63 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||||
|
|
||||||
|
module Servant.WrappedApiSpec (spec) where
|
||||||
|
|
||||||
|
import Prelude ()
|
||||||
|
import Prelude.Compat
|
||||||
|
|
||||||
|
import Control.Exception
|
||||||
|
(bracket)
|
||||||
|
import Control.Monad.Error.Class
|
||||||
|
(throwError)
|
||||||
|
import Data.Monoid ()
|
||||||
|
import Data.Proxy
|
||||||
|
import qualified Network.HTTP.Types as HTTP
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
|
import Servant.API
|
||||||
|
(Delete, Get, JSON, Post, Put)
|
||||||
|
import Servant.Client
|
||||||
|
import Servant.Server
|
||||||
|
import Servant.ClientTestUtils
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = describe "Servant.WrappedApiSpec" $ do
|
||||||
|
wrappedApiSpec
|
||||||
|
|
||||||
|
data WrappedApi where
|
||||||
|
WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
|
||||||
|
HasClient ClientM api, Client ClientM api ~ ClientM ()) =>
|
||||||
|
Proxy api -> WrappedApi
|
||||||
|
|
||||||
|
wrappedApiSpec :: Spec
|
||||||
|
wrappedApiSpec = describe "error status codes" $ do
|
||||||
|
let serveW api = serve api $ throwError $ ServerError 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") :
|
||||||
|
[]
|
||||||
Loading…
Reference in a new issue