graphql-engine/server/src-lib/Hasura/RQL/DDL/RequestTransform.hs

module Hasura.RQL.DDL.RequestTransform ( applyRequestTransform
                                       , mkRequestTransform
                                       , mkRequestTransformDebug
                                       , RequestMethod(..)
                                       , TemplatingEngine(..)
                                       , TemplateText(..)
                                       , ContentType(..)
                                       , TransformHeaders(..)
                                       , MetadataTransform(..)
                                       , RequestTransform(..)
                                       ) where

import           Control.Lens                      (over)
import           Data.Bifunctor                    (bimap)
import           Data.List                         (nubBy)
import           Hasura.Incremental                (Cacheable)
import           Hasura.Prelude
import           Hasura.Session                    (SessionVariables)

import qualified Data.Aeson                        as J
import qualified Data.CaseInsensitive              as CI
import qualified Data.HashMap.Strict               as M
import qualified Data.Text                         as T
import qualified Data.Text.Encoding                as TE
import qualified Network.HTTP.Client.Transformable as HTTP

import           Kriti                             (runKriti)

{-

Request Transformations are data transformations used to modify HTTP
Requests before those requests are executed.

`MetadataTransform` values are stored in Metadata within the
`CreateAction` and `CreateEventTriggerQuery` Types and then converted
into `RequestTransform` values using `mkRequestTransform`.

`RequestTransforms` are applied to an HTTP Request using
`applyRequestTransform`.

In the case of body transformations, a user specified templating
script is applied. Currently a runtime failure of the template script
will return the original request body.

-}

-- | A set of data transformation functions and substitutions generated from a
-- MetadataTransform
data RequestTransform = RequestTransform
  { rtRequestMethod  :: Maybe RequestMethod
  -- ^ Change the request method to one provided here. Nothing means POST.
  , rtRequestURL     :: Maybe Text
  -- ^ Change the request URL to one provided here. Nothing means original URL.
  , rtBodyTransform  :: J.Value -> Maybe SessionVariables -> J.Value
  -- ^ A function for transforming the request body using a Kriti template.
  , rtContentType    :: Maybe ContentType
  -- ^ Change content type to one provided here. Nothing means use original.
  , rtQueryParams    :: Maybe HTTP.Query
  -- ^ Change Request query params to those provided here. Nothing means use original.
  , rtRequestHeaders :: [HTTP.Header] -> [HTTP.Header]
  -- ^ A transformation function for modifying the Request Headers.
  }

data RequestMethod = GET | POST | PUT | PATCH | DELETE
  deriving (Show, Eq, Enum, Bounded, Generic)

renderRequestMethod :: RequestMethod -> Text
renderRequestMethod = \case
  GET    -> "GET"
  POST   -> "POST"
  PUT    -> "PUT"
  PATCH  -> "PATCH"
  DELETE -> "DELETE"

instance J.ToJSON RequestMethod where
  toJSON = J.String . renderRequestMethod

instance J.FromJSON RequestMethod where
  parseJSON = J.withText "RequestMethod" \case
    "GET"    -> pure GET
    "POST"   -> pure POST
    "PUT"    -> pure PUT
    "PATCH"  -> pure PATCH
    "DELETE" -> pure DELETE
    _        -> fail "Invalid Request Method"

instance NFData RequestMethod
instance Cacheable RequestMethod

-- | A de/serializable request transformation template which can be stored in
-- the metadata associated with an action/event trigger/etc. and used to produce
-- a 'RequestTransform'.
--
-- NOTE: This data type is _only_ intended to be parsed from and stored as user
-- metadata; no direct logical transformations should be done upon it.
--
-- NOTE: Users should convert this to 'RequestTransform' as close as possible to
-- the call site that performs a transformed HTTP request, as 'RequestTransform'
-- has a representation that makes it more difficult to deserialize for
-- debugging.
data MetadataTransform = MetadataTransform
  { mtRequestMethod    :: Maybe RequestMethod
  -- ^ Change the request method to one provided here. Nothing means POST.
  , mtRequestURL       :: Maybe Text
  -- ^ Change the request URL to one provided here. Nothing means original URL.
  , mtBodyTransform    :: Maybe TemplateText
    -- ^ Go-Basic template script for transforming the request body
  , mtContentType      :: Maybe ContentType
  -- ^ Only the following Content-Types are allowed (default: application/json):
  , mtQueryParams      :: Maybe (M.HashMap Text (Maybe Text))
  -- ^ Replace any existing query params with those provided here
  , mtRequestHeaders   :: Maybe TransformHeaders
  -- ^ Transform headers as defined here.
  , mtTemplatingEngine :: TemplatingEngine
  -- ^ The template engine to use for transformations. Default: Kriti
  } deriving (Show, Eq, Generic)

instance NFData MetadataTransform
instance Cacheable MetadataTransform

instance J.ToJSON MetadataTransform where
  toJSON MetadataTransform{..} =
        J.object [ "method"         J..= mtRequestMethod
                 , "url"            J..= mtRequestURL
                 , "body"           J..= mtBodyTransform
                 , "content_type"    J..= mtContentType
                 , "query_params"    J..= mtQueryParams
                 , "request_headers" J..= mtRequestHeaders
                 , "template_engine" J..= mtTemplatingEngine
                 ]

instance J.FromJSON MetadataTransform where
  parseJSON = J.withObject "Object" $ \o -> do
     method         <- o J..:? "method"
     url            <- o J..:? "url"
     body           <- o J..:? "body"
     contentType    <- o J..:? "content_type"
     queryParams    <- o J..:? "query_params"
     headers        <- o J..:? "request_headers"
     templateEngine <- o J..:?  "template_engine"
     let templateEngine' = maybe Kriti id templateEngine
     pure $ MetadataTransform method url body contentType queryParams headers templateEngine'

-- | Available Template Languages
data TemplatingEngine = Kriti
  deriving (Show, Eq, Enum, Bounded, Generic)

renderTemplatingEngine :: TemplatingEngine -> Text
renderTemplatingEngine _ = "Kriti"

instance J.FromJSON TemplatingEngine where
  parseJSON = J.withText "TemplatingEngine" \case
    "Kriti" -> pure Kriti
    _       -> fail "Invalid TemplatingEngine"

instance J.ToJSON TemplatingEngine where
  toJSON = J.String . renderTemplatingEngine

instance NFData TemplatingEngine
instance Cacheable TemplatingEngine

newtype TemplateText = TemplateText T.Text
  deriving (Show, Eq, Generic)

instance NFData TemplateText
instance Cacheable TemplateText

instance J.FromJSON TemplateText where
  parseJSON = J.withText "TemplateText" (pure . TemplateText)

instance J.ToJSON TemplateText where
  toJSON = J.String . coerce

data ContentType = JSON | XWWWFORM
  deriving (Show, Eq, Enum, Bounded, Generic)

renderContentType :: ContentType -> Text
renderContentType = \case
  JSON     -> "application/json"
  XWWWFORM -> "application/x-www-form-urlencoded"

instance J.ToJSON ContentType where
  toJSON = J.String . renderContentType

instance J.FromJSON ContentType where
  parseJSON = J.withText "ContentType" \case
    "application/json"                  -> pure JSON
    "application/x-www-form-urlencoded" -> pure XWWWFORM
    _                                   -> fail "Invalid ContentType"

instance NFData ContentType
instance Cacheable ContentType

-- | This newtype exists solely to anchor a `FromJSON` instance and is
-- eliminated in the `TransformHeaders` `FromJSON` instance.
newtype HeaderKey = HeaderKey { unHeaderKey :: CI.CI Text }
  deriving (Show, Eq, Ord, Generic)

instance NFData HeaderKey
instance Cacheable HeaderKey

instance J.FromJSON HeaderKey where
  parseJSON = J.withText "HeaderKey" \txt -> case CI.mk txt of
    "Content-Type" -> fail "Restricted Header: Content-Type"
    key            -> pure $ HeaderKey key

data TransformHeaders = TransformHeaders
  { addHeaders    :: [(CI.CI Text, Text)]
  , removeHeaders :: [CI.CI Text]
  } deriving (Show, Eq, Ord, Generic)

instance NFData TransformHeaders
instance Cacheable TransformHeaders

instance J.ToJSON TransformHeaders where
  toJSON TransformHeaders{..} =
    J.object [ "add_headers" J..= M.fromList (fmap (first CI.original) addHeaders)
             , "remove_headers" J..= fmap CI.original removeHeaders
             ]

instance J.FromJSON TransformHeaders where
  parseJSON = J.withObject "TransformHeaders" $ \o -> do
    addHeaders :: M.HashMap Text Text <- fromMaybe mempty <$> o J..:? "add_headers"
    let headers = M.toList $ mapKeys CI.mk addHeaders
    removeHeaders <- o J..:? "remove_headers"
    let removeHeaders' = unHeaderKey <$> fromMaybe mempty removeHeaders
    pure $ TransformHeaders headers removeHeaders'

-- | Construct a `RequestTransform` from its metadata representation.
mkRequestTransform :: MetadataTransform -> RequestTransform
mkRequestTransform MetadataTransform{..} =
  let transformParams = fmap (bimap TE.encodeUtf8 (fmap TE.encodeUtf8)) . M.toList
      queryParams = transformParams <$> mtQueryParams
      headerTransform = maybe id mkHeaderTransform mtRequestHeaders
  in RequestTransform mtRequestMethod mtRequestURL (mkBodyTransform mtBodyTransform mtTemplatingEngine) mtContentType queryParams headerTransform

mkRequestTransformDebug :: MetadataTransform -> RequestTransform
mkRequestTransformDebug mt@MetadataTransform{mtBodyTransform, mtTemplatingEngine} =
  (mkRequestTransform mt) { rtBodyTransform = mkBodyTransform mtBodyTransform mtTemplatingEngine }

-- | Construct a Header Transformation function from a `TransformHeaders` value.
mkHeaderTransform :: TransformHeaders -> [HTTP.Header] -> [HTTP.Header]
mkHeaderTransform TransformHeaders{..} headers =
  let toBeRemoved = (fmap . CI.map) (TE.encodeUtf8) removeHeaders
      filteredHeaders = filter ((`notElem` toBeRemoved) . fst) headers
      newHeaders = fmap (bimap (CI.map TE.encodeUtf8) TE.encodeUtf8) addHeaders
  in newHeaders <> filteredHeaders

-- | Construct a Body Transformation function
mkBodyTransform :: Maybe TemplateText -> TemplatingEngine -> J.Value -> Maybe SessionVariables -> J.Value
mkBodyTransform Nothing _ source _ = source
mkBodyTransform (Just (TemplateText template)) engine source sessionVars =
  let context = [("$", source)] <> catMaybes [("$session",) . J.toJSON <$> sessionVars]
  in
  case engine of
    Kriti -> case runKriti template context of
      Left err  -> J.toJSON err
      Right res -> res

-- | Transform an `HTTP.Request` with a `RequestTransform`.
applyRequestTransform :: RequestTransform -> HTTP.Request -> Maybe SessionVariables -> HTTP.Request
applyRequestTransform RequestTransform{..} reqData sessionVars =
 let method = fmap (TE.encodeUtf8 . renderRequestMethod) rtRequestMethod
     bodyFunc (Just b) = case J.decode @J.Value b of
       Just val -> pure $ J.encode $ rtBodyTransform val sessionVars
       Nothing  -> pure b
     bodyFunc Nothing = Nothing
     contentType = maybe "application/json" (TE.encodeUtf8 . renderContentType) rtContentType
     headerFunc = nubBy (\a b -> fst a == fst b) . (:) ("Content-Type", contentType) . rtRequestHeaders
  in reqData & over HTTP.url (`fromMaybe` rtRequestURL)
             & over HTTP.method (`fromMaybe` method)
             & over HTTP.queryParams (`fromMaybe`rtQueryParams)
             & over HTTP.headers headerFunc
             & over HTTP.body bodyFunc