2018-02-27 15:36:49 +01:00
|
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
|
|
{-# LANGUAGE DeriveFoldable #-}
|
|
|
|
{-# LANGUAGE DeriveFunctor #-}
|
|
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
|
|
{-# LANGUAGE DeriveTraversable #-}
|
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
2019-02-18 18:08:13 +01:00
|
|
|
module Servant.Client.Core.Request (
|
|
|
|
Request,
|
|
|
|
RequestF (..),
|
|
|
|
RequestBody (..),
|
|
|
|
defaultRequest,
|
|
|
|
-- ** Modifiers
|
|
|
|
addHeader,
|
|
|
|
appendToPath,
|
|
|
|
appendToQueryString,
|
|
|
|
setRequestBody,
|
|
|
|
setRequestBodyLBS,
|
|
|
|
) where
|
2017-09-06 23:13:05 +02:00
|
|
|
|
2018-06-30 21:17:08 +02:00
|
|
|
import Prelude ()
|
2017-09-06 23:13:05 +02:00
|
|
|
import Prelude.Compat
|
|
|
|
|
2018-11-09 18:43:55 +01:00
|
|
|
import Control.DeepSeq
|
|
|
|
(NFData (..))
|
2019-02-05 10:51:42 +01:00
|
|
|
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 qualified Data.Sequence as Seq
|
2018-06-30 21:17:08 +02:00
|
|
|
import Data.Text
|
|
|
|
(Text)
|
|
|
|
import Data.Text.Encoding
|
|
|
|
(encodeUtf8)
|
|
|
|
import Data.Typeable
|
2019-02-06 11:12:56 +01:00
|
|
|
(Typeable)
|
2018-06-30 21:17:08 +02:00
|
|
|
import GHC.Generics
|
|
|
|
(Generic)
|
|
|
|
import Network.HTTP.Media
|
2019-02-18 18:08:13 +01:00
|
|
|
(MediaType)
|
2018-06-30 21:17:08 +02:00
|
|
|
import Network.HTTP.Types
|
2018-11-09 18:43:55 +01:00
|
|
|
(Header, HeaderName, HttpVersion (..), Method, QueryItem,
|
2019-02-06 11:12:56 +01:00
|
|
|
http11, methodGet)
|
2018-11-13 15:51:18 +01:00
|
|
|
import Servant.API
|
2019-02-06 11:12:56 +01:00
|
|
|
(ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
|
2018-11-09 18:43:55 +01:00
|
|
|
|
2019-02-18 18:08:13 +01:00
|
|
|
import Servant.Client.Core.Internal (mediaTypeRnf)
|
2019-02-03 17:18:55 +01:00
|
|
|
|
2019-02-03 17:17:08 +01:00
|
|
|
data RequestF body path = Request
|
|
|
|
{ requestPath :: path
|
2017-09-06 23:13:05 +02:00
|
|
|
, requestQueryString :: Seq.Seq QueryItem
|
2019-02-05 10:51:42 +01:00
|
|
|
, requestBody :: Maybe (body, MediaType)
|
2017-09-06 23:13:05 +02:00
|
|
|
, requestAccept :: Seq.Seq MediaType
|
|
|
|
, requestHeaders :: Seq.Seq Header
|
|
|
|
, requestHttpVersion :: HttpVersion
|
2017-09-07 22:38:31 +02:00
|
|
|
, requestMethod :: Method
|
2019-11-05 16:31:06 +01:00
|
|
|
} deriving (Generic, Typeable, Eq, Functor, Foldable, Traversable)
|
2019-02-05 10:51:42 +01:00
|
|
|
|
2019-11-05 16:31:06 +01:00
|
|
|
instance (Show a, Show b) =>
|
|
|
|
Show (Servant.Client.Core.Request.RequestF a b) where
|
|
|
|
showsPrec p req
|
|
|
|
= showParen
|
|
|
|
(p >= 11)
|
|
|
|
( showString "Request {requestPath = "
|
|
|
|
. showsPrec 0 (requestPath req)
|
|
|
|
. showString ", requestQueryString = "
|
|
|
|
. showsPrec 0 (requestQueryString req)
|
|
|
|
. showString ", requestBody = "
|
|
|
|
. showsPrec 0 (requestBody req)
|
|
|
|
. showString ", requestAccept = "
|
|
|
|
. showsPrec 0 (requestAccept req)
|
|
|
|
. showString ", requestHeaders = "
|
|
|
|
. showsPrec 0 (redactSensitiveHeader <$> requestHeaders req))
|
|
|
|
. showString ", requestHttpVersion = "
|
|
|
|
. showsPrec 0 (requestHttpVersion req)
|
|
|
|
. showString ", requestMethod = "
|
|
|
|
. showsPrec 0 (requestMethod req)
|
|
|
|
. showString "}"
|
|
|
|
where
|
|
|
|
redactSensitiveHeader :: Header -> Header
|
|
|
|
redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")
|
|
|
|
redactSensitiveHeader h = h
|
2019-02-05 10:51:42 +01:00
|
|
|
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 }
|
2017-09-14 19:17:19 +02:00
|
|
|
|
2019-02-03 17:18:55 +01:00
|
|
|
instance (NFData path, NFData body) => NFData (RequestF body path) where
|
2019-02-05 10:51:42 +01:00
|
|
|
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
|
2019-02-03 17:17:08 +01:00
|
|
|
|
2019-02-05 10:51:42 +01:00
|
|
|
type Request = RequestF RequestBody Builder.Builder
|
2017-09-06 23:13:05 +02:00
|
|
|
|
2019-02-18 18:08:13 +01:00
|
|
|
-- | The request body. R replica of the @http-client@ @RequestBody@.
|
2018-02-27 15:36:49 +01:00
|
|
|
data RequestBody
|
|
|
|
= RequestBodyLBS LBS.ByteString
|
|
|
|
| RequestBodyBS BS.ByteString
|
2019-02-06 11:12:56 +01:00
|
|
|
| RequestBodySource (SourceIO LBS.ByteString)
|
2018-02-27 15:36:49 +01:00
|
|
|
deriving (Generic, Typeable)
|
2017-09-06 23:13:05 +02:00
|
|
|
|
2019-02-06 11:12:56 +01:00
|
|
|
instance Show RequestBody where
|
|
|
|
showsPrec d (RequestBodyLBS lbs) = showParen (d > 10)
|
|
|
|
$ showString "RequestBodyLBS "
|
|
|
|
. showsPrec 11 lbs
|
2019-02-18 18:08:13 +01:00
|
|
|
showsPrec d (RequestBodyBS bs) = showParen (d > 10)
|
|
|
|
$ showString "RequestBodyBS "
|
|
|
|
. showsPrec 11 bs
|
|
|
|
showsPrec d (RequestBodySource _) = showParen (d > 10)
|
|
|
|
$ showString "RequestBodySource <IO>"
|
2017-10-25 02:12:21 +02:00
|
|
|
|
2017-09-08 01:07:18 +02:00
|
|
|
-- A GET request to the top-level path
|
2017-09-06 23:13:05 +02:00
|
|
|
defaultRequest :: Request
|
|
|
|
defaultRequest = Request
|
|
|
|
{ requestPath = ""
|
|
|
|
, requestQueryString = Seq.empty
|
|
|
|
, requestBody = Nothing
|
|
|
|
, requestAccept = Seq.empty
|
|
|
|
, requestHeaders = Seq.empty
|
|
|
|
, requestHttpVersion = http11
|
2017-09-07 22:38:31 +02:00
|
|
|
, requestMethod = methodGet
|
2017-09-06 23:13:05 +02:00
|
|
|
}
|
|
|
|
|
|
|
|
appendToPath :: Text -> Request -> Request
|
|
|
|
appendToPath p req
|
|
|
|
= req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
|
|
|
|
|
2017-09-07 22:38:31 +02:00
|
|
|
appendToQueryString :: Text -- ^ param name
|
|
|
|
-> Maybe Text -- ^ param value
|
|
|
|
-> Request
|
|
|
|
-> Request
|
|
|
|
appendToQueryString pname pvalue req
|
|
|
|
= req { requestQueryString = requestQueryString req
|
|
|
|
Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}
|
2017-09-06 23:13:05 +02:00
|
|
|
|
|
|
|
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) }
|