servant-client 0.2.2 → 0.4.0
raw patch · 4 files changed
+397/−148 lines, 4 filesdep +HUnitdep +http-mediadep ~http-clientdep ~servantdep ~servant-server
Dependencies added: HUnit, http-media
Dependency ranges changed: http-client, servant, servant-server
Files
- servant-client.cabal +13/−6
- src/Servant/Client.hs +285/−85
- src/Servant/Common/Req.hs +92/−56
- test/Spec.hs +7/−1
servant-client.cabal view
@@ -1,5 +1,5 @@ name: servant-client-version: 0.2.2+version: 0.4.0 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that@@ -16,6 +16,8 @@ > getAllBooks :: BaseUrl -> EitherT String IO [Book] > postNewBook :: Book -> BaseUrl -> EitherT String IO Book > (getAllBooks :<|> postNewBook) = client myApi+ .+ <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG> license: BSD3 license-file: LICENSE author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni@@ -26,10 +28,10 @@ cabal-version: >=1.10 tested-with: GHC >= 7.8 homepage: http://haskell-servant.github.io/-Bug-reports: http://github.com/haskell-servant/servant-client/issues+Bug-reports: http://github.com/haskell-servant/servant/issues source-repository head type: git- location: http://github.com/haskell-servant/servant-client.git+ location: http://github.com/haskell-servant/servant.git library exposed-modules:@@ -45,10 +47,11 @@ , exceptions , http-client , http-client-tls+ , http-media , http-types , network-uri >= 2.6 , safe- , servant >= 0.2.2 && < 0.3+ , servant == 0.4.* , string-conversions , text , transformers@@ -70,11 +73,15 @@ , deepseq , either , hspec == 2.*+ , http-client+ , http-media , http-types+ , HUnit , network >= 2.6 , QuickCheck >= 2.7- , servant >= 0.2.1+ , servant == 0.4.* , servant-client- , servant-server >= 0.2.1 && < 0.3+ , servant-server == 0.4.*+ , text , wai , warp
src/Servant/Client.hs view
@@ -1,32 +1,43 @@-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+#if !MIN_VERSION_base(4,8,0)+{-# LANGUAGE OverlappingInstances #-}+#endif -- | This module provides 'client' which can automatically generate -- querying functions for each endpoint just from the type representing your -- API. module Servant.Client ( client , HasClient(..)+ , ServantError(..) , module Servant.Common.BaseUrl ) where -import Control.Monad-import Control.Monad.Trans.Either-import Data.Aeson-import Data.ByteString.Lazy (ByteString)-import Data.List-import Data.Proxy-import Data.String.Conversions-import Data.Text (unpack)-import GHC.TypeLits-import qualified Network.HTTP.Types as H-import Servant.API-import Servant.Common.BaseUrl-import Servant.Common.Req-import Servant.Common.Text+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad+import Control.Monad.Trans.Either+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)+import Network.HTTP.Media+import qualified Network.HTTP.Types as H+import qualified Network.HTTP.Types.Header as HTTP+import Servant.API+import Servant.Common.BaseUrl+import Servant.Common.Req -- * Accessing APIs as a Client @@ -41,16 +52,18 @@ -- > getAllBooks :: BaseUrl -> EitherT String IO [Book] -- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book -- > (getAllBooks :<|> postNewBook) = client myApi-client :: HasClient layout => Proxy layout -> Client layout-client p = clientWithRoute p defReq+client :: HasClient layout => Proxy layout -> BaseUrl -> Client layout+client p baseurl = clientWithRoute p defReq baseurl -- | 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 -> Client layout+ clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Client layout +{-type Client layout = Client layout-}+ -- | A client querying function for @a ':<|>' b@ will actually hand you -- one function for querying @a@ and another one for querying @b@, -- stitching them together with ':<|>', which really is just like a pair.@@ -66,9 +79,9 @@ -- > (getAllBooks :<|> postNewBook) = client myApi instance (HasClient a, HasClient b) => HasClient (a :<|> b) where type Client (a :<|> b) = Client a :<|> Client b- clientWithRoute Proxy req =- clientWithRoute (Proxy :: Proxy a) req :<|>- clientWithRoute (Proxy :: Proxy b) req+ clientWithRoute Proxy req baseurl =+ clientWithRoute (Proxy :: Proxy a) req baseurl :<|>+ clientWithRoute (Proxy :: Proxy b) req baseurl -- | If you use a 'Capture' in one of your endpoints in your API, -- the corresponding querying function will automatically take@@ -95,9 +108,10 @@ type Client (Capture capture a :> sublayout) = a -> Client sublayout - clientWithRoute Proxy req val =- clientWithRoute (Proxy :: Proxy sublayout) $- appendToPath p req+ clientWithRoute Proxy req baseurl val =+ clientWithRoute (Proxy :: Proxy sublayout)+ (appendToPath p req)+ baseurl where p = unpack (toText val) @@ -105,21 +119,80 @@ -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to.-instance HasClient Delete where- type Client Delete = BaseUrl -> EitherT String IO ()+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLE #-}+#endif+ (MimeUnrender ct a) => HasClient (Delete (ct ': cts) a) where+ type Client (Delete (ct ': cts) a) = EitherT ServantError IO a+ clientWithRoute Proxy req baseurl =+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl - clientWithRoute Proxy req host =- void $ performRequest H.methodDelete req (== 204) host+-- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content+-- HTTP header.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HasClient (Delete (ct ': cts) ()) where+ type Client (Delete (ct ': cts) ()) = EitherT ServantError IO ()+ clientWithRoute Proxy req baseurl =+ void $ performRequestNoBody H.methodDelete req [204] baseurl +-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the+-- corresponding headers.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ ( MimeUnrender ct a, BuildHeadersTo ls+ ) => HasClient (Delete (ct ': cts) (Headers ls a)) where+ type Client (Delete (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)+ clientWithRoute Proxy req baseurl = do+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl+ return $ Headers { getResponse = resp+ , getHeadersHList = buildHeadersTo hdrs+ }+ -- | If you have a 'Get' endpoint in your API, the client -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to.-instance FromJSON result => HasClient (Get result) where- type Client (Get result) = BaseUrl -> EitherT String IO result- clientWithRoute Proxy req host =- performRequestJSON H.methodGet req 200 host+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLE #-}+#endif+ (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where+ type Client (Get (ct ': cts) result) = EitherT ServantError IO result+ clientWithRoute Proxy req baseurl =+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] baseurl +-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content+-- HTTP status.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HasClient (Get (ct ': cts) ()) where+ type Client (Get (ct ': cts) ()) = EitherT ServantError IO ()+ clientWithRoute Proxy req baseurl =+ performRequestNoBody H.methodGet req [204] baseurl++-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the+-- corresponding headers.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ ( MimeUnrender ct a, BuildHeadersTo ls+ ) => HasClient (Get (ct ': cts) (Headers ls a)) where+ type Client (Get (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)+ clientWithRoute Proxy req baseurl = do+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] baseurl+ return $ Headers { getResponse = resp+ , getHeadersHList = buildHeadersTo hdrs+ }+ -- | If you use a 'Header' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'Header',@@ -151,9 +224,13 @@ type Client (Header sym a :> sublayout) = Maybe a -> Client sublayout - clientWithRoute Proxy req mval =- clientWithRoute (Proxy :: Proxy sublayout) $- maybe req (\value -> addHeader hname value req) mval+ clientWithRoute Proxy req baseurl mval =+ clientWithRoute (Proxy :: Proxy sublayout)+ (maybe req+ (\value -> Servant.Common.Req.addHeader hname value req)+ mval+ )+ baseurl where hname = symbolVal (Proxy :: Proxy sym) @@ -161,22 +238,119 @@ -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to.-instance FromJSON a => HasClient (Post a) where- type Client (Post a) = BaseUrl -> EitherT String IO a+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLE #-}+#endif+ (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where+ type Client (Post (ct ': cts) a) = EitherT ServantError IO a+ clientWithRoute Proxy req baseurl =+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] baseurl - clientWithRoute Proxy req uri =- performRequestJSON H.methodPost req 201 uri+-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content+-- HTTP header.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HasClient (Post (ct ': cts) ()) where+ type Client (Post (ct ': cts) ()) = EitherT ServantError IO ()+ clientWithRoute Proxy req baseurl =+ void $ performRequestNoBody H.methodPost req [204] baseurl +-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the+-- corresponding headers.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ ( MimeUnrender ct a, BuildHeadersTo ls+ ) => HasClient (Post (ct ': cts) (Headers ls a)) where+ type Client (Post (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)+ clientWithRoute Proxy req baseurl = do+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] baseurl+ return $ Headers { getResponse = resp+ , getHeadersHList = buildHeadersTo hdrs+ }+ -- | If you have a 'Put' endpoint in your API, the client -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to.-instance FromJSON a => HasClient (Put a) where- type Client (Put a) = BaseUrl -> EitherT String IO a+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLE #-}+#endif+ (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where+ type Client (Put (ct ': cts) a) = EitherT ServantError IO a+ clientWithRoute Proxy req baseurl =+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] baseurl - clientWithRoute Proxy req host =- performRequestJSON H.methodPut req 200 host+-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content+-- HTTP header.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HasClient (Put (ct ': cts) ()) where+ type Client (Put (ct ': cts) ()) = EitherT ServantError IO ()+ clientWithRoute Proxy req baseurl =+ void $ performRequestNoBody H.methodPut req [204] baseurl +-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the+-- corresponding headers.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ ( MimeUnrender ct a, BuildHeadersTo ls+ ) => HasClient (Put (ct ': cts) (Headers ls a)) where+ type Client (Put (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)+ clientWithRoute Proxy req baseurl = do+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] baseurl+ return $ Headers { getResponse = resp+ , getHeadersHList = buildHeadersTo hdrs+ }++-- | If you have a 'Patch' endpoint in your API, the client+-- side querying function that is created when calling 'client'+-- will just require an argument that specifies the scheme, host+-- and port to send the request to.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLE #-}+#endif+ (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where+ type Client (Patch (ct ': cts) a) = EitherT ServantError IO a+ clientWithRoute Proxy req baseurl =+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] baseurl++-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content+-- HTTP header.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HasClient (Patch (ct ': cts) ()) where+ type Client (Patch (ct ': cts) ()) = EitherT ServantError IO ()+ clientWithRoute Proxy req baseurl =+ void $ performRequestNoBody H.methodPatch req [204] baseurl++-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the+-- corresponding headers.+instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ ( MimeUnrender ct a, BuildHeadersTo ls+ ) => HasClient (Patch (ct ': cts) (Headers ls a)) where+ type Client (Patch (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)+ clientWithRoute Proxy req baseurl = do+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] baseurl+ return $ Headers { getResponse = resp+ , getHeadersHList = buildHeadersTo hdrs+ }+ -- | If you use a 'QueryParam' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'QueryParam',@@ -209,9 +383,13 @@ Maybe a -> Client sublayout -- if mparam = Nothing, we don't add it to the query string- clientWithRoute Proxy req mparam =- clientWithRoute (Proxy :: Proxy sublayout) $- maybe req (flip (appendToQueryString pname) req . Just) mparamText+ clientWithRoute Proxy req baseurl mparam =+ clientWithRoute (Proxy :: Proxy sublayout)+ (maybe req+ (flip (appendToQueryString pname) req . Just)+ mparamText+ )+ baseurl where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym)@@ -219,7 +397,7 @@ -- | If you use a 'QueryParams' in one of your endpoints in your API, -- the corresponding querying function will automatically take--- an additional argument, a list of values of the type specified +-- an additional argument, a list of values of the type specified -- by your 'QueryParams'. -- -- If you give an empty list, nothing will be added to the query string.@@ -250,9 +428,13 @@ type Client (QueryParams sym a :> sublayout) = [a] -> Client sublayout - clientWithRoute Proxy req paramlist =- clientWithRoute (Proxy :: Proxy sublayout) $- foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist'+ clientWithRoute Proxy req baseurl paramlist =+ clientWithRoute (Proxy :: Proxy sublayout)+ (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))+ req+ paramlist'+ )+ baseurl where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym)@@ -285,11 +467,13 @@ type Client (QueryFlag sym :> sublayout) = Bool -> Client sublayout - clientWithRoute Proxy req flag =- clientWithRoute (Proxy :: Proxy sublayout) $- if flag- then appendToQueryString paramname Nothing req- else req+ clientWithRoute Proxy req baseurl flag =+ clientWithRoute (Proxy :: Proxy sublayout)+ (if flag+ then appendToQueryString paramname Nothing req+ else req+ )+ baseurl where paramname = cs $ symbolVal (Proxy :: Proxy sym) @@ -325,9 +509,13 @@ Maybe a -> Client sublayout -- if mparam = Nothing, we don't add it to the query string- clientWithRoute Proxy req mparam =- clientWithRoute (Proxy :: Proxy sublayout) $- maybe req (flip (appendToMatrixParams pname . Just) req) mparamText+ clientWithRoute Proxy req baseurl mparam =+ clientWithRoute (Proxy :: Proxy sublayout)+ (maybe req+ (flip (appendToMatrixParams pname . Just) req)+ mparamText+ )+ baseurl where pname = symbolVal (Proxy :: Proxy sym) mparamText = fmap (cs . toText) mparam@@ -365,9 +553,13 @@ type Client (MatrixParams sym a :> sublayout) = [a] -> Client sublayout - clientWithRoute Proxy req paramlist =- clientWithRoute (Proxy :: Proxy sublayout) $- foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value) req paramlist'+ clientWithRoute Proxy req baseurl paramlist =+ clientWithRoute (Proxy :: Proxy sublayout)+ (foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value)+ req+ paramlist'+ )+ baseurl where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym)@@ -400,22 +592,24 @@ type Client (MatrixFlag sym :> sublayout) = Bool -> Client sublayout - clientWithRoute Proxy req flag =- clientWithRoute (Proxy :: Proxy sublayout) $- if flag- then appendToMatrixParams paramname Nothing req- else req+ clientWithRoute Proxy req baseurl flag =+ clientWithRoute (Proxy :: Proxy sublayout)+ (if flag+ then appendToMatrixParams paramname Nothing req+ else req+ )+ baseurl where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | Pick a 'Method' and specify where the server you want to query is. You get--- back the status code and the response body as a 'ByteString'.+-- back the full `Response`. instance HasClient Raw where- type Client Raw = H.Method -> BaseUrl -> EitherT String IO (Int, ByteString)+ type Client Raw = H.Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) - clientWithRoute :: Proxy Raw -> Req -> Client Raw- clientWithRoute Proxy req httpMethod host =- performRequest httpMethod req (const True) host+ clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw+ clientWithRoute Proxy req baseurl httpMethod = do+ performRequest httpMethod req (const True) baseurl -- | If you use a 'ReqBody' in one of your endpoints in your API, -- the corresponding querying function will automatically take@@ -435,23 +629,29 @@ -- > addBook :: Book -> BaseUrl -> EitherT String IO Book -- > addBook = client myApi -- > -- then you can just use "addBook" to query that endpoint-instance (ToJSON a, HasClient sublayout)- => HasClient (ReqBody a :> sublayout) where+instance (MimeRender ct a, HasClient sublayout)+ => HasClient (ReqBody (ct ': cts) a :> sublayout) where - type Client (ReqBody a :> sublayout) =+ type Client (ReqBody (ct ': cts) a :> sublayout) = a -> Client sublayout - clientWithRoute Proxy req body =- clientWithRoute (Proxy :: Proxy sublayout) $- setRQBody (encode body) req+ clientWithRoute Proxy req baseurl body =+ clientWithRoute (Proxy :: Proxy sublayout)+ (let ctProxy = Proxy :: Proxy ct+ in setRQBody (mimeRender ctProxy body)+ (contentType ctProxy)+ req+ )+ baseurl -- | 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 =- clientWithRoute (Proxy :: Proxy sublayout) $- appendToPath p req+ clientWithRoute Proxy req baseurl =+ clientWithRoute (Proxy :: Proxy sublayout)+ (appendToPath p req)+ baseurl where p = symbolVal (Proxy :: Proxy path)
src/Servant/Common/Req.hs view
@@ -1,42 +1,70 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Servant.Common.Req where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative-import Control.Concurrent+#endif import Control.Exception import Control.Monad import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class import Control.Monad.Trans.Either-import Data.Aeson-import Data.Aeson.Parser-import Data.Aeson.Types-import Data.Attoparsec.ByteString-import Data.ByteString.Lazy hiding (pack)+import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)+import Data.IORef import Data.String import Data.String.Conversions-import Data.Text+import Data.Proxy+import Data.Text (Text) import Data.Text.Encoding-import Network.HTTP.Client+import Network.HTTP.Client hiding (Proxy) import Network.HTTP.Client.TLS+import Network.HTTP.Media import Network.HTTP.Types+import qualified Network.HTTP.Types.Header as HTTP import Network.URI+import Servant.API.ContentTypes import Servant.Common.BaseUrl import Servant.Common.Text import System.IO.Unsafe import qualified Network.HTTP.Client as Client +data ServantError+ = FailureResponse+ { responseStatus :: Status+ , responseContentType :: MediaType+ , responseBody :: ByteString+ }+ | DecodeFailure+ { decodeError :: String+ , responseContentType :: MediaType+ , responseBody :: ByteString+ }+ | UnsupportedContentType+ { responseContentType :: MediaType+ , responseBody :: ByteString+ }+ | ConnectionError+ { connectionError :: HttpException+ }+ | InvalidContentTypeHeader+ { responseContentTypeHeader :: ByteString+ , responseBody :: ByteString+ }+ deriving (Show)+ data Req = Req- { reqPath :: String- , qs :: QueryText- , reqBody :: ByteString- , headers :: [(String, Text)]+ { reqPath :: String+ , qs :: QueryText+ , reqBody :: Maybe (ByteString, MediaType)+ , reqAccept :: [MediaType]+ , headers :: [(String, Text)] } defReq :: Req-defReq = Req "" [] "" []+defReq = Req "" [] Nothing [] [] appendToPath :: String -> Req -> Req appendToPath p req =@@ -62,12 +90,12 @@ ++ [(name, toText val)] } -setRQBody :: ByteString -> Req -> Req-setRQBody b req = req { reqBody = b }+setRQBody :: ByteString -> MediaType -> Req -> Req+setRQBody b t req = req { reqBody = Just (b, t) } reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request reqToRequest req (BaseUrl reqScheme reqHost reqPort) =- fmap (setheaders . setrqb . setQS ) $ parseUrl url+ fmap (setheaders . setAccept . setrqb . setQS ) $ parseUrl url where url = show $ nullURI { uriScheme = case reqScheme of Http -> "http:"@@ -80,10 +108,17 @@ , uriPath = reqPath req } - setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }+ setrqb r = case reqBody req of+ Nothing -> r+ Just (b,t) -> r { requestBody = RequestBodyLBS b+ , requestHeaders = requestHeaders r+ ++ [(hContentType, cs . show $ t)] } setQS = setQueryString $ queryTextToQuery (qs req)- setheaders r = r { requestHeaders = Prelude.map toProperHeader (headers req) }-+ setheaders r = r { requestHeaders = requestHeaders r+ <> fmap toProperHeader (headers req) }+ setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)+ <> [("Accept", renderHeader $ reqAccept req)+ | not . null . reqAccept $ req] } toProperHeader (name, val) = (fromString name, encodeUtf8 val) @@ -91,20 +126,20 @@ -- * performing requests {-# NOINLINE __manager #-}-__manager :: MVar Manager-__manager = unsafePerformIO (newManager tlsManagerSettings >>= newMVar)+__manager :: IORef Manager+__manager = unsafePerformIO (newManager tlsManagerSettings >>= newIORef) __withGlobalManager :: (Manager -> IO a) -> IO a-__withGlobalManager action = modifyMVar __manager $ \ manager -> do- result <- action manager- return (manager, result)+__withGlobalManager action = readIORef __manager >>= action displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" -performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString)+performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl+ -> EitherT ServantError IO ( Int, ByteString, MediaType+ , [HTTP.Header], Response ByteString) performRequest reqMethod req isWantedStatus reqHost = do partialRequest <- liftIO $ reqToRequest req reqHost @@ -113,42 +148,43 @@ } eResponse <- liftIO $ __withGlobalManager $ \ manager ->- catchStatusCodeException $+ catchHttpException $ Client.httpLbs request manager case eResponse of- Left status ->- left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)+ Left err ->+ left $ ConnectionError err Right response -> do let status = Client.responseStatus response- unless (isWantedStatus (statusCode status)) $- left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)- return $ (statusCode status, Client.responseBody response)- where- showStatus (Status code message) =- show code ++ " - " ++ cs message+ body = Client.responseBody response+ hrds = Client.responseHeaders response+ status_code = statusCode status+ ct <- case lookup "Content-Type" $ Client.responseHeaders response of+ Nothing -> pure $ "application"//"octet-stream"+ Just t -> case parseAccept t of+ Nothing -> left $ InvalidContentTypeHeader (cs t) body+ Just t' -> pure t'+ unless (isWantedStatus status_code) $+ left $ FailureResponse status ct body+ return (status_code, body, ct, hrds, response) -performRequestJSON :: FromJSON result =>- Method -> Req -> Int -> BaseUrl -> EitherT String IO result-performRequestJSON reqMethod req wantedStatus reqHost = do- (_status, respBody) <- performRequest reqMethod req (== wantedStatus) reqHost- either- (\ message -> left (displayHttpRequest reqMethod ++ " returned invalid json: " ++ message))- return- (decodeLenient respBody)-+performRequestCT :: MimeUnrender ct result =>+ Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ([HTTP.Header], result)+performRequestCT ct reqMethod req wantedStatus reqHost = do+ let acceptCT = contentType ct+ (_status, respBody, respCT, hrds, _response) <-+ performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost+ unless (matches respCT (acceptCT)) $ left $ UnsupportedContentType respCT respBody+ case mimeUnrender ct respBody of+ Left err -> left $ DecodeFailure err respCT respBody+ Right val -> return (hrds, val) -catchStatusCodeException :: IO a -> IO (Either Status a)-catchStatusCodeException action =- catch (Right <$> action) $ \e ->- case e of- Client.StatusCodeException status _ _ -> return $ Left status- exc -> throwIO exc+performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()+performRequestNoBody reqMethod req wantedStatus reqHost = do+ _ <- performRequest reqMethod req (`elem` wantedStatus) reqHost+ return () --- | Like 'Data.Aeson.decode' but allows all JSON values instead of just--- objects and arrays.-decodeLenient :: FromJSON a => ByteString -> Either String a-decodeLenient input = do- v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)- parseEither parseJSON v+catchHttpException :: IO a -> IO (Either HttpException a)+catchHttpException action =+ catch (Right <$> action) (pure . Left)
test/Spec.hs view
@@ -1,1 +1,7 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+import Servant.ClientSpec (spec, failSpec)++main :: IO ()+main = do+ spec+ failSpec+