diff --git a/servant-client.cabal b/servant-client.cabal --- a/servant-client.cabal +++ b/servant-client.cabal @@ -1,5 +1,5 @@ name: servant-client -version: 0.5 +version: 0.6 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that @@ -45,7 +45,7 @@ , http-types , network-uri >= 2.6 , safe - , servant == 0.5.* + , servant == 0.6.* , string-conversions , text , transformers @@ -79,9 +79,9 @@ , HUnit , network >= 2.6 , QuickCheck >= 2.7 - , servant == 0.5.* + , servant == 0.6.* , servant-client - , servant-server == 0.5.* + , servant-server == 0.6.* , text , wai , warp diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -27,14 +27,13 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad.Trans.Except import Data.ByteString.Lazy (ByteString) import Data.List import Data.Proxy import Data.String.Conversions import Data.Text (unpack) import GHC.TypeLits -import Network.HTTP.Client (Response, Manager) +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 @@ -54,19 +53,18 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getAllBooks :: ExceptT String IO [Book] --- > postNewBook :: Book -> ExceptT String IO Book --- > (getAllBooks :<|> postNewBook) = client myApi host manager --- > where host = BaseUrl Http "localhost" 8080 -client :: HasClient layout => Proxy layout -> BaseUrl -> Manager -> Client layout -client p baseurl = clientWithRoute p defReq baseurl +-- > 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 -- | This class lets us define how each API combinator -- influences the creation of an HTTP request. It's mostly -- an internal class, you can just use 'client'. class HasClient layout where type Client layout :: * - clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Manager -> Client layout + clientWithRoute :: Proxy layout -> Req -> Client layout -- | A client querying function for @a ':<|>' b@ will actually hand you @@ -79,15 +77,14 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getAllBooks :: ExceptT String IO [Book] --- > postNewBook :: Book -> ExceptT String IO Book --- > (getAllBooks :<|> postNewBook) = client myApi host manager --- > where host = BaseUrl Http "localhost" 8080 +-- > 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 - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy a) req baseurl manager :<|> - clientWithRoute (Proxy :: Proxy b) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy a) req :<|> + clientWithRoute (Proxy :: Proxy b) req -- | If you use a 'Capture' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -105,9 +102,8 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBook :: Text -> ExceptT String IO Book --- > getBook = client myApi host manager --- > where host = BaseUrl Http "localhost" 8080 +-- > 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) => HasClient (Capture capture a :> sublayout) where @@ -115,11 +111,9 @@ type Client (Capture capture a :> sublayout) = a -> Client sublayout - clientWithRoute Proxy req baseurl manager val = + clientWithRoute Proxy req val = clientWithRoute (Proxy :: Proxy sublayout) (appendToPath p req) - baseurl - manager where p = unpack (toUrlPiece val) @@ -127,16 +121,17 @@ -- 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) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager + 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) = ExceptT ServantError IO NoContent - clientWithRoute Proxy req baseurl manager = - performRequestNoBody method req baseurl manager >> 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_ @@ -144,10 +139,10 @@ ( 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)) - = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager = do + = 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 baseurl manager + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } @@ -156,10 +151,10 @@ ( BuildHeadersTo ls, ReflectMethod method ) => HasClient (Verb method status cts (Headers ls NoContent)) where type Client (Verb method status cts (Headers ls NoContent)) - = ExceptT ServantError IO (Headers ls NoContent) - clientWithRoute Proxy req baseurl manager = do + = Manager -> BaseUrl -> ClientM (Headers ls NoContent) + clientWithRoute Proxy req manager baseurl = do let method = reflectMethod (Proxy :: Proxy method) - hdrs <- performRequestNoBody method req baseurl manager + hdrs <- performRequestNoBody method req manager baseurl return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } @@ -178,7 +173,7 @@ -- Example: -- -- > newtype Referer = Referer { referrer :: Text } --- > deriving (Eq, Show, Generic, FromText, ToHttpApiData) +-- > deriving (Eq, Show, Generic, ToHttpApiData) -- > -- > -- GET /view-my-referer -- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer @@ -186,9 +181,8 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > viewReferer :: Maybe Referer -> ExceptT String IO Book --- > viewReferer = client myApi host --- > where host = BaseUrl Http "localhost" 8080 +-- > 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 instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) @@ -197,14 +191,12 @@ type Client (Header sym a :> sublayout) = Maybe a -> Client sublayout - clientWithRoute Proxy req baseurl manager mval = + clientWithRoute Proxy req mval = clientWithRoute (Proxy :: Proxy sublayout) (maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval ) - baseurl - manager where hname = symbolVal (Proxy :: Proxy sym) @@ -239,9 +231,8 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooksBy :: Maybe Text -> ExceptT String IO [Book] --- > getBooksBy = client myApi host --- > where host = BaseUrl Http "localhost" 8080 +-- > 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 -- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov @@ -252,14 +243,12 @@ Maybe a -> Client sublayout -- if mparam = Nothing, we don't add it to the query string - clientWithRoute Proxy req baseurl manager mparam = + clientWithRoute Proxy req mparam = clientWithRoute (Proxy :: Proxy sublayout) (maybe req (flip (appendToQueryString pname) req . Just) mparamText ) - baseurl - manager where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym) @@ -286,9 +275,8 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooksBy :: [Text] -> ExceptT String IO [Book] --- > getBooksBy = client myApi host --- > where host = BaseUrl Http "localhost" 8080 +-- > getBooksBy :: [Text] -> Manager -> BaseUrl -> ClientM [Book] +-- > getBooksBy = client myApi -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooksBy []' for all books -- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' @@ -299,13 +287,12 @@ type Client (QueryParams sym a :> sublayout) = [a] -> Client sublayout - clientWithRoute Proxy req baseurl manager paramlist = + clientWithRoute Proxy req paramlist = clientWithRoute (Proxy :: Proxy sublayout) (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist' ) - baseurl manager where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym) @@ -327,9 +314,8 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooks :: Bool -> ExceptT String IO [Book] --- > getBooks = client myApi host --- > where host = BaseUrl Http "localhost" 8080 +-- > getBooks :: Bool -> Manager -> BaseUrl -> ClientM [Book] +-- > getBooks = client myApi -- > -- then you can just use "getBooks" to query that endpoint. -- > -- 'getBooksBy False' for all books -- > -- 'getBooksBy True' to only get _already published_ books @@ -339,13 +325,12 @@ type Client (QueryFlag sym :> sublayout) = Bool -> Client sublayout - clientWithRoute Proxy req baseurl manager flag = + clientWithRoute Proxy req flag = clientWithRoute (Proxy :: Proxy sublayout) (if flag then appendToQueryString paramname Nothing req else req ) - baseurl manager where paramname = cs $ symbolVal (Proxy :: Proxy sym) @@ -353,11 +338,12 @@ -- | Pick a 'Method' and specify where the server you want to query is. You get -- back the full `Response`. instance HasClient Raw where - type Client Raw = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) + type Client Raw + = H.Method -> Manager -> BaseUrl -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) - clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw - clientWithRoute Proxy req baseurl manager httpMethod = do - performRequest httpMethod req baseurl manager + clientWithRoute :: Proxy Raw -> Req -> Client Raw + clientWithRoute Proxy req httpMethod = do + performRequest httpMethod req -- | If you use a 'ReqBody' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -374,9 +360,8 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > addBook :: Book -> ExceptT String IO Book --- > addBook = client myApi host manager --- > where host = BaseUrl Http "localhost" 8080 +-- > 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) => HasClient (ReqBody (ct ': cts) a :> sublayout) where @@ -384,43 +369,41 @@ type Client (ReqBody (ct ': cts) a :> sublayout) = a -> Client sublayout - clientWithRoute Proxy req baseurl manager body = + clientWithRoute Proxy req body = clientWithRoute (Proxy :: Proxy sublayout) (let ctProxy = Proxy :: Proxy ct in setRQBody (mimeRender ctProxy body) (contentType ctProxy) req ) - baseurl manager -- | Make the querying function append @path@ to the request path. instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where type Client (path :> sublayout) = Client sublayout - clientWithRoute Proxy req baseurl manager = + clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy sublayout) (appendToPath p req) - baseurl manager where p = symbolVal (Proxy :: Proxy path) instance HasClient api => HasClient (Vault :> api) where type Client (Vault :> api) = Client api - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy api) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy api) req instance HasClient api => HasClient (RemoteHost :> api) where type Client (RemoteHost :> api) = Client api - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy api) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy api) req instance HasClient api => HasClient (IsSecure :> api) where type Client (IsSecure :> api) = Client api - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy api) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy api) req instance HasClient subapi => HasClient (WithNamedContext name context subapi) where @@ -433,16 +416,16 @@ type Client (AuthProtect tag :> api) = AuthenticateReq (AuthProtect tag) -> Client api - clientWithRoute Proxy req baseurl manager (AuthenticateReq (val,func)) = - clientWithRoute (Proxy :: Proxy api) (func val req) baseurl manager + clientWithRoute Proxy req (AuthenticateReq (val,func)) = + clientWithRoute (Proxy :: Proxy api) (func val req) -- * Basic Authentication instance HasClient api => HasClient (BasicAuth realm usr :> api) where type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api - clientWithRoute Proxy req baseurl manager val = - clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager + clientWithRoute Proxy req val = + clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) {- Note [Non-Empty Content Types] diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -123,11 +123,12 @@ displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" +type ClientM = ExceptT ServantError IO -performRequest :: Method -> Req -> BaseUrl -> Manager - -> ExceptT ServantError IO ( Int, ByteString, MediaType - , [HTTP.Header], Response ByteString) -performRequest reqMethod req reqHost manager = do +performRequest :: Method -> Req -> Manager -> BaseUrl + -> ClientM ( Int, ByteString, MediaType + , [HTTP.Header], Response ByteString) +performRequest reqMethod req manager reqHost = do partialRequest <- liftIO $ reqToRequest req reqHost let request = partialRequest { Client.method = reqMethod @@ -155,21 +156,21 @@ performRequestCT :: MimeUnrender ct result => - Proxy ct -> Method -> Req -> BaseUrl -> Manager - -> ExceptT ServantError IO ([HTTP.Header], result) -performRequestCT ct reqMethod req reqHost manager = do + Proxy ct -> Method -> Req -> Manager -> BaseUrl + -> ClientM ([HTTP.Header], result) +performRequestCT ct reqMethod req manager reqHost = do let acceptCT = contentType ct (_status, respBody, respCT, hdrs, _response) <- - performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager + performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of Left err -> throwE $ DecodeFailure err respCT respBody Right val -> return (hdrs, val) -performRequestNoBody :: Method -> Req -> BaseUrl -> Manager - -> ExceptT ServantError IO [HTTP.Header] -performRequestNoBody reqMethod req reqHost manager = do - (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager +performRequestNoBody :: Method -> Req -> Manager -> BaseUrl + -> ClientM [HTTP.Header] +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) diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -28,19 +28,18 @@ import Control.Arrow (left) import Control.Concurrent (forkIO, killThread, ThreadId) import Control.Exception (bracket) -import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT) 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 Data.Proxy import qualified Data.Text as T import GHC.Generics (Generic) -import GHC.TypeLits import qualified Network.HTTP.Client as C import Network.HTTP.Media -import Network.HTTP.Types (Status (..), badRequest400, - methodGet, ok200, status400) +import qualified Network.HTTP.Types as HTTP import Network.Socket import Network.Wai (Application, Request, requestHeaders, responseLBS) @@ -120,6 +119,34 @@ 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 +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 + server :: Application server = serve api ( return alice @@ -132,8 +159,8 @@ Nothing -> throwE $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return - :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") - :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") + :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") + :<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent @@ -149,9 +176,9 @@ failServer :: Application failServer = serve failApi ( - (\ _request respond -> respond $ responseLBS ok200 [] "") - :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "") - :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") + (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "") + :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") + :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "") ) -- * basic auth stuff @@ -208,76 +235,64 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Servant.API.Get" $ \(_, baseUrl) -> do - let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager - (left show <$> runExceptT getGet) `shouldReturn` Right alice + (left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do - let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager - (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right NoContent + (left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do - let getDeleteContentType = getLast $ client api baseUrl manager - (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right NoContent + (left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do - let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager - (left show <$> runExceptT (getCapture "Paula")) `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 - getBody = getNth (Proxy :: Proxy 3) $ client api baseUrl manager - (left show <$> runExceptT (getBody p)) `shouldReturn` Right p + (left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p it "Servant.API.QueryParam" $ \(_, baseUrl) -> do - let getQueryParam = getNth (Proxy :: Proxy 4) $ client api baseUrl manager - left show <$> runExceptT (getQueryParam (Just "alice")) `shouldReturn` Right alice - Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob")) - responseStatus `shouldBe` Status 400 "bob not found" + 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 - let getQueryParams = getNth (Proxy :: Proxy 5) $ client api baseUrl manager - (left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right [] - (left show <$> runExceptT (getQueryParams ["alice", "bob"])) + (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 - let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api baseUrl manager - (left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag + (left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag it "Servant.API.Raw on success" $ \(_, baseUrl) -> do - let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api baseUrl manager - res <- runExceptT (getRawSuccess methodGet) + res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl) case res of Left e -> assertFailure $ show e Right (code, body, ct, _, response) -> do (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") C.responseBody response `shouldBe` body - C.responseStatus response `shouldBe` ok200 + C.responseStatus response `shouldBe` HTTP.ok200 it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do - let getRawFailure = getNth (Proxy :: Proxy 8) $ client api baseUrl manager - res <- runExceptT (getRawFailure methodGet) + res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl) case res of Right _ -> assertFailure "expected Left, but got Right" Left e -> do - Servant.Client.responseStatus e `shouldBe` status400 + Servant.Client.responseStatus e `shouldBe` HTTP.status400 Servant.Client.responseBody e `shouldBe` "rawFailure" it "Returns headers appropriately" $ \(_, baseUrl) -> do - let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api baseUrl manager - res <- runExceptT getRespHeaders + res <- runExceptT (getRespHeaders manager baseUrl) case res of Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] modifyMaxSuccess (const 20) $ do it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> - let getMultiple = getNth (Proxy :: Proxy 9) $ client api baseUrl manager - in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> + property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> ioProperty $ do - result <- left show <$> runExceptT (getMultiple cap num flag body) + result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl) return $ result === Right (cap, num, flag, body) @@ -289,10 +304,10 @@ let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do - let getResponse :: ExceptT ServantError IO () - getResponse = client api baseUrl manager - Left FailureResponse{..} <- runExceptT getResponse - responseStatus `shouldBe` (Status 500 "error message") + let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM () + getResponse = client api + Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl) + responseStatus `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : @@ -305,43 +320,43 @@ context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do - let (_ :<|> getDeleteEmpty :<|> _) = client api baseUrl manager - Left res <- runExceptT getDeleteEmpty + let (_ :<|> getDeleteEmpty :<|> _) = client api + Left res <- runExceptT (getDeleteEmpty manager baseUrl) case res of - FailureResponse (Status 404 "Not Found") _ _ -> return () + FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> getCapture :<|> _) = client api baseUrl manager - Left res <- runExceptT (getCapture "foo") + let (_ :<|> _ :<|> getCapture :<|> _) = client api + 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 (BaseUrl Http "127.0.0.1" 19872 "") manager - Left res <- runExceptT getGetWrongHost + let (getGetWrongHost :<|> _) = client api + 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 baseUrl manager - Left res <- runExceptT getGet + let (getGet :<|> _ ) = client api + 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 baseUrl manager - Left res <- runExceptT (getBody alice) + let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api + 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 ~ ExceptT ServantError IO ()) => + HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) => Proxy api -> WrappedApi basicAuthSpec :: Spec @@ -349,34 +364,34 @@ context "Authentication works when requests are properly authenticated" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do - let getBasic = client basicAuthAPI baseUrl manager + let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "servant" "server" - (left show <$> runExceptT (getBasic basicAuthData)) `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 baseUrl manager + let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "not" "password" - Left FailureResponse{..} <- runExceptT (getBasic basicAuthData) - responseStatus `shouldBe` Status 403 "Forbidden" + Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl) + responseStatus `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 baseUrl manager + let getProtected = client genAuthAPI let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) - (left show <$> runExceptT (getProtected authRequest)) `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 baseUrl manager + let getProtected = client genAuthAPI let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req) - Left FailureResponse{..} <- runExceptT (getProtected authRequest) - responseStatus `shouldBe` (Status 401 "Unauthorized") + Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl) + responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") -- * utils @@ -407,25 +422,3 @@ filter (not . (`elem` ("?%[]/#;" :: String))) $ filter isPrint $ map chr [0..127] - -class GetNth (n :: Nat) a b | n a -> b where - getNth :: Proxy n -> a -> b - -instance OVERLAPPING_ - GetNth 0 (x :<|> y) x where - getNth _ (x :<|> _) = x - -instance OVERLAPPING_ - (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where - getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x - -class GetLast a b | a -> b where - getLast :: a -> b - -instance OVERLAPPING_ - (GetLast b c) => GetLast (a :<|> b) c where - getLast (_ :<|> b) = getLast b - -instance OVERLAPPING_ - GetLast a a where - getLast a = a