salmon-ops-0.2.0.0: src/Salmon/Builtin/Nodes/Postgres.hs
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Salmon.Builtin.Nodes.Postgres where
import Control.Concurrent (threadDelay)
import Control.Exception (Exception, IOException, throwIO, try)
import Control.Monad (unless, when)
import qualified Crypto.Hash as Hash
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Crypto.Random as Random
import Data.Aeson (FromJSON, ToJSON)
import Data.Bits (xor)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Base64 as Base64
import Data.Char (isAscii)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import GHC.Generics
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Encoding.Error as TextError
import System.Exit (ExitCode (..))
import System.FilePath
import System.Process.ByteString (readCreateProcessWithExitCode)
import System.Process.ListLike (CreateProcess (..), proc)
import Salmon.Actions.UpDown (CheckResult (..))
import Salmon.Builtin.Extension
import Salmon.Builtin.Nodes.Binary (Binary, Command (..), justInstall, untrackedExec, withBinary, withBinaryStdin, withBinaryStdinAtUp)
import qualified Salmon.Builtin.Nodes.Binary as Binary
import Salmon.Builtin.Nodes.Filesystem (File, withFile)
import qualified Salmon.Builtin.Nodes.Filesystem as FS
import Salmon.Op.OpGraph
import Salmon.Op.Ref
import Salmon.Op.Track
import Salmon.Reporter
-------------------------------------------------------------------------------
-- todo: collapse PsqlAdmin commands as a single constructor
data Report
= PGStartLocalCluster !Binary.Report
| PGCreateDatabase !Database !Binary.Report
| PGCreateUser !User !Binary.Report
| PGSetUserPass !User !Binary.Report
| PGCreateGroup !Group !Binary.Report
| PGGrant !AccessRight !Binary.Report
| PGGroupMembership !Group !Role !Binary.Report
| PGDatabaseOwnership !Database !Role !Binary.Report
| PGScript !FilePath !Binary.Report
| PGAdminScript !FilePath !Binary.Report
| PGChmod !FilePath !Binary.Report
| PGCreateReplicationUser !User !Binary.Report
| PGClusterOp !PgCtl !Binary.Report
| PGAlterSystem !Text !Text !Binary.Report
| PGReloadConf !Binary.Report
| PGReplicationSlot !Text !Binary.Report
| PGTemplate !DatabaseName !Binary.Report
| PGCloneDatabase !Clone !Binary.Report
| PGDropClone !DatabaseName !Binary.Report
| PGExtension !PgExtension !Binary.Report
deriving (Show)
-------------------------------------------------------------------------------
type Host = Text
type Port = Int
-- | todo: distinguish server (to which we connect to) and cluster (with version)
data Server
= Server
{ serverHost :: Host
, serverPort :: Port
}
deriving (Eq, Ord, Show, Generic)
instance ToJSON Server
instance FromJSON Server
localServer :: Server
localServer = Server "127.0.0.1" 5432
type Version = Int
{- | Which Debian package's default postgres major version ends up installed
varies by release (e.g. 13 on bullseye, 15 on bookworm) and shifts over
time, so we can't bake a version number in here — instead the started
command detects, on the target machine at 'up' time, whichever cluster
"postgresql-common" actually created (via @pg_lsclusters@) and starts that
one. If several versions are installed, the highest one wins.
-}
pgLocalCluster :: Reporter Report -> Track' (Binary "postgres") -> Track' (Binary "pg_ctlcluster") -> Server -> Op
pgLocalCluster r pg pgctl server =
withBinary pgctl pgctlRun (Start server.serverPort) $ \start ->
op "pg-server" (deps [justInstall pg]) $ \actions ->
actions
{ notes = ["default server"]
, help = Text.unwords ["start pg cluster"]
, up = start r'
}
where
r' = contramap PGStartLocalCluster r
type ClusterName = Text
mainCluster :: ClusterName
mainCluster = "main"
data PgCtl
= Start Port
| CreateCluster !ClusterName !Port
| StartCluster !ClusterName
| StopCluster !ClusterName
| RestartCluster !ClusterName
| PromoteCluster !ClusterName
| EnsureHbaLine !ClusterName !Text
| CloneFromPrimary !StandbySetup
deriving (Show)
pgctlRun :: Command "pg_ctlcluster" PgCtl
pgctlRun = Command go
where
go (Start _port) = proc "bash" ["-c", detectVersionAndStartMainCluster]
go (CreateCluster name port) = proc "bash" ["-c", createClusterScript name port]
go (StartCluster name) = proc "bash" ["-c", clusterCtlScript name "start"]
go (StopCluster name) = proc "bash" ["-c", clusterCtlScript name "stop"]
go (RestartCluster name) = proc "bash" ["-c", clusterCtlScript name "restart"]
go (PromoteCluster name) = proc "bash" ["-c", clusterCtlScript name "promote"]
go (EnsureHbaLine name line) = proc "bash" ["-c", ensureHbaLineScript name line]
go (CloneFromPrimary setup) = proc "bash" ["-c", cloneFromPrimaryScript setup]
{- | @pg_lsclusters@'s header-less output is one line per cluster:
@Ver Cluster Port Status Owner DataDirectory LogFile@; sort numerically and
take the highest version so a freshly-provisioned box with a single cluster
just works, and a box with several installed versions picks the newest.
-}
detectVersionAndStartMainCluster :: String
detectVersionAndStartMainCluster =
-- `pg_ctlcluster start` exits 2 on a cluster that is already running, so
-- starting unconditionally failed every pass after the first (and every
-- pass on a box where apt's own service had started it).
"set -e; version=$(pg_lsclusters --no-header | awk '{print $1}' | sort -n | tail -n1); pg_ctlcluster \"$version\" main status >/dev/null || pg_ctlcluster \"$version\" main start"
-- | Shared preamble: detects the (single) installed major version, same way as 'detectVersionAndStartMainCluster'.
detectVersion :: String
detectVersion = "version=$(pg_lsclusters --no-header | awk '{print $1}' | sort -n | tail -n1)"
-- | Idempotent: only creates the named cluster if @pg_lsclusters@ doesn't already list it.
createClusterScript :: ClusterName -> Port -> String
createClusterScript name port =
unlines
[ "set -e"
, detectVersion
, "pg_lsclusters --no-header | awk '{print $2}' | grep -qx " <> shellQuote name <> " || pg_createcluster \"$version\" " <> Text.unpack name <> " -p " <> show port <> " -- --auth-local=peer --auth-host=md5"
]
clusterCtlScript :: ClusterName -> String -> String
clusterCtlScript name action =
unlines
[ "set -e"
, detectVersion
, "pg_ctlcluster \"$version\" " <> Text.unpack name <> " " <> action
]
-- | Appends a @pg_hba.conf@ line for the named cluster (skipping if already present) and reloads it.
ensureHbaLineScript :: ClusterName -> Text -> String
ensureHbaLineScript name line =
unlines
[ "set -e"
, detectVersion
, "hba=/etc/postgresql/$version/" <> Text.unpack name <> "/pg_hba.conf"
, "grep -qxF " <> shellQuote line <> " \"$hba\" || echo " <> shellQuote line <> " >> \"$hba\""
, "pg_ctlcluster \"$version\" " <> Text.unpack name <> " reload"
]
{- | Clones the named cluster's data directory from a running primary via
@pg_basebackup -R@ (which writes both @standby.signal@ and
@primary_conninfo@, so the cluster comes up in streaming-standby mode as
soon as it's started) and starts it.
= What decides whether to clone
The clone begins @rm -rf@ on a data directory, so what guards it is the
whole safety of this node. That guard is the __system identifier__: every
cluster gets one at @initdb@ time and a @pg_basebackup@ copy inherits its
primary's, so "this data directory holds a copy of that primary's cluster"
is a question with an exact answer. The primary's is read over the
replication protocol (@IDENTIFY_SYSTEM@), which is the one connection the
replication role is already authorized for in @pg_hba.conf@; the local one
comes from @pg_controldata@, no server needed.
* __Same identifier__: this directory is already a member of the primary's
cluster. Leave it alone, and start it if it is down.
* __No cluster here at all__: clone.
* __A different identifier__: clone only if that cluster is /pristine/, i.e.
holds no database beyond the ones @initdb@ makes, which is what a freshly
@pg_createcluster@-d standby looks like. Otherwise refuse, loudly, and
touch nothing.
The guard this replaces was @standby.signal@'s presence, which is deleted by
/promotion/: a promoted standby therefore looked exactly like a cluster that
had never been cloned, and the next @up@ with an unchanged directive would
@rm -rf@ the data directory of what is now the primary -- then fail to clone
from the old primary, which is typically the machine that just died. The
identifier survives promotion, which is the point of using it.
Pristineness is settled by looking at @base/@ for a directory whose name is
at or above @FirstNormalObjectId@ (16384), rather than by starting the
cluster and asking it: starting somebody else's cluster to find out whether
it is somebody else's is already the side effect worth avoiding.
-}
cloneFromPrimaryScript :: StandbySetup -> String
cloneFromPrimaryScript setup =
unlines
[ "set -e"
, detectVersion
, -- pg_controldata is a server program: postgresql-common puts a
-- wrapper on PATH for the client ones only.
"pg_controldata=/usr/lib/postgresql/$version/bin/pg_controldata"
, "[ -x \"$pg_controldata\" ] || pg_controldata=pg_controldata"
, "datadir=/var/lib/postgresql/$version/" <> cluster
, -- the replication protocol's own identity command: available to a
-- REPLICATION role over the `host replication` line the standby
-- already needs, with no rights on any database.
"primary_sysid=$(" <> pgpassword <> " psql -tAX -d " <> shellQuote replConninfo <> " -c 'IDENTIFY_SYSTEM' | head -n1 | cut -d'|' -f1)"
, "if [ -z \"$primary_sysid\" ]; then echo 'cannot read the primary system identifier' >&2; exit 1; fi"
, "local_sysid=''"
, "if [ -e \"$datadir/global/pg_control\" ]; then"
, " local_sysid=$(\"$pg_controldata\" -D \"$datadir\" | sed -n 's/^Database system identifier: *//p')"
, "fi"
, "if [ \"$local_sysid\" = \"$primary_sysid\" ]; then"
, " " <> pgctl "status" <> " >/dev/null || " <> pgctl "start"
, " exit 0"
, "fi"
, "if [ -n \"$local_sysid\" ]; then"
, " others=$(ls \"$datadir/base\" 2>/dev/null | awk '$1 ~ /^[0-9]+$/ && $1+0 >= 16384' | wc -l)"
, " if [ \"$others\" != 0 ]; then"
, " echo \"refusing to clone over $datadir: it holds cluster $local_sysid with $others database(s), and the primary is $primary_sysid\" >&2"
, " exit 1"
, " fi"
, "fi"
, pgctl "stop" <> " || true"
, "rm -rf \"$datadir\""
, pgpassword
<> " pg_basebackup -h "
<> Text.unpack setup.standby_primary_host
<> " -p "
<> show setup.standby_primary_port
<> " -U "
<> Text.unpack setup.standby_repl_user.userRole
<> " -D \"$datadir\" -Fp -Xs -R"
<> slotArg
, "chown -R postgres:postgres \"$datadir\""
, pgctl "start"
]
where
cluster = Text.unpack setup.standby_cluster
pgctl action = "pg_ctlcluster \"$version\" " <> cluster <> " " <> action
-- PGPASSFILE, not PGPASSWORD: a path rather than the secret itself, and
-- the same file `primary_conninfo` names once this is streaming.
pgpassword = "PGPASSFILE=" <> shellQuote (Text.pack setup.standby_repl_passfile)
replConninfo =
Text.unwords
[ "host=" <> setup.standby_primary_host
, "port=" <> Text.pack (show setup.standby_primary_port)
, "user=" <> setup.standby_repl_user.userRole
, "dbname=postgres"
, -- @true@, not @database@: a "database" replication connection
-- is the logical one, and @pg_hba.conf@ matches it against the
-- database name, so it is refused by the @host replication@
-- line this role has. @true@ is the physical connection that
-- line is for -- the same kind @pg_basebackup@ makes below.
"replication=true"
]
-- the slot (if any) is expected to already exist on the primary, created
-- independently via 'replicationSlot'/'primaryReplicationSetup'
slotArg = maybe "" (\slot -> " -S " <> Text.unpack slot) setup.standby_slot
shellQuote :: Text -> String
shellQuote t = "'" <> Text.unpack (Text.replace "'" "'\\''" t) <> "'"
type DatabaseName = Text
newtype Database = Database {getDatabase :: DatabaseName}
deriving (Show, ToJSON, FromJSON)
database :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> Database -> Op
database r server psql port db =
withBinary psql (psqlAdminRun_Sudo port) (CreateDB db.getDatabase) $ \up ->
op "pg-database" (deps [run server localServer]) $ \actions ->
actions
{ -- keyed by port as well as name, for the reason given at
-- 'alterSystemSet': two clusters on one box each hold their
-- own "appdb". 'cloneDatabase' uses the same key on
-- purpose, since a clone is a database at the same site.
ref = mkRef "pg-db" (port, db.getDatabase)
, up = up r'
, help = Text.unwords ["create db", db.getDatabase]
}
where
r' = contramap (PGCreateDatabase db) r
type RoleName = Text
newtype Password = Password {revealPassword :: Text}
readPassword :: FilePath -> IO Password
readPassword path = Password <$> Text.readFile path
instance Show Password where
show _ = "<password>"
newtype User = User {userRole :: RoleName}
deriving (Show, ToJSON, FromJSON)
{- | A login role with this password. Its check is 'checkUserPassword': a
role whose password was changed outside salmon is a 'Failure' naming the
role, not a node that re-applies blindly every pass.
The @ALTER ROLE@ sends a verifier computed here, not the password, so a
server with @log_statement = ddl|all@ logs that verifier; a password with a
non-ASCII character is the exception and is sent (and so may be logged) in
plaintext. See 'psqlAdminStdinSalted'.
-}
user :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> User -> Password -> Op
user r server psql port user pwd =
withBinaryStdinAtUp psql (psqlAdminRun_Sudo port) createUser $ \up ->
op "pg-user" (deps [run server localServer]) $ \actions ->
actions
{ ref = mkRef "pg-user" user.userRole
, help = Text.unwords ["create user", user.userRole]
, check = checkUserPassword port user.userRole (pure pwd)
, up = psqlAdminStdin createUser >>= \stdin -> up stdin r'
}
where
r' = contramap (PGCreateUser user) r
createUser = CreateUser user.userRole pwd
{- | A login role whose password is the content of a file, read at @check@
and @up@ time (never at graph build). Its check is 'checkUserPassword': the
password the cluster holds is compared with the file, so a rotation (a new
file) and a drift (a role altered by hand, restored from a backup) both show
as a 'Failure' before @up@ puts the file's password back. As for 'user', the
@ALTER ROLE@ carries a verifier, not the password, unless it is non-ASCII.
-}
userPassFile :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> File "passfile" -> User -> Op
userPassFile r server psql port genpass user =
withFile genpass $ \passfile ->
op "pg-user" (deps [runningServer, justInstall psql]) $ \actions ->
actions
{ ref = mkRef "pg-user" user.userRole
, help = Text.unwords ["set user password for", user.userRole, "from file at", Text.pack passfile]
, check = checkUserPassword port user.userRole (readPassword passfile)
, up = do
up =<< fmap Password (Text.readFile passfile)
}
where
r' = contramap (PGSetUserPass user) r
runningServer = run server localServer
up pass = do
let cmd = CreateUser user.userRole pass
stdin <- psqlAdminStdin cmd
untrackedExec (psqlAdminRun_Sudo port) cmd stdin r'
{- | The check of a @pg-user@ node: does the role exist, may it log in, and
is its password the declared one.
PostgreSQL never gives a password back, only the verifier it keeps in
@pg_authid.rolpassword@ (SCRAM-SHA-256 since 14, MD5 before). The declared
password is run through that same verifier's parameters here and the
results compared: no login as the role is attempted, so the check is the
same whatever @pg_hba.conf@ allows, and leaves no failed authentication in
the server's log. The reading is 'interpretRoleAuthRow', which is pure.
'Unknown' when the cluster cannot be asked or the password cannot be read
(the file is not there yet): acts like a 'Failure' for @run up@, which then
does what it did before this check existed.
Nothing secret leaves this function: the query names the role only, and a
'Failure' says what differs, never a verifier or anything computed from the
password.
-}
checkUserPassword :: Port -> RoleName -> IO Password -> IO CheckResult
checkUserPassword port name readPass = do
pass <- try readPass :: IO (Either IOException Password)
case pass of
Left _ -> pure Unknown
Right pwd -> either (const Unknown) (interpretRoleAuthRow name pwd) <$> psqlQuery_Sudo port (roleAuthSql name)
{- | One row, @t|VERIFIER@ or @f|VERIFIER@ (empty for a role without a
password), or none when the role does not exist. @pg_authid@, not
@pg_roles@: the latter shows the password as @********@. Needs a superuser,
which the @postgres@ OS user is.
The role is matched by its exact name, as 'CreateUser''s own existence test
does: a name with upper case letters, which 'CreateUser' leaves unquoted and
PostgreSQL folds, is never found and the check fails every pass (and @up@
runs every pass, as it did without a check).
-}
roleAuthSql :: RoleName -> Text
roleAuthSql name =
"SELECT CASE WHEN rolcanlogin THEN 't' ELSE 'f' END, coalesce(rolpassword, '') FROM pg_authid WHERE rolname = "
<> quoteLiteral name
{- | The verdict on 'roleAuthSql''s output for this declared password.
* No row: 'Failure', the role does not exist.
* @NOLOGIN@: 'Failure', since @up@ declares @LOGIN@.
* No password: 'Failure'.
* A verifier the password matches: 'Success'.
* A verifier the password does not match: 'Failure'.
* A verifier this cannot recompute (an unknown scheme, a SCRAM one for a
password that is not pure ASCII, which PostgreSQL first normalizes with
SASLprep, or an absurd iteration count): 'Unknown'.
-}
interpretRoleAuthRow :: RoleName -> Password -> Text -> CheckResult
interpretRoleAuthRow name pwd out =
case Text.lines (Text.strip out) of
[] -> Failure ("role " <> name <> " does not exist")
(row : _) -> case Text.breakOn "|" row of
(canLogin, rest)
| canLogin /= "t" -> Failure ("role " <> name <> " cannot log in")
| otherwise -> case Text.drop 1 rest of
"" -> Failure ("role " <> name <> " has no password")
verifier -> case matchesVerifier name pwd verifier of
Just True -> Success
Just False -> Failure ("the password of role " <> name <> " is not the declared one")
Nothing -> Unknown
{- | Whether the password is the one this verifier was made from; 'Nothing'
when that cannot be told here (see 'interpretRoleAuthRow').
-}
matchesVerifier :: RoleName -> Password -> Text -> Maybe Bool
matchesVerifier name pwd verifier
| Just hex <- Text.stripPrefix "md5" verifier
, Text.length hex == 32 =
Just (md5Verifier name pwd == verifier)
| Just params <- Text.stripPrefix "SCRAM-SHA-256$" verifier =
case Text.splitOn "$" params of
[iterSalt, keys]
| (iterText, saltText) <- Text.breakOn ":" iterSalt
, [(iters, "")] <- reads (Text.unpack iterText)
, iters > 0
, iters <= maxScramIterations
, Right salt <- Base64.decode (Text.encodeUtf8 (Text.drop 1 saltText))
, Text.all isAscii pwd.revealPassword ->
Just (Text.splitOn ":" keys == scramKeys iters salt pwd)
_ -> Nothing
| otherwise = Nothing
{- | A verifier asking for more rounds than this is answered 'Unknown'
rather than computed: the check runs every pass, and PostgreSQL's own
default is 4096.
-}
maxScramIterations :: Int
maxScramIterations = 1000000
-- | PostgreSQL's MD5 verifier: @md5@ and the hex MD5 of the password followed by the role name.
md5Verifier :: RoleName -> Password -> Text
md5Verifier name pwd =
"md5" <> Text.pack (show (Hash.hashWith Hash.MD5 (Text.encodeUtf8 (pwd.revealPassword <> name))))
{- | A SCRAM-SHA-256 verifier as PostgreSQL writes it,
@SCRAM-SHA-256$ITERATIONS:SALT$STOREDKEY:SERVERKEY@ (RFC 5802, RFC 7677),
for a pure-ASCII password, which PostgreSQL uses as it is.
-}
scramVerifier :: Int -> ByteString.ByteString -> Password -> Text
scramVerifier iters salt pwd =
"SCRAM-SHA-256$"
<> Text.pack (show iters)
<> ":"
<> Text.decodeUtf8 (Base64.encode salt)
<> "$"
<> Text.intercalate ":" (scramKeys iters salt pwd)
-- | @[StoredKey, ServerKey]@, base64, as in the verifier.
scramKeys :: Int -> ByteString.ByteString -> Password -> [Text]
scramKeys iters salt pwd =
fmap (Text.decodeUtf8 . Base64.encode) [SHA256.hash clientKey, serverKey]
where
salted = pbkdf2Sha256 (Text.encodeUtf8 pwd.revealPassword) salt iters
clientKey = SHA256.hmac salted "Client Key"
serverKey = SHA256.hmac salted "Server Key"
{- | PBKDF2-HMAC-SHA256 with a 32-byte output, the one block SCRAM-SHA-256
needs: @U1 = HMAC(P, S || 1)@, @Ui = HMAC(P, Ui-1)@, their XOR.
-}
pbkdf2Sha256 :: ByteString.ByteString -> ByteString.ByteString -> Int -> ByteString.ByteString
pbkdf2Sha256 pass salt iters = go (iters - 1) u1 u1
where
u1 = SHA256.hmac pass (salt <> ByteString.pack [0, 0, 0, 1])
go 0 _ acc = acc
go n u acc =
let u' = SHA256.hmac pass u
in go (n - 1 :: Int) u' (ByteString.pack (ByteString.zipWith xor acc u'))
data Group = Group {groupRole :: RoleName}
deriving (Show, Generic)
instance ToJSON Group
instance FromJSON Group
group :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> Group -> Op
group r server psql port group =
withBinary psql (psqlAdminRun_Sudo port) (CreateGroup group.groupRole) $ \up ->
op "pg-group" (deps [run server localServer]) $ \actions ->
actions
{ ref = mkRef "pg-group" group.groupRole
, up = up r'
, help = Text.unwords ["creates group", group.groupRole]
}
where
r' = contramap (PGCreateGroup group) r
data Role
= UserRole User
| GroupRole Group
deriving (Show, Generic)
instance ToJSON Role
instance FromJSON Role
roleName :: Role -> RoleName
roleName (UserRole u) = u.userRole
roleName (GroupRole g) = g.groupRole
data PGRight
= CREATE
| CONNECT
deriving (Show, Generic)
instance ToJSON PGRight
instance FromJSON PGRight
data AccessRight
= AccessRight
{ access_database :: Database
, access_role :: Role
, access_rights :: [PGRight]
}
deriving (Show, Generic)
instance ToJSON AccessRight
instance FromJSON AccessRight
grant :: Reporter Report -> Track' (Binary "psql") -> Port -> Track' Role -> AccessRight -> Op
grant r psql port role acl =
withBinary psql (psqlAdminRun_Sudo port) (Grant acl) $ \up ->
op "pg-grant" (deps [dbrole]) $ \actions ->
actions
{ ref = mkRef "pg-grant" (roleName acl.access_role)
, up = if null acl.access_rights then pure () else up r'
, help = Text.unwords ["grant", roleName acl.access_role]
}
where
r' = contramap (PGGrant acl) r
dbrole = run role acl.access_role
databaseOnwership ::
Reporter Report ->
Track' Server ->
Track' (Binary "psql") ->
Port ->
Track' Database ->
Database ->
Track' Role ->
Role ->
Op
databaseOnwership r server psql port mkdb db role u =
withBinary psql (psqlAdminRun_Sudo port) (DatabaseOwnership db.getDatabase (roleName u)) $ \up ->
op "pg-member" (deps [run mkdb db, dbuser]) $ \actions ->
actions
{ ref = mkRef "pg-ownership" (db.getDatabase, roleName u)
, up = up r'
, help = Text.unwords ["grant", db.getDatabase, "ownership to", roleName u]
}
where
r' = contramap (PGDatabaseOwnership db u) r
dbuser = run role u
groupMember :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> Group -> Track' Role -> Role -> Op
groupMember r server psql port g role u =
withBinary psql (psqlAdminRun_Sudo port) (GroupMembership g.groupRole (roleName u)) $ \up ->
op "pg-member" (deps [dbgroup, dbuser]) $ \actions ->
actions
{ ref = mkRef "pg-member" (g.groupRole, roleName u)
, up = up r'
, help = Text.unwords ["add", roleName u, "to", g.groupRole]
}
where
r' = contramap (PGGroupMembership g u) r
dbgroup = group r server psql port g
dbuser = run role u
adminScript ::
Reporter Report ->
Track' (Binary "psql") ->
Port ->
Track' DatabaseName ->
DatabaseName ->
File "psql-script" ->
Op
adminScript r psql port mkdb dbname file =
withFile file $ \path ->
let accessiblePath = adminDir </> path
in withBinary psql (psqlAdminRun_Sudo port) (ChmodAdminScript accessiblePath) $ \chmod ->
withBinary psql (psqlAdminRun_Sudo port) (AdminScript dbname accessiblePath) $ \up ->
op "pg-admin-script" (deps [run mkdb dbname, FS.fileCopy path accessiblePath `inject` enclosingdir]) $ \actions ->
actions
{ ref = mkRef "pg-admin-script" path
, up = chmod (r1 accessiblePath) >> up (r2 accessiblePath)
, help = Text.unwords ["runs pg script", Text.pack path]
}
where
adminDir :: FilePath
adminDir = "/opt/salmon/postgres/migrations/admin"
enclosingdir :: Op
enclosingdir = FS.dir (FS.Directory adminDir)
r1 path = contramap (PGChmod path) r
r2 path = contramap (PGAdminScript path) r
{- | commands to bootstrap PG roles and dbs as admin
expected to run as user "postgres" in Debian to handle the nopassword initial state
-}
data PsqlAdmin
= CreateDB DatabaseName
| CreateUser RoleName Password
| CreateReplicationUser RoleName Password
| CreateGroup RoleName
| Grant AccessRight
| GroupMembership RoleName RoleName
| AdminScript DatabaseName FilePath
| DatabaseOwnership DatabaseName RoleName
| ChmodAdminScript FilePath
| AlterSystemSet Text Text
| ReloadConf
| EnsurePhysicalReplicationSlot Text
{- | Every case connects to the locally-running cluster on 'port' explicitly
(via @-p@) rather than relying on @psql@'s default (which only ever reaches
whichever cluster happens to be on the default port, i.e. "main" — see
'Postgres.CreateDB' below and the "Conventions for node authors" note in
CLAUDE.md for why this matters once more than one named cluster exists on a
box).
todo: workaround chmod and sudo hack with some calling preference
- we'll need to request more than a Track' (Binary "psql") but some more complex logic
with sudo, the user, and the right binary
-}
psqlAdminRun_Sudo :: Port -> Command "psql" PsqlAdmin
psqlAdminRun_Sudo port = Command go
where
portArgs :: [String]
portArgs = ["-p", show port]
go (ChmodAdminScript path) =
proc "chmod" ["a+r", path]
go (AdminScript name path) =
proc "sudo" (["-u", "postgres", "psql"] <> portArgs <> ["-f", path, Text.unpack name])
-- CREATE DATABASE can't run inside a transaction/DO block (a hard Postgres
-- restriction), so unlike the role-creation commands below, idempotency
-- has to be a shell-level check-then-create rather than a SQL one.
go (CreateDB name) =
proc
"sudo"
[ "-u"
, "postgres"
, "bash"
, "-c"
, mconcat
[ "psql -p "
, show port
, " -tAc \"SELECT 1 FROM pg_database WHERE datname = '"
, Text.unpack name
, "'\" | grep -q 1 || psql -p "
, show port
, " -c 'CREATE DATABASE "
, Text.unpack name
, "'"
]
]
-- The two role commands carry a password, so their SQL is not in argv
-- (which every local user reads in /proc while psql runs, and which
-- 'Binary.CommandStart' reports): psql reads it on stdin, from
-- 'psqlAdminStdin'. @-X@ so no @.psqlrc@ turns on @ECHO@, which would
-- copy the statement into the captured output and from there into a
-- 'Binary.CommandFailed'; @VERBOSITY=terse@ so an error does not quote
-- the line it failed on (the default verbosity prints a @LINE 1:@ excerpt
-- of the statement); @ON_ERROR_STOP@ because a script read from stdin
-- otherwise exits 0 after an error.
go (CreateUser _ _) = psqlFromStdin
go (CreateReplicationUser _ _) = psqlFromStdin
go (AlterSystemSet param val) =
proc
"sudo"
( ["-u", "postgres", "psql"]
<> portArgs
<> ["-c", unwords ["ALTER SYSTEM SET", Text.unpack param, "=", "'" <> Text.unpack val <> "'"]]
)
go ReloadConf =
proc "sudo" (["-u", "postgres", "psql"] <> portArgs <> ["-c", "SELECT pg_reload_conf();"])
go (EnsurePhysicalReplicationSlot slot) =
proc
"sudo"
( ["-u", "postgres", "psql"]
<> portArgs
<> [ "-c"
, mconcat
[ "DO $$ BEGIN IF NOT EXISTS (SELECT 1 FROM pg_replication_slots WHERE slot_name = '"
, Text.unpack slot
, "') THEN PERFORM pg_create_physical_replication_slot('"
, Text.unpack slot
, "'); END IF; END $$;"
]
]
)
go (CreateGroup name) =
proc
"sudo"
( ["-u", "postgres", "psql"]
<> portArgs
<> [ "-c"
, mconcat
[ "DO $$ BEGIN IF NOT EXISTS (SELECT FROM pg_roles WHERE rolname = '"
, Text.unpack name
, "') THEN CREATE ROLE "
, Text.unpack name
, "; END IF; END $$;"
]
]
)
go (GroupMembership g u) =
proc
"sudo"
( ["-u", "postgres", "psql"]
<> portArgs
<> [ "-c"
, unwords
[ "ALTER GROUP"
, Text.unpack g
, "ADD USER"
, Text.unpack u
]
]
)
go (DatabaseOwnership d u) =
proc
"sudo"
( ["-u", "postgres", "psql"]
<> portArgs
<> [ "-c"
, unwords
[ "ALTER DATABASE"
, Text.unpack d
, "OWNER TO"
, Text.unpack u
]
]
)
go (Grant acl) =
proc
"sudo"
( ["-u", "postgres", "psql"]
<> portArgs
<> [ "-c"
, unwords
[ "GRANT"
, Text.unpack $ commaList $ fmap renderRight acl.access_rights
, "ON DATABASE"
, Text.unpack acl.access_database.getDatabase
, "TO"
, Text.unpack (roleName acl.access_role)
]
]
)
psqlFromStdin :: CreateProcess
psqlFromStdin =
proc
"sudo"
( ["-u", "postgres", "psql"]
<> portArgs
<> ["-X", "-q", "-v", "ON_ERROR_STOP=1", "-v", "VERBOSITY=terse", "-f", "-"]
)
renderRight :: PGRight -> Text
renderRight CREATE = "CREATE"
renderRight CONNECT = "CONNECT"
commaList :: [Text] -> Text
commaList = Text.intercalate ","
{- | What 'psqlAdminRun_Sudo' sends on psql's stdin: the role commands' SQL,
which holds the password (or a verifier of it), and nothing for every other
command (they keep their SQL in @-c@, having no secret in it). Draws a fresh
16-byte SCRAM salt each time, so it runs at @up@ time; 'psqlAdminStdinSalted'
is the same with the salt given.
-}
psqlAdminStdin :: PsqlAdmin -> IO ByteString.ByteString
psqlAdminStdin cmd = do
salt <- Random.getRandomBytes scramSaltBytes
pure (psqlAdminStdinSalted salt cmd)
{- | 'psqlAdminStdin' with the SCRAM salt given (pure, for the tests).
A role is created if missing and its password set either way: the password
is part of what the node declares, so a role that exists with some other one
has drifted from the declaration rather than been left alone deliberately.
Guarding the @ALTER@ behind the @IF NOT EXISTS@, as this used to, means a
rotated password never reaches the cluster and the failure arrives later as
"password authentication failed" somewhere that looks unrelated. CREATE ROLE
has no IF NOT EXISTS form, but (unlike CREATE DATABASE) it is fine inside a
@DO@ block, hence the explicit existence check.
__The plaintext is not sent__ for a pure-ASCII password: the @ALTER ROLE@
carries a verifier computed here, as psql's @\\password@ does, so a server
with @log_statement = ddl@ or @all@ (or an error, or @pg_stat_statements@)
records a verifier rather than the password. Which verifier follows the
server's @password_encryption@, read first with @\\gset@: MD5 (salted by the
role name, see 'md5Verifier') when it says @md5@ (or @on@), SCRAM-SHA-256
with 4096 iterations and a random salt otherwise (see 'scramVerifier'); a
verifier is stored as it is whatever that setting says, so this keeps the
scheme the server would have chosen. 'checkUserPassword' reads either. Note
that an MD5 verifier, in a log as in @pg_authid@, is enough to log in with
the @md5@ method: only a SCRAM one is safe to see.
A password with a non-ASCII character is still sent in plaintext, because
PostgreSQL normalizes such a password with SASLprep before deriving the
SCRAM keys and that is not reimplemented here; a server logging DDL logs it.
Needs psql 10 or later (@\\if@). The password or verifier is a
'quoteLiteral', so a quote in it cannot end the literal (and so cannot put
the rest of it in a syntax error's text).
-}
psqlAdminStdinSalted :: ByteString.ByteString -> PsqlAdmin -> ByteString.ByteString
psqlAdminStdinSalted salt (CreateUser name pass) = Text.encodeUtf8 (roleWithPasswordSql salt "LOGIN" name pass)
psqlAdminStdinSalted salt (CreateReplicationUser name pass) = Text.encodeUtf8 (roleWithPasswordSql salt "REPLICATION LOGIN" name pass)
psqlAdminStdinSalted _ _ = ""
-- | PostgreSQL's own default salt length (@SCRAM_DEFAULT_SALT_LEN@).
scramSaltBytes :: Int
scramSaltBytes = 16
-- | PostgreSQL's own default (@scram_iterations@, @SCRAM_SHA_256_DEFAULT_ITERATIONS@).
scramIterations :: Int
scramIterations = 4096
roleWithPasswordSql :: ByteString.ByteString -> Text -> RoleName -> Password -> Text
roleWithPasswordSql salt attrs name pass =
mconcat
[ "DO $$ BEGIN IF NOT EXISTS (SELECT FROM pg_roles WHERE rolname = '"
, name
, "') THEN CREATE ROLE "
, name
, " WITH "
, attrs
, "; END IF; END $$;\n"
, setPassword
]
where
alterWith secret = "ALTER ROLE " <> name <> " WITH " <> attrs <> " PASSWORD " <> quoteLiteral secret <> ";\n"
setPassword
| Text.all isAscii pass.revealPassword =
mconcat
[ "SELECT current_setting('password_encryption') IN ('md5', 'on') AS salmon_md5 \\gset\n"
, "\\if :salmon_md5\n"
, alterWith (md5Verifier name pass)
, "\\else\n"
, alterWith (scramVerifier scramIterations salt pass)
, "\\endif\n"
]
| otherwise = alterWith pass.revealPassword
-------------------------------------------------------------------------------
data ConnString pass = ConnString
{ connstring_server :: Server
, connstring_user :: User
, connstring_user_pass :: pass
, connstring_db :: Database
}
deriving (Generic, Functor)
instance (ToJSON a) => ToJSON (ConnString a)
instance (FromJSON a) => FromJSON (ConnString a)
type UnknownPassword = ()
connstring :: ConnString Password -> Text
connstring (ConnString server user pass db) =
mconcat
[ "postgresql://"
, user.userRole
, ":"
, pass.revealPassword
, "@"
, server.serverHost
, ":"
, Text.pack $ show server.serverPort
, "/"
, db.getDatabase
]
withPassword :: ConnString a -> Password -> ConnString Password
withPassword c pass = const pass <$> c
userScriptInMemoryPass ::
Reporter Report ->
Track' (Binary "psql") ->
Track' (ConnString Password) ->
ConnString Password ->
File "psql-script" ->
Op
userScriptInMemoryPass r psql mksetup c@(ConnString server user pass db) file =
withFile file $ \path ->
withBinaryStdin psql (psqlUserRun c) (UserScript path) (passwordStdin pass) $ \up ->
op "pg-script" (deps [run mksetup c]) $ \actions ->
actions
{ ref = mkRef "pg-script" path
, up = up (r' path)
, help = Text.unwords ["runs pg script", Text.pack path]
}
where
r' path = contramap (PGScript path) r
userScript ::
Reporter Report ->
Track' (Binary "psql") ->
Track' (ConnString FilePath) ->
ConnString FilePath ->
File "psql-script" ->
Op
userScript r psql mksetup c@(ConnString server user passFile db) file =
withFile file $ \path ->
op "pg-script" (deps [run mksetup c, justInstall psql]) $ \actions ->
actions
{ ref = mkRef "pg-script" path
, up = do
up path =<< fmap Password (Text.readFile passFile)
, help = Text.unwords ["runs pg script", Text.pack path]
}
where
r' path = contramap (PGScript path) r
up path pass = untrackedExec (psqlUserRun c) (UserScript path) (passwordStdin pass) (r' path)
data PsqlUser
= UserScript FilePath
{- | Runs a script as the connection's user. __The password is not in argv__
(which every local user reads in @/proc@ while psql runs, and which
'Binary.CommandStart' reports), nor in the 'CreateProcess' at all (its
environment is reported too): a @bash@ reads it from its stdin (see
'passwordStdin') into @PGPASSWORD@ and @exec@s psql with a connection URL
that has no password, so it lives only in psql's own environment, which only
the same user and root can read. Newlines in it are kept (@read -d ''@), as
they were in the URL this used to build: a password file written by
@openssl rand -hex@ ends with one, and so does the role's password set from
it. psql's stdin is @\/dev\/null@.
-}
psqlUserRun :: ConnString a -> Command "psql" PsqlUser
psqlUserRun c = Command go
where
go (UserScript path) =
proc
"bash"
[ "-c"
, "IFS= read -r -d '' PGPASSWORD || true; export PGPASSWORD; exec psql \"$@\" </dev/null"
, "psql"
, Text.unpack $ connstringWithoutPassword c
, "-f"
, path
]
-- | What 'psqlUserRun' reads on stdin: the password's bytes, nothing else.
passwordStdin :: Password -> ByteString.ByteString
passwordStdin pass = Text.encodeUtf8 pass.revealPassword
-- | 'connstring' without the @:password@, which libpq then takes from @PGPASSWORD@.
connstringWithoutPassword :: ConnString a -> Text
connstringWithoutPassword (ConnString server user _ db) =
mconcat
[ "postgresql://"
, user.userRole
, "@"
, server.serverHost
, ":"
, Text.pack $ show server.serverPort
, "/"
, db.getDatabase
]
-------------------------------------------------------------------------------
-- Cluster lifecycle (named, non-"main" clusters)
-- | @pg_createcluster@s a new, empty cluster under Debian's cluster management
-- (idempotent: a no-op if a cluster by that name already exists).
createCluster :: Reporter Report -> Track' (Binary "postgres") -> Track' (Binary "pg_ctlcluster") -> ClusterName -> Port -> Op
createCluster r pg pgctl name port =
withBinary pgctl pgctlRun cmd $ \run ->
op "pg-create-cluster" (deps [justInstall pg]) $ \actions ->
actions
{ ref = mkRef "pg-create-cluster" name
, help = Text.unwords ["creates pg cluster", name, "on port", Text.pack (show port)]
, up = run r'
}
where
cmd = CreateCluster name port
r' = contramap (PGClusterOp cmd) r
clusterCtl :: Reporter Report -> Track' (Binary "pg_ctlcluster") -> ClusterName -> PgCtl -> Text -> IO CheckResult -> Op
clusterCtl r pgctl name cmd label chk =
withBinary pgctl pgctlRun cmd $ \run ->
op "pg-cluster-ctl" nodeps $ \actions ->
actions
{ ref = mkRef "pg-cluster-ctl" (name, label)
, help = Text.unwords [label, "pg cluster", name]
, check = chk
, up = run r'
}
where
r' = contramap (PGClusterOp cmd) r
startCluster, stopCluster, restartCluster, promoteCluster :: Reporter Report -> Track' (Binary "pg_ctlcluster") -> ClusterName -> Op
-- | @pg_ctlcluster start@ exits 2 on a cluster that is already running, so this asks first.
startCluster r pgctl name = clusterCtl r pgctl name (StartCluster name) "start" (checkClusterIs Online name)
-- | The mirror image: @stop@ exits 2 on a cluster that is already down.
stopCluster r pgctl name = clusterCtl r pgctl name (StopCluster name) "stop" (checkClusterIs Down name)
{- | Restarts unconditionally, on every pass.
There is no check to write here: a restart's effect is not a state the
cluster can be found in afterwards. 'restartClusterIfPending' is the form
with a reason to stop, and is what 'primaryReplicationSetup' uses.
-}
restartCluster r pgctl name = clusterCtl r pgctl name (RestartCluster name) "restart" (pure Immaterial)
{- | Promotes unconditionally.
Deliberately left without a check: "this cluster is not in recovery" is a
fact about a /pair/ of machines, and answering it from one of them is how a
promotion happens twice. The node that will own that question is the
switchover node in @specs\/pg-switchover.md@.
-}
promoteCluster r pgctl name = clusterCtl r pgctl name (PromoteCluster name) "promote" (pure Immaterial)
{- | Restarts the cluster if any setting is waiting for one.
The check is @pg_settings.pending_restart@, which is Postgres's own record
of "you changed something that only a restart applies" -- the same shape of
answer as systemd's @NeedDaemonReload@, and for the same reason: the change
is already on disk, so nothing on disk can still testify that the running
server is stale.
An unreachable cluster answers 'Unknown', which the one-shot drivers treat
as "go ahead": @pg_ctlcluster restart@ on a stopped cluster starts it.
-}
restartClusterIfPending :: Reporter Report -> Track' (Binary "pg_ctlcluster") -> Port -> ClusterName -> Op
restartClusterIfPending r pgctl port name =
clusterCtl r pgctl name (RestartCluster name) "restart" (checkNoPendingRestart port)
-- | The two states @pg_lsclusters@ reports that this module has an opinion about.
data ClusterState = Online | Down
deriving (Eq, Show)
-- | Is the named cluster in this state?
checkClusterIs :: ClusterState -> ClusterName -> IO CheckResult
checkClusterIs wanted name =
either (const Unknown) (interpretClusterStatus wanted name) <$> clusterStatusOutput
{- | @pg_lsclusters --no-header@ is one line per cluster, @Ver Cluster Port
Status Owner DataDirectory LogFile@, and the status column is the one word
this reads. A cluster absent from the listing does not exist, which is not
the same as being down, and is a 'Failure' either way: it is not in the
state the caller asked for, and the reasons read differently to an operator.
Statuses other than @online@ and @down@ exist, and none of them is a state
to stop at: a cluster @online,recovery@ is still coming up, and
@online,recovery@ read as "already started" would let a dependant run
against a server still replaying WAL.
-}
interpretClusterStatus :: ClusterState -> ClusterName -> Text -> CheckResult
interpretClusterStatus wanted name out =
case [fields | line <- Text.lines out, fields <- [Text.words line], take 1 (drop 1 fields) == [name]] of
[] -> Failure ("no cluster named " <> name)
(fields : _) -> case drop 3 fields of
(status : _) -> verdict status
[] -> Unknown
where
verdict status
| status == expected = Success
| status `elem` ["online", "down"] = Failure (name <> " is " <> status)
| otherwise = Failure (name <> " is " <> status <> ", neither online nor down")
expected = case wanted of
Online -> "online"
Down -> "down"
clusterStatusOutput :: IO (Either Text Text)
clusterStatusOutput = do
(code, out, err) <- readCreateProcessWithExitCode (proc "pg_lsclusters" ["--no-header"]) ""
pure $ case code of
ExitSuccess -> Right (Text.decodeUtf8With TextError.lenientDecode out)
ExitFailure _ -> Left (Text.decodeUtf8With TextError.lenientDecode err)
-- | Is any setting on this cluster waiting for a restart?
checkNoPendingRestart :: Port -> IO CheckResult
checkNoPendingRestart port =
either (const Unknown) interpretPendingRestart
<$> psqlQuery_Sudo port "SELECT coalesce(string_agg(name, ','), '') FROM pg_settings WHERE pending_restart"
-- | The verdict 'checkNoPendingRestart' draws, split out so it is testable without a cluster.
interpretPendingRestart :: Text -> CheckResult
interpretPendingRestart out =
case Text.strip out of
"" -> Success
names -> Failure ("settings waiting for a restart: " <> names)
-------------------------------------------------------------------------------
-- Physical (WAL streaming) replication
{- | Settings a primary needs to accept streaming replicas. Debian's default
@postgresql.conf@ already ships @wal_level = replica@ on modern versions,
but we set it explicitly since a misconfigured value there is a silent
failure mode (replication just won't start).
-}
data ReplicationTuning
= ReplicationTuning
{ repl_max_wal_senders :: Int
, repl_max_replication_slots :: Int
, repl_wal_log_hints :: Bool
-- ^ whether @pg_rewind@ can ever be used on this cluster. See 'defaultReplicationTuning'.
, repl_max_slot_wal_keep_size :: Maybe Text
-- ^ a cap on the WAL a lagging standby's slot may pin, @Nothing@ for none.
}
deriving (Show)
{- | Ten senders and ten slots, hint logging on, and ten gigabytes of WAL a
slot may pin.
The last two are opinions, and both are about what happens on a bad day.
@wal_log_hints@ is what makes @pg_rewind@ possible, and it can only be
turned on by a /restart/: a cluster that did not have it when its primary
died cannot rewind the old primary onto the new one's history, so the only
way to put that machine back is to copy the whole cluster over the network
again. Deciding this after the fact is deciding it too late, and the cost
while nothing is wrong is some extra WAL.
@max_slot_wal_keep_size@ bounds that WAL. A replication slot with no cap
keeps every segment its standby has not consumed, for as long as the standby
is away -- so a standby that stays down long enough fills the primary's disk
and takes the __primary__ down with it. Past the cap, the slot is
invalidated instead and that standby has to be re-seeded, which is the
better of the two bad outcomes: one machine to rebuild rather than two.
-}
defaultReplicationTuning :: ReplicationTuning
defaultReplicationTuning = ReplicationTuning 10 10 True (Just "10GB")
{- | The @ALTER SYSTEM@ settings a primary needs, as (parameter, value)
pairs. Split out of 'primaryReplicationSetup' so a test can read them
without building a graph.
@wal_level@ is set explicitly although Debian's @postgresql.conf@ already
ships @replica@: a wrong value there fails silently, in the sense that
replication simply never starts.
-}
replicationSettings :: ReplicationTuning -> [(Text, Text)]
replicationSettings tuning =
[ ("wal_level", "replica")
, ("max_wal_senders", tshow tuning.repl_max_wal_senders)
, ("max_replication_slots", tshow tuning.repl_max_replication_slots)
, ("listen_addresses", "*")
, ("wal_log_hints", if tuning.repl_wal_log_hints then "on" else "off")
]
<> foldMap (\cap -> [("max_slot_wal_keep_size", cap)]) tuning.repl_max_slot_wal_keep_size
where
tshow = Text.pack . show
-- | A host or CIDR allowed to authenticate as the replication role, e.g. the standby's address.
type AllowedCidr = Text
type ReplicationSlotName = Text
-- | Everything needed to clone an empty (or freshly created) cluster off a running primary and start it as a streaming standby.
data StandbySetup
= StandbySetup
{ standby_cluster :: ClusterName
, standby_primary_host :: Host
, standby_primary_port :: Port
, standby_repl_user :: User
, standby_repl_passfile :: FilePath
-- ^ a @.pgpass@ file on the standby holding the replication role's
-- password. A path, not the password: this setup is rendered into a
-- shell script, and a script is visible in @ps@ and printed verbatim by
-- every 'Binary.Report' along the way. Pre-provisioned by the caller,
-- readable only by whoever runs this node.
--
-- @.pgpass@ format rather than a bare password, because
-- @primary_conninfo@'s @passfile=@ can read nothing else -- so one file
-- serves both the clone and the streaming that follows it, and a pair
-- has one secret per role rather than two spellings of it.
, standby_slot :: Maybe ReplicationSlotName
}
deriving (Show)
{- | A login role carrying the @REPLICATION@ attribute, for a standby's
@pg_basebackup@\/streaming connection. Its password goes as 'user''s does:
a verifier (what @log_statement = ddl|all@ may log), except for a non-ASCII
password, sent in plaintext; see 'psqlAdminStdinSalted'.
-}
replicationUser :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> User -> Password -> Op
replicationUser r server psql port u pwd =
withBinaryStdinAtUp psql (psqlAdminRun_Sudo port) createUser $ \up ->
op "pg-replication-user" (deps [run server localServer]) $ \actions ->
actions
{ ref = mkRef "pg-replication-user" u.userRole
, help = Text.unwords ["create replication user", u.userRole]
, up = psqlAdminStdin createUser >>= \stdin -> up stdin r'
}
where
r' = contramap (PGCreateReplicationUser u) r
createUser = CreateReplicationUser u.userRole pwd
alterSystemSet :: Reporter Report -> Track' (Binary "psql") -> Port -> Text -> Text -> Op
alterSystemSet r psql port param val =
withBinary psql (psqlAdminRun_Sudo port) (AlterSystemSet param val) $ \up ->
op "pg-alter-system" nodeps $ \actions ->
actions
{ -- keyed by port as well as parameter: a box running two
-- clusters has two genuinely different settings of the same
-- name, and keying on the name alone deduped them into one
-- node, silently dropping whichever was declared second.
ref = mkRef "pg-alter-system" (port, param)
, help = Text.unwords ["ALTER SYSTEM SET", param, "=", val]
, up = up r'
}
where
r' = contramap (PGAlterSystem param val) r
reloadConf :: Reporter Report -> Track' (Binary "psql") -> Port -> Op
reloadConf r psql port =
withBinary psql (psqlAdminRun_Sudo port) ReloadConf $ \up ->
op "pg-reload-conf" nodeps $ \actions ->
actions
{ -- same reasoning as 'alterSystemSet': one reload per
-- cluster, not one reload for the whole machine.
ref = mkRef "pg-reload-conf" port
, up = up r'
}
where
r' = contramap PGReloadConf r
-- | Ensures a physical replication slot exists on the primary (idempotent: skips if already present).
replicationSlot :: Reporter Report -> Track' (Binary "psql") -> Port -> ReplicationSlotName -> Op
replicationSlot r psql port slot =
withBinary psql (psqlAdminRun_Sudo port) (EnsurePhysicalReplicationSlot slot) $ \up ->
op "pg-replication-slot" nodeps $ \actions ->
actions
{ ref = mkRef "pg-replication-slot" slot
, help = Text.unwords ["ensure replication slot", slot]
, up = up r'
}
where
r' = contramap (PGReplicationSlot slot) r
{- | Ensures an arbitrary line is present in a cluster's @pg_hba.conf@, then
reloads it.
'allowReplicationFrom' and 'allowClientCertFrom' are the two lines this repo
has an opinion about; this is the escape hatch for the rest of
@pg_hba.conf@'s vocabulary, which is large and changes between major
versions. The line is matched verbatim (@grep -qxF@), so a line differing
only in whitespace is a /second/ line rather than an update of the first --
which is also why a caller changing its mind leaves the old line behind.
-}
hbaLine :: Reporter Report -> Track' (Binary "pg_ctlcluster") -> ClusterName -> Text -> Op
hbaLine r pgctl name line =
withBinary pgctl pgctlRun cmd $ \run ->
op "pg-hba-line" nodeps $ \actions ->
actions
{ ref = mkRef "pg-hba-line" (name, line)
, help = Text.unwords ["ensure pg_hba line on", name <> ":", line]
, notes = ["appended verbatim; changing it leaves the previous line in place"]
, up = run r'
}
where
cmd = EnsureHbaLine name line
r' = contramap (PGClusterOp cmd) r
{- | Authenticates a role by __client certificate only__, over TLS:
@hostssl \<db\> \<role\> \<cidr\> cert clientcert=verify-full@.
Two properties make this the interesting @pg_hba@ line rather than just
another one. @hostssl@ refuses a plaintext connection outright, so there is
no password path left to get wrong, and @clientcert=verify-full@ requires the
certificate's @CN@ to __equal the role name__ -- which turns "who may connect
as this role" into "who holds a certificate this cluster's CA issued for that
name", with no secret on the client that is not also a key.
The cluster must already be serving TLS and trusting the right CA for this to
be usable at all; that is 'serverTls'. A @hostssl@ line on a cluster with
@ssl = off@ is accepted by @pg_hba.conf@ and matches nothing.
-}
allowClientCertFrom ::
Reporter Report ->
Track' (Binary "pg_ctlcluster") ->
ClusterName ->
DatabaseName ->
RoleName ->
AllowedCidr ->
Op
allowClientCertFrom r pgctl name db role cidr =
hbaLine r pgctl name (Text.unwords ["hostssl", db, role, cidr, "cert", "clientcert=verify-full"])
{- | Where a cluster's TLS material lives. Paths are on the /database/ host,
and the key must be readable by the @postgres@ user and by nobody else --
see "Salmon.Builtin.Nodes.Filesystem".@ownedFile@, which exists for this.
-}
data ServerTls
= ServerTls
{ tls_certFile :: FilePath
, tls_keyFile :: FilePath
, tls_caFile :: FilePath
-- ^ the CA whose certificates this cluster will accept from clients.
}
deriving (Eq, Ord, Show)
{- | Turns TLS on for a cluster and points it at its certificate, key and
client CA.
All four settings are @sighup@-able, so this reloads rather than restarting:
a cluster serving traffic picks up a renewed certificate without dropping a
connection. (That also means a __broken__ certificate is not noticed until
something tries to connect, since the reload itself succeeds.)
-}
serverTls :: Reporter Report -> Track' (Binary "psql") -> Port -> ServerTls -> Op
serverTls = serverTlsAfter []
{- | 'serverTls', with nodes every setting and the reload wait for: the
certificate, key and CA in place with the ownership postgres demands,
typically.
The node returned (@pg-server-tls@) has no effect of its own: a node
@inject@ed onto it is a sibling of the settings and the reload, which may
then run first and point the cluster at a key not yet there. These go under
each of them instead. With @[]@ the graph is 'serverTls''s, unchanged.
-}
serverTlsAfter :: [Op] -> Reporter Report -> Track' (Binary "psql") -> Port -> ServerTls -> Op
serverTlsAfter prerequisites r psql port tls =
op "pg-server-tls" (deps [reload]) $ \actions ->
actions
{ ref = mkRef "pg-server-tls" (port, tls.tls_certFile)
, help = Text.unwords ["serves TLS on port", Text.pack (show port)]
}
where
after o = foldl inject o prerequisites
reload = foldl inject (after (reloadConf r psql port)) settings
settings =
map
after
[ alterSystemSet r psql port "ssl" "on"
, alterSystemSet r psql port "ssl_cert_file" (Text.pack tls.tls_certFile)
, alterSystemSet r psql port "ssl_key_file" (Text.pack tls.tls_keyFile)
, alterSystemSet r psql port "ssl_ca_file" (Text.pack tls.tls_caFile)
]
allowReplicationFrom :: Reporter Report -> Track' (Binary "pg_ctlcluster") -> ClusterName -> RoleName -> AllowedCidr -> Op
allowReplicationFrom r pgctl name replRole cidr =
withBinary pgctl pgctlRun cmd $ \run ->
op "pg-hba-replication" nodeps $ \actions ->
actions
{ ref = mkRef "pg-hba-replication" (name, replRole, cidr)
, help = Text.unwords ["allow replication from", cidr, "as", replRole, "on", name]
, up = run r'
}
where
line = Text.unwords ["host", "replication", replRole, cidr, "md5"]
cmd = EnsureHbaLine name line
r' = contramap (PGClusterOp cmd) r
{- | Turns an already-running, named cluster into a replication-capable
primary: WAL/replication-slot tuning (restart-required, so this restarts the
cluster), a @pg_hba.conf@ entry authorizing the standby, and the physical
replication slot the standby will stream from. Does /not/ create the
replication role itself — do that once via 'replicationUser' (it's shared
infrastructure, not per-standby).
-}
primaryReplicationSetup ::
Reporter Report ->
Track' (Binary "psql") ->
Track' (Binary "pg_ctlcluster") ->
Port ->
ClusterName ->
ReplicationTuning ->
RoleName ->
AllowedCidr ->
ReplicationSlotName ->
Op
primaryReplicationSetup r psql pgctl port name tuning replRole cidr slot =
op "pg-primary-replication-setup" (deps [replicationSlot r psql port slot, allowReplicationFrom r pgctl name replRole cidr, restartOp]) id
where
-- restart-if-pending rather than restart: this node is re-applied on
-- every pass, and an unconditional restart here is an outage per pass.
restartOp = restartClusterIfPending r pgctl port name `inject` applySettings
applySettings = op "pg-primary-wal-settings" (deps $ fmap (uncurry (alterSystemSet r psql port)) (replicationSettings tuning)) id
-- | Clones 'StandbySetup's cluster off its primary via @pg_basebackup -R@ and starts it as a streaming standby.
standbyReplicationSetup :: Reporter Report -> Track' (Binary "pg_ctlcluster") -> StandbySetup -> Op
standbyReplicationSetup r pgctl setup =
withBinary pgctl pgctlRun cmd $ \run ->
op "pg-standby-setup" nodeps $ \actions ->
actions
{ ref = mkRef "pg-standby-setup" setup.standby_cluster
, help = Text.unwords ["clone", setup.standby_cluster, "from", setup.standby_primary_host, "as a streaming standby"]
, up = run r'
}
where
cmd = CloneFromPrimary setup
r' = contramap (PGClusterOp cmd) r
-------------------------------------------------------------------------------
-- Template databases, and databases cloned from them
{- $templates
@CREATE DATABASE c TEMPLATE t@ copies @t@ at the file level, which is how a
database that took a whole migration history to build is handed out in a
second. What makes that safe to automate is almost entirely about who else
is touching @t@:
* Nothing may be connected to @t@ while it is copied, or the copy fails with
"source database is being accessed by other users". A template is therefore
/locked/ once built: @ALLOW_CONNECTIONS false@, and any session still
attached is terminated.
* @IS_TEMPLATE true@ lets a role with only @CREATEDB@ clone it, and makes
@DROP DATABASE@ refuse, so every teardown has to flip it back first.
Both the template and its clones are databases salmon /drops/ -- to rebuild a
template, and to take a clone down -- so each carries a marker in its
database comment ('templateMarker', 'cloneMarker') and every statement that
would drop or adopt one refuses a database without it. That is what stops a
template or clone named after an existing database from replacing it: the
name is the caller's to choose, and nothing else about a database says who
made it.
The statements are fed to @psql@ on stdin rather than with @-c@, because
@CREATE DATABASE@ cannot run inside a transaction or a @DO@ block, and
@\\gexec@ is the one conditional form it tolerates. @DROP DATABASE ... WITH
(FORCE)@ needs Postgres 13 or later.
-}
-- | The comment prefix on a database salmon built as a template.
templateMarker :: Text
templateMarker = "salmon-template:"
-- | The comment prefix on a database salmon cloned from a template.
cloneMarker :: Text
cloneMarker = "salmon-clone:"
-- | A double-quoted SQL identifier.
quoteIdent :: Text -> Text
quoteIdent t = "\"" <> Text.replace "\"" "\"\"" t <> "\""
-- | A single-quoted SQL string literal (with @standard_conforming_strings@, the default since 9.1).
quoteLiteral :: Text -> Text
quoteLiteral t = "'" <> Text.replace "'" "''" t <> "'"
{- | Dollar-quotes a @DO@ body with a tag that does not occur in it.
A bare @$$@ is broken out of by a database name containing @$$@, and
'quoteLiteral' does nothing about that because inside a dollar-quoted body
nothing is a literal yet.
-}
dollarQuote :: Text -> Text
dollarQuote body = tag <> body <> tag
where
-- the search terminates: a body of length n contains fewer than n tags
tag = case [t | n <- [0 :: Int ..], let t = "$salmon" <> Text.pack (show n) <> "$", not (t `Text.isInfixOf` body)] of
(t : _) -> t
[] -> error "unreachable: infinitely many candidate tags"
-- | A batch of SQL, fed to @psql@ on stdin as the @postgres@ OS user.
data PsqlBatch = PsqlBatch
{- | @ON_ERROR_STOP@ is not optional: @psql@ reading a script carries on past
a failed statement and exits @0@, so without it a refused drop would be
followed by the @CREATE@ it was guarding, and the node would report success.
-}
psqlBatchRun_Sudo :: Port -> Command "psql" PsqlBatch
psqlBatchRun_Sudo port = psqlBatchIn_Sudo port "postgres"
-- | 'psqlBatchRun_Sudo' connected to a named database (an extension lives in one).
psqlBatchIn_Sudo :: Port -> DatabaseName -> Command "psql" PsqlBatch
psqlBatchIn_Sudo port db = Command go
where
go PsqlBatch =
proc "sudo" ["-u", "postgres", "psql", "-p", show port, "-X", "-q", "-v", "ON_ERROR_STOP=1", "-d", Text.unpack db]
-- | Aborts the batch unless @name@ is absent or its comment starts with @marker@.
refuseUnmarked :: Text -> Text -> DatabaseName -> Text
refuseUnmarked marker verb name =
"DO " <> dollarQuote body <> ";\n"
where
body =
Text.unwords
[ "BEGIN IF EXISTS (SELECT FROM pg_database WHERE datname =" <> quoteLiteral name
, "AND coalesce(left(shobj_description(oid, 'pg_database'), " <> Text.pack (show (Text.length marker)) <> "), '') <>" <> quoteLiteral marker <> ")"
, "THEN RAISE EXCEPTION '%'," <> quoteLiteral ("refusing to " <> verb <> " database " <> name <> ": salmon did not create it") <> ";"
, "END IF; END"
]
-- | Drops a template salmon built, if it is there.
dropTemplateSql :: DatabaseName -> Text
dropTemplateSql name =
refuseUnmarked templateMarker "drop" name
<> Text.unlines
[ "SELECT format('ALTER DATABASE %I IS_TEMPLATE false', datname) FROM pg_database WHERE datname = " <> quoteLiteral name <> " \\gexec"
, "DROP DATABASE IF EXISTS " <> quoteIdent name <> " WITH (FORCE);"
]
{- | Starts a template build from nothing: whatever was there before is
dropped, and the fresh database is marked as a build in progress, so that a
build which dies half-way is recognisably salmon's to replace next time.
-}
prepareTemplateSql :: DatabaseName -> Text
prepareTemplateSql name =
refuseUnmarked templateMarker "replace" name
<> Text.unlines
[ "SELECT format('ALTER DATABASE %I IS_TEMPLATE false', datname) FROM pg_database WHERE datname = " <> quoteLiteral name <> " \\gexec"
, "DROP DATABASE IF EXISTS " <> quoteIdent name <> " WITH (FORCE);"
, "CREATE DATABASE " <> quoteIdent name <> ";"
, "COMMENT ON DATABASE " <> quoteIdent name <> " IS " <> quoteLiteral (templateMarker <> "building") <> ";"
]
{- | Finishes a build: stamps the inputs it was built from, locks it, and
evicts whatever is still connected -- a session left on the template is the
thing that makes the next clone fail.
-}
lockTemplateSql :: DatabaseName -> Text -> Text
lockTemplateSql name fingerprint =
Text.unlines
[ "COMMENT ON DATABASE " <> quoteIdent name <> " IS " <> quoteLiteral (templateMarker <> fingerprint) <> ";"
, "ALTER DATABASE " <> quoteIdent name <> " WITH IS_TEMPLATE true ALLOW_CONNECTIONS false;"
, "SELECT pg_terminate_backend(pid) FROM pg_stat_activity WHERE datname = " <> quoteLiteral name <> " AND pid <> pg_backend_pid();"
]
-- | One row, @datistemplate|datallowconn|comment@, or none.
inspectTemplateSql :: DatabaseName -> Text
inspectTemplateSql name =
"SELECT datistemplate, datallowconn, coalesce(shobj_description(oid, 'pg_database'), '') FROM pg_database WHERE datname = " <> quoteLiteral name
-- | Is @name@ a finished, locked template built from @fingerprint@.
checkTemplate :: Port -> DatabaseName -> Text -> IO CheckResult
checkTemplate port name fingerprint =
either (const Unknown) (interpretTemplateRow name fingerprint) <$> psqlQuery_Sudo port (inspectTemplateSql name)
{- | The verdict 'checkTemplate' draws, split out so it is testable without a
cluster.
Everything short of "locked, and stamped with these inputs" is a 'Failure',
and every one of them means the same thing to the node -- rebuild -- but the
reasons are kept apart because they are different stories for an operator:
a template built from older migrations is routine, a half-built one means a
build died, and an unlocked one means somebody has been connected to it.
-}
interpretTemplateRow :: DatabaseName -> Text -> Text -> CheckResult
interpretTemplateRow name fingerprint out =
case Text.lines (Text.strip out) of
[] -> Failure ("template " <> name <> " does not exist")
(row : _) -> case Text.splitOn "|" row of
(istemplate : allowconn : rest) -> verdict istemplate allowconn (Text.intercalate "|" rest)
_ -> Unknown
where
verdict istemplate allowconn comment
| not (templateMarker `Text.isPrefixOf` comment) =
Failure (name <> " exists and salmon did not build it as a template")
| comment == templateMarker <> "building" =
Failure ("template " <> name <> " is half-built: a previous build did not finish")
| comment /= templateMarker <> fingerprint =
Failure ("template " <> name <> " was built from different inputs")
| istemplate /= "t" || allowconn /= "f" =
Failure ("template " <> name <> " is not locked")
| otherwise = Success
-- | A database copied from a template once, on creation.
data Clone
= Clone
{ clone_database :: DatabaseName
, clone_template :: DatabaseName
, clone_owner :: Maybe RoleName
-- ^ must already exist; 'Nothing' leaves it owned by @postgres@. The
-- objects /inside/ keep whichever owners they had in the template.
}
deriving (Eq, Show, Generic)
instance ToJSON Clone
instance FromJSON Clone
cloneDatabaseSql :: Clone -> Text
cloneDatabaseSql c =
refuseUnmarked cloneMarker "adopt" c.clone_database
<> Text.unlines
[ "SELECT " <> quoteLiteral create <> " WHERE NOT EXISTS (SELECT FROM pg_database WHERE datname = " <> quoteLiteral c.clone_database <> ") \\gexec"
, "COMMENT ON DATABASE " <> quoteIdent c.clone_database <> " IS " <> quoteLiteral (cloneMarker <> c.clone_template) <> ";"
]
where
create =
Text.unwords $
["CREATE DATABASE", quoteIdent c.clone_database, "TEMPLATE", quoteIdent c.clone_template]
<> maybe [] (\o -> ["OWNER", quoteIdent o]) c.clone_owner
dropCloneSql :: DatabaseName -> Text
dropCloneSql name =
refuseUnmarked cloneMarker "drop" name
<> Text.unlines ["DROP DATABASE IF EXISTS " <> quoteIdent name <> " WITH (FORCE);"]
-- | One row, @row:\<comment\>@, or none; the prefix tells an uncommented database from a missing one.
inspectCloneSql :: DatabaseName -> Text
inspectCloneSql name =
"SELECT 'row:' || coalesce(shobj_description(oid, 'pg_database'), '') FROM pg_database WHERE datname = " <> quoteLiteral name
checkClone :: Port -> DatabaseName -> IO CheckResult
checkClone port name =
either (const Unknown) (interpretCloneRow name) <$> psqlQuery_Sudo port (inspectCloneSql name)
{- | A clone that exists is satisfied whichever template it came from: a
clone is somebody's data from the moment it is made, and re-declaring it
from a newer template is not a reason to throw that away.
-}
interpretCloneRow :: DatabaseName -> Text -> CheckResult
interpretCloneRow name out =
case Text.lines (Text.strip out) of
[] -> Failure ("database " <> name <> " does not exist")
(row : _)
| (("row:" <> cloneMarker) `Text.isPrefixOf` row) -> Success
| otherwise -> Failure (name <> " exists and salmon did not clone it")
{- | What taking a clone down does to its data.
The choice belongs to the declaration rather than to the clone, because the
same database changes hands during its life. A clone backing a pull
request's environment should survive that environment being torn down and
redeployed while the PR is open (somebody's test data is in it), and should
go once the PR is merged. That is one database declared 'Retain' and later
'Discard' -- see 'retainedClone' and 'disposableClone'.
-}
data Retention
= -- | @down@ leaves the database in place.
Retain
| -- | @down@ drops the database, data included.
Discard
deriving (Eq, Show, Generic)
instance ToJSON Retention
instance FromJSON Retention
{- | A database copied from a template.
The copy is taken __once__: a template rebuilt later does not reach an
existing clone. To pick up a newer template, take the clone down with
'Discard' and bring it up again.
With 'Discard', @down@ refuses a database salmon did not clone, same as @up@
refuses to adopt one. The 'Retention' is in the node's @notes@, so under
@run serve@ re-declaring a clone with the other one is seen as a change to
it, and a graph holding both is reported as a conflict.
-}
cloneDatabase :: Reporter Report -> Track' (Binary "psql") -> Port -> Track' DatabaseName -> Retention -> Clone -> Op
cloneDatabase r psql port mktemplate retention c =
withBinaryStdin psql (psqlBatchRun_Sudo port) PsqlBatch (Text.encodeUtf8 (cloneDatabaseSql c)) $ \create ->
withBinaryStdin psql (psqlBatchRun_Sudo port) PsqlBatch (Text.encodeUtf8 (dropCloneSql c.clone_database)) $ \dropIt ->
op "pg-clone" (deps [run mktemplate c.clone_template]) $ \actions ->
actions
{ ref = mkRef "pg-db" (port, c.clone_database)
, help = Text.unwords ["clone", c.clone_database, "from template", c.clone_template]
, notes = ["copied once: rebuilding the template does not refresh it", retentionNote]
, check = checkClone port c.clone_database
, up = create (contramap (PGCloneDatabase c) r)
, down = case retention of
Retain -> pure ()
Discard -> dropIt (contramap (PGDropClone c.clone_database) r)
}
where
retentionNote = case retention of
Retain -> "down keeps the database"
Discard -> "down drops the database"
-- | A clone whose data outlives a teardown: an open PR's environment.
retainedClone :: Reporter Report -> Track' (Binary "psql") -> Port -> Track' DatabaseName -> Clone -> Op
retainedClone r psql port mktemplate = cloneDatabase r psql port mktemplate Retain
-- | A clone that goes with its teardown: a test fixture, or a PR's environment once merged.
disposableClone :: Reporter Report -> Track' (Binary "psql") -> Port -> Track' DatabaseName -> Clone -> Op
disposableClone r psql port mktemplate = cloneDatabase r psql port mktemplate Discard
{- | Runs one query as the @postgres@ OS user, unaligned and tuples-only.
@Left@ when it could not be asked at all (cluster down, no @psql@), which the
checks above read as 'Unknown' rather than as the effect being absent.
-}
psqlQuery_Sudo :: Port -> Text -> IO (Either Text Text)
psqlQuery_Sudo port = psqlQueryIn_Sudo port "postgres"
-- | 'psqlQuery_Sudo' connected to a named database.
psqlQueryIn_Sudo :: Port -> DatabaseName -> Text -> IO (Either Text Text)
psqlQueryIn_Sudo port db sql = do
(code, out, err) <-
readCreateProcessWithExitCode
(proc "sudo" ["-u", "postgres", "psql", "-p", show port, "-X", "-tA", "-F", "|", "-d", Text.unpack db, "-c", Text.unpack sql])
""
pure $ case code of
ExitSuccess -> Right (Text.decodeUtf8With TextError.lenientDecode out)
ExitFailure _ -> Left (Text.decodeUtf8With TextError.lenientDecode err)
-------------------------------------------------------------------------------
{- | A @CREATE EXTENSION@ in one database.
The tree had no such node before pgvector wanted one; it is here rather than
in "Salmon.Builtin.Nodes.PgVector" because every extension (pg_textsearch,
pg_turret) needs the same three things.
-}
data PgExtension = PgExtension
{ extName :: Text
, extDatabase :: DatabaseName
, extMinServerVersion :: Maybe Int
-- ^ @server_version_num@ floor (@130000@ for PostgreSQL 13). Refused at
-- @up@ with the running version in the message, since a package built
-- for an older server is not something @CREATE EXTENSION@ can explain.
, extUpgrade :: Bool
-- ^ Whether the node also runs @ALTER EXTENSION ... UPDATE@ when the
-- installed version is older than the package's default. Off by
-- default: an extension upgrade can rewrite catalog entries of the
-- indexes built on it, which is an operator's decision, not a side
-- effect of converging.
}
deriving (Eq, Show)
-- | @CREATE EXTENSION IF NOT EXISTS@ (and, if asked, the upgrade), after the version floor.
createExtensionSql :: PgExtension -> Text
createExtensionSql e =
Text.unlines $
maybe [] (\n -> [floorCheck n]) e.extMinServerVersion
<> ["CREATE EXTENSION IF NOT EXISTS " <> quoteIdent e.extName <> ";"]
<> ["ALTER EXTENSION " <> quoteIdent e.extName <> " UPDATE;" | e.extUpgrade]
where
floorCheck n =
"DO "
<> dollarQuote
( "BEGIN IF current_setting('server_version_num')::int < "
<> Text.pack (show n)
<> " THEN RAISE EXCEPTION '%', "
<> quoteLiteral ("refusing to create extension " <> e.extName <> ": it needs server_version_num >= " <> Text.pack (show n) <> ", this server is ")
<> " || current_setting('server_version'); END IF; END"
)
<> ";"
-- | No @CASCADE@: an extension whose types are in use is refused, which is the answer a teardown should hear.
dropExtensionSql :: PgExtension -> Text
dropExtensionSql e = "DROP EXTENSION IF EXISTS " <> quoteIdent e.extName <> ";\n"
-- | Empty when the extension is not installed; otherwise @installed|default@.
inspectExtensionSql :: PgExtension -> Text
inspectExtensionSql e =
"SELECT e.extversion || '|' || coalesce(a.default_version, '') FROM pg_extension e LEFT JOIN pg_available_extensions a ON a.name = e.extname WHERE e.extname = "
<> quoteLiteral e.extName
{- | The verdict from 'inspectExtensionSql''s output. Present is 'Success'
unless 'extUpgrade' is on and the installed version is older than the
package's default, in which case it is a 'Failure' naming both.
-}
interpretExtensionRow :: PgExtension -> Text -> CheckResult
interpretExtensionRow e out =
case Text.lines (Text.strip out) of
[] -> Failure ("extension " <> e.extName <> " is not installed in " <> e.extDatabase)
(row : _) -> case Text.splitOn "|" row of
[installed, available]
| e.extUpgrade
, not (Text.null available)
, versionKey installed < versionKey available ->
Failure ("extension " <> e.extName <> " is at " <> installed <> ", the package has " <> available)
_ -> Success
-- | @"0.8.6"@ as @[0, 8, 6]@; a part that is not a number counts as 0.
versionKey :: Text -> [Int]
versionKey = fmap (\p -> case Text.unpack p of ds | not (null ds), all (`elem` ['0' .. '9']) ds -> read ds; _ -> 0) . Text.splitOn "."
extension :: Reporter Report -> Track' (Binary "psql") -> Port -> Track' DatabaseName -> PgExtension -> Op
extension r psql port mkdb e =
withBinaryStdin psql (psqlBatchIn_Sudo port e.extDatabase) PsqlBatch (Text.encodeUtf8 (createExtensionSql e)) $ \create ->
withBinaryStdin psql (psqlBatchIn_Sudo port e.extDatabase) PsqlBatch (Text.encodeUtf8 (dropExtensionSql e)) $ \dropIt ->
op "pg-extension" (deps [run mkdb e.extDatabase]) $ \actions ->
actions
{ ref = mkRef "pg-extension" (port, e.extDatabase, e.extName)
, help = Text.unwords ["extension", e.extName, "in", e.extDatabase]
, notes =
["upgrades the extension when the package is newer" | e.extUpgrade]
<> ["needs server_version_num >= " <> Text.pack (show n) | Just n <- [e.extMinServerVersion]]
, check = either (const Unknown) (interpretExtensionRow e) <$> psqlQueryIn_Sudo port e.extDatabase (inspectExtensionSql e)
, up = create (contramap (PGExtension e) r)
, down = dropIt (contramap (PGExtension e) r)
}
-------------------------------------------------------------------------------
-- shared_preload_libraries
{- | Something this module refuses or could not do, outside the tracked
commands of "Salmon.Builtin.Nodes.Binary" (whose failures carry their own
type).
-}
newtype PostgresError = PostgresError Text
deriving (Show)
instance Exception PostgresError
{- | The libraries in a @shared_preload_libraries@ value, as PostgreSQL
writes one: comma-separated, each possibly double-quoted. A library whose
quoted name contains a comma is not handled.
-}
parseLibraryList :: Text -> [Text]
parseLibraryList = filter (not . Text.null) . fmap (unquote . Text.strip) . Text.splitOn ","
where
unquote s = fromMaybe s (Text.stripPrefix "\"" s >>= Text.stripSuffix "\"")
-- | Appends, unless it is there already. The others keep their order: it can matter.
addLibrary :: Text -> [Text] -> [Text]
addLibrary lib libs
| lib `elem` libs = libs
| otherwise = libs <> [lib]
removeLibrary :: Text -> [Text] -> [Text]
removeLibrary lib = filter (/= lib)
{- | @ALTER SYSTEM SET@ takes a list, and writes it back as one value. The
reload that follows changes nothing in the running server; it is what makes
the server notice the files and report the setting as @pending_restart@,
which is the question 'restartClusterIfPending' asks.
An empty list is a @RESET@, never @= ''@: PostgreSQL writes that as
@shared_preload_libraries = '""'@, a list of one library with an empty
name, and __does not start again__ (@FATAL: could not access file ""@,
observed on 17). It is what this rendered for an empty list until
@pg_textsearch@'s Layer 2 test restarted a cluster after a teardown. A
@RESET@ drops the entry @ALTER SYSTEM@ holds, so a value in
@postgresql.conf@ itself, if there is one, applies again.
-}
alterPreloadSql :: [Text] -> Text
alterPreloadSql libs =
statement <> ";\nSELECT pg_reload_conf();\n"
where
statement = case libs of
[] -> "ALTER SYSTEM RESET shared_preload_libraries"
_ -> "ALTER SYSTEM SET shared_preload_libraries = " <> Text.intercalate ", " (fmap quoteLiteral libs)
{- | What the configuration files say a setting is, which for a
restart-only setting is not what the running server has: a library another
node added and that is still waiting for its restart is in the files and
nowhere else, and a merge that read the running value would drop it.
Rows with an @error@ are not left out: @pg_file_settings@ marks exactly
those entries (\"setting could not be applied\") once the files are reloaded.
-}
fileSettingSql :: Text -> Text
fileSettingSql name =
"SELECT coalesce((SELECT setting FROM pg_file_settings WHERE name = "
<> quoteLiteral name
<> " ORDER BY seqno DESC LIMIT 1), '')"
{- | Feeds a batch to @psql@ on its standard input, as the @postgres@ OS
user, and throws a 'PostgresError' carrying @psql@'s standard error unless
it exits 0. For nodes that decide in 'IO' what the batch is; a batch known
when the graph is built goes through 'withBinaryStdin'. Not for a batch that
holds a secret: the failure text quotes what @psql@ said.
-}
psqlBatchOrThrow_Sudo :: Port -> Text -> IO ()
psqlBatchOrThrow_Sudo port sql = do
(code, _out, err) <-
readCreateProcessWithExitCode
(Binary.prepare (psqlBatchRun_Sudo port) PsqlBatch)
(Text.encodeUtf8 sql)
case code of
ExitSuccess -> pure ()
ExitFailure n ->
throwIO . PostgresError $
"psql exited "
<> Text.pack (show n)
<> ": "
<> Text.strip (Text.decodeUtf8With TextError.lenientDecode err)
{- | The library is in @shared_preload_libraries@, next to whatever else is.
@ALTER SYSTEM SET shared_preload_libraries@ replaces the whole value, so
this reads the list the files hold and writes it back with one more entry.
That is a read followed by a write: two of these for two libraries need an
edge between them, and a declaration that sets the whole value some other
way (an 'alterSystemSet' of the same parameter has no check and runs every
pass) undoes this one every time.
Going down takes the library out of the list and leaves the others. Neither
direction restarts anything; see 'restartClusterIfPending'.
It was written in the experimental @pg_turret@ module, the first to need
it, and moved here when @pg_textsearch@ needed the same node: the 'Ref', the
help and the notes are the ones it had there.
-}
preloadLibrary :: Track' (Binary "psql") -> Port -> Text -> Op
preloadLibrary psql port lib =
op "pg-preload-library" (deps [justInstall psql]) $ \actions ->
actions
{ ref = mkRef "pg-preload-library" (port, lib)
, help = Text.unwords ["preload", lib, "in the cluster on port", Text.pack (show port)]
, notes = ["takes effect at the next restart of the cluster", "keeps the other entries of shared_preload_libraries"]
, check = either (const Unknown) verdict <$> current
, up = rewrite (addLibrary lib)
, down = rewrite (removeLibrary lib)
}
where
current = fmap parseLibraryList <$> psqlQuery_Sudo port (fileSettingSql "shared_preload_libraries")
verdict libs
| lib `elem` libs = Success
| otherwise = Failure (lib <> " is not in shared_preload_libraries")
rewrite f = do
libs <- either (\err -> throwIO (PostgresError ("cannot read shared_preload_libraries: " <> Text.strip err))) pure =<< current
when (f libs /= libs) $ do
psqlBatchOrThrow_Sudo port (alterPreloadSql (f libs))
awaitReload (20 :: Int)
-- A reload is a signal, and the restart node's check is a new session
-- asking the postmaster a moment later. Waits up to two seconds for the
-- flag, and carries on without it: a list put back to what the running
-- server already has is never pending.
awaitReload n = do
seen <- psqlQuery_Sudo port "SELECT pending_restart FROM pg_settings WHERE name = 'shared_preload_libraries'"
unless (n <= 0 || fmap Text.strip seen == Right "t") $ threadDelay 100000 >> awaitReload (n - 1)