module Hasura.RQL.DDL.Headers
  ( HeaderConf (..),
    HeaderValue (HVEnv, HVValue),
    makeHeadersFromConf,
    toHeadersConf,
  )
where

import Data.Aeson
import Data.CaseInsensitive qualified as CI
import Data.Environment qualified as Env
import Data.Text qualified as T
import Hasura.Base.Error
import Hasura.Base.Instances ()
import Hasura.Incremental (Cacheable)
import Hasura.Prelude
import Network.HTTP.Types qualified as HTTP

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
showList :: [HeaderConf] -> ShowS
$cshowList :: [HeaderConf] -> ShowS
show :: HeaderConf -> String
$cshow :: HeaderConf -> String
showsPrec :: Int -> HeaderConf -> ShowS
$cshowsPrec :: Int -> HeaderConf -> ShowS
Show, HeaderConf -> HeaderConf -> Bool
(HeaderConf -> HeaderConf -> Bool)
-> (HeaderConf -> HeaderConf -> Bool) -> Eq HeaderConf
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderConf -> HeaderConf -> Bool
$c/= :: HeaderConf -> HeaderConf -> Bool
== :: HeaderConf -> HeaderConf -> Bool
$c== :: 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
$cto :: forall x. Rep HeaderConf x -> HeaderConf
$cfrom :: forall x. HeaderConf -> Rep HeaderConf x
Generic)

instance NFData HeaderConf

instance Hashable HeaderConf

instance Cacheable HeaderConf

type HeaderName = Text

data HeaderValue = HVValue Text | 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
showList :: [HeaderValue] -> ShowS
$cshowList :: [HeaderValue] -> ShowS
show :: HeaderValue -> String
$cshow :: HeaderValue -> String
showsPrec :: Int -> HeaderValue -> ShowS
$cshowsPrec :: Int -> HeaderValue -> ShowS
Show, HeaderValue -> HeaderValue -> Bool
(HeaderValue -> HeaderValue -> Bool)
-> (HeaderValue -> HeaderValue -> Bool) -> Eq HeaderValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderValue -> HeaderValue -> Bool
$c/= :: HeaderValue -> HeaderValue -> Bool
== :: HeaderValue -> HeaderValue -> Bool
$c== :: 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
$cto :: forall x. Rep HeaderValue x -> HeaderValue
$cfrom :: forall x. HeaderValue -> Rep HeaderValue x
Generic)

instance NFData HeaderValue

instance Hashable HeaderValue

instance Cacheable HeaderValue

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 HeaderName
value <- Object
o Object -> Key -> Parser (Maybe HeaderName)
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 HeaderName
value, Maybe HeaderName
valueFromEnv) of
      (Maybe HeaderName
Nothing, Maybe HeaderName
Nothing) -> String -> Parser HeaderConf
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expecting value or value_from_env keys"
      (Just HeaderName
val, Maybe HeaderName
Nothing) -> HeaderConf -> Parser HeaderConf
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
HVValue HeaderName
val)
      (Maybe HeaderName
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 (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 (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 HeaderName
_, Just HeaderName
_) -> String -> Parser HeaderConf
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 (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 HeaderName
val)) = [Pair] -> Value
object [Key
"name" Key -> HeaderName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HeaderName
name, Key
"value" Key -> HeaderName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HeaderName
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
.= HeaderName
name, Key
"value_from_env" Key -> HeaderName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HeaderName
val]

-- | Resolve configuration headers
makeHeadersFromConf ::
  MonadError QErr m => Env.Environment -> [HeaderConf] -> m [HTTP.Header]
makeHeadersFromConf :: Environment -> [HeaderConf] -> m [Header]
makeHeadersFromConf Environment
env = (HeaderConf -> m Header) -> [HeaderConf] -> m [Header]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HeaderConf -> m Header
getHeader
  where
    getHeader :: HeaderConf -> m Header
getHeader HeaderConf
hconf =
      ((ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> (HeaderName -> ByteString) -> HeaderName -> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString
txtToBs) (HeaderName -> CI ByteString)
-> (HeaderName -> ByteString) -> (HeaderName, HeaderName) -> Header
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** HeaderName -> ByteString
txtToBs)
        ((HeaderName, HeaderName) -> Header)
-> m (HeaderName, HeaderName) -> m Header
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case HeaderConf
hconf of
          (HeaderConf HeaderName
name (HVValue HeaderName
val)) -> (HeaderName, HeaderName) -> m (HeaderName, HeaderName)
forall (m :: * -> *) a. Monad m => a -> m a
return (HeaderName
name, HeaderName
val)
          (HeaderConf HeaderName
name (HVEnv HeaderName
val)) -> do
            let mEnv :: Maybe String
mEnv = Environment -> String -> Maybe String
Env.lookupEnv Environment
env (HeaderName -> String
T.unpack HeaderName
val)
            case Maybe String
mEnv of
              Maybe String
Nothing -> Code -> HeaderName -> m (HeaderName, HeaderName)
forall (m :: * -> *) a. QErrM m => Code -> HeaderName -> m a
throw400 Code
NotFound (HeaderName -> m (HeaderName, HeaderName))
-> HeaderName -> m (HeaderName, HeaderName)
forall a b. (a -> b) -> a -> b
$ HeaderName
"environment variable '" HeaderName -> HeaderName -> HeaderName
forall a. Semigroup a => a -> a -> a
<> HeaderName
val HeaderName -> HeaderName -> HeaderName
forall a. Semigroup a => a -> a -> a
<> HeaderName
"' not set"
              Just String
envval -> (HeaderName, HeaderName) -> m (HeaderName, HeaderName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeaderName
name, String -> HeaderName
T.pack String
envval)

-- | Encode headers to HeaderConf
toHeadersConf :: [HTTP.Header] -> [HeaderConf]
toHeadersConf :: [Header] -> [HeaderConf]
toHeadersConf =
  (Header -> HeaderConf) -> [Header] -> [HeaderConf]
forall a b. (a -> b) -> [a] -> [b]
map ((HeaderName -> HeaderValue -> HeaderConf)
-> (HeaderName, HeaderValue) -> HeaderConf
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HeaderName -> HeaderValue -> HeaderConf
HeaderConf ((HeaderName, HeaderValue) -> HeaderConf)
-> (Header -> (HeaderName, HeaderValue)) -> Header -> HeaderConf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString -> HeaderName
bsToTxt (ByteString -> HeaderName)
-> (CI ByteString -> ByteString) -> CI ByteString -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> ByteString
forall s. CI s -> s
CI.original) (CI ByteString -> HeaderName)
-> (ByteString -> HeaderValue)
-> Header
-> (HeaderName, HeaderValue)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (HeaderName -> HeaderValue
HVValue (HeaderName -> HeaderValue)
-> (ByteString -> HeaderName) -> ByteString -> HeaderValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HeaderName
bsToTxt)))