Compiling HttpClient

servant-client-core/src/Servant/Client/Core.hs

@@ -24,6 +24,10 @@ module Servant.Client.Core
   , mkAuthenticateReq
   , ServantError(..)
   , EmptyClient(..)
+  , RunClient(..)
+  , Request(..)
+  , Response(..)
+  , RequestBody(..)
   , module Servant.Client.Core.Internal.BaseUrl
   ) where
 

servant-client-core/src/Servant/Client/Core/Internal/Request.hs

@@ -27,11 +27,17 @@ import           Network.HTTP.Types      (Header, HeaderName, HttpVersion,
 import           Web.HttpApiData         (ToHttpApiData, toEncodedUrlPiece,
                                           toHeader)
 
-data ServantError
+-- | A type representing possible errors in a request
-  = FailureResponse Response
+data ServantError =
+  -- | The server returned an error response
+    FailureResponse Response
+  -- | The body could not be decoded at the expected type
   | DecodeFailure Text Response
+  -- | The content-type of the response is not supported
   | UnsupportedContentType MediaType Response
+  -- | The content-type header is invalid
   | InvalidContentTypeHeader Response
+  -- | There was a connection error, and no response was received
   | ConnectionError Text
   deriving (Eq, Show, Generic, Typeable)
 
@@ -45,6 +51,7 @@ data Request = Request
   , requestMethod      :: Method
   } deriving (Generic, Typeable)
 
+-- | The request body. Currently only lazy ByteStrings are supported.
 newtype RequestBody = RequestBodyLBS LBS.ByteString
   deriving (Eq, Ord, Read, Show, Typeable)
 
@@ -55,6 +62,7 @@ data Response = Response
   , responseHttpVersion :: HttpVersion
   } deriving (Eq, Show, Generic, Typeable)
 
+-- A GET request to the top-level path
 defaultRequest :: Request
 defaultRequest = Request
   { requestPath = ""

servant-client/servant-client.cabal

@@ -29,23 +29,23 @@ source-repository head
 
 library
   exposed-modules:
-    Servant.Client
-    Servant.Client.Class
     Servant.Client.HttpClient
-    Servant.Client.Generic
-    Servant.Client.Experimental.Auth
-    Servant.Common.BaseUrl
-    Servant.Common.BasicAuth
-    Servant.Common.Req
   build-depends:
       base                  >= 4.7      && < 4.11
     , base-compat           >= 0.9.1    && < 0.10
+    , bytestring            >= 0.10     && < 0.11
     , aeson                 >= 0.7      && < 1.3
     , attoparsec            >= 0.12     && < 0.14
     , http-client           >= 0.4.18.1 && < 0.6
     , http-client-tls       >= 0.2.2    && < 0.4
+    , http-media            >= 0.6.2    && < 0.8
+    , http-types            >= 0.8.6    && < 0.10
+    , exceptions            >= 0.8      && < 0.9
     , monad-control         >= 1.0.0.4  && < 1.1
+    , mtl                   >= 2.2      && < 2.3
     , semigroupoids         >= 4.3      && < 5.3
+    , servant-client-core   == 0.11.*
+    , text                  >= 1.2      && < 1.3
     , transformers          >= 0.3      && < 0.6
     , transformers-base     >= 0.4.4    && < 0.5
     , transformers-compat   >= 0.4      && < 0.6

servant-client/src/Servant/Client/HttpClient.hs

@@ -20,41 +20,37 @@ import           Control.Monad
 import           Control.Monad.Base          (MonadBase (..))
 import           Control.Monad.Catch         (MonadCatch, MonadThrow)
 import           Control.Monad.Error.Class   (MonadError (..))
-import           Control.Monad.IO.Class      ()
+import           Data.ByteString.Builder     (toLazyByteString)
+import qualified Data.ByteString.Lazy        as BSL
+import           Data.Monoid                 ((<>))
+import           Data.String                 (fromString)
+import qualified Data.Text                   as T
+import           GHC.Exts                    (fromList)
+{-import           Control.Monad.IO.Class      ()-}
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Control (MonadBaseControl (..))
 import           Control.Monad.Trans.Except
-import           Data.ByteString.Lazy        hiding (any, elem, filter, map,
+{-import           Data.ByteString.Lazy        hiding (any, elem, filter, map,-}
-                                              null, pack)
+                                              {-null, pack)-}
 import           Data.Foldable               (toList)
 import           Data.Functor.Alt            (Alt (..))
 import           Data.Proxy
-import           Data.String.Conversions     (cs)
+{-import           Data.String.Conversions     (cs)-}
 import           GHC.Generics
-import           Network.HTTP.Media
+import           Network.HTTP.Media          (parseAccept, renderHeader, (//))
-import           Network.HTTP.Types
+import           Network.HTTP.Types          (hContentType, renderQuery,
-import           Servant.API.ContentTypes
+                                              statusCode)
-import           Servant.Client.Class
+{-import           Servant.API.ContentTypes-}
-import           Servant.Common.BaseUrl
+import           Servant.Client.Core
-import           Servant.Common.Req
+{-import           Servant.Common.BaseUrl-}
+{-import           Servant.Common.Req-}
 
 import qualified Network.HTTP.Client         as Client
-import qualified Network.HTTP.Types.Header   as HTTP
+{-import qualified Network.HTTP.Types.Header   as HTTP-}
-
-instance RunClient ClientM NoContent ( Int, ByteString, MediaType
-                                     , [HTTP.Header], Response ByteString) where
-  runRequest _ meth req = performRequest meth req
-
-instance (MimeUnrender ct a) =>
-         RunClient ClientM ct ([HTTP.Header], a) where
-  runRequest p meth req = performRequestCT p meth req
-
-instance RunClient ClientM NoContent [HTTP.Header] where
-  runRequest _ meth req = performRequestNoBody meth req
 
 data ClientEnv
   = ClientEnv
-  { manager :: Manager
+  { manager :: Client.Manager
   , baseUrl :: BaseUrl
   }
 
@@ -82,55 +78,83 @@ instance MonadBaseControl IO ClientM where
 instance Alt ClientM where
   a <!> b = a `catchError` \_ -> b
 
+instance RunClient ClientM where
+  runRequest = performRequest
+
 runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
 runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
 
 
-performRequest :: Method -> Req
-               -> ClientM Response
-performRequest reqMethod req = do
-  m <- asks manager
-  reqHost <- asks baseUrl
-  partialRequest <- liftIO $ reqToRequest req reqHost
 
-  let request = partialRequest { Client.method = reqMethod }
+performRequest :: Request -> ClientM Response
+performRequest req = do
+  m <- asks manager
+  burl <- asks baseUrl
+  let request = requestToClientRequest burl req
 
   eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
   case eResponse of
-    Left err ->
+    Left err -> throwError $ err
-      throwError . ConnectionError $ SomeException err
-
     Right response -> do
       let status = Client.responseStatus response
           body = Client.responseBody response
           hdrs = Client.responseHeaders response
           status_code = statusCode status
+          ourResponse = clientResponseToReponse response
       ct <- case lookup "Content-Type" $ Client.responseHeaders response of
                  Nothing -> pure $ "application"//"octet-stream"
                  Just t -> case parseAccept t of
-                   Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
+                   Nothing -> throwError $ InvalidContentTypeHeader ourResponse
                    Just t' -> pure t'
       unless (status_code >= 200 && status_code < 300) $
-        throwError $ FailureResponse (UrlReq reqHost req) status ct body
+        throwError $ FailureResponse ourResponse
-      return (status_code, body, ct, hdrs, response)
+      return ourResponse
 
-performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
+clientResponseToReponse :: Client.Response BSL.ByteString -> Response
-    -> ClientM ([HTTP.Header], result)
+clientResponseToReponse r = Response
-performRequestCT ct reqMethod req = do
+  { responseStatusCode = Client.responseStatus r
-  let acceptCTS = contentTypes ct
+  , responseBody = Client.responseBody r
-  (_status, respBody, respCT, hdrs, _response) <-
+  , responseHeaders = fromList $ Client.responseHeaders r
-    performRequest reqMethod (req { reqAccept = toList acceptCTS })
+  , responseHttpVersion = Client.responseVersion r
-  unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody
+  }
-  case mimeUnrender ct respBody of
-    Left err -> throwError $ DecodeFailure err respCT respBody
-    Right val -> return (hdrs, val)
 
-performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
+requestToClientRequest :: BaseUrl -> Request -> Client.Request
-performRequestNoBody reqMethod req = do
+requestToClientRequest burl r = Client.defaultRequest
-  (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
+  { Client.method = requestMethod r
-  return hdrs
+  , Client.host = fromString $ baseUrlHost burl
+  , Client.port = baseUrlPort burl
+  , Client.path = BSL.toStrict
+                $ fromString (baseUrlPath burl)
+               <> toLazyByteString (requestPath r)
+  , Client.queryString = renderQuery True . toList $ requestQueryString r
+  , Client.requestHeaders =
+      let orig = toList $ requestHeaders r
+      in maybe orig (: orig) contentTypeHdr
+  , Client.requestBody = body
+  }
+  where
+    (body, contentTypeHdr) = case requestBody r of
+      Nothing -> (Client.RequestBodyLBS "", Nothing)
+      Just (RequestBodyLBS body, typ)
+        -> (Client.RequestBodyLBS body, Just (hContentType, renderHeader typ))
+
+{-performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req-}
+    {--> ClientM ([HTTP.Header], result)-}
+{-performRequestCT ct reqMethod req = do-}
+  {-let acceptCTS = contentTypes ct-}
+  {-(_status, respBody, respCT, hdrs, _response) <--}
+    {-performRequest reqMethod (req { reqAccept = toList acceptCTS })-}
+  {-unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody-}
+  {-case mimeUnrender ct respBody of-}
+    {-Left err -> throwError $ DecodeFailure err respCT respBody-}
+    {-Right val -> return (hdrs, val)-}
+
+{-performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]-}
+{-performRequestNoBody reqMethod req = do-}
+  {-(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req-}
+  {-return hdrs-}
 
 catchConnectionError :: IO a -> IO (Either ServantError a)
 catchConnectionError action =
   catch (Right <$> action) $ \e ->
-    pure . Left . ConnectionError $ SomeException (e :: HttpException)
+    pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)