1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-22 06:51:32 +03:00
graphql-engine/server/src-lib/Hasura/Backends/Postgres/Connection/Settings.hs

Ignoring revisions in .git-blame-ignore-revs. Click here to bypass and see the normal blame view.

279 lines
8.5 KiB
Haskell
Raw Normal View History

{-# 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 (..),
getDefaultPGPoolSettingIfNotExists,
defaultPostgresPoolSettings,
setPostgresPoolSettings,
pccConnectionInfo,
pccReadReplicas,
psciDatabaseUrl,
psciPoolSettings,
psciUsePreparedStatements,
psciIsolationLevel,
psciSslConfiguration,
)
where
import Control.Lens (makeLenses)
import Data.Aeson
import Data.Aeson.Casing (aesonDrop)
import Data.Aeson.TH
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.Char (toLower)
import Data.Hashable.Time ()
import Data.Semigroup (Max (..))
import Data.Text (unpack)
import Data.Text qualified as T
import Data.Time
import Database.PG.Query qualified as Q
import Hasura.Base.Instances ()
import Hasura.Incremental (Cacheable (..))
import Hasura.Prelude
import Hasura.RQL.Types.Common (UrlConf (..))
import Hasura.Server.Utils (parseConnLifeTime, readIsoLevel)
import Test.QuickCheck.Instances.Semigroup ()
import Test.QuickCheck.Instances.Time ()
data PostgresPoolSettings = PostgresPoolSettings
{ _ppsMaxConnections :: !(Maybe Int),
_ppsIdleTimeout :: !(Maybe Int),
_ppsRetries :: !(Maybe Int),
_ppsPoolTimeout :: !(Maybe NominalDiffTime),
_ppsConnectionLifetime :: !(Maybe NominalDiffTime)
}
deriving (Show, Eq, Generic)
instance Cacheable PostgresPoolSettings
instance Hashable PostgresPoolSettings
instance NFData PostgresPoolSettings
$(deriveToJSON hasuraJSON {omitNothingFields = True} ''PostgresPoolSettings)
instance FromJSON PostgresPoolSettings where
parseJSON = withObject "PostgresPoolSettings" $ \o ->
PostgresPoolSettings
<$> o .:? "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),
_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 Cacheable SSLMode
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 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
data CertVar
= CertVar String
| CertLiteral String
deriving (Show, Eq, Generic)
instance Cacheable CertVar
instance Hashable CertVar
instance NFData CertVar
instance ToJSON CertVar where
toJSON (CertVar var) = (object ["from_env" .= var])
toJSON (CertLiteral var) = String (T.pack var)
instance FromJSON CertVar where
parseJSON (String s) = pure (CertLiteral (T.unpack s))
parseJSON x = withObject "CertVar" (\o -> CertVar <$> o .: "from_env") x
newtype CertData = CertData {unCert :: Text}
deriving (Show, Eq, Generic)
instance ToJSON CertData where
toJSON = String . unCert
data PGClientCerts p a = PGClientCerts
{ pgcSslCert :: a,
pgcSslKey :: a,
pgcSslRootCert :: a,
pgcSslMode :: SSLMode,
pgcSslPassword :: Maybe p
}
deriving (Show, Eq, Generic, Functor, Foldable, Traversable)
$(deriveFromJSON (aesonDrop 3 (fmap toLower)) ''PGClientCerts)
$(deriveToJSON (aesonDrop 3 (fmap toLower)) ''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 g [pgcSslCert, pgcSslKey, pgcSslRootCert]
fs = foldMap f pgcSslPassword
in gs <> fs
instance Bitraversable PGClientCerts where
bitraverse f g PGClientCerts {..} =
PGClientCerts
<$> g pgcSslCert
<*> g pgcSslKey
<*> g pgcSslRootCert
<*> pure pgcSslMode
<*> traverse f pgcSslPassword
instance (Cacheable p, Cacheable a) => Cacheable (PGClientCerts p a)
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 Q.TxIsolation
instance Cacheable Q.TxIsolation
instance NFData Q.TxIsolation
instance Hashable Q.TxIsolation
instance FromJSON Q.TxIsolation where
parseJSON = withText "Q.TxIsolation" $ \t ->
onLeft (readIsoLevel $ T.unpack t) fail
instance ToJSON Q.TxIsolation where
toJSON Q.ReadCommitted = "read-committed"
toJSON Q.RepeatableRead = "repeatable-read"
toJSON Q.Serializable = "serializable"
data PostgresSourceConnInfo = PostgresSourceConnInfo
{ _psciDatabaseUrl :: !UrlConf,
_psciPoolSettings :: !(Maybe PostgresPoolSettings),
_psciUsePreparedStatements :: !Bool,
_psciIsolationLevel :: !Q.TxIsolation,
_psciSslConfiguration :: !(Maybe (PGClientCerts CertVar CertVar))
}
deriving (Show, Eq, Generic)
instance Cacheable PostgresSourceConnInfo
instance Hashable PostgresSourceConnInfo
instance NFData PostgresSourceConnInfo
$(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" .!= Q.ReadCommitted
<*> o .:? "ssl_configuration"
data PostgresConnConfiguration = PostgresConnConfiguration
{ _pccConnectionInfo :: !PostgresSourceConnInfo,
_pccReadReplicas :: !(Maybe (NonEmpty PostgresSourceConnInfo))
}
deriving (Show, Eq, Generic)
instance Cacheable PostgresConnConfiguration
instance Hashable PostgresConnConfiguration
instance NFData PostgresConnConfiguration
$(deriveJSON hasuraJSON {omitNothingFields = True} ''PostgresConnConfiguration)
$(makeLenses ''PostgresConnConfiguration)