diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,54 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.16 +---- + +- Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError` + [#1131](https://github.com/haskell-servant/servant/pull/1131) + +- *servant-client-core* Rearrange modules. No more `Internal` modules, whole + API is versioned. + [#1130](https://github.com/haskell-servant/servant/pull/1130) + +- *servant-client-core* `RequestBody` is now + + ```haskell + = RequestBodyLBS LBS.ByteString + | RequestBodyBS BS.ByteString + | RequestBodySource (SourceIO LBS.ByteString) + ``` + + i.e. no more replicates `http-client`s API. + [#1117](https://github.com/haskell-servant/servant/pull/1117) + +- *servant-client-core* Keep structured exceptions in `ConnectionError` + constructor of `ClientError` + [#1115](https://github.com/haskell-servant/servant/pull/1115) + + ```diff + -| ConnectionError Text + +| ConnectionError SomeException + ``` + +- *servant-client-core* Preserve failing request in `FailureResponse` + constructor of `ClientError` + [#1114](https://github.com/haskell-servant/servant/pull/1114) + + ```diff + -FailureResponse Response + +-- | The server returned an error response including the + +-- failing request. 'requestPath' includes the 'BaseUrl' and the + +-- path of the request. + +FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response + ``` + +- *servant-client* Fix (implement) `StreamBody` instance + [#1110](https://github.com/haskell-servant/servant/pull/1110) + +- *servant-client* Update CookieJar with intermediate request/responses (redirects) + [#1104](https://github.com/haskell-servant/servant/pull/1104) + 0.15 ---- diff --git a/servant-client-core.cabal b/servant-client-core.cabal --- a/servant-client-core.cabal +++ b/servant-client-core.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-client-core -version: 0.15 +version: 0.16 synopsis: Core functionality and class for client function generation for servant APIs category: Servant, Web @@ -14,13 +14,13 @@ license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors +copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 - || ==8.6.2 + || ==8.6.3 extra-source-files: CHANGELOG.md @@ -36,15 +36,18 @@ Servant.Client.Free Servant.Client.Generic Servant.Client.Core.Reexport - Servant.Client.Core.Internal.Auth - Servant.Client.Core.Internal.BaseUrl - Servant.Client.Core.Internal.BasicAuth - Servant.Client.Core.Internal.ClientF - Servant.Client.Core.Internal.Generic - Servant.Client.Core.Internal.HasClient - Servant.Client.Core.Internal.Request - Servant.Client.Core.Internal.RunClient + Servant.Client.Core.Auth + Servant.Client.Core.BaseUrl + Servant.Client.Core.BasicAuth + Servant.Client.Core.ClientError + Servant.Client.Core.HasClient + Servant.Client.Core.Request + Servant.Client.Core.Response + Servant.Client.Core.RunClient + other-modules: + Servant.Client.Core.Internal + -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 -- @@ -58,9 +61,13 @@ , transformers >= 0.5.2.0 && < 0.6 , template-haskell >= 2.11.1.0 && < 2.15 + if !impl(ghc >= 8.2) + build-depends: + bifunctors >= 5.5.3 && < 5.6 + -- Servant dependencies build-depends: - servant >= 0.15 && <0.16 + servant >= 0.16 && <0.17 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. @@ -70,7 +77,6 @@ , base64-bytestring >= 1.0.0.1 && < 1.1 , exceptions >= 0.10.0 && < 0.11 , free >= 5.1 && < 5.2 - , generics-sop >= 0.4.0.1 && < 0.5 , http-media >= 0.7.1.3 && < 0.8 , http-types >= 0.12.2 && < 0.13 , network-uri >= 2.6.1.0 && < 2.7 @@ -98,8 +104,8 @@ -- Additonal dependencies build-depends: deepseq >= 1.4.2.0 && < 1.5 - , hspec >= 2.6.0 && < 2.7 + , hspec >= 2.6.0 && < 2.8 , QuickCheck >= 2.12.6.1 && < 2.13 build-tool-depends: - hspec-discover:hspec-discover >= 2.6.0 && <2.7 + hspec-discover:hspec-discover >= 2.6.0 && <2.8 diff --git a/src/Servant/Client/Core.hs b/src/Servant/Client/Core.hs --- a/src/Servant/Client/Core.hs +++ b/src/Servant/Client/Core.hs @@ -32,18 +32,20 @@ , AuthClientData -- * Generic Client - , ClientLike(..) - , genericMkClientL - , genericMkClientP - , ServantError(..) + , ClientError(..) , EmptyClient(..) - -- * Response , Response - , GenResponse (..) + , ResponseF (..) , RunClient(..) - , module Servant.Client.Core.Internal.BaseUrl + -- * BaseUrl + , BaseUrl (..) + , Scheme (..) + , showBaseUrl + , parseBaseUrl + , InvalidBaseUrlException (..) + -- ** Streaming , RunStreamingClient(..) , StreamingResponse @@ -56,12 +58,13 @@ , setRequestBodyLBS , setRequestBody ) where -import Servant.Client.Core.Internal.Auth -import Servant.Client.Core.Internal.BaseUrl - (BaseUrl (..), InvalidBaseUrlException, Scheme (..), +import Servant.Client.Core.Auth +import Servant.Client.Core.BaseUrl + (BaseUrl (..), InvalidBaseUrlException (..), Scheme (..), parseBaseUrl, showBaseUrl) -import Servant.Client.Core.Internal.BasicAuth -import Servant.Client.Core.Internal.Generic -import Servant.Client.Core.Internal.HasClient -import Servant.Client.Core.Internal.Request -import Servant.Client.Core.Internal.RunClient +import Servant.Client.Core.BasicAuth +import Servant.Client.Core.ClientError +import Servant.Client.Core.HasClient +import Servant.Client.Core.Request +import Servant.Client.Core.Response +import Servant.Client.Core.RunClient diff --git a/src/Servant/Client/Core/Auth.hs b/src/Servant/Client/Core/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Auth.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | Authentication for clients + +module Servant.Client.Core.Auth ( + AuthClientData, + AuthenticatedRequest (..), + mkAuthenticatedRequest, + ) where + +import Servant.Client.Core.Request + (Request) + +-- | For a resource protected by authentication (e.g. AuthProtect), we need +-- to provide the client with some data used to add authentication data +-- to a request +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +type family AuthClientData a :: * + +-- | For better type inference and to avoid usage of a data family, we newtype +-- wrap the combination of some 'AuthClientData' and a function to add authentication +-- data to a request +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +newtype AuthenticatedRequest a = + AuthenticatedRequest { 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 +mkAuthenticatedRequest :: AuthClientData a + -> (AuthClientData a -> Request -> Request) + -> AuthenticatedRequest a +mkAuthenticatedRequest val func = AuthenticatedRequest (val, func) diff --git a/src/Servant/Client/Core/BaseUrl.hs b/src/Servant/Client/Core/BaseUrl.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/BaseUrl.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE ViewPatterns #-} +module Servant.Client.Core.BaseUrl ( + BaseUrl (..), + Scheme (..), + showBaseUrl, + parseBaseUrl, + InvalidBaseUrlException (..), + ) where + +import Control.DeepSeq + (NFData (..)) +import Control.Monad.Catch + (Exception, MonadThrow, throwM) +import Data.Aeson + (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..)) +import Data.Aeson.Types + (FromJSONKeyFunction (..), contramapToJSONKeyFunction, + withText) +import Data.Data + (Data) +import Data.List +import qualified Data.Text as T +import GHC.Generics +import Language.Haskell.TH.Syntax + (Lift) +import Network.URI hiding + (path) +import Safe +import Text.Read + +-- | URI scheme to use +data Scheme = + Http -- ^ http:// + | Https -- ^ https:// + deriving (Show, Eq, Ord, Generic, Lift, Data) + +-- | 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) + , baseUrlPath :: String -- ^ path (eg "/a/b/c") + } deriving (Show, Ord, Generic, Lift, Data) +-- TODO: Ord is more precise than Eq +-- TODO: Add Hashable instance? +-- +instance NFData BaseUrl where + rnf (BaseUrl a b c d) = a `seq` rnf b `seq` rnf c `seq` rnf d + +instance Eq BaseUrl where + BaseUrl a b c path == BaseUrl a' b' c' path' + = a == a' && b == b' && c == c' && s path == s path' + where s ('/':x) = x + s x = x + +-- | >>> traverse_ (LBS8.putStrLn . encode) $ parseBaseUrl "api.example.com" +-- "http://api.example.com" +instance ToJSON BaseUrl where + toJSON = toJSON . showBaseUrl + toEncoding = toEncoding . showBaseUrl + +-- | >>> parseBaseUrl "api.example.com" >>= decode . encode :: Maybe BaseUrl +-- Just (BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""}) +instance FromJSON BaseUrl where + parseJSON = withText "BaseUrl" $ \t -> case parseBaseUrl (T.unpack t) of + Just u -> return u + Nothing -> fail $ "Invalid base url: " ++ T.unpack t + +-- | >>> :{ +-- traverse_ (LBS8.putStrLn . encode) $ do +-- u1 <- parseBaseUrl "api.example.com" +-- u2 <- parseBaseUrl "example.com" +-- return $ Map.fromList [(u1, 'x'), (u2, 'y')] +-- :} +-- {"http://api.example.com":"x","http://example.com":"y"} +instance ToJSONKey BaseUrl where + toJSONKey = contramapToJSONKeyFunction showBaseUrl toJSONKey + +instance FromJSONKey BaseUrl where + fromJSONKey = FromJSONKeyTextParser $ \t -> case parseBaseUrl (T.unpack t) of + Just u -> return u + Nothing -> fail $ "Invalid base url: " ++ T.unpack t + +-- | >>> showBaseUrl <$> parseBaseUrl "api.example.com" +-- "http://api.example.com" +showBaseUrl :: BaseUrl -> String +showBaseUrl (BaseUrl urlscheme host port path) = + schemeString ++ "//" ++ host ++ (portString path) + where + a b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b + schemeString = case urlscheme of + Http -> "http:" + Https -> "https:" + portString = case (urlscheme, port) of + (Http, 80) -> "" + (Https, 443) -> "" + _ -> ":" ++ show port + +newtype InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show) +instance Exception InvalidBaseUrlException + +-- | +-- +-- >>> parseBaseUrl "api.example.com" +-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""} +-- +-- /Note:/ trailing slash is removed +-- +-- >>> parseBaseUrl "api.example.com/" +-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""} +-- +-- >>> parseBaseUrl "api.example.com/dir/" +-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = "/dir"} +-- +parseBaseUrl :: MonadThrow m => String -> m 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)))) path "" "") -> + return (BaseUrl Http host port path) + Just (URI "http:" (Just (URIAuth "" host "")) path "" "") -> + return (BaseUrl Http host 80 path) + Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") -> + return (BaseUrl Https host port path) + Just (URI "https:" (Just (URIAuth "" host "")) path "" "") -> + return (BaseUrl Https host 443 path) + _ -> if "://" `isInfixOf` s + then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s) + else parseBaseUrl ("http://" ++ s) + where + removeTrailingSlash str = case lastMay str of + Just '/' -> init str + _ -> str + +-- $setup +-- +-- >>> import Data.Aeson +-- >>> import Data.Foldable (traverse_) +-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +-- >>> import qualified Data.Map.Strict as Map diff --git a/src/Servant/Client/Core/BasicAuth.hs b/src/Servant/Client/Core/BasicAuth.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/BasicAuth.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | Basic Authentication for clients +module Servant.Client.Core.BasicAuth ( + basicAuthReq, + ) where + +import Data.ByteString.Base64 + (encode) +import Data.Monoid + ((<>)) +import Data.Text.Encoding + (decodeUtf8) +import Servant.API.BasicAuth + (BasicAuthData (BasicAuthData)) +import Servant.Client.Core.Request + (Request, addHeader) + +-- | Authenticate a request using Basic Authentication +basicAuthReq :: BasicAuthData -> Request -> Request +basicAuthReq (BasicAuthData user pass) req = + let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass)) + in addHeader "Authorization" authText req diff --git a/src/Servant/Client/Core/ClientError.hs b/src/Servant/Client/Core/ClientError.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/ClientError.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Servant.Client.Core.ClientError ( + ClientError (..), + ) where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq + (NFData (..)) +import Control.Exception + (SomeException (..)) +import Control.Monad.Catch + (Exception) +import qualified Data.ByteString as BS +import Data.Text + (Text) +import Data.Typeable + (Typeable, typeOf) +import GHC.Generics + (Generic) +import Network.HTTP.Media + (MediaType) +import Network.HTTP.Types () + +import Servant.Client.Core.BaseUrl +import Servant.Client.Core.Internal + (mediaTypeRnf) +import Servant.Client.Core.Request +import Servant.Client.Core.Response + + +-- | A type representing possible errors in a request +-- +-- Note that this type substantially changed in 0.12. +data ClientError = + -- | The server returned an error response including the + -- failing request. 'requestPath' includes the 'BaseUrl' and the + -- path of the request. + FailureResponse (RequestF () (BaseUrl, BS.ByteString)) 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 SomeException + deriving (Show, Generic, Typeable) + +instance Eq ClientError where + FailureResponse req res == FailureResponse req' res' = req == req' && res == res' + DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r' + UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r' + InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r' + ConnectionError exc == ConnectionError exc' = eqSomeException exc exc' + where + -- returns true, if type of exception is the same + eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b + + -- prevent wild card blindness + FailureResponse {} == _ = False + DecodeFailure {} == _ = False + UnsupportedContentType {} == _ = False + InvalidContentTypeHeader {} == _ = False + ConnectionError {} == _ = False + +instance Exception ClientError + +-- | Note: an exception in 'ConnectionError' might not be evaluated fully, +-- We only 'rnf' its 'show'ed value. +instance NFData ClientError where + rnf (FailureResponse req res) = rnf req `seq` rnf res + rnf (DecodeFailure err res) = rnf err `seq` rnf res + rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res + rnf (InvalidContentTypeHeader res) = rnf res + rnf (ConnectionError err) = err `seq` rnf (show err) diff --git a/src/Servant/Client/Core/HasClient.hs b/src/Servant/Client/Core/HasClient.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/HasClient.hs @@ -0,0 +1,678 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Servant.Client.Core.HasClient ( + clientIn, + HasClient (..), + EmptyClient (..), + ) where + +import Prelude () +import Prelude.Compat + +import Control.Monad + (unless) +import qualified Data.ByteString.Lazy as BL +import Data.Foldable + (toList) +import Data.List + (foldl') +import Data.Proxy + (Proxy (Proxy)) +import Data.Sequence + (fromList) +import qualified Data.Text as T +import Network.HTTP.Media + (MediaType, matches, parseAccept, (//)) +import Data.String + (fromString) +import Data.Text + (Text, pack) +import GHC.TypeLits + (KnownSymbol, symbolVal) +import qualified Network.HTTP.Types as H +import Servant.API + ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData, + BuildHeadersTo (..), Capture', CaptureAll, Description, + EmptyAPI, FramingRender (..), FramingUnrender (..), + FromSourceIO (..), Header', Headers (..), HttpVersion, + IsSecure, MimeRender (mimeRender), + MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag, + QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost, + ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, + ToSourceIO (..), Vault, Verb, WithNamedContext, contentType, + getHeadersHList, getResponse, toQueryParam, toUrlPiece) +import Servant.API.ContentTypes + (contentTypes) +import Servant.API.Modifiers + (FoldRequired, RequiredArgument, foldRequiredArgument) + +import Servant.Client.Core.Auth +import Servant.Client.Core.BasicAuth +import Servant.Client.Core.ClientError +import Servant.Client.Core.Request +import Servant.Client.Core.Response +import Servant.Client.Core.RunClient + +-- * Accessing APIs as a Client + +-- | 'clientIn' allows you to produce operations to query an API from a client +-- within a 'RunClient' monad. +-- +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > clientM :: Proxy ClientM +-- > clientM = Proxy +-- > +-- > getAllBooks :: ClientM [Book] +-- > postNewBook :: Book -> ClientM Book +-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM +clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api +clientIn p pm = clientWithRoute pm p defaultRequest + + +-- | This class lets us define how each API combinator influences the creation +-- of an HTTP request. +-- +-- Unless you are writing a new backend for @servant-client-core@ or new +-- combinators that you want to support client-generation, you can ignore this +-- class. +class RunClient m => HasClient m api where + type Client (m :: * -> *) (api :: *) :: * + clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api + hoistClientMonad + :: Proxy m + -> Proxy api + -> (forall x. mon x -> mon' x) + -> Client mon api + -> Client mon' api + + +-- | 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 :: ClientM [Book] +-- > postNewBook :: Book -> ClientM Book +-- > (getAllBooks :<|> postNewBook) = client myApi +instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where + type Client m (a :<|> b) = Client m a :<|> Client m b + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy a) req :<|> + clientWithRoute pm (Proxy :: Proxy b) req + + hoistClientMonad pm _ f (ca :<|> cb) = + hoistClientMonad pm (Proxy :: Proxy a) f ca :<|> + hoistClientMonad pm (Proxy :: Proxy b) f cb + +-- | Singleton type representing a client for an empty API. +data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) + +-- | The client for 'EmptyAPI' is simply 'EmptyClient'. +-- +-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "nothing" :> EmptyAPI +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: ClientM [Book] +-- > (getAllBooks :<|> EmptyClient) = client myApi +instance RunClient m => HasClient m EmptyAPI where + type Client m EmptyAPI = EmptyClient + clientWithRoute _pm Proxy _ = EmptyClient + hoistClientMonad _ _ _ EmptyClient = EmptyClient + +-- | 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 'ToHttpApiData' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBook :: Text -> ClientM Book +-- > getBook = client myApi +-- > -- then you can just use "getBook" to query that endpoint +instance (KnownSymbol capture, ToHttpApiData a, HasClient m api) + => HasClient m (Capture' mods capture a :> api) where + + type Client m (Capture' mods capture a :> api) = + a -> Client m api + + clientWithRoute pm Proxy req val = + clientWithRoute pm (Proxy :: Proxy api) + (appendToPath p req) + + where p = (toUrlPiece val) + + hoistClientMonad pm _ f cl = \a -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl a) + +-- | If you use a 'CaptureAll' in one of your endpoints in your API, +-- the corresponding querying function will automatically take an +-- additional argument of a list of the type specified by your +-- 'CaptureAll'. 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 these values are turned into text by specifying +-- a 'ToHttpApiData' instance of your type. +-- +-- Example: +-- +-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile +-- > +-- > myApi :: Proxy +-- > myApi = Proxy +-- +-- > getSourceFile :: [Text] -> ClientM SourceFile +-- > getSourceFile = client myApi +-- > -- then you can use "getSourceFile" to query that endpoint +instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout) + => HasClient m (CaptureAll capture a :> sublayout) where + + type Client m (CaptureAll capture a :> sublayout) = + [a] -> Client m sublayout + + clientWithRoute pm Proxy req vals = + clientWithRoute pm (Proxy :: Proxy sublayout) + (foldl' (flip appendToPath) req ps) + + where ps = map (toUrlPiece) vals + + hoistClientMonad pm _ f cl = \as -> + hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as) + +instance {-# OVERLAPPABLE #-} + -- Note [Non-Empty Content Types] + ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient m (Verb method status cts' a) where + type Client m (Verb method status cts' a) = m a + clientWithRoute _pm Proxy req = do + response <- runRequest req + { requestAccept = fromList $ toList accept + , requestMethod = method + } + response `decodedAs` (Proxy :: Proxy ct) + where + accept = contentTypes (Proxy :: Proxy ct) + method = reflectMethod (Proxy :: Proxy method) + + hoistClientMonad _ _ f ma = f ma + +instance {-# OVERLAPPING #-} + ( RunClient m, ReflectMethod method + ) => HasClient m (Verb method status cts NoContent) where + type Client m (Verb method status cts NoContent) + = m NoContent + clientWithRoute _pm Proxy req = do + _response <- runRequest req { requestMethod = method } + return NoContent + where method = reflectMethod (Proxy :: Proxy method) + + hoistClientMonad _ _ f ma = f ma + +instance {-# OVERLAPPING #-} + -- Note [Non-Empty Content Types] + ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls + , ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient m (Verb method status cts' (Headers ls a)) where + type Client m (Verb method status cts' (Headers ls a)) + = m (Headers ls a) + clientWithRoute _pm Proxy req = do + response <- runRequest req + { requestMethod = method + , requestAccept = fromList $ toList accept + } + case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of + Left err -> throwClientError $ DecodeFailure (pack err) response + Right val -> return $ Headers + { getResponse = val + , getHeadersHList = buildHeadersTo . toList $ responseHeaders response + } + where method = reflectMethod (Proxy :: Proxy method) + accept = contentTypes (Proxy :: Proxy ct) + + hoistClientMonad _ _ f ma = f ma + +instance {-# OVERLAPPING #-} + ( RunClient m, BuildHeadersTo ls, ReflectMethod method + ) => HasClient m (Verb method status cts (Headers ls NoContent)) where + type Client m (Verb method status cts (Headers ls NoContent)) + = m (Headers ls NoContent) + clientWithRoute _pm Proxy req = do + let method = reflectMethod (Proxy :: Proxy method) + response <- runRequest req { requestMethod = method } + return $ Headers { getResponse = NoContent + , getHeadersHList = buildHeadersTo . toList $ responseHeaders response + } + + hoistClientMonad _ _ f ma = f ma + +instance {-# OVERLAPPABLE #-} + ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method, + FramingUnrender framing, FromSourceIO chunk a + ) => HasClient m (Stream method status framing ct a) where + + type Client m (Stream method status framing ct a) = m a + + hoistClientMonad _ _ f ma = f ma + + clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do + let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk + framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' + return $ fromSourceIO $ framingUnrender' $ responseBody gres + where + req' = req + { requestAccept = fromList [contentType (Proxy :: Proxy ct)] + , requestMethod = reflectMethod (Proxy :: Proxy method) + } + +-- | 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 'ToHttpApiData' instance. +-- +-- Example: +-- +-- > newtype Referer = Referer { referrer :: Text } +-- > deriving (Eq, Show, Generic, ToHttpApiData) +-- > +-- > -- GET /view-my-referer +-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > viewReferer :: Maybe Referer -> ClientM Book +-- > viewReferer = client myApi +-- > -- then you can just use "viewRefer" to query that endpoint +-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments +instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods)) + => HasClient m (Header' mods sym a :> api) where + + type Client m (Header' mods sym a :> api) = + RequiredArgument mods a -> Client m api + + clientWithRoute pm Proxy req mval = + clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument + (Proxy :: Proxy mods) add (maybe req add) mval + where + hname = fromString $ symbolVal (Proxy :: Proxy sym) + + add :: a -> Request + add value = addHeader hname value req + + hoistClientMonad pm _ f cl = \arg -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) + +-- | Using a 'HttpVersion' combinator in your API doesn't affect the client +-- functions. +instance HasClient m api + => HasClient m (HttpVersion :> api) where + + type Client m (HttpVersion :> api) = + Client m api + + clientWithRoute pm Proxy = + clientWithRoute pm (Proxy :: Proxy api) + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +-- | Ignore @'Summary'@ in client functions. +instance HasClient m api => HasClient m (Summary desc :> api) where + type Client m (Summary desc :> api) = Client m api + + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +-- | Ignore @'Description'@ in client functions. +instance HasClient m api => HasClient m (Description desc :> api) where + type Client m (Description desc :> api) = Client m api + + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +-- | 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 'ToHttpApiData' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: Maybe Text -> ClientM [Book] +-- > getBooksBy = client myApi +-- > -- 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, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods)) + => HasClient m (QueryParam' mods sym a :> api) where + + type Client m (QueryParam' mods sym a :> api) = + RequiredArgument mods a -> Client m api + + -- if mparam = Nothing, we don't add it to the query string + clientWithRoute pm Proxy req mparam = + clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument + (Proxy :: Proxy mods) add (maybe req add) mparam + where + add :: a -> Request + add param = appendToQueryString pname (Just $ toQueryParam param) req + + pname :: Text + pname = pack $ symbolVal (Proxy :: Proxy sym) + + hoistClientMonad pm _ f cl = \arg -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) + +-- | 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 'ToHttpApiData' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: [Text] -> ClientM [Book] +-- > getBooksBy = client myApi +-- > -- 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, ToHttpApiData a, HasClient m api) + => HasClient m (QueryParams sym a :> api) where + + type Client m (QueryParams sym a :> api) = + [a] -> Client m api + + clientWithRoute pm Proxy req paramlist = + clientWithRoute pm (Proxy :: Proxy api) + (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) + req + paramlist' + ) + + where pname = pack $ symbolVal (Proxy :: Proxy sym) + paramlist' = map (Just . toQueryParam) paramlist + + hoistClientMonad pm _ f cl = \as -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl as) + +-- | 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 -> ClientM [Book] +-- > getBooks = client myApi +-- > -- 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 m api) + => HasClient m (QueryFlag sym :> api) where + + type Client m (QueryFlag sym :> api) = + Bool -> Client m api + + clientWithRoute pm Proxy req flag = + clientWithRoute pm (Proxy :: Proxy api) + (if flag + then appendToQueryString paramname Nothing req + else req + ) + + where paramname = pack $ symbolVal (Proxy :: Proxy sym) + + hoistClientMonad pm _ f cl = \b -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl b) + +-- | Pick a 'Method' and specify where the server you want to query is. You get +-- back the full `Response`. +instance RunClient m => HasClient m Raw where + type Client m Raw + = H.Method -> m Response + + clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw + clientWithRoute _pm Proxy req httpMethod = do + runRequest req { requestMethod = httpMethod } + + hoistClientMonad _ _ f cl = \meth -> f (cl meth) + +-- | 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 -> ClientM Book +-- > addBook = client myApi +-- > -- then you can just use "addBook" to query that endpoint +instance (MimeRender ct a, HasClient m api) + => HasClient m (ReqBody' mods (ct ': cts) a :> api) where + + type Client m (ReqBody' mods (ct ': cts) a :> api) = + a -> Client m api + + clientWithRoute pm Proxy req body = + clientWithRoute pm (Proxy :: Proxy api) + (let ctProxy = Proxy :: Proxy ct + in setRequestBodyLBS (mimeRender ctProxy body) + -- We use first contentType from the Accept list + (contentType ctProxy) + req + ) + + hoistClientMonad pm _ f cl = \a -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl a) + +instance + ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a + ) => HasClient m (StreamBody' mods framing ctype a :> api) + where + + type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api + + hoistClientMonad pm _ f cl = \a -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl a) + + clientWithRoute pm Proxy req body + = clientWithRoute pm (Proxy :: Proxy api) + $ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req + where + ctypeP = Proxy :: Proxy ctype + framingP = Proxy :: Proxy framing + + sourceIO = framingRender + framingP + (mimeRender ctypeP :: chunk -> BL.ByteString) + (toSourceIO body) + +-- | Make the querying function append @path@ to the request path. +instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where + type Client m (path :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) + (appendToPath p req) + + where p = pack $ symbolVal (Proxy :: Proxy path) + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +instance HasClient m api => HasClient m (Vault :> api) where + type Client m (Vault :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +instance HasClient m api => HasClient m (RemoteHost :> api) where + type Client m (RemoteHost :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +instance HasClient m api => HasClient m (IsSecure :> api) where + type Client m (IsSecure :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +instance HasClient m subapi => + HasClient m (WithNamedContext name context subapi) where + + type Client m (WithNamedContext name context subapi) = Client m subapi + clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi) + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl + +instance ( HasClient m api + ) => HasClient m (AuthProtect tag :> api) where + type Client m (AuthProtect tag :> api) + = AuthenticatedRequest (AuthProtect tag) -> Client m api + + clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) = + clientWithRoute pm (Proxy :: Proxy api) (func val req) + + hoistClientMonad pm _ f cl = \authreq -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq) + +-- * Basic Authentication + +instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where + type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api + + clientWithRoute pm Proxy req val = + clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req) + + hoistClientMonad pm _ f cl = \bauth -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth) + + + +{- Note [Non-Empty Content Types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rather than have + + instance (..., cts' ~ (ct ': cts)) => ... cts' ... + +It may seem to make more sense to have: + + instance (...) => ... (ct ': cts) ... + +But this means that if another instance exists that does *not* require +non-empty lists, but is otherwise more specific, no instance will be overall +more specific. This in turn generally means adding yet another instance (one +for empty and one for non-empty lists). +-} + +------------------------------------------------------------------------------- +-- helpers +------------------------------------------------------------------------------- + +checkContentTypeHeader :: RunClient m => Response -> m MediaType +checkContentTypeHeader response = + case lookup "Content-Type" $ toList $ responseHeaders response of + Nothing -> return $ "application"//"octet-stream" + Just t -> case parseAccept t of + Nothing -> throwClientError $ InvalidContentTypeHeader response + Just t' -> return t' + +decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m) + => Response -> Proxy ct -> m a +decodedAs response ct = do + responseContentType <- checkContentTypeHeader response + unless (any (matches responseContentType) accept) $ + throwClientError $ UnsupportedContentType responseContentType response + case mimeUnrender ct $ responseBody response of + Left err -> throwClientError $ DecodeFailure (T.pack err) response + Right val -> return val + where + accept = toList $ contentTypes ct diff --git a/src/Servant/Client/Core/Internal.hs b/src/Servant/Client/Core/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Internal.hs @@ -0,0 +1,12 @@ +module Servant.Client.Core.Internal where + +import Control.DeepSeq + (rnf) +import Network.HTTP.Media + (MediaType, mainType, parameters, subType) + +mediaTypeRnf :: MediaType -> () +mediaTypeRnf mt = + rnf (mainType mt) `seq` + rnf (subType mt) `seq` + rnf (parameters mt) diff --git a/src/Servant/Client/Core/Internal/Auth.hs b/src/Servant/Client/Core/Internal/Auth.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/Auth.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} - --- | Authentication for clients - -module Servant.Client.Core.Internal.Auth where - -import Servant.Client.Core.Internal.Request - (Request) - --- | For a resource protected by authentication (e.g. AuthProtect), we need --- to provide the client with some data used to add authentication data --- to a request --- --- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -type family AuthClientData a :: * - --- | For better type inference and to avoid usage of a data family, we newtype --- wrap the combination of some 'AuthClientData' and a function to add authentication --- data to a request --- --- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -newtype AuthenticatedRequest a = - AuthenticatedRequest { 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 -mkAuthenticatedRequest :: AuthClientData a - -> (AuthClientData a -> Request -> Request) - -> AuthenticatedRequest a -mkAuthenticatedRequest val func = AuthenticatedRequest (val, func) diff --git a/src/Servant/Client/Core/Internal/BaseUrl.hs b/src/Servant/Client/Core/Internal/BaseUrl.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/BaseUrl.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE ViewPatterns #-} -module Servant.Client.Core.Internal.BaseUrl where - -import Control.Monad.Catch - (Exception, MonadThrow, throwM) -import Data.Aeson - (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..)) -import Data.Aeson.Types - (FromJSONKeyFunction (..), contramapToJSONKeyFunction, - withText) -import Data.Data - (Data) -import Data.List -import qualified Data.Text as T -import GHC.Generics -import Language.Haskell.TH.Syntax - (Lift) -import Network.URI hiding - (path) -import Safe -import Text.Read - --- | URI scheme to use -data Scheme = - Http -- ^ http:// - | Https -- ^ https:// - deriving (Show, Eq, Ord, Generic, Lift, Data) - --- | 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) - , baseUrlPath :: String -- ^ path (eg "/a/b/c") - } deriving (Show, Ord, Generic, Lift, Data) --- TODO: Ord is more precise than Eq --- TODO: Add Hashable instance? - -instance Eq BaseUrl where - BaseUrl a b c path == BaseUrl a' b' c' path' - = a == a' && b == b' && c == c' && s path == s path' - where s ('/':x) = x - s x = x - --- | >>> traverse_ (LBS8.putStrLn . encode) $ parseBaseUrl "api.example.com" --- "http://api.example.com" -instance ToJSON BaseUrl where - toJSON = toJSON . showBaseUrl - toEncoding = toEncoding . showBaseUrl - --- | >>> parseBaseUrl "api.example.com" >>= decode . encode :: Maybe BaseUrl --- Just (BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""}) -instance FromJSON BaseUrl where - parseJSON = withText "BaseUrl" $ \t -> case parseBaseUrl (T.unpack t) of - Just u -> return u - Nothing -> fail $ "Invalid base url: " ++ T.unpack t - --- | >>> :{ --- traverse_ (LBS8.putStrLn . encode) $ do --- u1 <- parseBaseUrl "api.example.com" --- u2 <- parseBaseUrl "example.com" --- return $ Map.fromList [(u1, 'x'), (u2, 'y')] --- :} --- {"http://api.example.com":"x","http://example.com":"y"} -instance ToJSONKey BaseUrl where - toJSONKey = contramapToJSONKeyFunction showBaseUrl toJSONKey - -instance FromJSONKey BaseUrl where - fromJSONKey = FromJSONKeyTextParser $ \t -> case parseBaseUrl (T.unpack t) of - Just u -> return u - Nothing -> fail $ "Invalid base url: " ++ T.unpack t - --- | >>> showBaseUrl <$> parseBaseUrl "api.example.com" --- "http://api.example.com" -showBaseUrl :: BaseUrl -> String -showBaseUrl (BaseUrl urlscheme host port path) = - schemeString ++ "//" ++ host ++ (portString path) - where - a b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b - schemeString = case urlscheme of - Http -> "http:" - Https -> "https:" - portString = case (urlscheme, port) of - (Http, 80) -> "" - (Https, 443) -> "" - _ -> ":" ++ show port - -newtype InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show) -instance Exception InvalidBaseUrlException - --- | --- --- >>> parseBaseUrl "api.example.com" --- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""} --- --- /Note:/ trailing slash is removed --- --- >>> parseBaseUrl "api.example.com/" --- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""} --- --- >>> parseBaseUrl "api.example.com/dir/" --- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = "/dir"} --- -parseBaseUrl :: MonadThrow m => String -> m 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)))) path "" "") -> - return (BaseUrl Http host port path) - Just (URI "http:" (Just (URIAuth "" host "")) path "" "") -> - return (BaseUrl Http host 80 path) - Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") -> - return (BaseUrl Https host port path) - Just (URI "https:" (Just (URIAuth "" host "")) path "" "") -> - return (BaseUrl Https host 443 path) - _ -> if "://" `isInfixOf` s - then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s) - else parseBaseUrl ("http://" ++ s) - where - removeTrailingSlash str = case lastMay str of - Just '/' -> init str - _ -> str - --- $setup --- --- >>> import Data.Aeson --- >>> import Data.Foldable (traverse_) --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 --- >>> import qualified Data.Map.Strict as Map diff --git a/src/Servant/Client/Core/Internal/BasicAuth.hs b/src/Servant/Client/Core/Internal/BasicAuth.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/BasicAuth.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} - --- | Basic Authentication for clients - -module Servant.Client.Core.Internal.BasicAuth where - -import Data.ByteString.Base64 - (encode) -import Data.Monoid - ((<>)) -import Data.Text.Encoding - (decodeUtf8) -import Servant.API.BasicAuth - (BasicAuthData (BasicAuthData)) -import Servant.Client.Core.Internal.Request - (Request, addHeader) - --- | Authenticate a request using Basic Authentication -basicAuthReq :: BasicAuthData -> Request -> Request -basicAuthReq (BasicAuthData user pass) req = - let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass)) - in addHeader "Authorization" authText req diff --git a/src/Servant/Client/Core/Internal/ClientF.hs b/src/Servant/Client/Core/Internal/ClientF.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/ClientF.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Servant.Client.Core.Internal.ClientF where - -import Servant.Client.Core.Internal.Request - -data ClientF a - = RunRequest Request (Response -> a) - | StreamingRequest Request (StreamingResponse -> a) - | Throw ServantError - deriving (Functor) diff --git a/src/Servant/Client/Core/Internal/Generic.hs b/src/Servant/Client/Core/Internal/Generic.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/Generic.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Servant.Client.Core.Internal.Generic where - -import Generics.SOP - (Code, Generic, I (..), NP (..), NS (Z), SOP (..), to) -import Servant.API - ((:<|>) (..)) - --- | This class allows us to match client structure with client functions --- produced with 'client' without explicit pattern-matching. --- --- The client structure needs a 'Generics.SOP.Generic' instance. --- --- Example: --- --- > type API --- > = "foo" :> Capture "x" Int :> Get '[JSON] Int --- > :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int] --- > :<|> Capture "nested" Int :> NestedAPI --- > --- > type NestedAPI --- > = Get '[JSON] String --- > :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] () --- > --- > data APIClient = APIClient --- > { getFoo :: Int -> ClientM Int --- > , postBar :: Maybe Char -> Maybe String -> ClientM [Int] --- > , mkNestedClient :: Int -> NestedClient --- > } deriving GHC.Generic --- > --- > instance Generics.SOP.Generic APIClient --- > instance (Client API ~ client) => ClientLike client APIClient --- > --- > data NestedClient = NestedClient --- > { getString :: ClientM String --- > , postBaz :: Maybe Char -> ClientM () --- > } deriving GHC.Generic --- > --- > instance Generics.SOP.Generic NestedClient --- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient --- > --- > mkAPIClient :: APIClient --- > mkAPIClient = mkClient (client (Proxy :: Proxy API)) --- --- By default, left-nested alternatives are expanded: --- --- > type API1 --- > = "foo" :> Capture "x" Int :> Get '[JSON] Int --- > :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String --- > --- > type API2 --- > = "baz" :> QueryParam "c" Char :> Post '[JSON] () --- > --- > type API = API1 :<|> API2 --- > --- > data APIClient = APIClient --- > { getFoo :: Int -> ClientM Int --- > , postBar :: Maybe Char -> ClientM String --- > , postBaz :: Maybe Char -> ClientM () --- > } deriving GHC.Generic --- > --- > instance Generics.SOP.Generic APIClient --- > instance (Client API ~ client) => ClientLike client APIClient --- > --- > mkAPIClient :: APIClient --- > mkAPIClient = mkClient (client (Proxy :: Proxy API)) --- --- If you want to define client for @API1@ as a separate data structure, --- you can use 'genericMkClientP': --- --- > data APIClient1 = APIClient1 --- > { getFoo :: Int -> ClientM Int --- > , postBar :: Maybe Char -> ClientM String --- > } deriving GHC.Generic --- > --- > instance Generics.SOP.Generic APIClient1 --- > instance (Client API1 ~ client) => ClientLike client APIClient1 --- > --- > data APIClient = APIClient --- > { mkAPIClient1 :: APIClient1 --- > , postBaz :: Maybe Char -> ClientM () --- > } deriving GHC.Generic --- > --- > instance Generics.SOP.Generic APIClient --- > instance (Client API ~ client) => ClientLike client APIClient where --- > mkClient = genericMkClientP --- > --- > mkAPIClient :: APIClient --- > mkAPIClient = mkClient (client (Proxy :: Proxy API)) -class ClientLike client custom where - mkClient :: client -> custom - default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs) - => client -> custom - mkClient = genericMkClientL - -instance ClientLike client custom - => ClientLike (a -> client) (a -> custom) where - mkClient c = mkClient . c - --- | Match client structure with client functions, regarding left-nested API clients --- as separate data structures. -class GClientLikeP client xs where - gMkClientP :: client -> NP I xs - -instance (GClientLikeP b (y ': xs), ClientLike a x) - => GClientLikeP (a :<|> b) (x ': y ': xs) where - gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b - -instance ClientLike a x => GClientLikeP a '[x] where - gMkClientP a = I (mkClient a) :* Nil - --- | Match client structure with client functions, expanding left-nested API clients --- in the same structure. -class GClientLikeL (xs :: [*]) (ys :: [*]) where - gMkClientL :: NP I xs -> NP I ys - -instance GClientLikeL '[] '[] where - gMkClientL Nil = Nil - -instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where - gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs - -type family ClientList (client :: *) (acc :: [*]) :: [*] where - ClientList (a :<|> b) acc = ClientList a (ClientList b acc) - ClientList a acc = a ': acc - -class GClientList client (acc :: [*]) where - gClientList :: client -> NP I acc -> NP I (ClientList client acc) - -instance (GClientList b acc, GClientList a (ClientList b acc)) - => GClientList (a :<|> b) acc where - gClientList (a :<|> b) acc = gClientList a (gClientList b acc) - -instance {-# OVERLAPPABLE #-} (ClientList client acc ~ (client ': acc)) - => GClientList client acc where - gClientList c acc = I c :* acc - --- | Generate client structure from client type, expanding left-nested API (done by default). -genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs) - => client -> custom -genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil - --- | Generate client structure from client type, regarding left-nested API clients as separate data structures. -genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs) - => client -> custom -genericMkClientP = to . SOP . Z . gMkClientP - diff --git a/src/Servant/Client/Core/Internal/HasClient.hs b/src/Servant/Client/Core/Internal/HasClient.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/HasClient.hs +++ /dev/null @@ -1,633 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Servant.Client.Core.Internal.HasClient where - -import Prelude () -import Prelude.Compat - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import Data.Foldable - (toList) -import Data.List - (foldl') -import Data.Proxy - (Proxy (Proxy)) -import Data.Sequence - (fromList) -import Data.String - (fromString) -import Data.Text - (Text, pack) -import GHC.TypeLits - (KnownSymbol, symbolVal) -import qualified Network.HTTP.Types as H -import Servant.API - ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData, - BuildHeadersTo (..), Capture', CaptureAll, Description, - EmptyAPI, FramingUnrender (..), FromSourceIO (..), Header', - Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender), - MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag, - QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost, - ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, - Vault, Verb, WithNamedContext, contentType, getHeadersHList, - getResponse, toQueryParam, toUrlPiece) -import Servant.API.ContentTypes - (contentTypes) -import Servant.API.Modifiers - (FoldRequired, RequiredArgument, foldRequiredArgument) -import qualified Servant.Types.SourceT as S - -import Servant.Client.Core.Internal.Auth -import Servant.Client.Core.Internal.BasicAuth -import Servant.Client.Core.Internal.Request -import Servant.Client.Core.Internal.RunClient - --- * Accessing APIs as a Client - --- | 'clientIn' allows you to produce operations to query an API from a client --- within a 'RunClient' monad. --- --- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > clientM :: Proxy ClientM --- > clientM = Proxy --- > --- > getAllBooks :: ClientM [Book] --- > postNewBook :: Book -> ClientM Book --- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM -clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api -clientIn p pm = clientWithRoute pm p defaultRequest - - --- | This class lets us define how each API combinator influences the creation --- of an HTTP request. --- --- Unless you are writing a new backend for @servant-client-core@ or new --- combinators that you want to support client-generation, you can ignore this --- class. -class RunClient m => HasClient m api where - type Client (m :: * -> *) (api :: *) :: * - clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api - hoistClientMonad - :: Proxy m - -> Proxy api - -> (forall x. mon x -> mon' x) - -> Client mon api - -> Client mon' api - - --- | 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 :: ClientM [Book] --- > postNewBook :: Book -> ClientM Book --- > (getAllBooks :<|> postNewBook) = client myApi -instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where - type Client m (a :<|> b) = Client m a :<|> Client m b - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy a) req :<|> - clientWithRoute pm (Proxy :: Proxy b) req - - hoistClientMonad pm _ f (ca :<|> cb) = - hoistClientMonad pm (Proxy :: Proxy a) f ca :<|> - hoistClientMonad pm (Proxy :: Proxy b) f cb - --- | Singleton type representing a client for an empty API. -data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) - --- | The client for 'EmptyAPI' is simply 'EmptyClient'. --- --- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "nothing" :> EmptyAPI --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getAllBooks :: ClientM [Book] --- > (getAllBooks :<|> EmptyClient) = client myApi -instance RunClient m => HasClient m EmptyAPI where - type Client m EmptyAPI = EmptyClient - clientWithRoute _pm Proxy _ = EmptyClient - hoistClientMonad _ _ _ EmptyClient = EmptyClient - --- | 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 'ToHttpApiData' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBook :: Text -> ClientM Book --- > getBook = client myApi --- > -- then you can just use "getBook" to query that endpoint -instance (KnownSymbol capture, ToHttpApiData a, HasClient m api) - => HasClient m (Capture' mods capture a :> api) where - - type Client m (Capture' mods capture a :> api) = - a -> Client m api - - clientWithRoute pm Proxy req val = - clientWithRoute pm (Proxy :: Proxy api) - (appendToPath p req) - - where p = (toUrlPiece val) - - hoistClientMonad pm _ f cl = \a -> - hoistClientMonad pm (Proxy :: Proxy api) f (cl a) - --- | If you use a 'CaptureAll' in one of your endpoints in your API, --- the corresponding querying function will automatically take an --- additional argument of a list of the type specified by your --- 'CaptureAll'. 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 these values are turned into text by specifying --- a 'ToHttpApiData' instance of your type. --- --- Example: --- --- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile --- > --- > myApi :: Proxy --- > myApi = Proxy --- --- > getSourceFile :: [Text] -> ClientM SourceFile --- > getSourceFile = client myApi --- > -- then you can use "getSourceFile" to query that endpoint -instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout) - => HasClient m (CaptureAll capture a :> sublayout) where - - type Client m (CaptureAll capture a :> sublayout) = - [a] -> Client m sublayout - - clientWithRoute pm Proxy req vals = - clientWithRoute pm (Proxy :: Proxy sublayout) - (foldl' (flip appendToPath) req ps) - - where ps = map (toUrlPiece) vals - - hoistClientMonad pm _ f cl = \as -> - hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as) - -instance {-# OVERLAPPABLE #-} - -- Note [Non-Empty Content Types] - ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) - ) => HasClient m (Verb method status cts' a) where - type Client m (Verb method status cts' a) = m a - clientWithRoute _pm Proxy req = do - response <- runRequest req - { requestAccept = fromList $ toList accept - , requestMethod = method - } - response `decodedAs` (Proxy :: Proxy ct) - where - accept = contentTypes (Proxy :: Proxy ct) - method = reflectMethod (Proxy :: Proxy method) - - hoistClientMonad _ _ f ma = f ma - -instance {-# OVERLAPPING #-} - ( RunClient m, ReflectMethod method - ) => HasClient m (Verb method status cts NoContent) where - type Client m (Verb method status cts NoContent) - = m NoContent - clientWithRoute _pm Proxy req = do - _response <- runRequest req { requestMethod = method } - return NoContent - where method = reflectMethod (Proxy :: Proxy method) - - hoistClientMonad _ _ f ma = f ma - -instance {-# OVERLAPPING #-} - -- Note [Non-Empty Content Types] - ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls - , ReflectMethod method, cts' ~ (ct ': cts) - ) => HasClient m (Verb method status cts' (Headers ls a)) where - type Client m (Verb method status cts' (Headers ls a)) - = m (Headers ls a) - clientWithRoute _pm Proxy req = do - response <- runRequest req - { requestMethod = method - , requestAccept = fromList $ toList accept - } - case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of - Left err -> throwServantError $ DecodeFailure (pack err) response - Right val -> return $ Headers - { getResponse = val - , getHeadersHList = buildHeadersTo . toList $ responseHeaders response - } - where method = reflectMethod (Proxy :: Proxy method) - accept = contentTypes (Proxy :: Proxy ct) - - hoistClientMonad _ _ f ma = f ma - -instance {-# OVERLAPPING #-} - ( RunClient m, BuildHeadersTo ls, ReflectMethod method - ) => HasClient m (Verb method status cts (Headers ls NoContent)) where - type Client m (Verb method status cts (Headers ls NoContent)) - = m (Headers ls NoContent) - clientWithRoute _pm Proxy req = do - let method = reflectMethod (Proxy :: Proxy method) - response <- runRequest req { requestMethod = method } - return $ Headers { getResponse = NoContent - , getHeadersHList = buildHeadersTo . toList $ responseHeaders response - } - - hoistClientMonad _ _ f ma = f ma - -instance {-# OVERLAPPABLE #-} - ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method, - FramingUnrender framing, FromSourceIO chunk a - ) => HasClient m (Stream method status framing ct a) where - - type Client m (Stream method status framing ct a) = m a - - hoistClientMonad _ _ f ma = f ma - - clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do - let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk - framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' - return $ fromSourceIO $ framingUnrender' $ S.fromAction BS.null (responseBody gres) - where - req' = req - { requestAccept = fromList [contentType (Proxy :: Proxy ct)] - , requestMethod = reflectMethod (Proxy :: Proxy method) - } - --- | 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 'ToHttpApiData' instance. --- --- Example: --- --- > newtype Referer = Referer { referrer :: Text } --- > deriving (Eq, Show, Generic, ToHttpApiData) --- > --- > -- GET /view-my-referer --- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > viewReferer :: Maybe Referer -> ClientM Book --- > viewReferer = client myApi --- > -- then you can just use "viewRefer" to query that endpoint --- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments -instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods)) - => HasClient m (Header' mods sym a :> api) where - - type Client m (Header' mods sym a :> api) = - RequiredArgument mods a -> Client m api - - clientWithRoute pm Proxy req mval = - clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument - (Proxy :: Proxy mods) add (maybe req add) mval - where - hname = fromString $ symbolVal (Proxy :: Proxy sym) - - add :: a -> Request - add value = addHeader hname value req - - hoistClientMonad pm _ f cl = \arg -> - hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) - --- | Using a 'HttpVersion' combinator in your API doesn't affect the client --- functions. -instance HasClient m api - => HasClient m (HttpVersion :> api) where - - type Client m (HttpVersion :> api) = - Client m api - - clientWithRoute pm Proxy = - clientWithRoute pm (Proxy :: Proxy api) - - hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl - --- | Ignore @'Summary'@ in client functions. -instance HasClient m api => HasClient m (Summary desc :> api) where - type Client m (Summary desc :> api) = Client m api - - clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) - - hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl - --- | Ignore @'Description'@ in client functions. -instance HasClient m api => HasClient m (Description desc :> api) where - type Client m (Description desc :> api) = Client m api - - clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) - - hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl - --- | 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 'ToHttpApiData' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooksBy :: Maybe Text -> ClientM [Book] --- > getBooksBy = client myApi --- > -- 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, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods)) - => HasClient m (QueryParam' mods sym a :> api) where - - type Client m (QueryParam' mods sym a :> api) = - RequiredArgument mods a -> Client m api - - -- if mparam = Nothing, we don't add it to the query string - clientWithRoute pm Proxy req mparam = - clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument - (Proxy :: Proxy mods) add (maybe req add) mparam - where - add :: a -> Request - add param = appendToQueryString pname (Just $ toQueryParam param) req - - pname :: Text - pname = pack $ symbolVal (Proxy :: Proxy sym) - - hoistClientMonad pm _ f cl = \arg -> - hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) - --- | 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 'ToHttpApiData' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooksBy :: [Text] -> ClientM [Book] --- > getBooksBy = client myApi --- > -- 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, ToHttpApiData a, HasClient m api) - => HasClient m (QueryParams sym a :> api) where - - type Client m (QueryParams sym a :> api) = - [a] -> Client m api - - clientWithRoute pm Proxy req paramlist = - clientWithRoute pm (Proxy :: Proxy api) - (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) - req - paramlist' - ) - - where pname = pack $ symbolVal (Proxy :: Proxy sym) - paramlist' = map (Just . toQueryParam) paramlist - - hoistClientMonad pm _ f cl = \as -> - hoistClientMonad pm (Proxy :: Proxy api) f (cl as) - --- | 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 -> ClientM [Book] --- > getBooks = client myApi --- > -- 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 m api) - => HasClient m (QueryFlag sym :> api) where - - type Client m (QueryFlag sym :> api) = - Bool -> Client m api - - clientWithRoute pm Proxy req flag = - clientWithRoute pm (Proxy :: Proxy api) - (if flag - then appendToQueryString paramname Nothing req - else req - ) - - where paramname = pack $ symbolVal (Proxy :: Proxy sym) - - hoistClientMonad pm _ f cl = \b -> - hoistClientMonad pm (Proxy :: Proxy api) f (cl b) - --- | Pick a 'Method' and specify where the server you want to query is. You get --- back the full `Response`. -instance RunClient m => HasClient m Raw where - type Client m Raw - = H.Method -> m Response - - clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw - clientWithRoute _pm Proxy req httpMethod = do - runRequest req { requestMethod = httpMethod } - - hoistClientMonad _ _ f cl = \meth -> f (cl meth) - --- | 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 -> ClientM Book --- > addBook = client myApi --- > -- then you can just use "addBook" to query that endpoint -instance (MimeRender ct a, HasClient m api) - => HasClient m (ReqBody' mods (ct ': cts) a :> api) where - - type Client m (ReqBody' mods (ct ': cts) a :> api) = - a -> Client m api - - clientWithRoute pm Proxy req body = - clientWithRoute pm (Proxy :: Proxy api) - (let ctProxy = Proxy :: Proxy ct - in setRequestBodyLBS (mimeRender ctProxy body) - -- We use first contentType from the Accept list - (contentType ctProxy) - req - ) - - hoistClientMonad pm _ f cl = \a -> - hoistClientMonad pm (Proxy :: Proxy api) f (cl a) - -instance - ( HasClient m api - ) => HasClient m (StreamBody' mods framing ctype a :> api) - where - - type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api - - hoistClientMonad pm _ f cl = \a -> - hoistClientMonad pm (Proxy :: Proxy api) f (cl a) - - clientWithRoute _pm Proxy _req _body = error "HasClient @StreamBody" - --- | Make the querying function append @path@ to the request path. -instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where - type Client m (path :> api) = Client m api - - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy api) - (appendToPath p req) - - where p = pack $ symbolVal (Proxy :: Proxy path) - - hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl - -instance HasClient m api => HasClient m (Vault :> api) where - type Client m (Vault :> api) = Client m api - - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy api) req - - hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl - -instance HasClient m api => HasClient m (RemoteHost :> api) where - type Client m (RemoteHost :> api) = Client m api - - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy api) req - - hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl - -instance HasClient m api => HasClient m (IsSecure :> api) where - type Client m (IsSecure :> api) = Client m api - - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy api) req - - hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl - -instance HasClient m subapi => - HasClient m (WithNamedContext name context subapi) where - - type Client m (WithNamedContext name context subapi) = Client m subapi - clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi) - - hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl - -instance ( HasClient m api - ) => HasClient m (AuthProtect tag :> api) where - type Client m (AuthProtect tag :> api) - = AuthenticatedRequest (AuthProtect tag) -> Client m api - - clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) = - clientWithRoute pm (Proxy :: Proxy api) (func val req) - - hoistClientMonad pm _ f cl = \authreq -> - hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq) - --- * Basic Authentication - -instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where - type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api - - clientWithRoute pm Proxy req val = - clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req) - - hoistClientMonad pm _ f cl = \bauth -> - hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth) - - -{- Note [Non-Empty Content Types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Rather than have - - instance (..., cts' ~ (ct ': cts)) => ... cts' ... - -It may seem to make more sense to have: - - instance (...) => ... (ct ': cts) ... - -But this means that if another instance exists that does *not* require -non-empty lists, but is otherwise more specific, no instance will be overall -more specific. This in turn generally means adding yet another instance (one -for empty and one for non-empty lists). --} diff --git a/src/Servant/Client/Core/Internal/Request.hs b/src/Servant/Client/Core/Internal/Request.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/Request.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module Servant.Client.Core.Internal.Request where - -import Prelude () -import Prelude.Compat - -import Control.DeepSeq - (NFData (..)) -import Control.Monad.Catch - (Exception) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString.Lazy as LBS -import Data.Int - (Int64) -import Data.Semigroup - ((<>)) -import qualified Data.Sequence as Seq -import Data.Text - (Text) -import Data.Text.Encoding - (encodeUtf8) -import Data.Typeable - (Typeable) -import GHC.Generics - (Generic) -import Network.HTTP.Media - (MediaType, mainType, parameters, subType) -import Network.HTTP.Types - (Header, HeaderName, HttpVersion (..), Method, QueryItem, - Status (..), http11, methodGet) -import Servant.API - (ToHttpApiData, toEncodedUrlPiece, toHeader) - --- | A type representing possible errors in a request --- --- Note that this type substantially changed in 0.12. -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) - -instance Exception ServantError - -instance NFData ServantError where - rnf (FailureResponse res) = rnf res - rnf (DecodeFailure err res) = rnf err `seq` rnf res - rnf (UnsupportedContentType mt' res) = - mediaTypeRnf mt' `seq` - rnf res - where - mediaTypeRnf mt = - rnf (mainType mt) `seq` - rnf (subType mt) `seq` - rnf (parameters mt) - rnf (InvalidContentTypeHeader res) = rnf res - rnf (ConnectionError err) = rnf err - -data RequestF a = Request - { requestPath :: a - , requestQueryString :: Seq.Seq QueryItem - , requestBody :: Maybe (RequestBody, MediaType) - , requestAccept :: Seq.Seq MediaType - , requestHeaders :: Seq.Seq Header - , requestHttpVersion :: HttpVersion - , requestMethod :: Method - } deriving (Generic, Typeable) - -type Request = RequestF Builder.Builder - --- | The request body. A replica of the @http-client@ @RequestBody@. -data RequestBody - = RequestBodyLBS LBS.ByteString - | RequestBodyBS BS.ByteString - | RequestBodyBuilder Int64 Builder.Builder - | RequestBodyStream Int64 ((IO BS.ByteString -> IO ()) -> IO ()) - | RequestBodyStreamChunked ((IO BS.ByteString -> IO ()) -> IO ()) - | RequestBodyIO (IO RequestBody) - deriving (Generic, Typeable) - -data GenResponse a = Response - { responseStatusCode :: Status - , responseHeaders :: Seq.Seq Header - , responseHttpVersion :: HttpVersion - , responseBody :: a - } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable) - -instance NFData a => NFData (GenResponse a) where - rnf (Response sc hs hv body) = - rnfStatus sc `seq` - rnf hs `seq` - rnfHttpVersion hv `seq` - rnf body - where - rnfStatus (Status code msg) = rnf code `seq` rnf msg - rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict - -type Response = GenResponse LBS.ByteString -type StreamingResponse = GenResponse (IO BS.ByteString) - --- A GET request to the top-level path -defaultRequest :: Request -defaultRequest = Request - { requestPath = "" - , requestQueryString = Seq.empty - , requestBody = Nothing - , requestAccept = Seq.empty - , requestHeaders = Seq.empty - , requestHttpVersion = http11 - , requestMethod = methodGet - } - -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.|> (encodeUtf8 pname, encodeUtf8 <$> 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) } diff --git a/src/Servant/Client/Core/Internal/RunClient.hs b/src/Servant/Client/Core/Internal/RunClient.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/RunClient.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | Types for possible backends to run client-side `Request` queries -module Servant.Client.Core.Internal.RunClient where - -import Prelude () -import Prelude.Compat - -import Control.Monad - (unless) -import Control.Monad.Free - (Free (..), liftF) -import Data.Foldable - (toList) -import Data.Proxy - (Proxy) -import qualified Data.Text as T -import Network.HTTP.Media - (MediaType, matches, parseAccept, (//)) -import Servant.API - (MimeUnrender, contentTypes, mimeUnrender) - -import Servant.Client.Core.Internal.ClientF -import Servant.Client.Core.Internal.Request - (GenResponse (..), Request, Response, ServantError (..), - StreamingResponse) - -class Monad m => RunClient m where - -- | How to make a request. - runRequest :: Request -> m Response - throwServantError :: ServantError -> m a - -class RunClient m => RunStreamingClient m where - withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a - -checkContentTypeHeader :: RunClient m => Response -> m MediaType -checkContentTypeHeader response = - case lookup "Content-Type" $ toList $ responseHeaders response of - Nothing -> return $ "application"//"octet-stream" - Just t -> case parseAccept t of - Nothing -> throwServantError $ InvalidContentTypeHeader response - Just t' -> return t' - -decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m) - => Response -> Proxy ct -> m a -decodedAs response contentType = do - responseContentType <- checkContentTypeHeader response - unless (any (matches responseContentType) accept) $ - throwServantError $ UnsupportedContentType responseContentType response - case mimeUnrender contentType $ responseBody response of - Left err -> throwServantError $ DecodeFailure (T.pack err) response - Right val -> return val - where - accept = toList $ contentTypes contentType - -instance ClientF ~ f => RunClient (Free f) where - runRequest req = liftF (RunRequest req id) - throwServantError = liftF . Throw - -{- -Free and streaming? -instance ClientF ~ f => RunStreamingClient (Free f) where - streamingRequest req = liftF (StreamingRequest req id) --} diff --git a/src/Servant/Client/Core/Reexport.hs b/src/Servant/Client/Core/Reexport.hs --- a/src/Servant/Client/Core/Reexport.hs +++ b/src/Servant/Client/Core/Reexport.hs @@ -9,13 +9,10 @@ -- * Response (for @Raw@) , Response , StreamingResponse - , GenResponse(..) + , ResponseF(..) - -- * Generic Client - , ClientLike(..) - , genericMkClientL - , genericMkClientP - , ServantError(..) + -- * Data types + , ClientError(..) , EmptyClient(..) -- * BaseUrl @@ -27,7 +24,7 @@ ) where -import Servant.Client.Core.Internal.BaseUrl -import Servant.Client.Core.Internal.Generic -import Servant.Client.Core.Internal.HasClient -import Servant.Client.Core.Internal.Request +import Servant.Client.Core.BaseUrl +import Servant.Client.Core.HasClient +import Servant.Client.Core.Response +import Servant.Client.Core.ClientError diff --git a/src/Servant/Client/Core/Request.hs b/src/Servant/Client/Core/Request.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Request.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Servant.Client.Core.Request ( + Request, + RequestF (..), + RequestBody (..), + defaultRequest, + -- ** Modifiers + addHeader, + appendToPath, + appendToQueryString, + setRequestBody, + setRequestBodyLBS, + ) where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq + (NFData (..)) +import Data.Bifoldable + (Bifoldable (..)) +import Data.Bifunctor + (Bifunctor (..)) +import Data.Bitraversable + (Bitraversable (..), bifoldMapDefault, bimapDefault) +import qualified Data.ByteString as BS +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.Text + (Text) +import Data.Text.Encoding + (encodeUtf8) +import Data.Typeable + (Typeable) +import GHC.Generics + (Generic) +import Network.HTTP.Media + (MediaType) +import Network.HTTP.Types + (Header, HeaderName, HttpVersion (..), Method, QueryItem, + http11, methodGet) +import Servant.API + (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO) + +import Servant.Client.Core.Internal (mediaTypeRnf) + +data RequestF body path = Request + { requestPath :: path + , requestQueryString :: Seq.Seq QueryItem + , requestBody :: Maybe (body, MediaType) + , requestAccept :: Seq.Seq MediaType + , requestHeaders :: Seq.Seq Header + , requestHttpVersion :: HttpVersion + , requestMethod :: Method + } deriving (Generic, Typeable, Eq, Show, Functor, Foldable, Traversable) + +instance Bifunctor RequestF where bimap = bimapDefault +instance Bifoldable RequestF where bifoldMap = bifoldMapDefault +instance Bitraversable RequestF where + bitraverse f g r = mk + <$> traverse (bitraverse f pure) (requestBody r) + <*> g (requestPath r) + where + mk b p = r { requestBody = b, requestPath = p } + +instance (NFData path, NFData body) => NFData (RequestF body path) where + rnf r = + rnf (requestPath r) + `seq` rnf (requestQueryString r) + `seq` rnfB (requestBody r) + `seq` rnf (fmap mediaTypeRnf (requestAccept r)) + `seq` rnf (requestHeaders r) + `seq` requestHttpVersion r + `seq` rnf (requestMethod r) + where + rnfB Nothing = () + rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt + +type Request = RequestF RequestBody Builder.Builder + +-- | The request body. R replica of the @http-client@ @RequestBody@. +data RequestBody + = RequestBodyLBS LBS.ByteString + | RequestBodyBS BS.ByteString + | RequestBodySource (SourceIO LBS.ByteString) + deriving (Generic, Typeable) + +instance Show RequestBody where + showsPrec d (RequestBodyLBS lbs) = showParen (d > 10) + $ showString "RequestBodyLBS " + . showsPrec 11 lbs + showsPrec d (RequestBodyBS bs) = showParen (d > 10) + $ showString "RequestBodyBS " + . showsPrec 11 bs + showsPrec d (RequestBodySource _) = showParen (d > 10) + $ showString "RequestBodySource " + +-- A GET request to the top-level path +defaultRequest :: Request +defaultRequest = Request + { requestPath = "" + , requestQueryString = Seq.empty + , requestBody = Nothing + , requestAccept = Seq.empty + , requestHeaders = Seq.empty + , requestHttpVersion = http11 + , requestMethod = methodGet + } + +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.|> (encodeUtf8 pname, encodeUtf8 <$> 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) } diff --git a/src/Servant/Client/Core/Response.hs b/src/Servant/Client/Core/Response.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Response.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Servant.Client.Core.Response ( + Response, + StreamingResponse, + ResponseF (..), + ) where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq + (NFData (..)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Sequence as Seq +import Data.Typeable + (Typeable) +import GHC.Generics + (Generic) +import Network.HTTP.Types + (Header, HttpVersion (..), Status (..)) + +import Servant.API.Stream + (SourceIO) + +data ResponseF a = Response + { responseStatusCode :: Status + , responseHeaders :: Seq.Seq Header + , responseHttpVersion :: HttpVersion + , responseBody :: a + } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable) + +instance NFData a => NFData (ResponseF a) where + rnf (Response sc hs hv body) = + rnfStatus sc `seq` + rnf hs `seq` + rnfHttpVersion hv `seq` + rnf body + where + rnfStatus (Status code msg) = rnf code `seq` rnf msg + rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict + +type Response = ResponseF LBS.ByteString +type StreamingResponse = ResponseF (SourceIO BS.ByteString) diff --git a/src/Servant/Client/Core/RunClient.hs b/src/Servant/Client/Core/RunClient.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/RunClient.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | Types for possible backends to run client-side `Request` queries +module Servant.Client.Core.RunClient ( + RunClient (..), + RunStreamingClient (..), + ClientF (..), + ) where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Free + (Free (..), liftF) + +import Servant.Client.Core.ClientError +import Servant.Client.Core.Request +import Servant.Client.Core.Response + +class Monad m => RunClient m where + -- | How to make a request. + runRequest :: Request -> m Response + throwClientError :: ClientError -> m a + +class RunClient m => RunStreamingClient m where + withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a + +------------------------------------------------------------------------------- +-- Free +------------------------------------------------------------------------------- + +-- | 'ClientF' cannot stream. +-- +-- Compare to 'RunClient'. +data ClientF a + = RunRequest Request (Response -> a) + | Throw ClientError + deriving (Functor) + +instance ClientF ~ f => RunClient (Free f) where + runRequest req = liftF (RunRequest req id) + throwClientError = liftF . Throw diff --git a/src/Servant/Client/Free.hs b/src/Servant/Client/Free.hs --- a/src/Servant/Client/Free.hs +++ b/src/Servant/Client/Free.hs @@ -11,8 +11,8 @@ import Data.Proxy (Proxy (..)) import Servant.Client.Core -import Servant.Client.Core.Internal.ClientF import Servant.Client.Core.Reexport +import Servant.Client.Core.RunClient client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api client api = api `clientIn` (Proxy :: Proxy (Free ClientF)) diff --git a/test/Servant/Client/Core/Internal/BaseUrlSpec.hs b/test/Servant/Client/Core/Internal/BaseUrlSpec.hs --- a/test/Servant/Client/Core/Internal/BaseUrlSpec.hs +++ b/test/Servant/Client/Core/Internal/BaseUrlSpec.hs @@ -8,7 +8,7 @@ import Test.Hspec import Test.QuickCheck -import Servant.Client.Core.Internal.BaseUrl +import Servant.Client.Core.BaseUrl spec :: Spec spec = do