{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Postgres Connection Settings -- -- This module contains types and combinators related to postgres connection, -- pool, and replica related settings. module Hasura.Backends.Postgres.Connection.Settings ( PostgresPoolSettings (..), PostgresSourceConnInfo (..), PostgresConnConfiguration (..), PGClientCerts (..), CertVar (..), CertData (..), SSLMode (..), DefaultPostgresPoolSettings (..), ConnectionTemplate (..), PostgresConnectionSetMemberName (..), PostgresConnectionSet (..), PostgresConnectionSetMember (..), KritiTemplate (..), getDefaultPGPoolSettingIfNotExists, defaultPostgresPoolSettings, defaultPostgresExtensionsSchema, setPostgresPoolSettings, pccConnectionInfo, pccReadReplicas, pccExtensionsSchema, psciDatabaseUrl, psciPoolSettings, psciUsePreparedStatements, psciIsolationLevel, psciSslConfiguration, pccConnectionTemplate, pccConnectionSet, ) where import Autodocodec hiding (object, (.=)) import Autodocodec qualified as AC import Control.Lens (makeLenses) import Data.Aeson import Data.Aeson.Casing (aesonDrop) import Data.Aeson.Extended (mapWithJSONPath) import Data.Aeson.TH import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.Char (toLower) import Data.HashMap.Strict.NonEmpty qualified as NEMap import Data.Hashable (hashWithSalt) import Data.List.Extended qualified as L (uniques) import Data.List.NonEmpty qualified as NonEmpty import Data.Semigroup (Max (..)) import Data.Text (unpack) import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.Extended (ToTxt (toTxt), dquote, dquoteList) import Data.Text.NonEmpty import Data.Time import Data.Time.Clock.Compat () import Database.PG.Query qualified as PG import Hasura.Base.Instances () import Hasura.Prelude import Hasura.RQL.Types.Common (UrlConf (..)) import Hasura.SQL.Types (ExtensionsSchema (..)) import Hasura.Server.Utils (parseConnLifeTime, readIsoLevel) import Kriti qualified import Kriti.Error qualified as Kriti import Kriti.Parser qualified as Kriti import Prettyprinter qualified as PP import Prettyprinter.Render.Text qualified as PP import Test.QuickCheck.Instances.Semigroup () import Test.QuickCheck.Instances.Time () data PostgresPoolSettings = PostgresPoolSettings { _ppsMaxConnections :: Maybe Int, _ppsTotalMaxConnections :: Maybe Int, _ppsIdleTimeout :: Maybe Int, _ppsRetries :: Maybe Int, _ppsPoolTimeout :: Maybe NominalDiffTime, _ppsConnectionLifetime :: Maybe NominalDiffTime } deriving (Show, Eq, Generic) instance Hashable PostgresPoolSettings instance NFData PostgresPoolSettings instance HasCodec PostgresPoolSettings where codec = CommentCodec "https://hasura.io/docs/latest/graphql/core/api-reference/syntax-defs.html#pgpoolsettings" $ AC.object "PostgresPoolSettings" $ PostgresPoolSettings <$> optionalFieldOrNull "max_connections" maxConnectionsDoc .== _ppsMaxConnections <*> optionalFieldOrNull "total_max_connections" totalMaxConnectionsDoc .== _ppsTotalMaxConnections <*> optionalFieldOrNull "idle_timeout" idleTimeoutDoc .== _ppsIdleTimeout <*> optionalFieldOrNull "retries" retriesDoc .== _ppsRetries <*> optionalFieldOrNull "pool_timeout" poolTimeoutDoc .== _ppsPoolTimeout <*> (parseConnLifeTime `rmapCodec` optionalFieldOrNull "connection_lifetime" connectionLifetimeDoc) .== _ppsConnectionLifetime where maxConnectionsDoc = "Maximum number of connections to be kept in the pool (default: 50)" totalMaxConnectionsDoc = "Total maximum number of connections across all instances (cloud only, default: null)" idleTimeoutDoc = "The idle timeout (in seconds) per connection (default: 180)" retriesDoc = "Number of retries to perform (default: 1)" poolTimeoutDoc = "Maximum time to wait while acquiring a Postgres connection from the pool, in seconds (default: forever)" connectionLifetimeDoc = T.unwords [ "Time from connection creation after which the connection should be", "destroyed and a new one created. A value of 0 indicates we should", "never destroy an active connection. If 0 is passed, memory from large", "query results may not be reclaimed. (default: 600 sec)" ] infix 8 .== (.==) = (AC..=) $(deriveToJSON hasuraJSON {omitNothingFields = True} ''PostgresPoolSettings) instance FromJSON PostgresPoolSettings where parseJSON = withObject "PostgresPoolSettings" $ \o -> PostgresPoolSettings <$> o .:? "max_connections" <*> o .:? "total_max_connections" <*> o .:? "idle_timeout" <*> o .:? "retries" <*> o .:? "pool_timeout" <*> ((o .:? "connection_lifetime") <&> parseConnLifeTime) data DefaultPostgresPoolSettings = DefaultPostgresPoolSettings { _dppsMaxConnections :: Int, _dppsIdleTimeout :: Int, _dppsRetries :: Int, _dppsConnectionLifetime :: Maybe NominalDiffTime } deriving (Show, Eq) defaultPostgresPoolSettings :: DefaultPostgresPoolSettings defaultPostgresPoolSettings = DefaultPostgresPoolSettings 50 180 1 (Just 600) -- Use this when you want to set only few of the PG Pool settings. -- The values which are not set will use the default values. setPostgresPoolSettings :: PostgresPoolSettings setPostgresPoolSettings = PostgresPoolSettings { _ppsMaxConnections = (Just $ _dppsMaxConnections defaultPostgresPoolSettings), _ppsTotalMaxConnections = Nothing, _ppsIdleTimeout = (Just $ _dppsIdleTimeout defaultPostgresPoolSettings), _ppsRetries = (Just $ _dppsRetries defaultPostgresPoolSettings), _ppsPoolTimeout = Nothing, -- @Nothing@ is the default value of the pool timeout _ppsConnectionLifetime = _dppsConnectionLifetime defaultPostgresPoolSettings } -- PG Pool Settings are not given by the user, set defaults getDefaultPGPoolSettingIfNotExists :: Maybe PostgresPoolSettings -> DefaultPostgresPoolSettings -> (Int, Int, Int) getDefaultPGPoolSettingIfNotExists connSettings defaultPgPoolSettings = case connSettings of -- Atleast one of the postgres pool settings is set, then set default values to other settings Just connSettings' -> (maxConnections connSettings', idleTimeout connSettings', retries connSettings') -- No PG Pool settings provided by user, set default values for all Nothing -> (defMaxConnections, defIdleTimeout, defRetries) where defMaxConnections = _dppsMaxConnections defaultPgPoolSettings defIdleTimeout = _dppsIdleTimeout defaultPgPoolSettings defRetries = _dppsRetries defaultPgPoolSettings maxConnections = fromMaybe defMaxConnections . _ppsMaxConnections idleTimeout = fromMaybe defIdleTimeout . _ppsIdleTimeout retries = fromMaybe defRetries . _ppsRetries data SSLMode = Disable | Allow | Prefer | Require | VerifyCA | VerifyFull deriving (Eq, Ord, Generic, Enum, Bounded) instance Hashable SSLMode instance NFData SSLMode instance Show SSLMode where show = \case Disable -> "disable" Allow -> "allow" Prefer -> "prefer" Require -> "require" VerifyCA -> "verify-ca" VerifyFull -> "verify-full" deriving via (Max SSLMode) instance Semigroup SSLMode instance HasCodec SSLMode where codec = named "SSLMode" $ stringConstCodec $ NonEmpty.fromList $ (\m -> (m, tshow m)) <$> [minBound ..] instance FromJSON SSLMode where parseJSON = withText "SSLMode" $ \case "disable" -> pure Disable "allow" -> pure Allow "prefer" -> pure Prefer "require" -> pure Require "verify-ca" -> pure VerifyCA "verify-full" -> pure VerifyFull err -> fail $ "Invalid SSL Mode " <> unpack err newtype CertVar = CertVar String deriving (Show, Eq, Generic) instance Hashable CertVar instance NFData CertVar instance HasCodec CertVar where codec = AC.object "CertVar" $ CertVar <$> requiredField' "from_env" .== unCertVar where unCertVar (CertVar t) = t infix 8 .== (.==) = (AC..=) instance ToJSON CertVar where toJSON (CertVar var) = (object ["from_env" .= var]) instance FromJSON CertVar where parseJSON = withObject "CertVar" (\o -> CertVar <$> o .: "from_env") newtype CertData = CertData {unCert :: Text} deriving (Show, Eq, Generic) instance HasCodec CertData where codec = dimapCodec CertData unCert textCodec instance ToJSON CertData where toJSON = String . unCert data PGClientCerts p a = PGClientCerts { pgcSslCert :: Maybe a, pgcSslKey :: Maybe a, pgcSslRootCert :: Maybe a, pgcSslMode :: SSLMode, pgcSslPassword :: Maybe p } deriving (Show, Eq, Generic, Functor, Foldable, Traversable) instance (HasCodec p, HasCodec a) => HasCodec (PGClientCerts p a) where codec = CommentCodec "https://hasura.io/docs/latest/graphql/core/api-reference/syntax-defs.html#pgcertsettings" $ AC.object "PGClientCerts" $ PGClientCerts <$> optionalFieldOrNull "sslcert" sslcertDoc .== pgcSslCert <*> optionalFieldOrNull "sslkey" sslkeyDoc .== pgcSslKey <*> optionalFieldOrNull "sslrootcert" sslrootcertDoc .== pgcSslRootCert <*> requiredField "sslmode" sslmodeDoc .== pgcSslMode <*> optionalFieldOrNull "sslpassword" sslpasswordDoc .== pgcSslPassword where sslcertDoc = "Environment variable which stores the client certificate." sslkeyDoc = "Environment variable which stores the client private key." sslrootcertDoc = "Environment variable which stores trusted certificate authorities." sslmodeDoc = "The SSL connection mode. See the libpq ssl support docs for more details." sslpasswordDoc = "Password in the case where the sslkey is encrypted." infix 8 .== (.==) = (AC..=) $(deriveFromJSON (aesonDrop 3 (fmap toLower)) ''PGClientCerts) $(deriveToJSON (aesonDrop 3 (fmap toLower)) {omitNothingFields = True} ''PGClientCerts) instance Bifunctor PGClientCerts where bimap f g oldCerts@(PGClientCerts {pgcSslPassword}) = let certs = oldCerts {pgcSslPassword = f <$> pgcSslPassword} in g <$> certs instance Bifoldable PGClientCerts where bifoldMap f g PGClientCerts {..} = let gs = foldMap (foldMap g) [pgcSslCert, pgcSslKey, pgcSslRootCert] fs = foldMap f pgcSslPassword in gs <> fs instance Bitraversable PGClientCerts where bitraverse f g PGClientCerts {..} = PGClientCerts <$> traverse g pgcSslCert <*> traverse g pgcSslKey <*> traverse g pgcSslRootCert <*> pure pgcSslMode <*> traverse f pgcSslPassword instance (Hashable p, Hashable a) => Hashable (PGClientCerts p a) instance (NFData p, NFData a) => NFData (PGClientCerts p a) instance ToJSON SSLMode where toJSON = String . tshow deriving instance Generic PG.TxIsolation instance NFData PG.TxIsolation instance Hashable PG.TxIsolation instance HasCodec PG.TxIsolation where codec = named "TxIsolation" $ stringConstCodec $ NonEmpty.fromList $ [ (PG.ReadCommitted, "read-committed"), (PG.RepeatableRead, "repeatable-read"), (PG.Serializable, "serializable") ] instance FromJSON PG.TxIsolation where parseJSON = withText "Q.TxIsolation" $ \t -> onLeft (readIsoLevel $ T.unpack t) fail instance ToJSON PG.TxIsolation where toJSON PG.ReadCommitted = "read-committed" toJSON PG.RepeatableRead = "repeatable-read" toJSON PG.Serializable = "serializable" data PostgresSourceConnInfo = PostgresSourceConnInfo { _psciDatabaseUrl :: UrlConf, _psciPoolSettings :: Maybe PostgresPoolSettings, _psciUsePreparedStatements :: Bool, _psciIsolationLevel :: PG.TxIsolation, _psciSslConfiguration :: Maybe (PGClientCerts CertVar CertVar) } deriving (Show, Eq, Generic) instance Hashable PostgresSourceConnInfo instance NFData PostgresSourceConnInfo instance HasCodec PostgresSourceConnInfo where codec = CommentCodec "https://hasura.io/docs/latest/graphql/core/api-reference/syntax-defs.html#pgsourceconnectioninfo" $ AC.object "PostgresSourceConnInfo" $ PostgresSourceConnInfo <$> requiredField "database_url" databaseUrlDoc .== _psciDatabaseUrl <*> optionalFieldOrNull "pool_settings" poolSettingsDoc .== _psciPoolSettings <*> optionalFieldWithDefault "use_prepared_statements" False usePreparedStatementsDoc .== _psciUsePreparedStatements <*> optionalFieldWithDefault "isolation_level" PG.ReadCommitted isolationLevelDoc .== _psciIsolationLevel <*> optionalFieldOrNull "ssl_configuration" sslConfigurationDoc .== _psciSslConfiguration where databaseUrlDoc = "The database connection URL as a string, as an environment variable, or as connection parameters." poolSettingsDoc = "Connection pool settings" usePreparedStatementsDoc = T.unwords [ "If set to true the server prepares statement before executing on the", "source database (default: false). For more details, refer to the", "Postgres docs" ] isolationLevelDoc = T.unwords [ "The transaction isolation level in which the queries made to the", "source will be run with (default: read-committed)." ] sslConfigurationDoc = "The client SSL certificate settings for the database (Only available in Cloud)." infix 8 .== (.==) = (AC..=) $(deriveToJSON hasuraJSON {omitNothingFields = True} ''PostgresSourceConnInfo) $(makeLenses ''PostgresSourceConnInfo) instance FromJSON PostgresSourceConnInfo where parseJSON = withObject "PostgresSourceConnInfo" $ \o -> PostgresSourceConnInfo <$> o .: "database_url" <*> o .:? "pool_settings" <*> o .:? "use_prepared_statements" .!= False -- By default, preparing statements is OFF for postgres source <*> o .:? "isolation_level" .!= PG.ReadCommitted <*> o .:? "ssl_configuration" defaultPostgresExtensionsSchema :: ExtensionsSchema defaultPostgresExtensionsSchema = ExtensionsSchema "public" -- | `kriti-lang` template. data KritiTemplate = KritiTemplate { -- TODO: There is redundency here, we should remove the templateSrc field once the renderPretty bug is resolved -- (https://github.com/hasura/kriti-lang/issues/77) -- | Raw kriti template _ktSource :: Text, -- | Parsed kriti template _ktParsedAST :: Kriti.ValueExt } deriving (Show, Eq, Generic) instance Hashable KritiTemplate where hashWithSalt salt (KritiTemplate templateSrc _) = hashWithSalt salt templateSrc instance NFData KritiTemplate instance ToJSON KritiTemplate where toJSON (KritiTemplate templateSrc _) = String templateSrc instance FromJSON KritiTemplate where parseJSON = withText "KritiTemplate" $ \templateSrc -> KritiTemplate templateSrc <$> Kriti.parser (T.encodeUtf8 templateSrc) `onLeft` \err -> fail $ "Kriti template parsing failed - " <> (T.unpack . serializedErrorToString . Kriti.serialize $ err) serializedErrorToString :: Kriti.SerializedError -> Text serializedErrorToString (Kriti.SerializedError code msg errSpan) = let prettyText = PP.renderStrict . PP.layoutPretty PP.defaultLayoutOptions . PP.pretty spanToText (Kriti.Span start end) = "from " <> prettySpan start <> " to " <> prettySpan end prettySpan (Kriti.AlexSourcePos line col) = "line " <> tshow line <> ", column " <> tshow col in msg <> " Occured " <> spanToText errSpan <> " with error code " <> dquote (prettyText code) <> "." instance HasCodec KritiTemplate where codec = codecViaAeson "KritiTemplate" -- | Connection template for the dynamic DB connection. data ConnectionTemplate = ConnectionTemplate { -- | Version for the connection template. Please read more about this in the dynamic DB connection RFC (Metadata API > Versioning). _ctVersion :: Int, -- | `kriti-lang` template for the dynamic DB connection. _ctTemplate :: KritiTemplate } deriving (Show, Eq, Generic) instance Hashable ConnectionTemplate instance NFData ConnectionTemplate -- | All the supported versions for the dynamic DB connection template. supportedConnectionTemplateVersions :: [Int] supportedConnectionTemplateVersions = [1] instance FromJSON ConnectionTemplate where parseJSON = withObject "ConnectionTemplate" $ \o -> do version <- o .:? "version" .!= 1 when (version `notElem` supportedConnectionTemplateVersions) $ fail $ "Supported versions are " <> show supportedConnectionTemplateVersions ConnectionTemplate version <$> o .: "template" instance ToJSON ConnectionTemplate where toJSON ConnectionTemplate {..} = object [ "version" .= _ctVersion, "template" .= _ctTemplate ] instance HasCodec ConnectionTemplate where codec = CommentCodec "https://hasura.io/docs/latest/graphql/core/api-reference/syntax-defs.html#pgconnectiontemplate" $ AC.object "ConnectionTemplate" $ ConnectionTemplate <$> optionalFieldWithOmittedDefault "version" 1 ctVersionInfoDoc AC..= _ctVersion <*> requiredField "template" ctTemplateInfoDoc AC..= _ctTemplate where ctVersionInfoDoc = "Optional connection template version (supported versions: [1], default: 1)" ctTemplateInfoDoc = "Connection kriti template (read more in the docs)" -- | Name of the member of a connection set. newtype PostgresConnectionSetMemberName = PostgresConnectionSetMemberName {getPostgresConnectionSetMemberName :: NonEmptyText} deriving (Show, Eq, Generic, Ord, ToTxt) instance Hashable PostgresConnectionSetMemberName instance NFData PostgresConnectionSetMemberName instance ToJSON PostgresConnectionSetMemberName where toJSON (PostgresConnectionSetMemberName sName) = toJSON sName instance FromJSON PostgresConnectionSetMemberName where parseJSON val = PostgresConnectionSetMemberName <$> parseJSON val data PostgresConnectionSetMember = PostgresConnectionSetMember { _pscmName :: PostgresConnectionSetMemberName, _pscmConnectionInfo :: PostgresSourceConnInfo } deriving (Show, Eq, Generic) $(deriveJSON hasuraJSON {omitNothingFields = True} ''PostgresConnectionSetMember) instance Hashable PostgresConnectionSetMember instance NFData PostgresConnectionSetMember -- | HashMap of the connection set. This is used for the dynamic DB connection feature. newtype PostgresConnectionSet = PostgresConnectionSet {getPostgresConnectionSet :: NEMap.NEHashMap PostgresConnectionSetMemberName PostgresConnectionSetMember} deriving (Show, Eq, Generic, Semigroup) instance Hashable PostgresConnectionSet instance NFData PostgresConnectionSet instance FromJSON PostgresConnectionSet where parseJSON = withArray "PostgresConnectionSet" \arr -> do connectionSet <- mapWithJSONPath parseJSON (toList arr) let connectionSetMemberNames = map _pscmName connectionSet duplicateConnSetMemberNames = connectionSetMemberNames \\ (L.uniques connectionSetMemberNames) -- check if members with same name are present in connection set unless (null duplicateConnSetMemberNames) $ do fail $ "connection set members with duplicate names are not allowed: " ++ unpack (dquoteList (map toTxt duplicateConnSetMemberNames)) let connectionSetTuples = map (_pscmName &&& id) connectionSet connectionSetHashMap <- NEMap.fromList connectionSetTuples `onNothing` fail "connection set cannot be empty" pure $ PostgresConnectionSet connectionSetHashMap instance ToJSON PostgresConnectionSet where toJSON (PostgresConnectionSet connSet) = toJSON $ NEMap.elems connSet instance HasCodec PostgresConnectionSet where codec = codecViaAeson "PostgresConnectionSet" data PostgresConnConfiguration = PostgresConnConfiguration { _pccConnectionInfo :: PostgresSourceConnInfo, _pccReadReplicas :: Maybe (NonEmpty PostgresSourceConnInfo), _pccExtensionsSchema :: ExtensionsSchema, _pccConnectionTemplate :: Maybe ConnectionTemplate, _pccConnectionSet :: Maybe PostgresConnectionSet } deriving (Show, Eq, Generic) instance Hashable PostgresConnConfiguration instance NFData PostgresConnConfiguration instance FromJSON PostgresConnConfiguration where parseJSON = withObject "PostgresConnConfiguration" $ \o -> do PostgresConnConfiguration <$> o .: "connection_info" <*> o .:? "read_replicas" <*> o .:? "extensions_schema" .!= defaultPostgresExtensionsSchema <*> o .:? "connection_template" <*> o .:? "connection_set" instance ToJSON PostgresConnConfiguration where toJSON PostgresConnConfiguration {..} = object $ ["connection_info" .= _pccConnectionInfo] <> maybe mempty (\readReplicas -> ["read_replicas" .= readReplicas]) _pccReadReplicas <> bool mempty (["extensions_schema" .= _pccExtensionsSchema]) (_pccExtensionsSchema /= defaultPostgresExtensionsSchema) <> maybe mempty (\connTemplate -> ["connection_template" .= connTemplate]) _pccConnectionTemplate <> maybe mempty (\connSet -> ["connection_set" .= NEMap.elems (getPostgresConnectionSet connSet)]) _pccConnectionSet instance HasCodec PostgresConnConfiguration where codec = CommentCodec "https://hasura.io/docs/latest/graphql/core/api-reference/syntax-defs.html#pgconfiguration" $ AC.object "PostgresConnConfiguration" $ PostgresConnConfiguration <$> requiredField "connection_info" connectionInfoDoc .== _pccConnectionInfo <*> optionalFieldOrNull "read_replicas" readReplicasDoc .== _pccReadReplicas <*> optionalFieldWithOmittedDefault "extensions_schema" defaultPostgresExtensionsSchema extensionsSchemaDoc .== _pccExtensionsSchema <*> optionalFieldOrNull "connection_template" connectionTemplateDoc .== _pccConnectionTemplate <*> optionalFieldOrNull "connection_set" connectionSetDoc .== _pccConnectionSet where connectionInfoDoc = "Connection parameters for the source" readReplicasDoc = "Optional list of read replica configuration (supported only in cloud/enterprise versions)" extensionsSchemaDoc = "Name of the schema where the graphql-engine will install database extensions (default: public)" connectionTemplateDoc = "Optional connection template (supported only for cloud/enterprise edition)" connectionSetDoc = "connection set used for connection template (supported only for cloud/enterprise edition)" infix 8 .== (.==) = (AC..=) $(makeLenses ''PostgresConnConfiguration)