graphql-engine/server/src-lib/Hasura/Eventing/HTTP.hs

-- |
--  = Hasura.Eventing.HTTP
--
--  This module is an utility module providing HTTP utilities for
--  "Hasura.Eventing.EventTriggers" and "Hasura.Eventing.ScheduledTriggers".
--
--  The event triggers and scheduled triggers share the event delivery
--  mechanism using the 'tryWebhook' function defined in this module.
module Hasura.Eventing.HTTP
  ( HTTPErr (..),
    HTTPResp (..),
    runHTTP,
    isNetworkError,
    isNetworkErrorHC,
    logHTTPForET,
    logHTTPForST,
    ExtraLogContext (..),
    RequestDetails (..),
    EventId,
    InvocationVersion,
    Response (..),
    WebhookRequest (..),
    WebhookResponse (..),
    ClientError (..),
    isClientError,
    mkClientErr,
    mkWebhookReq,
    mkResp,
    mkInvocationResp,
    LogBehavior (..),
    ResponseLogBehavior (..),
    HeaderLogBehavior (..),
    prepareHeaders,
    getRetryAfterHeaderFromHTTPErr,
    getRetryAfterHeaderFromResp,
    parseRetryHeaderValue,
    invocationVersionET,
    invocationVersionST,
    mkRequest,
    invokeRequest,
  )
where

import Control.Exception (try)
import Control.Lens (set)
import Data.Aeson
import Data.Aeson.TH
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.CaseInsensitive qualified as CI
import Data.Either
import Data.Has
import Data.HashMap.Lazy qualified as HML
import Data.Int (Int64)
import Data.TByteString qualified as TBS
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Text.Encoding.Error qualified as TE
import Hasura.HTTP (HttpException (..), addDefaultHeaders)
import Hasura.Logging
import Hasura.Prelude
import Hasura.RQL.DDL.Headers
import Hasura.RQL.DDL.RequestTransform (RequestTransform, applyRequestTransform)
import Hasura.RQL.Types.Common (ResolvedWebhook (..))
import Hasura.RQL.Types.EventTrigger
import Hasura.RQL.Types.Eventing
import Hasura.Server.Version (HasVersion)
import Hasura.Tracing
import Network.HTTP.Client.Transformable qualified as HTTP

data LogBehavior = LogBehavior
  { _lbHeader :: !HeaderLogBehavior,
    _lbResponse :: !ResponseLogBehavior
  }

data HeaderLogBehavior = LogEnvValue | LogEnvVarname
  deriving (Show, Eq)

data ResponseLogBehavior = LogSanitisedResponse | LogEntireResponse
  deriving (Show, Eq)

retryAfterHeader :: CI.CI Text
retryAfterHeader = "Retry-After"

data ExtraLogContext = ExtraLogContext
  { elEventId :: !EventId,
    elEventName :: !(Maybe TriggerName)
  }
  deriving (Show, Eq)

data HTTPResp (a :: TriggerTypes) = HTTPResp
  { hrsStatus :: !Int,
    hrsHeaders :: ![HeaderConf],
    hrsBody :: !TBS.TByteString,
    hrsSize :: !Int64
  }
  deriving (Show, Eq)

$(deriveToJSON hasuraJSON {omitNothingFields = True} ''HTTPResp)

instance ToEngineLog (HTTPResp 'EventType) Hasura where
  toEngineLog resp = (LevelInfo, eventTriggerLogType, toJSON resp)

instance ToEngineLog (HTTPResp 'ScheduledType) Hasura where
  toEngineLog resp = (LevelInfo, scheduledTriggerLogType, toJSON resp)

data HTTPErr (a :: TriggerTypes)
  = HClient !HttpException
  | HStatus !(HTTPResp a)
  | HOther !String
  deriving (Show)

instance ToJSON (HTTPErr a) where
  toJSON err = toObj $ case err of
    (HClient httpException) ->
      ("client", toJSON httpException)
    (HStatus resp) ->
      ("status", toJSON resp)
    (HOther e) -> ("internal", toJSON e)
    where
      toObj :: (Text, Value) -> Value
      toObj (k, v) =
        object
          [ "type" .= k,
            "detail" .= v
          ]

instance ToEngineLog (HTTPErr 'EventType) Hasura where
  toEngineLog err = (LevelError, eventTriggerLogType, toJSON err)

instance ToEngineLog (HTTPErr 'ScheduledType) Hasura where
  toEngineLog err = (LevelError, scheduledTriggerLogType, toJSON err)

mkHTTPResp :: HTTP.Response LBS.ByteString -> HTTPResp a
mkHTTPResp resp =
  HTTPResp
    { hrsStatus = HTTP.statusCode $ HTTP.responseStatus resp,
      hrsHeaders = map decodeHeader $ HTTP.responseHeaders resp,
      hrsBody = TBS.fromLBS respBody,
      hrsSize = LBS.length respBody
    }
  where
    respBody = HTTP.responseBody resp
    decodeBS = TE.decodeUtf8With TE.lenientDecode
    decodeHeader (hdrName, hdrVal) =
      HeaderConf (decodeBS $ CI.original hdrName) (HVValue (decodeBS hdrVal))

data RequestDetails = RequestDetails
  { _rdOriginalRequest :: HTTP.Request,
    _rdOriginalSize :: Int64,
    _rdTransformedRequest :: Maybe HTTP.Request,
    _rdTransformedSize :: Maybe Int64
  }

$(deriveToJSON hasuraJSON ''RequestDetails)

data HTTPRespExtra (a :: TriggerTypes) = HTTPRespExtra
  { _hreResponse :: !(Either (HTTPErr a) (HTTPResp a)),
    _hreContext :: !ExtraLogContext,
    _hreRequest :: !RequestDetails,
    -- | Whether to log the entire response, including the body and the headers,
    -- which may contain sensitive information.
    _hreLogResponse :: !ResponseLogBehavior
  }

instance ToJSON (HTTPRespExtra a) where
  toJSON (HTTPRespExtra resp ctxt req logResp) =
    case resp of
      Left errResp ->
        object $
          [ "response" .= toJSON errResp,
            "request" .= toJSON req,
            "event_id" .= elEventId ctxt
          ]
            ++ eventName
      Right okResp ->
        object $
          [ "response" .= case logResp of
              LogEntireResponse -> toJSON okResp
              LogSanitisedResponse -> sanitisedRespJSON okResp,
            "request" .= toJSON req,
            "event_id" .= elEventId ctxt
          ]
            ++ eventName
    where
      eventName = case elEventName ctxt of
        Just name -> ["event_name" .= name]
        Nothing -> []
      sanitisedRespJSON v =
        Object $
          HML.fromList
            [ "size" .= hrsSize v,
              "status" .= hrsStatus v
            ]

instance ToEngineLog (HTTPRespExtra 'EventType) Hasura where
  toEngineLog resp = (LevelInfo, eventTriggerLogType, toJSON resp)

instance ToEngineLog (HTTPRespExtra 'ScheduledType) Hasura where
  toEngineLog resp = (LevelInfo, scheduledTriggerLogType, toJSON resp)

isNetworkError :: HTTPErr a -> Bool
isNetworkError = \case
  HClient he -> isNetworkErrorHC he
  _ -> False

isNetworkErrorHC :: HttpException -> Bool
isNetworkErrorHC (HttpException exception) =
  case exception of
    HTTP.HttpExceptionRequest _ (HTTP.ConnectionFailure _) -> True
    HTTP.HttpExceptionRequest _ HTTP.ConnectionTimeout -> True
    HTTP.HttpExceptionRequest _ HTTP.ResponseTimeout -> True
    _ -> False

anyBodyParser :: HTTP.Response LBS.ByteString -> Either (HTTPErr a) (HTTPResp a)
anyBodyParser resp = do
  let httpResp = mkHTTPResp resp
  if respCode >= HTTP.status200 && respCode < HTTP.status300
    then return httpResp
    else throwError $ HStatus httpResp
  where
    respCode = HTTP.responseStatus resp

data HTTPReq = HTTPReq
  { _hrqMethod :: !String,
    _hrqUrl :: !String,
    _hrqPayload :: !(Maybe Value),
    _hrqTry :: !Int,
    _hrqDelay :: !(Maybe Int)
  }
  deriving (Show, Eq)

$(deriveJSON hasuraJSON {omitNothingFields = True} ''HTTPReq)

instance ToEngineLog HTTPReq Hasura where
  toEngineLog req = (LevelInfo, eventTriggerLogType, toJSON req)

logHTTPForET ::
  ( MonadReader r m,
    Has (Logger Hasura) r,
    MonadIO m
  ) =>
  Either (HTTPErr 'EventType) (HTTPResp 'EventType) ->
  ExtraLogContext ->
  RequestDetails ->
  LogBehavior ->
  m ()
logHTTPForET eitherResp extraLogCtx reqDetails logBehavior = do
  logger :: Logger Hasura <- asks getter
  unLogger logger $ HTTPRespExtra eitherResp extraLogCtx reqDetails (_lbResponse logBehavior)

logHTTPForST ::
  ( MonadReader r m,
    Has (Logger Hasura) r,
    MonadIO m
  ) =>
  Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType) ->
  ExtraLogContext ->
  RequestDetails ->
  LogBehavior ->
  m ()
logHTTPForST eitherResp extraLogCtx reqDetails logBehavior = do
  logger :: Logger Hasura <- asks getter
  unLogger logger $ HTTPRespExtra eitherResp extraLogCtx reqDetails (_lbResponse logBehavior)

runHTTP :: (MonadIO m) => HTTP.Manager -> HTTP.Request -> m (Either (HTTPErr a) (HTTPResp a))
runHTTP manager req = do
  res <- liftIO $ try $ HTTP.performRequest req manager
  return $ either (Left . HClient . HttpException) anyBodyParser res

mkRequest ::
  MonadError (HTTPErr a) m =>
  [HTTP.Header] ->
  HTTP.ResponseTimeout ->
  -- | the request body. It is passed as a 'BL.Bytestring' because we need to
  -- log the request size. As the logging happens outside the function, we pass
  -- it the final request body, instead of 'Value'
  LBS.ByteString ->
  Maybe RequestTransform ->
  ResolvedWebhook ->
  m RequestDetails
mkRequest headers timeout payload mRequestTransform (ResolvedWebhook webhook) =
  case HTTP.mkRequestEither webhook of
    Left excp -> throwError $ HClient $ HttpException excp
    Right initReq ->
      let req =
            initReq & set HTTP.method "POST"
              & set HTTP.headers headers
              & set HTTP.body (Just payload)
              & set HTTP.timeout timeout

          -- TODO(Solomon) Add SessionVariables
          transformedReq = (\rt -> applyRequestTransform rt req Nothing) <$> mRequestTransform
          transformedReqSize = fmap HTTP.getReqSize transformedReq
       in pure $ RequestDetails req (LBS.length payload) transformedReq transformedReqSize

invokeRequest ::
  ( MonadReader r m,
    Has HTTP.Manager r,
    MonadIO m,
    MonadTrace m
  ) =>
  RequestDetails ->
  ((Either (HTTPErr a) (HTTPResp a)) -> RequestDetails -> m ()) ->
  m (Either (HTTPErr a) (HTTPResp a))
invokeRequest reqDetails@RequestDetails {_rdOriginalRequest, _rdTransformedRequest} logger = do
  let finalReq = fromMaybe _rdOriginalRequest _rdTransformedRequest
  manager <- asks getter
  -- Perform the HTTP Request
  eitherResp <- tracedHttpRequest finalReq $ runHTTP manager
  -- Log the result along with the pre/post transformation Request data
  logger eitherResp reqDetails
  pure eitherResp

mkResp :: Int -> TBS.TByteString -> [HeaderConf] -> Response a
mkResp status payload headers =
  let wr = WebhookResponse payload headers status
   in ResponseHTTP wr

mkClientErr :: TBS.TByteString -> Response a
mkClientErr message =
  let cerr = ClientError message
   in ResponseError cerr

mkWebhookReq :: Value -> [HeaderConf] -> InvocationVersion -> WebhookRequest
mkWebhookReq payload headers = WebhookRequest payload headers

mkInvocationResp :: Maybe Int -> TBS.TByteString -> [HeaderConf] -> Response a
mkInvocationResp statusMaybe responseBody responseHeaders =
  case statusMaybe of
    Nothing -> mkClientErr responseBody
    Just status ->
      if isClientError status
        then mkClientErr responseBody
        else mkResp status responseBody responseHeaders

isClientError :: Int -> Bool
isClientError status = status >= 300

encodeHeader :: EventHeaderInfo -> HTTP.Header
encodeHeader (EventHeaderInfo hconf cache) =
  let (HeaderConf name _) = hconf
      ciname = CI.mk $ TE.encodeUtf8 name
      value = TE.encodeUtf8 cache
   in (ciname, value)

decodeHeader ::
  LogBehavior ->
  [EventHeaderInfo] ->
  (HTTP.HeaderName, BS.ByteString) ->
  HeaderConf
decodeHeader logBehavior headerInfos (hdrName, hdrVal) =
  let name = decodeBS $ CI.original hdrName
      getName ehi =
        let (HeaderConf name' _) = ehiHeaderConf ehi
         in name'
      mehi = find (\hi -> getName hi == name) headerInfos
   in case mehi of
        Nothing -> HeaderConf name (HVValue (decodeBS hdrVal))
        Just ehi -> case _lbHeader logBehavior of
          LogEnvValue -> HeaderConf name (HVValue (ehiCachedValue ehi))
          LogEnvVarname -> ehiHeaderConf ehi
  where
    decodeBS = TE.decodeUtf8With TE.lenientDecode

-- | Encodes given request headers along with our 'defaultHeaders' and returns
-- them along with the re-decoded set of headers (for logging purposes).
prepareHeaders ::
  HasVersion =>
  LogBehavior ->
  [EventHeaderInfo] ->
  ([HTTP.Header], [HeaderConf])
prepareHeaders logBehavior headerInfos = (headers, logHeaders)
  where
    encodedHeaders = map encodeHeader headerInfos
    headers = addDefaultHeaders encodedHeaders
    logHeaders = map (decodeHeader logBehavior headerInfos) headers

getRetryAfterHeaderFromHTTPErr :: HTTPErr a -> Maybe Text
getRetryAfterHeaderFromHTTPErr (HStatus resp) = getRetryAfterHeaderFromResp resp
getRetryAfterHeaderFromHTTPErr _ = Nothing

getRetryAfterHeaderFromResp :: HTTPResp a -> Maybe Text
getRetryAfterHeaderFromResp resp =
  let mHeader =
        find
          (\(HeaderConf name _) -> CI.mk name == retryAfterHeader)
          (hrsHeaders resp)
   in case mHeader of
        Just (HeaderConf _ (HVValue value)) -> Just value
        _ -> Nothing

parseRetryHeaderValue :: Text -> Maybe Int
parseRetryHeaderValue hValue =
  let seconds = readMaybe $ T.unpack hValue
   in case seconds of
        Nothing -> Nothing
        Just sec ->
          if sec > 0
            then Just sec
            else Nothing