servant-haxl-client 0.1.0.0 → 0.2.0.0

raw patch · 15 files changed

+1230/−952 lines, 15 filesdep +case-insensitivedep +ghcjs-basePVP ok

version bump matches the API change (PVP)

Dependencies added: case-insensitive, ghcjs-base

API changes (from Hackage documentation)

Files

• LICENSE +3/−2
• servant-haxl-client.cabal +30/−8
• src-ghc/Servant/Haxl/Client/Internal.hs +145/−0
• src-ghc/Servant/Haxl/Client/Internal/Error.hs +7/−0
• src-ghcjs/Servant/Haxl/Client/Internal.hs +172/−0
• src-ghcjs/Servant/Haxl/Client/Internal/Error.hs +7/−0
• src/Servant/Client/Haxl.hs +0/−622
• src/Servant/Common/BaseUrl/Haxl.hs +0/−63
• src/Servant/Common/Req/Haxl.hs +0/−241
• src/Servant/Haxl/Client.hs +619/−0
• src/Servant/Haxl/Client/BaseUrl.hs +45/−0
• src/Servant/Haxl/Client/Req.hs +95/−0
• src/Servant/Haxl/Client/Types.hs +88/−0
• test/Servant/ClientSpec.hs +18/−15
• test/Servant/Common/BaseUrlSpec.hs +1/−1

@@ -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. 

@@ -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

@@ -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

@@ -0,0 +1,7 @@+module Servant.Haxl.Client.Internal.Error+  ( ServantConnectionError(..)+  ) where++import           Network.HTTP.Client++data ServantConnectionError = ServantConnectionError HttpException deriving Show

@@ -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

@@ -0,0 +1,7 @@+module Servant.Haxl.Client.Internal.Error+  ( ServantConnectionError(..)+  ) where++import           JavaScript.Web.XMLHttpRequest++data ServantConnectionError = ServantConnectionError XHRError deriving Show

@@ -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)

@@ -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

@@ -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 ()

@@ -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)

@@ -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

@@ -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 ()

@@ -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)

@@ -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

@@ -6,7 +6,7 @@ import           Test.Hspec import           Test.QuickCheck -import           Servant.Common.BaseUrl.Haxl+import           Servant.Haxl.Client.BaseUrl  spec :: Spec spec = do