{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- | A primary and a streaming standby on two machines, with the primary's
location declared rather than discovered.
This is the pure half: what the two machines are observed to be, and what to
do next about it. The node that does the observing and the doing comes on
top of these; see @specs\/pg-switchover.md@ for the whole design, and
@specs\/pg-patroni.md@ for the other end of the range, where a consensus
system decides instead of an operator.
= The primary's location is a declaration
'pair_primary' says which side should be the primary. Nothing here decides
that a machine has died: salmon has no consensus, and promoting on a hunch
is how two primaries happen. An operator changes the declaration, and a pass
converges to it -- which is a /switchover/ when both machines are there, and
a failover only when the operator also says, through 'pair_may_discard',
which side's un-replicated writes they accept losing.
= Where the controller runs
Not on a member. The pass reaches both machines over ssh and its steps stop,
restart and rewind them, so a controller on the old primary is killed by
the step that stops it, and one on a member a partition cuts off is cut off
with it -- from the machine it has to decide about. Run it from a third
machine (an admin box, a CI runner). It keeps no state, so which one, and
whether it is always up, does not matter: see below, and S2 in
@specs\/pg-switchover.md@.
= Why the state is re-derived, never remembered
'nextStep' takes what the machines are /now/ and returns one step. Its
caller loops: observe, step, act, observe again. A switchover interrupted
half-way -- the controller killed between stopping the old primary and
promoting the new one -- leaves a state that the next pass recognises and
finishes, because there is no progress file that could disagree with the
machines. That is the property worth protecting when changing this module:
every step must be decidable from an observation alone.
-}
module SreBox.PostgresPair (
-- * Declaring a pair
Side (..),
other,
Member (..),
Pair (..),
Bouncer (..),
RoutedDatabase (..),
routedDatabases,
bouncerProblems,
memberOn,
memberSshHost,
sshLogin,
sshUser,
remoteCommand,
slotNameFor,
-- * How the two machines talk to each other
ConnSecurity (..),
Tls (..),
ServerCheck (..),
ServerFiles (..),
ClientCerts (..),
connSecurity,
hbaLinesFor,
hbaLinesRetired,
securityProblems,
-- * What the machines are
Lsn (..),
parseLsn,
Observed (..),
sysidOf,
probeScript,
parseObserved,
BouncerState (..),
bouncerProbeScript,
parseBouncerState,
parseBouncerStates,
-- * What to do about it
Step (..),
Target (..),
nextStep,
stepCommand,
-- * Doing it
Report (..),
memberScript,
member,
seedMember,
seedScript,
bouncerSetup,
bouncerSetupScript,
pairRole,
pairOp,
verdict,
observe,
decide,
converge,
convergeUpTo,
stepBudget,
-- * For recipes beside this one ("SreBox.PostgresPairPrereqs")
sshToTarget,
) where
import Control.Concurrent (threadDelay)
import Control.Exception (throwIO)
import Data.Aeson (FromJSON, ToJSON)
import Data.List (nub, (\\))
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Encoding.Error as TextError
import GHC.Generics (Generic)
import Numeric (readHex)
import System.Exit (ExitCode (..))
import System.Process.ByteString (readCreateProcessWithExitCode)
import System.Process.ListLike (proc)
import Salmon.Actions.UpDown (CheckResult (..))
import Salmon.Builtin.Extension
import qualified Salmon.Builtin.Nodes.PgBouncer as PgBouncer
import qualified Salmon.Builtin.Nodes.Postgres as Postgres
import Salmon.Op.OpGraph (inject)
import Salmon.Op.Ref (mkRef)
import Salmon.Reporter
-------------------------------------------------------------------------------
-- Declaring a pair
data Side = A | B
deriving (Eq, Show, Generic)
instance FromJSON Side
instance ToJSON Side
other :: Side -> Side
other A = B
other B = A
{- | One machine of the pair.
@member_host@ is how the /peer and the bouncers/ reach it: it is what goes
into @pg_hba.conf@, @primary_conninfo@ and the routing file, and what a
standby reports as its upstream. @member_ssh_user@ and 'memberSshHost' are
how the /controller/ reaches it, and nothing else reads them: on a cloud
network the operator sees a machine on its external address and the peer
sees it on its internal one, and with one field for both the controller has
to live inside that network.
-}
data Member
= Member
{ member_ssh_user :: Text
-- ^ who the controller logs in as. Anything but @root@ must have
-- passwordless sudo: every script is then run under one @sudo -n@
-- (see 'remoteCommand').
, member_host :: Postgres.Host
, member_cluster :: Postgres.ClusterName
, member_port :: Postgres.Port
, member_ssh_identity :: Maybe FilePath
-- ^ a key to authenticate with, for a machine that does not answer to
-- whatever the controller offers by default. Per member rather than per
-- pair: two machines need not have been given the same key.
, member_ssh_host :: Maybe Text
-- ^ where the controller's ssh goes, when that is not 'member_host'.
-- Absent (also from a directive written before this field existed) it is
-- 'member_host'. It appears in no script, no ref and no report: it is
-- the controller's route to the machine, not the machine's name.
}
deriving (Eq, Show, Generic)
instance FromJSON Member
instance ToJSON Member
-- | The address the controller's ssh connects to for this member.
memberSshHost :: Member -> Text
memberSshHost m = fromMaybe m.member_host m.member_ssh_host
{- | One pgbouncer in front of the pair, and everything needed to move
traffic through it without dropping any.
Traffic moves through the /admin console/ -- @PAUSE@, rewrite, @RELOAD@,
@RESUME@ -- because the alternative is restarting pgbouncer, which drops
every client it is holding, which is the thing it was put there to avoid.
The rewrite goes to 'bouncer_routing_path', a file included by the ini and
deliberately not watched by @PgBouncer.setup@ (see that module), so that
moving traffic and owning the service stay separable.
-}
data Bouncer
= Bouncer
{ bouncer_name :: Text
-- ^ what to call it in reports; it identifies nothing else.
, bouncer_ssh_user :: Text
-- ^ as 'member_ssh_user': @root@, or a login with passwordless sudo.
, bouncer_ssh_host :: Text
-- ^ how the /controller/ reaches it, which need not be how clients do.
, bouncer_ssh_identity :: Maybe FilePath
, bouncer_console_user :: Text
-- ^ a user in the bouncer's @admin_users@.
, bouncer_console_port :: Postgres.Port
, bouncer_console_passfile :: FilePath
-- ^ that user's password, in @.pgpass@ format, on the bouncer's machine.
-- A path, never the password: these are shell scripts.
, bouncer_alias :: Text
-- ^ the database clients connect to, whose upstream this pair owns.
, bouncer_dbname :: Text
-- ^ the database it resolves to on whichever member is the primary.
, bouncer_routing_path :: FilePath
, bouncer_config_dir :: FilePath
-- ^ where its @pgbouncer.ini@ lives, and, by @PgBouncer@'s convention,
-- its @userlist.txt@ -- which is /pre-provisioned/, like every other
-- secret this recipe touches. Standing up the bouncer writes the ini and
-- leaves authentication to whoever put that file there.
, bouncer_listen_port :: Postgres.Port
-- ^ what clients connect to, as opposed to 'bouncer_console_port'.
, bouncer_more_databases :: Maybe [RoutedDatabase]
-- ^ the pair's other databases this bouncer routes, beside
-- 'bouncer_alias'. Absent (also from a directive written before this
-- field existed) there are none, and the bouncer routes the one database
-- it always did. Read them all through 'routedDatabases'.
}
deriving (Eq, Show, Generic)
instance FromJSON Bouncer
instance ToJSON Bouncer
{- | One database of the pair as a bouncer's clients see it: the name they
connect to, and the database it resolves to on whichever member is the
primary.
-}
data RoutedDatabase
= RoutedDatabase
{ routed_alias :: Text
, routed_dbname :: Text
}
deriving (Eq, Show, Generic)
instance FromJSON RoutedDatabase
instance ToJSON RoutedDatabase
{- | Every database a bouncer routes, 'bouncer_alias' first.
They live in /one/ routing file and move in /one/ pause, rewrite, reload and
resume, which is the point of declaring them on one bouncer rather than on
several: two @Bouncer@s on one machine would each write the same
@pgbouncer.ini@ and own the same service.
-}
routedDatabases :: Bouncer -> [RoutedDatabase]
routedDatabases b =
RoutedDatabase b.bouncer_alias b.bouncer_dbname : fromMaybe [] b.bouncer_more_databases
{- | Everything wrong with the declared bouncers, not the first thing.
One alias twice in a routing file is one key twice in an ini section: the
bouncer keeps one of them and the probe reads whichever row it kept, so the
declaration could never be observed to hold. And a name that is not a plain
word would be read as something else by the routing file, by the console's
@PAUSE@, or by the shell carrying both -- checked only for the databases
beyond the first, so that a directive written before there could be several
is refused nothing it was not refused before.
-}
bouncerProblems :: Pair -> [Text]
bouncerProblems pair =
concat
[ [ "bouncer " <> b.bouncer_name <> ": the database " <> alias <> " is routed more than once"
| alias <- nub (aliases \\ nub aliases)
]
<> [ "bouncer " <> b.bouncer_name <> ": \"" <> name <> "\" is not a database name made of plain characters"
| d <- fromMaybe [] b.bouncer_more_databases
, name <- [d.routed_alias, d.routed_dbname]
, Text.null name || Text.any (not . plain) name
]
| b <- pair.pair_bouncers
, let aliases = map routed_alias (routedDatabases b)
]
where
plain c = c `elem` ("_-." :: String) || c `elem` ['a' .. 'z'] || c `elem` ['A' .. 'Z'] || c `elem` ['0' .. '9']
data Pair
= Pair
{ pair_name :: Text
, pair_a :: Member
, pair_b :: Member
, pair_primary :: Side
-- ^ where the primary should be. An operator's declaration, not an observation.
, pair_repl_role :: Postgres.RoleName
-- ^ the @REPLICATION@ role a rejoined member streams as.
, pair_repl_passfile :: FilePath
-- ^ that role's password, in @.pgpass@ format, on each member: it goes
-- into @primary_conninfo@ as @passfile=@, which is how a standby
-- authenticates without the password being written into a config file.
, pair_rewind_role :: Postgres.RoleName
-- ^ the role @pg_rewind@ connects as when an old primary rejoins. Not
-- the replication role: rewind reads files through ordinary function
-- calls, so it needs a plain login with @EXECUTE@ on @pg_ls_dir@,
-- @pg_stat_file@ and the two @pg_read_binary_file@s.
, pair_rewind_passfile :: FilePath
-- ^ that role's password, in @.pgpass@ format, on each member. A path,
-- never the password: these commands are shell scripts, and a script is
-- visible in @ps@ and printed by every report. (@.pgpass@ here, unlike
-- 'Postgres.standby_repl_passfile''s bare password, because
-- @primary_conninfo@ can only take this form.)
, pair_ssh_known_hosts :: Maybe FilePath
, pair_catch_up_seconds :: Int
-- ^ how long a standby may take to replay the old primary's last
-- checkpoint before the switchover gives up and says so.
, pair_seed :: Maybe Side
-- ^ "this side is to be built from the other one" -- the first clone of
-- a pair's life, and the only way back from a standby that has fallen
-- too far behind to catch up (@specs\/pg-switchover.md@ S6).
--
-- Declared rather than inferred, because it is a decision about losing
-- whatever is on that machine, which is the same class of decision as
-- 'pair_may_discard'. Safe to leave declared: the clone refuses a data
-- directory holding a cluster it does not recognise, and does nothing at
-- all once the two sides share a system identifier.
, pair_bouncers :: [Bouncer]
-- ^ the bouncers whose clients follow the declared primary. Empty is a
-- pair nothing routes through: the two bouncer steps then cannot arise,
-- since there is nobody holding a client to hold up a pass.
, pair_may_discard :: Maybe Side
-- ^ "I accept losing writes on this side that the other does not have".
--
-- The one escape hatch, and its name is what it costs. It covers the two
-- cases salmon cannot judge for itself: promoting although the other
-- machine cannot be confirmed stopped (a failover), and rewinding one of
-- two primaries onto the other's history (a split brain). It must name
-- the side that is /not/ 'pair_primary'; a directive saying otherwise is
-- contradictory and is rejected where it is built.
, pair_reseed :: Maybe Side
-- ^ "this side's data may be thrown away and rebuilt from the other".
--
-- The re-seeding half of @specs\/pg-switchover.md@ S6: a standby whose
-- slot on the primary is @lost@ can never catch up, the pair reports
-- that and does nothing (the wipe is a decision about a machine's data,
-- not a step), and this is the operator making that decision. It is a
-- declaration in the same class as 'pair_may_discard' and, like it,
-- names a side: the one that is /not/ 'pair_primary' (naming the
-- primary does nothing).
--
-- Safe to leave declared, more so than 'pair_may_discard': it acts only
-- on the one diagnosed condition, the named side's slot being lost, and
-- a pair that is healthy, or merely lagging, never has anything wiped.
-- 'pair_seed' cannot do this job -- it is the /first/ clone, and its
-- guard leaves a data directory of the primary's own cluster alone.
, pair_conn_security :: Maybe ConnSecurity
-- ^ what the replication and rewind connections between the two members
-- must be: see 'ConnSecurity'. Absent (also from a directive written
-- before this field existed) it is 'PlainMd5', which is what every pair
-- was before there was a choice; read it through 'connSecurity'.
}
deriving (Eq, Show, Generic)
instance FromJSON Pair
instance ToJSON Pair
{- | What the connections one member makes to the other -- streaming
replication, @pg_basebackup@, @pg_rewind@, the slot bookkeeping -- must be.
Three choices, weakest first, and the weakest is the one with the plain
name: it is what an absent 'pair_conn_security' means, because that is what
every pair deployed before this type existed is, and a recipe that tightened
@pg_hba.conf@ under a running pair on upgrade would be a recipe that broke
replication on upgrade.
['PlainMd5'] @host ... md5@. TLS is not required by either end (libpq's
default @sslmode=prefer@ will use it if the server offers it, and will not
mind if somebody in the middle says it does not), and @md5@ accepts a
password stored either way. For a network nobody else is on.
['TlsScram'] @hostssl ... scram-sha-256@. The server refuses a connection
that is not TLS, the client refuses one too (@sslmode=require@ or stricter,
see 'ServerCheck'), and the password is only ever proven, never sent. The
roles' passwords are re-stored as SCRAM verifiers on the way.
['TlsClientCert'] @hostssl ... cert@. As above for the transport, and the
/client/ is authenticated by a certificate whose @CN@ is the role's name --
what "SreBox.PostgresTls" sets up for application clients, here for the two
roles the pair itself connects as. The passfiles are still read (the roles
are still given their passwords), but no line this recipe writes accepts one.
Every file named in here is __pre-provisioned on both members, at the same
path__: this recipe does not issue certificates and does not move them, for
the same reason it does not move passwords.
-}
data ConnSecurity
= PlainMd5
| TlsScram Tls
| TlsClientCert Tls ClientCerts
deriving (Eq, Show, Generic)
instance FromJSON ConnSecurity
instance ToJSON ConnSecurity
-- | The transport half of a TLS choice: both ends of it.
data Tls
= Tls
{ tls_check :: ServerCheck
-- ^ how hard a connecting member checks the one it connects to.
, tls_server :: Maybe ServerFiles
-- ^ what each member serves TLS with. 'Nothing' leaves the cluster's
-- TLS settings as they were found -- Debian's clusters are created with
-- @ssl = on@ and a self-signed certificate, which is enough for
-- 'Encrypted' and for nothing stricter. Either way the member node
-- refuses to write a @hostssl@ line on a cluster that is not serving
-- TLS, since such a line matches nothing.
}
deriving (Eq, Show, Generic)
instance FromJSON Tls
instance ToJSON Tls
{- | What the connecting side demands of the server's certificate.
'Encrypted' is @sslmode=require@: the connection is encrypted and that is
all -- whoever answers at the peer's address is believed, so it keeps out an
eavesdropper and not somebody who can redirect the connection. The other two
name a CA certificate (on each member) and are @verify-ca@ and
@verify-full@; the last also wants the certificate to name 'member_host',
which for members declared by address means a certificate with that address
among its subject alternative names.
-}
data ServerCheck
= Encrypted
| VerifyCa FilePath
| VerifyFull FilePath
deriving (Eq, Show, Generic)
instance FromJSON ServerCheck
instance ToJSON ServerCheck
{- | A member's own certificate and key, and the CA it accepts client
certificates from. The paths are the same on both members; the files are
not (each member's certificate is its own). The key must be readable by
@postgres@ and by nobody else, or the cluster does not load it.
-}
data ServerFiles
= ServerFiles
{ server_cert :: FilePath
, server_key :: FilePath
, server_client_ca :: Maybe FilePath
-- ^ @ssl_ca_file@. Needed by 'TlsClientCert' (set here, or already set
-- on the cluster); left as found when absent.
}
deriving (Eq, Show, Generic)
instance FromJSON ServerFiles
instance ToJSON ServerFiles
{- | The certificates the pair's two roles present, on each member (either
may be the one connecting). Each certificate's @CN@ must be the role's name:
that equality is the whole authentication. Keys are read by @postgres@ (the
standby's own connection, @pg_rewind@) and by root (the first clone), and
libpq refuses one that group or others can read.
-}
data ClientCerts
= ClientCerts
{ client_repl_cert :: FilePath
, client_repl_key :: FilePath
, client_rewind_cert :: FilePath
, client_rewind_key :: FilePath
}
deriving (Eq, Show, Generic)
instance FromJSON ClientCerts
instance ToJSON ClientCerts
-- | The pair's choice, with the absent one spelled out.
connSecurity :: Pair -> ConnSecurity
connSecurity = fromMaybe PlainMd5 . pair_conn_security
{- | The two @pg_hba.conf@ lines a member needs for a choice: the peer's
replication connection, and the peer's rewind connection.
-}
hbaLinesFor :: Pair -> Side -> ConnSecurity -> [Text]
hbaLinesFor pair side sec = hbaShape pair side (shapeOf sec)
{- | The lines the /other/ choices would have written on this member, which
a member removes before it adds its own.
@pg_hba.conf@ is read top to bottom and the first line that matches decides,
and @host@ matches a TLS connection as well as a plain one: left in place,
the @host ... md5@ line of a pair that was 'PlainMd5' yesterday sits above
the @hostssl@ line appended today and goes on accepting everything it ever
did. So this one recipe, whose lines are otherwise append-if-missing,
removes -- exactly these lines, compared whole, and nothing else in the file.
-}
hbaLinesRetired :: Pair -> Side -> ConnSecurity -> [Text]
hbaLinesRetired pair side sec =
concat [hbaShape pair side shape | shape <- hbaShapes, shape /= shapeOf sec]
hbaShapes :: [(Text, Text)]
hbaShapes = [("host", "md5"), ("hostssl", "scram-sha-256"), ("hostssl", "cert")]
shapeOf :: ConnSecurity -> (Text, Text)
shapeOf PlainMd5 = ("host", "md5")
shapeOf (TlsScram _) = ("hostssl", "scram-sha-256")
shapeOf (TlsClientCert _ _) = ("hostssl", "cert")
hbaShape :: Pair -> Side -> (Text, Text) -> [Text]
hbaShape pair side (kind, method) =
[ Text.unwords [kind, "replication", pair.pair_repl_role, peer.member_host <> "/32", method]
, Text.unwords [kind, "all", pair.pair_rewind_role, peer.member_host <> "/32", method]
]
where
peer = memberOn pair (other side)
{- | Everything wrong with the declared choice, not the first thing.
The paths end up inside a libpq connection string, inside a line of
@postgresql.auto.conf@, inside a shell script: a path that is not a plain
word would be read as something else by one of the three.
-}
securityProblems :: Pair -> [Text]
securityProblems pair = case connSecurity pair of
PlainMd5 -> []
TlsScram tls -> tlsProblems tls
TlsClientCert tls cc ->
tlsProblems tls
<> path "replication client certificate" cc.client_repl_cert
<> path "replication client key" cc.client_repl_key
<> path "rewind client certificate" cc.client_rewind_cert
<> path "rewind client key" cc.client_rewind_key
where
tlsProblems :: Tls -> [Text]
tlsProblems tls =
( case tls.tls_check of
Encrypted -> []
VerifyCa ca -> path "CA certificate" ca
VerifyFull ca -> path "CA certificate" ca
)
<> foldMap
( \(sf :: ServerFiles) ->
path "server certificate" sf.server_cert
<> path "server key" sf.server_key
<> foldMap (path "client CA certificate") sf.server_client_ca
)
tls.tls_server
path :: Text -> FilePath -> [Text]
path what p =
[ what <> ": \"" <> Text.pack p <> "\" is not an absolute path made of plain characters"
| not (take 1 p == "/" && all plain p)
]
plain c = c `notElem` (" \t\n\r'\"\\$`" :: String)
data ConnAs = AsReplication | AsRewind
{- | What a connection string gains from the choice. Nothing at all for
'PlainMd5', so that pair's scripts are what they always were.
-}
sslParams :: Pair -> ConnAs -> [String]
sslParams pair who = case connSecurity pair of
PlainMd5 -> []
TlsScram tls -> check tls.tls_check
TlsClientCert tls cc -> check tls.tls_check <> certs cc
where
check Encrypted = ["sslmode=require"]
check (VerifyCa ca) = ["sslmode=verify-ca", "sslrootcert=" <> ca]
check (VerifyFull ca) = ["sslmode=verify-full", "sslrootcert=" <> ca]
certs :: ClientCerts -> [String]
certs cc = case who of
AsReplication -> ["sslcert=" <> cc.client_repl_cert, "sslkey=" <> cc.client_repl_key]
AsRewind -> ["sslcert=" <> cc.client_rewind_cert, "sslkey=" <> cc.client_rewind_key]
{- | The same, as environment, for the one command here that builds its own
connection: 'Postgres.cloneFromPrimaryScript', whose @pg_basebackup@ and
identity query take a host and a user rather than a string. libpq reads
these wherever a connection string says nothing, and every other connection
in these scripts says it in the string.
-}
sslEnvironment :: Pair -> [String]
sslEnvironment pair =
[ "export " <> var <> "=" <> shQuote (drop 1 value)
| param <- sslParams pair AsReplication
, let (key, value) = break (== '=') param
, Just var <- [lookup key [("sslmode", "PGSSLMODE"), ("sslrootcert", "PGSSLROOTCERT"), ("sslcert", "PGSSLCERT"), ("sslkey", "PGSSLKEY")]]
]
memberOn :: Pair -> Side -> Member
memberOn pair A = pair.pair_a
memberOn pair B = pair.pair_b
{- | The physical replication slot a member streams with, which lives on the
/other/ member.
One per side rather than one per pair, because both of them are somebody's
standby eventually and a slot is named on the machine that holds it. The name
is derived rather than declared so that nothing has to remember it across a
switchover: a member that rejoins computes the same name the member it
rejoins would, and a slot nobody can name is a slot nobody can drop.
Postgres allows a slot name of at most 63 lower-case letters, digits and
underscores, so anything else in the pair's name becomes an underscore.
-}
slotNameFor :: Pair -> Side -> Text
slotNameFor pair side =
Text.take 63 ("salmon_pair_" <> Text.map keep (Text.toLower pair.pair_name) <> side')
where
side' = case side of A -> "_a"; B -> "_b"
keep c
| c >= 'a' && c <= 'z' = c
| c >= '0' && c <= '9' = c
| otherwise = '_'
-------------------------------------------------------------------------------
-- What the machines are
{- | A write-ahead log position, as Postgres prints it (@0\/3000028@), kept
as the number it stands for so that two of them can be compared.
-}
newtype Lsn = Lsn Integer
deriving (Eq, Ord, Show, Generic)
instance FromJSON Lsn
instance ToJSON Lsn
parseLsn :: Text -> Maybe Lsn
parseLsn txt =
case Text.splitOn "/" (Text.strip txt) of
[hi, lo] -> Lsn <$> ((\h l -> h * 0x100000000 + l) <$> hex hi <*> hex lo)
_ -> Nothing
where
hex :: Text -> Maybe Integer
hex t = case readHex (Text.unpack t) of
[(n, "")] -> Just n
_ -> Nothing
{- | What one machine turned out to be.
'Unreachable' is deliberately one constructor for "ssh could not get there"
and "what came back made no sense": both mean the same thing to 'nextStep',
which is that this machine's state is not known, and neither is a reason to
touch the other one.
-}
data Observed
= Unreachable Text
| -- | no such cluster on that machine at all
Absent
| Stopped
{ o_sysid :: Text
, o_timeline :: Int
, o_checkpoint :: Lsn
-- ^ the furthest position @pg_controldata@ can prove this cluster
-- reached: its latest checkpoint, or its minimum recovery point if
-- that is further (which it is for a standby that was stopped).
, o_clean :: Bool
-- ^ whether it stopped cleanly, from @pg_controldata@'s cluster
-- state. This is what says whether 'o_checkpoint' is the whole
-- story: a cluster shut down cleanly ends with a checkpoint, so
-- there is no WAL after it, while a crashed one may have written
-- any amount past its last checkpoint and pg_control says nothing
-- about it.
}
| Primary
{ o_sysid :: Text
, o_timeline :: Int
, o_lsn :: Lsn
, o_slots :: [(Text, Text)]
-- ^ the replication slots this machine holds, and what each one's
-- WAL is worth (@pg_replication_slots.wal_status@). Only a primary
-- is asked, because only a primary holds the slot its standby
-- streams with -- and @lost@ on that slot is the one observation
-- that says a standby can never catch up again.
}
| Standby
{ o_sysid :: Text
, o_timeline :: Int
, o_upstream :: Maybe Postgres.Host
-- ^ where it /is/ streaming from, which is empty the moment the
-- connection drops.
, o_configured :: Maybe Postgres.Host
-- ^ where it is /told/ to stream from, from @primary_conninfo@. A
-- standby keeps this through a partition, which is what makes "it
-- cannot reach its primary right now" distinguishable from "it was
-- never pointed here at all" -- states that look identical in
-- 'o_upstream' and call for opposite actions.
, o_received :: Lsn
-- ^ the furthest position it holds: what it received, or what it
-- replayed from its own WAL if it has received nothing since it
-- started.
, o_replayed :: Lsn
}
deriving (Eq, Show)
-- | The system identifier, for the machines that have one.
sysidOf :: Observed -> Maybe Text
sysidOf (Stopped s _ _ _) = Just s
sysidOf (Primary s _ _ _) = Just s
sysidOf (Standby s _ _ _ _ _) = Just s
sysidOf _ = Nothing
{- | What to run on a member to produce what 'parseObserved' reads: one
@key=value@ per line.
A running cluster is asked; a stopped one is read off @pg_controldata@,
which needs no server. The two paths report different keys on purpose --
there is no "current LSN" for a cluster that is not running, and inventing
one would be inventing the very fact a switchover turns on.
-}
probeScript :: Member -> String
probeScript m =
unlines
[ "set -e"
, "version=$(pg_lsclusters --no-header | awk -v c=" <> shellQuote cluster <> " '$2==c {print $1}' | head -n1)"
, "if [ -z \"$version\" ]; then echo status=absent; exit 0; fi"
, "datadir=/var/lib/postgresql/$version/" <> cluster
, "pg_controldata=/usr/lib/postgresql/$version/bin/pg_controldata"
, "[ -x \"$pg_controldata\" ] || pg_controldata=pg_controldata"
, "if pg_ctlcluster \"$version\" " <> cluster <> " status >/dev/null 2>&1; then"
, " echo status=running"
, " sudo -u postgres psql -p " <> show m.member_port <> " -tAX -d postgres -c " <> shellQuote runningQuery
, "else"
, " echo status=stopped"
, " \"$pg_controldata\" -D \"$datadir\" " <> controldataFilter
, "fi"
]
where
cluster = Text.unpack m.member_cluster
runningQuery =
unwords
[ "SELECT 'sysid=' || system_identifier FROM pg_control_system();"
, "SELECT 'timeline=' || timeline_id FROM pg_control_checkpoint();"
, "SELECT 'in_recovery=' || CASE WHEN pg_is_in_recovery() THEN 't' ELSE 'f' END;"
, -- a standby that has just restarted and cannot reach its
-- primary -- which is the failover case, and so exactly when
-- this has to work -- has received nothing in this session, and
-- pg_last_wal_receive_lsn() is then NULL rather than the
-- position it crash-recovered to. Asking for the furthest of
-- the two is the same answer whenever both exist, since a
-- standby cannot replay what it has not received.
"SELECT 'lsn=' || CASE WHEN pg_is_in_recovery()"
<> " THEN GREATEST(coalesce(pg_last_wal_receive_lsn(), '0/0'::pg_lsn), coalesce(pg_last_wal_replay_lsn(), '0/0'::pg_lsn))"
<> " ELSE pg_current_wal_lsn() END;"
, "SELECT 'replayed=' || coalesce(pg_last_wal_replay_lsn()::text, '');"
, "SELECT 'upstream=' || coalesce((SELECT sender_host FROM pg_stat_wal_receiver LIMIT 1), '');"
, -- where it is *told* to stream from, which survives the
-- connection dropping. Read from pg_settings rather than SHOW
-- so that a primary, which has no such setting, reports an
-- empty value rather than failing the whole probe.
"SELECT 'configured=' || coalesce((SELECT substring(setting from 'host=([^ ]+)') FROM pg_settings WHERE name = 'primary_conninfo'), '');"
, "SELECT 'slot=' || slot_name || ':' || coalesce(wal_status, '') FROM pg_replication_slots;"
]
controldataFilter =
unwords
[ "| sed -n"
, "-e 's/^Database system identifier: *\\(.*\\)$/sysid=\\1/p'"
, "-e 's/^Database cluster state: *\\(.*\\)$/state=\\1/p'"
, "-e 's/^Latest checkpoint location: *\\(.*\\)$/checkpoint=\\1/p'"
, "-e \"s/^Latest checkpoint's TimeLineID: *\\(.*\\)$/timeline=\\1/p\""
, -- 0/0 on a primary; on a standby that was stopped, this is how
-- far it actually replayed, which is past its last checkpoint.
"-e 's/^Minimum recovery ending location: *\\(.*\\)$/min_recovery=\\1/p'"
]
shellQuote :: String -> String
shellQuote s = "'" <> concatMap (\c -> if c == '\'' then "'\\''" else [c]) s <> "'"
-- | Reads 'probeScript''s output. Anything missing or malformed is 'Unreachable'.
parseObserved :: Text -> Observed
parseObserved out =
case field "status" of
Just "absent" -> Absent
Just "stopped" -> stopped
Just "running" -> running
_ -> Unreachable "the probe reported no status"
where
fields :: [(Text, Text)]
fields = [(k, Text.drop 1 v) | l <- Text.lines out, let (k, v) = Text.breakOn "=" (Text.strip l), not (Text.null v)]
field :: Text -> Maybe Text
field k = lookup k fields
lsn :: Text -> Maybe Lsn
lsn k = field k >>= parseLsn
timeline :: Maybe Int
timeline = field "timeline" >>= \t -> case reads (Text.unpack t) of
[(n, "")] -> Just n
_ -> Nothing
stopped = case (field "sysid", timeline, lsn "checkpoint") of
(Just s, Just tl, Just cp) -> Stopped s tl (max cp (fromMaybe cp (lsn "min_recovery"))) cleanly
_ -> Unreachable "a stopped cluster reported no control data"
-- pg_controldata's cluster state, of which exactly two values mean the
-- cluster was stopped rather than lost: a primary shut down, and a
-- standby shut down while in recovery. "in production" on a cluster that
-- is not running is what a crash reads as, and an unrecognised value is
-- treated the same way -- the direction that refuses rather than the one
-- that promotes.
cleanly = field "state" `elem` [Just "shut down", Just "shut down in recovery"]
running = case (field "sysid", timeline, field "in_recovery") of
(Just s, Just tl, Just "f") -> case lsn "lsn" of
Just l -> Primary s tl l slots
Nothing -> Unreachable "a primary reported no write position"
(Just s, Just tl, Just "t") -> case lsn "lsn" of
Just recv -> Standby s tl upstream configured recv (fromMaybe recv (lsn "replayed"))
Nothing -> Unreachable "a standby reported no receive position"
_ -> Unreachable "a running cluster reported no identity"
upstream = host "upstream"
configured = host "configured"
-- one line per slot, so this is the one field that is a list
slots = [(Text.takeWhile (/= ':') v, Text.drop 1 (Text.dropWhile (/= ':') v)) | (k, v) <- fields, k == "slot"]
host k = case field k of
Just u | not (Text.null u) -> Just u
_ -> Nothing
{- | A bouncer as it was found: which member it sends clients to, and
whether it is holding them rather than passing them on.
It carries no name because nothing needs one -- 'nextStep' reads these as a
set, and the declaration says which bouncer each came from.
-}
data BouncerState
= BouncerState
{ bouncer_upstream :: Maybe Postgres.Host
, bouncer_paused :: Bool
}
deriving (Eq, Show)
{- | What to run on a bouncer to find that out. Asked with the header, so
that the columns are read by name: @SHOW DATABASES@ has grown columns
between pgbouncer versions, and counting them is a way to read the wrong one.
-}
bouncerProbeScript :: Bouncer -> String
bouncerProbeScript b = consoleCommand b "-AX" "SHOW DATABASES"
{- | Reads 'bouncerProbeScript''s output: one state per database the bouncer
routes, in 'routedDatabases'' order.
One per /database/ rather than one per bouncer, because 'nextStep' reads
these as a set and asks the same two things of each -- is it held, is it
pointed at the primary -- and a bouncer summed up as one state has to lie
about one of them whenever its databases disagree: a bouncer with one alias
moved and one left behind is neither at the primary nor at the peer, and one
with a single alias still paused is an outage for that alias's clients.
Every alias has to agree before a pair has arrived.
-}
parseBouncerStates :: Bouncer -> Text -> [BouncerState]
parseBouncerStates b out = [parseDatabaseState d.routed_alias out | d <- routedDatabases b]
-- | 'parseBouncerStates' for 'bouncer_alias' alone.
parseBouncerState :: Bouncer -> Text -> BouncerState
parseBouncerState b = parseDatabaseState b.bouncer_alias
parseDatabaseState :: Text -> Text -> BouncerState
parseDatabaseState alias out =
case (header, row) of
(Just hs, Just r) ->
BouncerState
(column hs r "host" >>= nonEmpty)
(column hs r "paused" == Just "1")
_ -> BouncerState Nothing False
where
rows = map (Text.splitOn "|") (Text.lines out)
header = case filter (elem "name") rows of
(h : _) -> Just h
_ -> Nothing
row = do
hs <- header
i <- lookupIndex hs "name"
case [r | r <- rows, atIndex r i == Just alias] of
(r : _) -> Just r
_ -> Nothing
column hs r name = lookupIndex hs name >>= atIndex r
lookupIndex xs x = lookup x (zip xs [0 ..])
atIndex xs i = case drop i xs of
(v : _) -> Just (Text.strip v)
_ -> Nothing
nonEmpty t = if Text.null t then Nothing else Just t
{- | @psql@ against a bouncer's admin console, which is an ordinary
connection to the database named @pgbouncer@ as a user the bouncer lists in
@admin_users@.
-}
consoleCommand :: Bouncer -> String -> String -> String
consoleCommand b flags sql =
unwords
[ "PGPASSFILE=" <> shQuote b.bouncer_console_passfile
, "psql"
, "-h"
, "127.0.0.1"
, "-p"
, show b.bouncer_console_port
, "-U"
, Text.unpack b.bouncer_console_user
, "-d"
, "pgbouncer"
, flags
, "-c"
, shQuote sql
]
-------------------------------------------------------------------------------
-- What to do about it
data Step
= -- | the declaration holds and the pair is redundant
Done
| -- | the declaration holds, but the pair is one machine short
Degraded Text
| PauseBouncers
| -- | a clean, fast shutdown, so the standby gets the final checkpoint
StopMember Side
| -- | this side must have received past that position before it is promoted
AwaitCatchUp Side Lsn
| -- | this side is pointed at the primary but is not streaming from it yet
AwaitStreaming Side
| Promote Side
| -- | @pg_rewind@ onto the primary's history, then start, as a standby
Rejoin Side
| StartMember Side
| -- | throw this side's data away and clone it again from the primary,
-- because its slot is lost and the operator has said it may be
Reseed Side
| -- | rewrite each bouncer's upstream, reload, and let clients go
RepointBouncers Side
| -- | nothing safe to do from here; the text says why
Refuse Text
deriving (Eq, Show)
{- | The one step to take next, given both machines and the bouncers.
Read in order, first match wins. Two rules run before everything else
because they are about whether this is even the pair it claims to be, and
whether anybody is being served at all.
-}
nextStep :: Pair -> Observed -> Observed -> [BouncerState] -> Step
nextStep pair obsA obsB bouncers
| mismatchedCluster = Refuse "the two machines hold different clusters"
| otherwise = case (p, q) of
-- The declared primary is the primary. Everything from here is about
-- the peer, and about where clients are being sent.
(Primary{}, _) | not bouncersReady -> RepointBouncers primarySide
(Primary{}, Standby _ _ up conf _ _)
-- the peer must be streaming from the primary, which is the
-- *other* machine's address: a standby pointed anywhere else is
-- not part of this pair, however healthy it looks.
| up == Just primary.member_host -> Done
-- pointed here, but not connected: a partition, a primary that
-- has just been promoted and not yet been found, a standby still
-- starting up. Rewinding a standby that is already this pair's
-- would stop it and then fail, since whatever keeps it from
-- streaming keeps pg_rewind from reading too -- a partition would
-- take the standby down rather than ride it out.
-- ... unless the primary's own slot for it says the waiting is
-- over: a lost slot is WAL that has been recycled, so there is
-- nothing left for this standby to stream and no amount of
-- patience produces it.
| reseeding -> Reseed peerSide
| peerSlotLost -> Degraded lostSlotWhy
| conf == Just primary.member_host -> AwaitStreaming peerSide
| otherwise -> Rejoin peerSide
(Primary{}, Stopped{})
-- the same, one state earlier: rewinding a member whose slot is
-- lost succeeds and changes nothing, since what it then needs to
-- replay is gone. Re-seeding is the only way back, and it is an
-- operator's decision, not a step.
| reseeding -> Reseed peerSide
| peerSlotLost -> Degraded lostSlotWhy
| otherwise -> Rejoin peerSide
-- the two below are also what a re-seed looks like half-way through:
-- the data directory gone, the slot (dropped only after the clone) not
-- yet. Declared and still lost is enough to say "carry on".
(Primary{}, Absent)
| reseeding -> Reseed peerSide
| otherwise -> Degraded "the peer has no cluster: seed it before it can stream"
(Primary{}, Unreachable why)
| reseeding -> Reseed peerSide
| otherwise -> Degraded ("the peer is unreachable: " <> why)
(Primary{}, Primary{})
| discardable peerSide -> StopMember peerSide
| otherwise -> Refuse "both machines are primaries; say which side's writes may be discarded"
-- The declared primary is a standby: this is the switchover, and what
-- it costs depends on what the peer is doing.
(Standby _ _ up _ _ _, Primary{})
-- stopping the peer is safe only once the declared primary is
-- streaming from it, because a clean stop hands the tail over
-- through that connection and there is otherwise nothing to hand
-- it over. Declared during a partition, the old rule stopped the
-- primary and stranded every record the standby had not got --
-- an outage produced out of a healthy pair by a declaration.
| up /= Just peer.member_host -> AwaitStreaming primarySide
| any (not . bouncer_paused) bouncers -> PauseBouncers
| otherwise -> StopMember peerSide
(Standby _ _ up _ recv _, Stopped _ _ checkpoint clean)
-- the operator has already said what may be lost, so nothing
-- below can tell them anything they have not accepted.
| discardable peerSide -> Promote primarySide
-- a crashed peer proves nothing past its last checkpoint: it may
-- have written and acknowledged any amount of WAL after it, and
-- pg_control does not say. Comparing against the checkpoint would
-- read as "the standby has everything" precisely when it is least
-- likely to be true.
| not clean ->
Refuse
"the peer did not stop cleanly, so what it wrote after its last checkpoint is unknown; say whether its writes may be discarded"
| recv >= checkpoint -> Promote primarySide
-- the tail is only ever in flight while the connection is up.
-- Once it is gone and the peer is stopped, nothing will arrive
-- however long anybody waits, and the way to converge without
-- losing those records is to start the machine that has them:
-- the standby catches up from it, and the ordinary switchover
-- takes it from there.
| up /= Just peer.member_host -> StartMember peerSide
| otherwise -> AwaitCatchUp primarySide checkpoint
(Standby{}, Absent) -> Promote primarySide
(Standby _ _ _ _ recv _, Standby _ _ _ _ peerRecv _)
| recv >= peerRecv -> Promote primarySide
| otherwise -> Refuse "the peer standby is ahead of the declared primary"
(Standby{}, Unreachable why)
| not (discardable peerSide) ->
Refuse ("cannot confirm the peer has stopped (" <> why <> "); say whether its writes may be discarded")
| any (not . bouncer_paused) bouncers -> PauseBouncers
| otherwise -> Promote primarySide
-- The declared primary is not running: nothing can be decided until it is.
(Stopped{}, _) -> StartMember primarySide
(Absent, _) -> Refuse "the declared primary has no cluster"
(Unreachable why, _) -> Refuse ("the declared primary is unreachable: " <> why)
where
primarySide = pair.pair_primary
peerSide = other primarySide
peer = memberOn pair peerSide
primary = memberOn pair primarySide
(p, q) = case primarySide of
A -> (obsA, obsB)
B -> (obsB, obsA)
mismatchedCluster = case (sysidOf p, sysidOf q) of
(Just x, Just y) -> x /= y
_ -> False
discardable side = pair.pair_may_discard == Just side
-- the slot the peer streams with lives on the declared primary, which is
-- the only machine that can say what has become of it.
peerSlotLost = case p of
Primary _ _ _ slots -> lookup (slotNameFor pair peerSide) slots == Just "lost"
_ -> False
-- the operator has said this machine may be rebuilt, and the primary says
-- the standby it has is beyond catching up: both, or nothing.
reseeding = peerSlotLost && pair.pair_reseed == Just peerSide
lostSlotWhy =
"the peer's replication slot ("
<> slotNameFor pair peerSide
<> ") is lost: it fell further behind than the slot budget allows, so the WAL it needs is gone and only a re-seed brings it back; declare that machine "
<> Text.pack (show peerSide)
<> " in pair_reseed if its data may be thrown away"
-- every bouncer sending clients to the declared primary, and none of
-- them holding those clients: a bouncer left paused is an outage, so it
-- is not a state any pass may call finished.
bouncersReady =
all
(\b -> not b.bouncer_paused && b.bouncer_upstream == Just primary.member_host)
bouncers
-------------------------------------------------------------------------------
-- Doing it
-- | Where a step's command runs.
data Target
= OnMember Member
| OnBouncer Bouncer
deriving (Eq, Show)
{- | The commands a step runs, and where.
Pure, so that what a switchover actually does to a machine is readable and
testable without one. 'Left' is a step that runs nowhere: 'Done' and
'Degraded' are arrivals, 'Refuse' is a stop, and the two @Await@s are waits.
A list rather than one command, because the bouncer steps address every
bouncer there is; the member steps address exactly one machine and return a
single-element list. An empty list is a step with nothing to do, which is
what the bouncer steps become when no bouncer is declared -- though
'nextStep' does not reach them then either.
-}
stepCommand :: Pair -> Step -> Either Text [(Target, String)]
stepCommand pair = go
where
onMember side script = Right [(OnMember (on side), script)]
onBouncers script = Right [(OnBouncer b, script b) | b <- pair.pair_bouncers]
go (StopMember side) = onMember side (stopScript side)
go (StartMember side) =
onMember side (pgctl side "status >/dev/null 2>&1 || " <> unwords ["pg_ctlcluster", "\"$version\"", cluster side, "start"])
go (Promote side) =
onMember side (psql side "SELECT CASE WHEN pg_promote(true, 60) THEN 'promoted' ELSE 'promotion timed out' END")
go (Rejoin side) = onMember side (rejoinScript side)
go (Reseed side) = onMember side (reseedScript pair side)
go Done = Left "nothing to do"
go (Degraded why) = Left why
go (Refuse why) = Left why
go (AwaitCatchUp _ _) = Left "waiting for the standby to catch up"
go (AwaitStreaming _) = Left "waiting for the standby to start streaming"
go PauseBouncers = onBouncers pauseScript
go (RepointBouncers side) = onBouncers (repointScript side)
on = memberOn pair
cluster side = Text.unpack (on side).member_cluster
port side = show (on side).member_port
{- Fast, not immediate: a clean shutdown sends the standby everything it
has not got, including the shutdown checkpoint, which is the record the
promotion waits for.
What that clean shutdown also does is checkpoint, and a checkpoint
recycles the WAL before it -- which is the WAL a rewind of this member
would need, read back to the last checkpoint the two machines share. In
an ordinary switchover that is the shutdown checkpoint itself and nothing
older is wanted; after a split brain the histories parted much earlier,
and stopping the loser is what destroys the record of how. Pinning what
pg_wal already holds costs nothing, since it is on the disk either way,
and the rejoin takes the pin off again. -}
stopScript side =
unlines
[ "set -e"
, versionOf side
, "datadir=/var/lib/postgresql/$version/" <> cluster side
, "keep=$(du -sm \"$datadir/pg_wal\" | awk '{print $1 + 1}')"
, "sudo -u postgres psql -p " <> port side <> " -tAX -d postgres -c \"ALTER SYSTEM SET wal_keep_size = '${keep}MB'\""
, "sudo -u postgres psql -p " <> port side <> " -tAX -d postgres -c 'SELECT pg_reload_conf()'"
, unwords ["pg_ctlcluster", "\"$version\"", cluster side, "stop -m fast"]
]
pgctl side action =
unlines
[ "set -e"
, versionOf side
, unwords ["pg_ctlcluster", "\"$version\"", cluster side, action]
]
versionOf side =
"version=$(pg_lsclusters --no-header | awk -v c=" <> shQuote (cluster side) <> " '$2==c {print $1}' | head -n1)"
psql side sql =
unlines
[ "set -e"
, unwords ["sudo", "-u", "postgres", "psql", "-p", port side, "-tAX", "-d", "postgres", "-c", shQuote sql]
]
{- An old primary rejoins by being rewound onto the new one's history,
not by being copied over the network: same machine, same data, only the
records that diverged are replaced. Everything that makes it /this
pair's/ standby afterwards is 'standbyTail', which a member that was
seeded from nothing runs too.
pg_rewind wants the target shut down, and refuses outright if
wal_log_hints was off when the cluster was made -- which is why
Postgres.defaultReplicationTuning turns it on before there is data. -}
rejoinScript side =
unlines $
[ "set -e"
, versionOf side
, "datadir=/var/lib/postgresql/$version/" <> cluster side
, "confdir=/etc/postgresql/$version/" <> cluster side
, "bindir=/usr/lib/postgresql/$version/bin"
, unwords ["pg_ctlcluster", "\"$version\"", cluster side, "stop || true"]
, -- pg_rewind finishes a crashed target's recovery itself, by
-- running `postgres --single -D <datadir>` -- which takes the
-- configuration to be in the data directory. On Debian it is in
-- /etc/postgresql, so that step fails and the rewind with it, in
-- exactly the case a failover is about: the machine that died.
-- Do the recovery here, where the config file's location is
-- known. Single-user, never a start: a server that listens is a
-- second primary, and this one still believes it is one.
"state=$(\"$bindir/pg_controldata\" -D \"$datadir\" | sed -n 's/^Database cluster state: *//p')"
, -- and it must not throw away what it is being run for: a clean
-- shutdown ends in a checkpoint, and a checkpoint recycles the
-- WAL before it -- which is the WAL pg_rewind then reads, from
-- the last checkpoint the two machines share. Keeping as much
-- as pg_wal already holds costs nothing, since it is on the
-- disk either way.
"keep=$(du -sm \"$datadir/pg_wal\" | awk '{print $1 + 1}')"
, "case \"$state\" in"
, " 'shut down'|'shut down in recovery') ;;"
, " *) sudo -u postgres \"$bindir/postgres\" --single -D \"$datadir\""
<> " -c config_file=\"$confdir/postgresql.conf\" -c wal_keep_size=\"${keep}MB\""
<> " template1 </dev/null >/dev/null ;;"
, "esac"
, "sudo -u postgres env PGPASSFILE=" <> shQuote pair.pair_rewind_passfile <> " \"$bindir/pg_rewind\""
<> " --target-pgdata=\"$datadir\" -R --source-server="
<> shQuote (sourceServer pair (other side))
]
<> standbyTail pair side
<> [ unwords ["pg_ctlcluster", "\"$version\"", cluster side, "start"]
, dropStaleSlot pair side
]
{- Holding the clients, rather than dropping them: with transaction
pooling, PAUSE waits for the transactions in flight and queues what comes
after, so a client sees latency where it would otherwise see an error.
Asked for and then checked, because PAUSE on an already-paused database
is an error and a pass that is resumed after being interrupted will find
one -- and because "did the clients actually stop" is the question this
step exists to answer, not "did a command exit zero". -}
pauseScript b =
unlines ["set -e"]
<> concatMap (pauseOne b . Text.unpack . routed_alias) (routedDatabases b)
{- Every database the bouncer routes, one after the other and each
checked before the next: the step is over only once all of them are
held, and 'nextStep' does not stop the old primary before that. -}
pauseOne b alias =
unlines
[ -- kept, rather than discarded: "it did not pause" is a
-- symptom, and what the console said about it is the cause.
"said=$(" <> consoleCommand b "-tAX" ("PAUSE " <> alias) <> " 2>&1)" <> " || true"
, "paused=$(" <> showDatabasesColumn b alias "paused" <> ")"
, "[ \"$paused\" = 1 ] || { echo " <> shQuote ("bouncer " <> Text.unpack b.bouncer_name <> " did not pause " <> alias <> ", and said:") <> " \"$said\" >&2; "
<> consoleCommand b "-AX" "SHOW DATABASES" <> " >&2 2>&1 || true; exit 1; }"
]
{- The whole of moving traffic: rewrite the routing file, RELOAD so the
bouncer reads it, RESUME so the clients it has been holding go to the new
primary. The file is written here rather than reloaded from a
declaration, because between those two things there is a moment when the
bouncer would send clients to a machine that is not the primary yet.
One file and one RELOAD whatever number of databases the bouncer routes,
so they move together; then each is resumed and checked. A database that
fails its check leaves the ones after it held, which the next pass sees
(not every alias is ready) and repoints again. -}
repointScript side b =
unlines
( [ "set -e"
, "cat > " <> shQuote b.bouncer_routing_path <> " <<'SALMON_ROUTING'"
]
<> routingLines (on side) b
<> [ "SALMON_ROUTING"
, consoleCommand b "-tAX" "RELOAD" <> " >/dev/null"
]
)
<> concatMap (resumeOne side b . Text.unpack . routed_alias) (routedDatabases b)
resumeOne side b alias =
unlines
[ "said=$(" <> consoleCommand b "-tAX" ("RESUME " <> alias) <> " 2>&1)" <> " || true"
, "host=$(" <> showDatabasesColumn b alias "host" <> ")"
, "paused=$(" <> showDatabasesColumn b alias "paused" <> ")"
, "[ \"$host\" = " <> shQuote (Text.unpack (on side).member_host) <> " ] && [ \"$paused\" = 0 ]"
<> " || { echo " <> shQuote ("bouncer " <> Text.unpack b.bouncer_name <> " is still sending clients of " <> alias <> " to $host (paused=$paused), and said:") <> " \"$said\" >&2; exit 1; }"
]
{- One column of one database's row of SHOW DATABASES, found by column
/name/: the columns have changed between pgbouncer versions, and
counting them reads the wrong one.
The two values are handed to awk with @-v@ rather than written into its
program, because a shell-quoted string spliced into a single-quoted awk
program stops being a string: the shell eats the quotes, awk reads a bare
word, and a bare word in awk is an empty variable that equals nothing. -}
showDatabasesColumn b alias col =
consoleCommand b "-AX" "SHOW DATABASES"
<> " | awk -F'|' -v col="
<> shQuote col
<> " -v want="
<> shQuote alias
<> " 'NR==1 { for (i=1;i<=NF;i++) { if ($i==\"name\") n=i; if ($i==col) c=i } } NR>1 && $n==want { print $c }'"
{- The routing file's contents: one line per database the bouncer routes,
all sent to the same member. Shared by the two writers of that file so that
they cannot come to disagree about its shape. -}
routingLines :: Member -> Bouncer -> [String]
routingLines m b =
"[databases]"
: [ Text.unpack d.routed_alias
<> " = host="
<> Text.unpack m.member_host
<> " port="
<> show m.member_port
<> " dbname="
<> Text.unpack d.routed_dbname
| d <- routedDatabases b
]
{- Everything that makes a member /this pair's/ standby, whatever brought
it here -- a rewind, or a clone from nothing. It writes the recovery
configuration rather than trusting @pg_rewind -R@ or @pg_basebackup -R@
to have done it: both are entitled to write something reasonable and
neither is entitled to write this pair's slot, and a member that comes
back as somebody else's standby is a second primary waiting to happen.
It leaves the cluster stopped or running exactly as it found it; the
caller starts it. -}
standbyTail :: Pair -> Side -> [String]
standbyTail pair side =
let peerSide' = other side
conf = "\"$datadir/postgresql.auto.conf\""
slotHere = slotNameFor pair side
in [ {- The slot this member streams with, on the machine it streams
from. Slots are not replicated and nothing else creates this
one, so the member makes its own -- and then checks, because a
standby that names a slot the primary does not have retries
forever ("replication slot ... does not exist") while looking,
to every other query, like a healthy standby. Creating it goes
over the replication connection, which is the one path the pair
is already required to have; the check goes over the rewind
role's ordinary one. -}
"sudo -u postgres env PGPASSFILE=" <> shQuote pair.pair_repl_passfile <> " psql -tAX -d " <> shQuote (replicationConn pair peerSide')
<> " -c " <> shQuote ("CREATE_REPLICATION_SLOT " <> Text.unpack slotHere <> " PHYSICAL") <> " >/dev/null 2>&1 || true"
, "have=$(sudo -u postgres env PGPASSFILE=" <> shQuote pair.pair_rewind_passfile <> " psql -tAX -d " <> shQuote (sourceServer pair peerSide')
<> " -c " <> shQuote ("SELECT count(*) FROM pg_replication_slots WHERE slot_name = '" <> Text.unpack slotHere <> "'") <> ")"
, "[ \"$have\" = 1 ] || { echo " <> shQuote ("no replication slot " <> Text.unpack slotHere <> " on " <> Text.unpack (memberOn pair peerSide').member_host) <> " >&2; exit 1; }"
, "sudo -u postgres sed -i '/^primary_conninfo/d' " <> conf
, "echo " <> shQuote ("primary_conninfo = '" <> primaryConninfo pair peerSide' <> "'") <> " | sudo -u postgres tee -a " <> conf <> " >/dev/null"
, "sudo -u postgres sed -i '/^primary_slot_name/d' " <> conf
, "echo " <> shQuote ("primary_slot_name = '" <> Text.unpack slotHere <> "'") <> " | sudo -u postgres tee -a " <> conf <> " >/dev/null"
, -- and the WAL a stop pinned so that a rewind could happen: it
-- has happened, and a standby holding every segment it ever saw
-- fills a disk.
"sudo -u postgres sed -i '/^wal_keep_size/d' " <> conf
, "sudo -u postgres touch \"$datadir/standby.signal\""
]
{- The slot this member held for the peer back when it was the primary.
Nothing consumes it here, and a slot nobody consumes still pins every
segment behind it: a standby that keeps one fills its own disk waiting
for a machine that is not coming. Not fatal -- this member is already
back in the pair by the time it runs. -}
dropStaleSlot :: Pair -> Side -> String
dropStaleSlot pair side =
"sudo -u postgres psql -p " <> show (memberOn pair side).member_port <> " -tAX -d postgres -c "
<> shQuote ("SELECT pg_drop_replication_slot(slot_name) FROM pg_replication_slots WHERE slot_name = '" <> Text.unpack (slotNameFor pair (other side)) <> "'")
<> " >/dev/null || echo " <> shQuote ("could not drop the stale slot " <> Text.unpack (slotNameFor pair (other side))) <> " >&2"
primaryConninfo :: Pair -> Side -> String
primaryConninfo pair side =
unwords $
[ "host=" <> Text.unpack (memberOn pair side).member_host
, "port=" <> show (memberOn pair side).member_port
, "user=" <> Text.unpack pair.pair_repl_role
, "passfile=" <> pair.pair_repl_passfile
]
<> sslParams pair AsReplication
replicationConn :: Pair -> Side -> String
replicationConn pair side =
unwords $
[ "host=" <> Text.unpack (memberOn pair side).member_host
, "port=" <> show (memberOn pair side).member_port
, "user=" <> Text.unpack pair.pair_repl_role
, "dbname=postgres"
, -- the physical kind. `replication=database` is the logical one,
-- and pg_hba matches that against the database name.
"replication=true"
]
<> sslParams pair AsReplication
sourceServer :: Pair -> Side -> String
sourceServer pair side =
unwords $
[ "host=" <> Text.unpack (memberOn pair side).member_host
, "port=" <> show (memberOn pair side).member_port
, "user=" <> Text.unpack pair.pair_rewind_role
, "dbname=postgres"
]
<> sslParams pair AsRewind
shQuote :: String -> String
shQuote s = "'" <> concatMap (\c -> if c == '\'' then "'\\''" else [c]) s <> "'"
-------------------------------------------------------------------------------
data Report
= Probed !Side !Observed
| Deciding !Step
| Acted !Text !ExitCode !Text
-- ^ what was acted on -- a member's side, or a bouncer's name -- and how
-- it went.
deriving (Show)
{- | Where this pair's primary is.
A node stating a fact about two machines, not an action: its @check@ asks
them both and is satisfied only when the declaration holds, and its @up@
takes 'nextStep's steps until it does. Both run from a /controlling/
machine, over ssh -- never from a member, since the member that dies might
be the one running this.
@ref@ is keyed on the pair, never on which side is primary, so moving the
primary changes this node rather than declaring a second one. The declared
side is in @notes@ instead, which is what makes a re-declaration visible to
@run serve@ as a change (see "Salmon.Actions.Serve"'s @Stale@).
There is no @down@: tearing a pair down is not "stop being a primary", it is
whatever the machines' own nodes do, and a switchover node that could stop
serving on the way out is a footgun with no use.
-}
{- | What a machine needs in order to be either half of the pair, whichever
half it happens to be today.
Both members get the same node, and **it says nothing about which of them is
the primary** -- not in its 'ref', not in its 'help', not in its 'notes'. A
switchover then changes exactly one declaration, the role node's, and under
@run serve@ the members are not marked 'Salmon.Actions.Serve.Stale' by a
change that is none of their business.
It runs over ssh from the controller, like every other part of this recipe,
which is why it renders SQL rather than reusing the nodes in
"Salmon.Builtin.Nodes.Postgres": those are ops that run /on/ the machine
they configure, and nothing here does. What it does reuse is that module's
opinion about which settings replication needs
('Postgres.replicationSettings'), so there is one place that decides.
The passwords are read on the member, out of the @.pgpass@ files the pair
already names, and fed to @psql@ on standard input rather than an argument:
they are never in this script, never on a command line, and never in a
report. Provisioning those files is somebody else's job, which is the rule
for recipes -- a recipe that ships secrets has chosen a transport for
everyone who uses it.
The node has no 'check': everything it does is a set rather than an insert,
and asking a machine whether all of it is already true costs the same round
trips as doing it again.
-}
member :: Reporter Report -> Pair -> Side -> Op
member r pair side =
op "pg-pair-member" nodeps $ \actions ->
actions
{ ref = mkRef "pg-pair-member" (pair.pair_name <> "@" <> m.member_host)
, help = Text.unwords ["member of", pair.pair_name, "on", m.member_host]
, notes =
[ "accepts replication and rewind connections from " <> peer.member_host
, "cluster " <> m.member_cluster <> " on port " <> Text.pack (show m.member_port)
, -- what a re-declaration with another choice changes, so
-- that `run serve` sees one
"those connections: " <> securityNote (connSecurity pair)
]
, up = do
refuseBadSecurity pair
(code, out, err) <- sshToTarget pair (OnMember m) (memberScript pair side)
runReporter r (Acted m.member_host code (Text.strip (out <> err)))
case code of
ExitSuccess -> pure ()
ExitFailure _ ->
throwIO (userError (Text.unpack ("member " <> m.member_host <> ": " <> Text.strip (err <> out))))
}
where
m = memberOn pair side
peer = memberOn pair (other side)
{- | Builds one member out of the other: @pg_basebackup@, then everything
that makes it this pair's standby.
This is the one node here that can destroy a machine's data, so what guards
it is 'Postgres.cloneFromPrimaryScript''s own guard, reused rather than
rewritten: same system identifier means this data directory already belongs
to that cluster and is left alone, a different one is cloned over only if
what is there is pristine, and anything else is refused by name. See P1 in
@specs\/pg-switchover.md@, which is the defect that guard was written for.
It is not part of a switchover. A member that already belongs to the pair
rejoins by being rewound (see 'Step''s @Rejoin@); copying a whole cluster
across the network is what you do when there is nothing to rewind /from/.
-}
seedMember :: Reporter Report -> Pair -> Side -> Op
seedMember r pair side =
op "pg-pair-seed" nodeps $ \actions ->
actions
{ ref = mkRef "pg-pair-seed" (pair.pair_name <> "@" <> m.member_host)
, help = Text.unwords ["seeds", m.member_host, "from", peer.member_host]
, notes =
[ "clones only over a pristine or matching data directory, and refuses anything else"
]
, up = do
refuseBadSecurity pair
(code, out, err) <- sshToTarget pair (OnMember m) (seedScript pair side)
runReporter r (Acted m.member_host code (Text.strip (out <> err)))
case code of
ExitSuccess -> pure ()
ExitFailure _ ->
throwIO (userError (Text.unpack ("seeding " <> m.member_host <> ": " <> Text.strip (err <> out))))
}
where
m = memberOn pair side
peer = memberOn pair (other side)
-- | The script 'seedMember' runs.
seedScript :: Pair -> Side -> String
seedScript = seedScriptWith []
{- | 'seedScript', with lines to run between the clone and the standby
configuration -- once there is a fresh data directory, and before the slot
this member streams with is made on the primary.
-}
seedScriptWith :: [String] -> Pair -> Side -> String
seedScriptWith between pair side =
unlines $
sslEnvironment pair
<> [ Postgres.cloneFromPrimaryScript setup
, -- the clone leaves it running and streaming with whatever
-- pg_basebackup's -R wrote; from here it is this pair's standby,
-- with this pair's slot, which nothing else would give it.
"version=$(pg_lsclusters --no-header | awk -v c=" <> shQuote (Text.unpack m.member_cluster) <> " '$2==c {print $1}' | head -n1)"
, "datadir=/var/lib/postgresql/$version/" <> Text.unpack m.member_cluster
]
<> between
<> standbyTail pair side
<> [ unwords ["pg_ctlcluster", "\"$version\"", Text.unpack m.member_cluster, "restart"]
]
where
m = memberOn pair side
peer = memberOn pair (other side)
setup =
Postgres.StandbySetup
{ Postgres.standby_cluster = m.member_cluster
, Postgres.standby_primary_host = peer.member_host
, Postgres.standby_primary_port = peer.member_port
, Postgres.standby_repl_user = Postgres.User pair.pair_repl_role
, Postgres.standby_repl_passfile = pair.pair_repl_passfile
, -- no slot for the copy itself: the slot this member streams
-- with is made just below, once there is a member to make it
-- for.
Postgres.standby_slot = Nothing
}
{- | Wipes a standby whose slot is lost and builds it again from the primary.
The one place a node here @rm -rf@s a data directory that belongs to the
pair, so what runs it is 'nextStep' and only when the primary says the slot
is lost /and/ the operator named this side in 'pair_reseed'. What guards the
directory itself is unchanged and is 'Postgres.cloneFromPrimaryScript''s:
* the same system identifier as the primary's, or no cluster at all, is the
pair's own data (or nothing): removed here so the clone below runs;
* anything else is left exactly where it is, and the clone refuses it by
name unless it is pristine. A machine that turns out to hold somebody
else's cluster is never wiped by a declaration about this pair's slot.
The order is what makes an interrupted pass resumable, since the machines
are re-asked every turn and there is no note to lose. The slot is dropped
/after/ the clone: until then it still reads @lost@, so a pass killed
between the wipe and the clone finds the same diagnosis, the same
declaration, and starts again. Dropped before the member's own is made,
because a standby streaming with an invalidated slot of the right name
looks healthy to everything but @pg_stat_wal_receiver@ ('standbyTail''s
check counts slots by name, and this one would still be counted).
-}
reseedScript :: Pair -> Side -> String
reseedScript pair side =
unlines $
[ "set -e"
, "version=$(pg_lsclusters --no-header | awk -v c=" <> shQuote cluster <> " '$2==c {print $1}' | head -n1)"
, "datadir=/var/lib/postgresql/$version/" <> cluster
, "pg_controldata=/usr/lib/postgresql/$version/bin/pg_controldata"
, "[ -x \"$pg_controldata\" ] || pg_controldata=pg_controldata"
, "primary_sysid=$(PGPASSFILE=" <> shQuote pair.pair_repl_passfile <> " psql -tAX -d " <> shQuote (replicationConn pair peerSide)
<> " -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\" ] || [ ! -e \"$datadir/global/pg_control\" ]; then"
, " pg_ctlcluster \"$version\" " <> cluster <> " stop -m immediate || true"
, " rm -rf \"$datadir\""
, "fi"
]
<> [seedScriptWith [dropLostSlot] pair side]
where
cluster = Text.unpack m.member_cluster
m = memberOn pair side
peerSide = other side
slot = Text.unpack (slotNameFor pair side)
-- the lost slot, on the primary, over the connection the pair already
-- needs; and then checked, because a slot that survives this is one
-- 'standbyTail' would take for its own.
dropLostSlot =
unlines
[ "sudo -u postgres env PGPASSFILE=" <> shQuote pair.pair_repl_passfile <> " psql -tAX -d " <> shQuote (replicationConn pair peerSide)
<> " -c " <> shQuote ("DROP_REPLICATION_SLOT " <> slot) <> " >/dev/null 2>&1 || true"
, "left=$(sudo -u postgres env PGPASSFILE=" <> shQuote pair.pair_rewind_passfile <> " psql -tAX -d " <> shQuote (sourceServer pair peerSide)
<> " -c " <> shQuote ("SELECT count(*) FROM pg_replication_slots WHERE slot_name = '" <> slot <> "'") <> ")"
, "[ \"$left\" = 0 ] || { echo " <> shQuote ("could not drop the lost slot " <> slot <> " on " <> Text.unpack (memberOn pair peerSide).member_host) <> " >&2; exit 1; }"
]
{- | Stands a bouncer up in front of the pair: its @pgbouncer.ini@, and the
routing file the ini includes.
The two are written differently on purpose. The ini is this node's, so it is
rewritten whenever the declaration changes it, and a change means a restart
-- which is affordable exactly because the ini says nothing about where the
primary is. The routing file, which does, is written here only if it is
/missing/, because from then on it belongs to the role node, which moves it
the gentle way. Two writers and one file is how a switchover turns into an
outage.
-}
bouncerSetup :: Reporter Report -> Pair -> Bouncer -> Op
bouncerSetup r pair b =
op "pg-pair-bouncer" nodeps $ \actions ->
actions
{ ref = mkRef "pg-pair-bouncer" (pair.pair_name <> "@" <> b.bouncer_ssh_host)
, help = Text.unwords ["pgbouncer", b.bouncer_name, "in front of", pair.pair_name]
, notes =
[ "clients reach " <> Text.intercalate ", " (map routed_alias (routedDatabases b)) <> " on port " <> Text.pack (show b.bouncer_listen_port)
, "routing is " <> Text.pack b.bouncer_routing_path <> ", which the role node owns"
]
, up = do
(code, out, err) <- sshToTarget pair (OnBouncer b) (bouncerSetupScript pair b)
runReporter r (Acted b.bouncer_name code (Text.strip (out <> err)))
case code of
ExitSuccess -> pure ()
ExitFailure _ ->
throwIO (userError (Text.unpack ("bouncer " <> b.bouncer_name <> ": " <> Text.strip (err <> out))))
}
-- | The script 'bouncerSetup' runs.
bouncerSetupScript :: Pair -> Bouncer -> String
bouncerSetupScript pair b =
unlines
[ "set -e"
, "cat > /tmp/salmon-pgbouncer.ini <<'SALMON_INI'"
, Text.unpack (Text.strip (PgBouncer.renderIni iniConfig))
, "SALMON_INI"
, -- written only if absent: after that it is the role node's, and a
-- pass that rewrote it here would move clients without pausing them
"[ -e " <> shQuote b.bouncer_routing_path <> " ] || cat > " <> shQuote b.bouncer_routing_path <> " <<'SALMON_ROUTING'"
]
<> unlines (routingLines primary b)
<> unlines
[ "SALMON_ROUTING"
, "if ! cmp -s /tmp/salmon-pgbouncer.ini " <> shQuote ini <> "; then"
, " install -m 0644 /tmp/salmon-pgbouncer.ini " <> shQuote ini <> ""
, " systemctl restart pgbouncer"
, "fi"
, "rm -f /tmp/salmon-pgbouncer.ini"
, "systemctl is-active --quiet pgbouncer || systemctl start pgbouncer"
]
where
primary = memberOn pair pair.pair_primary
ini = b.bouncer_config_dir <> "/pgbouncer.ini"
iniConfig =
PgBouncer.BouncerConfig
{ PgBouncer.bouncer_config_dir = b.bouncer_config_dir
, PgBouncer.bouncer_listen_addr = "*"
, PgBouncer.bouncer_listen_port = b.bouncer_listen_port
, -- this pair's database is in the routing file, not here
PgBouncer.bouncer_databases = []
, -- and its users are in the pre-provisioned auth file
PgBouncer.bouncer_users = []
, -- the pooling a switchover needs: PAUSE then waits for
-- transactions rather than for whole sessions, so a client
-- sees a pause of its own length and not of somebody else's.
PgBouncer.bouncer_pool_mode = PgBouncer.TransactionPooling
, PgBouncer.bouncer_max_client_conn = 200
, PgBouncer.bouncer_default_pool_size = 20
, PgBouncer.bouncer_admin_users = [b.bouncer_console_user]
, PgBouncer.bouncer_routing_file = Just b.bouncer_routing_path
}
{- | A declaration whose paths would not survive being spliced into a script
runs nothing at all, and says everything that is wrong with it.
-}
refuseBadSecurity :: Pair -> IO ()
refuseBadSecurity pair =
case (securityProblems pair, bouncerProblems pair) of
([], []) -> pure ()
([], problems) ->
throwIO (userError (Text.unpack ("pair " <> pair.pair_name <> ": pair_bouncers: " <> Text.intercalate "; " problems)))
(problems, _) ->
throwIO (userError (Text.unpack ("pair " <> pair.pair_name <> ": pair_conn_security: " <> Text.intercalate "; " problems)))
-- | The choice in words, for a node's @notes@: paths, never contents.
securityNote :: ConnSecurity -> Text
securityNote PlainMd5 = "host, md5 (TLS not required)"
securityNote (TlsScram tls) = "hostssl, scram-sha-256, " <> tlsNote tls
securityNote (TlsClientCert tls cc) =
"hostssl, client certificates ("
<> Text.pack cc.client_repl_cert
<> ", "
<> Text.pack cc.client_rewind_cert
<> "), "
<> tlsNote tls
tlsNote :: Tls -> Text
tlsNote tls =
Text.intercalate
", "
[ case tls.tls_check of
Encrypted -> "server not verified (sslmode=require)"
VerifyCa ca -> "server verified against " <> Text.pack ca <> " (verify-ca)"
VerifyFull ca -> "server and its name verified against " <> Text.pack ca <> " (verify-full)"
, case tls.tls_server of
Nothing -> "the cluster's TLS settings left as found"
Just sf -> "served with " <> Text.pack sf.server_cert
]
{- | The script 'member' runs. Pure, like the steps, so that what it does to
a machine can be read without one.
= What it does to @pg_hba.conf@
It removes the lines the pair's /other/ 'ConnSecurity' choices would have
written for this peer ('hbaLinesRetired'), and appends this choice's two if
they are missing ('hbaLinesFor'). Removing is what makes a tightened choice
mean anything -- see 'hbaLinesRetired' -- and it touches those exact lines
only. A line somebody else wrote above them that also matches the peer still
wins: this recipe owns its lines, not the file.
For the TLS choices, in this order: the cluster is made to serve TLS (if
'tls_server' says with what), it is /asked/ whether it does, and only then
is the file touched. A @hostssl@ line on a cluster with @ssl = off@ matches
nothing, so a pass that wrote one first would cut the pair's replication to
announce that TLS is not set up. Afterwards the server is asked whether it
could read the file it was given (@pg_hba_file_rules@), since a file it
cannot parse is silently not loaded.
= What it does on a standby
Aligns @primary_conninfo@ with the declared choice, if and only if the
standby is already pointed at its peer: a choice changed on a running pair
otherwise reaches the standby's own connection at its next rejoin, and with
client certificates that connection would fail at its next reconnect. It
never points a standby anywhere -- that is the role node's, through a rejoin.
-}
memberScript :: Pair -> Side -> String
memberScript pair side =
unlines $
[ "set -e"
, "version=$(pg_lsclusters --no-header | awk -v c=" <> shQuote cluster <> " '$2==c {print $1}' | head -n1)"
, "hba=/etc/postgresql/$version/" <> cluster <> "/pg_hba.conf"
]
<> map setting (Postgres.replicationSettings Postgres.defaultReplicationTuning)
<> servesTls
<> map (retireHbaLine . Text.unpack) (hbaLinesRetired pair side security)
<> map (hbaLine . Text.unpack) (hbaLinesFor pair side security)
<> -- roles are catalog rows: they reach the other machine through
-- the WAL like any other write, so only a primary makes them,
-- and a standby that is one tomorrow already has them.
[ "if [ \"$(" <> query "SELECT pg_is_in_recovery()" <> ")\" = f ]; then"
, " replpw=$(awk -F: 'NR==1 {print $5}' " <> shQuote pair.pair_repl_passfile <> ")"
, " rewindpw=$(awk -F: 'NR==1 {print $5}' " <> shQuote pair.pair_rewind_passfile <> ")"
, " " <> heredoc (roleSql "REPLICATION LOGIN" pair.pair_repl_role "$replpw")
, " " <> heredoc (roleSql "LOGIN" pair.pair_rewind_role "$rewindpw" <> " " <> grants)
, "else"
, -- a standby already pointed at its peer connects the way the
-- pair now says to. Compared first: for a pair whose choice
-- did not change this is one query and nothing else.
" conninfo=$(" <> query "SELECT setting FROM pg_settings WHERE name = 'primary_conninfo'" <> ")"
, " case \"$conninfo\" in"
, " " <> shQuote ("host=" <> Text.unpack peer.member_host <> " ") <> "*)"
, " [ \"$conninfo\" = " <> shQuote wantedConninfo <> " ] || "
<> psql' ("ALTER SYSTEM SET primary_conninfo = " <> Text.unpack (quoteSql (Text.pack wantedConninfo)))
<> " ;;"
, " esac"
, "fi"
]
<> [psql' "SELECT pg_reload_conf()"]
<> hbaLoaded
<> [ -- the same shape as systemd's NeedDaemonReload: the file has
-- changed, and only the running server knows whether what
-- changed needs it to come back.
"pending=$(" <> query "SELECT count(*) FROM pg_settings WHERE pending_restart" <> ")"
, "[ \"$pending\" = 0 ] || pg_ctlcluster \"$version\" " <> cluster <> " restart"
]
where
m = memberOn pair side
peer = memberOn pair (other side)
cluster = Text.unpack m.member_cluster
port = show m.member_port
security = connSecurity pair
wantedConninfo = primaryConninfo pair (other side)
setting (k, v) = psql' ("ALTER SYSTEM SET " <> Text.unpack k <> " = " <> Text.unpack (quoteSql v))
quoteSql v = "'" <> Text.replace "'" "''" v <> "'"
hbaLine l = "grep -qxF " <> shQuote l <> " \"$hba\" || echo " <> shQuote l <> " >> \"$hba\""
{- Written back with `cat >`, not moved into place: the file keeps its
owner, its mode and its inode, which are postgresql-common's. -}
retireHbaLine l =
"if grep -qxF " <> shQuote l <> " \"$hba\"; then awk -v l=" <> shQuote l
<> " '$0 != l' \"$hba\" > \"$hba.salmon\" && cat \"$hba.salmon\" > \"$hba\"; rm -f \"$hba.salmon\"; fi"
servesTls = case security of
PlainMd5 -> []
TlsScram tls -> serving tls False
TlsClientCert tls _ -> serving tls True
serving :: Tls -> Bool -> [String]
serving tls needsClientCa =
foldMap serverFiles tls.tls_server
<> [ psql' "SELECT pg_reload_conf()"
, "[ \"$(" <> query "SHOW ssl" <> ")\" = on ] || { echo "
<> shQuote ("cluster " <> cluster <> " is not serving TLS (ssl is off), so a hostssl line would match nothing: pg_hba.conf left as it was")
<> " >&2; exit 1; }"
]
<> [ "[ -n \"$(" <> query "SHOW ssl_ca_file" <> ")\" ] || { echo "
<> shQuote ("cluster " <> cluster <> " has no ssl_ca_file, so it cannot check a client certificate: pg_hba.conf left as it was")
<> " >&2; exit 1; }"
| needsClientCa
]
serverFiles :: ServerFiles -> [String]
serverFiles sf =
map readable ([sf.server_cert, sf.server_key] <> foldMap pure sf.server_client_ca)
<> [ setting ("ssl_cert_file", Text.pack sf.server_cert)
, setting ("ssl_key_file", Text.pack sf.server_key)
]
<> foldMap (\ca -> [setting ("ssl_ca_file", Text.pack ca)]) sf.server_client_ca
<> [setting ("ssl", "on")]
readable f =
"sudo -u postgres test -r " <> shQuote f <> " || { echo "
<> shQuote ("pre-provisioned file missing or unreadable by postgres: " <> f)
<> " >&2; exit 1; }"
hbaLoaded = case security of
PlainMd5 -> []
_ ->
[ "broken=$(" <> query "SELECT count(*) FROM pg_hba_file_rules WHERE error IS NOT NULL" <> ")"
, "[ \"$broken\" = 0 ] || { echo "
<> shQuote "the server could not read pg_hba.conf as it now stands (see pg_hba_file_rules), so it is still using the previous one"
<> " >&2; exit 1; }"
]
psql' sql = "sudo -u postgres psql -p " <> port <> " -tAX -d postgres -c " <> shQuote sql
query = psql'
{- Fed on standard input, so that a password is never an argument: this
runs on a machine with other people on it, and an argument is in `ps`.
The delimiter is deliberately unquoted, so that the shell substitutes the
password it just read -- which is why the dollar-quoted DO block is
written @\\$do\\$@, or the shell would take it for a variable. -}
heredoc sql =
"sudo -u postgres psql -p " <> port <> " -tAX -d postgres >/dev/null <<PAIR_SQL\n" <> sql <> "\nPAIR_SQL"
{- Created if missing, and its password set either way, so that rotating
the passfile is enough to rotate the role -- and, under a TLS choice,
stored as a SCRAM verifier whatever the cluster's own default is, since
@scram-sha-256@ in pg_hba.conf refuses a role whose password is stored
as md5. -}
roleSql attrs role pw =
storedAs
<> "DO \\$do\\$ BEGIN CREATE ROLE "
<> Text.unpack role
<> " "
<> attrs
<> "; EXCEPTION WHEN duplicate_object THEN NULL; END \\$do\\$;"
<> " ALTER ROLE "
<> Text.unpack role
<> " "
<> attrs
<> " PASSWORD '"
<> pw
<> "';"
storedAs = case security of
PlainMd5 -> ""
_ -> "SET password_encryption = 'scram-sha-256'; "
grants =
unwords
[ "GRANT EXECUTE ON FUNCTION pg_ls_dir(text, boolean, boolean) TO " <> Text.unpack pair.pair_rewind_role <> ";"
, "GRANT EXECUTE ON FUNCTION pg_stat_file(text, boolean) TO " <> Text.unpack pair.pair_rewind_role <> ";"
, "GRANT EXECUTE ON FUNCTION pg_read_binary_file(text) TO " <> Text.unpack pair.pair_rewind_role <> ";"
, "GRANT EXECUTE ON FUNCTION pg_read_binary_file(text, bigint, bigint, boolean) TO " <> Text.unpack pair.pair_rewind_role <> ";"
]
pairRole :: Reporter Report -> Pair -> Op
pairRole r pair =
op "pg-pair-role" nodeps $ \actions ->
actions
{ ref = mkRef "pg-pair-role" pair.pair_name
, help = Text.unwords ["primary of", pair.pair_name, "is on", Text.pack (show pair.pair_primary)]
, notes =
[ "primary declared on " <> Text.pack (show pair.pair_primary)
, maybe "no side's writes may be discarded" (\s -> "writes may be discarded on " <> Text.pack (show s)) pair.pair_may_discard
, maybe "no side may be re-seeded" (\s -> "may be re-seeded, if its slot is lost: " <> Text.pack (show s)) pair.pair_reseed
]
, check = verdict <$> decide pair
, up = refuseBadSecurity pair >> converge r pair
}
{- | The whole pair as one declaration: both machines configured to be
either half of it, every bouncer stood up in front, and on top of those the
one sentence that says where the primary is.
The ordering is the point. The role node is the only one that mentions a
side, so it is the only one an operator edits to move the primary, and it
runs after the machines underneath it are ready to take either role.
-}
pairOp :: Reporter Report -> Pair -> Op
pairOp r pair =
foldl inject (pairRole r pair) $
[member r pair A, member r pair B]
<> foldMap
( \side ->
-- after *both* members, not just its own: a clone reads
-- from the peer, and the peer is only ready to be read
-- from once its own member node has let this side in.
[foldl inject (seedMember r pair side) [member r pair A, member r pair B]]
)
pair.pair_seed
<> [bouncerSetup r pair b | b <- pair.pair_bouncers]
{- | What the pair is, as a verdict.
'Degraded' is 'Unknown' on purpose. Under @run serve@ that is the one
verdict which restarts nothing (see "Salmon.Actions.Upkeep"), and "the
primary is where it should be, and the other machine is unreachable" is
exactly a state to keep looking at and not to act on.
-}
verdict :: Step -> CheckResult
verdict Done = Success
verdict (Degraded _) = Unknown
-- the peer is where it should be and pointed where it should be, and is not
-- streaming: a partition reads as this, and so does a standby that came back
-- a second ago. Neither is a reason to act, and only one of them is a reason
-- to worry, which is a distinction no observation can make.
verdict (AwaitStreaming _) = Unknown
verdict (Refuse why) = Failure why
verdict step = Failure (Text.pack (show step) <> " is still to do")
-- | Asks both machines and every bouncer, then draws the conclusion.
decide :: Pair -> IO Step
decide pair = do
obsA <- observe pair A
obsB <- observe pair B
bouncers <- traverse (observeBouncer pair) pair.pair_bouncers
pure (nextStep pair obsA obsB (concat bouncers))
{- | Asks a bouncer where it is sending clients, and whether it is holding
them.
A bouncer that cannot be reached reads as sending clients nowhere, which is
not 'Done' -- so a pass will try to repoint it, and say so loudly when it
cannot. That is the right way round: a pair whose clients are going somewhere
unknown has not arrived.
-}
observeBouncer :: Pair -> Bouncer -> IO [BouncerState]
observeBouncer pair b = do
(code, out, _) <- sshToTarget pair (OnBouncer b) (bouncerProbeScript b)
pure $ case code of
ExitSuccess -> parseBouncerStates b out
ExitFailure _ -> [BouncerState Nothing False | _ <- routedDatabases b]
-- | Runs 'probeScript' on a member and reads what comes back.
observe :: Pair -> Side -> IO Observed
observe pair side = do
(code, out, err) <- sshTo pair side (probeScript (memberOn pair side))
pure $ case code of
ExitSuccess -> parseObserved out
ExitFailure _ -> Unreachable (Text.strip (Text.take 200 err))
{- | Steps until the declaration holds.
The loop is the design: every turn starts by asking the machines again, so
an @up@ that died half-way is resumed by the next one rather than continued
from a note it left itself. The budget is a guard against a state this table
cannot leave, not a timeout -- a pair that needs more than a handful of
steps is a pair something else is fighting over.
-}
converge :: Reporter Report -> Pair -> IO ()
converge r = convergeUpTo r stepBudget
{- | How many steps a pass may take before it decides the pair is being
fought over by something else. A switchover between two machines that are
both there is three: stop the old primary, promote the new one, rejoin the
old one.
-}
stepBudget :: Int
stepBudget = 12
-- | 'converge', with the budget spelled out. A test stopping a controller
-- part-way is what this is for.
convergeUpTo :: Reporter Report -> Int -> Pair -> IO ()
convergeUpTo r budget0 pair = go budget0
where
go budget = do
step <- decide pair
runReporter r (Deciding step)
case step of
Done -> pure ()
Degraded _ -> pure ()
Refuse why -> throwIO (userError (Text.unpack ("pair " <> pair.pair_name <> ": " <> why)))
-- a standby that is pointed here and still not streaming when the
-- waiting runs out is a pair that is one machine short, which is
-- a state to report and keep looking at -- not a pass that
-- failed. Every other step that outlasts its budget is.
AwaitStreaming _ | budget <= 0 -> pure ()
_
-- asked after the arrivals, never before: a pass that has
-- spent its budget and is /there/ has not failed at anything.
| budget <= 0 ->
throwIO (userError ("pair " <> Text.unpack pair.pair_name <> ": still " <> show step <> " after " <> show budget0 <> " steps, giving up"))
AwaitCatchUp _ _ -> waitABit >> go (budget - 1)
AwaitStreaming _ -> waitABit >> go (budget - 1)
_ -> case stepCommand pair step of
Left why -> throwIO (userError (Text.unpack ("pair " <> pair.pair_name <> ": " <> why)))
Right commands -> do
-- in order, and stopping at the first failure: these are
-- steps like "hold every client", where doing half of it
-- and carrying on is worse than not starting.
failures <- runEach commands
case failures of
[] -> go (budget - 1)
(why : _) ->
throwIO (userError (Text.unpack ("pair " <> pair.pair_name <> ": " <> Text.pack (show step) <> " failed: " <> why)))
runEach [] = pure []
runEach ((target, script) : rest) = do
(code, out, err) <- sshToTarget pair target script
runReporter r (Acted (targetName target) code (Text.strip (out <> err)))
case code of
ExitSuccess -> runEach rest
ExitFailure _ -> pure [targetName target <> ": " <> Text.strip (err <> out)]
waitABit = threadDelay (min 5 pair.pair_catch_up_seconds * 1000000)
-- | What a report calls the machine a command ran on.
targetName :: Target -> Text
targetName (OnMember m) = m.member_host
targetName (OnBouncer b) = b.bouncer_name
-- | Runs a script on a member over ssh, as the login that member declares.
sshTo :: Pair -> Side -> String -> IO (ExitCode, Text, Text)
sshTo pair side = sshToTarget pair (OnMember (memberOn pair side))
{- | The @user\@host@ the controller's ssh is given for a machine: the one
place a member's ssh address is read. Everything a script /contains/ about a
member is its 'member_host'.
-}
sshLogin :: Target -> Text
sshLogin target = sshUser target <> "@" <> case target of
OnMember m -> memberSshHost m
OnBouncer b -> b.bouncer_ssh_host
-- | The user the controller logs in as on a machine.
sshUser :: Target -> Text
sshUser (OnMember m) = m.member_ssh_user
sshUser (OnBouncer b) = b.bouncer_ssh_user
{- | The words ssh is given after the login: the script, under one @bash -c@,
and under one @sudo@ when the login is not root.
Every script this recipe sends was written to be run by root -- it appends to
@pg_hba.conf@, calls @pg_ctlcluster@, installs into @\/etc\/pgbouncer@,
restarts units, and reaches postgres through @sudo -u postgres@ -- and stock
cloud images refuse root logins. So the privilege is taken once, around the
whole script, rather than line by line: one wrapper cannot miss a line, and a
script reads the same whoever logged in. A root login is sent what it always
was, with no @sudo@ in front, so a machine without sudo installed still works
as root.
@-n@ because nobody is there to type a password: a login whose sudo wants one
fails at once, saying so, rather than waiting on a prompt. The locale is set
/inside/ the script, since sudo resets the environment.
-}
remoteCommand :: Target -> String -> [String]
remoteCommand target script = escalate <> ["bash", "-c", shQuote quieted]
where
escalate
| sshUser target == "root" = []
| otherwise = ["sudo", "-n"]
{- A neutral locale, because ssh forwards the caller's and Debian's psql
is a perl wrapper that complains about every locale the guest does not
have -- fifteen lines of it, per invocation, into the report of a node
that did nothing wrong. -}
quieted = "export LANG=C LC_ALL=C\n" <> script
-- | The same, for whichever kind of machine a step addresses.
sshToTarget :: Pair -> Target -> String -> IO (ExitCode, Text, Text)
sshToTarget pair target script = do
(code, out, err) <- readCreateProcessWithExitCode (proc "ssh" args) ""
pure (code, decode out, decode err)
where
login = sshLogin target
identity = case target of
OnMember m -> m.member_ssh_identity
OnBouncer b -> b.bouncer_ssh_identity
args =
concat
[ maybe [] (\key -> ["-i", key, "-o", "IdentitiesOnly=yes"]) identity
, maybe [] (\hosts -> ["-o", "UserKnownHostsFile=" <> hosts, "-o", "StrictHostKeyChecking=accept-new"]) pair.pair_ssh_known_hosts
, ["-o", "BatchMode=yes"]
, -- a member that cannot be reached is the case this recipe
-- exists for, so deciding that must take seconds. Left to
-- itself ssh retries a dropped connection for minutes, which
-- would make every pass during a partition hang rather than
-- report. The second pair covers a connection that dies while
-- the probe is already running.
["-o", "ConnectTimeout=10", "-o", "ServerAliveInterval=5", "-o", "ServerAliveCountMax=2"]
, [Text.unpack login]
, remoteCommand target script
]
decode = Text.decodeUtf8With TextError.lenientDecode