-- TODO(SOLOMON): Should this be moved into `Data.Environment`? module Hasura.Server.Init.Env ( -- * WithEnv WithEnvT (..), WithEnv, runWithEnvT, runWithEnv, withOption, withOptionDefault, withOptions, withOptionSwitch, considerEnv, considerEnvs, -- * FromEnv FromEnv (..), ) where -------------------------------------------------------------------------------- import Control.Monad.Morph qualified as Morph import Data.Char qualified as Char import Data.HashSet qualified as HashSet import Data.String qualified as String import Data.Text qualified as Text import Data.Time qualified as Time import Data.URL.Template qualified as Template import Database.PG.Query qualified as Query import Hasura.Backends.Postgres.Connection.MonadTx (ExtensionsSchema) import Hasura.Backends.Postgres.Connection.MonadTx qualified as MonadTx import Hasura.Cache.Bounded qualified as Cache import Hasura.GraphQL.Execute.Subscription.Options qualified as Subscription.Options import Hasura.GraphQL.Schema.NamingCase (NamingCase) import Hasura.GraphQL.Schema.NamingCase qualified as NamingCase import Hasura.GraphQL.Schema.Options qualified as Options import Hasura.Logging qualified as Logging import Hasura.Prelude import Hasura.Server.Auth qualified as Auth import Hasura.Server.Cors qualified as Cors import Hasura.Server.Init.Config qualified as Config import Hasura.Server.Logging qualified as Server.Logging import Hasura.Server.Types qualified as Server.Types import Hasura.Server.Utils qualified as Utils import Hasura.Session qualified as Session import Network.Wai.Handler.Warp qualified as Warp import Refined (NonNegative, Positive, Refined, refineFail, unrefine) -------------------------------------------------------------------------------- -- | Lookup a key in the application environment then parse the value -- with a 'FromEnv' instance' considerEnv :: (Monad m, FromEnv a) => String -> WithEnvT m (Maybe a) considerEnv envVar = do env <- ask case lookup envVar env of Nothing -> pure Nothing Just val -> either throwErr (pure . Just) $ fromEnv val where throwErr s = throwError $ "Fatal Error:- Environment variable " ++ envVar ++ ": " ++ s -- | Lookup a list of keys with 'considerEnv' and return the first -- value to parse successfully. considerEnvs :: (Monad m, FromEnv a) => [String] -> WithEnvT m (Maybe a) considerEnvs envVars = foldl1 (<|>) <$> mapM considerEnv envVars -- | Lookup a list of keys with 'withOption' and return the first -- value to parse successfully. withOptions :: (Monad m, FromEnv option) => Maybe option -> [Config.Option ()] -> WithEnvT m (Maybe option) withOptions parsed options = foldl1 (<|>) <$> traverse (withOption parsed) options -- | Given the parse result for an option and the 'Option def' record -- for that option, query the environment, and then merge the results -- from the parser and environment. withOption :: (Monad m, FromEnv option) => Maybe option -> Config.Option () -> WithEnvT m (Maybe option) withOption parsed option = let option' = option {Config._default = Nothing} in withOptionDefault (fmap Just parsed) option' -- | Given the parse result for an option and the 'Option def' record -- for that option, query the environment, and then merge the results -- from the parser, environment, and the default. withOptionDefault :: (Monad m, FromEnv option) => Maybe option -> Config.Option option -> WithEnvT m option withOptionDefault parsed Config.Option {..} = onNothing parsed (fromMaybe _default <$> considerEnv _envVar) -- | Switches in 'optparse-applicative' have different semantics then -- ordinary flags. They are always optional and produce a 'False' when -- absent rather then a 'Nothing'. -- -- In HGE we give Env Vars a higher precedence then an absent Switch -- but the ordinary 'withEnv' operation expects a 'Nothing' for an -- absent arg parser result. -- -- This function executes with 'withOption Nothing' when the Switch is -- absent, otherwise it returns 'True'. -- -- An alternative solution would be to make Switches return 'Maybe _', -- where '_' is an option specific sum type. This would allow us to -- use 'withOptionDefault' directly. Additionally, all fields of -- 'ServeOptionsRaw' would become 'Maybe' or 'First' values which -- would allow us to write a 'Monoid ServeOptionsRaw' instance for -- combing different option sources. withOptionSwitch :: Monad m => Bool -> Config.Option Bool -> WithEnvT m Bool withOptionSwitch parsed option = bool (withOptionDefault Nothing option) (pure True) parsed -------------------------------------------------------------------------------- -- | A 'Read' style parser used for consuming Env Vars and building -- 'ReadM' parsers for 'optparse-applicative'. class FromEnv a where fromEnv :: String -> Either String a type WithEnv = WithEnvT Identity -- NOTE: Should we use `Data.Environment.Environment` for context? -- | The monadic context for querying Env Vars. newtype WithEnvT m a = WithEnvT {unWithEnvT :: ReaderT [(String, String)] (ExceptT String m) a} deriving newtype (Functor, Applicative, Monad, MonadReader [(String, String)], MonadError String, MonadIO) instance MonadTrans WithEnvT where lift = WithEnvT . lift . lift instance Morph.MFunctor WithEnvT where hoist f (WithEnvT m) = WithEnvT $ Morph.hoist (Morph.hoist f) m -- | Given an environment run a 'WithEnv' action producing either a -- parse error or an @a@. runWithEnv :: [(String, String)] -> WithEnv a -> Either String a runWithEnv env (WithEnvT m) = runIdentity $ runExceptT $ runReaderT m env -- | Given an environment run a 'WithEnvT' action producing either a -- parse error or an @a@. runWithEnvT :: [(String, String)] -> WithEnvT m a -> m (Either String a) runWithEnvT env (WithEnvT m) = runExceptT $ runReaderT m env -------------------------------------------------------------------------------- -- Deserialize from seconds, in the usual way instance FromEnv Time.NominalDiffTime where fromEnv s = case (readMaybe s :: Maybe Double) of Nothing -> Left "could not parse as a Double" Just i -> Right $ realToFrac i instance FromEnv Time.DiffTime where fromEnv s = case (readMaybe s :: Maybe Seconds) of Nothing -> Left "could not parse as a Double" Just i -> Right $ seconds i instance FromEnv String where fromEnv = Right instance FromEnv Warp.HostPreference where fromEnv = Right . String.fromString instance FromEnv Text where fromEnv = Right . Text.pack instance FromEnv a => FromEnv (Maybe a) where fromEnv = fmap Just . fromEnv instance FromEnv Auth.AuthHookType where fromEnv = \case "GET" -> Right Auth.AHTGet "POST" -> Right Auth.AHTPost _ -> Left "Only expecting GET / POST" instance FromEnv Int where fromEnv s = case readMaybe s of Nothing -> Left "Expecting Int value" Just m -> Right m instance FromEnv Auth.AdminSecretHash where fromEnv = Right . Auth.hashAdminSecret . Text.pack instance FromEnv Session.RoleName where fromEnv string = case Session.mkRoleName (Text.pack string) of Nothing -> Left "empty string not allowed" Just roleName -> Right roleName instance FromEnv Bool where fromEnv t | map Char.toLower t `elem` truthVals = Right True | map Char.toLower t `elem` falseVals = Right False | otherwise = Left errMsg where truthVals = ["true", "t", "yes", "y"] falseVals = ["false", "f", "no", "n"] errMsg = " Not a valid boolean text. True values are " ++ show truthVals ++ " and False values are " ++ show falseVals ++ ". All values are case insensitive" instance FromEnv Options.StringifyNumbers where fromEnv = fmap (bool Options.Don'tStringifyNumbers Options.StringifyNumbers) . fromEnv @Bool instance FromEnv Options.RemoteSchemaPermissions where fromEnv = fmap (bool Options.DisableRemoteSchemaPermissions Options.EnableRemoteSchemaPermissions) . fromEnv @Bool instance FromEnv Options.DangerouslyCollapseBooleans where fromEnv = fmap (bool Options.Don'tDangerouslyCollapseBooleans Options.DangerouslyCollapseBooleans) . fromEnv @Bool instance FromEnv Options.InferFunctionPermissions where fromEnv = fmap (bool Options.Don'tInferFunctionPermissions Options.InferFunctionPermissions) . fromEnv @Bool instance FromEnv (Server.Types.MaintenanceMode ()) where fromEnv = fmap (bool Server.Types.MaintenanceModeDisabled (Server.Types.MaintenanceModeEnabled ())) . fromEnv @Bool instance FromEnv Server.Logging.MetadataQueryLoggingMode where fromEnv = fmap (bool Server.Logging.MetadataQueryLoggingDisabled Server.Logging.MetadataQueryLoggingEnabled) . fromEnv @Bool instance FromEnv Query.TxIsolation where fromEnv = Utils.readIsoLevel instance FromEnv Cors.CorsConfig where fromEnv = Cors.readCorsDomains instance FromEnv (HashSet Config.API) where fromEnv = fmap HashSet.fromList . traverse readAPI . Text.splitOn "," . Text.pack where readAPI si = case Text.toUpper $ Text.strip si of "METADATA" -> Right Config.METADATA "GRAPHQL" -> Right Config.GRAPHQL "PGDUMP" -> Right Config.PGDUMP "DEVELOPER" -> Right Config.DEVELOPER "CONFIG" -> Right Config.CONFIG "METRICS" -> Right Config.METRICS _ -> Left "Only expecting list of comma separated API types metadata,graphql,pgdump,developer,config,metrics" instance FromEnv NamingCase where fromEnv = NamingCase.parseNamingConventionFromText . Text.pack instance FromEnv (HashSet Server.Types.ExperimentalFeature) where fromEnv = fmap HashSet.fromList . traverse readAPI . Text.splitOn "," . Text.pack where readAPI si = case Text.toLower $ Text.strip si of "inherited_roles" -> Right Server.Types.EFInheritedRoles "streaming_subscriptions" -> Right Server.Types.EFStreamingSubscriptions "optimize_permission_filters" -> Right Server.Types.EFOptimizePermissionFilters "naming_convention" -> Right Server.Types.EFNamingConventions "apollo_federation" -> Right Server.Types.EFApolloFederation "hide_update_many_fields" -> Right Server.Types.EFHideUpdateManyFields "bigquery_string_numeric_input" -> Right Server.Types.EFBigQueryStringNumericInput _ -> Left $ "Only expecting list of comma separated experimental features, options are:" ++ "inherited_roles, streaming_subscriptions, hide_update_many_fields, optimize_permission_filters, naming_convention, apollo_federation, bigquery_string_numeric_input" instance FromEnv Subscription.Options.BatchSize where fromEnv s = do val <- readEither s maybeToEither "batch size should be a non negative integer" $ Subscription.Options.mkBatchSize val instance FromEnv Subscription.Options.RefetchInterval where fromEnv x = do val <- fmap (milliseconds . fromInteger) . readEither $ x maybeToEither "refetch interval should be a non negative integer" $ Subscription.Options.mkRefetchInterval val instance FromEnv Milliseconds where fromEnv = readEither instance FromEnv Config.OptionalInterval where fromEnv x = do i <- fromEnv @(Refined NonNegative Milliseconds) x if unrefine i == 0 then pure $ Config.Skip else pure $ Config.Interval i instance FromEnv Seconds where fromEnv = fmap fromInteger . readEither instance FromEnv Config.WSConnectionInitTimeout where fromEnv s = do seconds <- fromIntegral @_ @Seconds <$> fromEnv @Int s nonNegative <- maybeToEither "WebSocket Connection Timeout must not be negative" $ refineFail seconds pure $ Config.WSConnectionInitTimeout nonNegative instance FromEnv Config.KeepAliveDelay where fromEnv = fmap Config.KeepAliveDelay . fromEnv @(Refined NonNegative Seconds) instance FromEnv Auth.JWTConfig where fromEnv = readJson instance FromEnv [Auth.JWTConfig] where fromEnv = readJson instance Logging.EnabledLogTypes impl => FromEnv (HashSet (Logging.EngineLogType impl)) where fromEnv = fmap HashSet.fromList . Logging.parseEnabledLogTypes instance FromEnv Logging.LogLevel where fromEnv s = case Text.toLower $ Text.strip $ Text.pack s of "debug" -> Right Logging.LevelDebug "info" -> Right Logging.LevelInfo "warn" -> Right Logging.LevelWarn "error" -> Right Logging.LevelError _ -> Left "Valid log levels: debug, info, warn or error" instance FromEnv Template.URLTemplate where fromEnv = Template.parseURLTemplate . Text.pack instance (Num a, Ord a, FromEnv a) => FromEnv (Refined NonNegative a) where fromEnv s = fmap (maybeToEither "Only expecting a non negative numeric") refineFail =<< fromEnv s instance FromEnv (Refined Positive Int) where fromEnv s = maybeToEither "Only expecting a positive integer" (refineFail =<< readMaybe s) instance FromEnv Config.Port where fromEnv s = maybeToEither "Only expecting a value between 0 and 65535" (Config.mkPort =<< readMaybe s) instance FromEnv Cache.CacheSize where fromEnv = Cache.parseCacheSize instance FromEnv ExtensionsSchema where fromEnv = Right . MonadTx.ExtensionsSchema . Text.pack