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

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

import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson qualified as J
import Data.Text qualified as T
import Data.Validation
import Hasura.Incremental (Cacheable)
import Hasura.Prelude
import Hasura.RQL.DDL.Webhook.Transform.Class
  ( RequestTransformCtx (..),
    TemplatingEngine,
    Transform (..),
    TransformErrorBundle (..),
    UnescapedTemplate (..),
    runRequestTemplateTransform,
    throwErrorBundle,
    validateRequestUnescapedTemplateTransform',
    wrapUnescapedTemplate,
  )
import Network.URI (parseURI)

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

-- | The actual URL string we are transforming.
--
-- This newtype is necessary because otherwise we end up with an
-- orphan instance.
newtype Url = Url {Url -> Text
unUrl :: Text}
  deriving stock (Url -> Url -> Bool
(Url -> Url -> Bool) -> (Url -> Url -> Bool) -> Eq Url
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Url -> Url -> Bool
$c/= :: Url -> Url -> Bool
== :: Url -> Url -> Bool
$c== :: Url -> Url -> Bool
Eq, Int -> Url -> ShowS
[Url] -> ShowS
Url -> String
(Int -> Url -> ShowS)
-> (Url -> String) -> ([Url] -> ShowS) -> Show Url
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Url] -> ShowS
$cshowList :: [Url] -> ShowS
show :: Url -> String
$cshow :: Url -> String
showsPrec :: Int -> Url -> ShowS
$cshowsPrec :: Int -> Url -> ShowS
Show)

instance Transform Url where
  -- NOTE: GHC does not let us attach Haddock documentation to data family
  -- instances, so 'UrlTransformFn' is defined separately from this
  -- wrapper.
  newtype TransformFn Url = UrlTransformFn_ UrlTransformFn
    deriving stock (TransformFn Url -> TransformFn Url -> Bool
(TransformFn Url -> TransformFn Url -> Bool)
-> (TransformFn Url -> TransformFn Url -> Bool)
-> Eq (TransformFn Url)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransformFn Url -> TransformFn Url -> Bool
$c/= :: TransformFn Url -> TransformFn Url -> Bool
== :: TransformFn Url -> TransformFn Url -> Bool
$c== :: TransformFn Url -> TransformFn Url -> Bool
Eq, (forall x. TransformFn Url -> Rep (TransformFn Url) x)
-> (forall x. Rep (TransformFn Url) x -> TransformFn Url)
-> Generic (TransformFn Url)
forall x. Rep (TransformFn Url) x -> TransformFn Url
forall x. TransformFn Url -> Rep (TransformFn Url) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep (TransformFn Url) x -> TransformFn Url
$cfrom :: forall x. TransformFn Url -> Rep (TransformFn Url) x
Generic, Int -> TransformFn Url -> ShowS
[TransformFn Url] -> ShowS
TransformFn Url -> String
(Int -> TransformFn Url -> ShowS)
-> (TransformFn Url -> String)
-> ([TransformFn Url] -> ShowS)
-> Show (TransformFn Url)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransformFn Url] -> ShowS
$cshowList :: [TransformFn Url] -> ShowS
show :: TransformFn Url -> String
$cshow :: TransformFn Url -> String
showsPrec :: Int -> TransformFn Url -> ShowS
$cshowsPrec :: Int -> TransformFn Url -> ShowS
Show)
    deriving newtype (Eq (TransformFn Url)
Eq (TransformFn Url)
-> (Accesses -> TransformFn Url -> TransformFn Url -> Bool)
-> Cacheable (TransformFn Url)
Accesses -> TransformFn Url -> TransformFn Url -> Bool
forall a. Eq a -> (Accesses -> a -> a -> Bool) -> Cacheable a
unchanged :: Accesses -> TransformFn Url -> TransformFn Url -> Bool
$cunchanged :: Accesses -> TransformFn Url -> TransformFn Url -> Bool
$cp1Cacheable :: Eq (TransformFn Url)
Cacheable, TransformFn Url -> ()
(TransformFn Url -> ()) -> NFData (TransformFn Url)
forall a. (a -> ()) -> NFData a
rnf :: TransformFn Url -> ()
$crnf :: TransformFn Url -> ()
NFData, Value -> Parser [TransformFn Url]
Value -> Parser (TransformFn Url)
(Value -> Parser (TransformFn Url))
-> (Value -> Parser [TransformFn Url])
-> FromJSON (TransformFn Url)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [TransformFn Url]
$cparseJSONList :: Value -> Parser [TransformFn Url]
parseJSON :: Value -> Parser (TransformFn Url)
$cparseJSON :: Value -> Parser (TransformFn Url)
FromJSON, [TransformFn Url] -> Value
[TransformFn Url] -> Encoding
TransformFn Url -> Value
TransformFn Url -> Encoding
(TransformFn Url -> Value)
-> (TransformFn Url -> Encoding)
-> ([TransformFn Url] -> Value)
-> ([TransformFn Url] -> Encoding)
-> ToJSON (TransformFn Url)
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TransformFn Url] -> Encoding
$ctoEncodingList :: [TransformFn Url] -> Encoding
toJSONList :: [TransformFn Url] -> Value
$ctoJSONList :: [TransformFn Url] -> Value
toEncoding :: TransformFn Url -> Encoding
$ctoEncoding :: TransformFn Url -> Encoding
toJSON :: TransformFn Url -> Value
$ctoJSON :: TransformFn Url -> Value
ToJSON)

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

  -- 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_ fn) = TemplatingEngine
-> UrlTransformFn -> Validation TransformErrorBundle ()
validateUrlTransformFn TemplatingEngine
engine UrlTransformFn
fn

-- | The defunctionalized transformation function on 'Url'
newtype UrlTransformFn
  = Modify UnescapedTemplate
  deriving stock (UrlTransformFn -> UrlTransformFn -> Bool
(UrlTransformFn -> UrlTransformFn -> Bool)
-> (UrlTransformFn -> UrlTransformFn -> Bool) -> Eq UrlTransformFn
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UrlTransformFn -> UrlTransformFn -> Bool
$c/= :: UrlTransformFn -> UrlTransformFn -> Bool
== :: UrlTransformFn -> UrlTransformFn -> Bool
$c== :: UrlTransformFn -> UrlTransformFn -> Bool
Eq, (forall x. UrlTransformFn -> Rep UrlTransformFn x)
-> (forall x. Rep UrlTransformFn x -> UrlTransformFn)
-> Generic UrlTransformFn
forall x. Rep UrlTransformFn x -> UrlTransformFn
forall x. UrlTransformFn -> Rep UrlTransformFn x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UrlTransformFn x -> UrlTransformFn
$cfrom :: forall x. UrlTransformFn -> Rep UrlTransformFn x
Generic, Int -> UrlTransformFn -> ShowS
[UrlTransformFn] -> ShowS
UrlTransformFn -> String
(Int -> UrlTransformFn -> ShowS)
-> (UrlTransformFn -> String)
-> ([UrlTransformFn] -> ShowS)
-> Show UrlTransformFn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UrlTransformFn] -> ShowS
$cshowList :: [UrlTransformFn] -> ShowS
show :: UrlTransformFn -> String
$cshow :: UrlTransformFn -> String
showsPrec :: Int -> UrlTransformFn -> ShowS
$cshowsPrec :: Int -> UrlTransformFn -> ShowS
Show)
  deriving newtype (Eq UrlTransformFn
Eq UrlTransformFn
-> (Accesses -> UrlTransformFn -> UrlTransformFn -> Bool)
-> Cacheable UrlTransformFn
Accesses -> UrlTransformFn -> UrlTransformFn -> Bool
forall a. Eq a -> (Accesses -> a -> a -> Bool) -> Cacheable a
unchanged :: Accesses -> UrlTransformFn -> UrlTransformFn -> Bool
$cunchanged :: Accesses -> UrlTransformFn -> UrlTransformFn -> Bool
$cp1Cacheable :: Eq UrlTransformFn
Cacheable, UrlTransformFn -> ()
(UrlTransformFn -> ()) -> NFData UrlTransformFn
forall a. (a -> ()) -> NFData a
rnf :: UrlTransformFn -> ()
$crnf :: UrlTransformFn -> ()
NFData, Value -> Parser [UrlTransformFn]
Value -> Parser UrlTransformFn
(Value -> Parser UrlTransformFn)
-> (Value -> Parser [UrlTransformFn]) -> FromJSON UrlTransformFn
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [UrlTransformFn]
$cparseJSONList :: Value -> Parser [UrlTransformFn]
parseJSON :: Value -> Parser UrlTransformFn
$cparseJSON :: Value -> Parser UrlTransformFn
FromJSON, [UrlTransformFn] -> Value
[UrlTransformFn] -> Encoding
UrlTransformFn -> Value
UrlTransformFn -> Encoding
(UrlTransformFn -> Value)
-> (UrlTransformFn -> Encoding)
-> ([UrlTransformFn] -> Value)
-> ([UrlTransformFn] -> Encoding)
-> ToJSON UrlTransformFn
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [UrlTransformFn] -> Encoding
$ctoEncodingList :: [UrlTransformFn] -> Encoding
toJSONList :: [UrlTransformFn] -> Value
$ctoJSONList :: [UrlTransformFn] -> Value
toEncoding :: UrlTransformFn -> Encoding
$ctoEncoding :: UrlTransformFn -> Encoding
toJSON :: UrlTransformFn -> Value
$ctoJSON :: UrlTransformFn -> Value
ToJSON)

-- | 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 :: 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 (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 (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