{-# OPTIONS_GHC -Wno-orphans #-}

module Hasura.RQL.DDL.Webhook.Transform.Url
  ( -- * Url Transformations
    Url (..),
    TransformFn (..),
    TransformCtx (..),
    UrlTransformFn (..),
  )
where

-------------------------------------------------------------------------------

import Data.Aeson qualified as J
import Data.Text qualified as T
import Data.Validation
import Hasura.Prelude
import Hasura.RQL.DDL.Webhook.Transform.Class
  ( TemplatingEngine,
    Transform (..),
    TransformErrorBundle (..),
    throwErrorBundle,
    wrapUnescapedTemplate,
  )
import Hasura.RQL.DDL.Webhook.Transform.Request
  ( RequestTransformCtx,
    runRequestTemplateTransform,
    validateRequestUnescapedTemplateTransform',
  )
import Hasura.RQL.Types.Webhook.Transform.Url (TransformCtx (..), TransformFn (..), Url (..), UrlTransformFn (..))
import Network.URI (parseURI)

-------------------------------------------------------------------------------

instance Transform Url where
  -- NOTE: GHC does not let us attach Haddock documentation to typeclass
  -- method implementations, so 'applyUrlTransformFn' is defined separately.
  transform :: forall (m :: * -> *).
MonadError TransformErrorBundle m =>
TransformFn Url -> TransformCtx Url -> Url -> m Url
transform (UrlTransformFn_ UrlTransformFn
fn) (TransformCtx RequestTransformCtx
reqCtx) = UrlTransformFn -> RequestTransformCtx -> Url -> m Url
forall (m :: * -> *).
MonadError TransformErrorBundle m =>
UrlTransformFn -> RequestTransformCtx -> Url -> m Url
applyUrlTransformFn UrlTransformFn
fn RequestTransformCtx
reqCtx

  -- NOTE: GHC does not let us attach Haddock documentation to typeclass
  -- method implementations, so 'validateUrlTransformFn' is defined separately.
  validate :: TemplatingEngine
-> TransformFn Url -> Validation TransformErrorBundle ()
validate TemplatingEngine
engine (UrlTransformFn_ UrlTransformFn
fn) = TemplatingEngine
-> UrlTransformFn -> Validation TransformErrorBundle ()
validateUrlTransformFn TemplatingEngine
engine UrlTransformFn
fn

-- | Provide an implementation for the transformations defined by
-- 'UrlTransformFn'.
--
-- If one views 'UrlTransformFn' as an interface describing URL
-- transformations, this can be seen as an implementation of these
-- transformations as normal Haskell functions.
applyUrlTransformFn ::
  (MonadError TransformErrorBundle m) =>
  UrlTransformFn ->
  RequestTransformCtx ->
  Url ->
  m Url
applyUrlTransformFn :: forall (m :: * -> *).
MonadError TransformErrorBundle m =>
UrlTransformFn -> RequestTransformCtx -> Url -> m Url
applyUrlTransformFn UrlTransformFn
fn RequestTransformCtx
context Url
_oldUrl = case UrlTransformFn
fn of
  Modify UnescapedTemplate
unescapedTemplate -> do
    let template :: Template
template = UnescapedTemplate -> Template
wrapUnescapedTemplate UnescapedTemplate
unescapedTemplate
    Value
resultJson <- Either TransformErrorBundle Value -> m Value
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either TransformErrorBundle Value -> m Value)
-> Either TransformErrorBundle Value -> m Value
forall a b. (a -> b) -> a -> b
$ Template
-> RequestTransformCtx -> Either TransformErrorBundle Value
runRequestTemplateTransform Template
template RequestTransformCtx
context
    Text
templatedUrlTxt <- case Value
resultJson of
      J.String Text
templatedUrlTxt -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
templatedUrlTxt
      Value
val -> do
        let errTxt :: Text
errTxt = Text
"URL Transforms must produce a JSON String: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
forall a. Show a => a -> Text
tshow Value
val
        Text -> Maybe Value -> m Text
forall (m :: * -> *) a.
MonadError TransformErrorBundle m =>
Text -> Maybe Value -> m a
throwErrorBundle Text
errTxt Maybe Value
forall a. Maybe a
Nothing
    case String -> Maybe URI
parseURI (Text -> String
T.unpack Text
templatedUrlTxt) of
      Maybe URI
Nothing -> Text -> Maybe Value -> m Url
forall (m :: * -> *) a.
MonadError TransformErrorBundle m =>
Text -> Maybe Value -> m a
throwErrorBundle (Text
"Invalid URL: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
templatedUrlTxt) Maybe Value
forall a. Maybe a
Nothing
      Just URI
_validatedUrl -> Url -> m Url
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Url -> m Url) -> Url -> m Url
forall a b. (a -> b) -> a -> b
$ Text -> Url
Url Text
templatedUrlTxt

-- | Validate that the provided 'UrlTransformFn' is correct in the context of a
-- particular 'TemplatingEngine'.
--
-- This is a product of the fact that the correctness of a given transformation
-- may be dependent on zero, one, or more of the templated transformations
-- encoded within the given 'UrlTransformFn'.
validateUrlTransformFn ::
  TemplatingEngine ->
  UrlTransformFn ->
  Validation TransformErrorBundle ()
validateUrlTransformFn :: TemplatingEngine
-> UrlTransformFn -> Validation TransformErrorBundle ()
validateUrlTransformFn TemplatingEngine
engine UrlTransformFn
fn = case UrlTransformFn
fn of
  Modify UnescapedTemplate
template ->
    TemplatingEngine
-> UnescapedTemplate -> Validation TransformErrorBundle ()
validateRequestUnescapedTemplateTransform' TemplatingEngine
engine UnescapedTemplate
template