mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-13 19:33:55 +03:00
Simplify Transformable Requests Module
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/8400 GitOrigin-RevId: 10728012c3d74e178c34b926e13d3627d514ce17
This commit is contained in:
Solomon
hasura-bot
parent
e3d76a8fe5
commit
cca1a92399
@ -15,9 +15,7 @@ import Hasura.HTTP qualified
|
||||
import Hasura.Logging (Hasura, Logger)
|
||||
import Hasura.Prelude
|
||||
import Hasura.Tracing (MonadTrace, traceHTTPRequest)
|
||||
import Network.HTTP.Client (Manager)
|
||||
import Network.HTTP.Client qualified as HTTP
|
||||
import Network.HTTP.Client.Transformable qualified as TransformableHTTP
|
||||
import Network.HTTP.Client.Transformable qualified as HTTP
|
||||
import Network.HTTP.Types.Status (Status)
|
||||
import Servant.Client
|
||||
import Servant.Client.Core (Request, RunClient (..))
|
||||
@ -26,7 +24,7 @@ import Servant.Client.Internal.HttpClient (clientResponseToResponse, mkFailureRe
|
||||
data AgentClientContext = AgentClientContext
|
||||
{ _accLogger :: Logger Hasura,
|
||||
_accBaseUrl :: BaseUrl,
|
||||
_accHttpManager :: Manager,
|
||||
_accHttpManager :: HTTP.Manager,
|
||||
_accResponseTimeout :: Maybe Int
|
||||
}
|
||||
|
||||
@ -46,28 +44,24 @@ instance (MonadIO m, MonadTrace m, MonadError QErr m) => RunClient (AgentClientT
|
||||
runRequestAcceptStatus' :: (MonadIO m, MonadTrace m, MonadError QErr m) => Maybe [Status] -> Request -> (AgentClientT m) Response
|
||||
runRequestAcceptStatus' acceptStatus req = do
|
||||
AgentClientContext {..} <- askClientContext
|
||||
let req' = defaultMakeClientRequest _accBaseUrl req
|
||||
|
||||
transformableReq <-
|
||||
TransformableHTTP.tryFromClientRequest req'
|
||||
`onLeft` (\err -> throw500 $ "Error in Data Connector backend: Could not create request. " <> err)
|
||||
let transformableReq = defaultMakeClientRequest _accBaseUrl req
|
||||
|
||||
-- Set the response timeout explicitly if it is provided
|
||||
let transformableReq' =
|
||||
transformableReq &~ do
|
||||
for _accResponseTimeout \x -> TransformableHTTP.timeout .= HTTP.responseTimeoutMicro x
|
||||
for _accResponseTimeout \x -> HTTP.timeout .= HTTP.responseTimeoutMicro x
|
||||
|
||||
(tracedReq, responseOrException) <- traceHTTPRequest transformableReq' \tracedReq ->
|
||||
fmap (tracedReq,) . liftIO . try @HTTP.HttpException $ TransformableHTTP.performRequest tracedReq _accHttpManager
|
||||
fmap (tracedReq,) . liftIO . try @HTTP.HttpException $ HTTP.httpLbs tracedReq _accHttpManager
|
||||
logAgentRequest _accLogger tracedReq responseOrException
|
||||
case responseOrException of
|
||||
-- throwConnectionError is used here in order to avoid a metadata inconsistency error
|
||||
Left ex -> throwConnectionError $ "Error in Data Connector backend: " <> Hasura.HTTP.serializeHTTPExceptionMessage (Hasura.HTTP.HttpException ex)
|
||||
Right response -> do
|
||||
let status = TransformableHTTP.responseStatus response
|
||||
let status = HTTP.responseStatus response
|
||||
servantResponse = clientResponseToResponse id response
|
||||
goodStatus = case acceptStatus of
|
||||
Nothing -> TransformableHTTP.statusIsSuccessful status
|
||||
Nothing -> HTTP.statusIsSuccessful status
|
||||
Just good -> status `elem` good
|
||||
if goodStatus
|
||||
then pure $ servantResponse
|
||||
|
||||
@ -4,7 +4,7 @@ module Hasura.Backends.DataConnector.Logging
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Control.Lens ((^.), (^?))
|
||||
import Data.Aeson (object, (.=))
|
||||
import Data.Aeson.Key qualified as K
|
||||
import Data.Aeson.KeyMap (KeyMap)
|
||||
@ -21,7 +21,7 @@ import Hasura.Prelude
|
||||
import Hasura.Tracing (MonadTrace)
|
||||
import Hasura.Tracing qualified as Tracing
|
||||
import Hasura.Tracing.TraceId (spanIdToHex, traceIdToHex)
|
||||
import Network.HTTP.Client.Transformable (Header, HttpException (..), Request, Response (..), body, headers, method, path, statusCode, url)
|
||||
import Network.HTTP.Client.Transformable qualified as HTTP
|
||||
import Servant.Client (ClientError (..), responseStatusCode, showBaseUrl)
|
||||
import Servant.Client.Core (RequestF (..))
|
||||
|
||||
@ -59,32 +59,33 @@ instance ToEngineLog AgentCommunicationLog Hasura where
|
||||
Just $ "spanId" .= _aclSpanId
|
||||
]
|
||||
|
||||
logAgentRequest :: (MonadIO m, MonadTrace m) => Logger Hasura -> Request -> Either HttpException (Response BSL.ByteString) -> m ()
|
||||
logAgentRequest :: (MonadIO m, MonadTrace m) => Logger Hasura -> HTTP.Request -> Either HTTP.HttpException (HTTP.Response BSL.ByteString) -> m ()
|
||||
logAgentRequest (Logger writeLog) req responseOrError = do
|
||||
traceCtx <- Tracing.currentContext
|
||||
let _aclRequest = Just $ extractRequestLogInfoFromClientRequest req
|
||||
_aclResponseStatusCode = case responseOrError of
|
||||
Right response -> Just . statusCode $ responseStatus response
|
||||
Right response -> Just . HTTP.statusCode $ HTTP.responseStatus response
|
||||
Left httpExn -> Hasura.HTTP.getHTTPExceptionStatus $ Hasura.HTTP.HttpException httpExn
|
||||
_aclError = either (Just . Hasura.HTTP.serializeHTTPExceptionMessageForDebugging) (const Nothing) responseOrError
|
||||
_aclTraceId = maybe "" (bsToTxt . traceIdToHex . Tracing.tcCurrentTrace) traceCtx
|
||||
_aclSpanId = maybe "" (bsToTxt . spanIdToHex . Tracing.tcCurrentSpan) traceCtx
|
||||
writeLog AgentCommunicationLog {..}
|
||||
|
||||
extractRequestLogInfoFromClientRequest :: Request -> RequestLogInfo
|
||||
extractRequestLogInfoFromClientRequest :: HTTP.Request -> RequestLogInfo
|
||||
extractRequestLogInfoFromClientRequest req =
|
||||
let _rliRequestMethod = req ^. method & fromUtf8
|
||||
_rliRequestUri = req ^. url
|
||||
_rliRequestPath = req ^. path & fromUtf8
|
||||
_rliRequestHeaders = req ^. headers & headersToKeyMap
|
||||
_rliRequestBody = req ^. body <&> (BSL.toStrict >>> fromUtf8)
|
||||
let _rliRequestMethod = req ^. HTTP.method & fromUtf8
|
||||
_rliRequestUri = req ^. HTTP.url
|
||||
_rliRequestPath = req ^. HTTP.path & fromUtf8
|
||||
_rliRequestHeaders = req ^. HTTP.headers & headersToKeyMap
|
||||
-- NOTE: We cannot decode IO based body types.
|
||||
_rliRequestBody = req ^? (HTTP.body . HTTP._RequestBodyLBS) <&> (BSL.toStrict >>> fromUtf8)
|
||||
in RequestLogInfo {..}
|
||||
|
||||
logClientError :: (MonadIO m, MonadTrace m) => Logger Hasura -> ClientError -> m ()
|
||||
logClientError (Logger writeLog) clientError = do
|
||||
traceCtx <- Tracing.currentContext
|
||||
let _aclResponseStatusCode = case clientError of
|
||||
FailureResponse _ response -> Just . statusCode $ responseStatusCode response
|
||||
FailureResponse _ response -> Just . HTTP.statusCode $ responseStatusCode response
|
||||
_ -> Nothing
|
||||
_aclRequest = extractRequestLogInfoFromClientInfo clientError
|
||||
_aclError = Just $ Hasura.HTTP.serializeServantClientErrorMessageForDebugging clientError
|
||||
@ -103,7 +104,7 @@ extractRequestLogInfoFromClientInfo = \case
|
||||
in Just RequestLogInfo {..}
|
||||
_ -> Nothing
|
||||
|
||||
headersToKeyMap :: [Header] -> KeyMap Text
|
||||
headersToKeyMap :: [HTTP.Header] -> KeyMap Text
|
||||
headersToKeyMap headers' =
|
||||
headers'
|
||||
<&> (\(name, value) -> (K.fromText . fromUtf8 $ CI.original name, fromUtf8 value))
|
||||
|
||||
@ -538,7 +538,7 @@ processEventQueue logger statsLogger httpMgr getSchemaCache getEventEngineCtx ac
|
||||
pure (request, resp)
|
||||
case eitherReqRes of
|
||||
Right (req, resp) -> do
|
||||
let reqBody = fromMaybe J.Null $ view HTTP.body req >>= J.decode @J.Value
|
||||
let reqBody = fromMaybe J.Null $ preview (HTTP.body . HTTP._RequestBodyLBS) req >>= J.decode @J.Value
|
||||
processSuccess sourceConfig e logHeaders reqBody maintenanceModeVersion resp >>= flip onLeft logQErr
|
||||
eventExecutionFinishTime <- liftIO getCurrentTime
|
||||
let eventWebhookProcessingTime' = realToFrac $ diffUTCTime eventExecutionFinishTime eventExecutionStartTime
|
||||
|
||||
@ -44,7 +44,7 @@ module Hasura.Eventing.HTTP
|
||||
where
|
||||
|
||||
import Control.Exception (try)
|
||||
import Control.Lens (preview, set, view, (.~))
|
||||
import Control.Lens (preview, set, (.~))
|
||||
import Data.Aeson qualified as J
|
||||
import Data.Aeson.Encoding qualified as JE
|
||||
import Data.Aeson.Key qualified as J
|
||||
@ -278,7 +278,7 @@ logHTTPForST eitherResp extraLogCtx reqDetails webhookVarName logHeaders = do
|
||||
|
||||
runHTTP :: (MonadIO m) => HTTP.Manager -> HTTP.Request -> m (Either (HTTPErr a) (HTTPResp a))
|
||||
runHTTP manager req = do
|
||||
res <- liftIO $ try $ HTTP.performRequest req manager
|
||||
res <- liftIO $ try $ HTTP.httpLbs req manager
|
||||
return $ either (Left . HClient . HttpException) anyBodyParser res
|
||||
|
||||
data TransformableRequestError a
|
||||
@ -306,7 +306,7 @@ mkRequest headers timeout payload mRequestTransform (ResolvedWebhook webhook) =
|
||||
initReq
|
||||
& set HTTP.method "POST"
|
||||
& set HTTP.headers headers
|
||||
& set HTTP.body (Just payload)
|
||||
& set HTTP.body (HTTP.RequestBodyLBS payload)
|
||||
& set HTTP.timeout timeout
|
||||
sessionVars = do
|
||||
val <- J.decode @J.Value payload
|
||||
@ -341,7 +341,7 @@ invokeRequest ::
|
||||
m (HTTPResp a)
|
||||
invokeRequest reqDetails@RequestDetails {..} respTransform' sessionVars logger = do
|
||||
let finalReq = fromMaybe _rdOriginalRequest _rdTransformedRequest
|
||||
reqBody = fromMaybe J.Null $ view HTTP.body finalReq >>= J.decode @J.Value
|
||||
reqBody = fromMaybe J.Null $ preview (HTTP.body . HTTP._RequestBodyLBS) finalReq >>= J.decode @J.Value
|
||||
manager <- asks getter
|
||||
-- Perform the HTTP Request
|
||||
eitherResp <- traceHTTPRequest finalReq $ runHTTP manager
|
||||
|
||||
@ -123,7 +123,7 @@ where
|
||||
|
||||
import Control.Concurrent.Extended (Forever (..), sleep)
|
||||
import Control.Concurrent.STM
|
||||
import Control.Lens (view)
|
||||
import Control.Lens (preview)
|
||||
import Data.Aeson qualified as J
|
||||
import Data.Environment qualified as Env
|
||||
import Data.Has
|
||||
@ -444,7 +444,7 @@ processScheduledEvent prometheusMetrics eventId eventHeaders retryCtx payload we
|
||||
pure (request, resp)
|
||||
case eitherReqRes of
|
||||
Right (req, resp) ->
|
||||
let reqBody = fromMaybe J.Null $ view HTTP.body req >>= J.decode @J.Value
|
||||
let reqBody = fromMaybe J.Null $ preview (HTTP.body . HTTP._RequestBodyLBS) req >>= J.decode @J.Value
|
||||
in processSuccess eventId decodedHeaders type' reqBody resp
|
||||
Left (HTTPError reqBody e) -> processError eventId retryCtx decodedHeaders type' reqBody e
|
||||
Left (TransformationError _ e) -> do
|
||||
|
||||
@ -569,7 +569,7 @@ callWebhook
|
||||
initReq
|
||||
& set HTTP.method "POST"
|
||||
& set HTTP.headers hdrs
|
||||
& set HTTP.body (Just requestBody)
|
||||
& set HTTP.body (HTTP.RequestBodyLBS requestBody)
|
||||
& set HTTP.timeout responseTimeout
|
||||
|
||||
(transformedReq, transformedReqSize, reqTransformCtx) <- case metadataRequestTransform of
|
||||
@ -593,7 +593,7 @@ callWebhook
|
||||
|
||||
httpResponse <-
|
||||
Tracing.traceHTTPRequest actualReq $ \request ->
|
||||
liftIO . try $ HTTP.performRequest request manager
|
||||
liftIO . try $ HTTP.httpLbs request manager
|
||||
|
||||
let requestInfo = ActionRequestInfo webhookEnvName postPayload (confHeaders <> toHeadersConf clientHeaders) transformedReq
|
||||
|
||||
|
||||
@ -158,12 +158,12 @@ execRemoteGQ env userInfo reqHdrs rsdef gqlReq@GQLReq {..} = do
|
||||
initReq
|
||||
& set HTTP.method "POST"
|
||||
& set HTTP.headers finalHeaders
|
||||
& set HTTP.body (Just $ J.encode gqlReqUnparsed)
|
||||
& set HTTP.body (HTTP.RequestBodyLBS $ J.encode gqlReqUnparsed)
|
||||
& set HTTP.timeout (HTTP.responseTimeoutMicro (timeout * 1000000))
|
||||
|
||||
manager <- askHTTPManager
|
||||
Tracing.traceHTTPRequest req \req' -> do
|
||||
(time, res) <- withElapsedTime $ liftIO $ try $ HTTP.performRequest req' manager
|
||||
(time, res) <- withElapsedTime $ liftIO $ try $ HTTP.httpLbs req' manager
|
||||
resp <- onLeft res (throwRemoteSchemaHttp webhookEnvRecord)
|
||||
pure (time, mkSetCookieHeaders resp, resp ^. Wreq.responseBody)
|
||||
where
|
||||
|
||||
@ -806,7 +806,7 @@ runTestWebhookTransform (TestWebhookTransform env headers urlE payload rt _ sv)
|
||||
result <- runExceptT $ do
|
||||
initReq <- hoistEither $ first RequestInitializationError $ HTTP.mkRequestEither url
|
||||
|
||||
let req = initReq & HTTP.body .~ pure (J.encode payload) & HTTP.headers .~ headers'
|
||||
let req = initReq & HTTP.body .~ HTTP.RequestBodyLBS (J.encode payload) & HTTP.headers .~ headers'
|
||||
reqTransform = requestFields rt
|
||||
engine = templateEngine rt
|
||||
reqTransformCtx = fmap mkRequestContext $ mkReqTransformCtx url sv engine
|
||||
@ -875,6 +875,7 @@ packTransformResult = \case
|
||||
[ "webhook_url" J..= (req ^. HTTP.url),
|
||||
"method" J..= (req ^. HTTP.method),
|
||||
"headers" J..= (first CI.foldedCase <$> (req ^. HTTP.headers)),
|
||||
"body" J..= decodeBody (req ^. HTTP.body)
|
||||
-- NOTE: We cannot decode IO based body types.
|
||||
"body" J..= decodeBody (req ^? HTTP.body . HTTP._RequestBodyLBS)
|
||||
]
|
||||
Left err -> throw400WithDetail ValidationFailed "request transform validation failed" $ J.toJSON err
|
||||
|
||||
@ -1,5 +1,8 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
{-# HLINT ignore "Use maybe" #-}
|
||||
|
||||
-- | Webhook Transformations are data transformations used to modify
|
||||
-- HTTP Requests/Responses before requests are executed and after
|
||||
@ -57,7 +60,7 @@ where
|
||||
|
||||
import Autodocodec (HasCodec, dimapCodec, disjointEitherCodec, optionalField', optionalFieldWithDefault')
|
||||
import Autodocodec qualified as AC
|
||||
import Control.Lens (Lens', lens, set, traverseOf, view)
|
||||
import Control.Lens (Lens', lens, preview, set, traverseOf, view)
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import Data.Aeson.Extended ((.!=), (.:?), (.=), (.=?))
|
||||
import Data.Aeson.Extended qualified as Aeson
|
||||
@ -293,16 +296,16 @@ requestL = lens getter setter
|
||||
RequestFields
|
||||
{ method = coerce $ CI.mk $ TE.decodeUtf8 $ view HTTP.method req,
|
||||
url = coerce $ view HTTP.url req,
|
||||
body = coerce $ JSONBody $ Aeson.decode =<< view HTTP.body req,
|
||||
body = coerce $ JSONBody $ Aeson.decode =<< preview (HTTP.body . HTTP._RequestBodyLBS) req,
|
||||
queryParams = coerce $ view HTTP.queryParams req,
|
||||
requestHeaders = coerce $ view HTTP.headers req
|
||||
}
|
||||
|
||||
serializeBody :: Body -> Maybe BL.ByteString
|
||||
serializeBody :: Body -> HTTP.RequestBody
|
||||
serializeBody = \case
|
||||
JSONBody body -> fmap Aeson.encode body
|
||||
RawBody "" -> Nothing
|
||||
RawBody bs -> Just bs
|
||||
JSONBody body -> HTTP.RequestBodyLBS $ fromMaybe mempty $ fmap Aeson.encode body
|
||||
RawBody "" -> mempty
|
||||
RawBody bs -> HTTP.RequestBodyLBS bs
|
||||
|
||||
setter :: HTTP.Request -> RequestData -> HTTP.Request
|
||||
setter req RequestFields {..} =
|
||||
|
||||
@ -78,7 +78,7 @@ mkReqTransformCtx ::
|
||||
mkReqTransformCtx url sessionVars rtcEngine reqData =
|
||||
let rtcBaseUrl = Just $ Aeson.toJSON url
|
||||
rtcBody =
|
||||
let mBody = Lens.view HTTP.body reqData >>= Aeson.decode @Aeson.Value
|
||||
let mBody = Lens.preview (HTTP.body . HTTP._RequestBodyLBS) reqData >>= Aeson.decode @Aeson.Value
|
||||
in fromMaybe Aeson.Null mBody
|
||||
rtcSessionVariables = sessionVars
|
||||
rtcQueryParams =
|
||||
|
||||
@ -360,7 +360,7 @@ fetchJwk (Logger logger) manager url = do
|
||||
res <- try $ do
|
||||
req <- liftIO $ HTTP.mkRequestThrow $ tshow url
|
||||
let req' = req & over HTTP.headers addDefaultHeaders
|
||||
liftIO $ HTTP.performRequest req' manager
|
||||
liftIO $ HTTP.httpLbs req' manager
|
||||
resp <- onLeft res logAndThrowHttp
|
||||
let status = resp ^. Wreq.responseStatus
|
||||
respBody = resp ^. Wreq.responseBody
|
||||
|
||||
@ -80,7 +80,7 @@ userInfoFromAuthHook logger manager hook reqHeaders reqs = do
|
||||
let isCommonHeader = (`elem` commonClientHeadersIgnored)
|
||||
filteredHeaders = filter (not . isCommonHeader . fst) reqHeaders
|
||||
req' = req & set HTTP.headers (addDefaultHeaders filteredHeaders)
|
||||
HTTP.performRequest req' manager
|
||||
HTTP.httpLbs req' manager
|
||||
AHTPost -> do
|
||||
let contentType = ("Content-Type", "application/json")
|
||||
headersPayload = J.toJSON $ Map.fromList $ hdrsToText reqHeaders
|
||||
@ -90,7 +90,7 @@ userInfoFromAuthHook logger manager hook reqHeaders reqs = do
|
||||
& set HTTP.headers (addDefaultHeaders [contentType])
|
||||
& set
|
||||
HTTP.body
|
||||
( Just $
|
||||
( HTTP.RequestBodyLBS $
|
||||
J.encode $
|
||||
object
|
||||
( ["headers" J..= headersPayload]
|
||||
@ -98,7 +98,7 @@ userInfoFromAuthHook logger manager hook reqHeaders reqs = do
|
||||
<> ["request" J..= reqs | ahSendRequestBody hook]
|
||||
)
|
||||
)
|
||||
HTTP.performRequest req' manager
|
||||
HTTP.httpLbs req' manager
|
||||
|
||||
logAndThrow :: HTTP.HttpException -> m a
|
||||
logAndThrow err = do
|
||||
|
||||
@ -1,15 +1,28 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
-- | Our HTTP client library, with better ergonomics for logging and so on (see
|
||||
-- 'Request').
|
||||
--
|
||||
-- NOTE: Do not create requests with IO based RequestBody
|
||||
-- constructors. They cannot be transformed or logged.
|
||||
--
|
||||
-- NOTE: This module is meant to be imported qualified, e.g.
|
||||
--
|
||||
-- > import qualified Network.HTTP.Client.Transformable as HTTP
|
||||
--
|
||||
-- ...or
|
||||
--
|
||||
-- > import qualified Network.HTTP.Client.Transformable as Transformable
|
||||
module Network.HTTP.Client.Transformable
|
||||
( Request,
|
||||
( Client.Request,
|
||||
mkRequestThrow,
|
||||
mkRequestEither,
|
||||
tryFromClientRequest,
|
||||
url,
|
||||
Network.HTTP.Client.Transformable.method,
|
||||
headers,
|
||||
host,
|
||||
body,
|
||||
_RequestBodyLBS,
|
||||
port,
|
||||
path,
|
||||
queryParams,
|
||||
@ -17,28 +30,31 @@ module Network.HTTP.Client.Transformable
|
||||
timeout,
|
||||
getReqSize,
|
||||
getQueryStr,
|
||||
performRequest,
|
||||
Client.Response (..),
|
||||
Client.ResponseTimeout,
|
||||
Client.HttpException (..),
|
||||
Internal.HttpExceptionContent (..),
|
||||
Client.Manager,
|
||||
Client.httpLbs,
|
||||
Client.responseTimeoutDefault,
|
||||
Client.responseTimeoutMicro,
|
||||
Client.newManager,
|
||||
module Types,
|
||||
module TLSClient,
|
||||
Client.RequestBody (..),
|
||||
)
|
||||
where
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
import Control.Exception.Safe (impureThrow)
|
||||
import Control.Lens (Lens', lens, set, to, view, (^.), (^?), _Just)
|
||||
import Control.Lens.Iso (strict)
|
||||
import Control.Lens (Lens', Prism', lens, preview, prism', set, strict, to, view, (^.), (^?))
|
||||
import Control.Monad.Catch (MonadThrow, fromException)
|
||||
import Data.Aeson qualified as J
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString qualified as B
|
||||
import Data.ByteString.Builder qualified as Builder
|
||||
import Data.ByteString.Char8 qualified as C8
|
||||
import Data.ByteString.Lazy qualified as BL
|
||||
import Data.CaseInsensitive qualified as CI
|
||||
@ -58,48 +74,20 @@ import Network.HTTP.Types as Types
|
||||
import Network.URI qualified as URI
|
||||
import Prelude
|
||||
|
||||
-- | @Network.HTTP.Client@.'Client.Request' stores the request body in a sum
|
||||
-- type which has a case containing IO along with some other unwieldy cases.
|
||||
-- This makes it difficult to log our requests before and after transformation.
|
||||
--
|
||||
-- In our codebase we only ever use the Lazy ByteString case. So by
|
||||
-- lifting the request body out of Network.HTTP.Client.Request, we
|
||||
-- make it much easier to log our Requests.
|
||||
--
|
||||
-- When executing the request we simply insert the value at `rdBody`
|
||||
-- into the Request.
|
||||
--
|
||||
-- When working with Transformable Requests you should always import
|
||||
-- this module qualified and use the `mkRequest*` functions for
|
||||
-- constructing requests. Modification of Request should be done using
|
||||
-- the provided lens API.
|
||||
--
|
||||
-- NOTE: This module is meant to be imported qualified, e.g.
|
||||
--
|
||||
-- > import qualified Network.HTTP.Client.Transformable as HTTP
|
||||
--
|
||||
-- ...or
|
||||
--
|
||||
-- > import qualified Network.HTTP.Client.Transformable as Transformable
|
||||
--
|
||||
-- Use 'performRequest' to execute the request.
|
||||
data Request = Request
|
||||
{ rdRequest :: Client.Request,
|
||||
rdBody :: Maybe BL.ByteString
|
||||
}
|
||||
deriving (Show)
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- XXX: This function makes internal usage of `Strict.utf8`/`TE.decodeUtf8`,
|
||||
-- NOTE: This function makes internal usage of `Strict.utf8`/`TE.decodeUtf8`,
|
||||
-- which throws an impure exception when the supplied `ByteString` cannot be
|
||||
-- decoded into valid UTF8 text!
|
||||
instance J.ToJSON Request where
|
||||
toJSON req@Request {rdRequest, rdBody} =
|
||||
instance J.ToJSON Client.Request where
|
||||
toJSON req =
|
||||
J.object
|
||||
[ "url" J..= (req ^. url),
|
||||
"method" J..= (req ^. method . Strict.utf8),
|
||||
"headers" J..= (req ^. headers . renderHeaders),
|
||||
"body" J..= (rdBody ^? _Just . strict . Strict.utf8),
|
||||
"query_string" J..= (rdRequest ^. to Client.queryString . Strict.utf8),
|
||||
-- NOTE: We cannot decode IO based body types.
|
||||
"body" J..= (req ^? body . _RequestBodyLBS . strict . Strict.utf8),
|
||||
"query_string" J..= (req ^. to Client.queryString . Strict.utf8),
|
||||
"response_timeout" J..= (req ^. timeout . renderResponseTimeout)
|
||||
]
|
||||
where
|
||||
@ -117,10 +105,8 @@ instance J.ToJSON Request where
|
||||
--
|
||||
-- NOTE: This function will throw an error in 'MonadThrow' if the URL is
|
||||
-- invalid.
|
||||
mkRequestThrow :: MonadThrow m => Text -> m Request
|
||||
mkRequestThrow urlTxt = do
|
||||
request <- Client.parseRequest $ T.unpack urlTxt
|
||||
pure $ Request request Nothing
|
||||
mkRequestThrow :: MonadThrow m => Text -> m Client.Request
|
||||
mkRequestThrow = Client.parseRequest . T.unpack
|
||||
|
||||
-- | 'mkRequestThrow' with the 'MonadThrow' instance specialized to 'Either'.
|
||||
--
|
||||
@ -130,29 +116,13 @@ mkRequestThrow urlTxt = do
|
||||
-- 'mkRequestThrow' calls 'Client.parseRequest', which only ever throws
|
||||
-- 'Client.HttpException' errors (which should be "caught" by the
|
||||
-- 'fromException' cast).
|
||||
mkRequestEither :: Text -> Either Client.HttpException Request
|
||||
mkRequestEither :: Text -> Either Client.HttpException Client.Request
|
||||
mkRequestEither urlTxt =
|
||||
mkRequestThrow urlTxt & first
|
||||
\someExc -> case fromException @Client.HttpException someExc of
|
||||
Just httpExc -> httpExc
|
||||
Nothing -> impureThrow someExc
|
||||
|
||||
-- | Creates a 'Request', converting it from a 'Client.Request'. This only
|
||||
-- supports requests that use a Strict/Lazy ByteString as a request body
|
||||
-- and will fail with all other body types.
|
||||
--
|
||||
-- NOTE: You should avoid creating 'Client.Request's and use the 'mk'
|
||||
-- functions to create 'Request's. This is for if a framework hands you
|
||||
-- a precreated 'Client.Request' and you don't have a choice.
|
||||
tryFromClientRequest :: Client.Request -> Either Text Request
|
||||
tryFromClientRequest req = case Client.requestBody req of
|
||||
Client.RequestBodyLBS lbs -> Right $ Request req (Just lbs)
|
||||
Client.RequestBodyBS bs -> Right $ Request req (Just $ BL.fromStrict bs)
|
||||
Client.RequestBodyBuilder _ _ -> Left "Unsupported body: Builder"
|
||||
Client.RequestBodyStream _ _ -> Left "Unsupported body: Stream"
|
||||
Client.RequestBodyStreamChunked _ -> Left "Unsupported body: Stream Chunked"
|
||||
Client.RequestBodyIO _ -> Left "Unsupported body: IO"
|
||||
|
||||
-- | Url is 'materialized view' into `Request` consisting of
|
||||
-- concatenation of `host`, `port`, `queryParams`, and `path` in the
|
||||
-- underlying request object, as well as a literal url field that
|
||||
@ -167,13 +137,13 @@ tryFromClientRequest req = case Client.requestBody req of
|
||||
-- We use the literal field to `view` the value but we must
|
||||
-- carefully set the subcomponents by hand during `set` operations. Be
|
||||
-- careful modifying this lens and verify against the unit tests..
|
||||
url :: Lens' Request Text
|
||||
url :: Lens' Client.Request Text
|
||||
url = lens getUrl setUrl
|
||||
where
|
||||
getUrl :: Request -> Text
|
||||
getUrl Request {rdRequest} = T.pack $ URI.uriToString id (Client.getUri rdRequest) mempty
|
||||
getUrl :: Client.Request -> Text
|
||||
getUrl req = T.pack $ URI.uriToString id (Client.getUri req) mempty
|
||||
|
||||
setUrl :: Request -> Text -> Request
|
||||
setUrl :: Client.Request -> Text -> Client.Request
|
||||
setUrl req url' = fromMaybe req $ do
|
||||
uri <- URI.parseURI (T.unpack url')
|
||||
URI.URIAuth {..} <- URI.uriAuthority uri
|
||||
@ -192,103 +162,97 @@ url = lens getUrl setUrl
|
||||
& set queryParams queryString
|
||||
& set path path'
|
||||
|
||||
body :: Lens' Request (Maybe BL.ByteString)
|
||||
body = lens rdBody setBody
|
||||
body :: Lens' Client.Request NHS.RequestBody
|
||||
body = lens getBody setBody
|
||||
where
|
||||
setBody :: Request -> Maybe BL.ByteString -> Request
|
||||
setBody req body' = req {rdBody = body'}
|
||||
getBody :: Client.Request -> NHS.RequestBody
|
||||
getBody = NHS.requestBody
|
||||
|
||||
headers :: Lens' Request [Types.Header]
|
||||
setBody :: Client.Request -> NHS.RequestBody -> Client.Request
|
||||
setBody req newBody = req {NHS.requestBody = newBody}
|
||||
|
||||
-- NOTE: We cannot decode IO based body types.
|
||||
_RequestBodyLBS :: Prism' NHS.RequestBody BL.ByteString
|
||||
_RequestBodyLBS = prism' Client.RequestBodyLBS $ \case
|
||||
Client.RequestBodyLBS lbs -> pure lbs
|
||||
Client.RequestBodyBS bs -> pure (BL.fromStrict bs)
|
||||
Client.RequestBodyBuilder _ bldr -> pure (Builder.toLazyByteString bldr)
|
||||
_ -> Nothing
|
||||
|
||||
headers :: Lens' Client.Request [Types.Header]
|
||||
headers = lens getHeaders setHeaders
|
||||
where
|
||||
getHeaders :: Request -> [Types.Header]
|
||||
getHeaders Request {rdRequest} = Client.requestHeaders rdRequest
|
||||
getHeaders :: Client.Request -> [Types.Header]
|
||||
getHeaders = Client.requestHeaders
|
||||
|
||||
setHeaders :: Request -> [Types.Header] -> Request
|
||||
setHeaders req@Request {rdRequest} headers' =
|
||||
req {rdRequest = NHS.setRequestHeaders headers' rdRequest}
|
||||
setHeaders :: Client.Request -> [Types.Header] -> Client.Request
|
||||
setHeaders req headers' = NHS.setRequestHeaders headers' req
|
||||
|
||||
host :: Lens' Request B.ByteString
|
||||
host :: Lens' Client.Request B.ByteString
|
||||
host = lens getHost setHost
|
||||
where
|
||||
getHost :: Request -> B.ByteString
|
||||
getHost Request {rdRequest} = Client.host rdRequest
|
||||
getHost :: Client.Request -> B.ByteString
|
||||
getHost = Client.host
|
||||
|
||||
setHost :: Request -> B.ByteString -> Request
|
||||
setHost req@Request {rdRequest} host' =
|
||||
req {rdRequest = NHS.setRequestHost host' rdRequest}
|
||||
setHost :: Client.Request -> B.ByteString -> Client.Request
|
||||
setHost req host' = NHS.setRequestHost host' req
|
||||
|
||||
secure :: Lens' Request Bool
|
||||
secure :: Lens' Client.Request Bool
|
||||
secure = lens getSecure setSecure
|
||||
where
|
||||
getSecure :: Request -> Bool
|
||||
getSecure Request {rdRequest} = Client.secure rdRequest
|
||||
getSecure :: Client.Request -> Bool
|
||||
getSecure = Client.secure
|
||||
|
||||
setSecure :: Request -> Bool -> Request
|
||||
setSecure req@Request {rdRequest} ssl =
|
||||
req {rdRequest = NHS.setRequestSecure ssl rdRequest}
|
||||
setSecure :: Client.Request -> Bool -> Client.Request
|
||||
setSecure req ssl = NHS.setRequestSecure ssl req
|
||||
|
||||
method :: Lens' Request B.ByteString
|
||||
method :: Lens' Client.Request B.ByteString
|
||||
method = lens getMethod setMethod
|
||||
where
|
||||
getMethod :: Request -> B.ByteString
|
||||
getMethod Request {rdRequest} = Client.method rdRequest
|
||||
getMethod :: Client.Request -> B.ByteString
|
||||
getMethod = Client.method
|
||||
|
||||
setMethod :: Request -> B.ByteString -> Request
|
||||
setMethod req@Request {rdRequest} method' = req {rdRequest = NHS.setRequestMethod method' rdRequest}
|
||||
setMethod :: Client.Request -> B.ByteString -> Client.Request
|
||||
setMethod req method' = NHS.setRequestMethod method' req
|
||||
|
||||
path :: Lens' Request B.ByteString
|
||||
path :: Lens' Client.Request B.ByteString
|
||||
path = lens getPath setPath
|
||||
where
|
||||
getPath :: Request -> B.ByteString
|
||||
getPath Request {rdRequest} = Client.path rdRequest
|
||||
getPath :: Client.Request -> B.ByteString
|
||||
getPath = Client.path
|
||||
|
||||
setPath :: Request -> B.ByteString -> Request
|
||||
setPath req@Request {rdRequest} p =
|
||||
req {rdRequest = rdRequest {Client.path = p}}
|
||||
setPath :: Client.Request -> B.ByteString -> Client.Request
|
||||
setPath req p = req {Client.path = p}
|
||||
|
||||
port :: Lens' Request Int
|
||||
port :: Lens' Client.Request Int
|
||||
port = lens getPort setPort
|
||||
where
|
||||
getPort :: Request -> Int
|
||||
getPort Request {rdRequest} = Client.port rdRequest
|
||||
getPort :: Client.Request -> Int
|
||||
getPort = Client.port
|
||||
|
||||
setPort :: Request -> Int -> Request
|
||||
setPort req@Request {rdRequest} i =
|
||||
req {rdRequest = NHS.setRequestPort i rdRequest}
|
||||
setPort :: Client.Request -> Int -> Client.Request
|
||||
setPort req i = NHS.setRequestPort i req
|
||||
|
||||
getQueryStr :: Request -> ByteString
|
||||
getQueryStr :: Client.Request -> ByteString
|
||||
getQueryStr = Types.renderQuery True . view queryParams
|
||||
|
||||
queryParams :: Lens' Request NHS.Query
|
||||
queryParams :: Lens' Client.Request NHS.Query
|
||||
queryParams = lens getQueryParams setQueryParams
|
||||
where
|
||||
getQueryParams :: Request -> NHS.Query
|
||||
getQueryParams Request {rdRequest} = NHS.getRequestQueryString rdRequest
|
||||
getQueryParams :: Client.Request -> NHS.Query
|
||||
getQueryParams = NHS.getRequestQueryString
|
||||
|
||||
setQueryParams :: Request -> NHS.Query -> Request
|
||||
setQueryParams req@Request {rdRequest} params = req {rdRequest = NHS.setQueryString params rdRequest}
|
||||
setQueryParams :: Client.Request -> NHS.Query -> Client.Request
|
||||
setQueryParams req params = NHS.setQueryString params req
|
||||
|
||||
timeout :: Lens' Request Client.ResponseTimeout
|
||||
timeout :: Lens' Client.Request Client.ResponseTimeout
|
||||
timeout = lens getTimeout setTimeout
|
||||
where
|
||||
getTimeout :: Request -> Client.ResponseTimeout
|
||||
getTimeout Request {rdRequest} = Client.responseTimeout rdRequest
|
||||
getTimeout :: Client.Request -> Client.ResponseTimeout
|
||||
getTimeout = Client.responseTimeout
|
||||
|
||||
setTimeout :: Request -> Client.ResponseTimeout -> Request
|
||||
setTimeout req@Request {rdRequest} timeout' =
|
||||
let updatedReq = rdRequest {Client.responseTimeout = timeout'}
|
||||
in req {rdRequest = updatedReq}
|
||||
setTimeout :: Client.Request -> Client.ResponseTimeout -> Client.Request
|
||||
setTimeout req timeout' = req {Client.responseTimeout = timeout'}
|
||||
|
||||
getReqSize :: Request -> Int64
|
||||
getReqSize Request {rdBody} = maybe 0 BL.length rdBody
|
||||
|
||||
toRequest :: Request -> Client.Request
|
||||
toRequest Request {rdRequest, rdBody} = case rdBody of
|
||||
Nothing -> rdRequest
|
||||
Just body' -> NHS.setRequestBody (Client.RequestBodyLBS body') rdRequest
|
||||
|
||||
-- | NOTE: for now, please always wrap this in @tracedHttpRequest@ to make sure
|
||||
-- a trace is logged.
|
||||
performRequest :: Request -> Client.Manager -> IO (Client.Response BL.ByteString)
|
||||
performRequest req manager = Client.httpLbs (toRequest req) manager
|
||||
getReqSize :: Client.Request -> Int64
|
||||
getReqSize req = maybe 0 BL.length $ preview (body . _RequestBodyLBS) req
|
||||
|
||||
@ -64,28 +64,28 @@ specBodyLens = describe "Body Lens" $ do
|
||||
|
||||
it "get body s ≡ a" $ do
|
||||
-- THEN
|
||||
view Client.body req `shouldBe` Nothing
|
||||
preview (Client.body . Client._RequestBodyLBS) req `shouldBe` Just mempty
|
||||
|
||||
it "get body . set body b ≡ b" $ do
|
||||
-- WHEN
|
||||
let req' = set Client.body (Just "{ \"hello\": \"world\"}") req
|
||||
let req' = set Client.body (Client.RequestBodyLBS "{ \"hello\": \"world\"}") req
|
||||
|
||||
-- THEN
|
||||
view Client.body req' `shouldBe` (Just "{ \"hello\": \"world\"}")
|
||||
preview (Client.body . Client._RequestBodyLBS) req' `shouldBe` (Just "{ \"hello\": \"world\"}")
|
||||
|
||||
it "over id ≡ id" $ do
|
||||
-- WHEN
|
||||
let req' = over Client.body id req
|
||||
|
||||
-- THEN
|
||||
view Client.body req' `shouldBe` Nothing
|
||||
preview (Client.body . Client._RequestBodyLBS) req' `shouldBe` Just mempty
|
||||
|
||||
it "over body (const b) ≡ set body b" $ do
|
||||
-- WHEN
|
||||
let req' = over Client.body (const (Just "{ \"hello\": \"world\"}")) req
|
||||
let req' = over Client.body (const (Client.RequestBodyLBS "{ \"hello\": \"world\"}")) req
|
||||
|
||||
-- THEN
|
||||
view Client.body req' `shouldBe` (Just "{ \"hello\": \"world\"}")
|
||||
preview (Client.body . Client._RequestBodyLBS) req' `shouldBe` (Just "{ \"hello\": \"world\"}")
|
||||
|
||||
specHeadersLens :: Spec
|
||||
specHeadersLens = describe "Headers Lens" $ do
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
headers:
|
||||
- - foo
|
||||
- bar
|
||||
body:
|
||||
body: ''
|
||||
method: GET
|
||||
webhook_url: http://www.google.com?foo=bar
|
||||
query:
|
||||
|
||||
Loading…
Reference in New Issue
Block a user