module Hasura.RQL.Types.Headers
  ( HeaderConf (..),
    HeaderValue (HVEnv, HVValue),
  )
where

import Autodocodec (HasCodec (codec), bimapCodec, disjointEitherCodec, requiredField')
import Autodocodec qualified as AC
import Data.Aeson
import Data.Text qualified as T
import Data.URL.Template
import Hasura.Base.Instances ()
import Hasura.Prelude

data HeaderConf = HeaderConf HeaderName HeaderValue
  deriving (Int -> HeaderConf -> ShowS
[HeaderConf] -> ShowS
HeaderConf -> String
(Int -> HeaderConf -> ShowS)
-> (HeaderConf -> String)
-> ([HeaderConf] -> ShowS)
-> Show HeaderConf
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeaderConf -> ShowS
showsPrec :: Int -> HeaderConf -> ShowS
$cshow :: HeaderConf -> String
show :: HeaderConf -> String
$cshowList :: [HeaderConf] -> ShowS
showList :: [HeaderConf] -> ShowS
Show, HeaderConf -> HeaderConf -> Bool
(HeaderConf -> HeaderConf -> Bool)
-> (HeaderConf -> HeaderConf -> Bool) -> Eq HeaderConf
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeaderConf -> HeaderConf -> Bool
== :: HeaderConf -> HeaderConf -> Bool
$c/= :: HeaderConf -> HeaderConf -> Bool
/= :: HeaderConf -> HeaderConf -> Bool
Eq, (forall x. HeaderConf -> Rep HeaderConf x)
-> (forall x. Rep HeaderConf x -> HeaderConf) -> Generic HeaderConf
forall x. Rep HeaderConf x -> HeaderConf
forall x. HeaderConf -> Rep HeaderConf x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HeaderConf -> Rep HeaderConf x
from :: forall x. HeaderConf -> Rep HeaderConf x
$cto :: forall x. Rep HeaderConf x -> HeaderConf
to :: forall x. Rep HeaderConf x -> HeaderConf
Generic)

instance NFData HeaderConf

instance Hashable HeaderConf

type HeaderName = Text

data HeaderValue = HVValue Template | HVEnv Text
  deriving (Int -> HeaderValue -> ShowS
[HeaderValue] -> ShowS
HeaderValue -> String
(Int -> HeaderValue -> ShowS)
-> (HeaderValue -> String)
-> ([HeaderValue] -> ShowS)
-> Show HeaderValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeaderValue -> ShowS
showsPrec :: Int -> HeaderValue -> ShowS
$cshow :: HeaderValue -> String
show :: HeaderValue -> String
$cshowList :: [HeaderValue] -> ShowS
showList :: [HeaderValue] -> ShowS
Show, HeaderValue -> HeaderValue -> Bool
(HeaderValue -> HeaderValue -> Bool)
-> (HeaderValue -> HeaderValue -> Bool) -> Eq HeaderValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeaderValue -> HeaderValue -> Bool
== :: HeaderValue -> HeaderValue -> Bool
$c/= :: HeaderValue -> HeaderValue -> Bool
/= :: HeaderValue -> HeaderValue -> Bool
Eq, (forall x. HeaderValue -> Rep HeaderValue x)
-> (forall x. Rep HeaderValue x -> HeaderValue)
-> Generic HeaderValue
forall x. Rep HeaderValue x -> HeaderValue
forall x. HeaderValue -> Rep HeaderValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HeaderValue -> Rep HeaderValue x
from :: forall x. HeaderValue -> Rep HeaderValue x
$cto :: forall x. Rep HeaderValue x -> HeaderValue
to :: forall x. Rep HeaderValue x -> HeaderValue
Generic)

instance NFData HeaderValue

instance Hashable HeaderValue

instance HasCodec HeaderConf where
  codec :: JSONCodec HeaderConf
codec = (Either (HeaderName, Template) (HeaderName, HeaderName)
 -> Either String HeaderConf)
-> (HeaderConf
    -> Either (HeaderName, Template) (HeaderName, HeaderName))
-> Codec
     Value
     (Either (HeaderName, Template) (HeaderName, HeaderName))
     (Either (HeaderName, Template) (HeaderName, HeaderName))
-> JSONCodec HeaderConf
forall oldOutput newOutput newInput oldInput context.
(oldOutput -> Either String newOutput)
-> (newInput -> oldInput)
-> Codec context oldInput oldOutput
-> Codec context newInput newOutput
bimapCodec Either (HeaderName, Template) (HeaderName, HeaderName)
-> Either String HeaderConf
dec HeaderConf
-> Either (HeaderName, Template) (HeaderName, HeaderName)
enc (Codec
   Value
   (Either (HeaderName, Template) (HeaderName, HeaderName))
   (Either (HeaderName, Template) (HeaderName, HeaderName))
 -> JSONCodec HeaderConf)
-> Codec
     Value
     (Either (HeaderName, Template) (HeaderName, HeaderName))
     (Either (HeaderName, Template) (HeaderName, HeaderName))
-> JSONCodec HeaderConf
forall a b. (a -> b) -> a -> b
$ Codec Value (HeaderName, Template) (HeaderName, Template)
-> Codec Value (HeaderName, HeaderName) (HeaderName, HeaderName)
-> Codec
     Value
     (Either (HeaderName, Template) (HeaderName, HeaderName))
     (Either (HeaderName, Template) (HeaderName, HeaderName))
forall context input1 output1 input2 output2.
Codec context input1 output1
-> Codec context input2 output2
-> Codec context (Either input1 input2) (Either output1 output2)
disjointEitherCodec Codec Value (HeaderName, Template) (HeaderName, Template)
valCodec Codec Value (HeaderName, HeaderName) (HeaderName, HeaderName)
fromEnvCodec
    where
      valCodec :: Codec Value (HeaderName, Template) (HeaderName, Template)
valCodec =
        HeaderName
-> ObjectCodec (HeaderName, Template) (HeaderName, Template)
-> Codec Value (HeaderName, Template) (HeaderName, Template)
forall input output.
HeaderName -> ObjectCodec input output -> ValueCodec input output
AC.object HeaderName
"HeaderConfValue"
          (ObjectCodec (HeaderName, Template) (HeaderName, Template)
 -> Codec Value (HeaderName, Template) (HeaderName, Template))
-> ObjectCodec (HeaderName, Template) (HeaderName, Template)
-> Codec Value (HeaderName, Template) (HeaderName, Template)
forall a b. (a -> b) -> a -> b
$ (,)
          (HeaderName -> Template -> (HeaderName, Template))
-> Codec Object (HeaderName, Template) HeaderName
-> Codec
     Object (HeaderName, Template) (Template -> (HeaderName, Template))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> ObjectCodec HeaderName HeaderName
forall output.
HasCodec output =>
HeaderName -> ObjectCodec output output
requiredField' HeaderName
"name"
          ObjectCodec HeaderName HeaderName
-> ((HeaderName, Template) -> HeaderName)
-> Codec Object (HeaderName, Template) HeaderName
forall oldInput output newInput.
ObjectCodec oldInput output
-> (newInput -> oldInput) -> ObjectCodec newInput output
AC..= (HeaderName, Template) -> HeaderName
forall a b. (a, b) -> a
fst
            Codec
  Object (HeaderName, Template) (Template -> (HeaderName, Template))
-> Codec Object (HeaderName, Template) Template
-> ObjectCodec (HeaderName, Template) (HeaderName, Template)
forall a b.
Codec Object (HeaderName, Template) (a -> b)
-> Codec Object (HeaderName, Template) a
-> Codec Object (HeaderName, Template) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeaderName -> ObjectCodec Template Template
forall output.
HasCodec output =>
HeaderName -> ObjectCodec output output
requiredField' HeaderName
"value"
          ObjectCodec Template Template
-> ((HeaderName, Template) -> Template)
-> Codec Object (HeaderName, Template) Template
forall oldInput output newInput.
ObjectCodec oldInput output
-> (newInput -> oldInput) -> ObjectCodec newInput output
AC..= (HeaderName, Template) -> Template
forall a b. (a, b) -> b
snd

      fromEnvCodec :: Codec Value (HeaderName, HeaderName) (HeaderName, HeaderName)
fromEnvCodec =
        HeaderName
-> ObjectCodec (HeaderName, HeaderName) (HeaderName, HeaderName)
-> Codec Value (HeaderName, HeaderName) (HeaderName, HeaderName)
forall input output.
HeaderName -> ObjectCodec input output -> ValueCodec input output
AC.object HeaderName
"HeaderConfFromEnv"
          (ObjectCodec (HeaderName, HeaderName) (HeaderName, HeaderName)
 -> Codec Value (HeaderName, HeaderName) (HeaderName, HeaderName))
-> ObjectCodec (HeaderName, HeaderName) (HeaderName, HeaderName)
-> Codec Value (HeaderName, HeaderName) (HeaderName, HeaderName)
forall a b. (a -> b) -> a -> b
$ (,)
          (HeaderName -> HeaderName -> (HeaderName, HeaderName))
-> Codec Object (HeaderName, HeaderName) HeaderName
-> Codec
     Object
     (HeaderName, HeaderName)
     (HeaderName -> (HeaderName, HeaderName))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> ObjectCodec HeaderName HeaderName
forall output.
HasCodec output =>
HeaderName -> ObjectCodec output output
requiredField' HeaderName
"name"
          ObjectCodec HeaderName HeaderName
-> ((HeaderName, HeaderName) -> HeaderName)
-> Codec Object (HeaderName, HeaderName) HeaderName
forall oldInput output newInput.
ObjectCodec oldInput output
-> (newInput -> oldInput) -> ObjectCodec newInput output
AC..= (HeaderName, HeaderName) -> HeaderName
forall a b. (a, b) -> a
fst
            Codec
  Object
  (HeaderName, HeaderName)
  (HeaderName -> (HeaderName, HeaderName))
-> Codec Object (HeaderName, HeaderName) HeaderName
-> ObjectCodec (HeaderName, HeaderName) (HeaderName, HeaderName)
forall a b.
Codec Object (HeaderName, HeaderName) (a -> b)
-> Codec Object (HeaderName, HeaderName) a
-> Codec Object (HeaderName, HeaderName) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeaderName -> ObjectCodec HeaderName HeaderName
forall output.
HasCodec output =>
HeaderName -> ObjectCodec output output
requiredField' HeaderName
"value_from_env"
          ObjectCodec HeaderName HeaderName
-> ((HeaderName, HeaderName) -> HeaderName)
-> Codec Object (HeaderName, HeaderName) HeaderName
forall oldInput output newInput.
ObjectCodec oldInput output
-> (newInput -> oldInput) -> ObjectCodec newInput output
AC..= (HeaderName, HeaderName) -> HeaderName
forall a b. (a, b) -> b
snd

      dec :: Either (HeaderName, Template) (HeaderName, HeaderName)
-> Either String HeaderConf
dec (Left (HeaderName
name, Template
value)) = HeaderConf -> Either String HeaderConf
forall a b. b -> Either a b
Right (HeaderConf -> Either String HeaderConf)
-> HeaderConf -> Either String HeaderConf
forall a b. (a -> b) -> a -> b
$ HeaderName -> HeaderValue -> HeaderConf
HeaderConf HeaderName
name (Template -> HeaderValue
HVValue Template
value)
      dec (Right (HeaderName
name, HeaderName
valueFromEnv)) =
        if HeaderName -> HeaderName -> Bool
T.isPrefixOf HeaderName
"HASURA_GRAPHQL_" HeaderName
valueFromEnv
          then String -> Either String HeaderConf
forall a b. a -> Either a b
Left (String -> Either String HeaderConf)
-> String -> Either String HeaderConf
forall a b. (a -> b) -> a -> b
$ String
"env variables starting with \"HASURA_GRAPHQL_\" are not allowed in value_from_env: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HeaderName -> String
T.unpack HeaderName
valueFromEnv
          else HeaderConf -> Either String HeaderConf
forall a b. b -> Either a b
Right (HeaderConf -> Either String HeaderConf)
-> HeaderConf -> Either String HeaderConf
forall a b. (a -> b) -> a -> b
$ HeaderName -> HeaderValue -> HeaderConf
HeaderConf HeaderName
name (HeaderName -> HeaderValue
HVEnv HeaderName
valueFromEnv)

      enc :: HeaderConf
-> Either (HeaderName, Template) (HeaderName, HeaderName)
enc (HeaderConf HeaderName
name (HVValue Template
val)) = (HeaderName, Template)
-> Either (HeaderName, Template) (HeaderName, HeaderName)
forall a b. a -> Either a b
Left (HeaderName
name, Template
val)
      enc (HeaderConf HeaderName
name (HVEnv HeaderName
val)) = (HeaderName, HeaderName)
-> Either (HeaderName, Template) (HeaderName, HeaderName)
forall a b. b -> Either a b
Right (HeaderName
name, HeaderName
val)

instance FromJSON HeaderConf where
  parseJSON :: Value -> Parser HeaderConf
parseJSON (Object Object
o) = do
    HeaderName
name <- Object
o Object -> Key -> Parser HeaderName
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
    Maybe Value
value <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"value"
    Maybe HeaderName
valueFromEnv <- Object
o Object -> Key -> Parser (Maybe HeaderName)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"value_from_env"
    case (Maybe Value
value, Maybe HeaderName
valueFromEnv) of
      (Maybe Value
Nothing, Maybe HeaderName
Nothing) -> String -> Parser HeaderConf
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expecting value or value_from_env keys"
      (Just Value
val, Maybe HeaderName
Nothing) -> do
        Template
template <- Value -> Parser Template
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
        HeaderConf -> Parser HeaderConf
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (HeaderConf -> Parser HeaderConf)
-> HeaderConf -> Parser HeaderConf
forall a b. (a -> b) -> a -> b
$ HeaderName -> HeaderValue -> HeaderConf
HeaderConf HeaderName
name (Template -> HeaderValue
HVValue Template
template)
      (Maybe Value
Nothing, Just HeaderName
val) -> do
        Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HeaderName -> HeaderName -> Bool
T.isPrefixOf HeaderName
"HASURA_GRAPHQL_" HeaderName
val)
          (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
          (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
"env variables starting with \"HASURA_GRAPHQL_\" are not allowed in value_from_env: "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HeaderName -> String
T.unpack HeaderName
val
        HeaderConf -> Parser HeaderConf
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (HeaderConf -> Parser HeaderConf)
-> HeaderConf -> Parser HeaderConf
forall a b. (a -> b) -> a -> b
$ HeaderName -> HeaderValue -> HeaderConf
HeaderConf HeaderName
name (HeaderName -> HeaderValue
HVEnv HeaderName
val)
      (Just Value
_, Just HeaderName
_) -> String -> Parser HeaderConf
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expecting only one of value or value_from_env keys"
  parseJSON Value
_ = String -> Parser HeaderConf
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expecting object for headers"

instance ToJSON HeaderConf where
  toJSON :: HeaderConf -> Value
toJSON (HeaderConf HeaderName
name (HVValue Template
val)) = [Pair] -> Value
object [Key
"name" Key -> HeaderName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= HeaderName
name, Key
"value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Template -> Value
forall a. ToJSON a => a -> Value
toJSON Template
val]
  toJSON (HeaderConf HeaderName
name (HVEnv HeaderName
val)) = [Pair] -> Value
object [Key
"name" Key -> HeaderName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= HeaderName
name, Key
"value_from_env" Key -> HeaderName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= HeaderName
val]