diff --git a/servant-client-core/README.md b/servant-client-core/README.md new file mode 100644 index 00000000..601a1d55 --- /dev/null +++ b/servant-client-core/README.md @@ -0,0 +1,5 @@ +# servant-client-core + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +HTTP-client-agnostic client functions for servant APIs. diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 0e9411b7..d5716be5 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -65,5 +65,3 @@ test-suite spec , QuickCheck >= 2.7 && < 2.10 other-modules: Servant.Client.Core.Internal.BaseUrlSpec - build-depends: - base == 4.* diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index 5701e8c2..5de52556 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -19,7 +19,7 @@ module Servant.Client.Core ( AuthClientData , AuthenticateReq(..) - , client + , clientIn , HasClient(..) , mkAuthenticateReq , ServantError(..) @@ -29,6 +29,15 @@ module Servant.Client.Core , Response(..) , RequestBody(..) , module Servant.Client.Core.Internal.BaseUrl + , ClientLike(..) + , genericMkClientL + , genericMkClientP + -- * Writing instances + , addHeader + , appendToQueryString + , appendToPath + , setRequestBodyLBS + , setRequestBody ) where import Control.Monad.Error.Class (throwError) @@ -67,10 +76,15 @@ import Servant.API ((:<|>) ((:<|>)), (:>), import Servant.API.ContentTypes (contentTypes) import Servant.Client.Core.Internal.Auth -import Servant.Client.Core.Internal.BaseUrl +import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..), + InvalidBaseUrlException, + Scheme (..), + parseBaseUrl, + showBaseUrl) import Servant.Client.Core.Internal.BasicAuth import Servant.Client.Core.Internal.Class import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.Generic -- * Accessing APIs as a Client @@ -88,9 +102,9 @@ import Servant.Client.Core.Internal.Request -- > -- > getAllBooks :: ClientM [Book] -- > postNewBook :: Book -> ClientM Book --- > (getAllBooks :<|> postNewBook) = client clientM myApi -client :: HasClient m api => Proxy m -> Proxy api -> Client m api -client pm p = clientWithRoute pm p defaultRequest +-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM +clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api +clientIn p pm = clientWithRoute pm p defaultRequest -- | This class lets us define how each API combinator diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs index 9640bfbe..cf9eb596 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -- | Authentication for clients module Servant.Client.Core.Internal.Auth where -import Servant.Client.Core.Internal.Request (Request) +import Servant.Client.Core.Internal.Request (Request) -- | For a resource protected by authentication (e.g. AuthProtect), we need -- to provide the client with some data used to add authentication data diff --git a/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs index 9443035d..b95f57bd 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs @@ -1,21 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ViewPatterns #-} -module Servant.Client.Core.Internal.BaseUrl ( - -- * types - BaseUrl (..) - , InvalidBaseUrlException - , Scheme (..) - -- * functions - , parseBaseUrl - , showBaseUrl -) where +module Servant.Client.Core.Internal.BaseUrl where import Control.Monad.Catch (Exception, MonadThrow, throwM) import Data.List import Data.Typeable import GHC.Generics -import Network.URI hiding (path) +import Network.URI hiding (path) import Safe import Text.Read diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs b/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs index c2f5a662..fa3a94bf 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs @@ -10,11 +10,7 @@ #include "overlapping-compat.h" -module Servant.Client.Core.Internal.Generic - ( ClientLike(..) - , genericMkClientL - , genericMkClientP - ) where +module Servant.Client.Core.Internal.Generic where import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to) import Servant.API ((:<|>)(..)) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index d56ad33d..116d92cd 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -12,7 +12,7 @@ license: BSD3 license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors +copyright: 2014-2017 Zalora South East Asia Pte Ltd, Servant Contributors category: Servant, Web build-type: Simple cabal-version: >=1.10 @@ -29,7 +29,8 @@ source-repository head library exposed-modules: - Servant.Client.HttpClient + Servant.Client + Servant.Client.Internal.HttpClient build-depends: base >= 4.7 && < 4.11 , base-compat >= 0.9.1 && < 0.10 @@ -67,7 +68,6 @@ test-suite spec main-is: Spec.hs other-modules: Servant.ClientSpec - , Servant.Common.BaseUrlSpec build-depends: base == 4.* , aeson diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs new file mode 100644 index 00000000..bf03817f --- /dev/null +++ b/servant-client/src/Servant/Client.hs @@ -0,0 +1,10 @@ +module Servant.Client + ( ClientEnv(..) + , ClientM + , runClientM + , client + , module X + ) where + +import Servant.Client.Internal.HttpClient +import Servant.Client.Core as X diff --git a/servant-client/src/Servant/Client/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs similarity index 94% rename from servant-client/src/Servant/Client/HttpClient.hs rename to servant-client/src/Servant/Client/Internal/HttpClient.hs index a54574f6..dcf72dc3 100644 --- a/servant-client/src/Servant/Client/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -9,7 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-| http-client based client requests executor -} -module Servant.Client.HttpClient where +module Servant.Client.Internal.HttpClient where import Prelude () @@ -28,6 +29,7 @@ import qualified Data.ByteString.Lazy as BSL import Data.Foldable (toList) import Data.Functor.Alt (Alt (..)) import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) import Data.String (fromString) import qualified Data.Text as T import GHC.Exts (fromList) @@ -45,6 +47,8 @@ data ClientEnv , baseUrl :: BaseUrl } +client :: HasClient ClientM api => Proxy api -> Client ClientM api +client api = api `clientIn` (Proxy :: Proxy ClientM) -- | @ClientM@ is the monad in which client functions run. Contains the -- 'Manager' and 'BaseUrl' used for requests in the reader environment. diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 49b35769..1a37cc3f 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -26,44 +26,59 @@ #include "overlapping-compat.h" module Servant.ClientSpec where -import Control.Arrow (left) -import Control.Concurrent (forkIO, killThread, ThreadId) -import Control.Exception (bracket) -import Control.Monad.Error.Class (throwError ) +import Control.Arrow (left) +import Control.Concurrent (ThreadId, forkIO, + killThread) +import Control.Exception (bracket) +import Control.Monad.Error.Class (throwError) import Data.Aeson -import qualified Data.ByteString.Lazy as BS -import Data.Char (chr, isPrint) -import Data.Foldable (forM_) -import Data.Monoid hiding (getLast) +import qualified Data.ByteString.Lazy as BS +import Data.Char (chr, isPrint) +import Data.Foldable (forM_) +import Data.Monoid hiding (getLast) import Data.Proxy -import qualified Generics.SOP as SOP -import GHC.Generics (Generic) -import qualified Network.HTTP.Client as C +import qualified Generics.SOP as SOP +import GHC.Generics (Generic) +import qualified Network.HTTP.Client as C import Network.HTTP.Media -import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP.Types as HTTP import Network.Socket -import Network.Wai (Request, requestHeaders, responseLBS) +import qualified Network.Wai as Wai import Network.Wai.Handler.Warp -import Prelude () +import Prelude () import Prelude.Compat -import System.IO.Unsafe (unsafePerformIO) -import Test.HUnit +import System.IO.Unsafe (unsafePerformIO) import Test.Hspec import Test.Hspec.QuickCheck +import Test.HUnit import Test.QuickCheck -import Web.FormUrlEncoded (FromForm, ToForm) +import Web.FormUrlEncoded (FromForm, ToForm) -import Servant.API +import Servant.API ((:<|>) ((:<|>)), + (:>), AuthProtect, + BasicAuth, + BasicAuthData (..), + Capture, + CaptureAll, Delete, + DeleteNoContent, + EmptyAPI, + FormUrlEncoded, + Get, Header, + Headers, JSON, + NoContent, Post, + Put, QueryFlag, + QueryParam, + QueryParams, + ReqBody) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client -import Servant.Client.Generic -import qualified Servant.Common.Req as SCR -import qualified Servant.Client.HttpClient as SCR +{-import qualified Servant.Common.Req as SCR-} +{-import qualified Servant.Client.HttpClient as SCR-} import Servant.Server import Servant.Server.Experimental.Auth -- This declaration simply checks that all instances are in place. -_ = client inClientM comprehensiveAPI +_ = client comprehensiveAPI spec :: Spec spec = describe "Servant.Client" $ do @@ -76,17 +91,16 @@ spec = describe "Servant.Client" $ do -- * test data types -data Person = Person { - name :: String, - age :: Integer - } - deriving (Eq, Show, Generic) +data Person = Person + { name :: String + , age :: Integer + } deriving (Eq, Show, Generic) instance ToJSON Person instance FromJSON Person -instance ToForm Person where -instance FromForm Person where +instance ToForm Person +instance FromForm Person alice :: Person alice = Person "Alice" 42 @@ -117,22 +131,22 @@ type Api = api :: Proxy Api api = Proxy -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 +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 - -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) + -> ClientM Response getRawFailure :: HTTP.Method - -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) + -> ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] - -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])]) -getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool) -getDeleteContentType :: SCR.ClientM NoContent + -> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) +getRespHeaders :: ClientM (Headers TestHeaders Bool) +getDeleteContentType :: ClientM NoContent getGet :<|> getDeleteEmpty @@ -147,7 +161,7 @@ getGet :<|> getMultiple :<|> getRespHeaders :<|> getDeleteContentType - :<|> EmptyClient = client inClientM api + :<|> EmptyClient = client api server :: Application server = serve api ( @@ -162,8 +176,8 @@ server = serve api ( Nothing -> throwError $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return - :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") - :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") + :<|> (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 @@ -179,9 +193,9 @@ failApi = Proxy failServer :: Application failServer = serve failApi ( - (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "") - :<|> (\ _capture -> Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") - :<|> (Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "") + (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "") + :<|> (\ _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 @@ -237,7 +251,7 @@ type GenericClientAPI :<|> Capture "foo" String :> NestedAPI1 data GenericClient = GenericClient - { getSqr :: Maybe Int -> SCR.ClientM Int + { getSqr :: Maybe Int -> ClientM Int , mkNestedClient1 :: String -> NestedClient1 } deriving Generic instance SOP.Generic GenericClient @@ -249,7 +263,7 @@ type NestedAPI1 data NestedClient1 = NestedClient1 { mkNestedClient2 :: Maybe Int -> NestedClient2 - , idChar :: Maybe Char -> SCR.ClientM Char + , idChar :: Maybe Char -> ClientM Char } deriving Generic instance SOP.Generic NestedClient1 instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1 @@ -259,8 +273,8 @@ type NestedAPI2 :<|> "void" :> Post '[JSON] () data NestedClient2 = NestedClient2 - { getSum :: Int -> Int -> SCR.ClientM Int - , doNothing :: SCR.ClientM () + { getSum :: Int -> Int -> ClientM Int + , doNothing :: ClientM () } deriving Generic instance SOP.Generic NestedClient2 instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2 @@ -277,50 +291,52 @@ genericClientServer = serve (Proxy :: Proxy GenericClientAPI) ( nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return) nestedServer2 _int = (\ x y -> return (x + y)) :<|> return () -{-# NOINLINE manager #-} -manager :: C.Manager -manager = unsafePerformIO $ C.newManager C.defaultManagerSettings +{-# NOINLINE manager' #-} +manager' :: C.Manager +manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings + +runClient x = runClientM x (ClientEnv manager' baseUrl) sucessSpec :: Spec sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Servant.API.Get" $ \(_, baseUrl) -> do - (left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice + (left show <$> runClient getGet) `shouldReturn` Right alice describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do - (left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent + (left show <$> (runClient getDeleteEmpty)) `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do - (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent + (left show <$> (runClient getDeleteContentType)) `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do - (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0) + (left show <$> (runClient (getCapture "Paula"))) `shouldReturn` Right (Person "Paula" 0) it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do let expected = [(Person "Paula" 0), (Person "Peta" 1)] - (left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected + (left show <$> (runClient (getCaptureAll ["Paula", "Peta"]))) `shouldReturn` Right expected it "Servant.API.ReqBody" $ \(_, baseUrl) -> do let p = Person "Clara" 42 - (left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p + (left show <$> runClient (getBody p)) `shouldReturn` Right p it "Servant.API.QueryParam" $ \(_, baseUrl) -> do - 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" + left show <$> runClient (getQueryParam (Just "alice")) `shouldReturn` Right alice + Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) + responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found" it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do - (left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right [] - (left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl)) + (left show <$> runClient (getQueryParams [])) `shouldReturn` Right [] + (left show <$> runClient (getQueryParams ["alice", "bob"])) `shouldReturn` Right [Person "alice" 0, Person "bob" 1] context "Servant.API.QueryParam.QueryFlag" $ forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do - (left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag + (left show <$> runClient (getQueryFlag flag)) `shouldReturn` Right flag it "Servant.API.Raw on success" $ \(_, baseUrl) -> do - res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl) + res <- runClient (getRawSuccess HTTP.methodGet) case res of Left e -> assertFailure $ show e Right (code, body, ct, _, response) -> do @@ -329,15 +345,16 @@ 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 <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl) + res <- runClient (getRawFailure HTTP.methodGet) case res of Right _ -> assertFailure "expected Left, but got Right" - Left e -> do - Servant.Client.responseStatus e `shouldBe` HTTP.status400 - Servant.Client.responseBody e `shouldBe` "rawFailure" + 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 <- runClientM getRespHeaders (ClientEnv manager baseUrl) + res <- runClient getRespHeaders case res of Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] @@ -346,7 +363,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> ioProperty $ do - result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl) + result <- left show <$> runClient (getMultiple cap num flag body) return $ result === Right (cap, num, flag, body) @@ -358,10 +375,10 @@ 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 () - getResponse = client inClientM api - Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl) - responseStatus `shouldBe` (HTTP.Status 500 "error message") + let getResponse :: ClientM () + getResponse = client api + Left (FailureResponse r) <- runClient getResponse + responseStatusCode r `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : @@ -374,43 +391,43 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do - let (_ :<|> getDeleteEmpty :<|> _) = client inClientM api - Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl) + let (_ :<|> getDeleteEmpty :<|> _) = client api + Left res <- runClient getDeleteEmpty case res of - FailureResponse _ (HTTP.Status 404 "Not Found") _ _ -> return () + FailureResponse r | responseStatusCode r == 404 -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> getCapture :<|> _) = client inClientM api - Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl) + let (_ :<|> _ :<|> getCapture :<|> _) = client api + Left res <- runClient (getCapture "foo") (ClientEnv manager baseUrl) case res of - DecodeFailure _ ("application/json") _ -> return () + DecodeFailure _ _ -> return () _ -> fail $ "expected DecodeFailure, but got " <> show res it "reports ConnectionError" $ \_ -> do - let (getGetWrongHost :<|> _) = client inClientM api + let (getGetWrongHost :<|> _) = client api Left res <- runClientM getGetWrongHost (ClientEnv manager (BaseUrl Http "127.0.0.1" 19872 "")) case res of ConnectionError _ -> return () _ -> fail $ "expected ConnectionError, but got " <> show res it "reports UnsupportedContentType" $ \(_, baseUrl) -> do - let (getGet :<|> _ ) = client inClientM api - Left res <- runClientM getGet (ClientEnv manager baseUrl) + let (getGet :<|> _ ) = client api + Left res <- runClient getGet case res of UnsupportedContentType ("application/octet-stream") _ -> return () _ -> fail $ "expected UnsupportedContentType, but got " <> show res it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client inClientM api - Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl) + let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api + Left res <- runClient (getBody alice) case res of - InvalidContentTypeHeader "fooooo" _ -> return () + 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 ~ SCR.ClientM ()) => + HasClient ClientM api, Client ClientM api ~ ClientM ()) => Proxy api -> WrappedApi basicAuthSpec :: Spec @@ -418,50 +435,50 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d context "Authentication works when requests are properly authenticated" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do - let getBasic = client inClientM basicAuthAPI + let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "servant" "server" - (left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice + (left show <$> runClient (getBasic basicAuthData)) `shouldReturn` Right alice context "Authentication is rejected when requests are not authenticated properly" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do - let getBasic = client inClientM basicAuthAPI + let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "not" "password" - Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl) - responseStatus `shouldBe` HTTP.Status 403 "Forbidden" + Left (FailureResponse r) <- runClient (getBasic basicAuthData) + 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 inClientM genAuthAPI - let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) - (left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice + let getProtected = client genAuthAPI + let authRequest = mkAuthenticateReq () (\_ req -> addHeader "AuthHeader" ("cool" :: String) req) + (left show <$> runClient (getProtected authRequest) ) `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 inClientM genAuthAPI - let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req) - Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl) - responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") + let getProtected = client genAuthAPI + let authRequest = mkAuthenticateReq () (\_ req -> addHeader "Wrong" ("header" :: String) req) + Left (FailureResponse r) <- runClient (getProtected authRequest) + responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized") genericClientSpec :: Spec genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do describe "Servant.Client.Generic" $ do - let GenericClient{..} = mkClient (client inClientM (Proxy :: Proxy GenericClientAPI)) + let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI)) NestedClient1{..} = mkNestedClient1 "example" NestedClient2{..} = mkNestedClient2 (Just 42) it "works for top-level client inClientM function" $ \(_, baseUrl) -> do - (left show <$> (runClientM (getSqr (Just 5)) (ClientEnv manager baseUrl))) `shouldReturn` Right 25 + (left show <$> (runClient (getSqr (Just 5)))) `shouldReturn` Right 25 it "works for nested clients" $ \(_, baseUrl) -> do - (left show <$> (runClientM (idChar (Just 'c')) (ClientEnv manager baseUrl))) `shouldReturn` Right 'c' - (left show <$> (runClientM (getSum 3 4) (ClientEnv manager baseUrl))) `shouldReturn` Right 7 - (left show <$> (runClientM doNothing (ClientEnv manager baseUrl))) `shouldReturn` Right () + (left show <$> (runClient (idChar (Just 'c')))) `shouldReturn` Right 'c' + (left show <$> (runClient (getSum 3 4))) `shouldReturn` Right 7 + (left show <$> (runClient doNothing )) `shouldReturn` Right () -- * utils