module Hasura.RQL.DDL.Headers
  ( makeHeadersFromConf,
    toHeadersConf,
  )
where

import Data.CaseInsensitive qualified as CI
import Data.Environment qualified as Env
import Data.Text qualified as T
import Data.URL.Template (mkPlainTemplate, renderTemplate)
import Hasura.Base.Error
import Hasura.Base.Instances ()
import Hasura.Prelude
import Hasura.RQL.Types.Headers
import Network.HTTP.Types qualified as HTTP

-- | Resolve configuration headers
makeHeadersFromConf ::
  (MonadError QErr m) => Env.Environment -> [HeaderConf] -> m [HTTP.Header]
makeHeadersFromConf :: forall (m :: * -> *).
MonadError QErr m =>
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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)
-> (Text -> ByteString) -> Text -> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
txtToBs) (Text -> CI ByteString)
-> (Text -> ByteString) -> (Text, Text) -> Header
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> ByteString
txtToBs)
        ((Text, Text) -> Header) -> m (Text, Text) -> m Header
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case HeaderConf
hconf of
          (HeaderConf Text
name (HVValue Template
template)) -> do
            let renderedTemplate :: Either Text Text
renderedTemplate = Environment -> Template -> Either Text Text
renderTemplate Environment
env Template
template
            case Either Text Text
renderedTemplate of
              Left Text
e -> Code -> Text -> m (Text, Text)
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
NotFound (Text -> m (Text, Text)) -> Text -> m (Text, Text)
forall a b. (a -> b) -> a -> b
$ Text
"template cannot be resolved: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e
              Right Text
v -> (Text, Text) -> m (Text, Text)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
name, Text
v)
          (HeaderConf Text
name (HVEnv Text
val)) -> do
            let mEnv :: Maybe String
mEnv = Environment -> String -> Maybe String
Env.lookupEnv Environment
env (Text -> String
T.unpack Text
val)
            case Maybe String
mEnv of
              Maybe String
Nothing -> Code -> Text -> m (Text, Text)
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
NotFound (Text -> m (Text, Text)) -> Text -> m (Text, Text)
forall a b. (a -> b) -> a -> b
$ Text
"environment variable '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' not set"
              Just String
envval -> (Text, Text) -> m (Text, Text)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
name, String -> Text
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 ((Text -> HeaderValue -> HeaderConf)
-> (Text, HeaderValue) -> HeaderConf
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> HeaderValue -> HeaderConf
HeaderConf ((Text, HeaderValue) -> HeaderConf)
-> (Header -> (Text, HeaderValue)) -> Header -> HeaderConf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString -> Text
bsToTxt (ByteString -> Text)
-> (CI ByteString -> ByteString) -> CI ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> ByteString
forall s. CI s -> s
CI.original) (CI ByteString -> Text)
-> (ByteString -> HeaderValue) -> Header -> (Text, HeaderValue)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Template -> HeaderValue
HVValue (Template -> HeaderValue)
-> (ByteString -> Template) -> ByteString -> HeaderValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Template
mkPlainTemplate (Text -> Template)
-> (ByteString -> Text) -> ByteString -> Template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
bsToTxt)))