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

changed ClientM to be a Reader of ClientEnv

Browse source
This commit is contained in:
Christian Klinger 2016-09-08 00:03:44 +02:00
parent bf824a3889
commit 7a7f7d7cf5
6 changed files with 126 additions and 91 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
doc/tutorial/Client.lhs
View file

@ -15,11 +15,10 @@ need to have some language extensions and imports:
module Client where
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Data.Aeson
import Data.Proxy
import GHC.Generics
import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)
import Network.HTTP.Client (newManager, defaultManagerSettings)
import Servant.API
import Servant.Client
```
@ -71,19 +70,13 @@ What we are going to get with **servant-client** here is 3 functions, one to que
``` haskell
position :: Int -- ^ value for "x"
-> Int -- ^ value for "y"
-> Manager -- ^ the HTTP client to use
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO Position
-> ClientM Position
hello :: Maybe String -- ^ an optional value for "name"
-> Manager -- ^ the HTTP client to use
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO HelloMessage
-> ClientM HelloMessage
marketing :: ClientInfo -- ^ value for the request body
-> Manager -- ^ the HTTP client to use
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO Email
-> ClientM Email
```
Each function makes available as an argument any value that the response may
@ -120,17 +113,17 @@ data BaseUrl = BaseUrl
That's it. Let's now write some code that uses our client functions.
``` haskell
queries :: Manager -> BaseUrl -> ExceptT ServantError IO (Position, HelloMessage, Email)
queries manager baseurl = do
pos <- position 10 10 manager baseurl
message <- hello (Just "servant") manager baseurl
em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) manager baseurl
queries :: ClientM (Position, HelloMessage, Email)
queries = do
pos <- position 10 10
message <- hello (Just "servant")
em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"])
return (pos, message, em)
run :: IO ()
run = do
manager <- newManager defaultManagerSettings
res <- runExceptT (queries manager (BaseUrl Http "localhost" 8081 ""))
res <- runClientM queries (ClientEnv manager (BaseUrl Http "localhost" 8081 ""))
case res of
Left err -> putStrLn $ "Error: " ++ show err
Right (pos, message, em) -> do

8
servant-client/CHANGELOG.md
View file

@ -1,3 +1,11 @@
0.8.1
-----
* BACKWARDS INCOMPATIBLE: `client` now returns a ClientM which is a Reader for
BasicEnv. BasicEnv comprises the HttpManager and BaseUrl that have had to be
passed to each method returned by `client`.
0.7.1
-----

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

@ -53,6 +53,7 @@ library
, text >= 1.2 && < 1.3
, transformers >= 0.3 && < 0.6
, transformers-compat >= 0.4 && < 0.6
, mtl
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall

30
servant-client/src/Servant/Client.hs
View file

@ -20,6 +20,8 @@ module Servant.Client
, client
, HasClient(..)
, ClientM
, runClientM
, ClientEnv (ClientEnv)
, mkAuthenticateReq
, ServantError(..)
, module Servant.Common.BaseUrl
@ -34,7 +36,7 @@ import Data.Proxy
import Data.String.Conversions
import Data.Text (unpack)
import GHC.TypeLits
import Network.HTTP.Client (Manager, Response)
import Network.HTTP.Client (Response)
import Network.HTTP.Media
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP
@ -154,17 +156,17 @@ instance OVERLAPPABLE_
-- Note [Non-Empty Content Types]
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' a) where
type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a
clientWithRoute Proxy req manager baseurl =
snd <$> performRequestCT (Proxy :: Proxy ct) method req manager baseurl
type Client (Verb method status cts' a) = ClientM a
clientWithRoute Proxy req = do
snd <$> performRequestCT (Proxy :: Proxy ct) method req
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where
type Client (Verb method status cts NoContent)
= Manager -> BaseUrl -> ClientM NoContent
clientWithRoute Proxy req manager baseurl =
performRequestNoBody method req manager baseurl >> return NoContent
= ClientM NoContent
clientWithRoute Proxy req = do
performRequestNoBody method req >> return NoContent
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
@ -172,10 +174,10 @@ instance OVERLAPPING_
( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' (Headers ls a)) where
type Client (Verb method status cts' (Headers ls a))
= Manager -> BaseUrl -> ClientM (Headers ls a)
clientWithRoute Proxy req manager baseurl = do
= ClientM (Headers ls a)
clientWithRoute Proxy req = do
let method = reflectMethod (Proxy :: Proxy method)
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
@ -184,10 +186,10 @@ instance OVERLAPPING_
( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls NoContent)) where
type Client (Verb method status cts (Headers ls NoContent))
= Manager -> BaseUrl -> ClientM (Headers ls NoContent)
clientWithRoute Proxy req manager baseurl = do
= ClientM (Headers ls NoContent)
clientWithRoute Proxy req = do
let method = reflectMethod (Proxy :: Proxy method)
hdrs <- performRequestNoBody method req manager baseurl
hdrs <- performRequestNoBody method req
return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs
}
@ -372,7 +374,7 @@ instance (KnownSymbol sym, HasClient api)
-- back the full `Response`.
instance HasClient Raw where
type Client Raw
= H.Method -> Manager -> BaseUrl -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
= H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
clientWithRoute :: Proxy Raw -> Req -> Client Raw
clientWithRoute Proxy req httpMethod = do

69
servant-client/src/Servant/Common/Req.hs
View file

@ -1,7 +1,10 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Servant.Common.Req where
#if !MIN_VERSION_base(4,8,0)
@ -10,8 +13,18 @@ import Control.Applicative
import Control.Exception
import Control.Monad
import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class
#if MIN_VERSION_mtl(2,2,0)
import Control.Monad.Except (MonadError(..))
#else
import Control.Monad.Error.Class (MonadError(..))
#endif
import Control.Monad.Trans.Except
import GHC.Generics
import Control.Monad.IO.Class ()
import Control.Monad.Reader
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
import Data.String
import Data.String.Conversions
@ -19,9 +32,9 @@ import Data.Proxy
import Data.Text (Text)
import Data.Text.Encoding
import Data.Typeable
import Network.HTTP.Client hiding (Proxy, path)
import Network.HTTP.Media
import Network.HTTP.Types
import Network.HTTP.Client hiding (Proxy, path)
import qualified Network.HTTP.Types.Header as HTTP
import Network.URI hiding (path)
import Servant.API.ContentTypes
@ -149,20 +162,40 @@ parseRequest url = liftM disableStatusCheck (parseUrl url)
displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
type ClientM = ExceptT ServantError IO
data ClientEnv
= ClientEnv
{ manager :: Manager
, baseUrl :: BaseUrl
}
performRequest :: Method -> Req -> Manager -> BaseUrl
-- | @ClientM@ is the monad in which client functions run. Contains the
-- 'Manager' and 'BaseUrl' used for requests in the reader environment.
newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
deriving ( Functor, Applicative, Monad, MonadIO, Generic
, MonadReader ClientEnv
, MonadError ServantError
)
runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
performRequest :: Method -> Req
-> ClientM ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString)
performRequest reqMethod req manager reqHost = do
performRequest reqMethod req = do
m <- asks manager
reqHost <- asks baseUrl
partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod }
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
case eResponse of
Left err ->
throwE . ConnectionError $ SomeException err
throwError . ConnectionError $ SomeException err
Right response -> do
let status = Client.responseStatus response
@ -172,28 +205,26 @@ performRequest reqMethod req manager reqHost = do
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream"
Just t -> case parseAccept t of
Nothing -> throwE $ InvalidContentTypeHeader (cs t) body
Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $
throwE $ FailureResponse status ct body
throwError $ FailureResponse status ct body
return (status_code, body, ct, hdrs, response)
performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> Manager -> BaseUrl
performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
-> ClientM ([HTTP.Header], result)
performRequestCT ct reqMethod req manager reqHost = do
performRequestCT ct reqMethod req = do
let acceptCT = contentType ct
(_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
performRequest reqMethod (req { reqAccept = [acceptCT] })
unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody
Left err -> throwError $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val)
performRequestNoBody :: Method -> Req -> Manager -> BaseUrl
-> ClientM [HTTP.Header]
performRequestNoBody reqMethod req manager reqHost = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost
performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
performRequestNoBody reqMethod req = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
return hdrs
catchConnectionError :: IO a -> IO (Either ServantError a)

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

@ -32,7 +32,7 @@ import Control.Applicative ((<$>))
import Control.Arrow (left)
import Control.Concurrent (forkIO, killThread, ThreadId)
import Control.Exception (bracket)
import Control.Monad.Trans.Except (throwE, runExceptT)
import Control.Monad.Trans.Except (throwE )
import Data.Aeson
import qualified Data.ByteString.Lazy as BS
import Data.Char (chr, isPrint)
@ -123,22 +123,22 @@ type Api =
api :: Proxy Api
api = Proxy
getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person
getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent
getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person
getCaptureAll :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person]
getBody :: Person -> C.Manager -> BaseUrl -> SCR.ClientM Person
getQueryParam :: Maybe String -> C.Manager -> BaseUrl -> SCR.ClientM Person
getQueryParams :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person]
getQueryFlag :: Bool -> C.Manager -> BaseUrl -> SCR.ClientM Bool
getRawSuccess :: HTTP.Method -> C.Manager -> BaseUrl
getGet :: SCR.ClientM Person
getDeleteEmpty :: SCR.ClientM NoContent
getCapture :: String -> SCR.ClientM Person
getCaptureAll :: [String] -> SCR.ClientM [Person]
getBody :: Person -> SCR.ClientM Person
getQueryParam :: Maybe String -> SCR.ClientM Person
getQueryParams :: [String] -> SCR.ClientM [Person]
getQueryFlag :: Bool -> SCR.ClientM Bool
getRawSuccess :: HTTP.Method
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
getRawFailure :: HTTP.Method -> C.Manager -> BaseUrl
getRawFailure :: HTTP.Method
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> C.Manager -> BaseUrl
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
-> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: C.Manager -> BaseUrl -> SCR.ClientM (Headers TestHeaders Bool)
getDeleteContentType :: C.Manager -> BaseUrl -> SCR.ClientM NoContent
getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool)
getDeleteContentType :: SCR.ClientM NoContent
getGet
:<|> getDeleteEmpty
:<|> getCapture
@ -242,42 +242,42 @@ sucessSpec :: Spec
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Servant.API.Get" $ \(_, baseUrl) -> do
(left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice
(left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice
describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do
(left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent
(left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do
(left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent
(left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do
(left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0)
(left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
let expected = [(Person "Paula" 0), (Person "Peta" 1)]
(left show <$> runExceptT (getCaptureAll ["Paula", "Peta"] manager baseUrl)) `shouldReturn` Right expected
(left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
let p = Person "Clara" 42
(left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p
(left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice
Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl)
left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice
Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl)
responseStatus `shouldBe` HTTP.Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
(left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right []
(left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl))
(left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []
(left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager 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 <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag
(left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl)
res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)
case res of
Left e -> assertFailure $ show e
Right (code, body, ct, _, response) -> do
@ -286,7 +286,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
C.responseStatus response `shouldBe` HTTP.ok200
it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl)
res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)
case res of
Right _ -> assertFailure "expected Left, but got Right"
Left e -> do
@ -294,7 +294,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
Servant.Client.responseBody e `shouldBe` "rawFailure"
it "Returns headers appropriately" $ \(_, baseUrl) -> do
res <- runExceptT (getRespHeaders manager baseUrl)
res <- runClientM getRespHeaders (ClientEnv manager baseUrl)
case res of
Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
@ -303,7 +303,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ 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 <$> runExceptT (getMultiple cap num flag body manager baseUrl)
result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)
return $
result === Right (cap, num, flag, body)
@ -315,9 +315,9 @@ wrappedApiSpec = describe "error status codes" $ do
let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) =
it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM ()
let getResponse :: SCR.ClientM ()
getResponse = client api
Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl)
Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl)
responseStatus `shouldBe` (HTTP.Status 500 "error message")
in mapM_ test $
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
@ -332,42 +332,42 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
context "client returns errors appropriately" $ do
it "reports FailureResponse" $ \(_, baseUrl) -> do
let (_ :<|> getDeleteEmpty :<|> _) = client api
Left res <- runExceptT (getDeleteEmpty manager baseUrl)
Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)
case res of
FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
_ -> fail $ "expected 404 response, but got " <> show res
it "reports DecodeFailure" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> getCapture :<|> _) = client api
Left res <- runExceptT (getCapture "foo" manager baseUrl)
Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)
case res of
DecodeFailure _ ("application/json") _ -> return ()
_ -> fail $ "expected DecodeFailure, but got " <> show res
it "reports ConnectionError" $ \_ -> do
let (getGetWrongHost :<|> _) = client api
Left res <- runExceptT (getGetWrongHost manager (BaseUrl Http "127.0.0.1" 19872 ""))
Left res <- runClientM getGetWrongHost (ClientEnv manager (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 <- runExceptT (getGet manager baseUrl)
Left res <- runClientM getGet (ClientEnv manager 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 <- runExceptT (getBody alice manager baseUrl)
Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl)
case res of
InvalidContentTypeHeader "fooooo" _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where
WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) =>
HasClient api, Client api ~ SCR.ClientM ()) =>
Proxy api -> WrappedApi
basicAuthSpec :: Spec
@ -377,14 +377,14 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "servant" "server"
(left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice
(left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager 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{..} <- runExceptT (getBasic basicAuthData manager baseUrl)
Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)
responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
genAuthSpec :: Spec
@ -394,14 +394,14 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
(left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice
(left show <$> runClientM (getProtected authRequest) (ClientEnv manager 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 = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl)
Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
-- * utils