{-# LANGUAGE DeriveAnyClass #-}

module Hasura.RQL.DDL.Webhook.Transform.Method
  ( -- * Method transformations
    Method (..),
    TransformFn (..),
    MethodTransformFn (..),
  )
where

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

import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson qualified as J
import Data.CaseInsensitive qualified as CI
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 (..),
  )

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

-- | The actual request method we are transforming.
--
-- This newtype is necessary because otherwise we end up with an
-- orphan instance.
newtype Method = Method (CI.CI T.Text)
  deriving stock ((forall x. Method -> Rep Method x)
-> (forall x. Rep Method x -> Method) -> Generic Method
forall x. Rep Method x -> Method
forall x. Method -> Rep Method x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Method x -> Method
$cfrom :: forall x. Method -> Rep Method x
Generic)
  deriving newtype (Int -> Method -> ShowS
[Method] -> ShowS
Method -> String
(Int -> Method -> ShowS)
-> (Method -> String) -> ([Method] -> ShowS) -> Show Method
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Method] -> ShowS
$cshowList :: [Method] -> ShowS
show :: Method -> String
$cshow :: Method -> String
showsPrec :: Int -> Method -> ShowS
$cshowsPrec :: Int -> Method -> ShowS
Show, Method -> Method -> Bool
(Method -> Method -> Bool)
-> (Method -> Method -> Bool) -> Eq Method
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Method -> Method -> Bool
$c/= :: Method -> Method -> Bool
== :: Method -> Method -> Bool
$c== :: Method -> Method -> Bool
Eq)
  deriving anyclass (Method -> ()
(Method -> ()) -> NFData Method
forall a. (a -> ()) -> NFData a
rnf :: Method -> ()
$crnf :: Method -> ()
NFData, Eq Method
Eq Method
-> (Accesses -> Method -> Method -> Bool) -> Cacheable Method
Accesses -> Method -> Method -> Bool
forall a. Eq a -> (Accesses -> a -> a -> Bool) -> Cacheable a
unchanged :: Accesses -> Method -> Method -> Bool
$cunchanged :: Accesses -> Method -> Method -> Bool
$cp1Cacheable :: Eq Method
Cacheable)

instance J.ToJSON Method where
  toJSON :: Method -> Value
toJSON = Text -> Value
J.String (Text -> Value) -> (Method -> Text) -> Method -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> Text
forall s. CI s -> s
CI.original (CI Text -> Text) -> (Method -> CI Text) -> Method -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> CI Text
coerce

instance J.FromJSON Method where
  parseJSON :: Value -> Parser Method
parseJSON = String -> (Text -> Parser Method) -> Value -> Parser Method
forall a. String -> (Text -> Parser a) -> Value -> Parser a
J.withText String
"Method" (Method -> Parser Method
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Method -> Parser Method)
-> (Text -> Method) -> Text -> Parser Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> Method
coerce (CI Text -> Method) -> (Text -> CI Text) -> Text -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk)

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

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

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

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

-- | Provide an implementation for the transformations defined by
-- 'MethodTransformFn'.
--
-- If one views 'MethodTransformFn' as an interface describing HTTP method
-- transformations, this can be seen as an implementation of these
-- transformations as normal Haskell functions.
applyMethodTransformFn ::
  MonadError TransformErrorBundle m =>
  MethodTransformFn ->
  RequestTransformCtx ->
  Method ->
  m Method
applyMethodTransformFn :: MethodTransformFn -> RequestTransformCtx -> Method -> m Method
applyMethodTransformFn MethodTransformFn
fn RequestTransformCtx
_context Method
_oldMethod = case MethodTransformFn
fn of
  Replace Method
newMethod -> Method -> m Method
forall (f :: * -> *) a. Applicative f => a -> f a
pure Method
newMethod

-- | Validate that the provided 'MethodTransformFn' 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 'MethodTransformFn'.
--
-- XXX: Do we want to validate the HTTP method verb?
validateMethodTransformFn ::
  TemplatingEngine ->
  MethodTransformFn ->
  Validation TransformErrorBundle ()
validateMethodTransformFn :: TemplatingEngine
-> MethodTransformFn -> Validation TransformErrorBundle ()
validateMethodTransformFn TemplatingEngine
_engine = \case
  Replace Method
_method -> () -> Validation TransformErrorBundle ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()