Rewrite servant-client.

This commit begins the reorganization of the servant-client project
    so as to allow multiple backends, and also begins some much-needed
    refactoring of the servant-client code.

servant-client-core/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for servant-client-core
+
+## 0.11  -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

servant-client-core/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2017, Servant Contributors
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Servant Contributors nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

servant-client-core/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

servant-client-core/include/overlapping-compat.h

@@ -0,0 +1,8 @@
+#if __GLASGOW_HASKELL__ >= 710
+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
+#define OVERLAPPING_  {-# OVERLAPPING #-}
+#else
+{-# LANGUAGE OverlappingInstances #-}
+#define OVERLAPPABLE_
+#define OVERLAPPING_
+#endif

servant-client-core/servant-client-core.cabal

@@ -0,0 +1,40 @@
+name:                servant-client-core
+version:             0.11
+synopsis:            Core functionality and class for client function generation for servant APIs
+description:
+  This library provides a class
+license:             BSD3
+license-file:        LICENSE
+author:              Servant Contributors
+maintainer:          haskell-servant-maintainers@googlegroups.com
+homepage:            http://haskell-servant.readthedocs.org/
+bug-reports:         http://github.com/haskell-servant/servant/issues
+-- copyright:
+category:            Web
+build-type:          Simple
+extra-source-files:
+  include/*.h
+  CHANGELOG.md
+  README.md
+source-repository head
+  type:              git
+  location:          http://github.com/haskell-servant/servant.git
+cabal-version:       >=1.10
+
+library
+  exposed-modules:
+  build-depends:
+      base                  >= 4.7      && < 4.11
+    , base-compat           >= 0.9.1    && < 0.10
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+
+test-suite spec
+  type:              exitcode-stdio-1.0
+  ghc-options:       -Wall
+  default-language:  Haskell2010
+  hs-source-dirs:    test
+  main-is:           Spec.hs
+  other-modules:
+  build-depends:
+      base == 4.*

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

@@ -10,7 +10,7 @@ module Servant.Client.Experimental.Auth (
   , mkAuthenticateReq
   ) where
 
-import Servant.Common.Req (Req)
+import Servant.Common.Req (Request)
 
 -- | For a resource protected by authentication (e.g. AuthProtect), we need
 -- to provide the client with some data used to add authentication data
@@ -25,12 +25,12 @@ type family AuthClientData a :: *
 --
 -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
 newtype AuthenticateReq a =
-  AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) }
+  AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Request -> Request) }
 
 -- | Handy helper to avoid wrapping datatypes in tuples everywhere.
 --
 -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
 mkAuthenticateReq :: AuthClientData a
-                  -> (AuthClientData a -> Req -> Req)
+                  -> (AuthClientData a -> Request -> Request)
                   -> AuthenticateReq a
 mkAuthenticateReq val func = AuthenticateReq (val, func)

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

@@ -11,11 +11,11 @@ module Servant.Common.BasicAuth (
 import Data.ByteString.Base64 (encode)
 import Data.Monoid ((<>))
 import Data.Text.Encoding (decodeUtf8)
-import Servant.Common.Req (addHeader, Req)
+import Servant.Common.Req (addHeader, Request)
 import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
 
 -- | Authenticate a request using Basic Authentication
-basicAuthReq :: BasicAuthData -> Req -> Req
+basicAuthReq :: BasicAuthData -> Request -> Request
 basicAuthReq (BasicAuthData user pass) req =
     let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass))
     in addHeader "Authorization" authText req

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

@@ -0,0 +1,13 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-| Types for possible backends to run client-side `Request` queries -}
+module Servant.Client.Class where
+
+import Data.Proxy
+import Network.HTTP.Types
+import Servant.Common.Req (Request, Response)
+
+class (Monad m) => RunClient m ct where
+  runRequest :: Proxy ct
+             -> Method
+             -> Request
+             -> m Response

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

@@ -0,0 +1,146 @@
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeFamilies               #-}
+
+module Servant.Common.Request where
+
+import           Prelude                 ()
+import           Prelude.Compat
+
+import qualified Data.ByteString.Builder as Builder
+import qualified Data.ByteString.Lazy    as LBS
+import           Data.Semigroup          ((<>))
+import qualified Data.Sequence           as Seq
+import           Data.String.Conversions (cs)
+import           Data.Text               (Text)
+import           Data.Typeable           (Typeable)
+import           GHC.Generics            (Generic)
+import           Network.HTTP.Media      (MediaType)
+import           Network.HTTP.Types      (Header, HeaderName, HttpVersion,
+                                          Method, QueryItem, Status, http11)
+import           Web.HttpApiData         (ToHttpApiData, toEncodedUrlPiece,
+                                          toHeader)
+
+data ServantError
+  = FailureResponse Response
+  | DecodeFailure Text Response
+  | UnsupportedContentType MediaType Response
+  | InvalidContentTypeHeader Response
+  | ConnectionError Text
+  deriving (Eq, Show, Generic, Typeable)
+
+data Request = Request
+  { requestPath        :: Builder.Builder
+  , requestQueryString :: Seq.Seq QueryItem
+  , requestBody        :: Maybe (RequestBody, MediaType)
+  , requestAccept      :: Seq.Seq MediaType
+  , requestHeaders     :: Seq.Seq Header
+  , requestHttpVersion :: HttpVersion
+  } deriving (Generic, Typeable)
+
+newtype RequestBody = RequestBodyLBS LBS.ByteString
+  deriving (Eq, Ord, Read, Show, Typeable)
+
+data Response = Response
+  { responseStatusCode  :: Status
+  , responseBody        :: LBS.ByteString
+  , responseHeaders     :: Seq.Seq Header
+  , responseHttpVersion :: HttpVersion
+  } deriving (Eq, Show, Generic, Typeable)
+
+defaultRequest :: Request
+defaultRequest = Request
+  { requestPath = ""
+  , requestQueryString = Seq.empty
+  , requestBody = Nothing
+  , requestAccept = Seq.empty
+  , requestHeaders = Seq.empty
+  , requestHttpVersion = http11
+  }
+
+appendToPath :: Text -> Request -> Request
+appendToPath p req
+  = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
+
+{-appendToQueryString :: Text       -- ^ param name-}
+                    {--> Maybe Text -- ^ param value-}
+                    {--> Request-}
+                    {--> Request-}
+{-appendToQueryString pname pvalue req-}
+  {-= req { requestQueryString = requestQueryString req Seq.|> (pname, pvalue)}-}
+
+addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
+addHeader name val req
+  = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
+
+-- | Set body and media type of the request being constructed.
+--
+-- The body is set to the given bytestring using the 'RequestBodyLBS'
+-- constructor.
+--
+-- @since 0.12
+--
+setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request
+setRequestBodyLBS b t req
+  = req { requestBody = Just (RequestBodyLBS b, t) }
+
+-- | Set body and media type of the request being constructed.
+--
+-- @since 0.12
+--
+setRequestBody :: RequestBody -> MediaType -> Request -> Request
+setRequestBody b t req = req { requestBody = Just (b, t) }
+
+{-reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request-}
+{-reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =-}
+    {-setheaders . setAccept . setrqb . setQS <$> parseRequest url-}
+
+  {-where url = show $ nullURI { uriScheme = case reqScheme of-}
+                                  {-Http  -> "http:"-}
+                                  {-Https -> "https:"-}
+                             {-, uriAuthority = Just $-}
+                                 {-URIAuth { uriUserInfo = ""-}
+                                         {-, uriRegName = reqHost-}
+                                         {-, uriPort = ":" ++ show reqPort-}
+                                         {-}-}
+                             {-, uriPath = fullPath-}
+                             {-}-}
+        {-fullPath = path ++ cs (Builder.toLazyByteString (reqPath req))-}
+
+        {-setrqb r = case reqBody req of-}
+                     {-Nothing -> r-}
+                     {-Just (b,t) -> r { requestBody = 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)-}
+
+#if !MIN_VERSION_http_client(0,4,30)
+-- 'parseRequest' is introduced in http-client-0.4.30
+-- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses
+--
+-- See for implementations:
+-- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest
+-- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest
+parseRequest :: MonadThrow m => String -> m Request
+parseRequest url = liftM disableStatusCheck (parseUrl url)
+  where
+    disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }
+#endif
+
+
+-- * performing requests
+
+displayHttpRequest :: Method -> String
+displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"

servant-client/servant-client.cabal

@@ -44,6 +44,7 @@ library
     , attoparsec            >= 0.12     && < 0.14
     , base64-bytestring     >= 1.0.0.1  && < 1.1
     , bytestring            >= 0.10     && < 0.11
+    , containers            >= 0.5      && < 0.6
     , exceptions            >= 0.8      && < 0.9
     , generics-sop          >= 0.1.0.0  && < 0.4
     , http-api-data         >= 0.3.6    && < 0.4

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

@@ -1,15 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-| Types for possible backends to run client-side `Req` queries -}
-module Servant.Client.Class
-  (RunClient(..))
-where
-
-import Data.Proxy
-import Network.HTTP.Types
-import Servant.Common.Req
-
-class (Monad m) => RunClient m ct result where
-  runRequest :: Proxy ct
-             -> Method
-             -> Req
-             -> m result

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

@@ -4,44 +4,42 @@
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeFamilies               #-}
 
 {-| http-client based client  requests executor -}
 module Servant.Client.HttpClient where
 
 
-import Prelude ()
+import           Prelude                     ()
-import Prelude.Compat
+import           Prelude.Compat
 
-import Control.Exception
+import           Control.Exception
-import Control.Monad
+import           Control.Monad
-import Control.Monad.Catch (MonadThrow, MonadCatch)
+import           Control.Monad.Base          (MonadBase (..))
-import Data.Foldable (toList)
+import           Control.Monad.Catch         (MonadCatch, MonadThrow)
-import Data.Functor.Alt (Alt (..))
+import           Control.Monad.Error.Class   (MonadError (..))
+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,
+                                              null, pack)
+import           Data.Foldable               (toList)
+import           Data.Functor.Alt            (Alt (..))
+import           Data.Proxy
+import           Data.String.Conversions     (cs)
+import           GHC.Generics
+import           Network.HTTP.Media
+import           Network.HTTP.Types
+import           Servant.API.ContentTypes
+import           Servant.Client.Class
+import           Servant.Common.BaseUrl
+import           Servant.Common.Req
 
-import Control.Monad.Error.Class (MonadError(..))
+import qualified Network.HTTP.Client         as Client
-import Control.Monad.Trans.Except
-
-import GHC.Generics
-import Control.Monad.Base (MonadBase (..))
-import Control.Monad.IO.Class ()
-import Control.Monad.Reader
-import Control.Monad.Trans.Control (MonadBaseControl (..))
-import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
-import Data.String.Conversions (cs)
-import Data.Proxy
-import Network.HTTP.Media
-import Network.HTTP.Types
-import Network.HTTP.Client hiding (Proxy, path)
 import qualified Network.HTTP.Types.Header   as HTTP
-import Servant.API.ContentTypes
-import Servant.Client.Class
-import Servant.Common.BaseUrl
-import Servant.Common.Req
-
-import qualified Network.HTTP.Client as Client
 
 instance RunClient ClientM NoContent ( Int, ByteString, MediaType
                                      , [HTTP.Header], Response ByteString) where
@@ -89,8 +87,7 @@ runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
 
 
 performRequest :: Method -> Req
-               -> ClientM ( Int, ByteString, MediaType
+               -> ClientM Response
-                          , [HTTP.Header], Response ByteString)
 performRequest reqMethod req = do
   m <- asks manager
   reqHost <- asks baseUrl

servant-client/src/Servant/Common/Req.hs

@@ -1,183 +0,0 @@
-{-# LANGUAGE CPP                        #-}
-{-# LANGUAGE DeriveDataTypeable         #-}
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-
-module Servant.Common.Req where
-
-import Prelude ()
-import Prelude.Compat
-
-import Control.Exception
-import Control.Monad.Catch (MonadThrow)
-import Data.Semigroup ((<>))
-
-import Control.Monad.IO.Class ()
-import qualified Data.ByteString.Builder as BS
-import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
-import Data.String
-import Data.String.Conversions (cs)
-import Data.Text (Text)
-import Data.Text.Encoding
-import Data.Typeable
-import Network.HTTP.Media
-import Network.HTTP.Types
-import Network.HTTP.Client hiding (Proxy, path)
-import Network.URI hiding (path)
-import Servant.Common.BaseUrl
-
-import Web.HttpApiData
-
-data ServantError
-  = FailureResponse
-    { failingRequest            :: UrlReq
-    , responseStatus            :: Status
-    , responseContentType       :: MediaType
-    , responseBody              :: ByteString
-    }
-  | DecodeFailure
-    { decodeError               :: String
-    , responseContentType       :: MediaType
-    , responseBody              :: ByteString
-    }
-  | UnsupportedContentType
-    { responseContentType       :: MediaType
-    , responseBody              :: ByteString
-    }
-  | InvalidContentTypeHeader
-    { responseContentTypeHeader :: ByteString
-    , responseBody              :: ByteString
-    }
-  | ConnectionError
-    { connectionError           :: SomeException
-    }
-  deriving (Show, Typeable)
-
-instance Eq ServantError where
-  FailureResponse _ a b c == FailureResponse _ x y z =
-    (a, b, c) == (x, y, z)
-  DecodeFailure a b c == DecodeFailure x y z =
-    (a, b, c) == (x, y, z)
-  UnsupportedContentType a b == UnsupportedContentType x y =
-    (a, b) == (x, y)
-  InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
-    (a, b) == (x, y)
-  ConnectionError a == ConnectionError x =
-    show a == show x
-  _ == _ = False
-
-instance Exception ServantError
-
-data UrlReq = UrlReq BaseUrl Req
-
-instance Show UrlReq where
-  show (UrlReq url req) = showBaseUrl url ++ path ++ "?" ++ show (qs req)
-    where
-      path = cs (BS.toLazyByteString (reqPath req))
-
-data Req = Req
-  { reqPath   :: BS.Builder
-  , qs        :: QueryText
-  , reqBody   :: Maybe (RequestBody, MediaType)
-  , reqAccept :: [MediaType]
-  , headers   :: [(String, Text)]
-  }
-
-defReq :: Req
-defReq = Req "" [] Nothing [] []
-
-appendToPath :: String -> Req -> Req
-appendToPath p req =
-  req { reqPath = reqPath req <> "/" <> toEncodedUrlPiece p }
-
-appendToQueryString :: Text       -- ^ param name
-                    -> Maybe Text -- ^ param value
-                    -> Req
-                    -> Req
-appendToQueryString pname pvalue req =
-  req { qs = qs req ++ [(pname, pvalue)]
-      }
-
-addHeader :: ToHttpApiData a => String -> a -> Req -> Req
-addHeader name val req = req { headers = headers req
-                                      ++ [(name, decodeUtf8 (toHeader val))]
-                             }
-
--- | Set body and media type of the request being constructed.
---
--- The body is set to the given bytestring using the 'RequestBodyLBS'
--- constructor.
---
-{-# DEPRECATED setRQBody "Use setReqBodyLBS instead" #-}
-setRQBody :: ByteString -> MediaType -> Req -> Req
-setRQBody = setReqBodyLBS
-
--- | Set body and media type of the request being constructed.
---
--- The body is set to the given bytestring using the 'RequestBodyLBS'
--- constructor.
---
--- @since 0.9.2.0
---
-setReqBodyLBS :: ByteString -> MediaType -> Req -> Req
-setReqBodyLBS b t req = req { reqBody = Just (RequestBodyLBS b, t) }
-
--- | Set body and media type of the request being constructed.
---
--- @since 0.9.2.0
---
-setReqBody :: RequestBody -> MediaType -> Req -> Req
-setReqBody b t req = req { reqBody = Just (b, t) }
-
-reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
-reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
-    setheaders . setAccept . setrqb . setQS <$> parseRequest url
-
-  where url = show $ nullURI { uriScheme = case reqScheme of
-                                  Http  -> "http:"
-                                  Https -> "https:"
-                             , uriAuthority = Just $
-                                 URIAuth { uriUserInfo = ""
-                                         , uriRegName = reqHost
-                                         , uriPort = ":" ++ show reqPort
-                                         }
-                             , uriPath = fullPath
-                             }
-        fullPath = path ++ cs (BS.toLazyByteString (reqPath req))
-
-        setrqb r = case reqBody req of
-                     Nothing -> r
-                     Just (b,t) -> r { requestBody = 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)
-
-#if !MIN_VERSION_http_client(0,4,30)
--- 'parseRequest' is introduced in http-client-0.4.30
--- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses
---
--- See for implementations:
--- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest
--- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest
-parseRequest :: MonadThrow m => String -> m Request
-parseRequest url = liftM disableStatusCheck (parseUrl url)
-  where
-    disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }
-#endif
-
-
--- * performing requests
-
-displayHttpRequest :: Method -> String
-displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"