Manager and BaseUrl are now explicit parameters of all client functions, instead of ReaderTs
This commit is contained in:
mbg
parent
41129e98b3
commit
9e1ba9221d
|
|
@ -33,7 +33,7 @@ import Data.Proxy
|
|||
import Data.String.Conversions
|
||||
import Data.Text (unpack)
|
||||
import GHC.TypeLits
|
||||
import Network.HTTP.Client (Response)
|
||||
import Network.HTTP.Client (Manager, Response)
|
||||
import Network.HTTP.Media
|
||||
import qualified Network.HTTP.Types as H
|
||||
import qualified Network.HTTP.Types.Header as HTTP
|
||||
|
|
@ -53,8 +53,8 @@ import Servant.Common.Req
|
|||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: ClientM [Book]
|
||||
-- > postNewBook :: Book -> ClientM Book
|
||||
-- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book]
|
||||
-- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book
|
||||
-- > (getAllBooks :<|> postNewBook) = client myApi
|
||||
client :: HasClient layout => Proxy layout -> Client layout
|
||||
client p = clientWithRoute p defReq
|
||||
|
|
@ -77,8 +77,8 @@ class HasClient layout where
|
|||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: ClientM [Book]
|
||||
-- > postNewBook :: Book -> ClientM Book
|
||||
-- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book]
|
||||
-- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book
|
||||
-- > (getAllBooks :<|> postNewBook) = client myApi
|
||||
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
|
||||
type Client (a :<|> b) = Client a :<|> Client b
|
||||
|
|
@ -102,7 +102,7 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
|
|||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBook :: Text -> ClientM Book
|
||||
-- > getBook :: Text -> Manager -> BaseUrl -> ClientM Book
|
||||
-- > getBook = client myApi
|
||||
-- > -- then you can just use "getBook" to query that endpoint
|
||||
instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
|
||||
|
|
@ -121,26 +121,28 @@ 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) = ClientM a
|
||||
clientWithRoute Proxy req =
|
||||
snd <$> performRequestCT (Proxy :: Proxy ct) method req
|
||||
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
|
||||
where method = reflectMethod (Proxy :: Proxy method)
|
||||
|
||||
instance OVERLAPPING_
|
||||
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where
|
||||
type Client (Verb method status cts NoContent) = ClientM NoContent
|
||||
clientWithRoute Proxy req =
|
||||
performRequestNoBody method req >> return NoContent
|
||||
type Client (Verb method status cts NoContent)
|
||||
= Manager -> BaseUrl -> ClientM NoContent
|
||||
clientWithRoute Proxy req manager baseurl =
|
||||
performRequestNoBody method req manager baseurl >> return NoContent
|
||||
where method = reflectMethod (Proxy :: Proxy method)
|
||||
|
||||
instance OVERLAPPING_
|
||||
-- Note [Non-Empty Content Types]
|
||||
( 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)) = ClientM (Headers ls a)
|
||||
clientWithRoute Proxy req = do
|
||||
type Client (Verb method status cts' (Headers ls a))
|
||||
= Manager -> BaseUrl -> ClientM (Headers ls a)
|
||||
clientWithRoute Proxy req manager baseurl = do
|
||||
let method = reflectMethod (Proxy :: Proxy method)
|
||||
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req
|
||||
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl
|
||||
return $ Headers { getResponse = resp
|
||||
, getHeadersHList = buildHeadersTo hdrs
|
||||
}
|
||||
|
|
@ -149,10 +151,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))
|
||||
= ClientM (Headers ls NoContent)
|
||||
clientWithRoute Proxy req = do
|
||||
= Manager -> BaseUrl -> ClientM (Headers ls NoContent)
|
||||
clientWithRoute Proxy req manager baseurl = do
|
||||
let method = reflectMethod (Proxy :: Proxy method)
|
||||
hdrs <- performRequestNoBody method req
|
||||
hdrs <- performRequestNoBody method req manager baseurl
|
||||
return $ Headers { getResponse = NoContent
|
||||
, getHeadersHList = buildHeadersTo hdrs
|
||||
}
|
||||
|
|
@ -179,7 +181,7 @@ instance OVERLAPPING_
|
|||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > viewReferer :: Maybe Referer -> ClientM Book
|
||||
-- > viewReferer :: Maybe Referer -> Manager -> BaseUrl -> ClientM Book
|
||||
-- > viewReferer = client myApi
|
||||
-- > -- then you can just use "viewRefer" to query that endpoint
|
||||
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
|
||||
|
|
@ -229,7 +231,7 @@ instance HasClient sublayout
|
|||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooksBy :: Maybe Text -> ClientM [Book]
|
||||
-- > getBooksBy :: Maybe Text -> Manager -> BaseUrl -> ClientM [Book]
|
||||
-- > getBooksBy = client myApi
|
||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooksBy Nothing' for all books
|
||||
|
|
@ -273,7 +275,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
|
|||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooksBy :: [Text] -> ClientM [Book]
|
||||
-- > getBooksBy :: [Text] -> Manager -> BaseUrl -> ClientM [Book]
|
||||
-- > getBooksBy = client myApi
|
||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooksBy []' for all books
|
||||
|
|
@ -312,7 +314,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
|
|||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooks :: Bool -> ClientM [Book]
|
||||
-- > getBooks :: Bool -> Manager -> BaseUrl -> ClientM [Book]
|
||||
-- > getBooks = client myApi
|
||||
-- > -- then you can just use "getBooks" to query that endpoint.
|
||||
-- > -- 'getBooksBy False' for all books
|
||||
|
|
@ -337,7 +339,7 @@ instance (KnownSymbol sym, HasClient sublayout)
|
|||
-- back the full `Response`.
|
||||
instance HasClient Raw where
|
||||
type Client Raw
|
||||
= H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
|
||||
= H.Method -> Manager -> BaseUrl -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
|
||||
|
||||
clientWithRoute :: Proxy Raw -> Req -> Client Raw
|
||||
clientWithRoute Proxy req httpMethod = do
|
||||
|
|
@ -358,7 +360,7 @@ instance HasClient Raw where
|
|||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > addBook :: Book -> ClientM Book
|
||||
-- > addBook :: Book -> Manager -> BaseUrl -> ClientM Book
|
||||
-- > addBook = client myApi
|
||||
-- > -- then you can just use "addBook" to query that endpoint
|
||||
instance (MimeRender ct a, HasClient sublayout)
|
||||
|
|
|
|||
|
|
@ -11,9 +11,7 @@ import Control.Exception
|
|||
import Control.Monad
|
||||
import Control.Monad.Catch (MonadThrow)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
|
||||
import Data.String
|
||||
import Data.String.Conversions
|
||||
|
|
@ -125,21 +123,12 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
|
|||
displayHttpRequest :: Method -> String
|
||||
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
|
||||
|
||||
type ClientM = ReaderT BaseUrl (ReaderT Manager (ExceptT ServantError IO))
|
||||
type ClientM = ExceptT ServantError IO
|
||||
|
||||
runClientM :: ClientM a -> BaseUrl -> Manager -> IO (Either ServantError a)
|
||||
runClientM m baseUrl manager = runExceptT (runReaderT (runReaderT m baseUrl) manager)
|
||||
|
||||
-- to avoid adding a dependency on mtl
|
||||
throwError :: ServantError -> ClientM a
|
||||
throwError = lift . lift . throwE
|
||||
|
||||
performRequest :: Method -> Req
|
||||
performRequest :: Method -> Req -> Manager -> BaseUrl
|
||||
-> ClientM ( Int, ByteString, MediaType
|
||||
, [HTTP.Header], Response ByteString)
|
||||
performRequest reqMethod req = do
|
||||
reqHost <- ask
|
||||
manager <- lift ask
|
||||
performRequest reqMethod req manager reqHost = do
|
||||
partialRequest <- liftIO $ reqToRequest req reqHost
|
||||
|
||||
let request = partialRequest { Client.method = reqMethod
|
||||
|
|
@ -149,7 +138,7 @@ performRequest reqMethod req = do
|
|||
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
|
||||
case eResponse of
|
||||
Left err ->
|
||||
throwError . ConnectionError $ SomeException err
|
||||
throwE . ConnectionError $ SomeException err
|
||||
|
||||
Right response -> do
|
||||
let status = Client.responseStatus response
|
||||
|
|
@ -159,29 +148,29 @@ performRequest reqMethod req = do
|
|||
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
|
||||
Nothing -> pure $ "application"//"octet-stream"
|
||||
Just t -> case parseAccept t of
|
||||
Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
|
||||
Nothing -> throwE $ InvalidContentTypeHeader (cs t) body
|
||||
Just t' -> pure t'
|
||||
unless (status_code >= 200 && status_code < 300) $
|
||||
throwError $ FailureResponse status ct body
|
||||
throwE $ FailureResponse status ct body
|
||||
return (status_code, body, ct, hdrs, response)
|
||||
|
||||
|
||||
performRequestCT :: MimeUnrender ct result =>
|
||||
Proxy ct -> Method -> Req
|
||||
Proxy ct -> Method -> Req -> Manager -> BaseUrl
|
||||
-> ClientM ([HTTP.Header], result)
|
||||
performRequestCT ct reqMethod req = do
|
||||
performRequestCT ct reqMethod req manager reqHost = do
|
||||
let acceptCT = contentType ct
|
||||
(_status, respBody, respCT, hdrs, _response) <-
|
||||
performRequest reqMethod (req { reqAccept = [acceptCT] })
|
||||
unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody
|
||||
performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost
|
||||
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
|
||||
case mimeUnrender ct respBody of
|
||||
Left err -> throwError $ DecodeFailure err respCT respBody
|
||||
Left err -> throwE $ DecodeFailure err respCT respBody
|
||||
Right val -> return (hdrs, val)
|
||||
|
||||
performRequestNoBody :: Method -> Req
|
||||
performRequestNoBody :: Method -> Req -> Manager -> BaseUrl
|
||||
-> ClientM [HTTP.Header]
|
||||
performRequestNoBody reqMethod req = do
|
||||
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
|
||||
performRequestNoBody reqMethod req manager reqHost = do
|
||||
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost
|
||||
return hdrs
|
||||
|
||||
catchConnectionError :: IO a -> IO (Either ServantError a)
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ import Control.Applicative ((<$>))
|
|||
import Control.Arrow (left)
|
||||
import Control.Concurrent (forkIO, killThread, ThreadId)
|
||||
import Control.Exception (bracket)
|
||||
import Control.Monad.Trans.Except (ExceptT, throwE)
|
||||
import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
|
||||
import Data.Aeson
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import Data.Char (chr, isPrint)
|
||||
|
|
@ -119,52 +119,33 @@ type Api =
|
|||
api :: Proxy Api
|
||||
api = Proxy
|
||||
|
||||
getGet :: SCR.ClientM Person
|
||||
getDeleteEmpty :: SCR.ClientM NoContent
|
||||
getCapture :: 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
|
||||
-> SCR.ClientM ( Int
|
||||
, BS.ByteString
|
||||
, MediaType
|
||||
, [HTTP.Header]
|
||||
, C.Response BS.ByteString )
|
||||
getMultiple :: String
|
||||
-> Maybe Int
|
||||
-> Bool
|
||||
-> [(String, [Rational])]
|
||||
-> SCR.ClientM ( String
|
||||
, Maybe Int
|
||||
, Bool
|
||||
, [(String, [Rational])] )
|
||||
getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool)
|
||||
getDeleteContentType :: SCR.ClientM NoContent
|
||||
getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person
|
||||
getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent
|
||||
getCapture :: 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
|
||||
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
|
||||
getRawFailure :: HTTP.Method -> C.Manager -> BaseUrl
|
||||
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
|
||||
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> C.Manager -> BaseUrl
|
||||
-> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])
|
||||
getRespHeaders :: C.Manager -> BaseUrl -> SCR.ClientM (Headers TestHeaders Bool)
|
||||
getDeleteContentType :: C.Manager -> BaseUrl -> SCR.ClientM NoContent
|
||||
getGet
|
||||
:<|> getDeleteEmpty
|
||||
:<|> getCapture
|
||||
:<|> getBody
|
||||
:<|> getQueryParam
|
||||
:<|> getQueryParams
|
||||
:<|> getQueryFlag
|
||||
:<|> getRawSuccess
|
||||
:<|> getRawFailure
|
||||
:<|> getMultiple
|
||||
:<|> getRespHeaders
|
||||
:<|> getDeleteContentType = client api
|
||||
:<|> getDeleteEmpty
|
||||
:<|> getCapture
|
||||
:<|> getBody
|
||||
:<|> getQueryParam
|
||||
:<|> getQueryParams
|
||||
:<|> getQueryFlag
|
||||
:<|> getRawSuccess
|
||||
:<|> getRawFailure
|
||||
:<|> getMultiple
|
||||
:<|> getRespHeaders
|
||||
:<|> getDeleteContentType = client api
|
||||
|
||||
server :: Application
|
||||
server = serve api (
|
||||
|
|
@ -254,38 +235,38 @@ sucessSpec :: Spec
|
|||
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
||||
|
||||
it "Servant.API.Get" $ \(_, baseUrl) -> do
|
||||
(left show <$> SCR.runClientM getGet baseUrl manager) `shouldReturn` Right alice
|
||||
(left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice
|
||||
|
||||
describe "Servant.API.Delete" $ do
|
||||
it "allows empty content type" $ \(_, baseUrl) -> do
|
||||
(left show <$> SCR.runClientM getDeleteEmpty baseUrl manager) `shouldReturn` Right NoContent
|
||||
(left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent
|
||||
|
||||
it "allows content type" $ \(_, baseUrl) -> do
|
||||
(left show <$> SCR.runClientM getDeleteContentType baseUrl manager) `shouldReturn` Right NoContent
|
||||
(left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent
|
||||
|
||||
it "Servant.API.Capture" $ \(_, baseUrl) -> do
|
||||
(left show <$> SCR.runClientM (getCapture "Paula") baseUrl manager) `shouldReturn` Right (Person "Paula" 0)
|
||||
(left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0)
|
||||
|
||||
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
|
||||
let p = Person "Clara" 42
|
||||
(left show <$> SCR.runClientM (getBody p) baseUrl manager) `shouldReturn` Right p
|
||||
(left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p
|
||||
|
||||
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
|
||||
left show <$> SCR.runClientM (getQueryParam (Just "alice")) baseUrl manager `shouldReturn` Right alice
|
||||
Left FailureResponse{..} <- SCR.runClientM (getQueryParam (Just "bob")) baseUrl manager
|
||||
left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice
|
||||
Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl)
|
||||
responseStatus `shouldBe` HTTP.Status 400 "bob not found"
|
||||
|
||||
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
|
||||
(left show <$> SCR.runClientM (getQueryParams []) baseUrl manager) `shouldReturn` Right []
|
||||
(left show <$> SCR.runClientM (getQueryParams ["alice", "bob"]) baseUrl manager)
|
||||
(left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right []
|
||||
(left show <$> runExceptT (getQueryParams ["alice", "bob"] 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 <$> SCR.runClientM (getQueryFlag flag) baseUrl manager) `shouldReturn` Right flag
|
||||
(left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag
|
||||
|
||||
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
|
||||
res <- SCR.runClientM (getRawSuccess HTTP.methodGet) baseUrl manager
|
||||
res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl)
|
||||
case res of
|
||||
Left e -> assertFailure $ show e
|
||||
Right (code, body, ct, _, response) -> do
|
||||
|
|
@ -294,7 +275,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 <- SCR.runClientM (getRawFailure HTTP.methodGet) baseUrl manager
|
||||
res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl)
|
||||
case res of
|
||||
Right _ -> assertFailure "expected Left, but got Right"
|
||||
Left e -> do
|
||||
|
|
@ -302,7 +283,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
|||
Servant.Client.responseBody e `shouldBe` "rawFailure"
|
||||
|
||||
it "Returns headers appropriately" $ \(_, baseUrl) -> do
|
||||
res <- SCR.runClientM getRespHeaders baseUrl manager
|
||||
res <- runExceptT (getRespHeaders manager baseUrl)
|
||||
case res of
|
||||
Left e -> assertFailure $ show e
|
||||
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
|
||||
|
|
@ -311,7 +292,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 <$> SCR.runClientM (getMultiple cap num flag body) baseUrl manager
|
||||
result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl)
|
||||
return $
|
||||
result === Right (cap, num, flag, body)
|
||||
|
||||
|
|
@ -323,9 +304,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 :: SCR.ClientM ()
|
||||
let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM ()
|
||||
getResponse = client api
|
||||
Left FailureResponse{..} <- SCR.runClientM getResponse baseUrl manager
|
||||
Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl)
|
||||
responseStatus `shouldBe` (HTTP.Status 500 "error message")
|
||||
in mapM_ test $
|
||||
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
|
||||
|
|
@ -340,42 +321,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 <- SCR.runClientM getDeleteEmpty baseUrl manager
|
||||
Left res <- runExceptT (getDeleteEmpty 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 <- SCR.runClientM (getCapture "foo") baseUrl manager
|
||||
Left res <- runExceptT (getCapture "foo" 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 <- SCR.runClientM getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "") manager
|
||||
Left res <- runExceptT (getGetWrongHost 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 <- SCR.runClientM getGet baseUrl manager
|
||||
Left res <- runExceptT (getGet 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 <- SCR.runClientM (getBody alice) baseUrl manager
|
||||
Left res <- runExceptT (getBody alice manager baseUrl)
|
||||
case res of
|
||||
InvalidContentTypeHeader "fooooo" _ -> return ()
|
||||
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
|
||||
|
||||
data WrappedApi where
|
||||
WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a,
|
||||
HasClient api, Client api ~ SCR.ClientM ()) =>
|
||||
HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) =>
|
||||
Proxy api -> WrappedApi
|
||||
|
||||
basicAuthSpec :: Spec
|
||||
|
|
@ -385,14 +366,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 <$> SCR.runClientM (getBasic basicAuthData) baseUrl manager) `shouldReturn` Right alice
|
||||
(left show <$> runExceptT (getBasic basicAuthData 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{..} <- SCR.runClientM (getBasic basicAuthData) baseUrl manager
|
||||
Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl)
|
||||
responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
|
||||
|
||||
genAuthSpec :: Spec
|
||||
|
|
@ -402,14 +383,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 <$> SCR.runClientM (getProtected authRequest) baseUrl manager) `shouldReturn` Right alice
|
||||
(left show <$> runExceptT (getProtected authRequest 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{..} <- SCR.runClientM (getProtected authRequest) baseUrl manager
|
||||
Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl)
|
||||
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
|
||||
|
||||
-- * utils
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user