diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2016, Will Fancher +Portions 2014-2016, Zalora South East Asia Pte Ltd All rights reserved. @@ -13,7 +14,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Zalora South East Asia Pte Ltd nor the names of other + * Neither the name of Will Fancher nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/servant-haxl-client.cabal b/servant-haxl-client.cabal --- a/servant-haxl-client.cabal +++ b/servant-haxl-client.cabal @@ -1,5 +1,5 @@ name: servant-haxl-client -version: 0.1.0.0 +version: 0.2.0.0 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that @@ -19,15 +19,22 @@ tested-with: GHC >= 7.10 homepage: http://github.com/ElvishJerricco/servant-haxl-client/ Bug-reports: http://github.com/ElvishJerricco/servant-haxl-client/issues +-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367 +extra-source-files: src-ghc/Servant/Haxl/Client/Internal.hs + src-ghc/Servant/Haxl/Client/Internal/Error.hs + src-ghcjs/Servant/Haxl/Client/Internal.hs + src-ghcjs/Servant/Haxl/Client/Internal/Error.hs + src/Servant/Haxl/Client.hs + src/Servant/Haxl/Client/BaseUrl.hs + src/Servant/Haxl/Client/Req.hs + src/Servant/Haxl/Client/Types.hs + source-repository head type: git location: http://github.com/ElvishJerricco/servant-haxl-client.git library - exposed-modules: - Servant.Client.Haxl - Servant.Common.BaseUrl.Haxl - Servant.Common.Req.Haxl + hs-source-dirs: src build-depends: base >=4.8 && <5 , aeson @@ -38,8 +45,6 @@ , exceptions , hashable , haxl - , http-client - , http-client-tls , http-media , http-types , network-uri >= 2.6 @@ -48,9 +53,26 @@ , string-conversions , text , transformers - hs-source-dirs: src + if !impl(ghcjs) + hs-source-dirs: src-ghc + build-depends: + http-client + , http-client-tls + else + hs-source-dirs: src-ghcjs + build-depends: + ghcjs-base + , case-insensitive + exposed-modules: + Servant.Haxl.Client + Servant.Haxl.Client.BaseUrl + Servant.Haxl.Client.Req + Servant.Haxl.Client.Types + Servant.Haxl.Client.Internal + Servant.Haxl.Client.Internal.Error default-language: Haskell2010 ghc-options: -Wall + test-suite spec type: exitcode-stdio-1.0 diff --git a/src-ghc/Servant/Haxl/Client/Internal.hs b/src-ghc/Servant/Haxl/Client/Internal.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Servant/Haxl/Client/Internal.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Servant.Haxl.Client.Internal + ( ServantResponse(..) + , ServantRequest(..) + , initServantClientState + ) where + +import Control.Concurrent.Async +import Control.Concurrent.QSem +import Control.Exception +import Control.Monad +import Control.Monad.Catch (MonadThrow) +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import Data.ByteString.Lazy hiding (elem, filter, map, + null, pack) +import Data.Hashable +import Data.String +import Data.String.Conversions +import Data.Text.Encoding +import Haxl.Core hiding (Request, catch) +import Network.HTTP.Client +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.Haxl.Client.BaseUrl +import Servant.Haxl.Client.Internal.Error +import Servant.Haxl.Client.Types + +import qualified Network.HTTP.Client as Client + +data ServantResponse = ServantResponse (Response ByteString) deriving Show + +reqToRequest :: MonadThrow m => Req -> BaseUrl -> m Request +reqToRequest req (BaseUrl reqScheme reqHost reqPort) = + (setheaders . setAccept . setrqb . setQS) <$> parseUrl url + + where url = show $ nullURI { uriScheme = case reqScheme of + Http -> "http:" + Https -> "https:" + , uriAuthority = Just + URIAuth { uriUserInfo = "" + , uriRegName = reqHost + , uriPort = ":" ++ show reqPort + } + , uriPath = reqPath 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 = 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) + + +performRequest_ :: Manager -> Method -> Req -> WantedStatusCodes -> BaseUrl + -> EitherT ServantError IO ( Int, ByteString, MediaType + , [HTTP.Header], ServantResponse) +performRequest_ manager reqMethod req wantedStatus reqHost = do + partialRequest <- liftIO $ reqToRequest req reqHost + + let request = partialRequest { Client.method = reqMethod + , checkStatus = \ _status _headers _cookies -> Nothing + } + + eResponse <- liftIO $ catchHttpException $ Client.httpLbs request manager + case eResponse of + Left err -> + left $ ConnectionError $ ServantConnectionError err + + Right response -> do + let status = Client.responseStatus response + 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 (wantedStatus `wants` status_code) $ + left $ FailureResponse status ct body + return (status_code, body, ct, hrds, ServantResponse response) + where + wants AllCodes _ = True + wants (SelectCodes codes) status_code = status_code `elem` codes + +catchHttpException :: IO a -> IO (Either HttpException a) +catchHttpException action = + catch (Right <$> action) (pure . Left) + +data ServantRequest a where + ServantRequest :: Method -> Req -> WantedStatusCodes -> BaseUrl -> + ServantRequest (Int, ByteString, MediaType, [HTTP.Header], ServantResponse) + +deriving instance Show (ServantRequest a) +deriving instance Eq (ServantRequest a) + +instance Show1 ServantRequest where + show1 = show + +instance Hashable (ServantRequest a) where + hashWithSalt s (ServantRequest m r w h) = hashWithSalt s (m, r, w, h) + +instance StateKey ServantRequest where + data State ServantRequest = ServantRequestState Int Manager + +instance DataSourceName ServantRequest where + dataSourceName _ = "ServantRequest" + +instance DataSource () ServantRequest where + fetch (ServantRequestState numThreads manager) _ () requests = AsyncFetch $ \inner -> do + sem <- newQSem numThreads + asyncs <- mapM (handler sem) requests + inner + mapM_ wait asyncs + where + handler :: QSem -> BlockedFetch ServantRequest -> IO (Async ()) + handler sem (BlockedFetch (ServantRequest met req wantedStatus reqHost) rvar) = + async $ bracket_ (waitQSem sem) (signalQSem sem) $ do + e <- runEitherT $ performRequest_ manager met req wantedStatus reqHost + case e of + Left err -> putFailure rvar err + Right a -> putSuccess rvar a + return () + +initServantClientState :: Int -> IO (State ServantRequest) +initServantClientState numThreads = + ServantRequestState numThreads <$> newManager tlsManagerSettings diff --git a/src-ghc/Servant/Haxl/Client/Internal/Error.hs b/src-ghc/Servant/Haxl/Client/Internal/Error.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Servant/Haxl/Client/Internal/Error.hs @@ -0,0 +1,7 @@ +module Servant.Haxl.Client.Internal.Error + ( ServantConnectionError(..) + ) where + +import Network.HTTP.Client + +data ServantConnectionError = ServantConnectionError HttpException deriving Show diff --git a/src-ghcjs/Servant/Haxl/Client/Internal.hs b/src-ghcjs/Servant/Haxl/Client/Internal.hs new file mode 100644 --- /dev/null +++ b/src-ghcjs/Servant/Haxl/Client/Internal.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Servant.Haxl.Client.Internal + ( ServantResponse(..) + , ServantRequest(..) + , initServantClientState + ) where + +import Control.Concurrent.Async +import Control.Concurrent.QSem +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import qualified Data.ByteString.Char8 as BS +import Data.ByteString.Lazy hiding (elem, filter, map, + null, pack) +import qualified Data.CaseInsensitive as CI +import Data.Hashable +import qualified Data.JSString as JSString +import Data.JSString.Text +import Data.Maybe +import Data.String.Conversions +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding +import Haxl.Core hiding (Request, catch) +import qualified JavaScript.Web.XMLHttpRequest as XHR +import Network.HTTP.Media +import Network.HTTP.Types +import qualified Network.HTTP.Types.Header as HTTP +import Network.URI +import Servant.Haxl.Client.BaseUrl +import Servant.Haxl.Client.Internal.Error +import Servant.Haxl.Client.Types + +-- foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal + +data ServantResponse = ServantResponse (XHR.Response BS.ByteString) +instance Show ServantResponse where + show (ServantResponse xhrResponse) = show $ XHR.contents xhrResponse + +xhrMethodConversion :: Method -> XHR.Method +xhrMethodConversion method + | method == methodGet = XHR.GET + | method == methodPost = XHR.POST + | method == methodPut = XHR.PUT + | method == methodDelete = XHR.DELETE + | otherwise = error "No such XHR method" + +xhrRequestConversion :: XHR.Method -> Req -> BaseUrl -> XHR.Request +xhrRequestConversion method req (BaseUrl reqScheme reqHost reqPort) = + setData XHR.Request + { XHR.reqMethod = method + , XHR.reqURI = JSString.pack . show $ nullURI + { uriScheme = case reqScheme of + Http -> "http:" + Https -> "https:" + , uriAuthority = Just + URIAuth { uriUserInfo = "" + , uriRegName = reqHost + , uriPort = ":" ++ show reqPort + } + , uriPath = reqPath req + , uriQuery = BS.unpack $ renderQuery True $ queryTextToQuery (qs req) + } + , XHR.reqLogin = Nothing + , XHR.reqHeaders = (\(str, text) -> (JSString.pack str, textToJSString text)) + <$> headers req + , XHR.reqWithCredentials = False + , XHR.reqData = XHR.NoData -- will be set by setData + } + where + setData r = case reqBody req of + Nothing -> r + Just (bs, media) -> do + -- let (b, _, _) = fromByteString $ toStrict bs + r { XHR.reqHeaders = XHR.reqHeaders r ++ [("Content-Type", JSString.pack . show $ media)] + -- , XHR.reqData = XHR.TypedArrayData $ getUint8Array b + -- Temporary workaround until I can solve this: + -- http://stackoverflow.com/questions/35930517/sending-binary-data-with-ghcjs-xhr + , XHR.reqData = XHR.StringData $ textToJSString $ decodeUtf8 $ toStrict bs + } + +performRequest_ :: Method -> Req -> WantedStatusCodes -> BaseUrl + -> EitherT ServantError IO ( Int, ByteString, MediaType + , [HTTP.Header], ServantResponse) +performRequest_ method req wantedStatus reqHost = do + let xhrMethod = xhrMethodConversion method + let xhrReq = xhrRequestConversion xhrMethod req reqHost + eResponse <- liftIO $ catchXHRError $ XHR.xhrByteString xhrReq + case eResponse of + Left err -> + left $ ConnectionError $ ServantConnectionError err + Right response -> do + let body = fromStrict $ fromMaybe "" (XHR.contents response) + status_code = XHR.status response + hrds <- liftIO $ + breakHeaders . textFromJSString <$> XHR.getAllResponseHeaders response + ct <- case lookup "Content-Type" hrds of + Nothing -> pure $ "application"//"octet-stream" + Just t -> case parseAccept t of + Nothing -> left $ InvalidContentTypeHeader (cs t) body + Just t' -> pure t' + unless (wantedStatus `wants` status_code) $ + left $ FailureResponse (Status status_code "") ct body + return (status_code, body, ct, hrds, ServantResponse response) + where + wants AllCodes _ = True + wants (SelectCodes codes) status_code = status_code `elem` codes + +breakHeaders :: Text -> [HTTP.Header] +breakHeaders allHeaders = Text.splitOn "\r\n" allHeaders >>= breakHeader + where + breakHeader :: Text -> [HTTP.Header] + breakHeader txHeader = header + where + (txName, txDataWithColon) = Text.breakOn ": " txHeader + txData = Text.stripPrefix ": " txDataWithColon + ciName = CI.mk $ encodeUtf8 txName + bsData = encodeUtf8 <$> txData + header = maybe [] (\d -> [(ciName, d)]) bsData + +catchXHRError :: IO a -> IO (Either XHR.XHRError a) +catchXHRError action = catch (Right <$> action) (pure . Left) + +data ServantRequest a where + ServantRequest :: Method -> Req -> WantedStatusCodes -> BaseUrl -> + ServantRequest (Int, ByteString, MediaType, [HTTP.Header], ServantResponse) + +deriving instance Show (ServantRequest a) +deriving instance Eq (ServantRequest a) + +instance Show1 ServantRequest where + show1 = show + +instance Hashable (ServantRequest a) where + hashWithSalt s (ServantRequest m r w h) = hashWithSalt s (m, r, w, h) + +instance DataSourceName ServantRequest where + dataSourceName _ = "ServantRequest" + +instance StateKey ServantRequest where + data State ServantRequest = ServantRequestState Int + +instance DataSource () ServantRequest where + fetch (ServantRequestState numThreads) _ () requests = + AsyncFetch $ \inner -> do + sem <- newQSem numThreads + asyncs <- mapM (handler sem) requests + inner + mapM_ wait asyncs + where + handler :: QSem -> BlockedFetch ServantRequest -> IO (Async ()) + handler sem (BlockedFetch (ServantRequest met req wantedStatus reqHost) rvar) = + async $ bracket_ (waitQSem sem) (signalQSem sem) $ do + e <- runEitherT $ performRequest_ met req wantedStatus reqHost + case e of + Left err -> putFailure rvar err + Right a -> putSuccess rvar a + return () + +initServantClientState :: Int -> IO (State ServantRequest) +initServantClientState = return . ServantRequestState diff --git a/src-ghcjs/Servant/Haxl/Client/Internal/Error.hs b/src-ghcjs/Servant/Haxl/Client/Internal/Error.hs new file mode 100644 --- /dev/null +++ b/src-ghcjs/Servant/Haxl/Client/Internal/Error.hs @@ -0,0 +1,7 @@ +module Servant.Haxl.Client.Internal.Error + ( ServantConnectionError(..) + ) where + +import JavaScript.Web.XMLHttpRequest + +data ServantConnectionError = ServantConnectionError XHRError deriving Show diff --git a/src/Servant/Client/Haxl.hs b/src/Servant/Client/Haxl.hs deleted file mode 100644 --- a/src/Servant/Client/Haxl.hs +++ /dev/null @@ -1,622 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} --- | This module provides 'client' which can automatically generate --- querying functions for each endpoint just from the type representing your --- API. -module Servant.Client.Haxl - ( client - , initServantClientState - , HasClient(..) - , ServantError(..) - , module Servant.Common.BaseUrl.Haxl - ) where - -import Control.Monad -import Data.ByteString.Lazy (ByteString) -import Data.List -import Data.Proxy -import Data.String.Conversions -import Data.Text (unpack) -import GHC.TypeLits -import Haxl.Core (GenHaxl, State) -import Network.HTTP.Client hiding (Proxy) -import Network.HTTP.Client.TLS -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.Haxl -import Servant.Common.Req.Haxl - --- * Accessing APIs as a Client - --- | 'client' allows you to produce operations to query an API from a client. --- --- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getAllBooks :: EitherT String IO [Book] --- > postNewBook :: Book -> EitherT String IO Book --- > (getAllBooks :<|> postNewBook) = client myApi host --- > where host = BaseUrl Http "localhost" 8080 -client :: HasClient layout => Proxy layout -> BaseUrl -> Client layout -client p = clientWithRoute p defReq - -initServantClientState :: Int -> IO (State ServantRequest) -initServantClientState numThreads = - ServantRequestState numThreads <$> newManager tlsManagerSettings - --- | 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 -> 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. --- --- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getAllBooks :: EitherT String IO [Book] --- > postNewBook :: Book -> EitherT String IO Book --- > (getAllBooks :<|> postNewBook) = client myApi host --- > where host = BaseUrl Http "localhost" 8080 -instance (HasClient a, HasClient b) => HasClient (a :<|> b) where - type Client (a :<|> b) = Client a :<|> Client b - 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 --- an additional argument of the type specified by your 'Capture'. --- That function will take care of inserting a textual representation --- of this value at the right place in the request path. --- --- You can control how values for this type are turned into --- text by specifying a 'ToText' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBook :: Text -> EitherT String IO Book --- > getBook = client myApi host --- > where host = BaseUrl Http "localhost" 8080 --- > -- then you can just use "getBook" to query that endpoint -instance (KnownSymbol capture, ToText a, HasClient sublayout) - => HasClient (Capture capture a :> sublayout) where - - type Client (Capture capture a :> sublayout) = - a -> Client sublayout - - clientWithRoute Proxy req baseurl val = - clientWithRoute (Proxy :: Proxy sublayout) - (appendToPath p req) - baseurl - - where p = unpack (toText val) - --- | If you have a 'Delete' 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 {-# OVERLAPPABLE #-} - -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances - (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where - type Client (Delete cts' a) = GenHaxl () a - clientWithRoute Proxy req baseurl = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req (SelectCodes [200, 202]) baseurl - --- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content --- HTTP header. -instance {-# OVERLAPPING #-} - HasClient (Delete cts ()) where - type Client (Delete cts ()) = GenHaxl () () - clientWithRoute Proxy req baseurl = - void $ performRequestNoBody H.methodDelete req (SelectCodes [204]) baseurl - --- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance {-# OVERLAPPING #-} - -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances - ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) - ) => HasClient (Delete cts' (Headers ls a)) where - type Client (Delete cts' (Headers ls a)) = GenHaxl () (Headers ls a) - clientWithRoute Proxy req baseurl = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req (SelectCodes [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 {-# OVERLAPPABLE #-} - (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where - type Client (Get (ct ': cts) result) = GenHaxl () result - clientWithRoute Proxy req baseurl = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req (SelectCodes [200, 203]) baseurl - --- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content --- HTTP status. -instance {-# OVERLAPPING #-} - HasClient (Get (ct ': cts) ()) where - type Client (Get (ct ': cts) ()) = GenHaxl () () - clientWithRoute Proxy req = - performRequestNoBody H.methodGet req (SelectCodes [204]) - --- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance {-# OVERLAPPING #-} - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Get (ct ': cts) (Headers ls a)) where - type Client (Get (ct ': cts) (Headers ls a)) = GenHaxl () (Headers ls a) - clientWithRoute Proxy req baseurl = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req (SelectCodes [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', --- wrapped in Maybe. --- --- That function will take care of encoding this argument as Text --- in the request headers. --- --- All you need is for your type to have a 'ToText' instance. --- --- Example: --- --- > newtype Referer = Referer { referrer :: Text } --- > deriving (Eq, Show, Generic, FromText, ToText) --- > --- > -- GET /view-my-referer --- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > viewReferer :: Maybe Referer -> EitherT String IO Book --- > viewReferer = client myApi host --- > where host = BaseUrl Http "localhost" 8080 --- > -- then you can just use "viewRefer" to query that endpoint --- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments -instance (KnownSymbol sym, ToText a, HasClient sublayout) - => HasClient (Header sym a :> sublayout) where - - type Client (Header sym a :> sublayout) = - Maybe a -> Client sublayout - - clientWithRoute Proxy req baseurl mval = - clientWithRoute (Proxy :: Proxy sublayout) - (maybe req - (\value -> Servant.Common.Req.Haxl.addHeader hname value req) - mval - ) - baseurl - - where hname = symbolVal (Proxy :: Proxy sym) - --- | If you have a 'Post' 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 {-# OVERLAPPABLE #-} - (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where - type Client (Post (ct ': cts) a) = GenHaxl () a - clientWithRoute Proxy req baseurl = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req (SelectCodes [200, 201, 202]) baseurl - --- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content --- HTTP header. -instance {-# OVERLAPPING #-} - HasClient (Post (ct ': cts) ()) where - type Client (Post (ct ': cts) ()) = GenHaxl () () - clientWithRoute Proxy req baseurl = - void $ performRequestNoBody H.methodPost req (SelectCodes [204]) baseurl - --- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance {-# OVERLAPPING #-} - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Post (ct ': cts) (Headers ls a)) where - type Client (Post (ct ': cts) (Headers ls a)) = GenHaxl () (Headers ls a) - clientWithRoute Proxy req baseurl = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req (SelectCodes [200, 201, 202]) 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 {-# OVERLAPPABLE #-} - (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where - type Client (Put (ct ': cts) a) = GenHaxl () a - clientWithRoute Proxy req baseurl = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req (SelectCodes [200,201]) baseurl - --- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content --- HTTP header. -instance {-# OVERLAPPING #-} - HasClient (Put (ct ': cts) ()) where - type Client (Put (ct ': cts) ()) = GenHaxl () () - clientWithRoute Proxy req baseurl = - void $ performRequestNoBody H.methodPut req (SelectCodes [204]) baseurl - --- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance {-# OVERLAPPING #-} - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Put (ct ': cts) (Headers ls a)) where - type Client (Put (ct ': cts) (Headers ls a)) = GenHaxl () (Headers ls a) - clientWithRoute Proxy req baseurl = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req (SelectCodes [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 {-# OVERLAPPABLE #-} - (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where - type Client (Patch (ct ': cts) a) = GenHaxl () a - clientWithRoute Proxy req baseurl = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req (SelectCodes [200,201]) baseurl - --- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content --- HTTP header. -instance {-# OVERLAPPING #-} - HasClient (Patch (ct ': cts) ()) where - type Client (Patch (ct ': cts) ()) = GenHaxl () () - clientWithRoute Proxy req baseurl = - void $ performRequestNoBody H.methodPatch req (SelectCodes [204]) baseurl - --- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance {-# OVERLAPPING #-} - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Patch (ct ': cts) (Headers ls a)) where - type Client (Patch (ct ': cts) (Headers ls a)) = GenHaxl () (Headers ls a) - clientWithRoute Proxy req baseurl = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req (SelectCodes [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', --- enclosed in Maybe. --- --- If you give Nothing, nothing will be added to the query string. --- --- If you give a non-'Nothing' value, this function will take care --- of inserting a textual representation of this value in the query string. --- --- You can control how values for your type are turned into --- text by specifying a 'ToText' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooksBy :: Maybe Text -> EitherT String IO [Book] --- > getBooksBy = client myApi host --- > where host = BaseUrl Http "localhost" 8080 --- > -- 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 -instance (KnownSymbol sym, ToText a, HasClient sublayout) - => HasClient (QueryParam sym a :> sublayout) where - - type Client (QueryParam sym a :> sublayout) = - Maybe a -> Client sublayout - - -- if mparam = Nothing, we don't add it to the query string - 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) - mparamText = fmap toText mparam - --- | 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 --- by your 'QueryParams'. --- --- If you give an empty list, nothing will be added to the query string. --- --- Otherwise, this function will take care --- of inserting a textual representation of your values in the query string, --- under the same query string parameter name. --- --- You can control how values for your type are turned into --- text by specifying a 'ToText' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooksBy :: [Text] -> EitherT String IO [Book] --- > getBooksBy = client myApi host --- > where host = BaseUrl Http "localhost" 8080 --- > -- then you can just use "getBooksBy" to query that endpoint. --- > -- 'getBooksBy []' for all books --- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' --- > -- to get all books by Asimov and Heinlein -instance (KnownSymbol sym, ToText a, HasClient sublayout) - => HasClient (QueryParams sym a :> sublayout) where - - type Client (QueryParams sym a :> sublayout) = - [a] -> Client sublayout - - 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) - paramlist' = map (Just . toText) paramlist - --- | If you use a 'QueryFlag' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional 'Bool' argument. --- --- If you give 'False', nothing will be added to the query string. --- --- Otherwise, this function will insert a value-less query string --- parameter under the name associated to your 'QueryFlag'. --- --- Example: --- --- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooks :: Bool -> EitherT String IO [Book] --- > getBooks = client myApi host --- > where host = BaseUrl Http "localhost" 8080 --- > -- then you can just use "getBooks" to query that endpoint. --- > -- 'getBooksBy False' for all books --- > -- 'getBooksBy True' to only get _already published_ books -instance (KnownSymbol sym, HasClient sublayout) - => HasClient (QueryFlag sym :> sublayout) where - - type Client (QueryFlag sym :> sublayout) = - Bool -> Client sublayout - - 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) - --- | If you use a 'MatrixParam' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'MatrixParam', --- enclosed in Maybe. --- --- If you give Nothing, nothing will be added to the query string. --- --- If you give a non-'Nothing' value, this function will take care --- of inserting a textual representation of this value in the query string. --- --- You can control how values for your type are turned into --- text by specifying a 'ToText' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> MatrixParam "author" Text :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooksBy :: Maybe Text -> EitherT String IO [Book] --- > getBooksBy = client myApi host --- > where host = BaseUrl Http "localhost" 8080 --- > -- 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 -instance (KnownSymbol sym, ToText a, HasClient sublayout) - => HasClient (MatrixParam sym a :> sublayout) where - - type Client (MatrixParam sym a :> sublayout) = - Maybe a -> Client sublayout - - -- if mparam = Nothing, we don't add it to the query string - 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 - --- | If you use a 'MatrixParams' 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 by your --- 'MatrixParams'. --- --- If you give an empty list, nothing will be added to the query string. --- --- Otherwise, this function will take care of inserting a textual --- representation of your values in the path segment string, under the --- same matrix string parameter name. --- --- You can control how values for your type are turned into text by --- specifying a 'ToText' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> MatrixParams "authors" Text :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooksBy :: [Text] -> EitherT String IO [Book] --- > getBooksBy = client myApi host --- > where host = BaseUrl Http "localhost" 8080 --- > -- then you can just use "getBooksBy" to query that endpoint. --- > -- 'getBooksBy []' for all books --- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' --- > -- to get all books by Asimov and Heinlein -instance (KnownSymbol sym, ToText a, HasClient sublayout) - => HasClient (MatrixParams sym a :> sublayout) where - - type Client (MatrixParams sym a :> sublayout) = - [a] -> Client sublayout - - 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) - paramlist' = map (Just . toText) paramlist - --- | If you use a 'MatrixFlag' in one of your endpoints in your API, --- the corresponding querying function will automatically take an --- additional 'Bool' argument. --- --- If you give 'False', nothing will be added to the path segment. --- --- Otherwise, this function will insert a value-less matrix parameter --- under the name associated to your 'MatrixFlag'. --- --- Example: --- --- > type MyApi = "books" :> MatrixFlag "published" :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooks :: Bool -> EitherT String IO [Book] --- > getBooks = client myApi host --- > where host = BaseUrl Http "localhost" 8080 --- > -- then you can just use "getBooks" to query that endpoint. --- > -- 'getBooksBy False' for all books --- > -- 'getBooksBy True' to only get _already published_ books -instance (KnownSymbol sym, HasClient sublayout) - => HasClient (MatrixFlag sym :> sublayout) where - - type Client (MatrixFlag sym :> sublayout) = - Bool -> Client sublayout - - 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 full `Response`. -instance HasClient Raw where - type Client Raw = H.Method -> GenHaxl () (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) - - clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw - clientWithRoute Proxy req baseurl httpMethod = performRequest httpMethod req AllCodes baseurl - --- | If you use a 'ReqBody' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'ReqBody'. --- That function will take care of encoding this argument as JSON and --- of using it as the request body. --- --- All you need is for your type to have a 'ToJSON' instance. --- --- Example: --- --- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > addBook :: Book -> EitherT String IO Book --- > addBook = client myApi host --- > where host = BaseUrl Http "localhost" 8080 --- > -- then you can just use "addBook" to query that endpoint -instance (MimeRender ct a, HasClient sublayout) - => HasClient (ReqBody (ct ': cts) a :> sublayout) where - - type Client (ReqBody (ct ': cts) a :> sublayout) = - a -> Client sublayout - - 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) - - where p = symbolVal (Proxy :: Proxy path) diff --git a/src/Servant/Common/BaseUrl/Haxl.hs b/src/Servant/Common/BaseUrl/Haxl.hs deleted file mode 100644 --- a/src/Servant/Common/BaseUrl/Haxl.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ViewPatterns #-} -module Servant.Common.BaseUrl.Haxl where - -import Data.Hashable -import Data.List -import GHC.Generics -import Network.URI -import Safe -import Text.Read - --- | URI scheme to use -data Scheme = - Http -- ^ http:// - | Https -- ^ https:// - deriving (Show, Eq, Ord, Generic) - -instance Hashable Scheme where - hashWithSalt s Http = hashWithSalt s (0 :: Int) - hashWithSalt s Https = hashWithSalt s (1 :: Int) - --- | Simple data type to represent the target of HTTP requests --- for servant's automatically-generated clients. -data BaseUrl = BaseUrl - { baseUrlScheme :: Scheme -- ^ URI scheme to use - , baseUrlHost :: String -- ^ host (eg "haskell.org") - , baseUrlPort :: Int -- ^ port (eg 80) - } deriving (Show, Eq, Ord, Generic) - -instance Hashable BaseUrl where - hashWithSalt s (BaseUrl sc h p) = hashWithSalt s (sc, h, p) - -showBaseUrl :: BaseUrl -> String -showBaseUrl (BaseUrl urlscheme host port) = - schemeString ++ "//" ++ host ++ portString - where - schemeString = case urlscheme of - Http -> "http:" - Https -> "https:" - portString = case (urlscheme, port) of - (Http, 80) -> "" - (Https, 443) -> "" - _ -> ":" ++ show port - -parseBaseUrl :: String -> Either String BaseUrl -parseBaseUrl s = case parseURI (removeTrailingSlash s) of - -- This is a rather hacky implementation and should be replaced with something - -- implemented in attoparsec (which is already a dependency anyhow (via aeson)). - Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> - Right (BaseUrl Http host port) - Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") -> - Right (BaseUrl Http host 80) - Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> - Right (BaseUrl Https host port) - Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") -> - Right (BaseUrl Https host 443) - _ -> if "://" `isInfixOf` s - then Left ("invalid base url: " ++ s) - else parseBaseUrl ("http://" ++ s) - where - removeTrailingSlash str = case lastMay str of - Just '/' -> init str - _ -> str diff --git a/src/Servant/Common/Req/Haxl.hs b/src/Servant/Common/Req/Haxl.hs deleted file mode 100644 --- a/src/Servant/Common/Req/Haxl.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -module Servant.Common.Req.Haxl where - -import Control.Concurrent.Async -import Control.Concurrent.QSem -import Control.Exception -import Control.Monad -import Control.Monad.Catch (MonadThrow, throwM) -import Control.Monad.IO.Class -import Control.Monad.Trans.Either -import Data.ByteString.Lazy hiding (elem, filter, map, null, - pack) -import Data.Hashable -import Data.Proxy -import Data.String -import Data.String.Conversions -import Data.Text (Text) -import Data.Text.Encoding -import GHC.Generics -import Haxl.Core hiding (Request, catch) -import Network.HTTP.Client hiding (Proxy) -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.Haxl -import Servant.Common.Text - -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) - -instance Exception ServantError where - -data Req = Req - { reqPath :: String - , qs :: QueryText - , reqBody :: Maybe (ByteString, MediaType) - , reqAccept :: [MediaType] - , headers :: [(String, Text)] - } deriving (Show, Eq, Ord, Generic) - -instance Hashable Req where - hashWithSalt s (Req p q b a h) = hashWithSalt s (p, q, bHash, aHash, h) - where - hashMediaType m = hashWithSalt s (show m) - bHash = fmap (fmap hashMediaType) b - aHash = fmap hashMediaType a - -data WantedStatusCodes = AllCodes | SelectCodes [Int] - deriving (Show, Eq, Ord, Generic) - -instance Hashable WantedStatusCodes where - hashWithSalt s AllCodes = hashWithSalt s (0::Int) - hashWithSalt s (SelectCodes codes) = hashWithSalt s (1::Int, codes) - -defReq :: Req -defReq = Req "" [] Nothing [] [] - -appendToPath :: String -> Req -> Req -appendToPath p req = - req { reqPath = reqPath req ++ "/" ++ p } - -appendToMatrixParams :: String - -> Maybe String - -> Req - -> Req -appendToMatrixParams pname pvalue req = - req { reqPath = reqPath req ++ ";" ++ pname ++ maybe "" ("=" ++) pvalue } - -appendToQueryString :: Text -- ^ param name - -> Maybe Text -- ^ param value - -> Req - -> Req -appendToQueryString pname pvalue req = - req { qs = qs req ++ [(pname, pvalue)] - } - -addHeader :: ToText a => String -> a -> Req -> Req -addHeader name val req = req { headers = headers req - ++ [(name, toText val)] - } - -setRQBody :: ByteString -> MediaType -> Req -> Req -setRQBody b t req = req { reqBody = Just (b, t) } - -reqToRequest :: MonadThrow m => Req -> BaseUrl -> m Request -reqToRequest req (BaseUrl reqScheme reqHost reqPort) = - (setheaders . setAccept . setrqb . setQS) <$> parseUrl url - - where url = show $ nullURI { uriScheme = case reqScheme of - Http -> "http:" - Https -> "https:" - , uriAuthority = Just - URIAuth { uriUserInfo = "" - , uriRegName = reqHost - , uriPort = ":" ++ show reqPort - } - , uriPath = reqPath 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 = 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) - - --- * performing requests - -displayHttpRequest :: Method -> String -displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" - - -performRequest_ :: Manager -> Method -> Req -> WantedStatusCodes -> BaseUrl - -> EitherT ServantError IO ( Int, ByteString, MediaType - , [HTTP.Header], Response ByteString) -performRequest_ manager reqMethod req wantedStatus reqHost = do - partialRequest <- liftIO $ reqToRequest req reqHost - - let request = partialRequest { Client.method = reqMethod - , checkStatus = \ _status _headers _cookies -> Nothing - } - - eResponse <- liftIO $ catchHttpException $ Client.httpLbs request manager - case eResponse of - Left err -> - left $ ConnectionError err - - Right response -> do - let status = Client.responseStatus response - 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 (wantedStatus `wants` status_code) $ - left $ FailureResponse status ct body - return (status_code, body, ct, hrds, response) - where - wants AllCodes _ = True - wants (SelectCodes codes) status_code = status_code `elem` codes - -catchHttpException :: IO a -> IO (Either HttpException a) -catchHttpException action = - catch (Right <$> action) (pure . Left) - -data ServantRequest a where - ServantRequest :: Method -> Req -> WantedStatusCodes -> BaseUrl -> - ServantRequest (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) - -deriving instance Show (ServantRequest a) -deriving instance Eq (ServantRequest a) - -instance Show1 ServantRequest where - show1 = show - -instance Hashable (ServantRequest a) where - hashWithSalt s (ServantRequest m r w h) = hashWithSalt s (m, r, w, h) - -instance StateKey ServantRequest where - data State ServantRequest = ServantRequestState Int Manager - -instance DataSourceName ServantRequest where - dataSourceName _ = "ServantRequest" - -instance DataSource () ServantRequest where - fetch (ServantRequestState numThreads manager) _ () requests = AsyncFetch $ \inner -> do - sem <- newQSem numThreads - asyncs <- mapM (handler sem) requests - inner - mapM_ wait asyncs - where - handler :: QSem -> BlockedFetch ServantRequest -> IO (Async ()) - handler sem (BlockedFetch ((ServantRequest met req wantedStatus reqHost) :: ServantRequest a) rvar) = - async $ bracket_ (waitQSem sem) (signalQSem sem) $ do - e <- runEitherT $ performRequest_ manager met req wantedStatus reqHost - case e of - Left err -> putFailure rvar err - Right a -> putSuccess rvar a - return () - -performRequest :: Method -> Req -> WantedStatusCodes -> BaseUrl -> GenHaxl () (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) -performRequest m r w h = dataFetch $ ServantRequest m r w h - -performRequestCT :: MimeUnrender ct result => - Proxy ct -> Method -> Req -> WantedStatusCodes -> BaseUrl -> GenHaxl () ([HTTP.Header], result) -performRequestCT ct reqMethod req wantedStatus reqHost = do - let acceptCT = contentType ct - (_status, respBody, respCT, hrds, _response) <- - performRequest reqMethod (req { reqAccept = [acceptCT] }) wantedStatus reqHost - unless (matches respCT acceptCT) $ throwM $ UnsupportedContentType respCT respBody - case mimeUnrender ct respBody of - Left err -> throwM $ DecodeFailure err respCT respBody - Right val -> return (hrds, val) - -performRequestNoBody :: Method -> Req -> WantedStatusCodes -> BaseUrl -> GenHaxl () () -performRequestNoBody reqMethod req wantedStatus reqHost = do - _ <- performRequest reqMethod req wantedStatus reqHost - return () diff --git a/src/Servant/Haxl/Client.hs b/src/Servant/Haxl/Client.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Haxl/Client.hs @@ -0,0 +1,619 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | This module provides 'client' which can automatically generate +-- querying functions for each endpoint just from the type representing your +-- API. +module Servant.Haxl.Client + ( client + , initServantClientState + , HasClient(..) + , ServantError(..) + , ServantResponse + , ServantConnectionError + , module Servant.Haxl.Client.BaseUrl + ) where + +import Control.Monad +import Data.ByteString.Lazy (ByteString) +import Data.List +import Data.Proxy +import Data.String.Conversions +import Data.Text (unpack) +import GHC.TypeLits +import Haxl.Core (GenHaxl) +import Network.HTTP.Media +import qualified Network.HTTP.Types as H +import qualified Network.HTTP.Types.Header as HTTP +import Servant.API +import Servant.Haxl.Client.Types +import Servant.Haxl.Client.Req +import Servant.Haxl.Client.BaseUrl + +-- * Accessing APIs as a Client + +-- | 'client' allows you to produce operations to query an API from a client. +-- +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: EitherT String IO [Book] +-- > postNewBook :: Book -> EitherT String IO Book +-- > (getAllBooks :<|> postNewBook) = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +client :: HasClient layout => Proxy layout -> BaseUrl -> 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 -> 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. +-- +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: EitherT String IO [Book] +-- > postNewBook :: Book -> EitherT String IO Book +-- > (getAllBooks :<|> postNewBook) = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +instance (HasClient a, HasClient b) => HasClient (a :<|> b) where + type Client (a :<|> b) = Client a :<|> Client b + 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 +-- an additional argument of the type specified by your 'Capture'. +-- That function will take care of inserting a textual representation +-- of this value at the right place in the request path. +-- +-- You can control how values for this type are turned into +-- text by specifying a 'ToText' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBook :: Text -> EitherT String IO Book +-- > getBook = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- then you can just use "getBook" to query that endpoint +instance (KnownSymbol capture, ToText a, HasClient sublayout) + => HasClient (Capture capture a :> sublayout) where + + type Client (Capture capture a :> sublayout) = + a -> Client sublayout + + clientWithRoute Proxy req baseurl val = + clientWithRoute (Proxy :: Proxy sublayout) + (appendToPath p req) + baseurl + + where p = unpack (toText val) + +-- | If you have a 'Delete' 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 {-# OVERLAPPABLE #-} + -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances + (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where + type Client (Delete cts' a) = GenHaxl () a + clientWithRoute Proxy req baseurl = + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req (SelectCodes [200, 202]) baseurl + +-- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content +-- HTTP header. +instance {-# OVERLAPPING #-} + HasClient (Delete cts ()) where + type Client (Delete cts ()) = GenHaxl () () + clientWithRoute Proxy req baseurl = + void $ performRequestNoBody H.methodDelete req (SelectCodes [204]) baseurl + +-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance {-# OVERLAPPING #-} + -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances + ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) + ) => HasClient (Delete cts' (Headers ls a)) where + type Client (Delete cts' (Headers ls a)) = GenHaxl () (Headers ls a) + clientWithRoute Proxy req baseurl = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req (SelectCodes [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 {-# OVERLAPPABLE #-} + (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where + type Client (Get (ct ': cts) result) = GenHaxl () result + clientWithRoute Proxy req baseurl = + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req (SelectCodes [200, 203]) baseurl + +-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content +-- HTTP status. +instance {-# OVERLAPPING #-} + HasClient (Get (ct ': cts) ()) where + type Client (Get (ct ': cts) ()) = GenHaxl () () + clientWithRoute Proxy req = + performRequestNoBody H.methodGet req (SelectCodes [204]) + +-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance {-# OVERLAPPING #-} + ( MimeUnrender ct a, BuildHeadersTo ls + ) => HasClient (Get (ct ': cts) (Headers ls a)) where + type Client (Get (ct ': cts) (Headers ls a)) = GenHaxl () (Headers ls a) + clientWithRoute Proxy req baseurl = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req (SelectCodes [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', +-- wrapped in Maybe. +-- +-- That function will take care of encoding this argument as Text +-- in the request headers. +-- +-- All you need is for your type to have a 'ToText' instance. +-- +-- Example: +-- +-- > newtype Referer = Referer { referrer :: Text } +-- > deriving (Eq, Show, Generic, FromText, ToText) +-- > +-- > -- GET /view-my-referer +-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > viewReferer :: Maybe Referer -> EitherT String IO Book +-- > viewReferer = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- then you can just use "viewRefer" to query that endpoint +-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments +instance (KnownSymbol sym, ToText a, HasClient sublayout) + => HasClient (Header sym a :> sublayout) where + + type Client (Header sym a :> sublayout) = + Maybe a -> Client sublayout + + clientWithRoute Proxy req baseurl mval = + clientWithRoute (Proxy :: Proxy sublayout) + (maybe req + (\value -> Servant.Haxl.Client.Req.addHeader hname value req) + mval + ) + baseurl + + where hname = symbolVal (Proxy :: Proxy sym) + +-- | If you have a 'Post' 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 {-# OVERLAPPABLE #-} + (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where + type Client (Post (ct ': cts) a) = GenHaxl () a + clientWithRoute Proxy req baseurl = + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req (SelectCodes [200, 201, 202]) baseurl + +-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content +-- HTTP header. +instance {-# OVERLAPPING #-} + HasClient (Post (ct ': cts) ()) where + type Client (Post (ct ': cts) ()) = GenHaxl () () + clientWithRoute Proxy req baseurl = + void $ performRequestNoBody H.methodPost req (SelectCodes [204]) baseurl + +-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance {-# OVERLAPPING #-} + ( MimeUnrender ct a, BuildHeadersTo ls + ) => HasClient (Post (ct ': cts) (Headers ls a)) where + type Client (Post (ct ': cts) (Headers ls a)) = GenHaxl () (Headers ls a) + clientWithRoute Proxy req baseurl = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req (SelectCodes [200, 201, 202]) 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 {-# OVERLAPPABLE #-} + (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where + type Client (Put (ct ': cts) a) = GenHaxl () a + clientWithRoute Proxy req baseurl = + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req (SelectCodes [200,201]) baseurl + +-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content +-- HTTP header. +instance {-# OVERLAPPING #-} + HasClient (Put (ct ': cts) ()) where + type Client (Put (ct ': cts) ()) = GenHaxl () () + clientWithRoute Proxy req baseurl = + void $ performRequestNoBody H.methodPut req (SelectCodes [204]) baseurl + +-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance {-# OVERLAPPING #-} + ( MimeUnrender ct a, BuildHeadersTo ls + ) => HasClient (Put (ct ': cts) (Headers ls a)) where + type Client (Put (ct ': cts) (Headers ls a)) = GenHaxl () (Headers ls a) + clientWithRoute Proxy req baseurl = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req (SelectCodes [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 {-# OVERLAPPABLE #-} + (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where + type Client (Patch (ct ': cts) a) = GenHaxl () a + clientWithRoute Proxy req baseurl = + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req (SelectCodes [200,201]) baseurl + +-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content +-- HTTP header. +instance {-# OVERLAPPING #-} + HasClient (Patch (ct ': cts) ()) where + type Client (Patch (ct ': cts) ()) = GenHaxl () () + clientWithRoute Proxy req baseurl = + void $ performRequestNoBody H.methodPatch req (SelectCodes [204]) baseurl + +-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance {-# OVERLAPPING #-} + ( MimeUnrender ct a, BuildHeadersTo ls + ) => HasClient (Patch (ct ': cts) (Headers ls a)) where + type Client (Patch (ct ': cts) (Headers ls a)) = GenHaxl () (Headers ls a) + clientWithRoute Proxy req baseurl = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req (SelectCodes [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', +-- enclosed in Maybe. +-- +-- If you give Nothing, nothing will be added to the query string. +-- +-- If you give a non-'Nothing' value, this function will take care +-- of inserting a textual representation of this value in the query string. +-- +-- You can control how values for your type are turned into +-- text by specifying a 'ToText' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: Maybe Text -> EitherT String IO [Book] +-- > getBooksBy = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- 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 +instance (KnownSymbol sym, ToText a, HasClient sublayout) + => HasClient (QueryParam sym a :> sublayout) where + + type Client (QueryParam sym a :> sublayout) = + Maybe a -> Client sublayout + + -- if mparam = Nothing, we don't add it to the query string + 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) + mparamText = fmap toText mparam + +-- | 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 +-- by your 'QueryParams'. +-- +-- If you give an empty list, nothing will be added to the query string. +-- +-- Otherwise, this function will take care +-- of inserting a textual representation of your values in the query string, +-- under the same query string parameter name. +-- +-- You can control how values for your type are turned into +-- text by specifying a 'ToText' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: [Text] -> EitherT String IO [Book] +-- > getBooksBy = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooksBy []' for all books +-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' +-- > -- to get all books by Asimov and Heinlein +instance (KnownSymbol sym, ToText a, HasClient sublayout) + => HasClient (QueryParams sym a :> sublayout) where + + type Client (QueryParams sym a :> sublayout) = + [a] -> Client sublayout + + 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) + paramlist' = map (Just . toText) paramlist + +-- | If you use a 'QueryFlag' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional 'Bool' argument. +-- +-- If you give 'False', nothing will be added to the query string. +-- +-- Otherwise, this function will insert a value-less query string +-- parameter under the name associated to your 'QueryFlag'. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooks :: Bool -> EitherT String IO [Book] +-- > getBooks = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- then you can just use "getBooks" to query that endpoint. +-- > -- 'getBooksBy False' for all books +-- > -- 'getBooksBy True' to only get _already published_ books +instance (KnownSymbol sym, HasClient sublayout) + => HasClient (QueryFlag sym :> sublayout) where + + type Client (QueryFlag sym :> sublayout) = + Bool -> Client sublayout + + 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) + +-- | If you use a 'MatrixParam' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'MatrixParam', +-- enclosed in Maybe. +-- +-- If you give Nothing, nothing will be added to the query string. +-- +-- If you give a non-'Nothing' value, this function will take care +-- of inserting a textual representation of this value in the query string. +-- +-- You can control how values for your type are turned into +-- text by specifying a 'ToText' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> MatrixParam "author" Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: Maybe Text -> EitherT String IO [Book] +-- > getBooksBy = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- 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 +instance (KnownSymbol sym, ToText a, HasClient sublayout) + => HasClient (MatrixParam sym a :> sublayout) where + + type Client (MatrixParam sym a :> sublayout) = + Maybe a -> Client sublayout + + -- if mparam = Nothing, we don't add it to the query string + 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 + +-- | If you use a 'MatrixParams' 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 by your +-- 'MatrixParams'. +-- +-- If you give an empty list, nothing will be added to the query string. +-- +-- Otherwise, this function will take care of inserting a textual +-- representation of your values in the path segment string, under the +-- same matrix string parameter name. +-- +-- You can control how values for your type are turned into text by +-- specifying a 'ToText' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> MatrixParams "authors" Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: [Text] -> EitherT String IO [Book] +-- > getBooksBy = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooksBy []' for all books +-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' +-- > -- to get all books by Asimov and Heinlein +instance (KnownSymbol sym, ToText a, HasClient sublayout) + => HasClient (MatrixParams sym a :> sublayout) where + + type Client (MatrixParams sym a :> sublayout) = + [a] -> Client sublayout + + 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) + paramlist' = map (Just . toText) paramlist + +-- | If you use a 'MatrixFlag' in one of your endpoints in your API, +-- the corresponding querying function will automatically take an +-- additional 'Bool' argument. +-- +-- If you give 'False', nothing will be added to the path segment. +-- +-- Otherwise, this function will insert a value-less matrix parameter +-- under the name associated to your 'MatrixFlag'. +-- +-- Example: +-- +-- > type MyApi = "books" :> MatrixFlag "published" :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooks :: Bool -> EitherT String IO [Book] +-- > getBooks = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- then you can just use "getBooks" to query that endpoint. +-- > -- 'getBooksBy False' for all books +-- > -- 'getBooksBy True' to only get _already published_ books +instance (KnownSymbol sym, HasClient sublayout) + => HasClient (MatrixFlag sym :> sublayout) where + + type Client (MatrixFlag sym :> sublayout) = + Bool -> Client sublayout + + 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 full `Response`. +instance HasClient Raw where + type Client Raw = H.Method -> GenHaxl () (Int, ByteString, MediaType, [HTTP.Header], ServantResponse) + + clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw + clientWithRoute Proxy req baseurl httpMethod = performRequest httpMethod req AllCodes baseurl + +-- | If you use a 'ReqBody' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'ReqBody'. +-- That function will take care of encoding this argument as JSON and +-- of using it as the request body. +-- +-- All you need is for your type to have a 'ToJSON' instance. +-- +-- Example: +-- +-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > addBook :: Book -> EitherT String IO Book +-- > addBook = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- then you can just use "addBook" to query that endpoint +instance (MimeRender ct a, HasClient sublayout) + => HasClient (ReqBody (ct ': cts) a :> sublayout) where + + type Client (ReqBody (ct ': cts) a :> sublayout) = + a -> Client sublayout + + 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) + + where p = symbolVal (Proxy :: Proxy path) diff --git a/src/Servant/Haxl/Client/BaseUrl.hs b/src/Servant/Haxl/Client/BaseUrl.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Haxl/Client/BaseUrl.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE ViewPatterns #-} +module Servant.Haxl.Client.BaseUrl + ( Scheme(..) + , BaseUrl(..) + , showBaseUrl + , parseBaseUrl + ) where + +import Data.List +import Network.URI +import Safe +import Servant.Haxl.Client.Types +import Text.Read + +showBaseUrl :: BaseUrl -> String +showBaseUrl (BaseUrl urlscheme host port) = + schemeString ++ "//" ++ host ++ portString + where + schemeString = case urlscheme of + Http -> "http:" + Https -> "https:" + portString = case (urlscheme, port) of + (Http, 80) -> "" + (Https, 443) -> "" + _ -> ":" ++ show port + +parseBaseUrl :: String -> Either String BaseUrl +parseBaseUrl s = case parseURI (removeTrailingSlash s) of + -- This is a rather hacky implementation and should be replaced with something + -- implemented in attoparsec (which is already a dependency anyhow (via aeson)). + Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> + Right (BaseUrl Http host port) + Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") -> + Right (BaseUrl Http host 80) + Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> + Right (BaseUrl Https host port) + Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") -> + Right (BaseUrl Https host 443) + _ -> if "://" `isInfixOf` s + then Left ("invalid base url: " ++ s) + else parseBaseUrl ("http://" ++ s) + where + removeTrailingSlash str = case lastMay str of + Just '/' -> init str + _ -> str diff --git a/src/Servant/Haxl/Client/Req.hs b/src/Servant/Haxl/Client/Req.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Haxl/Client/Req.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Servant.Haxl.Client.Req + ( Req + , ServantError + , ServantResponse + , ServantConnectionError + , defReq + , appendToPath + , appendToMatrixParams + , appendToQueryString + , addHeader + , setRQBody + , displayHttpRequest + , initServantClientState + , performRequest + , performRequestCT + , performRequestNoBody + ) where + +import Control.Monad +import Control.Monad.Catch +import Data.ByteString.Lazy hiding (elem, filter, map, + null, pack) +import Data.Proxy +import Data.String.Conversions +import Data.Text (Text) +import Haxl.Core hiding (Request, catch) +import Network.HTTP.Media +import Network.HTTP.Types +import qualified Network.HTTP.Types.Header as HTTP +import Servant.API.ContentTypes +import Servant.Common.Text +import Servant.Haxl.Client.BaseUrl +import Servant.Haxl.Client.Internal +import Servant.Haxl.Client.Internal.Error +import Servant.Haxl.Client.Types + +defReq :: Req +defReq = Req "" [] Nothing [] [] + +appendToPath :: String -> Req -> Req +appendToPath p req = + req { reqPath = reqPath req ++ "/" ++ p } + +appendToMatrixParams :: String + -> Maybe String + -> Req + -> Req +appendToMatrixParams pname pvalue req = + req { reqPath = reqPath req ++ ";" ++ pname ++ maybe "" ("=" ++) pvalue } + +appendToQueryString :: Text -- ^ param name + -> Maybe Text -- ^ param value + -> Req + -> Req +appendToQueryString pname pvalue req = + req { qs = qs req ++ [(pname, pvalue)] + } + +addHeader :: ToText a => String -> a -> Req -> Req +addHeader name val req = req { headers = headers req + ++ [(name, toText val)] + } + +setRQBody :: ByteString -> MediaType -> Req -> Req +setRQBody b t req = req { reqBody = Just (b, t) } + +-- * performing requests + +displayHttpRequest :: Method -> String +displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" + +performRequest :: Method -> Req -> WantedStatusCodes -> BaseUrl -> GenHaxl () (Int, ByteString, MediaType, [HTTP.Header], ServantResponse) +performRequest m r w h = dataFetch $ ServantRequest m r w h + +performRequestCT :: MimeUnrender ct result => + Proxy ct -> Method -> Req -> WantedStatusCodes -> BaseUrl -> GenHaxl () ([HTTP.Header], result) +performRequestCT ct reqMethod req wantedStatus reqHost = do + let acceptCT = contentType ct + (_status, respBody, respCT, hrds, _response) <- + performRequest reqMethod (req { reqAccept = [acceptCT] }) wantedStatus reqHost + unless (matches respCT acceptCT) $ throwM $ UnsupportedContentType respCT respBody + case mimeUnrender ct respBody of + Left err -> throwM $ DecodeFailure err respCT respBody + Right val -> return (hrds, val) + +performRequestNoBody :: Method -> Req -> WantedStatusCodes -> BaseUrl -> GenHaxl () () +performRequestNoBody reqMethod req wantedStatus reqHost = do + _ <- performRequest reqMethod req wantedStatus reqHost + return () diff --git a/src/Servant/Haxl/Client/Types.hs b/src/Servant/Haxl/Client/Types.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Haxl/Client/Types.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Servant.Haxl.Client.Types + ( ServantError(..) + , ServantConnectionError + , Req(..) + , WantedStatusCodes(..) + , Scheme(..) + , BaseUrl(..) + ) where + +import Control.Exception +import Data.ByteString.Lazy +import Data.Hashable +import Data.Text +import GHC.Generics +import Network.HTTP.Media +import Network.HTTP.Types +import Servant.Haxl.Client.Internal.Error + +data ServantError + = FailureResponse + { responseStatus :: Status + , responseContentType :: MediaType + , responseBody :: ByteString + } + | DecodeFailure + { decodeError :: String + , responseContentType :: MediaType + , responseBody :: ByteString + } + | UnsupportedContentType + { responseContentType :: MediaType + , responseBody :: ByteString + } + | ConnectionError + { connectionError :: ServantConnectionError + } + | InvalidContentTypeHeader + { responseContentTypeHeader :: ByteString + , responseBody :: ByteString + } + deriving (Show) + +instance Exception ServantError where + +data Req = Req + { reqPath :: String + , qs :: QueryText + , reqBody :: Maybe (ByteString, MediaType) + , reqAccept :: [MediaType] + , headers :: [(String, Text)] + } deriving (Show, Eq, Ord, Generic) + +instance Hashable Req where + hashWithSalt s (Req p q b a h) = hashWithSalt s (p, q, bHash, aHash, h) + where + hashMediaType m = hashWithSalt s (show m) + bHash = fmap (fmap hashMediaType) b + aHash = fmap hashMediaType a + +data WantedStatusCodes = AllCodes | SelectCodes [Int] + deriving (Show, Eq, Ord, Generic) + +instance Hashable WantedStatusCodes where + hashWithSalt s AllCodes = hashWithSalt s (0::Int) + hashWithSalt s (SelectCodes codes) = hashWithSalt s (1::Int, codes) + +-- | URI scheme to use +data Scheme = + Http -- ^ http:// + | Https -- ^ https:// + deriving (Show, Eq, Ord, Generic) + +instance Hashable Scheme where + hashWithSalt s Http = hashWithSalt s (0 :: Int) + hashWithSalt s Https = hashWithSalt s (1 :: Int) + +-- | Simple data type to represent the target of HTTP requests +-- for servant's automatically-generated clients. +data BaseUrl = BaseUrl + { baseUrlScheme :: Scheme -- ^ URI scheme to use + , baseUrlHost :: String -- ^ host (eg "haskell.org") + , baseUrlPort :: Int -- ^ port (eg 80) + } deriving (Show, Eq, Ord, Generic) + +instance Hashable BaseUrl where + hashWithSalt s (BaseUrl sc h p) = hashWithSalt s (sc, h, p) diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -12,25 +12,25 @@ module Servant.ClientSpec where -import qualified Control.Arrow as Arrow +import qualified Control.Arrow as Arrow import Control.Concurrent import Control.Exception import Control.Monad.Trans.Either import Data.Aeson -import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy (ByteString) import Data.Char -import Data.Foldable (forM_) +import Data.Foldable (forM_) import Data.Monoid import Data.Proxy -import qualified Data.Text as T +import qualified Data.Text as T import GHC.Generics -import Haxl.Core hiding (try) -import qualified Network.HTTP.Client as C +import Haxl.Core hiding (try) +import qualified Network.HTTP.Client as C import Network.HTTP.Media -import Network.HTTP.Types hiding (Header) -import qualified Network.HTTP.Types as HTTP +import Network.HTTP.Types hiding (Header) +import qualified Network.HTTP.Types as HTTP import Network.Socket -import Network.Wai hiding (Response) +import Network.Wai hiding (Response) import Network.Wai.Handler.Warp import Test.Hspec import Test.Hspec.QuickCheck @@ -38,7 +38,9 @@ import Test.QuickCheck import Servant.API -import Servant.Client.Haxl +import Servant.Haxl.Client +import Servant.Haxl.Client.Internal +import Servant.Haxl.Client.Internal.Error import Servant.Server -- * test data types @@ -67,6 +69,7 @@ return $ Person (T.unpack n) (read $ T.unpack a) deriving instance Eq ServantError +deriving instance Eq ServantConnectionError instance Eq C.HttpException where a == b = show a == show b @@ -167,8 +170,8 @@ getMatrixParam :: Maybe String -> GenHaxl () Person getMatrixParams :: [String] -> GenHaxl () [Person] getMatrixFlag :: Bool -> GenHaxl () Bool - getRawSuccess :: Method -> GenHaxl () (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString) - getRawFailure :: Method -> GenHaxl () (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString) + getRawSuccess :: Method -> GenHaxl () (Int, ByteString, MediaType, [HTTP.Header], ServantResponse) + getRawFailure :: Method -> GenHaxl () (Int, ByteString, MediaType, [HTTP.Header], ServantResponse) getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> GenHaxl () (String, Maybe Int, Bool, [(String, [Rational])]) getRespHeaders :: GenHaxl () (Headers TestHeaders Bool) getDeleteContentType :: GenHaxl () () @@ -241,7 +244,7 @@ res <- testHaxl (getRawSuccess methodGet) case res of Left e -> assertFailure $ show e - Right (code, body, ct, _, response) -> do + Right (code, body, ct, _, (ServantResponse response)) -> do (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") C.responseBody response `shouldBe` body C.responseStatus response `shouldBe` ok200 @@ -250,7 +253,7 @@ res <- testHaxl (getRawFailure methodGet) case res of Left e -> assertFailure $ show e - Right (code, body, ct, _, response) -> do + Right (code, body, ct, _, (ServantResponse response)) -> do (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream") C.responseBody response `shouldBe` body C.responseStatus response `shouldBe` badRequest400 @@ -319,7 +322,7 @@ it "reports ConnectionError" $ do Left res <- testHaxl getGetWrongHost case res of - ConnectionError (C.FailedConnectionException2 "127.0.0.1" 19872 False _) -> return () + ConnectionError (ServantConnectionError (C.FailedConnectionException2 "127.0.0.1" 19872 False _)) -> return () _ -> fail $ "expected ConnectionError, but got " <> show res it "reports UnsupportedContentType" $ do diff --git a/test/Servant/Common/BaseUrlSpec.hs b/test/Servant/Common/BaseUrlSpec.hs --- a/test/Servant/Common/BaseUrlSpec.hs +++ b/test/Servant/Common/BaseUrlSpec.hs @@ -6,7 +6,7 @@ import Test.Hspec import Test.QuickCheck -import Servant.Common.BaseUrl.Haxl +import Servant.Haxl.Client.BaseUrl spec :: Spec spec = do