mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 04:24:35 +03:00
4d6604ba08
Codecs for event triggers, including webhook transforms. These are not hooked into the higher-up table metadata codec yet because some backend implementations implement event triggers with `error` which causes an error when codecs are evaluated. I plan to follow up with another PR to resolve that. Ticket: https://hasurahq.atlassian.net/browse/GDC-585 PR-URL: https://github.com/hasura/graphql-engine-mono/pull/7237 GitOrigin-RevId: 8ce40fe6fedcf8b109d6ca50a505333df855a8ce
99 lines
3.4 KiB
Haskell
99 lines
3.4 KiB
Haskell
module Hasura.RQL.DDL.Headers
|
|
( HeaderConf (..),
|
|
HeaderValue (HVEnv, HVValue),
|
|
makeHeadersFromConf,
|
|
toHeadersConf,
|
|
)
|
|
where
|
|
|
|
import Autodocodec (HasCodec (codec), bimapCodec, disjointEitherCodec, requiredField')
|
|
import Autodocodec qualified as AC
|
|
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.Prelude
|
|
import Network.HTTP.Types qualified as HTTP
|
|
|
|
data HeaderConf = HeaderConf HeaderName HeaderValue
|
|
deriving (Show, Eq, Generic)
|
|
|
|
instance NFData HeaderConf
|
|
|
|
instance Hashable HeaderConf
|
|
|
|
type HeaderName = Text
|
|
|
|
data HeaderValue = HVValue Text | HVEnv Text
|
|
deriving (Show, Eq, Generic)
|
|
|
|
instance NFData HeaderValue
|
|
|
|
instance Hashable HeaderValue
|
|
|
|
instance HasCodec HeaderConf where
|
|
codec = bimapCodec dec enc $ disjointEitherCodec valCodec fromEnvCodec
|
|
where
|
|
valCodec =
|
|
AC.object "HeaderConfValue" $
|
|
(,)
|
|
<$> requiredField' "name" AC..= fst
|
|
<*> requiredField' "value" AC..= snd
|
|
|
|
fromEnvCodec =
|
|
AC.object "HeaderConfFromEnv" $
|
|
(,)
|
|
<$> requiredField' "name" AC..= fst
|
|
<*> requiredField' "value_from_env" AC..= snd
|
|
|
|
dec (Left (name, value)) = Right $ HeaderConf name (HVValue value)
|
|
dec (Right (name, valueFromEnv)) =
|
|
if T.isPrefixOf "HASURA_GRAPHQL_" valueFromEnv
|
|
then Left $ "env variables starting with \"HASURA_GRAPHQL_\" are not allowed in value_from_env: " <> T.unpack valueFromEnv
|
|
else Right $ HeaderConf name (HVEnv valueFromEnv)
|
|
|
|
enc (HeaderConf name (HVValue val)) = Left (name, val)
|
|
enc (HeaderConf name (HVEnv val)) = Right (name, val)
|
|
|
|
instance FromJSON HeaderConf where
|
|
parseJSON (Object o) = do
|
|
name <- o .: "name"
|
|
value <- o .:? "value"
|
|
valueFromEnv <- o .:? "value_from_env"
|
|
case (value, valueFromEnv) of
|
|
(Nothing, Nothing) -> fail "expecting value or value_from_env keys"
|
|
(Just val, Nothing) -> return $ HeaderConf name (HVValue val)
|
|
(Nothing, Just val) -> do
|
|
when (T.isPrefixOf "HASURA_GRAPHQL_" val) $
|
|
fail $
|
|
"env variables starting with \"HASURA_GRAPHQL_\" are not allowed in value_from_env: " <> T.unpack val
|
|
return $ HeaderConf name (HVEnv val)
|
|
(Just _, Just _) -> fail "expecting only one of value or value_from_env keys"
|
|
parseJSON _ = fail "expecting object for headers"
|
|
|
|
instance ToJSON HeaderConf where
|
|
toJSON (HeaderConf name (HVValue val)) = object ["name" .= name, "value" .= val]
|
|
toJSON (HeaderConf name (HVEnv val)) = object ["name" .= name, "value_from_env" .= val]
|
|
|
|
-- | Resolve configuration headers
|
|
makeHeadersFromConf ::
|
|
MonadError QErr m => Env.Environment -> [HeaderConf] -> m [HTTP.Header]
|
|
makeHeadersFromConf env = mapM getHeader
|
|
where
|
|
getHeader hconf =
|
|
((CI.mk . txtToBs) *** txtToBs)
|
|
<$> case hconf of
|
|
(HeaderConf name (HVValue val)) -> return (name, val)
|
|
(HeaderConf name (HVEnv val)) -> do
|
|
let mEnv = Env.lookupEnv env (T.unpack val)
|
|
case mEnv of
|
|
Nothing -> throw400 NotFound $ "environment variable '" <> val <> "' not set"
|
|
Just envval -> pure (name, T.pack envval)
|
|
|
|
-- | Encode headers to HeaderConf
|
|
toHeadersConf :: [HTTP.Header] -> [HeaderConf]
|
|
toHeadersConf =
|
|
map (uncurry HeaderConf . ((bsToTxt . CI.original) *** (HVValue . bsToTxt)))
|