diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for salmon-ops-recipes + +## 0.1.0.0 -- unreleased + +* First release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2022-2026, Lucas DiCioccio +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/salmon-ops-recipes.cabal b/salmon-ops-recipes.cabal new file mode 100644 --- /dev/null +++ b/salmon-ops-recipes.cabal @@ -0,0 +1,194 @@ +cabal-version: 2.4 +name: salmon-ops-recipes +version: 0.1.0.0 +synopsis: Opinionated recipes built from Salmon builtins. +description: Higher-level recipes (postgres migrations, postgres primary/standby pairs, micro DNS, ...) composed from salmon-ops builtins. +homepage: https://lucasdicioccio.github.io/salmon/ +bug-reports: https://github.com/lucasdicioccio/salmon/issues +license: BSD-3-Clause +license-file: LICENSE +author: Lucas DiCioccio +maintainer: lucas@dicioccio.fr +copyright: 2022-2026 Lucas DiCioccio +category: Development +build-type: Simple +tested-with: GHC == 9.10.3 +extra-doc-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/lucasdicioccio/salmon + subdir: salmon-ops-recipes + +library + exposed-modules: SreBox.PostgresMigrations + , SreBox.CabalBuilding + , SreBox.Environment + , SreBox.Initialize + , SreBox.DNSRegistration + , SreBox.MicroDNS + , SreBox.PostgresInit + , SreBox.Postgrest + , SreBox.PostgresTls + , SreBox.PostgresBackup + , SreBox.PostgresTemplate + , SreBox.PostgresPair + , SreBox.JWTSigning + , SreBox.WireGuardVpn + , SreBox.Gcp.VmProvision + , SreBox.Gcp.CloudRunDeploy + , SreBox.Gcp.CloudRunAlerts + , SreBox.Gcp.PostgrestCloudRun + , SreBox.Gcp.PreviewEnvironment + build-depends: base >=4.16.3.0 && <4.22 + , aeson + , base16-bytestring + , base64-bytestring + , bytestring + , case-insensitive + , comonad + , containers + , contravariant + , cryptohash-sha256 + , crypton-connection + , crypton-x509 + , crypton-x509-store + , crypton-x509-validation + , directory + , filepath + , free + , hashable + , http-client + , http-client-tls + , jose + , jose-jwt + , mtl + , optparse-applicative + , optparse-generic + , process + , process-extras + , salmon-core ^>=0.1.0.0 + , salmon-ops ^>=0.1.0.0 + , text + , time + , tls + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: KindSignatures + , DataKinds + , OverloadedStrings + , DeriveFunctor + , OverloadedRecordDot + , TypeApplications + , ScopedTypeVariables + +test-suite salmon-ops-recipes-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: Test.Harness + , Test.CheckSpec + , Test.ClientModelSpec + , Test.AptRepositorySpec + , Test.DebianPackageSpec + , Test.LlamaServerSpec + , Test.ServeApi + , Test.ServeApiSpec + , Test.PgVectorSpec + , Test.PlakarSpec + , Test.WireGuardSpec + , Test.DebootstrapSpec + , Test.ConcurrentSpec + , Test.DaemonSpec + , Test.DagSpec + , Test.DownTreeSpec + , Test.FilesystemSpec + , Test.FollowCacheSpec + , Test.FollowRegistrySpec + , Test.FollowSchedulerSpec + , Test.FollowSignatureSpec + , Test.FollowSpec + , Test.GcpSpec + , Test.PodmanCommandSpec + , Test.JWTSigningSpec + , Test.LedgerSpec + , Test.MigratorTemplateSpec + , Test.PgBackupSpec + , Test.PodmanSpec + , Test.PostgresBackupSpec + , Test.PostgresInitSpec + , Test.PostgresReplicationSpec + , Test.PostgresClusterSpec + , Test.PgBouncerSpec + , Test.EtcdSpec + , Test.PgPairDemoSpec + , Test.PatroniHarnessSpec + , Test.PatroniVms + , Test.PostgresPairSpec + , Test.PostgresSwitchoverSpec + , Test.PostgresVms + , Test.PostgresTemplateSpec + , Test.PostgresTlsSpec + , Test.PostgrestCloudRunSpec + , Test.QemuResolveKernelSpec + , Test.QemuShutdownSpec + , Test.QemuSmokeSpec + , Test.QuerySpec + , Test.ReportJsonSpec + , Test.RewriteSpec + , Test.ServeEventsSpec + , Test.ServeHttpSpec + , Test.ServeModelSpec + , Test.ServeSocketSpec + , Test.ServeSpec + , Test.ServeTlsSpec + , Test.StatusSinkSpec + , Test.SystemdSpec + , Test.UpTreeSpec + , Test.UpkeepSpec + , Test.WindowSpec + build-depends: QuickCheck + , base >=4.16.3.0 && <4.22 + , aeson + , bytestring + , comonad + , containers + , contravariant + , crypton-connection + , crypton-x509-store + , directory + , filepath + , free + , http-client + , http-client-tls + , http-types + , mtl + , network + , optparse-applicative + , process + , process-extras + , stm + , salmon-core ^>=0.1.0.0 + , salmon-ops ^>=0.1.0.0 + , salmon-ops-recipes ^>=0.1.0.0 + , tasty + , tasty-hunit + , tasty-quickcheck + , temporary + , text + , time + , tls + , unix + , wai + , warp + -- Salmon.Actions.Serve reads its input handle on a forked thread, so a + -- test driving the loop wants a runtime where a blocking read does not + -- stall every other Haskell thread. + ghc-options: -threaded + default-language: Haskell2010 + default-extensions: DataKinds + , KindSignatures + , OverloadedStrings + , OverloadedRecordDot + , ScopedTypeVariables + , TypeApplications diff --git a/src/SreBox/CabalBuilding.hs b/src/SreBox/CabalBuilding.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/CabalBuilding.hs @@ -0,0 +1,196 @@ +module SreBox.CabalBuilding where + +import Data.Text (Text) +import qualified Data.Text as Text +import System.FilePath (takeFileName, ()) + +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.Binary as Binary +import qualified Salmon.Builtin.Nodes.Cabal as Cabal +import qualified Salmon.Builtin.Nodes.Debian.OS as Debian +import qualified Salmon.Builtin.Nodes.Debian.Package as Debian +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Git as Git +import qualified Salmon.Builtin.Nodes.Rsync as Rsync +import qualified Salmon.Builtin.Nodes.Upx as Upx +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- +data Report + = Upload !FilePath !Rsync.Report + | Packing !Text !Upx.Report + | CallCabal !CabalTarget !Cabal.Report + | CallGit !CabalTarget !Git.Report + deriving (Show) + +isBuildSuccess :: Report -> Bool +isBuildSuccess r = case r of + (CallCabal _ (Cabal.CabalBuild _ cmd)) -> + Binary.isCommandSuccessful cmd + (CallCabal _ (Cabal.CabalInstall _ cmd)) -> + Binary.isCommandSuccessful cmd + otherwise -> False + +isReleaseSuccess :: Report -> Bool +isReleaseSuccess r = case r of + (CallCabal _ (Cabal.CabalUpload Cabal.Public _ cmd)) -> + Binary.isCommandSuccessful cmd + otherwise -> False + +------------------------------------------------------------------------------- + +cabalBinUpload :: Reporter Report -> Tracked' FilePath -> Rsync.Remote -> Tracked' FilePath +cabalBinUpload r mkbin remote = + mkbin `bindTracked` go + where + go localpath = + Tracked (Track $ const $ upload localpath) (remotePath localpath) + upload local = Rsync.sendFile (r' local) Debian.rsync (FS.PreExisting local) remote distpath + r' local = contramap (Upload local) r + distpath = "tmp/" + remotePath local = distpath takeFileName local + +microDNS :: Reporter Report -> BinaryDir -> Tracked' FilePath +microDNS r bindir = + cabalRepoBuild + r + "microdns" + bindir + realNoop + "microdns" + "microdns" + (Git.Remote "https://github.com/lucasdicioccio/microdns.git") + "main" + "" + [] + +kitchenSink :: Reporter Report -> BinaryDir -> Tracked' FilePath +kitchenSink r bindir = + cabalRepoBuild + r + "kitchensink" + bindir + realNoop + "exe:kitchen-sink" + "kitchen-sink" + (Git.Remote "https://github.com/kitchensink-tech/kitchensink.git") + "main" + "hs" + [] + +kitchenSink_dev :: Reporter Report -> Tracked' FilePath +kitchenSink_dev r = + cabalRepoBuild + r + "kitchensink-dev" + optBuildsBindir + realNoop + "exe:kitchen-sink" + "kitchen-sink" + (Git.Remote "/home/lucasdicioccio/code/opensource/kitchen-sink") + "main" + "hs" + [] + +postgrest :: Reporter Report -> Tracked' FilePath +postgrest r = + cabalRepoBuild + r + "postgrest" + optBuildsBindir + (Debian.deb $ Debian.Package "libpq-dev") + "exe:postgrest" + "postgrest" + (Git.Remote "https://github.com/PostgREST/postgrest.git") + "main" + "" + [] + +type CloneDir = Text +type BinaryDir = FilePath +type SDistDir = FilePath +type CabalTarget = Text +type SDistTarget = Text +type CabalBinaryName = Text -- may vary from target when exe: or lib: are prepended +type SubDir = FilePath -- subdir where we can cabal build + +optBuildsBindir :: BinaryDir +optBuildsBindir = "/opt/builds/bin" + +-- builds a binary in a cabal repository +cabalRepoBuild :: + Reporter Report -> + CloneDir -> + BinaryDir -> + Op -> + CabalTarget -> + CabalBinaryName -> + Git.Remote -> + Git.BranchName -> + SubDir -> + Cabal.CabalFlags -> + Tracked' FilePath +cabalRepoBuild r dirname bindir sysdeps target binname remote branch subdir flags = + Tracked (Track $ const $ op `inject` sysdeps) binpath + where + op = FS.withFile (Git.repofile mkrepo repo subdir) $ \repopath -> upxpack `inject` localInstall repopath + + localInstall repopath = Cabal.install (contramap (CallCabal target) r) cabal flags (Cabal.Cabal repopath target) bindir + binpath = bindir Text.unpack binname + repo = Git.Repo "./git-repos/" dirname remote (Git.Branch branch) + git = Debian.git + cabal = (Track $ \_ -> noop "preinstalled") + mkrepo = Track $ Git.repo (contramap (CallGit target) r) git + upxpack = Upx.pack (contramap (Packing binname) r) Debian.upx binpath + +-- builds a library in a cabal repository +cabalRepoOnlyBuild :: + Reporter Report -> + CloneDir -> + BinaryDir -> + Op -> + CabalTarget -> + Git.Remote -> + Git.BranchName -> + SubDir -> + Cabal.CabalFlags -> + Op +cabalRepoOnlyBuild r dirname bindir sysdeps target remote branch subdir flags = + op `inject` sysdeps + where + op = FS.withFile (Git.repofile mkrepo repo subdir) $ \repopath -> + Cabal.build (contramap (CallCabal target) r) cabal flags (Cabal.Cabal repopath target) + repo = Git.Repo "./git-repos/" dirname remote (Git.Branch branch) + git = Debian.git + cabal = (Track $ \_ -> noop "preinstalled") + mkrepo = Track $ Git.repo (contramap (CallGit target) r) git + +type VersionString = Text + +-- publishes a package on Hackage +publishHackage :: + Reporter Report -> + CloneDir -> + SDistDir -> + SDistTarget -> + CabalTarget -> + VersionString -> + Git.Remote -> + Git.BranchName -> + SubDir -> + Op +publishHackage r dirname sdistdir sdisttarget target version remote branch subdir = + uploadOp + where + tgzOp = FS.withFile (Git.repofile mkrepo repo subdir) $ \repopath -> + Cabal.sdist r' cabal (Cabal.Cabal repopath target) sdistdir + r' = contramap (CallCabal target) r + uploadOp = Cabal.upload r' cabal (Track $ const tgzOp) tgzpath + repo = Git.Repo "./git-repos/" dirname remote (Git.Branch branch) + git = Debian.git + cabal = (Track $ \_ -> noop "preinstalled") + mkrepo = Track $ Git.repo (contramap (CallGit target) r) git + tgzpath = sdistdir tgzname + tgzname = Text.unpack $ mconcat [sdisttarget, "-", version, ".tar.gz"] diff --git a/src/SreBox/DNSRegistration.hs b/src/SreBox/DNSRegistration.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/DNSRegistration.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE DeriveGeneric #-} + +module SreBox.DNSRegistration where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) + +import qualified Salmon.Builtin.CommandLine as CLI +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.Binary as Binary +import qualified Salmon.Builtin.Nodes.CronTask as CronTask +import qualified Salmon.Builtin.Nodes.Debian.OS as Debian +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Rsync as Rsync +import qualified Salmon.Builtin.Nodes.Self as Self +import qualified Salmon.Builtin.Nodes.Ssh as Ssh +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Track +import Salmon.Reporter +import SreBox.MicroDNS (DNSName, MicroDNSConfig (..), selfSignedCert, sharedToken) +import qualified SreBox.MicroDNS as MicroDNS + +------------------------------------------------------------------------------- +data Report + = UploadToken !Rsync.Report + | UploadPEM !Rsync.Report + | SelfSign !MicroDNS.Report + | MakeToken !MicroDNS.Report + | UploadSelf !Self.Report + | CallSelf !Self.Report + deriving (Show) + +------------------------------------------------------------------------------- + +data RegisteredMachineConfig + = RegisteredMachineConfig + { registration_machineName :: DNSName + , registration_cfg_local_token_path :: FilePath + , -- + registration_cfg_task_script :: FilePath + , registration_cfg_task_data_path_token :: FilePath + , registration_cfg_task_data_path_pem :: FilePath + } + +setupRegistration :: + forall directive. + (FromJSON directive, ToJSON directive) => + Reporter Report -> + Track' Ssh.Remote -> + Track' directive -> + Self.SelfPath -> + Self.Remote -> + MicroDNSConfig -> + RegisteredMachineConfig -> + (RegisteredMachineSetup -> directive) -> + Op +setupRegistration r mkRemote simulate selfpath selfRemote dns cfg toSpec = + op "registration" (deps [trackedGraph remoteRegistration, uploadPem, uploadToken]) id + where + rsyncRemote :: Rsync.Remote + rsyncRemote = (\(Self.Remote a b) -> Rsync.Remote a b) selfRemote + + tmpTokenPath :: FilePath + tmpTokenPath = "tmp/" <> Text.unpack cfg.registration_machineName <> "-registration.token" + + uploadToken = + Rsync.sendFile (contramap UploadToken r) Debian.rsync (FS.Generated mkToken cfg.registration_cfg_local_token_path) rsyncRemote tmpTokenPath + + tmpPemPath :: FilePath + tmpPemPath = "tmp/registration.pem" + + uploadPem = + Rsync.sendFile (contramap UploadPEM r) Debian.rsync (FS.Generated (selfSignedCert (contramap SelfSign r) dns) dns.microdns_cfg_pemPath) rsyncRemote tmpPemPath + + mkToken :: Track' FilePath + mkToken = Track $ \tokenPath -> + sharedToken (contramap MakeToken r) dns.microdns_cfg_secretPath cfg.registration_machineName tokenPath + + self = Self.uploadSelf (contramap UploadSelf r) "tmp" selfRemote selfpath + remoteRegistration = self `bindTracked` \ref -> Self.callSelfAsSudo (contramap CallSelf r) mkRemote ref simulate CLI.Up (toSpec regSetup) + + regSetup = + RegisteredMachineSetup + cfg.registration_machineName + tmpTokenPath + tmpPemPath + (cfg.registration_cfg_task_script) + (cfg.registration_cfg_task_data_path_token) + (cfg.registration_cfg_task_data_path_pem) + +data RegisteredMachineSetup + = RegisteredMachineSetup + { registration_name :: DNSName + , registration_token_tmppath :: FilePath + , registration_pem_tmppath :: FilePath + , -- where to copy to + registration_script_path :: FilePath + , registration_token_path :: FilePath + , registration_pem_path :: FilePath + } + deriving (Generic) + +instance FromJSON RegisteredMachineSetup +instance ToJSON RegisteredMachineSetup + +registerMachine :: RegisteredMachineSetup -> Op +registerMachine setup = + op "enrolled-machine" (deps [autoregister, movetoken, movepem, Binary.justInstall Debian.curl]) id + where + tokenPath = setup.registration_token_path + pemPath = setup.registration_pem_path + taskScript = setup.registration_script_path + + movetoken :: Op + movetoken = + FS.fileCopy setup.registration_token_tmppath tokenPath + + movepem :: Op + movepem = + FS.fileCopy setup.registration_pem_tmppath pemPath + + scriptcontents :: Text + scriptcontents = autoregisterscript setup + + autoregister :: Op + autoregister = + let + task = + CronTask.CronTask + ("register-dns_" <> setup.registration_name) + "root" + CronTask.everyMinute + "bash" + [ Text.pack taskScript + , Text.pack tokenPath + , setup.registration_name + , Text.pack pemPath + ] + in + CronTask.crontask ignoreTrack task `inject` FS.filecontents (FS.FileContents taskScript scriptcontents) + +autoregisterscript :: RegisteredMachineSetup -> Text +autoregisterscript setup = + Text.unlines + [ "#!/bin/bash" + , "" + , "hmacpath=$1" + , "regname=$2" + , "pempath=$3" + , "" + , "hmac=`cat ${hmacpath}`" + , "curl -XPOST \\" + , " --cacert \"${pempath}\"\\" + , " -H \"x-microdns-hmac: ${hmac}\" \\" + , " \"https://box.dicioccio.fr:65432/register/auto/${regname}\"" + ] diff --git a/src/SreBox/Environment.hs b/src/SreBox/Environment.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/Environment.hs @@ -0,0 +1,6 @@ +module SreBox.Environment where + +data Environment + = Production + | Staging + deriving (Show, Ord, Eq) diff --git a/src/SreBox/Gcp/CloudRunAlerts.hs b/src/SreBox/Gcp/CloudRunAlerts.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/Gcp/CloudRunAlerts.hs @@ -0,0 +1,133 @@ +{- | The standard alerts for one Cloud Run service, to one email address: +what an operator wants to hear about first, as one node. + +Four "Salmon.Builtin.Nodes.Gcp.Monitoring".@alertPolicy@ declarations on +one @notificationChannel@, each keyed on its own display name +(@\: 5xx ratio@ and so on) so that a service's alerts and another +service's are distinct resources while two declarations of one service's +are one: + +* the share of requests answered 5xx ('at_errorRatio', 5% by default), +* the 99th-percentile request latency ('at_latencyP99Ms', 2s), +* the 99th-percentile container memory utilisation + ('at_memoryUtilization', 90%), +* and, when the service has a @--max-instances@ ('cra_maxInstances'), + the active instance count reaching it, + +each having to hold for 'at_duration' seconds (5 minutes) before firing. + +Enabling @monitoring.googleapis.com@ is the caller's, as +@run.googleapis.com@ is for "SreBox.Gcp.CloudRunDeploy": a recipe does not +know what else the project's foundation has to come before. +-} +module SreBox.Gcp.CloudRunAlerts ( + AlertThresholds (..), + defaultAlertThresholds, + CloudRunAlertsConfig (..), + standardAlerts, + standardPolicies, + Report (..), +) where + +import Data.Text (Text) +import qualified Data.Text as Text + +import Salmon.Builtin.Extension +import Salmon.Builtin.Nodes.Binary (Binary) +import Salmon.Builtin.Nodes.Gcp.Core (Project (..), Region (..)) +import qualified Salmon.Builtin.Nodes.Gcp.Monitoring as Monitoring +import Salmon.Op.Ref +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- + +newtype Report + = RunMonitoring Monitoring.Report + deriving (Show) + +------------------------------------------------------------------------------- + +-- | Where each alert fires. See the module header for the defaults. +data AlertThresholds = AlertThresholds + { at_errorRatio :: Double + -- ^ 5xx over all requests, in @[0,1]@ + , at_latencyP99Ms :: Double + , at_memoryUtilization :: Double + -- ^ in @[0,1]@ + , at_duration :: Int + -- ^ seconds a condition must hold + } + deriving (Eq, Show) + +defaultAlertThresholds :: AlertThresholds +defaultAlertThresholds = + AlertThresholds + { at_errorRatio = 0.05 + , at_latencyP99Ms = 2000 + , at_memoryUtilization = 0.9 + , at_duration = 300 + } + +data CloudRunAlertsConfig = CloudRunAlertsConfig + { cra_project :: Project + , cra_region :: Region + , cra_service :: Text + , cra_email :: Text + -- ^ where the notifications go + , cra_channelName :: Text + -- ^ the channel's display name, shared by every service alerting to + -- the same address + , cra_maxInstances :: Maybe Int + -- ^ the service's @--max-instances@, if it has one: the instance-count + -- alert exists only then, and fires at that number + , cra_thresholds :: AlertThresholds + } + deriving (Eq, Show) + +-- | The channel and the policies, under one node. +standardAlerts :: Reporter Report -> Track' (Binary "gcloud") -> CloudRunAlertsConfig -> Op +standardAlerts r gcloudTrack cfg = + op "gcp-cloudrun-alerts" (deps (map (Monitoring.alertPolicy rMon gcloudTrack) (standardPolicies cfg))) $ \actions -> + actions + { help = Text.unwords ["the standard alerts for Cloud Run service", cfg.cra_service, "to", cfg.cra_email] + , ref = mkRef "gcp-cloudrun-alerts" (cfg.cra_project.projectId, cfg.cra_region.regionName, cfg.cra_service) + } + where + rMon = contramap RunMonitoring r + +-- | The policies 'standardAlerts' declares, for a test or a caller wanting +-- to add its own beside them. +standardPolicies :: CloudRunAlertsConfig -> [Monitoring.AlertPolicy] +standardPolicies cfg = + [ policy "5xx ratio" (Monitoring.ServerErrorRatio t.at_errorRatio t.at_duration) ("More than " <> percent t.at_errorRatio <> " of requests are answered 5xx.") + , policy "p99 latency" (Monitoring.RequestLatencyP99 t.at_latencyP99Ms t.at_duration) ("The 99th-percentile request latency is above " <> Text.pack (show t.at_latencyP99Ms) <> " ms.") + , policy "memory" (Monitoring.MemoryUtilization t.at_memoryUtilization t.at_duration) ("Container memory utilisation (p99) is above " <> percent t.at_memoryUtilization <> " of the limit.") + ] + <> [ policy "instances at max" (Monitoring.InstanceCount n t.at_duration) ("The service is running its maximum of " <> Text.pack (show n) <> " instances; requests may be queued or refused.") + | Just n <- [cfg.cra_maxInstances] + ] + where + t = cfg.cra_thresholds + channel = + Monitoring.NotificationChannel + { Monitoring.ncProject = cfg.cra_project + , Monitoring.ncDisplayName = cfg.cra_channelName + , Monitoring.ncKind = Monitoring.Email cfg.cra_email + } + target = + Monitoring.CloudRunTarget + { Monitoring.crtProject = cfg.cra_project + , Monitoring.crtRegion = cfg.cra_region + , Monitoring.crtService = cfg.cra_service + } + policy name condition doc = + Monitoring.AlertPolicy + { Monitoring.apProject = cfg.cra_project + , Monitoring.apDisplayName = cfg.cra_service <> ": " <> name + , Monitoring.apTarget = target + , Monitoring.apConditions = [condition] + , Monitoring.apChannels = [channel] + , Monitoring.apDocumentation = "Cloud Run service `" <> cfg.cra_service <> "` in " <> cfg.cra_region.regionName <> ": " <> doc + } + percent x = Text.pack (show (round (x * 100) :: Int)) <> "%" diff --git a/src/SreBox/Gcp/CloudRunDeploy.hs b/src/SreBox/Gcp/CloudRunDeploy.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/Gcp/CloudRunDeploy.hs @@ -0,0 +1,144 @@ +{- | Bootstraps a podman image onto CloudRun: builds it, pushes it to +Artifact Registry, and deploys it -- the piece +"Salmon.Builtin.Nodes.Gcp.CloudRun".@cloudRunService@ explicitly says it +does not do itself ("a CloudRun service node does not build or push +images. It depends on an upstream node that pushes a Podman-built image to +Artifact Registry"), and which nothing before this module provided. + +The image is tagged, pushed, and deployed under __one__ fully-qualified +Artifact Registry reference (see "Salmon.Builtin.Nodes.Podman".@push@'s own +note) so there is exactly one string in this whole pipeline that means "the +image" -- 'crd_image' -- rather than a local tag and a remote ref that a +caller has to keep in sync by hand. + +Authentication goes through "Salmon.Builtin.Nodes.Podman".@login@ against +an explicit, caller-chosen 'Podman.AuthFile' ('crd_authFile') rather than +@gcloud auth configure-docker@'s ambient, user-global Docker credential +store: two concurrent salmon processes deploying under two different GCP +identities to the same registry would otherwise race on that one shared +file. Picking two different 'crd_authFile' paths makes that race +impossible rather than merely unlikely -- see 'Podman.AuthFile'’s own note. +-} +module SreBox.Gcp.CloudRunDeploy ( + CloudRunDeployConfig (..), + buildPushDeploy, + Report (..), +) where + +import Data.Map (Map) +import Data.Text (Text) +import qualified Data.Text as Text + +import Salmon.Builtin.Extension +import Salmon.Builtin.Nodes.Binary (Binary) +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Gcp.ArtifactRegistry as ArtifactRegistry +import qualified Salmon.Builtin.Nodes.Gcp.CloudRun as CloudRun +import qualified Salmon.Builtin.Nodes.Gcp.Core as Core +import Salmon.Builtin.Nodes.Gcp.Core (Project, Region) +import qualified Salmon.Builtin.Nodes.Podman as Podman +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- + +data Report + = RunArtifactRegistry !ArtifactRegistry.Report + | RunPodman !Podman.Report + | RunCloudRun !CloudRun.Report + deriving (Show) + +------------------------------------------------------------------------------- + +{- | Everything needed to go from a Containerfile to a running CloudRun +revision. +-} +data CloudRunDeployConfig = CloudRunDeployConfig + { crd_repo :: ArtifactRegistry.ArtifactRepo + -- ^ the Artifact Registry repository the image is pushed to; created + -- (idempotently) as part of this pipeline rather than assumed to exist. + , crd_authFile :: Podman.AuthFile + -- ^ where podman login writes credentials for this deploy's push -- + -- give two concurrent deploys (e.g. two tenants, or two identities + -- against the same registry) two different paths. + , crd_containerfile :: FS.File "containerfile" + , crd_image :: Text + -- ^ the fully-qualified image reference, e.g. + -- @us-docker.pkg.dev\/my-project\/my-repo\/my-image:my-tag@ -- used + -- unchanged as the podman build tag, the podman push target, and + -- 'CloudRun.crsImage'. + , crd_service :: Text + , crd_project :: Project + , crd_region :: Region + , crd_env :: Map Text Text + , crd_serviceAccount :: Text + , crd_ingress :: CloudRun.IngressSetting + , crd_maxInstances :: Maybe Int + , crd_options :: CloudRun.CloudRunOptions + -- ^ secrets, cpu/memory, concurrency, port; 'CloudRun.defaultCloudRunOptions' + -- is the deploy this recipe made before any of them existed. + } + +-- | Builds, pushes, and deploys 'crd_image' as 'crd_service'. +buildPushDeploy :: + Reporter Report -> + Track' (Binary "gcloud") -> + Track' (Binary "podman") -> + CloudRunDeployConfig -> + Op +buildPushDeploy r gcloudTrack podmanTrack cfg = + op "gcp-cloudrun-deploy" (deps [deployed]) $ \actions -> + actions + { help = Text.unwords ["builds, pushes and deploys", cfg.crd_image, "as CloudRun service", cfg.crd_service] + , ref = mkRef "gcp-cloudrun-deploy" (cfg.crd_service, cfg.crd_image) + } + where + rAr = contramap RunArtifactRegistry r + rPodman = contramap RunPodman r + rCloudRun = contramap RunCloudRun r + + -- Artifact Registry's docker/podman-facing hostname for the repo's own + -- location -- not the Cloud Run region: a repository in one location + -- serving services deployed in another is ordinary (one registry, many + -- regions), and logging in to the region's host would leave the push to + -- the repo's host unauthenticated. + registry :: Podman.Registry + registry = Podman.Registry (cfg.crd_repo.repoLocation.regionName <> "-docker.pkg.dev") + + repo :: Op + repo = ArtifactRegistry.artifactRepository rAr gcloudTrack cfg.crd_repo + + loggedIn :: Op + loggedIn = + Podman.login rPodman podmanTrack cfg.crd_authFile registry (Podman.Username "oauth2accesstoken") Core.printAccessToken + `inject` repo + + built :: Op + built = Podman.buildImage rPodman podmanTrack cfg.crd_containerfile cfg.crd_image + + pushed :: Op + pushed = + Podman.push rPodman podmanTrack (Just cfg.crd_authFile) cfg.crd_image + `inject` built + `inject` loggedIn + + deployed :: Op + deployed = + CloudRun.cloudRunService + rCloudRun + gcloudTrack + ( CloudRun.CloudRunService + { CloudRun.crsName = cfg.crd_service + , CloudRun.crsProject = cfg.crd_project + , CloudRun.crsRegion = cfg.crd_region + , CloudRun.crsImage = cfg.crd_image + , CloudRun.crsEnv = cfg.crd_env + , CloudRun.crsServiceAccount = cfg.crd_serviceAccount + , CloudRun.crsIngress = cfg.crd_ingress + , CloudRun.crsMaxInstances = cfg.crd_maxInstances + , CloudRun.crsOptions = cfg.crd_options + } + ) + `inject` pushed diff --git a/src/SreBox/Gcp/PostgrestCloudRun.hs b/src/SreBox/Gcp/PostgrestCloudRun.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/Gcp/PostgrestCloudRun.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | PostgREST on Cloud Run, talking to a Postgres somewhere else over a +client certificate. + +This is +expressed as ops: an image, four secrets, the IAM that lets the service read +them, and a deploy. The database half — what makes that certificate mean +anything — is "SreBox.PostgresTls", and the two are designed to be used +together: 'pcr_role' here and +'SreBox.PostgresTls.ca_role' there are the same string, which is also the +@CN@ of the certificate, which is what @clientcert=verify-full@ compares. + += The wrinkle that makes this a recipe rather than a deploy command + +Cloud Run mounts secrets __read-only, owned by root, mode 0444__, and there +is no way to ask for anything else. @libpq@ refuses to use a client key +whose mode is wider than @0600@ and says so in a message about file +permissions that mentions neither Cloud Run nor the secret. So the container +cannot use a mounted key directly, and the way through is an entrypoint that +copies the mounted files somewhere writable and narrows them before exec'ing +the real binary. 'renderEntrypoint' is that script, and it is the reason a +stock @postgrest@ image will not do. + += What is deliberately not here + +No database roles, grants or migrations: those are PostgREST's real +difficulty and they belong to whoever owns the schema +("SreBox.PostgresInit" and "SreBox.PostgresMigrations" are the tools). This +module gets a correctly-configured PostgREST talking to a database; what it +is allowed to see once it arrives is somebody else's design. +-} +module SreBox.Gcp.PostgrestCloudRun ( + Report (..), + PostgrestCloudRunConfig (..), + postgrestCloudRun, + + -- * The image + renderContainerfile, + renderEntrypoint, + + -- * The deploy's shape, exposed for inspection and testing + secretBindings, + environment, + + -- * Where things land inside the container + vaultDir, + secretsDir, + mountedMaterial, + runtimeMaterial, + + -- * Secret names + certSecretName, + keySecretName, + caSecretName, + jwtSecretName, +) where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as Text +import System.FilePath (()) + +import Salmon.Builtin.Extension +import Salmon.Builtin.Nodes.Binary (Binary) +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Gcp.ArtifactRegistry as ArtifactRegistry +import qualified Salmon.Builtin.Nodes.Gcp.CloudRun as CloudRun +import qualified Salmon.Builtin.Nodes.Gcp.Core as Core +import qualified Salmon.Builtin.Nodes.Gcp.Iam as Iam +import qualified Salmon.Builtin.Nodes.Gcp.SecretManager as SecretManager +import qualified Salmon.Builtin.Nodes.Podman as Podman +import qualified Salmon.Builtin.Nodes.Postgres as Postgres +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track +import Salmon.Reporter + +import qualified SreBox.Gcp.CloudRunDeploy as CloudRunDeploy +import qualified SreBox.PostgresTls as Tls + +------------------------------------------------------------------------------- + +data Report + = UploadSecret !SecretManager.Report + | GrantAccess !Iam.Report + | Deploy !CloudRunDeploy.Report + deriving (Show) + +------------------------------------------------------------------------------- + +data PostgrestCloudRunConfig = PostgrestCloudRunConfig + { pcr_service :: Text + , pcr_project :: Core.Project + , pcr_region :: Core.Region + , pcr_serviceAccount :: Text + -- ^ the service account the revision runs as, and the principal granted + -- @secretAccessor@ on each secret below + , pcr_repo :: ArtifactRegistry.ArtifactRepo + , pcr_image :: Text + -- ^ fully-qualified image reference, tag included + , pcr_authFile :: Podman.AuthFile + , pcr_workDir :: FilePath + -- ^ where the generated @Containerfile@ and @run.sh@ are written + , pcr_postgrestImage :: Text + -- ^ the upstream image the binary is copied out of, e.g. + -- @postgrest\/postgrest:v12.2.1@. Pinned, not @latest@: this is the + -- thing that decides how your JWT claims are read. + , pcr_db :: Postgres.Server + , pcr_database :: Postgres.DatabaseName + , pcr_role :: Postgres.RoleName + -- ^ the authenticator role; also the @CN@ of the client certificate + , pcr_anonRole :: Text + , pcr_jwtRoleClaimKey :: Maybe Text + , pcr_schemas :: Maybe Text + , pcr_sslMode :: Tls.SslMode + , pcr_clientMaterial :: (FilePath, FilePath, FilePath) + -- ^ local (certificate, key, CA certificate) — typically + -- 'SreBox.PostgresTls.clientMaterialPaths' of the material this same + -- graph generated + , pcr_jwtSecretFile :: Maybe FilePath + -- ^ a local file holding the JWT signing secret. This recipe does not + -- create it: see "SreBox.JWTSigning" or + -- "Salmon.Builtin.Nodes.Secrets".@sharedSecretFile@. + , pcr_ingress :: CloudRun.IngressSetting + , pcr_maxInstances :: Maybe Int + , pcr_cpu :: Maybe Text + , pcr_memory :: Maybe Text + , pcr_concurrency :: Maybe Int + , pcr_allowUnauthenticated :: Bool + } + +------------------------------------------------------------------------------- + +{- | Uploads the credentials, grants the service account access to them, +builds the wrapper image and deploys it. + +The deploy is injected onto every secret and every binding, which is the +ordering that matters: a revision naming a secret that does not exist yet +fails to start, and one naming a secret it may not read fails at the first +connection instead — later, and much less legibly. +-} +postgrestCloudRun :: + Reporter Report -> + Track' (Binary "gcloud") -> + Track' (Binary "podman") -> + PostgrestCloudRunConfig -> + Op +postgrestCloudRun r gcloudTrack podmanTrack cfg = + op "gcp-postgrest-cloudrun" (deps [deploy]) $ \actions -> + actions + { help = Text.unwords ["deploys PostgREST", cfg.pcr_service, "against", cfg.pcr_database] + , ref = mkRef "gcp-postgrest-cloudrun" (cfg.pcr_project.projectId, cfg.pcr_service) + } + where + rSecret = contramap UploadSecret r + rIam = contramap GrantAccess r + rDeploy = contramap Deploy r + + (localCert, localKey, localCa) = cfg.pcr_clientMaterial + + deploy :: Op + deploy = + foldl + inject + ( CloudRunDeploy.buildPushDeploy + rDeploy + gcloudTrack + podmanTrack + CloudRunDeploy.CloudRunDeployConfig + { CloudRunDeploy.crd_repo = cfg.pcr_repo + , CloudRunDeploy.crd_authFile = cfg.pcr_authFile + , CloudRunDeploy.crd_containerfile = containerfile + , CloudRunDeploy.crd_image = cfg.pcr_image + , CloudRunDeploy.crd_service = cfg.pcr_service + , CloudRunDeploy.crd_project = cfg.pcr_project + , CloudRunDeploy.crd_region = cfg.pcr_region + , CloudRunDeploy.crd_env = environment cfg + , CloudRunDeploy.crd_serviceAccount = cfg.pcr_serviceAccount + , CloudRunDeploy.crd_ingress = cfg.pcr_ingress + , CloudRunDeploy.crd_maxInstances = cfg.pcr_maxInstances + , CloudRunDeploy.crd_options = + CloudRun.defaultCloudRunOptions + { CloudRun.croSecrets = secretBindings cfg + , CloudRun.croCpu = cfg.pcr_cpu + , CloudRun.croMemory = cfg.pcr_memory + , CloudRun.croConcurrency = cfg.pcr_concurrency + , CloudRun.croAllowUnauthenticated = cfg.pcr_allowUnauthenticated + } + } + `inject` entrypoint + ) + (secretsAndGrants <> [entrypoint]) + + -- The entrypoint is COPY'd by the Containerfile, so it has to exist + -- before the build, not merely before the deploy. + entrypoint :: Op + entrypoint = + FS.filecontents (FS.FileContents (cfg.pcr_workDir "run.sh") (renderEntrypoint cfg)) + + containerfile :: FS.File "containerfile" + containerfile = + FS.generateFileContents (renderContainerfile cfg) (cfg.pcr_workDir "Containerfile") + + secretsAndGrants :: [Op] + secretsAndGrants = + concat + [ uploaded (certSecretName cfg) localCert + , uploaded (keySecretName cfg) localKey + , uploaded (caSecretName cfg) localCa + , maybe [] (uploaded (jwtSecretName cfg)) cfg.pcr_jwtSecretFile + ] + + uploaded :: Text -> FilePath -> [Op] + uploaded name source = + [ version + , -- Without this the revision deploys happily and then fails to + -- start, because a service account has no access to a project's + -- secrets by virtue of being in the project. + Iam.iamBinding + rIam + gcloudTrack + (Iam.IamBinding (Iam.ServiceAccount cfg.pcr_serviceAccount) "roles/secretmanager.secretAccessor" resource) + `inject` version + ] + where + sec = + SecretManager.Secret + { SecretManager.secretName = name + , SecretManager.secretProject = cfg.pcr_project + , SecretManager.secretReplication = "automatic" + } + version = + SecretManager.secretVersion rSecret gcloudTrack (SecretManager.SecretVersion sec source) + resource = + Text.intercalate "/" ["projects", cfg.pcr_project.projectId, "secrets", name] + +------------------------------------------------------------------------------- +-- Names and paths + +certSecretName, keySecretName, caSecretName, jwtSecretName :: PostgrestCloudRunConfig -> Text +certSecretName cfg = cfg.pcr_service <> "-db-cert" +keySecretName cfg = cfg.pcr_service <> "-db-key" +caSecretName cfg = cfg.pcr_service <> "-db-ca" +jwtSecretName cfg = cfg.pcr_service <> "-jwt" + +{- | Where Cloud Run mounts the secrets: read-only, root-owned, @0444@, and +not changeable. +-} +vaultDir :: FilePath +vaultDir = "/opt/vault" + +-- | Where 'renderEntrypoint' copies them so libpq will accept them. +secretsDir :: FilePath +secretsDir = "/opt/secrets" + +-- | (certificate, key, CA) as mounted. +mountedMaterial :: (FilePath, FilePath, FilePath) +mountedMaterial = + (vaultDir "cert.pem", vaultDir "key.pem", vaultDir "ca.pem") + +-- | (certificate, key, CA) as the connection string names them. +runtimeMaterial :: (FilePath, FilePath, FilePath) +runtimeMaterial = + (secretsDir "cert.pem", secretsDir "key.pem", secretsDir "ca.pem") + +------------------------------------------------------------------------------- +-- The deploy's shape + +secretBindings :: PostgrestCloudRunConfig -> [CloudRun.SecretBinding] +secretBindings cfg = + [ CloudRun.SecretFile mCert (certSecretName cfg) "latest" + , CloudRun.SecretFile mKey (keySecretName cfg) "latest" + , CloudRun.SecretFile mCa (caSecretName cfg) "latest" + ] + <> maybe + [] + -- The JWT secret is an env var rather than a file because that is + -- what PostgREST reads; it is also the one credential here that a + -- crash report could leak, which is an argument for the file form + -- and PGRST_JWT_SECRET_FILE if your version supports it. + (const [CloudRun.SecretEnvVar "PGRST_JWT_SECRET" (jwtSecretName cfg) "latest"]) + cfg.pcr_jwtSecretFile + where + (mCert, mKey, mCa) = mountedMaterial + +environment :: PostgrestCloudRunConfig -> Map Text Text +environment cfg = + Map.fromList $ + [ ("PGRST_DB_URI", Tls.clientConnString cfg.pcr_db cfg.pcr_database cfg.pcr_role cfg.pcr_sslMode runtimeMaterial) + , ("PGRST_DB_ANON_ROLE", cfg.pcr_anonRole) + ] + <> catMaybes + [ (,) "PGRST_JWT_ROLE_CLAIM_KEY" <$> cfg.pcr_jwtRoleClaimKey + , (,) "PGRST_DB_SCHEMAS" <$> cfg.pcr_schemas + ] + +------------------------------------------------------------------------------- +-- The image + +{- | A two-stage build: the upstream PostgREST binary, on a base that has +@libpq@ and a shell. + +Copying the binary out rather than deriving @FROM@ the upstream image is what +makes room for the entrypoint — the upstream image is deliberately minimal +and has neither the shell nor the tools the copy-and-chmod dance needs. +-} +renderContainerfile :: PostgrestCloudRunConfig -> Text +renderContainerfile cfg = + Text.unlines + [ "FROM " <> cfg.pcr_postgrestImage <> " AS upstream" + , "" + , "FROM debian:bookworm-slim" + , "RUN apt-get update \\" + , " && apt-get install -y --no-install-recommends libpq5 ca-certificates \\" + , " && rm -rf /var/lib/apt/lists/*" + , "COPY --from=upstream /bin/postgrest /bin/postgrest" + , "COPY run.sh /run.sh" + , "RUN chmod 0755 /run.sh" + , "ENTRYPOINT [\"/bin/bash\", \"/run.sh\"]" + ] + +{- | The entrypoint: copy the mounted secrets somewhere writable, narrow +them, hand the port over, exec PostgREST. + +Every line of it is load-bearing: + +* @cp -L@ dereferences, because a Cloud Run secret mount is a symlink farm + into a @..data@ directory and copying the links would copy the permissions + with them. +* the @chmod@ is the entire point (see the module header): @0600@ on the + files, because libpq refuses anything wider, and @0700@ on the directory + because there is no reason to be less careful about it. +* @PGRST_SERVER_PORT@ is taken from @$PORT@, which is Cloud Run's side of + the contract and is not necessarily the port anyone configured. +* @exec@, so PostgREST is PID 1 and receives the @SIGTERM@ Cloud Run sends + when it drains an instance. Without it the shell gets the signal, the + server does not, and every deploy ends in a ten-second kill instead of a + clean shutdown. +-} +renderEntrypoint :: PostgrestCloudRunConfig -> Text +renderEntrypoint _cfg = + Text.unlines + [ "#!/bin/bash" + , "set -euo pipefail" + , "" + , "# Cloud Run mounts secrets read-only at 0444 and there is no way to ask" + , "# for anything else; libpq refuses a client key wider than 0600. So the" + , "# credentials are copied somewhere writable before they are used." + , "mkdir -p " <> Text.pack secretsDir + , "cp -L " <> Text.pack vaultDir <> "/* " <> Text.pack secretsDir <> "/" + , "chmod 0700 " <> Text.pack secretsDir + , "find " <> Text.pack secretsDir <> " -type f -exec chmod 0600 {} +" + , "" + , "# Cloud Run decides the port, not the configuration." + , "export PGRST_SERVER_PORT=\"${PORT:-3000}\"" + , "export PGRST_SERVER_HOST='*4'" + , "" + , "exec /bin/postgrest" + ] diff --git a/src/SreBox/Gcp/PreviewEnvironment.hs b/src/SreBox/Gcp/PreviewEnvironment.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/Gcp/PreviewEnvironment.hs @@ -0,0 +1,104 @@ +{- | Composes several 'CloudRunDeploy.CloudRunDeployConfig's (api, proxy, +webapp -- or however many a caller has) into __one__ named node: a preview +environment. + +"SreBox.Gcp.CloudRunDeploy".@buildPushDeploy@ already builds, pushes and +deploys a single service. Nothing before this module gave a caller one +thing to point @run up@/@run down@/@run tree@ at for "every service this +branch's preview needs" -- each service was its own independent 'Op', so +standing one up or tearing one down meant naming each of them by hand and +keeping that list in sync by hand too. + +This is deliberately thin and deliberately generic: it knows nothing about +which services a preview environment needs are called api/proxy/webapp, or +about koli. It is a list of named deploys plus an environment name, folded +into one 'Op' whose dependencies are exactly those deploys. Teardown falls +out of the ordinary DAG semantics ("Salmon.Actions.UpDown": a node comes +down only after everything depending on it has) -- @run down@ against the +environment's own ref tears down every service it composes, in one pass, +provided nothing else in the graph still depends on one of them. + +The environment name (typically derived from a git branch -- see the +sibling koli repo's preview-env glue script) is folded into every member +service's own name by the __caller__, not by this module: 'CloudRunDeployConfig' +already carries 'crd_service', and two preview environments must not collide +on one Cloud Run service name. This module only groups whatever +already-uniquely-named configs it is handed. +-} +module SreBox.Gcp.PreviewEnvironment ( + PreviewService (..), + PreviewEnvironment (..), + previewEnvironment, + Report (..), +) where + +import Data.Text (Text) +import qualified Data.Text as Text + +import Salmon.Builtin.Extension +import Salmon.Builtin.Nodes.Binary (Binary) +import qualified Salmon.Builtin.Nodes.Gcp.Core as Core +import Salmon.Op.Ref +import Salmon.Op.Track +import Salmon.Reporter + +import SreBox.Gcp.CloudRunDeploy (CloudRunDeployConfig, buildPushDeploy) +import qualified SreBox.Gcp.CloudRunDeploy as CloudRunDeploy + +------------------------------------------------------------------------------- + +data Report + = RunService Text CloudRunDeploy.Report + deriving (Show) + +------------------------------------------------------------------------------- + +-- | One service belonging to a preview environment, named for reporting +-- (e.g. @"api"@, @"proxy"@, @"webapp"@) -- independent of 'crd_service', +-- which is the actual Cloud Run service name and must already be unique +-- per environment. +data PreviewService = PreviewService + { psRole :: Text + , psDeploy :: CloudRunDeployConfig + } + +{- | A named group of services making up one short-lived preview +environment (typically one per branch/PR). + +'peProject'/'peRegion' are carried here only for the node's own @ref@/@help@ +text (each member config already carries its own project/region, which is +what actually gets deployed to) -- most callers will pass the same project +and region for every member, but this module does not enforce that. +-} +data PreviewEnvironment = PreviewEnvironment + { peName :: Text + -- ^ the environment's name, e.g. @"preview-" <> sanitizedBranch@ + , peProject :: Core.Project + , peRegion :: Core.Region + , peServices :: [PreviewService] + } + +-- | Builds, pushes and deploys every member service, grouped under one ref. +previewEnvironment :: + Reporter Report -> + Track' (Binary "gcloud") -> + Track' (Binary "podman") -> + PreviewEnvironment -> + Op +previewEnvironment r gcloudTrack podmanTrack env = + op "gcp-preview-environment" (deps (map deployOne env.peServices)) $ \actions -> + actions + { help = Text.unwords ["preview environment", env.peName, "(" <> Text.intercalate ", " roleNames <> ")"] + , notes = + [ "torn down as a unit: `run down` on this node's ref tears down every" + <> " service it composes, provided nothing else in the graph still" + <> " depends on one of them" + ] + , ref = mkRef "gcp-preview-environment" (env.peProject.projectId, env.peRegion.regionName, env.peName) + } + where + roleNames = map psRole env.peServices + + deployOne :: PreviewService -> Op + deployOne svc = + buildPushDeploy (contramap (RunService svc.psRole) r) gcloudTrack podmanTrack svc.psDeploy diff --git a/src/SreBox/Gcp/VmProvision.hs b/src/SreBox/Gcp/VmProvision.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/Gcp/VmProvision.hs @@ -0,0 +1,206 @@ +{- | Turns up a GCE instance and then runs a Salmon binary on it over SSH, +composing the builtins under "Salmon.Builtin.Nodes.Gcp" with the existing +'Self.uploadAndCallSelfAsSudo' machinery -- the piece @specs/gcloud-support.md@ +section 6 calls "the objective" and which nothing before this module actually +wired up. + +The SSH trust model is plan section 5's Option B (project-metadata SSH-CA): +we generate an SSH CA once with "Salmon.Builtin.Nodes.Keys" (so its private +key is treated like any other salmon-managed secret, per section 14, rather +than a bare 'FilePath' the caller has to have produced out of band), push the +CA's public key into project metadata with +'Salmon.Builtin.Nodes.Gcp.SshAccess.installMetadataCaKey', and sign a +short-lived client certificate for the connecting user with 'Keys.signKey'. +'Keys.signKey' writes that certificate next to the client's private key as +@\-cert.pub@, which is exactly the name @ssh -i \@ auto-loads, so +'SshAccess.sshAvailable' probing with that private key exercises the same +certificate the eventual @ssh@ call to run the self binary will use. + +Dependency shape: the self-upload-and-call step depends on 'sshAvailable' +succeeding (and on every 'vmp_beforeCall' node, which in turn depends on it) (plan section 4's own recommendation, not followed by its section +6 pseudocode) rather than only on the instance's GCE-level @RUNNING@ status, +because @RUNNING@ says nothing about sshd being reachable yet. +-} +module SreBox.Gcp.VmProvision ( + VmProvisionConfig (..), + provisionedVm, + Report (..), +) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import qualified Data.Text as Text + +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.CommandLine as CLI +import Salmon.Builtin.Nodes.Binary (Binary) +import qualified Salmon.Builtin.Nodes.Gcp.Compute as Compute +import qualified Salmon.Builtin.Nodes.Gcp.SshAccess as SshAccess +import Salmon.Builtin.Nodes.Keys (SSHKeyPair) +import qualified Salmon.Builtin.Nodes.Keys as Keys +import qualified Salmon.Builtin.Nodes.Self as Self +import qualified Salmon.Builtin.Nodes.Ssh as Ssh +import System.FilePath (takeDirectory, ()) +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- + +data Report + = RunCompute !Compute.Report + | RunSshAccess !SshAccess.Report + | RunKeys !Keys.Report + | RunSelf !Self.Report + deriving (Show) + +------------------------------------------------------------------------------- + +{- | Everything needed to bring up a GCE VM over SSH and hand it the rest of +its setup as a @directive@, run by a re-uploaded copy of the calling binary. + +The SSH endpoint (host/port/user) is supplied by the caller rather than +derived from the 'Compute.Instance', mirroring +@specs/gcloud-support.md@ section 6's own signature: an ephemeral instance's +address generally is not known until after 'up' runs, so a recipe that needs +one has to either reserve a static address up front or thread it through +some other channel -- deriving it here would just move that problem, not +solve it. +-} +data VmProvisionConfig directive = VmProvisionConfig + { vmp_name :: Text + -- ^ a unique name for this provisioning declaration, used as the 'Ref' key. + , vmp_instance :: Compute.Instance + , vmp_ca :: SSHKeyPair + -- ^ the CA whose public key is pushed into project metadata; instances + -- must be configured (e.g. via a startup script writing @sshd_config@'s + -- @TrustedUserCAKeys@) to trust it, which is outside this module's scope. + , vmp_clientIdentity :: SSHKeyPair + -- ^ the key salmon connects with, signed by 'vmp_ca'. + , vmp_sshUser :: Text + , vmp_sshHost :: Text + , vmp_sshPort :: Int + , vmp_prerequisites :: [Op] + -- ^ nodes that must be up /before the instance is created/ -- a + -- startup-script file the instance's metadata points at, a firewall rule + -- its sshd needs, the address it claims. They inject into the instance + -- rather than into this recipe's root, because a root only orders itself + -- after both, which would let the instance boot first. + , vmp_beforeCall :: Ssh.ClientOpts -> [Op] + -- ^ nodes that must be up /after ssh answers and before the self binary + -- runs/ -- files the remote directive will read once it is there + -- (migrations, generated secrets), uploaded with the same signed key + -- and known-hosts file this recipe connects with, which is why they are + -- handed the 'Ssh.ClientOpts' rather than left to find them. Each one + -- depends on the ssh probe and the remote call depends on each of them. + -- @const []@ when nothing needs to precede the call. + , vmp_remoteDir :: FilePath + -- ^ where the self binary is uploaded on the VM. + , vmp_selfPath :: Self.SelfPath + , vmp_directiveTrack :: Track' directive + , vmp_directive :: directive + } + +{- | How this recipe's ssh, rsync and probe all authenticate: the signed +client key, and a known-hosts file kept beside it rather than in the calling +user's @~\/.ssh@. + +The second half matters as much as the first. These machines are disposable +and their addresses are not: rebuild a VM behind a reserved IP and every +later connection fails with @REMOTE HOST IDENTIFICATION HAS CHANGED@ against +the entry the /previous/ machine left behind. Keeping the file next to the +key scopes that record to this recipe (and lets +'SshAccess.sshAvailable' clear a stale entry when it sees one), instead of +leaving a landmine in a file the operator shares with everything else. +-} +clientOpts :: VmProvisionConfig directive -> Ssh.ClientOpts +clientOpts cfg = + Ssh.ClientOpts + { Ssh.optIdentity = Just key + , Ssh.optKnownHosts = Just (takeDirectory key "known_hosts") + } + where + key = Keys.privateKeyPath cfg.vmp_clientIdentity + +{- | Creates the instance, installs SSH-CA trust, waits for SSH to answer, +then uploads and runs a copy of the calling binary against 'vmp_directive'. +-} +provisionedVm :: + forall directive. + (FromJSON directive, ToJSON directive) => + Reporter Report -> + Track' (Binary "gcloud") -> + Track' (Binary "ssh-keygen") -> + VmProvisionConfig directive -> + Op +provisionedVm r gcloudTrack keygenTrack cfg = + op "gcp-vm-provision" (deps [foldl inject (trackedGraph call) (sshReady : beforeCall)]) $ \actions -> + actions + { help = Text.unwords ["provisions GCE VM", cfg.vmp_instance.instanceName, "over SSH and runs the self binary on it"] + , ref = mkRef "gcp-vm-provision" cfg.vmp_name + } + where + rCompute = contramap RunCompute r + rSshAccess = contramap RunSshAccess r + rKeys = contramap RunKeys r + rSelf = contramap RunSelf r + + -- The CA's public key has to be in project metadata *before* the + -- instance boots: the instance's startup script reads it from there to + -- set sshd's TrustedUserCAKeys, and a boot that happens first trusts + -- nobody until the next one. + vm :: Op + vm = + foldl + inject + (Compute.gceInstance rCompute gcloudTrack cfg.vmp_instance) + (sshCa : cfg.vmp_prerequisites) + + caKey :: Op + caKey = Keys.sshKey rKeys keygenTrack cfg.vmp_ca + + sshCa :: Op + sshCa = + SshAccess.installMetadataCaKey + rSshAccess + gcloudTrack + (SshAccess.MetadataSshCa cfg.vmp_instance.instanceProject (Keys.publicKeyPath cfg.vmp_ca)) + `inject` caKey + + signedClient :: Op + signedClient = + Keys.signKey + rKeys + keygenTrack + (Keys.SSHCertificateAuthority cfg.vmp_ca) + (Keys.KeyIdentifier cfg.vmp_sshUser) + [Keys.Principal cfg.vmp_sshUser] + cfg.vmp_clientIdentity + + sshReady :: Op + sshReady = + SshAccess.sshAvailable + rSshAccess + (SshAccess.SshEndpoint (Just cfg.vmp_sshUser) cfg.vmp_sshHost cfg.vmp_sshPort (clientOpts cfg)) + `inject` vm + `inject` signedClient + + beforeCall :: [Op] + beforeCall = [step `inject` sshReady | step <- cfg.vmp_beforeCall (clientOpts cfg)] + + call :: Tracked' (Self.RemoteCall directive) + call = + -- The key this recipe just had signed lives at a path of its own + -- choosing, which ssh has no reason to offer otherwise. + Self.uploadAndCallSelfAsSudoWith + (clientOpts cfg) + rSelf + rSelf + cfg.vmp_remoteDir + (Self.Remote cfg.vmp_sshUser cfg.vmp_sshHost) + cfg.vmp_selfPath + Ssh.preExistingRemoteMachine + cfg.vmp_directiveTrack + CLI.Up + cfg.vmp_directive diff --git a/src/SreBox/Initialize.hs b/src/SreBox/Initialize.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/Initialize.hs @@ -0,0 +1,82 @@ +module SreBox.Initialize where + +import Data.Text (Text) +import qualified Data.Text as Text + +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.Debian.OS as Debian +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.User as User +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Track +import Salmon.Reporter + +-- | @authorizedKey@, if provided, is the literal contents of a public key +-- (e.g. an @id_ed25519.pub@ line) to allow to log in as the salmon user. +-- Reading it from a file is the caller's job (typically the seed\/Configure +-- step, on the commanding machine) -- this recipe only ever sees key material +-- it's handed, matching every other recipe's key-exchange-agnostic stance. +initialize :: Reporter User.Report -> Maybe Text -> Op +initialize r authorizedKey = + op "initialize" (deps [sudoerfile, tmpdir, passwordlessUser, homeOwnership]) id + where + sudoerfile :: Op + sudoerfile = + FS.filecontents + (FS.FileContents "/etc/sudoers.d/salmon" sudoercontent) + + sudoercontent :: Text + sudoercontent = + Text.unlines + [ Text.unwords + [ "salmon" + , "ALL=(ALL)" + , "NOPASSWD:" + , "ALL" + ] + ] + + sudoUser :: Op + sudoUser = User.user r Debian.useradd mkGroup (User.NewUser user [sudo]) + + passwordlessUser :: Op + passwordlessUser = User.passwordless r Debian.usermod mkUser user + + -- chowned recursively and last, so it also covers .ssh/authorized_keys + -- if 'authorizedKeyOp' created it. + homeOwnership :: Op + homeOwnership = + maybe id (flip inject) authorizedKeyOp $ + User.chown r Debian.chown True (User.Owner user salmonGroup) "/home/salmon" `inject` tmpdir + + -- forced to run after 'homeDir', rather than relying on `mkdir -p` + -- implicitly creating /home/salmon as a side effect of some other subdir + authorizedKeyOp :: Maybe Op + authorizedKeyOp = + (`inject` homeDir) . FS.appendLineIfMissing . FS.AppendLineIfMissing "/home/salmon/.ssh/authorized_keys" <$> authorizedKey + + salmonGroup :: User.Group + salmonGroup = User.Group "salmon" + + mkUser :: Track' User.User + mkUser = Track $ \u -> User.user r Debian.useradd mkGroup (User.NewUser u [sudo]) + + mkGroup :: Track' User.Group + mkGroup = Track $ \grp -> User.group r Debian.groupadd grp + + user :: User.User + user = User.User "salmon" + + sudo :: User.Group + sudo = User.Group "sudo" + + -- /home/salmon/tmp and /home/salmon/.ssh both live under the user's home + -- dir; force that ordering explicitly with 'inject' rather than relying + -- on `mkdir -p`'s incidental parent-creation, so the graph reflects the + -- real "home dir first" relationship (relevant once this recipe is + -- generalized to initializing more than the single hardcoded salmon user). + homeDir :: Op + homeDir = FS.dir (FS.Directory "/home/salmon") `inject` sudoUser + + tmpdir :: Op + tmpdir = FS.dir (FS.Directory "/home/salmon/tmp") `inject` homeDir diff --git a/src/SreBox/JWTSigning.hs b/src/SreBox/JWTSigning.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/JWTSigning.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module SreBox.JWTSigning where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson as Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base64.URL as B64Url +import qualified Data.ByteString.Lazy as LByteString +import Data.Foldable (for_) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Jose.Jwa as Jose +import qualified Jose.Jws as Jose + +import Salmon.Actions.UpDown (skipIfFileExists) +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.Secrets as Secrets +import Salmon.Op.OpGraph (OpGraph (..), inject) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track (using) +import Salmon.Reporter + +------------------------------------------------------------------------------- +data Report + = Sign !Secrets.Secret FilePath + deriving (Show) + +signHmac :: Reporter Report -> Tracked' Secrets.Secret -> ByteString -> FilePath -> Op +signHmac r secret jwtPayload jwtPath = + using secret $ \sekret -> + op "jwt-signed-token" nodeps $ \actions -> + actions + { help = "derive a JWT for claims and and a given signing Key" + , ref = mkRef "sign-jwt" jwtPath + , check = skipIfFileExists jwtPath + , up = up sekret + } + where + up sekret = do + runReporter r (Sign sekret jwtPath) + keytxt <- ByteString.readFile sekret.secret_path + let key = case sekret.secret_type of + Secrets.Base64 -> B64.decodeLenient keytxt + Secrets.Base64SafeUrl -> B64Url.decodeLenient keytxt + Secrets.Hex -> keytxt + print key + let jwt = Jose.hmacEncode Jose.HS256 key jwtPayload + for_ jwt $ \blob -> + LByteString.writeFile jwtPath (Aeson.encode blob) diff --git a/src/SreBox/MicroDNS.hs b/src/SreBox/MicroDNS.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/MicroDNS.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE DeriveGeneric #-} + +module SreBox.MicroDNS where + +import qualified Crypto.Hash.SHA256 as HMAC256 +import Data.Aeson (FromJSON, ToJSON) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Base16 as Base16 +import Data.CaseInsensitive (CI) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.X509 as Crypton +import Data.X509.CertificateStore as Crypton +import Data.X509.Validation as Crypton +import GHC.Generics (Generic) +import Network.Connection as Crypton +import Network.HTTP.Client (Manager, Request, httpNoBody) +import Network.HTTP.Client.TLS as Tls +import Network.TLS as Tls +import Network.TLS.Extra as Tls +import System.Directory +import System.FilePath + +import qualified Salmon.Builtin.CommandLine as CLI +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.Certificates as Certs +import qualified Salmon.Builtin.Nodes.Continuation as Continuation +import qualified Salmon.Builtin.Nodes.Debian.OS as Debian +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Rsync as Rsync +import qualified Salmon.Builtin.Nodes.Secrets as Secrets +import qualified Salmon.Builtin.Nodes.Self as Self +import qualified Salmon.Builtin.Nodes.Ssh as Ssh +import qualified Salmon.Builtin.Nodes.Systemd as Systemd +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track (Track (..), trackedGraph, using, (>*<)) +import Salmon.Reporter + +import SreBox.CabalBuilding (cabalBinUpload, microDNS, optBuildsBindir) +import qualified SreBox.CabalBuilding as CabalBuilding +import SreBox.Environment + +------------------------------------------------------------------------------- +data Report + = Build !CabalBuilding.Report + | Upload !CabalBuilding.Report + | CallSelf !Self.Report + | UploadSelf !Self.Report + | UploadFile !Rsync.Report + | GenSecret !Secrets.Report + | SetupSystemd !Systemd.Report + | SelfSign !Certs.Report + deriving (Show) + +------------------------------------------------------------------------------- + +type DNSName = Text +type PortNumber = Int + +data MicroDNSConfig + = MicroDNSConfig + { microdns_cfg_domainName :: DNSName + , microdns_cfg_apex :: DNSName + , microdns_cfg_portnum :: PortNumber + , microdns_cfg_postTxt :: DNSName -> Text -> IO () + , microdns_cfg_key :: Certs.Key + , microdns_cfg_pemPath :: FilePath + , microdns_cfg_secretPath :: FilePath + , microdns_cfg_selfCsr :: Certs.SigningRequest + , microdns_cfg_zonefileContents :: Text + } + +data MicroDNSSetup + = MicroDNSSetup + { microdns_setup_localBinPath :: FilePath + , microdns_setup_apex :: DNSName + , microdns_setup_portnum :: PortNumber + , microdns_setup_localPemPath :: FilePath + , microdns_setup_localKeyPath :: FilePath + , microdns_setup_localSecretPath :: FilePath + , microdns_setup_zoneFileContents :: Text + } + deriving (Generic) +instance FromJSON MicroDNSSetup +instance ToJSON MicroDNSSetup + +setupDNS :: + (FromJSON directive, ToJSON directive) => + Reporter Report -> + Track' Ssh.Remote -> + Track' directive -> + Self.Remote -> + Self.SelfPath -> + (MicroDNSSetup -> directive) -> + MicroDNSConfig -> + Op +setupDNS r mkRemote simulate selfRemote selfpath toSpec cfg = + using (cabalBinUpload (contramap Upload r) (microDNS (contramap Build r) optBuildsBindir) rsyncRemote) $ \remotepath -> + let + setup = MicroDNSSetup remotepath cfg.microdns_cfg_apex cfg.microdns_cfg_portnum remotePem remoteKey remoteSecret cfg.microdns_cfg_zonefileContents + in + trackedGraph (continueRemotely setup) `inject` configUploads + where + rsyncRemote :: Rsync.Remote + rsyncRemote = (\(Self.Remote a b) -> Rsync.Remote a b) selfRemote + + configUploads = op "uploads-microdns-configs" (deps [uploadCert, uploadKey, uploadSecret]) id + + -- recursive call + continueRemotely setup = + Self.uploadAndCallSelfAsSudo + (contramap UploadSelf r) + (contramap CallSelf r) + "tmp" + selfRemote + selfpath + mkRemote + simulate + CLI.Up + (toSpec setup) + + -- upload certificate and key + remotePem = "tmp/microdns.pem" + remoteKey = "tmp/microdns.key" + remoteSecret = "tmp/microdns.shared-secret" + + upload gen localpath distpath = + Rsync.sendFile (contramap UploadFile r) Debian.rsync (FS.Generated gen localpath) rsyncRemote distpath + + uploadCert = + upload (selfSignedCert r cfg) cfg.microdns_cfg_pemPath remotePem + + uploadKey = + upload (selfSigningKey r cfg) (Certs.keyPath cfg.microdns_cfg_key) remoteKey + + uploadSecret = + upload sharedSecret cfg.microdns_cfg_secretPath remoteSecret + where + sharedSecret = + Track $ dnsSecretFile r + +dnsZoneFile :: FilePath -> Text -> Op +dnsZoneFile path contents = + FS.filecontents (FS.FileContents path contents) + +dnsSecretFile :: Reporter Report -> FilePath -> Op +dnsSecretFile r path = + Secrets.sharedSecretFile + (contramap GenSecret r) + Debian.openssl + (Secrets.Secret Secrets.Base64 16 path) + +systemdMicroDNS :: Reporter Report -> MicroDNSSetup -> Op +systemdMicroDNS r arg = + Systemd.systemdService (contramap SetupSystemd r) Debian.systemctl trackConfig config + where + trackConfig :: Track' Systemd.Config + trackConfig = Track $ \cfg -> + let + execPath = Systemd.start_path $ Systemd.service_execStart $ Systemd.config_service $ cfg + copybin = FS.fileCopy (microdns_setup_localBinPath arg) execPath + copypem = FS.fileCopy (microdns_setup_localPemPath arg) pemPath + copykey = FS.fileCopy (microdns_setup_localKeyPath arg) keyPath + copySecret = FS.fileCopy (microdns_setup_localSecretPath arg) hmacSecretFile + in + op "setup-systemd-for-microdns" (deps [copybin, copypem, copykey, copySecret, localDnsSetup]) id + + localDnsSetup :: Op + localDnsSetup = + op "dns-setup" (deps [localDNSZoneFile]) id + where + localDNSZoneFile = dnsZoneFile zoneFile arg.microdns_setup_zoneFileContents + + config :: Systemd.Config + config = Systemd.Config Systemd.System "/etc/systemd/system" tgt unit service install + + tgt :: Systemd.UnitTarget + tgt = "salmon-microdns.service" + + hmacSecretFile, zoneFile, keyPath, pemPath :: FilePath + hmacSecretFile = "/opt/rundir/microdns/microdns.secret" + zoneFile = "/opt/rundir/microdns/microdns.zone" + pemPath = "/opt/rundir/microdns/cert.pem" + keyPath = "/opt/rundir/microdns/cert.key" + + unit :: Systemd.Unit + unit = Systemd.Unit "MicroDNS from Salmon" "network-online.target" + + service :: Systemd.Service + service = Systemd.Service Systemd.Simple "root" "root" "007" start Systemd.OnFailure Systemd.Process "/opt/rundir/microdns" + + start :: Systemd.Start + start = + Systemd.Start + "/opt/rundir/microdns/bin/microdns" + [ "tls" + , "--webPort" + , Text.pack (show arg.microdns_setup_portnum) + , "--dnsPort" + , "53" + , "--dnsApex" + , arg.microdns_setup_apex + , "--webHmacSecretFile" + , Text.pack hmacSecretFile + , "--zoneFile" + , Text.pack zoneFile + , "--certFile" + , Text.pack pemPath + , "--keyFile" + , Text.pack keyPath + ] + + install :: Systemd.Install + install = Systemd.Install "multi-user.target" + +makeTlsManagerForSelfSigned :: DNSName -> FilePath -> IO (Maybe Manager) +makeTlsManagerForSelfSigned hostname dir = do + certStore <- Crypton.readCertificateStore dir + case certStore of + Nothing -> pure Nothing + Just store -> do + let base = Tls.defaultParamsClient tlshostname "" + let tlsSetts = setStore store base + Just <$> Tls.newTlsManagerWith (Tls.mkManagerSettings (Crypton.TLSSettings tlsSetts) Nothing) + where + tlshostname :: Tls.HostName + tlshostname = Text.unpack hostname + + setStore :: + Crypton.CertificateStore -> + Tls.ClientParams -> + Tls.ClientParams + setStore store base = + base + { clientShared = + (base.clientShared) + { sharedCAStore = store + } + , clientSupported = + (base.clientSupported) + { supportedCiphers = Tls.ciphersuite_default + } + , clientHooks = + (base.clientHooks) + { onServerCertificate = Crypton.validate Crypton.HashSHA256 Crypton.defaultHooks relaxedChecks + } + } + relaxedChecks :: Crypton.ValidationChecks + relaxedChecks = Crypton.defaultChecks{checkLeafV3 = False} + +sharedToken :: Reporter Report -> FilePath -> Text -> FilePath -> Op +sharedToken r secret_path hashedpart token_path = + op "microdns-token" (deps [prepareSecret, enclosingdir]) $ \actions -> + actions + { help = "store token built from " <> Text.pack secret_path <> " at " <> Text.pack token_path + , ref = mkRef "microdns-token" token_path + , up = do + sharedsecret <- ByteString.readFile secret_path + ByteString.writeFile token_path $ hmacHashedPart sharedsecret hashedpart + } + where + enclosingdir :: Op + enclosingdir = FS.dir (FS.Directory $ takeDirectory token_path) + prepareSecret :: Op + prepareSecret = dnsSecretFile r secret_path + +hmacHashedPart :: ByteString -> Text -> ByteString +hmacHashedPart sharedsecret txtrecord = + Base16.encode $ HMAC256.hmac sharedsecret (Text.encodeUtf8 txtrecord) + +hmacHeader :: ByteString -> Text -> (CI ByteString, ByteString) +hmacHeader s t = ("x-microdns-hmac", hmacHashedPart s t) + +selfSignedCert :: Reporter Report -> MicroDNSConfig -> Track' FilePath +selfSignedCert r cfg = + Track $ \p -> Certs.selfSign (contramap SelfSign r) Debian.openssl (Certs.SelfSigned p cfg.microdns_cfg_selfCsr) + +selfSigningKey :: Reporter Report -> MicroDNSConfig -> Track' FilePath +selfSigningKey r cfg = + Track $ const $ Certs.tlsKey (contramap SelfSign r) Debian.openssl cfg.microdns_cfg_key diff --git a/src/SreBox/PostgresBackup.hs b/src/SreBox/PostgresBackup.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/PostgresBackup.hs @@ -0,0 +1,530 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | Periodic @pg_dump@ backups: the script, the schedule that runs it, and a +node that notices when no recent dump exists. + +The shape is the one everybody writes by hand -- dump, compress, ship, prune +-- expressed so that the three questions salmon can answer about it are +answerable: is the job installed, is the script the one we meant, and __is +there actually a recent backup__. The last is the one a hand-rolled cron +entry never answers: a job that has been failing silently for three weeks +looks exactly like one that has been working, right up until a restore. + += The bug in the obvious version + +The canonical script says: + +> pg_dump … | gzip > "$BACKUP_FILE" +> if [ $? -eq 0 ]; then echo "Backup completed"; else echo "Backup failed!" >&2; exit 1; fi + +@$?@ there is __gzip's__ exit status, not @pg_dump@'s. A dump that fails +half-way -- lost connection, permission denied on one table, disk full on the +server -- still leaves a perfectly valid gzip file and still reports success, +because @gzip@ compressed whatever it was given and exited @0@. The generated +script sets @pipefail@, which is what makes the failure of any stage of the +pipeline the failure of the whole thing. + += Retention is local only + +'pgb_retentionDays' prunes the /local/ directory. When 'pgb_gcs' is set the +copies in the bucket are not pruned by this recipe at all: object lifecycle +is a property of the bucket, and expressing it here would mean this node +silently deleting objects a bucket policy says to keep. Set a lifecycle rule +on the bucket instead. +-} +module SreBox.PostgresBackup ( + Report (..), + GcsDestination (..), + Credentials (..), + credentialEnvironment, + NamingPolicy (..), + defaultNamingPolicy, + dumpNameGlob, + dumpNameFor, + PgBackupConfig (..), + defaultBackupConfig, + + -- * The recipe + postgresBackup, + scheduledBackup, + backupScript, + recentBackup, + namedBackup, + + -- * The script + renderBackupScript, + backupFilePattern, + shellQuote, + shellExpand, + + -- * Freshness + checkBackupFreshness, + interpretBackupAge, +) where + +import Control.Exception (SomeException, try) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) +import Data.List (isPrefixOf, isSuffixOf) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) +import System.Directory (doesDirectoryExist, getModificationTime, listDirectory) +import System.FilePath (()) + +import Salmon.Actions.UpDown (CheckResult (..), skipIfFileExists) +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.Bash as Bash +import Salmon.Builtin.Nodes.Binary (Binary, withBinary) +import qualified Salmon.Builtin.Nodes.Binary as Binary +import qualified Salmon.Builtin.Nodes.CronTask as Cron +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Postgres as Postgres +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- + +data Report + = RunBackup !Binary.Report + deriving (Show) + +------------------------------------------------------------------------------- + +-- | A bucket (and optional prefix) each dump is copied to after it is written. +data GcsDestination = GcsDestination + { gcs_bucket :: Text + -- ^ bare bucket name, no @gs:\/\/@ + , gcs_prefix :: Text + -- ^ may be empty; no leading or trailing slash + } + deriving (Eq, Show, Generic) + +instance FromJSON GcsDestination +instance ToJSON GcsDestination + +{- | How @pg_dump@ is told who it is, without ever putting a credential on a +command line. + +Every one of these renders to __environment variables only__. That is the +whole point of the type: @\/proc\/\\/cmdline@ is world-readable for as +long as the process lives, so a connection string on @pg_dump@'s argv is a +password any user on the box can read by running @ps@ at the right moment. +@\/proc\/\\/environ@ is readable only by the process's own owner. + +The four mechanisms, in rough order of how much they leave lying around: + +* 'PeerAuth' -- nothing at all. The job runs as an OS user the cluster + trusts over the local socket, which is what a backup job on the database + host should normally use. +* 'ClientCertificate' -- a key on disk and no password anywhere, the client + side of "SreBox.PostgresTls". +* 'ServiceFile' -- a libpq service file naming a connection, credentials + included. The connection string never becomes an argument. +* 'PassFile' -- a @.pgpass@. + +None of them is /created/ by this recipe: how a credential reaches the +machine is the caller's business, same rule as everywhere else here. +-} +data Credentials + = -- | the OS user is the authentication + PeerAuth + | -- | @PGPASSFILE@ + PassFile FilePath + | -- | @PGSERVICEFILE@ and @PGSERVICE@ + ServiceFile FilePath Text + | -- | @PGSSLCERT@, @PGSSLKEY@, @PGSSLROOTCERT@ (with @PGSSLMODE=verify-ca@) + ClientCertificate FilePath FilePath FilePath + deriving (Eq, Show, Generic) + +instance FromJSON Credentials +instance ToJSON Credentials + +-- | The @export@ lines a 'Credentials' turns into. +credentialEnvironment :: Credentials -> [Text] +credentialEnvironment PeerAuth = [] +credentialEnvironment (PassFile path) = + ["export PGPASSFILE=" <> shellQuote (Text.pack path)] +credentialEnvironment (ServiceFile path service) = + [ "export PGSERVICEFILE=" <> shellQuote (Text.pack path) + , "export PGSERVICE=" <> shellQuote service + ] +credentialEnvironment (ClientCertificate cert key ca) = + [ "export PGSSLMODE=verify-ca" + , "export PGSSLCERT=" <> shellQuote (Text.pack cert) + , "export PGSSLKEY=" <> shellQuote (Text.pack key) + , "export PGSSLROOTCERT=" <> shellQuote (Text.pack ca) + ] + +{- | What a dump is called. + +Worth being a policy rather than a constant for two reasons that pull in +opposite directions. Operators want dumps that sort and are recognisable +from a listing months later. And anything that has to /fetch/ a dump has to be able +to predict its name -- which is why 'dumpNameFor' takes the timestamp as an +argument rather than reading the clock: a controller driving a backup on +another machine freezes the timestamp when it builds the directive, so both +ends name the same file. Letting each side call @date@ is the obvious +version and it loses the file whenever the two land either side of a second. +-} +data NamingPolicy = NamingPolicy + { np_prefix :: Text + , np_timestampFormat :: Text + -- ^ a @date(1)@ format string, without the leading @+@ + , np_suffix :: Text + } + deriving (Eq, Show, Generic) + +instance FromJSON NamingPolicy +instance ToJSON NamingPolicy + +-- | @\_%Y%m%d_%H%M%S.sql.gz@, flat. +defaultNamingPolicy :: Postgres.DatabaseName -> NamingPolicy +defaultNamingPolicy db = + NamingPolicy + { np_prefix = db + , np_timestampFormat = "%Y%m%d_%H%M%S" + , np_suffix = ".sql.gz" + } + +{- | The shell glob matching every dump this policy produces, used by the +retention @find@ and by the freshness check so the two cannot drift. +-} +dumpNameGlob :: NamingPolicy -> Text +dumpNameGlob policy = policy.np_prefix <> "_*" <> policy.np_suffix + +{- | The name of the dump taken at a given (already formatted) timestamp, +relative to the backup directory. +-} +dumpNameFor :: NamingPolicy -> Text -> FilePath +dumpNameFor policy stamp = + Text.unpack (policy.np_prefix <> "_" <> stamp <> policy.np_suffix) + +data PgBackupConfig = PgBackupConfig + { pgb_database :: Postgres.DatabaseName + , pgb_role :: Maybe Postgres.RoleName + -- ^ 'Nothing' lets libpq default the role to the OS user, which is what + -- peer authentication over the local socket wants. + , pgb_server :: Maybe Postgres.Server + -- ^ 'Nothing' connects over the __unix socket__ rather than TCP. That is + -- not a detail: @peer@ authentication only exists on the socket, so a + -- backup job on the database host that names @127.0.0.1@ is asking for a + -- password it does not have. + , pgb_sudoUser :: Maybe Text + -- ^ run @pg_dump@ as this OS user (@sudo -u@). With 'PeerAuth' this /is/ + -- the authentication; the cluster believes whoever the kernel says is on + -- the other end of the socket. + , pgb_dir :: FilePath + -- ^ where dumps are written + , pgb_scriptPath :: FilePath + , pgb_osUser :: Text + -- ^ the account cron runs the job as, and whose credentials @pg_dump@ uses + , pgb_credentials :: Credentials + , pgb_naming :: NamingPolicy + , pgb_fixedTimestamp :: Maybe Text + -- ^ when set, the script writes exactly this dump rather than one named + -- for the moment it runs -- which is what lets a controller on another + -- machine know the path to fetch. Pointless (and wrong) for a scheduled + -- job, which would overwrite the same file forever. + , pgb_retentionDays :: Int + , pgb_schedule :: Cron.Schedule + , pgb_gcs :: Maybe GcsDestination + , pgb_maxAge :: NominalDiffTime + -- ^ how old the newest dump may be before 'recentBackup' calls it stale. + -- Give this slack over 'pgb_schedule': equal values make every check that + -- lands just before the next run report a failure. + } + deriving (Eq, Show, Generic) + +-- | Serialisable so a whole backup configuration can travel as a directive to +-- the machine that will run it -- see @salmon-pg-backup@. +instance FromJSON PgBackupConfig +instance ToJSON PgBackupConfig + +{- | Daily at 03:17, keeping a week, with a freshness window of 26 hours. + +The odd minute is deliberate (see 'Cron.dailyAt'), and the window is the +period plus two hours rather than exactly a day, so a run that is merely late +is not reported as a missing backup. +-} +defaultBackupConfig :: Postgres.DatabaseName -> Maybe Postgres.RoleName -> PgBackupConfig +defaultBackupConfig db role = + PgBackupConfig + { pgb_database = db + , pgb_role = role + , pgb_server = Nothing + , pgb_sudoUser = Just "postgres" + , pgb_dir = "/data/backups/postgresql" + , pgb_scriptPath = "/opt/salmon/postgres/backup-" <> Text.unpack db <> ".sh" + , pgb_osUser = "postgres" + , pgb_credentials = PeerAuth + , pgb_naming = defaultNamingPolicy db + , pgb_fixedTimestamp = Nothing + , pgb_retentionDays = 7 + , pgb_schedule = Cron.dailyAt "3" "17" + , pgb_gcs = Nothing + , pgb_maxAge = 26 * 3600 + } + +------------------------------------------------------------------------------- + +{- | The whole thing: the script, the cron entry that runs it, and a node +asserting a recent dump exists. + +Bringing this up therefore /takes a backup immediately/ if there is not +already a recent one — which is what you want the first time (waiting until +03:17 to discover the credentials are wrong is not a plan) and costs nothing +on later passes, since the freshness check skips the node. +-} +postgresBackup :: + Reporter Report -> + Track' (Binary "bash") -> + PgBackupConfig -> + Op +postgresBackup r bash cfg = + op "pg-backup" (deps [scheduledBackup cfg, recentBackup r bash cfg]) $ \actions -> + actions + { help = Text.unwords ["backs up", cfg.pgb_database, "to", Text.pack cfg.pgb_dir] + , ref = mkRef "pg-backup" (cfg.pgb_database, cfg.pgb_dir) + } + +-- | The script and the crontab entry, without taking a backup now. +scheduledBackup :: PgBackupConfig -> Op +scheduledBackup cfg = + Cron.crontask (Track $ const scriptOp) task + where + task :: Cron.CronTask + task = + Cron.CronTask + { Cron.name = "pg-backup-" <> cfg.pgb_database + , Cron.user = cfg.pgb_osUser + , Cron.schedule = cfg.pgb_schedule + , Cron.command = "/bin/bash" + , Cron.commandArgs = [Text.pack cfg.pgb_scriptPath] + } + + scriptOp :: Op + scriptOp = backupScript cfg + +-- | The generated script, and the directory it writes into. +backupScript :: PgBackupConfig -> Op +backupScript cfg = + FS.filecontents (FS.FileContents cfg.pgb_scriptPath (renderBackupScript cfg)) + `inject` FS.dir (FS.Directory cfg.pgb_dir) + +{- | "There is a dump newer than 'pgb_maxAge'", with @up@ being "take one". + +The node that makes this recipe worth more than a crontab line: its @check@ +is a statement about the /backups/, not about the job, so under @run serve@ +it is the thing that notices three weeks of silent failure. Under a one-shot +@run up@ it takes a dump only when one is missing. +-} +recentBackup :: Reporter Report -> Track' (Binary "bash") -> PgBackupConfig -> Op +recentBackup r bash cfg = + withBinary bash Bash.bashrun (Bash.BashCommand cfg.pgb_scriptPath) $ \runScript -> + op "pg-backup-recent" (deps [backupScript cfg]) $ \actions -> + actions + { help = Text.unwords ["ensures a recent backup of", cfg.pgb_database] + , notes = ["up takes a backup; check reports on the newest one on disk"] + , ref = mkRef "pg-backup-recent" (cfg.pgb_database, cfg.pgb_dir) + , check = checkBackupFreshness cfg + , up = runScript (contramap RunBackup r) + , -- Deleting backups is not what tearing a backup job down + -- means, and doing it here would make `run down` the most + -- destructive command in the system. + down = pure () + } + +------------------------------------------------------------------------------- + +{- | The dump filenames this recipe writes and reads: @\_@ … @.sql.gz@. + +Shared by the script (which creates them), the retention @find@ (which +deletes them) and 'checkBackupFreshness' (which ages them) so the three +cannot drift apart. +-} +backupFilePattern :: PgBackupConfig -> (String, String) +backupFilePattern cfg = + (Text.unpack (cfg.pgb_naming.np_prefix <> "_"), Text.unpack cfg.pgb_naming.np_suffix) + +-- | Ages the newest dump in 'pgb_dir'. +checkBackupFreshness :: PgBackupConfig -> IO CheckResult +checkBackupFreshness cfg = do + now <- getCurrentTime + newest <- newestBackup cfg + pure (interpretBackupAge cfg.pgb_maxAge now newest) + +{- | The verdict, split out from the filesystem so it is testable. + +A directory with no dump at all is a 'Failure' rather than an +'Salmon.Actions.UpDown.Unknown': "we have never managed to back this up" is +the most actionable thing this check ever says, and the least worth being +tentative about. +-} +interpretBackupAge :: NominalDiffTime -> UTCTime -> Maybe (FilePath, UTCTime) -> CheckResult +interpretBackupAge _maxAge _now Nothing = Failure "no backup found" +interpretBackupAge maxAge now (Just (path, modified)) + | age <= maxAge = Success + | otherwise = + Failure $ + Text.pack path + <> " is the newest backup and is " + <> Text.pack (show (round (age / 3600) :: Int)) + <> "h old" + where + age = diffUTCTime now modified + +{- | The most recently modified dump, or 'Nothing'. + +An unreadable directory reads as "no backup", which is the same verdict and +the same call to action: whatever is wrong, there is nothing here to restore +from. +-} +newestBackup :: PgBackupConfig -> IO (Maybe (FilePath, UTCTime)) +newestBackup cfg = do + present <- doesDirectoryExist cfg.pgb_dir + if not present + then pure Nothing + else do + entries <- either (const []) id <$> tryIO (listDirectory cfg.pgb_dir) + let (prefix, suffix) = backupFilePattern cfg + dumps = [cfg.pgb_dir e | e <- entries, prefix `isPrefixOf` e, suffix `isSuffixOf` e] + stamped <- traverse stamp dumps + pure $ case [x | Just x <- stamped] of + [] -> Nothing + xs -> Just (maximumOn snd xs) + where + stamp path = either (const Nothing) (Just . (,) path) <$> tryIO (getModificationTime path) + + maximumOn f = foldr1 (\a b -> if f a >= f b then a else b) + +tryIO :: IO a -> IO (Either SomeException a) +tryIO = try + +------------------------------------------------------------------------------- + +{- | The backup script. + +Everything it needs is interpolated at graph-declaration time, so the file on +disk is fully explicit -- readable by an operator who has never heard of +salmon, and diffable when the config changes (which is also what lets +'FS.filecontents' notice a hand-edit and put it back). +-} +renderBackupScript :: PgBackupConfig -> Text +renderBackupScript cfg = + Text.unlines $ + [ "#!/bin/bash" + , -- pipefail is the whole point: without it `pg_dump | gzip` reports + -- gzip's success and a failed dump is stored as a valid archive. + "set -euo pipefail" + , "" + , "BACKUP_DIR=" <> shellQuote (Text.pack cfg.pgb_dir) + , "DATABASE=" <> shellQuote cfg.pgb_database + , timestampLine + , "BACKUP_FILE=\"${BACKUP_DIR}/" <> shellExpand (cfg.pgb_naming.np_prefix <> "_") <> "${TIMESTAMP}" <> shellExpand cfg.pgb_naming.np_suffix <> "\"" + , "" + , "mkdir -p \"$BACKUP_DIR\"" + ] + <> credentialLines + <> [ "" + , dumpLine + , "echo \"backup completed: $BACKUP_FILE\"" + ] + <> uploadLines + <> [ "" + , -- pruning last, and only if everything above succeeded: + -- under `set -e` a failed upload stops the script here, so a + -- dump that never reached the bucket is not also deleted + -- locally. + "find \"$BACKUP_DIR\" -name " + <> shellQuote (dumpNameGlob cfg.pgb_naming) + <> " -mtime +" + <> Text.pack (show cfg.pgb_retentionDays) + <> " -delete" + ] + where + -- A driven backup freezes the timestamp in the directive so the machine + -- that will fetch the dump knows its name; a scheduled one must not, or + -- every run would overwrite one file forever. + timestampLine = case cfg.pgb_fixedTimestamp of + Just stamp -> "TIMESTAMP=" <> shellQuote stamp + Nothing -> "TIMESTAMP=$(date +" <> shellQuote cfg.pgb_naming.np_timestampFormat <> ")" + + credentialLines = credentialEnvironment cfg.pgb_credentials + + -- `sudo -u postgres` and no -h is what peer authentication looks like; + -- naming a host turns the same call into a TCP connection that pg_hba + -- will want a password for. + dumpLine = + Text.concat + [ maybe "" (\u -> "sudo -u " <> shellQuote u <> " ") cfg.pgb_sudoUser + , "pg_dump" + , maybe "" (\srv -> " -h " <> shellQuote srv.serverHost <> " -p " <> Text.pack (show srv.serverPort)) cfg.pgb_server + , maybe "" (\u -> " -U " <> shellQuote u) cfg.pgb_role + , " -d \"$DATABASE\" | gzip > \"$BACKUP_FILE\"" + ] + + uploadLines = case cfg.pgb_gcs of + Nothing -> [] + Just dest -> + [ "" + , "gcloud storage cp \"$BACKUP_FILE\" " <> shellQuote (destination dest) + ] + + destination :: GcsDestination -> Text + destination dest + | Text.null dest.gcs_prefix = "gs://" <> dest.gcs_bucket <> "/" + | otherwise = "gs://" <> dest.gcs_bucket <> "/" <> dest.gcs_prefix <> "/" + +{- | POSIX single-quoting, the same rule as +"Salmon.Builtin.Nodes.Gcp.LoadBalancing".@shellQuote@: every value +interpolated into the script goes through it, because database and role names +come from a caller and end up inside a @bash -c@ context. +-} +shellQuote :: Text -> Text +shellQuote t = "'" <> Text.replace "'" "'\\''" t <> "'" + +{- | Escapes a literal for use /inside/ a double-quoted string, where +'shellQuote' cannot be used because the surrounding quotes have to stay open +for a @${…}@ expansion next to it. + +Backslash first, or the escapes added by the later passes get escaped again. +-} +shellExpand :: Text -> Text +shellExpand = + Text.replace "\"" "\\\"" + . Text.replace "`" "\\`" + . Text.replace "$" "\\$" + . Text.replace "\\" "\\\\" + +------------------------------------------------------------------------------- + +{- | "The dump named by this timestamp exists", with @up@ being "produce it". + +The one-shot counterpart to 'recentBackup', and the node a /driven/ backup +needs. Where 'recentBackup' asks a question about the state of the backup +directory ("is anything in here recent enough"), this one asks about a +single named file — which is the only question whose answer another machine +can act on, because the dump it is about to fetch has to be a path it can +name before the dump exists. + +Requires 'pgb_fixedTimestamp' to be set to the same stamp, or the script +will name its output after the moment it runs and this check will never be +satisfied by it. +-} +namedBackup :: Reporter Report -> Track' (Binary "bash") -> PgBackupConfig -> Text -> Op +namedBackup r bash cfg stamp = + withBinary bash Bash.bashrun (Bash.BashCommand cfg.pgb_scriptPath) $ \runScript -> + op "pg-backup-named" (deps [backupScript cfg]) $ \actions -> + actions + { help = Text.unwords ["takes the backup", Text.pack path] + , ref = mkRef "pg-backup-named" path + , check = skipIfFileExists path + , up = runScript (contramap RunBackup r) + , down = pure () + } + where + path = cfg.pgb_dir dumpNameFor cfg.pgb_naming stamp diff --git a/src/SreBox/PostgresInit.hs b/src/SreBox/PostgresInit.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/PostgresInit.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE DeriveGeneric #-} + +module SreBox.PostgresInit where + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Text as Text +import GHC.Generics (Generic) + +import qualified Salmon.Builtin.CommandLine as CLI +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.Debian.OS as Debian +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Postgres as Postgres +import qualified Salmon.Builtin.Nodes.Rsync as Rsync +import qualified Salmon.Builtin.Nodes.Self as Self +import qualified Salmon.Builtin.Nodes.Ssh as Ssh +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Track +import Salmon.Reporter +import qualified SreBox.PostgresMigrations as PGMigrate + +------------------------------------------------------------------------------- +data Report + = InitPostgres !Postgres.Report + | UploadSelf !Self.Report + | CallSelf !Self.Report + | UploadSecret !Postgres.User !Rsync.Report + | RunMigration !PGMigrate.Report + deriving (Show) + +------------------------------------------------------------------------------- + +{- | A PG setup definition where: +* groups and users have rights +* users have passwords +* users may be in groups (no subgroups) +-} +data InitSetup pass + = InitSetup + { init_setup_database :: Postgres.Database + , init_setup_owner :: (Postgres.User, pass) + , init_setup_users :: [(Postgres.User, pass, [Postgres.PGRight], [Postgres.Group])] + , init_setup_groups :: [(Postgres.Group, [Postgres.PGRight])] + } + deriving (Generic) + +instance (FromJSON a) => FromJSON (InitSetup a) +instance (ToJSON a) => ToJSON (InitSetup a) + +setupWithPreExistingPasswords :: InitSetup FilePath -> InitSetup (FS.File "passfile") +setupWithPreExistingPasswords setup = + InitSetup + setup.init_setup_database + (ownerUser, FS.PreExisting ownerPass) + [(u, FS.PreExisting pass, rs, gs) | (u, pass, rs, gs) <- setup.init_setup_users] + setup.init_setup_groups + where + (ownerUser, ownerPass) = setup.init_setup_owner + +-- | generate a db with a given sets of users, all having some rights +setupPG :: Reporter Report -> InitSetup (FS.File "passfile") -> Op +setupPG r setup = + op "pg-setup" (deps [memberships, groupAcls, userAcls `inject` basics]) id + where + basics = op "pg-basics" (deps [users `inject` groups `inject` db, dbOwner `inject` db]) id + + cluster = Track $ Postgres.pgLocalCluster (contramap InitPostgres r) Debian.postgres Debian.pg_ctlcluster + + port = Postgres.localServer.serverPort + + db = Postgres.database (contramap InitPostgres r) cluster Debian.psql port setup.init_setup_database + + groups = op "pg-groups" (deps $ fmap group setup.init_setup_groups) id + + group (g, _) = + Postgres.group (contramap InitPostgres r) cluster Debian.psql port g + + users = op "pg-users" (deps $ fmap user setup.init_setup_users) id + + -- roundabout ways to generate users and owner user + baseUser u pass = + Postgres.userPassFile (contramap InitPostgres r) cluster Debian.psql port pass u + user (u, pass, _, _) = baseUser u pass + owner = + let (u, pass) = setup.init_setup_owner + in baseUser u pass + + -- we force all users to be created before any group membership + trackuserFromMembershipByCreatingAllUsers = Track $ const users + trackuserFromAclsByCreatingAllUsers = Track $ const users + trackgroupsFromAclsByCreatingAllGroups = Track $ const groups + trackOwnerRoleForUser = Track $ const owner + + dbOwner = op "pg-db-ownership" (deps [ownership]) id + where + ownership = + Postgres.databaseOnwership + (contramap InitPostgres r) + cluster + Debian.psql + port + ignoreTrack + setup.init_setup_database + trackOwnerRoleForUser + (Postgres.UserRole $ fst setup.init_setup_owner) + + userAcls = op "pg-user-grants" (deps $ fmap acl setup.init_setup_users) id + where + acl (u, _, rights, _) = + Postgres.grant + (contramap InitPostgres r) + Debian.psql + port + trackuserFromAclsByCreatingAllUsers + (Postgres.AccessRight setup.init_setup_database (Postgres.UserRole u) rights) + + groupAcls = op "pg-group-grants" (deps $ fmap acl setup.init_setup_groups) id + where + acl (g, rights) = + Postgres.grant + (contramap InitPostgres r) + Debian.psql + port + trackgroupsFromAclsByCreatingAllGroups + (Postgres.AccessRight setup.init_setup_database (Postgres.GroupRole g) rights) + + memberships = op "pg-user-memberships" (deps $ [membership u g | (u, _, _, gs) <- setup.init_setup_users, g <- gs]) id + where + membership u g = + Postgres.groupMember + (contramap InitPostgres r) + cluster + Debian.psql + port + g + trackuserFromMembershipByCreatingAllUsers + (Postgres.UserRole u) + +-- | typical setup with a single connection account +setupSingleUserPG :: Reporter Report -> Postgres.ConnString FilePath -> Op +setupSingleUserPG r connstring = + setupPG r setup + where + setup = InitSetup d1 (u1, FS.PreExisting pass1) users [] + users = [(u1, FS.PreExisting pass1, [Postgres.CONNECT, Postgres.CREATE], [])] + + cluster = Track $ Postgres.pgLocalCluster (contramap InitPostgres r) Debian.postgres Debian.pg_ctlcluster + d1 = connstring.connstring_db + u1 = connstring.connstring_user + pass1 = connstring.connstring_user_pass + +-- | semi-advanced setup with multiple users +setupMultiUserPG :: + Reporter Report -> + Postgres.ConnString FilePath -> + [(Postgres.User, FS.File "passfile", [Postgres.PGRight], [Postgres.Group])] -> + [(Postgres.Group, [Postgres.PGRight])] -> + Op +setupMultiUserPG r ownerConnstring users groups = + setupPG r setup + where + setup = InitSetup d1 (u1, FS.PreExisting pass1) users groups + + cluster = Track $ Postgres.pgLocalCluster (contramap InitPostgres r) Debian.postgres Debian.pg_ctlcluster + d1 = ownerConnstring.connstring_db + u1 = ownerConnstring.connstring_user + pass1 = ownerConnstring.connstring_user_pass + +setupNakedPG :: Reporter Report -> Postgres.DatabaseName -> Op +setupNakedPG r dbname = + Postgres.database + (contramap InitPostgres r) + cluster + Debian.psql + Postgres.localServer.serverPort + (Postgres.Database dbname) + where + cluster = Track $ Postgres.pgLocalCluster (contramap InitPostgres r) Debian.postgres Debian.pg_ctlcluster + +remoteSetupPG :: + (FromJSON directive, ToJSON directive) => + Reporter Report -> + Track' directive -> + Self.Remote -> + Self.SelfPath -> + (InitSetup FilePath -> directive) -> + InitSetup FilePath -> + Op +remoteSetupPG r simulate selfRemote selfpath toSpec cfg = + op "init-remotely" (deps [remoteInit `inject` uploadSecrets]) id + where + rsyncRemote :: Rsync.Remote + rsyncRemote = (\(Self.Remote a b) -> Rsync.Remote a b) selfRemote + + remoteSetup :: InitSetup FilePath + remoteSetup = InitSetup cfg.init_setup_database cfg.init_setup_owner remoteusers cfg.init_setup_groups + + remoteusers = [(u, remotePassFilePath u, rs, gs) | (u, _, rs, gs) <- cfg.init_setup_users] + remotePassFilePath u = Text.unpack $ "tmp/pg-init-pass-" <> Postgres.userRole u + + remoteInit :: Op + remoteInit = + trackedGraph $ + Self.uploadAndCallSelfAsSudo + (contramap UploadSelf r) + (contramap CallSelf r) + "tmp" + selfRemote + selfpath + Ssh.preExistingRemoteMachine + simulate + CLI.Up + (toSpec remoteSetup) + + uploadSecrets :: Op + uploadSecrets = op "pg-init-secrets" (deps [uploaduserSecret u p | (u, p, _, _) <- cfg.init_setup_users]) id + + uploaduserSecret :: Postgres.User -> FilePath -> Op + uploaduserSecret u pass = + Rsync.sendFile + (contramap (UploadSecret u) r) + Debian.rsync + ( FS.Generated + (PGMigrate.pgPassword (contramap RunMigration r)) + pass + ) + (rsyncRemote) + (remotePassFilePath u) diff --git a/src/SreBox/PostgresMigrations.hs b/src/SreBox/PostgresMigrations.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/PostgresMigrations.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE DeriveGeneric #-} + +module SreBox.PostgresMigrations where + +import Control.Comonad (extract) +import Control.Comonad.Cofree (Cofree (..)) +import Control.Exception (throwIO) +import Control.Monad (unless) +import Control.Monad.Identity +import Crypto.Hash.SHA256 as SHA256 +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.ByteString.Base16 as Base16 +import Data.ByteString.Char8 as C8 +import Data.Coerce (coerce) +import Data.Dynamic (toDyn) +import Data.Foldable (toList) +import Data.List (stripPrefix) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import GHC.Generics +import System.FilePath (takeDirectory, ()) +import System.IO.Error (userError) + +import qualified Salmon.Actions.Dot as Dot +import qualified Salmon.Actions.UpDown as UpDown +import qualified Salmon.Builtin.CommandLine as CLI +import Salmon.Builtin.Extension +import Salmon.Builtin.Helpers (collapse) +import Salmon.Builtin.Migrations +import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary) +import Salmon.Builtin.Nodes.Debian.OS as Debian +import Salmon.Builtin.Nodes.Filesystem as FS +import Salmon.Builtin.Nodes.Postgres (ConnString (..), Database (..), DatabaseName, Password, User, adminScript, connstring, localServer, readPassword, userScript, withPassword) +import qualified Salmon.Builtin.Nodes.Postgres as Postgres +import qualified Salmon.Builtin.Nodes.Rsync as Rsync +import qualified Salmon.Builtin.Nodes.Secrets as Secrets +import qualified Salmon.Builtin.Nodes.Self as Self +import qualified Salmon.Builtin.Nodes.Ssh as Ssh +import Salmon.Op.Eval +import Salmon.Op.G +import Salmon.Op.Graph +import Salmon.Op.OpGraph +import Salmon.Op.Ref +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- +data Report + = ApplyMigration !FilePath !Postgres.Report + | UploadFile !Rsync.Report + | UploadSecretFile !Rsync.Report + | UploadSelf !Self.Report + | CallSelf !Self.Report + | CreatePassword !Secrets.Report + | Continuation !(UpDown.Report Extension) + deriving (Show) + +------------------------------------------------------------------------------- + +data MigrationFile + = MigrationFile + { path :: FilePath + } + deriving (Show, Generic) + +instance FromJSON MigrationFile +instance ToJSON MigrationFile + +defaultMigrationReader :: MigrationReader MigrationFile +defaultMigrationReader = + MigrationReader + (pure . MigrationFile) + (parsePredecessors) + id + where + parsePredecessors :: C8.ByteString -> [FilePath] + parsePredecessors txt = + catMaybes $ fmap parsePredecessorLine $ C8.lines txt + + parsePredecessorLine :: C8.ByteString -> Maybe FilePath + parsePredecessorLine line = + C8.unpack <$> C8.stripPrefix prefix line + + prefix :: C8.ByteString + prefix = "-- migrate.after: " + +data MigrateStyle + = MigrateUserScript (Track' (ConnString FilePath)) (ConnString FilePath) + | MigrateAdminScript (Track' DatabaseName) DatabaseName + +migrateG :: + Reporter Report -> + Track' (Binary "psql") -> + MigrateStyle -> + G MigrationFile -> + Op +migrateG r psql style g = + migrate r psql style (coerce g) + +-- | A helper to turn a migration graph into an Op. +migrate :: + Reporter Report -> + Track' (Binary "psql") -> + MigrateStyle -> + Cofree Graph MigrationFile -> + Op +migrate r psql style (m :< x) = + let + current :: Op + current = + case style of + MigrateUserScript mksetup connstring -> + userScript r' psql mksetup connstring (PreExisting m.path) + MigrateAdminScript mksetup dbname -> + adminScript r' psql localServer.serverPort mksetup dbname (PreExisting m.path) + + pred :: Op + pred = evalPred "" x + in + current `inject` pred + where + r' = contramap (ApplyMigration m.path) r + gorec = migrate r psql style + setref lineage actions = + actions{ref = mkRef "migration" (m.path, lineage)} + + -- the string in eval pred accumulates left/right branches choices to disambiguate noop nodes by ref + evalPred :: String -> Graph (Cofree Graph MigrationFile) -> Op + evalPred l (Vertices []) = realNoop + evalPred l (Vertices zs) = + op "migrate:deps" (deps $ fmap gorec zs) (setref l) + evalPred l (Overlay g1 g2) = + op "migrate:deps" (deps [evalPred ('l' : l) g1, evalPred ('r' : l) g2]) (setref l) + evalPred l (Connect g1 g2) = + op "migrate:deps" (deps [evalPred ('l' : l) g2 `inject` evalPred ('r' : l) g1]) (setref l) + +------------------------------------------------------------------------------- + +data MigrationPlan a + = MigrationPlan + { migration_connstring :: ConnString a + , migration_file :: G MigrationFile + } + deriving (Generic) +instance (ToJSON a) => ToJSON (MigrationPlan a) +instance (FromJSON a) => FromJSON (MigrationPlan a) + +------------------------------------------------------------------------------- + +data RemoteMigrateConfig t + = RemoteMigrateConfig + { cfg_migrations :: t (G MigrationFile) + , cfg_remoteMigrationPath :: MigrationFile -> FilePath + , cfg_user :: User + , cfg_database :: Database + , cfg_password :: FilePath + , cfg_extra_users :: [(User, FilePath)] + } + +defaultRemoteMigrationDir :: DatabaseName -> FilePath +defaultRemoteMigrationDir dbname = + "tmp/migrations" Text.unpack dbname + +defaultRemoteMigrationPath :: DatabaseName -> MigrationFile -> FilePath +defaultRemoteMigrationPath dbname m = + defaultRemoteMigrationDir dbname shafile <> ".sql" + where + shafile = C8.unpack $ Base16.encode $ SHA256.hash (C8.pack m.path) + +remoteMigrateOpaqueSetup :: + (FromJSON directive, ToJSON directive) => + Text -> + Reporter Report -> + Track' directive -> + Self.Remote -> + Self.SelfPath -> + (Either PrepareRemoteMigrationSetup MigrationSetup -> directive) -> + RemoteMigrateConfig TrackedIO -> + Op +remoteMigrateOpaqueSetup uniquename r simulate selfRemote selfpath toSpec cfg = + op "migrate-remotely" (deps [opaquemigration `inject` uploadsecrets]) $ \actions -> + actions + { help = Text.unwords ["remotely apply the (opaque) migration", uniquename] + , ref = mkRef "remote-migrate" uniquename + } + where + rsyncRemote :: Rsync.Remote + rsyncRemote = (\(Self.Remote a b) -> Rsync.Remote a b) selfRemote + + opaquemigration = + using (unwrapTIO cfg.cfg_migrations) $ \ioMigrations -> + op "opaque-migrate" nodeps $ \actions -> + actions + { ref = mkRef "opaque-migration" uniquename + , up = do + migrations <- ioMigrations + let prepare = remotePrepare (toList migrations) + let uploads = collapse "." uploadmigrationFile (getCofreeGraph migrations) + let apply = remoteApply migrations + ok <- UpDown.upTree (contramap Continuation r) (pure . runIdentity) (apply `inject` uploads `inject` prepare) + -- 'up' has to throw, not just report, to fail loudly: this is a nested + -- upTree run from inside another node's 'up', so the only way the outer + -- traversal finds out this failed is if this 'up' itself throws. + unless ok (throwIO (userError ("remote migration failed: " <> Text.unpack uniquename))) + , dynamics = [toDyn $ Dot.OpaqueNode "migration"] + } + + dbname :: Text + dbname = getDatabase cfg.cfg_database + + remoteMigrationPath :: MigrationFile -> FilePath + remoteMigrationPath = cfg.cfg_remoteMigrationPath + + remoteMigrationDir :: MigrationFile -> FilePath + remoteMigrationDir = takeDirectory . cfg.cfg_remoteMigrationPath + + uploadmigrationFile :: MigrationFile -> Op + uploadmigrationFile m = + Rsync.sendFile + (contramap UploadFile r) + Debian.rsync + (FS.PreExisting m.path) + (rsyncRemote) + (remoteMigrationPath m) + + uploadsecrets :: Op + uploadsecrets = op "uploading-secrets" (deps (uploadMainSecret : extraSecrets)) id + where + extraSecrets :: [Op] + extraSecrets = fmap uploadExtraSecret cfg.cfg_extra_users + + uploadMainSecret :: Op + uploadMainSecret = + Rsync.sendFile + (contramap UploadSecretFile r) + Debian.rsync + (FS.Generated (pgPassword r) cfg.cfg_password) + (rsyncRemote) + (remotePgSecretPath) + + remotePgSecretPath :: FilePath + remotePgSecretPath = Text.unpack $ "tmp/connstring-" <> dbname + + uploadExtraSecret :: (User, FilePath) -> Op + uploadExtraSecret (u, p) = + Rsync.sendFile + (contramap UploadSecretFile r) + Debian.rsync + (FS.Generated (pgPassword r) p) + (rsyncRemote) + (remotePgSecretPathForUser u) + + remotePgSecretPathForUser :: User -> FilePath + remotePgSecretPathForUser u = Text.unpack $ "tmp/connstring-" <> dbname <> "." <> u.userRole + + remoteExtraUsers :: [(User, FilePath)] + remoteExtraUsers = [(u, remotePgSecretPathForUser u) | (u, _) <- cfg.cfg_extra_users] + + remoteMigrationPlan :: G MigrationFile -> G MigrationFile + remoteMigrationPlan migrations = + (G $ fmap (MigrationFile . remoteMigrationPath) $ getCofreeGraph migrations) + + remotePrepare :: [MigrationFile] -> Op + remotePrepare migrations = + trackedGraph $ + Self.uploadAndCallSelf + (contramap UploadSelf r) + (contramap CallSelf r) + "tmp" + selfRemote + selfpath + Ssh.preExistingRemoteMachine + simulate + CLI.Up + ( toSpec $ + Left $ + PrepareRemoteMigrationSetup $ + fmap remoteMigrationDir migrations + ) + + remoteApply :: G MigrationFile -> Op + remoteApply migrations = + trackedGraph $ + Self.uploadAndCallSelfAsSudo + (contramap UploadSelf r) + (contramap CallSelf r) + "tmp" + selfRemote + selfpath + Ssh.preExistingRemoteMachine + simulate + CLI.Up + (toSpec $ Right $ MigrationSetup (remoteMigrationPlan migrations) cfg.cfg_user cfg.cfg_database remotePgSecretPath remoteExtraUsers) + +data PrepareRemoteMigrationSetup + = PrepareRemoteMigrationSetup + { prepare_tmp_migration_paths :: [FilePath] + } + deriving (Generic) +instance FromJSON PrepareRemoteMigrationSetup +instance ToJSON PrepareRemoteMigrationSetup + +-- | locally running to lay the preparation work for remote +prepareRemoteMigration :: + PrepareRemoteMigrationSetup -> + Op +prepareRemoteMigration setup = + op "prepare-remote-migration" (deps [FS.dir (FS.Directory path) | path <- setup.prepare_tmp_migration_paths]) id + +data MigrationSetup + = MigrationSetup + { setup_migration :: G MigrationFile + , setup_user :: User + , setup_database :: Database + , setup_tmp_secret_path :: FilePath + , setup_extra_users :: [(User, FilePath)] + } + deriving (Generic) +instance FromJSON MigrationSetup +instance ToJSON MigrationSetup + +applyUserScriptMigration :: + Reporter Report -> + Track' (Binary "psql") -> + Track' (ConnString FilePath) -> + MigrationSetup -> + Op +applyUserScriptMigration r psql mkConnstring setup = + migrateG r psql style setup.setup_migration + where + style = MigrateUserScript mkConnstring connstring + connstring = + ConnString localServer setup.setup_user setup.setup_tmp_secret_path setup.setup_database + +applyAdminScriptMigration :: + Reporter Report -> + Track' (Binary "psql") -> + Track' DatabaseName -> + MigrationSetup -> -- TODO: no user required for admin + Op +applyAdminScriptMigration r psql mkdb setup = + migrateG r psql style setup.setup_migration + where + style = MigrateAdminScript mkdb (setup.setup_database.getDatabase) + +pgPassword :: Reporter Report -> Track' FilePath +pgPassword r = Track $ \path -> + Secrets.sharedSecretFile + (contramap CreatePassword r) + Debian.openssl + (Secrets.Secret Secrets.Hex 48 path) + +pgConnstringFile :: Reporter Report -> ConnString FilePath -> Track' FilePath +pgConnstringFile r conn = + Track $ \cstringpath -> + op "pg-connstring" (deps [run (pgPassword r) passFile]) $ \actions -> + actions + { ref = mkRef "connstring" cstringpath + , help = "store connection string at " <> Text.pack cstringpath + , up = do + pass <- readPassword passFile + let contents = connstring (withPassword conn pass) + Text.writeFile cstringpath contents + } + where + passFile :: FilePath + passFile = conn.connstring_user_pass diff --git a/src/SreBox/PostgresPair.hs b/src/SreBox/PostgresPair.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/PostgresPair.hs @@ -0,0 +1,1561 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | 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 (..), + memberOn, + slotNameFor, + + -- * What the machines are + Lsn (..), + parseLsn, + Observed (..), + sysidOf, + probeScript, + parseObserved, + BouncerState (..), + bouncerProbeScript, + parseBouncerState, + + -- * 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, +) where + +import Control.Concurrent (threadDelay) +import Control.Exception (throwIO) +import Data.Aeson (FromJSON, ToJSON) +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_ssh_user@ and @member_host@ are how the /controller/ reaches it; +@member_host@ is also how the peer and the bouncers do, so it has to be an +address both can use. +-} +data Member + = Member + { member_ssh_user :: Text + , 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. + } + deriving (Eq, Show, Generic) + +instance FromJSON Member +instance ToJSON Member + +{- | 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 + , 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'. + } + deriving (Eq, Show, Generic) + +instance FromJSON Bouncer +instance ToJSON Bouncer + +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. + } + deriving (Eq, Show, Generic) + +instance FromJSON Pair +instance ToJSON Pair + +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, for the one database this pair owns. +parseBouncerState :: Bouncer -> Text -> BouncerState +parseBouncerState b 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 b.bouncer_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 ` -- 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 ;;" + , "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" + , -- 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 " <> Text.unpack b.bouncer_alias) <> " 2>&1)" <> " || true" + , "paused=$(" <> showDatabasesColumn b "paused" <> ")" + , "[ \"$paused\" = 1 ] || { echo " <> shQuote ("bouncer " <> Text.unpack b.bouncer_name <> " did not pause " <> Text.unpack b.bouncer_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. -} + repointScript side b = + unlines + [ "set -e" + , "cat > " <> shQuote b.bouncer_routing_path <> " <<'SALMON_ROUTING'" + , "[databases]" + , Text.unpack b.bouncer_alias + <> " = host=" + <> Text.unpack (on side).member_host + <> " port=" + <> port side + <> " dbname=" + <> Text.unpack b.bouncer_dbname + , "SALMON_ROUTING" + , consoleCommand b "-tAX" "RELOAD" <> " >/dev/null" + , "said=$(" <> consoleCommand b "-tAX" ("RESUME " <> Text.unpack b.bouncer_alias) <> " 2>&1)" <> " || true" + , "host=$(" <> showDatabasesColumn b "host" <> ")" + , "paused=$(" <> showDatabasesColumn b "paused" <> ")" + , "[ \"$host\" = " <> shQuote (Text.unpack (on side).member_host) <> " ] && [ \"$paused\" = 0 ]" + <> " || { echo " <> shQuote ("bouncer " <> Text.unpack b.bouncer_name <> " is still sending clients to $host (paused=$paused), and said:") <> " \"$said\" >&2; exit 1; }" + ] + + {- One column of this pair'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 col = + consoleCommand b "-AX" "SHOW DATABASES" + <> " | awk -F'|' -v col=" + <> shQuote col + <> " -v want=" + <> shQuote (Text.unpack b.bouncer_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 }'" + +{- 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 + ] + +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" + ] + +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" + ] + + +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) + ] + , up = do + (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) + +{- | The script 'member' runs. Pure, like the steps, so that what it does to +a machine can be read without one. +-} +{- | 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 + (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 $ + [ 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 " <> b.bouncer_alias <> " 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'" + , "[databases]" + , Text.unpack b.bouncer_alias + <> " = host=" + <> Text.unpack primary.member_host + <> " port=" + <> show primary.member_port + <> " dbname=" + <> Text.unpack b.bouncer_dbname + , "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 + } + +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) + <> map hbaLine + [ "host replication " <> Text.unpack pair.pair_repl_role <> " " <> Text.unpack peer.member_host <> "/32 md5" + , "host all " <> Text.unpack pair.pair_rewind_role <> " " <> Text.unpack peer.member_host <> "/32 md5" + ] + <> -- 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) + , "fi" + ] + <> [ psql' "SELECT pg_reload_conf()" + , -- 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 + + 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\"" + + 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 < sql <> "\nPAIR_SQL" + + {- Created if missing, and its password set either way, so that rotating + the passfile is enough to rotate the role. -} + roleSql attrs role pw = + "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 + <> "';" + + 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 = 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 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 -> parseBouncerState b out + ExitFailure _ -> BouncerState Nothing False + +-- | 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 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, identity) = case target of + OnMember m -> (m.member_ssh_user <> "@" <> m.member_host, m.member_ssh_identity) + OnBouncer b -> (b.bouncer_ssh_user <> "@" <> b.bouncer_ssh_host, b.bouncer_ssh_identity) + {- 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 + 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] + , ["bash", "-c", shQuote quieted] + ] + decode = Text.decodeUtf8With TextError.lenientDecode diff --git a/src/SreBox/PostgresTemplate.hs b/src/SreBox/PostgresTemplate.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/PostgresTemplate.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE DeriveGeneric #-} + +{- | Template databases: build a database once, lock it, and hand out copies. + +The builtins ("Salmon.Builtin.Nodes.Postgres", under /Template databases/) +know how to lock, stamp, clone and drop. This module adds the one thing they +cannot express: that the template's contents are /behind/ its check. + += Why the build is opaque + +The obvious shape is a lock node depending on the migrations that fill the +database. It breaks on the second @run up@: a walk applies dependencies +before it asks a dependant's check, so the migrations run first -- against a +database that now refuses connections, since that is what locking it means. +Nothing in a node's check can stop its dependencies being applied. + +So 'template' carries the build as an 'Op' of its own and walks it from +inside @up@, the same move as +"SreBox.PostgresMigrations".@remoteMigrateOpaqueSetup@. The check then +guards the whole build: a template stamped with the current inputs is +skipped outright, and anything else is rebuilt __from nothing__ -- dropped, +recreated, filled, locked. Never migrated in place, which is what makes the +fingerprint worth trusting: it describes everything that went into the +database, not the last few steps. + += The fingerprint + +'template_fingerprint' is whatever identifies the inputs -- normally a hash +of the migration files, see 'fingerprint'. It is stamped on the database +when a build finishes and compared by the check, and it goes into the node's +@notes@ so that under @run serve@ a re-declaration with new inputs is seen +as a change to the node (see "Salmon.Actions.Serve"'s @Stale@) rather than +as the same node declared again. +-} +module SreBox.PostgresTemplate ( + Report (..), + Template (..), + template, + fingerprint, + fileFingerprintParts, +) where + +import Control.Exception (throwIO) +import Control.Monad (unless) +import Control.Monad.Identity (runIdentity) +import Crypto.Hash.SHA256 as SHA256 +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as C8 +import Data.Dynamic (toDyn) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import GHC.Generics (Generic) + +import qualified Salmon.Actions.Dot as Dot +import qualified Salmon.Actions.UpDown as UpDown +import Salmon.Builtin.Extension +import Salmon.Builtin.Nodes.Binary (Binary, withBinaryStdin) +import qualified Salmon.Builtin.Nodes.Postgres as Postgres +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- + +data Report + = TemplateSql !Postgres.Report + | Build !Postgres.DatabaseName !(UpDown.Report Extension) + deriving (Show) + +------------------------------------------------------------------------------- + +data Template + = Template + { template_database :: Postgres.DatabaseName + , template_fingerprint :: Text + -- ^ identifies the build's inputs; any change rebuilds the template. + } + deriving (Eq, Show, Generic) + +instance FromJSON Template +instance ToJSON Template + +{- | A database built by @build@, then locked as a template. + +@build@ fills the database named 'template_database' -- a migration graph, +normally -- and may assume it exists and is empty: 'template' creates it +first. It runs as a nested walk (see the module header), so it does not +appear in @run tree@ and its nodes are not shared with the surrounding graph. +The cluster is an ordinary dependency instead, since the database has to be +created before @build@ starts. + +@down@ drops the template. Clones already taken from it are independent +copies and are unaffected. +-} +template :: + Reporter Report -> + Track' Postgres.Server -> + Track' (Binary "psql") -> + Postgres.Server -> + Template -> + Op -> + Op +template r cluster psql server tpl build = + batch (Postgres.prepareTemplateSql name) $ \prepare -> + batch (Postgres.lockTemplateSql name tpl.template_fingerprint) $ \lock -> + batch (Postgres.dropTemplateSql name) $ \dropIt -> + op "pg-template" (deps [run cluster server]) $ \actions -> + actions + { -- the same key as 'Postgres.database': a template is a + -- database at that site, and declaring a template and a + -- clone under one name is a collision worth reporting. + ref = mkRef "pg-db" (port, name) + , help = Text.unwords ["builds template database", name] + , notes = ["built from inputs " <> tpl.template_fingerprint, "rebuilt from nothing whenever the inputs change"] + , check = Postgres.checkTemplate port name tpl.template_fingerprint + , up = do + prepare r' + ok <- UpDown.upTree (contramap (Build name) r) (pure . runIdentity) build + -- a nested walk's failure is invisible to the outer + -- one unless this throws; the database is left + -- marked half-built, so the next pass starts over. + unless ok (throwIO (userError ("building template " <> Text.unpack name <> " failed"))) + lock r' + , down = dropIt r' + , dynamics = [toDyn (Dot.OpaqueNode "template build")] + } + where + name = tpl.template_database + port = server.serverPort + r' = contramap (TemplateSql . Postgres.PGTemplate name) r + batch sql = withBinaryStdin psql (Postgres.psqlBatchRun_Sudo port) Postgres.PsqlBatch (Text.encodeUtf8 sql) + +------------------------------------------------------------------------------- + +{- | A stable hash over a list of parts. + +Each part is length-prefixed, so @["ab", "c"]@ and @["a", "bc"]@ differ -- +which matters when the parts are paths and contents laid end to end. +-} +fingerprint :: [ByteString.ByteString] -> Text +fingerprint parts = + Text.decodeUtf8 $ Base16.encode $ SHA256.finalize $ SHA256.updates SHA256.init (concatMap framed parts) + where + framed p = [C8.pack (show (ByteString.length p)) <> ":", p] + +-- | Each file's path and contents, in the order given; feed to 'fingerprint'. +fileFingerprintParts :: [FilePath] -> IO [ByteString.ByteString] +fileFingerprintParts paths = + concat <$> traverse (\p -> (\c -> [C8.pack p, c]) <$> ByteString.readFile p) paths diff --git a/src/SreBox/PostgresTls.hs b/src/SreBox/PostgresTls.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/PostgresTls.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Postgres authenticating its clients by __certificate__ rather than by +password, and the material that makes that possible. + +This is the half that + leaves unspecified: it gives the client's side of the connection +(@sslmode=verify-ca sslcert=… sslkey=… sslrootcert=…@) and says nothing about +what the server has to be told for that string to work. The answer is four +settings, one @pg_hba.conf@ line, and three files with the right owner. + += Why certificates rather than a password + +Because of where the client runs. A password reaching a serverless container +has to be stored somewhere it can be read at start-up, which is a secret +store, which is the same amount of machinery as a certificate -- and then the +password is /also/ replayable by anyone who ever sees it, while a certificate +is only usable by whoever holds the key. The clinching detail is +@clientcert=verify-full@: it requires the certificate's @CN@ to __equal the +database role__, so "who may connect as @api_owner@" becomes "who holds a +certificate this CA issued for that name", and there is no shared secret in +the system at all. + += What this module does not do + +It does not move files between machines. The server material belongs on the +database host and the client material belongs wherever the client is +deployed from, and how they get there -- rsync, a secret manager, an operator +with a USB stick -- is the caller's business, expressed by handing in a +'Track''. Recipes here stay transport-agnostic about secrets on purpose. + += The three ways the pieces are usually arranged + +* __One box.__ The CA, the server material and the client material are all + generated on the database host: pass 'generatedAuthority' everywhere. +* __A CA somewhere else.__ The database host receives cert, key and CA cert + that were signed elsewhere. Pass 'ignoreTrack' as the material track and + give 'postgresClientCertAuth' the paths the files already occupy. +* __Client deployed from a workstation.__ The CA and 'generateClientMaterial' + run there, the resulting three files are pushed into a secret store, and + the database host only ever sees 'postgresClientCertAuth'. This is the + Cloud Run shape. +-} +module SreBox.PostgresTls ( + Report (..), + + -- * The database side + ClientAccess (..), + PostgresClientCertConfig (..), + postgresClientCertAuth, + + -- * Certificate material + generatedAuthority, + ServerMaterialConfig (..), + generateServerMaterial, + ClientMaterialConfig (..), + generateClientMaterial, + clientMaterialPaths, + + -- * Connecting as a client + SslMode (..), + renderSslMode, + clientConnString, +) where + +import Data.Text (Text) +import qualified Data.Text as Text +import System.FilePath (()) +import System.Posix.Types (FileMode) + +import Salmon.Builtin.Extension +import Salmon.Builtin.Nodes.Binary (Binary) +import qualified Salmon.Builtin.Nodes.Certificates as Certs +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Postgres as Postgres +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- + +data Report + = GenerateCertificate !Certs.Report + | ConfigureCluster !Postgres.Report + deriving (Show) + +------------------------------------------------------------------------------- +-- The database side + +{- | One role that may authenticate by certificate, and from where. + +@ca_cidr@ is worth a thought rather than a default: a certificate is the +whole authentication, so a wide range is not the exposure it would be with a +password -- but it is still the difference between "an attacker needs the key" +and "an attacker needs the key /and/ a foothold in this network". Serverless +clients have no stable egress address without a NAT, which is the usual +reason this ends up wide. +-} +data ClientAccess = ClientAccess + { ca_role :: Postgres.RoleName + -- ^ must equal the @CN@ of the certificate this client presents + , ca_database :: Postgres.DatabaseName + , ca_cidr :: Postgres.AllowedCidr + } + deriving (Eq, Show) + +{- | Everything the database host is told. + +'pgcc_material' is the track that makes 'pgcc_tls'\'s three files exist: +'generateServerMaterial' when this graph issues them, 'ignoreTrack' when +something else already put them there. +-} +data PostgresClientCertConfig = PostgresClientCertConfig + { pgcc_cluster :: Postgres.ClusterName + , pgcc_port :: Postgres.Port + , pgcc_tls :: Postgres.ServerTls + , pgcc_owner :: Text + -- ^ the OS user the cluster runs as, usually @postgres@ + , pgcc_clients :: [ClientAccess] + } + +{- | Serves TLS, trusts one CA, and lets the named roles in on a certificate. + +Ordering is the whole content of this node and it is not obvious: the +@pg_hba.conf@ lines are injected __after__ the TLS settings, because a +@hostssl@ line on a cluster with @ssl = off@ is accepted and then matches +nothing, which presents as "my client hangs on a password prompt" a long way +from the cause. +-} +postgresClientCertAuth :: + Reporter Report -> + Track' (Binary "psql") -> + Track' (Binary "pg_ctlcluster") -> + Track' Postgres.ServerTls -> + PostgresClientCertConfig -> + Op +postgresClientCertAuth r psql pgctl materialTrack cfg = + op "pg-client-cert-auth" (deps (map hba cfg.pgcc_clients)) $ \actions -> + actions + { help = Text.unwords ["authenticates", nRoles, "role(s) by certificate on", cfg.pgcc_cluster] + , ref = mkRef "pg-client-cert-auth" (cfg.pgcc_cluster, cfg.pgcc_port) + } + where + rPg = contramap ConfigureCluster r + nRoles = Text.pack (show (length cfg.pgcc_clients)) + + hba :: ClientAccess -> Op + hba client = + Postgres.allowClientCertFrom + rPg + pgctl + cfg.pgcc_cluster + client.ca_database + client.ca_role + client.ca_cidr + `inject` tls + + tls :: Op + tls = + Postgres.serverTls rPg psql cfg.pgcc_port cfg.pgcc_tls + `inject` ownedMaterial + + -- Postgres refuses to start with a group- or world-readable key, and + -- says so in terms of permissions rather than of TLS. Declaring the + -- ownership as its own node means that rule is enforced wherever the + -- file came from -- including the 'ignoreTrack' case, where salmon did + -- not write it and cannot know what mode it arrived with. + ownedMaterial :: Op + ownedMaterial = + op "pg-tls-material" (deps [keyOwnership, certOwnership, caOwnership]) $ \actions -> + actions + { help = "places the cluster's TLS material with the ownership postgres demands" + , ref = mkRef "pg-tls-material" (cfg.pgcc_port, cfg.pgcc_tls.tls_keyFile) + } + + keyOwnership = owned cfg.pgcc_tls.tls_keyFile 0o600 + certOwnership = owned cfg.pgcc_tls.tls_certFile 0o644 + caOwnership = owned cfg.pgcc_tls.tls_caFile 0o644 + + owned :: FilePath -> FileMode -> Op + owned path mode = + FS.ownedFile + FS.FileOwnership + { FS.ownedPath = path + , FS.ownedUser = Just cfg.pgcc_owner + , FS.ownedGroup = Just cfg.pgcc_owner + , FS.ownedMode = mode + } + `inject` run materialTrack cfg.pgcc_tls + +------------------------------------------------------------------------------- +-- Material + +{- | A CA this graph owns. Pass the result to 'generateServerMaterial' and +'generateClientMaterial'; pass 'ignoreTrack' instead wherever the CA is +somebody else's and merely has to be present. +-} +generatedAuthority :: Reporter Report -> Track' (Binary "openssl") -> Track' Certs.CertificateAuthority +generatedAuthority r openssl = + Track $ Certs.certificateAuthority (contramap GenerateCertificate r) openssl + +{- | What to issue for the server. + +'smc_commonName' is the name clients will use in @host=@ if they ever move +from @verify-ca@ to @verify-full@; under @verify-ca@ it is not checked at +all, which is a trap worth knowing about — a wrong name here costs nothing +until the day somebody tightens the client's @sslmode@. +-} +data ServerMaterialConfig = ServerMaterialConfig + { smc_commonName :: Certs.Domain + , smc_authority :: Certs.CertificateAuthority + , smc_key :: Certs.Key + , smc_csrDir :: FilePath + , smc_validityDays :: Int + , smc_tls :: Postgres.ServerTls + -- ^ where the signed certificate, its key and the CA certificate land + } + +{- | Issues the cluster's certificate, as a track over the paths it fills in. + +The CA certificate is /copied/ to 'Postgres.tls_caFile' rather than being +pointed at where it already lives, because the cluster reads that file as the +@postgres@ user and the CA's own directory is a +'Salmon.Builtin.Nodes.Filesystem.retainedDir' holding a private key that user +has no business being able to reach. +-} +generateServerMaterial :: + Reporter Report -> + Track' (Binary "openssl") -> + Track' Certs.CertificateAuthority -> + ServerMaterialConfig -> + Track' Postgres.ServerTls +generateServerMaterial r openssl caTrack cfg = + Track $ \_tls -> + op "pg-server-material" (deps [copyCert, copyKey, copyCa]) $ \actions -> + actions + { help = "issues the cluster's TLS certificate" + , ref = mkRef "pg-server-material" cfg.smc_tls.tls_certFile + } + where + r' = contramap GenerateCertificate r + + request :: Certs.SigningRequest + request = + Certs.SigningRequest + { Certs.certDomain = cfg.smc_commonName + , Certs.certKey = cfg.smc_key + , Certs.certCSRDir = cfg.smc_csrDir + , Certs.certCSRName = Certs.getDomain cfg.smc_commonName <> ".csr" + } + + pemPath :: FilePath + pemPath = cfg.smc_csrDir Text.unpack (Certs.getDomain cfg.smc_commonName <> ".pem") + + signed :: Op + signed = + Certs.caSign + r' + openssl + caTrack + Certs.CaSigned + { Certs.caSignedPEMPath = pemPath + , Certs.caSignedRequest = request + , Certs.caSignedAuthority = cfg.smc_authority + , Certs.caSignedValidityDays = cfg.smc_validityDays + } + + copyCert = FS.fileCopy pemPath cfg.smc_tls.tls_certFile `inject` signed + copyKey = FS.fileCopy (Certs.keyPath cfg.smc_key) cfg.smc_tls.tls_keyFile `inject` signed + copyCa = FS.fileCopy cfg.smc_authority.caCertPath cfg.smc_tls.tls_caFile `inject` run caTrack cfg.smc_authority + +------------------------------------------------------------------------------- + +{- | What to issue for one client. + +'cmc_role' is both the @CN@ of the certificate and the Postgres role it will +be accepted as — they are the same string by construction here, which is the +only way @clientcert=verify-full@ ever succeeds. Getting them out of step is +the single most common way this setup fails, and it fails with +@certificate authentication failed for user@ rather than with anything about +names. +-} +data ClientMaterialConfig = ClientMaterialConfig + { cmc_role :: Postgres.RoleName + , cmc_authority :: Certs.CertificateAuthority + , cmc_dir :: FilePath + , cmc_keyType :: Certs.KeyType + , cmc_validityDays :: Int + } + +{- | The three files a libpq client needs: key, certificate, CA certificate. + +The key is left where 'Certs.tlsKey' put it (a @retainedDir@) and is +'Salmon.Builtin.Nodes.Filesystem.ownedFile'-restricted to @0600@, because +libpq refuses a key any wider — the same rule the server applies, enforced on +the other end and reported just as obscurely. +-} +generateClientMaterial :: + Reporter Report -> + Track' (Binary "openssl") -> + Track' Certs.CertificateAuthority -> + ClientMaterialConfig -> + Op +generateClientMaterial r openssl caTrack cfg = + op "pg-client-material" (deps [restrictedKey, signed, caCopy]) $ \actions -> + actions + { help = Text.unwords ["issues a client certificate for role", cfg.cmc_role] + , ref = mkRef "pg-client-material" (cfg.cmc_dir, cfg.cmc_role) + } + where + r' = contramap GenerateCertificate r + paths = clientMaterialPaths cfg + + key :: Certs.Key + key = Certs.Key cfg.cmc_keyType cfg.cmc_dir (cfg.cmc_role <> ".key") + + request :: Certs.SigningRequest + request = + Certs.SigningRequest + { -- the CN *is* the role name; see the note on 'cmc_role' + Certs.certDomain = Certs.Domain cfg.cmc_role + , Certs.certKey = key + , Certs.certCSRDir = cfg.cmc_dir + , Certs.certCSRName = cfg.cmc_role <> ".csr" + } + + signed :: Op + signed = + Certs.caSign + r' + openssl + caTrack + Certs.CaSigned + { Certs.caSignedPEMPath = fst3 paths + , Certs.caSignedRequest = request + , Certs.caSignedAuthority = cfg.cmc_authority + , Certs.caSignedValidityDays = cfg.cmc_validityDays + } + + restrictedKey :: Op + restrictedKey = + FS.ownedFile + FS.FileOwnership + { FS.ownedPath = snd3 paths + , FS.ownedUser = Nothing + , FS.ownedGroup = Nothing + , FS.ownedMode = 0o600 + } + `inject` signed + + caCopy :: Op + caCopy = + FS.fileCopy cfg.cmc_authority.caCertPath (thd3 paths) + `inject` run caTrack cfg.cmc_authority + +-- | The (certificate, key, CA certificate) paths 'generateClientMaterial' fills in. +clientMaterialPaths :: ClientMaterialConfig -> (FilePath, FilePath, FilePath) +clientMaterialPaths cfg = + ( cfg.cmc_dir Text.unpack (cfg.cmc_role <> ".pem") + , cfg.cmc_dir Text.unpack (cfg.cmc_role <> ".key") + , cfg.cmc_dir "ca.pem" + ) + +fst3 :: (a, b, c) -> a +fst3 (a, _, _) = a + +snd3 :: (a, b, c) -> b +snd3 (_, b, _) = b + +thd3 :: (a, b, c) -> c +thd3 (_, _, c) = c + +------------------------------------------------------------------------------- + +{- | How hard a client checks the server. + +@verify-ca@ proves the server's certificate was issued by the expected CA; +@verify-full@ additionally requires its name to match @host=@. With a private +CA the first already excludes everybody but this CA's holders, which is why +it is what the write-up uses — but it does not distinguish /which/ of them +answered, so a CA that also issues to untrusted parties needs the second. +-} +data SslMode + = VerifyCa + | VerifyFull + deriving (Eq, Show) + +renderSslMode :: SslMode -> Text +renderSslMode VerifyCa = "verify-ca" +renderSslMode VerifyFull = "verify-full" + +{- | A libpq connection string authenticating by certificate. + +Deliberately keyword/value form rather than a URI: the three file paths are +what libpq wants and a URI would have to percent-encode them, and this is the +string that ends up in a container's environment where it will be read by +people. + +The paths are the client's view of where the files are __at run time__, which +is not necessarily where 'generateClientMaterial' wrote them — a secret +manager may well mount them somewhere else entirely. +-} +clientConnString :: + Postgres.Server -> + Postgres.DatabaseName -> + Postgres.RoleName -> + SslMode -> + -- | (certificate, key, CA certificate), as the client will see them + (FilePath, FilePath, FilePath) -> + Text +clientConnString server db role mode (cert, key, ca) = + Text.unwords + [ "host=" <> server.serverHost + , "port=" <> Text.pack (show server.serverPort) + , "dbname=" <> db + , "user=" <> role + , "sslmode=" <> renderSslMode mode + , "sslcert=" <> Text.pack cert + , "sslkey=" <> Text.pack key + , "sslrootcert=" <> Text.pack ca + ] diff --git a/src/SreBox/Postgrest.hs b/src/SreBox/Postgrest.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/Postgrest.hs @@ -0,0 +1,381 @@ +{-# LANGUAGE DeriveGeneric #-} + +module SreBox.Postgrest where + +import Data.Aeson (FromJSON, ToJSON) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import GHC.Generics (Generic) +import System.Directory +import System.FilePath + +import qualified Salmon.Builtin.CommandLine as CLI +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Migrations as Migrations +import qualified Salmon.Builtin.Nodes.Certificates as Certs +import qualified Salmon.Builtin.Nodes.Continuation as Continuation +import qualified Salmon.Builtin.Nodes.Debian.OS as Debian +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Postgres as Postgres +import qualified Salmon.Builtin.Nodes.Rsync as Rsync +import qualified Salmon.Builtin.Nodes.Secrets as Secrets +import qualified Salmon.Builtin.Nodes.Self as Self +import qualified Salmon.Builtin.Nodes.Ssh as Ssh +import qualified Salmon.Builtin.Nodes.Systemd as Systemd +import Salmon.Op.G (G (..)) +import Salmon.Op.OpGraph (OpGraph (..), inject) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track (Track (..), Tracked (..), trackedGraph, using, (>*<)) +import Salmon.Reporter + +import qualified Salmon.Builtin.Nodes.Git as Git +import SreBox.CabalBuilding (cabalBinUpload, postgrest) +import qualified SreBox.CabalBuilding as CabalBuilding +import SreBox.Environment +import qualified SreBox.PostgresInit as PGInit +import qualified SreBox.PostgresMigrations as PGMigrate + +------------------------------------------------------------------------------- +data Report + = Build !CabalBuilding.Report + | Upload !CabalBuilding.Report + | CallSelf !Self.Report + | UploadSelf !Self.Report + | UploadFile !Rsync.Report + | GetSources !Git.Report + | InitializeDB !PGInit.Report + | Migration !PGMigrate.Report + | SetupSystemd !Systemd.Report + deriving (Show) + +------------------------------------------------------------------------------- + +type ServiceName = Text + +type PortNumber = Int + +data PostgrestConfig + = PostgrestConfig + { postgrest_cfg_serviceName :: ServiceName + , postgrest_cfg_portnum :: PortNumber + , postgrest_cfg_anonRole :: Postgres.Group + , postgrest_cfg_connectionString :: Postgres.ConnString FilePath + , postgrest_cfg_configPath :: FilePath + -- TODO: schemas + } + +data PostgrestSetup + = PostgrestSetup + { postgrest_setup_serviceName :: ServiceName + , postgrest_setup_localBinPath :: FilePath + , postgrest_setup_localConfigPath :: FilePath + , postgrest_setup_localConnstringPath :: FilePath + , postgrest_setup_localJwtKeySecretPath :: FilePath + } + deriving (Generic) +instance FromJSON PostgrestSetup +instance ToJSON PostgrestSetup + +setupPostgrest :: + (FromJSON directive, ToJSON directive) => + Reporter Report -> + Track' Ssh.Remote -> + Track' directive -> + Self.Remote -> + Self.SelfPath -> + (PostgrestSetup -> directive) -> + Track' FilePath -> + FilePath -> + FilePaths -> + PostgrestConfig -> + Op +setupPostgrest r mkRemote simulate selfRemote selfpath toSpec makeJwt jwtFilePath paths cfg = + using uploadbuiltfile $ \remotepath -> + let + setup = + PostgrestSetup + cfg.postgrest_cfg_serviceName + remotepath + remoteConfig + remoteConnstring + remoteJwtSecret + in + trackedGraph (continueRemotely setup) `inject` configUploads + where + uploadbuiltfile = + cabalBinUpload + (contramap Upload r) + (postgrest (contramap Build r)) + rsyncRemote + rsyncRemote :: Rsync.Remote + rsyncRemote = (\(Self.Remote a b) -> Rsync.Remote a b) selfRemote + + configUploads = + let opdeps = deps [uploadConfig, uploadConnStringFile, uploadJwtFile] + in op "uploads-postgrest-configs" opdeps $ \actions -> + actions + { notes = + [ "for service: " <> cfg.postgrest_cfg_serviceName + ] + , ref = mkRef "postgrest-uploads" cfg.postgrest_cfg_serviceName + } + + -- recursive call + continueRemotely setup = + Self.uploadAndCallSelfAsSudo + (contramap UploadSelf r) + (contramap CallSelf r) + "tmp" + selfRemote + selfpath + mkRemote + simulate + CLI.Up + (toSpec setup) + + -- upload config file + remoteConfig = Text.unpack $ "tmp/postgrest-" <> cfg.postgrest_cfg_serviceName <> ".config" + remoteConnstring = Text.unpack $ "tmp/postgrest-" <> cfg.postgrest_cfg_serviceName <> ".connstring" + remoteJwtSecret = Text.unpack $ "tmp/postgrest-" <> cfg.postgrest_cfg_serviceName <> ".shared-secret" + + upload gen localpath distpath = + Rsync.sendFile (contramap UploadFile r) Debian.rsync (FS.Generated gen localpath) rsyncRemote distpath + + uploadConfig = + upload makeConfig cfg.postgrest_cfg_configPath remoteConfig + where + -- make config using remote filepaths as contents + makeConfig = + Track $ \path -> + let connectionString = paths.connstringPath cfg.postgrest_cfg_serviceName + jwtSigningKey = paths.jwtSigningKeyPath cfg.postgrest_cfg_serviceName + in FS.filecontents $ + (FS.FileContents path (renderConfig cfg jwtSigningKey connectionString)) + + uploadConnStringFile = + upload makeConnstring connstringFilePath remoteConnstring + where + makeConnstring = PGMigrate.pgConnstringFile (contramap Migration r) (cfg.postgrest_cfg_connectionString) + + connstringFilePath = + Text.unpack $ mconcat ["./configs/posgtrest/postgrest-", cfg.postgrest_cfg_serviceName, ".connstring"] + + uploadJwtFile = + upload makeJwt jwtFilePath remoteJwtSecret + +renderConfig :: PostgrestConfig -> FilePath -> FilePath -> Text +renderConfig cfg secretFilePath connstringFilePath = + Text.unlines + [ kv_text "db-anon-role" $ Postgres.groupRole cfg.postgrest_cfg_anonRole + , kv_text "db-channel" "pgrst" + , kv_bool "db-channel-enabled" True + , kv_bool "db-config" True + , kv_text "db-extra-search-path" "public" + , kv_int "db-pool" 10 + , kv_bool "db-prepared-statements" True + , kv_text "db-schemas" "public" + , kv_text "db-tx-end" "commit" + , kv_text "db-uri" (Text.pack $ '@' : connstringFilePath) + , kv_text "jwt-role-claim-key" ".role" + , kv_text "jwt-secret" (Text.pack $ '@' : secretFilePath) + , kv_bool "jwt-secret-is-base64" True + , kv_text "log-level" "error" + , kv_text "openapi-mode" "follow-privileges" + , kv_text "openapi-server-proxy-uri" "" + , kv_text "server-host" "!4" + , kv_int "server-port" cfg.postgrest_cfg_portnum + , kv_bool "server-timing-enabled" False + ] + where + kv_text k v = Text.unwords [k, "=", "\"" <> v <> "\""] + kv_bool k v = Text.unwords [k, "=", if v then "true" else "false"] + kv_int k v = Text.unwords [k, "=", Text.pack $ show v] + +systemdPostgrest :: Reporter Report -> FilePaths -> PostgrestSetup -> Op +systemdPostgrest r paths setup = + Systemd.systemdService (contramap SetupSystemd r) Debian.systemctl trackConfig config + where + trackConfig :: Track' Systemd.Config + trackConfig = Track $ \cfg -> + let + execPath = Systemd.start_path $ Systemd.service_execStart $ Systemd.config_service $ cfg + copybin = FS.fileCopy (postgrest_setup_localBinPath setup) execPath + copyConfig = FS.fileCopy (postgrest_setup_localConfigPath setup) cpath + copyConnstringSecret = FS.fileCopy (postgrest_setup_localConnstringPath setup) sconnstringpath + copyJwtKeySecret = FS.fileCopy (postgrest_setup_localJwtKeySecretPath setup) sjwtpath + in + op "setup-systemd-for-postgrest" (deps [copybin, copyConfig, copyJwtKeySecret, copyConnstringSecret]) $ \actions -> + actions + { ref = mkRef "postgrest-systemd" setup.postgrest_setup_serviceName + } + + config :: Systemd.Config + config = Systemd.Config Systemd.System "/etc/systemd/system" tgt unit service install + + tgt :: Systemd.UnitTarget + tgt = "salmon-postgrest-" <> setup.postgrest_setup_serviceName <> ".service" + + unit :: Systemd.Unit + unit = Systemd.Unit (mconcat ["Postgrest from Salmon (", setup.postgrest_setup_serviceName, ")"]) "network-online.target" + + service :: Systemd.Service + service = Systemd.Service Systemd.Simple "root" "root" "007" start Systemd.OnFailure Systemd.Process "/opt/rundir/postgrest" + + start :: Systemd.Start + start = + Systemd.Start + "/opt/rundir/postgrest/bin/postgrest" + [ Text.pack cpath + ] + + cpath :: FilePath + cpath = paths.configPath setup.postgrest_setup_serviceName + + sconnstringpath :: FilePath + sconnstringpath = paths.connstringPath setup.postgrest_setup_serviceName + + sjwtpath :: FilePath + sjwtpath = paths.jwtSigningKeyPath setup.postgrest_setup_serviceName + + install :: Systemd.Install + install = Systemd.Install "multi-user.target" + +------------------------------------------------------------------------------- + +data FilePaths + = FilePaths + { configPath :: ServiceName -> FilePath + , connstringPath :: ServiceName -> FilePath + , jwtSigningKeyPath :: ServiceName -> FilePath + } + +defaultFilePaths :: FilePaths +defaultFilePaths = + FilePaths + configPath + connstringPath + jwtSigningKeyPath + where + configPath name = + "/opt/rundir/postgrest" Text.unpack name "config.txt" + + connstringPath name = + "/opt/rundir/postgrest" Text.unpack name "connstring.connstring" + + jwtSigningKeyPath name = + "/opt/rundir/postgrest" Text.unpack name "jwt-shared-secret" + +------------------------------------------------------------------------------- + +data PostgrestMigratedApiConfig + = PostgrestMigratedApiConfig + { pma_serviceName :: Text + , pma_apiPort :: Int + , pma_repo :: Git.Repo + , pma_migrationTip :: FilePath + , pma_migrationsPrefix :: FilePath + , pma_migrate_connstring :: Postgres.ConnString FilePath + , pma_setrole_connstring :: Postgres.ConnString FilePath + , pma_fallback_role :: Postgres.Group + , pma_token_protected_roles :: [Postgres.Group] + } + +postgrestMigratedApi :: + (FromJSON directive, ToJSON directive) => + Reporter Report -> + Track' directive -> + (PGInit.InitSetup FilePath -> directive) -> + (Either PGMigrate.PrepareRemoteMigrationSetup PGMigrate.MigrationSetup -> directive) -> + (PostgrestSetup -> directive) -> + Self.SelfPath -> + Self.Remote -> + Track' FilePath -> + FilePath -> + FilePaths -> + PostgrestMigratedApiConfig -> + Op +postgrestMigratedApi r simulate toSpec0 toSpec1 toSpec2 selfpath remoteSelf mkJwt jwtPath paths cfg = + op "postgrest-api" (deps [prest `inject` migrateDBWithUser `inject` initDB]) $ \actions -> + actions + { ref = mkRef "prest-api" cfg.pma_serviceName + } + where + inputMigrations :: IO (G PGMigrate.MigrationFile) + inputMigrations = + let reader = + Migrations.addFilePrefix (Git.clonedir cfg.pma_repo cfg.pma_migrationsPrefix) $ + PGMigrate.defaultMigrationReader + in G . fmap node <$> Migrations.loadMigrations reader cfg.pma_migrationTip + + exposedDatabase = cfg.pma_migrate_connstring.connstring_db + migrateUser = cfg.pma_migrate_connstring.connstring_user + setroleUser = cfg.pma_setrole_connstring.connstring_user + anonRoleGroup = cfg.pma_fallback_role + extraNonAnonRoleGroups = cfg.pma_token_protected_roles + + cloneSource = Track $ const $ Git.repo (contramap GetSources r) Debian.git cfg.pma_repo + + initDB = + PGInit.remoteSetupPG + (contramap InitializeDB r) + simulate + remoteSelf + selfpath + toSpec0 + ( PGInit.InitSetup + exposedDatabase + (migrateUser, cfg.pma_migrate_connstring.connstring_user_pass) + [ (migrateUser, cfg.pma_migrate_connstring.connstring_user_pass, [Postgres.CONNECT, Postgres.CREATE], []) + , (setroleUser, cfg.pma_setrole_connstring.connstring_user_pass, [Postgres.CONNECT], anonRoleGroup : extraNonAnonRoleGroups) + ] + [ (anonRoleGroup, []) + ] + ) + + migrateDBWithUser = + PGMigrate.remoteMigrateOpaqueSetup + cfg.pma_serviceName + (contramap Migration r) + simulate + remoteSelf + selfpath + toSpec1 + ( PGMigrate.RemoteMigrateConfig + (TrackedIO $ Tracked cloneSource inputMigrations) + (PGMigrate.defaultRemoteMigrationPath exposedDatabase.getDatabase) + migrateUser + exposedDatabase + cfg.pma_migrate_connstring.connstring_user_pass + [] + ) + + prest = op "postgrest" (deps [setupPrest]) $ \actions -> + actions + { ref = mkRef "prest-service" cfg.pma_serviceName + } + + setupPrest = + setupPostgrest + r + Ssh.preExistingRemoteMachine + simulate + remoteSelf + selfpath + toSpec2 + mkJwt + jwtPath + paths + prestConfig + + serviceName = "postgrest-api-" <> cfg.pma_serviceName + prestConfigPath = Text.unpack $ mconcat ["./configs/posgtrest/postgrest-", cfg.pma_serviceName, ".config"] + prestConfig = + PostgrestConfig + serviceName + cfg.pma_apiPort + anonRoleGroup + cfg.pma_setrole_connstring + prestConfigPath diff --git a/src/SreBox/WireGuardVpn.hs b/src/SreBox/WireGuardVpn.hs new file mode 100644 --- /dev/null +++ b/src/SreBox/WireGuardVpn.hs @@ -0,0 +1,231 @@ +{- | A point-to-point WireGuard VPN between a statically-addressed server and a +client that may sit behind a dynamic-IP eyeball connection. + +Design: + +* the server owns the VPN subnet (an RFC1918 /24 carved out of 10.0.0.0/8), + keeps to routing only VPN-subnet traffic on the WireGuard interface (a + dedicated filter-forward base chain with a drop policy only opens up + traffic in/out of that interface), and NATs (masquerades) VPN-subnet + traffic that leaves via any other interface so it can act as the client's + internet exit node; +* the client keeps its normal default route and LAN routes untouched (more + specific routes always win over the routes we add here) and additionally + routes all other traffic over the VPN by installing the classic + @0.0.0.0\/1@ + @128.0.0.0\/1@ split-default routes, plus a pinned host + route to the server's own IP via the original default gateway so the + tunnel's own traffic doesn't try to route over itself; the client also + sets a persistent-keepalive on its peer entry so the NAT/dynamic-IP side + of the tunnel stays punched through. +-} +module SreBox.WireGuardVpn where + +import Data.Text (Text) + +import Salmon.Builtin.Extension +import Salmon.Builtin.Nodes.Binary (Binary, justInstall) +import qualified Salmon.Builtin.Nodes.Binary as Binary +import qualified Salmon.Builtin.Nodes.Netfilter as Nft +import qualified Salmon.Builtin.Nodes.Routes as IpRoute +import qualified Salmon.Builtin.Nodes.Sysctl as Sysctl +import qualified Salmon.Builtin.Nodes.WireGuard as WG +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- +data Report + = RunWireGuard !WG.Report + | RunNft !Nft.Report + | RunSysctl !Sysctl.Report + | RunIpRoute !IpRoute.Report + deriving (Show) + +------------------------------------------------------------------------------- + +{- | Binaries needed on either side of the VPN. Both server and client need +@wg@/@ip@; only the server needs @nft@ and @sysctl@ (for NAT/forwarding). +-} +data Binaries + = Binaries + { binWg :: Track' (Binary "wg") + , binIp :: Track' (Binary "ip") + , binNft :: Track' (Binary "nft") + , binSysctl :: Track' (Binary "sysctl") + } + +------------------------------------------------------------------------------- + +-- | One client of the VPN, as seen from the server side. +data ClientPeer + = ClientPeer + { peerVpnAddr :: WG.IpNet + -- ^ the client's address inside the VPN subnet, e.g. 10.0.3.2/24 + , peerPublicKeyPath :: FilePath + -- ^ path (on the server) to the client's already-provisioned public key + } + +data ServerVpnSpec + = ServerVpnSpec + { server_wg_iface :: WG.WgName + , server_wg_port :: WG.PortNum + , server_wg_privkey_path :: FilePath + , server_vpn_net :: WG.IpNet + -- ^ the VPN subnet as configured on the server's WireGuard interface, e.g. 10.0.3.1/24 + , server_clients :: [ClientPeer] + } + +{- | Sets up the server side: WireGuard interface + peers, IPv4 forwarding, +NAT masquerade for VPN-subnet traffic leaving any non-VPN interface, and a +forward chain restricted to VPN-interface traffic only. +-} +serverVpn :: Reporter Report -> Binaries -> ServerVpnSpec -> Op +serverVpn r bins spec = + op "wireguard-vpn-server" (deps [wgSetup, forwarding, nat]) id + where + wg_r = contramap RunWireGuard r + nft_r = contramap RunNft r + sysctl_r = contramap RunSysctl r + + ifaceTrack :: Track' WG.WgName + ifaceTrack = Track $ \name -> WG.iface wg_r bins.binIp name spec.server_vpn_net + + privkeyTrack :: Track' FilePath + privkeyTrack = Track $ WG.privateKey bins.binWg + + wgSetup :: Op + wgSetup = + op "wireguard-vpn-server-peers" (deps $ fmap addPeer spec.server_clients) id + `inject` serverIface + + serverIface :: Op + serverIface = + WG.server wg_r bins.binWg privkeyTrack ifaceTrack spec.server_wg_iface spec.server_wg_privkey_path spec.server_wg_port + + addPeer :: ClientPeer -> Op + addPeer p = + WG.peer + wg_r + bins.binWg + ignoreTrack -- the client's public key is provisioned out of band (e.g. rsync'd in) + ifaceTrack + ignoreTrack + spec.server_wg_iface + p.peerPublicKeyPath + Nothing -- server never dials out: the client (dynamic IP) always initiates + (WG.iptxt p.peerVpnAddr <> "/32") + + -- ip_forward is required for the server to route between the VPN subnet and the internet + forwarding :: Op + forwarding = + Sysctl.set sysctl_r bins.binSysctl (Sysctl.Setting "net.ipv4.ip_forward" "1") + `inject` forwardChain + + filterTable :: Nft.Table + filterTable = Nft.Table "filter" Nft.Inet + + -- restrict all forwarding to VPN-interface traffic: nothing else gets routed through this box + forwardChain :: Op + forwardChain = + Nft.rule nft_r bins.binNft chain (Nft.RawRule ["ct", "state", "established,related", "accept"]) + `inject` Nft.rule nft_r bins.binNft chain (Nft.RawRule ["iifname", ifaceQuoted, "accept"]) + where + chain = Nft.baseChain "forward" filterTable (Nft.BaseChainSpec Nft.FilterChain Nft.Forward 0 Nft.Drop) + + natTable :: Nft.Table + natTable = Nft.Table "nat" Nft.Inet + + -- masquerade VPN-subnet traffic as it leaves any interface other than the VPN one + nat :: Op + nat = + Nft.rule + nft_r + bins.binNft + (Nft.baseChain "postrouting" natTable (Nft.BaseChainSpec Nft.NatChain Nft.PostRouting 100 Nft.Accept)) + (Nft.RawRule ["ip", "saddr", WG.nettxt spec.server_vpn_net, "oifname", "!=", ifaceQuoted, "masquerade"]) + + ifaceQuoted :: Text + ifaceQuoted = "\"" <> spec.server_wg_iface <> "\"" + +------------------------------------------------------------------------------- + +data ClientVpnSpec + = ClientVpnSpec + { client_wg_iface :: WG.WgName + , client_wg_privkey_path :: FilePath + , client_vpn_addr :: WG.IpNet + -- ^ the client's own address inside the VPN subnet, e.g. 10.0.3.2/24 + , client_server_endpoint :: WG.Endpoint + -- ^ "host:port" of the server (its static IP) + , client_server_ip :: Text + -- ^ bare IP of the server (used to pin a host route via the original gateway) + , client_server_pubkey_path :: FilePath + -- ^ path (on the client) to the server's already-provisioned public key + , client_keepalive_seconds :: Int + -- ^ persistent-keepalive so the NAT/dynamic-IP side stays punched through; 25s is the usual default + } + +{- | Sets up the client side: WireGuard interface + a single peer (the +server) routing all traffic (@0.0.0.0\/0@ split in two \/1s, the classic +wg-quick trick) over the VPN, plus a pinned host route to the server's own +IP so the tunnel doesn't try to route over itself. Existing LAN/default +routes are left untouched, since more specific routes always take priority +over what we add here. +-} +clientVpn :: Reporter Report -> Binaries -> ClientVpnSpec -> Op +clientVpn r bins spec = + op "wireguard-vpn-client" (deps [routeAllTraffic]) id + where + wg_r = contramap RunWireGuard r + ip_r = contramap RunIpRoute r + + ifaceTrack :: Track' WG.WgName + ifaceTrack = Track $ \name -> WG.iface wg_r bins.binIp name spec.client_vpn_addr + + privkeyTrack :: Track' FilePath + privkeyTrack = Track $ WG.privateKey bins.binWg + + clientIface :: Op + clientIface = + WG.client wg_r bins.binWg privkeyTrack ifaceTrack spec.client_wg_iface spec.client_wg_privkey_path + + serverPeer :: Op + serverPeer = + WG.peerKeepalive + wg_r + bins.binWg + ignoreTrack -- the server's public key is provisioned out of band + ifaceTrack + ignoreTrack -- the endpoint is just a "host:port" string, nothing to provision + spec.client_wg_iface + spec.client_server_pubkey_path + (Just spec.client_server_endpoint) + "0.0.0.0/0" + (Just spec.client_keepalive_seconds) + `inject` clientIface + + -- pin a host route to the server's own IP via whatever the kernel currently + -- uses (the physical uplink), so the tunnel's own traffic doesn't loop over itself + pinServerRoute :: Op + pinServerRoute = + ( op "wireguard-vpn-client-pin-server-route" (deps [justInstall bins.binIp]) $ \actions -> + actions + { help = "keeps the route to the VPN server itself off the tunnel" + , ref = mkRef "wg-vpn-pin-server-route" spec.client_server_ip + , up = do + (via, dev) <- IpRoute.discoverGatewayFor spec.client_server_ip + let cmd = IpRoute.ReplaceRoute (IpRoute.Route (IpRoute.RawNetwork (spec.client_server_ip <> "/32")) dev via) + Binary.untrackedExec IpRoute.ipcommand cmd "" (contramap (IpRoute.RunIp cmd) ip_r) + } + ) + `inject` serverPeer + + -- classic wg-quick "route all traffic" trick: two more-specific-than-default + -- routes over the VPN interface, leaving the real default route (and every + -- other more-specific route, e.g. the LAN) untouched + routeAllTraffic :: Op + routeAllTraffic = + IpRoute.route ip_r bins.binIp (IpRoute.Route (IpRoute.RawNetwork "128.0.0.0/1") spec.client_wg_iface Nothing) + `inject` IpRoute.route ip_r bins.binIp (IpRoute.Route (IpRoute.RawNetwork "0.0.0.0/1") spec.client_wg_iface Nothing) + `inject` pinServerRoute diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,150 @@ +module Main (main) where + +import qualified Test.AptRepositorySpec as AptRepositorySpec +import qualified Test.CheckSpec as CheckSpec +import qualified Test.ClientModelSpec as ClientModelSpec +import qualified Test.ConcurrentSpec as ConcurrentSpec +import qualified Test.DaemonSpec as DaemonSpec +import qualified Test.DagSpec as DagSpec +import qualified Test.DebianPackageSpec as DebianPackageSpec +import qualified Test.LlamaServerSpec as LlamaServerSpec +import qualified Test.ServeApiSpec as ServeApiSpec +import qualified Test.PgVectorSpec as PgVectorSpec +import qualified Test.PlakarSpec as PlakarSpec +import qualified Test.WireGuardSpec as WireGuardSpec +import qualified Test.DebootstrapSpec as DebootstrapSpec +import qualified Test.DownTreeSpec as DownTreeSpec +import qualified Test.FilesystemSpec as FilesystemSpec +import qualified Test.FollowCacheSpec as FollowCacheSpec +import qualified Test.FollowRegistrySpec as FollowRegistrySpec +import qualified Test.FollowSchedulerSpec as FollowSchedulerSpec +import qualified Test.FollowSignatureSpec as FollowSignatureSpec +import qualified Test.FollowSpec as FollowSpec +import qualified Test.GcpSpec as GcpSpec +import qualified Test.JWTSigningSpec as JWTSigningSpec +import qualified Test.LedgerSpec as LedgerSpec +import qualified Test.PodmanCommandSpec as PodmanCommandSpec +import qualified Test.MigratorTemplateSpec as MigratorTemplateSpec +import qualified Test.PgBackupSpec as PgBackupSpec +import qualified Test.PodmanSpec as PodmanSpec +import qualified Test.PostgresBackupSpec as PostgresBackupSpec +import qualified Test.PostgresInitSpec as PostgresInitSpec +import qualified Test.PostgresReplicationSpec as PostgresReplicationSpec +import qualified Test.PostgresClusterSpec as PostgresClusterSpec +import qualified Test.PgBouncerSpec as PgBouncerSpec +import qualified Test.EtcdSpec as EtcdSpec +import qualified Test.PatroniHarnessSpec as PatroniHarnessSpec +import qualified Test.PgPairDemoSpec as PgPairDemoSpec +import qualified Test.PostgresPairSpec as PostgresPairSpec +import qualified Test.PostgresSwitchoverSpec as PostgresSwitchoverSpec +import qualified Test.PostgresTemplateSpec as PostgresTemplateSpec +import qualified Test.PostgresTlsSpec as PostgresTlsSpec +import qualified Test.PostgrestCloudRunSpec as PostgrestCloudRunSpec +import qualified Test.QemuResolveKernelSpec as QemuResolveKernelSpec +import qualified Test.QemuShutdownSpec as QemuShutdownSpec +import qualified Test.QemuSmokeSpec as QemuSmokeSpec +import qualified Test.QuerySpec as QuerySpec +import qualified Test.ReportJsonSpec as ReportJsonSpec +import qualified Test.RewriteSpec as RewriteSpec +import qualified Test.ServeEventsSpec as ServeEventsSpec +import qualified Test.ServeHttpSpec as ServeHttpSpec +import qualified Test.ServeModelSpec as ServeModelSpec +import qualified Test.ServeSocketSpec as ServeSocketSpec +import qualified Test.ServeSpec as ServeSpec +import qualified Test.ServeTlsSpec as ServeTlsSpec +import qualified Test.StatusSinkSpec as StatusSinkSpec +import qualified Test.SystemdSpec as SystemdSpec +import qualified Test.UpTreeSpec as UpTreeSpec +import qualified Test.UpkeepSpec as UpkeepSpec +import qualified Test.WindowSpec as WindowSpec + +import Test.Tasty (DependencyType (..), TestTree, defaultMain, sequentialTestGroup, testGroup) + +{- | The cheap tiers run concurrently, as tasty does by default; the tiers +that reach for a machine-wide resource do not. + +Layer 2 and Layer 3 contend in ways that have nothing to do with what they +assert. Every VM-based spec asks the harness for the same bridge address, so +two of them at once fight over one tap and one IP; the podman specs mutate +@PATH@ process-globally to shim binaries, which is not a thing two threads +can do at once. Before this, three qemu specs in one suite failed together +and individually passed — which reads exactly like a real bug and is not +one. + +'sequentialTestGroup' rather than @localOption (NumThreads 1)@: tasty reads +'NumThreads' once, for the whole run, so setting it on a subtree left these +running alongside one another all the same. +-} +heavy :: [TestTree] -> TestTree +heavy = sequentialTestGroup "containers and VMs (serialized)" AllFinish + +main :: IO () +main = + defaultMain $ + testGroup + "salmon-ops-recipes" + [ heavy + [ DebootstrapSpec.tests + , -- these two shim PATH, which is process-global + PostgresInitSpec.tests + , PostgresTemplateSpec.sandboxTests + , MigratorTemplateSpec.tests + , -- the rest of the VM specs: they share one bridge and a + -- handful of fixed addresses, so two at once is two guests + -- claiming one address. + QemuSmokeSpec.tests + , PostgresReplicationSpec.tests + , PostgresSwitchoverSpec.tests + , PgBackupSpec.tests + , PgPairDemoSpec.tests + , PatroniHarnessSpec.tests + ] + , CheckSpec.tests + , ClientModelSpec.tests + , ConcurrentSpec.tests + , DaemonSpec.tests + , DagSpec.tests + , AptRepositorySpec.tests + , DebianPackageSpec.tests + , LlamaServerSpec.tests + , ServeApiSpec.tests + , PgVectorSpec.tests + , PlakarSpec.tests + , WireGuardSpec.tests + , DownTreeSpec.tests + , FilesystemSpec.tests + , FollowCacheSpec.tests + , FollowRegistrySpec.tests + , FollowSchedulerSpec.tests + , FollowSignatureSpec.tests + , FollowSpec.tests + , GcpSpec.tests + , JWTSigningSpec.tests + , LedgerSpec.tests + , PodmanCommandSpec.tests + , PodmanSpec.tests + , PostgresBackupSpec.tests + , PostgresClusterSpec.tests + , PgBouncerSpec.tests + , EtcdSpec.tests + , PostgresPairSpec.tests + , PostgresTemplateSpec.tests + , PostgresTlsSpec.tests + , PostgrestCloudRunSpec.tests + , QemuResolveKernelSpec.tests + , QemuShutdownSpec.tests + , QuerySpec.tests + , ReportJsonSpec.tests + , RewriteSpec.tests + , ServeEventsSpec.tests + , ServeHttpSpec.tests + , ServeModelSpec.tests + , ServeSocketSpec.tests + , ServeSpec.tests + , ServeTlsSpec.tests + , StatusSinkSpec.tests + , SystemdSpec.tests + , UpTreeSpec.tests + , UpkeepSpec.tests + , WindowSpec.tests + ] diff --git a/test/Test/AptRepositorySpec.hs b/test/Test/AptRepositorySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/AptRepositorySpec.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Layer 0 coverage for "Salmon.Builtin.Nodes.Debian.AptRepository": the +rendering of the sources and preference files, the codename-to-suite +mapping, and the fingerprint pin. Sample @gpg --with-colons@ lines have the +shape real output has (a primary key, a user id, a signing subkey). +-} +module Test.AptRepositorySpec (tests) where + +import qualified Data.List.NonEmpty as NEList +import qualified Data.Text as Text +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) + +import Salmon.Builtin.Nodes.Debian.AptRepository + +repo :: AptRepository +repo = pgdg "/secrets/pgdg.asc" "B97B 0AFC AA1A 47F0 44F2 44A0 7FCC 7D46 ACCC 4CF8" + +tests :: TestTree +tests = + testGroup + "Salmon.Builtin.Nodes.Debian.AptRepository" + [ testCase "the sources file is a deb822 stanza naming the installed key" $ + assertEqual + "" + ( Text.unlines + [ "Types: deb" + , "URIs: https://apt.postgresql.org/pub/repos/apt" + , "Suites: bookworm-pgdg" + , "Components: main" + , "Signed-By: /etc/apt/keyrings/pgdg.asc" + ] + ) + (renderSources repo (resolveSuite repo.repoSuite "bookworm")) + , testCase "a fixed suite ignores the codename" $ + assertEqual "" "stable" (resolveSuite (FixedSuite "stable") "bookworm") + , testCase "the key keeps the extension it was provisioned with" $ do + assertEqual "" "/etc/apt/keyrings/pgdg.asc" (keyDestination repo) + assertEqual "" "/etc/apt/keyrings/pgdg.gpg" (keyDestination repo{repoKeyFile = "/k/pgdg.gpg"}) + assertEqual "" "/etc/apt/keyrings/pgdg.gpg" (keyDestination repo{repoKeyFile = "/k/pgdg"}) + , testCase "an aimed apt directory moves every path" $ + assertEqual "" "/t/sources.list.d/pgdg.sources" (sourcesPath repo{repoAptDir = "/t"}) + , testCase "codename comes from os-release, quoted or not" $ do + assertEqual "" (Just "bookworm") (parseOsReleaseCodename "PRETTY_NAME=\"Debian\"\nVERSION_CODENAME=bookworm\nID=debian\n") + assertEqual "" (Just "jammy") (parseOsReleaseCodename "VERSION_CODENAME=\"jammy\"\n") + assertEqual "" Nothing (parseOsReleaseCodename "ID=debian\n") + assertEqual "" Nothing (parseOsReleaseCodename "VERSION_CODENAME=\n") + , testCase "the preference file pins the origin low, then the named packages up" $ + assertEqual + "" + ( Text.unlines + [ "Package: *" + , "Pin: origin apt.postgresql.org" + , "Pin-Priority: 1" + , "" + , "Package: postgresql-*-pgvector" + , "Pin: origin apt.postgresql.org" + , "Pin-Priority: 500" + , "" + , "Package: postgresql-*-textsearch" + , "Pin: origin apt.postgresql.org" + , "Pin-Priority: 500" + ] + ) + (renderPreferences repo ("postgresql-*-pgvector" NEList.:| ["postgresql-*-textsearch"])) + , testCase "the host of a URI, with and without a port or scheme" $ do + assertEqual "" "apt.postgresql.org" (repositoryHost "https://apt.postgresql.org/pub/repos/apt") + assertEqual "" "mirror.local:8080" (repositoryHost "http://mirror.local:8080/debian") + , testCase "index files are named after the URI" $ + assertEqual "" "apt.postgresql.org_pub_repos_apt" (listsPrefix "https://apt.postgresql.org/pub/repos/apt/") + , testCase "fingerprints compare without spaces or case" $ + assertEqual "" "B97B0AFCAA1A47F044F244A07FCC7D46ACCC4CF8" (normalizeFingerprint "b97b 0afc aa1a 47f0 44f2 44a0 7fcc 7d46 accc 4cf8") + , testCase "only a primary key's fingerprint counts, not a subkey's" $ + assertEqual "" ["AAAA"] (primaryFingerprints colons) + , testCase "two primary keys in one file are both accepted" $ + assertEqual "" ["AAAA", "CCCC"] (primaryFingerprints (colons <> colonsSecond)) + , testCase "no key, no fingerprint" $ + assertEqual "" [] (primaryFingerprints "") + ] + where + colons = + "tru::1:1700000000:0:3:1:5\n\ + \pub:-:4096:1:1111111111111111:1400000000:::-:::scESC:::::::\n\ + \fpr:::::::::AAAA:\n\ + \uid:-::::1400000000::HASH::PostgreSQL Debian Repository:::::::::\n\ + \sub:-:4096:1:2222222222222222:1400000000::::::e::::::\n\ + \fpr:::::::::BBBB:\n" + colonsSecond = + "pub:-:4096:1:3333333333333333:1500000000:::-:::scESC:::::::\n\ + \fpr:::::::::CCCC:\n" diff --git a/test/Test/CheckSpec.hs b/test/Test/CheckSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/CheckSpec.hs @@ -0,0 +1,132 @@ +{- | Layer 0 coverage for @check :: IO CheckResult@, the field that replaced +@prelim :: IO Requirement@ and the never-implemented @check :: IO ()@ +(milestone 1 of @specs/per-node-state-machines.md@). + +Two things are worth pinning here. First, that every 'CheckResult' +constructor lands on the right side of the "do I run 'up'" question, since +that mapping is what preserves the behaviour of 22 ported nodes. Second, the +one deliberate behaviour change of the merge: @prelim@ used to be evaluated +outside the @try@ that wraps 'up', so a @prelim@ that threw took the whole +traversal down with it. A 'check' that throws must now fail only its own +node, and that node must still be evaluated. +-} +module Test.CheckSpec (tests) where + +import Control.Exception (ErrorCall (..), throwIO) +import Data.IORef (modifyIORef', newIORef, readIORef) +import Data.List (sort) +import Data.Text (Text) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) + +import Salmon.Actions.UpDown (CheckResult (..), Report (..), Requirement (..), requirement) +import Salmon.Builtin.Extension (Extension (..), Op, deps, nodeps, op, ref, up) +import Salmon.Op.Actions (shorthand) +import Salmon.Op.Ref (mkRef) + +import Test.Harness (runUp, runUpCapturing) + +tests :: TestTree +tests = + testGroup + "Salmon.Builtin.Extension.check" + [ testCase "Success/Skipped/Completed are Skippable, Failure/Unknown/Immaterial are Required" requirementMapping + , testCase "a satisfied check skips the node, an unsatisfied one evaluates it" checkDecidesEval + , testCase "a node that implements no check is still evaluated" noCheckMeansEval + , testCase "a check that throws fails only its own node, not the traversal" throwingCheckIsContained + ] + +requirementMapping :: IO () +requirementMapping = do + assertEqual "Success" Skippable (requirement Success) + assertEqual "Skipped" Skippable (requirement Skipped) + assertEqual "Completed" Skippable (requirement Completed) + assertEqual "Failure" Required (requirement (Failure "not there")) + assertEqual "Unknown" Required (requirement Unknown) + assertEqual "Immaterial" Required (requirement Immaterial) + +{- | One leaf per 'CheckResult', all under a common root, run in a single +traversal: the three satisfied answers must report 'Skip' and leave 'up' +alone, the three unsatisfied ones must report 'Eval' and run it. +-} +checkDecidesEval :: IO () +checkDecidesEval = do + ranRef <- newIORef [] + let rec name = modifyIORef' ranRef (name :) + leaf name result = + op name nodeps $ \x -> + x + { ref = mkRef "check-leaf" (name :: Text) + , check = pure result + , up = rec name + } + leaves = + [ leaf "ok" Success + , leaf "forced" Skipped + , leaf "done" Completed + , leaf "absent" (Failure "not there") + , leaf "dunno" Unknown + , leaf "cheap" Immaterial + ] + root = op "root" (deps leaves) $ \x -> x{ref = mkRef "check-root" ()} + reports <- runUpCapturing root + ran <- readIORef ranRef + assertEqual + "only the unsatisfied checks ran their up" + ["absent", "cheap", "dunno"] + (sortNames ran) + assertEqual + "the satisfied checks were reported Skip" + ["done", "forced", "ok"] + (sortNames [shorthand act | Skip act <- reports]) + assertEqual + "the unsatisfied checks were reported Eval" + ["absent", "cheap", "dunno", "root"] + (sortNames [shorthand act | Eval act <- reports]) + +-- | The default 'check' is 'Immaterial' ("asking would cost what applying +-- costs"), which has to keep the pre-merge default's behaviour: run 'up'. +-- The one-shot drivers must not be able to tell it from 'Unknown'. +noCheckMeansEval :: IO () +noCheckMeansEval = do + ranRef <- newIORef [] + let lone = op "lone" nodeps $ \x -> x{ref = mkRef "check-leaf" ("lone" :: Text), up = modifyIORef' ranRef ("lone" :)} + reports <- runUpCapturing lone + ran <- readIORef ranRef + assertEqual "up ran" ["lone"] ran + assertEqual "reported Eval, not Skip" 1 (length [() | Eval _ <- reports]) + assertEqual "never reported Skip" 0 (length [() | Skip _ <- reports]) + +{- | @boom@'s check throws. Under the old @prelim@ this escaped 'upTree' +entirely and the sibling never ran. Now the throw is read as "could not +confirm the effect", so @boom@ is evaluated like any other unconfirmed node +and @quiet@ is untouched. +-} +throwingCheckIsContained :: IO () +throwingCheckIsContained = do + ranRef <- newIORef [] + let rec name = modifyIORef' ranRef (name :) + boom = + op "boom" nodeps $ \x -> + x + { ref = mkRef "check-leaf" ("boom" :: Text) + , check = throwIO (ErrorCall "check blew up") + , up = rec "boom" + } + quiet = + op "quiet" nodeps $ \x -> + x + { ref = mkRef "check-leaf" ("quiet" :: Text) + , check = pure Success + , up = rec "quiet" + } + root = op "root" (deps [boom, quiet]) $ \x -> x{ref = mkRef "check-root" ()} + ok <- runUp root + ran <- readIORef ranRef + assertBool "the traversal reported success: a thrown check is not a failed node" ok + assertEqual "boom's up ran, quiet's was skipped by its own check" ["boom"] (sortNames ran) + +------------------------------------------------------------------------------- + +sortNames :: [Text] -> [Text] +sortNames = sort diff --git a/test/Test/ClientModelSpec.hs b/test/Test/ClientModelSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/ClientModelSpec.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE DeriveGeneric #-} + +{- | Coverage for "Salmon.Client.Model" and "Salmon.Client.Http" (milestone +6 of @specs\/generic-server.md@, the client's half). + +Layer 0 on the model: a @\/dag@ answer folded over a recorded event +sequence — @declared@, @converge-start@, @eval@, @done@, @failed@, +@blocked@, @converge-stop@, @parked@, @next-look@, @hung-up@, @gap@ — +gives the per-node view a terminal would show; folding an event twice is +folding it once; an @acted@ is unwrapped to the pass's vocabulary; a node +wanted down is dropped by its @done@; the SSE block parser reads what +"Salmon.Actions.Serve.Events" renders, comments included; and the rendered +rows and header are the text expected. + +Layer 1 over a real @withHttpServer@ on a temp socket, driven through the +client itself: @dag@, then @commandAsync "up ..."@, then @events@ from the +number it answered, re-reading @\/dag@ when the model asks (the @declared@ +event), sees the pass and the model converges. +-} +module Test.ClientModelSpec (tests) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) +import Control.Exception (try) +import Control.Monad (forM_, when) +import Data.Aeson (FromJSON, ToJSON, Value (..), object, (.=)) +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LByteString +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.List (foldl') +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (isNothing) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import System.FilePath (()) +import System.IO (Handle, hClose) +import System.Posix.IO (FdOption (CloseOnExec), createPipe, fdToHandle, setFdOption) +import System.Timeout (timeout) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) + +import qualified Salmon.Actions.Serve as Serve +import Salmon.Actions.Serve (Attributed (..), World) +import qualified Salmon.Actions.Serve.Events as Events +import qualified Salmon.Actions.Serve.Http as Http +import Salmon.Builtin.Extension (Track', deps, down, help, nodeps, op, ref, up) +import qualified Salmon.Client.Http as Client +import qualified Salmon.Client.Model as Model +import Salmon.Client.Model (Check (..), Model (..), Node (..), Pass (..), RefId (..)) +import Salmon.Op.Configure (Configure (..)) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track (Track (..)) +import Salmon.Reporter (contramap) +import qualified Salmon.Reporter.Tagged as Tagged + +import Test.Harness (capture, withTempDir) + +tests :: TestTree +tests = + testGroup + "Salmon.Client" + [ testGroup + "the model" + [ testCase "a /dag snapshot folded over a recorded pass gives the per-node view" recordedPass + , testCase "folding an event twice is folding it once" replayIsIdempotent + , testCase "an upkeep acted is unwrapped to the pass's vocabulary" actedUnwraps + , testCase "a node wanted down is dropped by its done" downNodeDropped + , testCase "the SSE parser reads what the server renders" sseParser + , testCase "the rendered rows and header" rendering + ] + , testGroup + "the client against a real server" + [ testCase "dag, then commandAsync, then events from that seq: the model converges" clientConverges + ] + ] + +------------------------------------------------------------------------------- +-- Layer 0: a recorded sequence + +refOf :: Text -> RefId +refOf short = RefId short ("full-" <> short) + +refValue :: Text -> Value +refValue short = object ["short" .= short, "full" .= ("full-" <> short)] + +nodeValue :: Text -> Text -> [Text] -> Value +nodeValue short shorthand dependencies = + object + [ "ref" .= refValue short + , "shorthand" .= shorthand + , "help" .= ("help for " <> short) + , "notes" .= (["a note"] :: [Text]) + , "direction" .= ("up" :: Text) + , "convergence" .= ("pending" :: Text) + , "status" .= Null + , "paths" .= (["/" <> short] :: [Text]) + , "dynamics" .= ([] :: [Text]) + , "dependencies" .= fmap refValue dependencies + , "dependants" .= ([] :: [Value]) + ] + +-- | Three nodes in dependency order: the two leaves, then the root over them. +snapshot :: Value +snapshot = snapshotAt 5 + +snapshotAt :: Int -> Value +snapshotAt seqNo = + object + [ "mode" .= ("interactive" :: Text) + , "seq" .= seqNo + , "nodes" .= [nodeValue "n1" "node-one" [], nodeValue "n2" "node-two" [], nodeValue "root" "the-root" ["n1", "n2"]] + ] + +about :: Text -> Text -> Text -> Int -> [(Key.Key, Value)] -> Value +about stream kind short seqNo rest = + object $ + [ "stream" .= stream + , "kind" .= kind + , "seq" .= seqNo + , "ref" .= refValue short + , "node" .= object ["shorthand" .= short, "help" .= ("" :: Text), "notes" .= ([] :: [Text])] + ] + ++ rest + +loop :: Text -> Int -> [(Key.Key, Value)] -> Value +loop kind seqNo rest = object (["stream" .= ("serve" :: Text), "kind" .= kind, "seq" .= seqNo] ++ rest) + +-- | The events the stream carries for one @up@ whose second node fails. +recorded :: [Value] +recorded = + [ loop "declared" 6 ["epoch" .= (0 :: Int), "direction" .= ("up" :: Text), "nodes" .= (3 :: Int), "active_seeds" .= (1 :: Int)] + , loop "converge-start" 7 ["down" .= (0 :: Int), "up" .= (3 :: Int)] + , about "updown" "eval" "n1" 8 [] + , about "updown" "done" "n1" 9 [] + , about "updown" "eval" "n2" 10 [] + , about "updown" "failed" "n2" 11 ["error" .= ("boom" :: Text)] + , about "updown" "blocked" "root" 12 [] + , loop "converge-stop" 13 ["ok" .= False, "remaining" .= (2 :: Int)] + , about "upkeep" "parked" "n1" 14 [] + , about "upkeep" "next-look" "n1" 15 ["check" .= object ["verdict" .= ("success" :: Text)], "delay_us" .= (500000 :: Int)] + , loop "hung-up" 16 ["from" .= ("x#0" :: Text)] + , object ["stream" .= ("server" :: Text), "kind" .= ("gap" :: Text), "from" .= (40 :: Int)] + ] + +fold :: Model -> [Value] -> Model +fold = foldl' (\m v -> Model.step m (Model.eventOf v)) + +start :: IO Model +start = either (assertFailure . ("snapshot: " <>)) pure (Model.fromDag snapshot) + +recordedPass :: IO () +recordedPass = do + m0 <- start + assertEqual "the snapshot's seq" 5 m0.modelSeq + assertEqual "the snapshot's order" [refOf "n1", refOf "n2", refOf "root"] m0.modelOrder + assertEqual "mode" "interactive" m0.modelMode + -- the declaration asks for a re-read, and the fold goes on past it + let afterDeclared = fold m0 (take 1 recorded) + assertBool "declared asks for a resync" (Model.modelResync afterDeclared /= Nothing) + let m = fold (Model.resolve afterDeclared) (drop 1 recorded) + assertEqual "seq is the highest seen (the gap has none)" 16 m.modelSeq + assertEqual "the gap asks for a resync" (Just "events 40 fell off the ring") (Model.modelResync m) + assertEqual "the pass stopped with a failure and two left" (Just (Stopped False 2)) m.modelPass + let view r = maybe (assertFailure ("no node " <> show r)) pure (Model.lookupNode (refOf r) m) + n1 <- view "n1" + assertEqual "n1 converged" "converged" n1.nodeConvergence + assertEqual "n1's last check is what next-look said" (Just (Check "success" Nothing)) n1.nodeCheck + assertEqual "n1's last event" (Just "next-look", Just 15) (n1.nodeLastKind, n1.nodeLastSeq) + assertEqual "n1 keeps no error" Nothing n1.nodeError + n2 <- view "n2" + assertEqual "n2 errored" "errored" n2.nodeConvergence + assertEqual "n2's error" (Just "boom") n2.nodeError + assertEqual "n2's last event" (Just "failed", Just 11) (n2.nodeLastKind, n2.nodeLastSeq) + root <- view "root" + assertEqual "root blocked" "blocked" root.nodeConvergence + assertEqual "root's last event" (Just "blocked", Just 12) (root.nodeLastKind, root.nodeLastSeq) + assertEqual "counts" (Model.Counts 1 1 3) (Model.counts m) + assertEqual "order kept" [refOf "n1", refOf "n2", refOf "root"] (fmap nodeRef (Model.nodesInOrder m)) + assertEqual "the last event folded" (Just "gap") (Model.eventKind <$> m.modelLast) + +replayIsIdempotent :: IO () +replayIsIdempotent = do + m0 <- start + let once = fold m0 recorded + twice = fold once recorded + -- and every numbered prefix replayed onto the whole leaves it + -- where it was: those events are at or below its seq, so they + -- are dropped rather than regressing the pass to `converging` + numbered = filter ((/= Nothing) . Model.eventSeq . Model.eventOf) recorded + prefixes = [fold once (take k numbered) | k <- [0 .. length numbered]] + assertEqual "the whole sequence twice" once twice + forM_ (zip [0 :: Int ..] prefixes) $ \(k, m) -> assertEqual ("prefix " <> show k <> " replayed") once m + -- a snapshot taken after a racing event drops that event's replay too + m9 <- either (assertFailure . ("snapshot: " <>)) pure (Model.fromDag (snapshotAt 9)) + let later = fold m9 recorded + assertEqual "events above the snapshot's seq land" (Just (Just "failed", Just 11)) ((\n -> (n.nodeLastKind, n.nodeLastSeq)) <$> Model.lookupNode (refOf "n2") later) + assertEqual "n1's done (9) was not re-applied: the snapshot already had its say, and next-look (15) does not converge" (Just ("pending", Just "next-look")) ((\n -> (n.nodeConvergence, n.nodeLastKind)) <$> Model.lookupNode (refOf "n1") later) + -- but the loop's part has its own stamp: a fresh snapshot read after + -- the pass, rebased onto a model that saw it start, still takes the stop + let started = fold m0 (take 2 recorded) + assertEqual "converging" (Just (Converging 0 3)) started.modelPass + m20 <- either (assertFailure . ("snapshot: " <>)) pure (Model.fromDag (snapshotAt 20)) + let rebased = Model.rebase started m20 + assertEqual "the pass carried over" (Just (Converging 0 3)) rebased.modelPass + assertEqual "the cursor is the snapshot's" 20 rebased.modelSeq + assertEqual "the resync is answered" Nothing (Model.modelResync rebased) + let ended = fold rebased (drop 2 recorded) + assertEqual "the stop (13 < 20) still lands on the loop's part" (Just (Stopped False 2)) ended.modelPass + assertEqual "while the nodes are the snapshot's (n2's failed (11) is below its stamp)" (Just "pending") (nodeConvergence <$> Model.lookupNode (refOf "n2") ended) + +actedUnwraps :: IO () +actedUnwraps = do + m0 <- start + let inner = about "updown" "done" "n2" 0 [] + acted = object ["stream" .= ("upkeep" :: Text), "kind" .= ("acted" :: Text), "seq" .= (20 :: Int), "report" .= inner] + m = fold m0 [acted] + n2 <- maybe (assertFailure "no n2") pure (Model.lookupNode (refOf "n2") m) + assertEqual "converged through the tending machine" "converged" n2.nodeConvergence + assertEqual "recorded as an acted done, at the outer seq" (Just "acted done", Just 20) (n2.nodeLastKind, n2.nodeLastSeq) + +downNodeDropped :: IO () +downNodeDropped = do + let retiring = + object + [ "mode" .= ("interactive" :: Text) + , "seq" .= (1 :: Int) + , "nodes" .= [withDirection "down" (nodeValue "n1" "node-one" []), nodeValue "n2" "node-two" []] + ] + m0 <- either (assertFailure . ("snapshot: " <>)) pure (Model.fromDag retiring) + assertEqual "two nodes" 2 (Model.countTotal (Model.counts m0)) + let m = fold m0 [about "updown" "eval" "n1" 2 [], about "updown" "done" "n1" 3 []] + assertEqual "n1 is gone once down" Nothing (Model.lookupNode (refOf "n1") m) + assertEqual "the order follows" [refOf "n2"] m.modelOrder + -- while a node wanted up that is done stays + let m' = fold m0 [about "updown" "done" "n2" 4 []] + assertEqual "n2 stays, converged" (Just "converged") (nodeConvergence <$> Model.lookupNode (refOf "n2") m') + where + withDirection d (Object o) = Object (KeyMap.insert "direction" (String d) o) + withDirection _ v = v + +sseParser :: IO () +sseParser = do + let e1 = Events.Event 7 Nothing (Events.Enqueued "up n1") + e2 = Events.Event 8 (Just (Serve.Origin "x#0")) (Events.Reported (Tagged.FromServe Serve.Started)) + wire = LByteString.toStrict (Builder.toLazyByteString (Events.renderGap 3 <> Events.renderEvent e1 <> Events.keepAlive <> Events.renderEvent e2)) + (blocks, rest) = Client.splitBlocks (wire <> "id: 9\ndata: {\"partial") + assertEqual "the partial block is left over" "id: 9\ndata: {\"partial" rest + assertEqual + "gap without id, two events with theirs, and the comment" + [ Client.SseEvent Nothing (Events.gapValue 3) + , Client.SseEvent (Just 7) (Events.eventValue e1) + , Client.SseComment + , Client.SseEvent (Just 8) (Events.eventValue e2) + ] + (concatMap Client.parseBlock blocks) + -- and what the model makes of them + let gap = Model.eventOf (Events.gapValue 3) + queued = Model.eventOf (Events.eventValue e1) + started = Model.eventOf (Events.eventValue e2) + assertEqual "gap" (Nothing, "server", "gap", Nothing) (gap.eventSeq, gap.eventStream, gap.eventKind, gap.eventOrigin) + assertEqual "enqueued" (Just 7, "server", "enqueued", Nothing) (queued.eventSeq, queued.eventStream, queued.eventKind, queued.eventOrigin) + assertEqual "started, for a command" (Just 8, "serve", "started", Just "x#0") (started.eventSeq, started.eventStream, started.eventKind, started.eventOrigin) + +rendering :: IO () +rendering = do + m0 <- start + let m = fold m0 recorded + assertEqual + "one row per node, in order" + [ "n1 node-one up converged success next-look #15" + , "n2 node-two up errored - failed #11: boom" + , "root the-root up blocked - blocked #12" + ] + (fmap Model.renderNodeRow (Model.nodesInOrder m)) + assertEqual + "the header" + "/tmp/x.http mode=interactive seq=16 converged=1 errored=1 total=3 incomplete(2 left)+failure " + (Model.renderHeader "/tmp/x.http" m) + assertEqual "an event line about a node" "#11 updown failed n2 n2" (Model.renderEventLine (Model.eventOf (recorded !! 5))) + assertEqual "an event line about the loop" "#13 serve converge-stop ok=false remaining=2" (Model.renderEventLine (Model.eventOf (recorded !! 7))) + +------------------------------------------------------------------------------- +-- Layer 1: the client against a real server + +newtype Spec = Spec {specNames :: [String]} + deriving (Eq, Show, Generic) + +instance ToJSON Spec +instance FromJSON Spec + +parseSpec :: [String] -> Either Text Spec +parseSpec [] = Left "expected at least one node name" +parseSpec args = Right (Spec args) + +spyProgram :: IORef (Map String Int) -> Track' Spec +spyProgram upsRef = Track $ \spec -> + op "client-root" (deps (fmap nodeOp spec.specNames)) $ \actions -> + actions{ref = mkRef "client-root" spec.specNames, help = "the root of " <> Text.pack (unwords spec.specNames)} + where + nodeOp name = + op "client-node" nodeps $ \actions -> + actions + { ref = mkRef "client-node" name + , help = "node " <> Text.pack name + , up = atomicModifyIORef' upsRef (\m -> (Map.insertWith (+) name 1 m, ())) + , down = pure () + } + +data Running = Running + { runningStdin :: Handle + , runningWorld :: MVar (World Spec Spec) + , runningClient :: Client.Client + , runningUps :: IORef (Map String Int) + } + +-- | The loop with an HTTP server on a temp socket, as 'Test.ServeEventsSpec' +-- starts it (close-on-exec on every descriptor, for the reason given there). +withRunning :: (Running -> IO a) -> IO a +withRunning act = + withTempDir $ \dir -> do + let path = dir "client.http" + (stdinR, stdinW) <- privatePipe + worldVar <- newEmptyMVar + (own, _) <- capture + upsRef <- newIORef Map.empty + Http.withHttpServer path "usage: config NAME...\n" (pure Serve.Interactive) $ \server -> do + let base = (contramap attributed (Tagged.serveStream own), contramap attributed (Tagged.updownStream own)) + (serveR, updownR) = Http.serverReporters server base + _ <- forkIO $ do + w <- + Serve.serveObserved + (Http.serverObserver server) + [] + Nothing + True + serveR + updownR + parseSpec + (Configure pure) + (spyProgram upsRef) + Nothing + [Serve.stdinProducer stdinR, Http.serverProducer server] + putMVar worldVar w + client <- Client.newUnixClient path + r <- act (Running stdinW worldVar client upsRef) + _ <- try (hClose stdinW) :: IO (Either IOError ()) + ended <- timeout (10 * 1000000) (takeMVar worldVar) + when (isNothing ended) (assertFailure "the loop did not end") + pure r + +privatePipe :: IO (Handle, Handle) +privatePipe = do + (r, w) <- createPipe + forM_ [r, w] $ \fd -> setFdOption fd CloseOnExec True + (,) <$> fdToHandle r <*> fdToHandle w + +clientConverges :: IO () +clientConverges = + withRunning $ \running -> do + let client = runningClient running + -- the sync command answers with the line's reports + quiet <- Client.command client "supervise off" + assertEqual "one report for supervise off" ["supervised"] (fmap (Model.eventKind . Model.eventOf) quiet) + -- an empty world first + m0 <- either (assertFailure . ("dag: " <>)) pure . Model.fromDag =<< Client.dag client + assertEqual "nothing declared yet" 0 (Model.countTotal (Model.counts m0)) + -- queue the declaration, and read the stream from its number + queued <- Client.commandAsync client "up n1 n2" + assertBool "queued above the snapshot" (queued.enqueuedSeq > m0.modelSeq) + modelRef <- newIORef m0 + seen <- newIORef [] + let converged m = Model.countTotal (Model.counts m) == 3 && Model.countConverged (Model.counts m) == 3 + onEvent e = do + atomicModifyIORef' seen (\es -> (e : es, ())) + m <- readIORef modelRef + let m' = Model.step m e + m'' <- case Model.modelResync m' of + -- what a terminal client does on `declared`: re-read + -- the snapshot, rebase, and go on folding from it + Just _ -> either (assertFailure . ("dag: " <>)) (pure . Model.rebase m') . Model.fromDag =<< Client.dag client + Nothing -> pure m' + writeIORef modelRef m'' + -- stop once the pass has stopped and every node is converged + pure (not (converged m'' && isStopped m''.modelPass)) + r <- timeout (20 * 1000000) (Client.events client (Just queued.enqueuedSeq) Client.noFilter onEvent) + assertEqual "the stream was read to the pass's end" (Just ()) r + m <- readIORef modelRef + events <- reverse <$> readIORef seen + let kinds = fmap Model.eventKind events + assertBool ("the pass was seen: " <> show kinds) (all (`elem` kinds) ["declared", "converge-start", "done", "converge-stop"]) + assertBool "every event is above the enqueue number" (all (maybe False (> queued.enqueuedSeq) . Model.eventSeq) events) + assertBool "every event carries the command's origin" (all ((== Just queued.enqueuedOrigin) . Model.eventOrigin) events) + assertEqual "three nodes, all converged" (Model.Counts 3 0 3) (Model.counts m) + assertBool "the model's seq moved past the enqueue" (m.modelSeq > queued.enqueuedSeq) + assertEqual "the pass stopped clean" (Just (Stopped True 0)) m.modelPass + -- the re-read snapshot was taken while (or after) the pass ran, so + -- a node's view is the snapshot's or the stream's, whichever is + -- numbered later; either way it is converged and wanted up + forM_ (Model.nodesInOrder m) $ \n -> do + assertEqual ("direction of " <> show n.nodeRef) "up" n.nodeDirection + assertEqual ("convergence of " <> show n.nodeRef) "converged" n.nodeConvergence + -- /dag's order is the Dag's first-seen order, the one `run tree` prints: the root, then what it stands on + assertEqual "the root comes first, as printDagTree prints it" (Just "client-root") (nodeShorthand <$> headMay (Model.nodesInOrder m)) + ups <- readIORef (runningUps running) + assertEqual "each node went up once" (Map.fromList [("n1", 1), ("n2", 1)]) ups + -- and the reads beside it + st <- Client.status client + assertBool "status answers with nodes" (has "nodes" st) + hist <- Client.history client + assertBool "history answers with seeds" (has "seeds" hist) + hlp <- Client.seedHelp client + assertBool "help answers with the seed text" (has "seed" hlp) + -- a refused request is a typed error + bad <- try (Client.command client "status\nhistory") + case bad of + Left (Client.Refused 400 _) -> pure () + other -> assertFailure ("two lines in one body: " <> show (either show (const "answered") other)) + where + isStopped (Just (Stopped _ _)) = True + isStopped _ = False + has k (Object o) = KeyMap.member k o + has _ _ = False + headMay [] = Nothing + headMay (x : _) = Just x diff --git a/test/Test/ConcurrentSpec.hs b/test/Test/ConcurrentSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/ConcurrentSpec.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Layer 0/1 coverage for "Salmon.Actions.Concurrent": the same contract as +the sequential drivers, plus the things only a concurrent one has to get +right. + +Three groups of case here. The first are the sequential drivers' own +guarantees restated — ordering, one application per 'Ref', failure +containment — because "same contract" is the whole claim being made. The +second is that independent nodes really do overlap, asserted by having them +block on each other rather than by timing. The third is what only appears +once nodes run at once: a cycle that no thread can ever get past, and a +mailbox delivering an operator's instruction into a running pass. +-} +module Test.ConcurrentSpec (tests) where + +import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar) +import Control.Concurrent.STM (atomically) +import Data.IORef (atomicModifyIORef', newIORef, readIORef) +import Data.List (elemIndex, sort) +import Data.Maybe (isNothing) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Text (Text) +import System.Timeout (timeout) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) + +import qualified Salmon.Actions.Concurrent as Concurrent +import Salmon.Actions.UpDown (CheckResult (..), Report (..), Requirement (..), alwaysRequired) +import Salmon.Builtin.Extension (Extension, Op, check, deps, down, dynamics, evalDeps, help, nodeps, notes, op, opAct, ref, up) +import Salmon.Op.Actions (Act (..)) +import qualified Salmon.Op.Concurrency as Concurrency +import qualified Salmon.Op.Dag as Dag +import Salmon.Op.Mailbox (Instruction (..)) +import qualified Salmon.Op.Mailbox as Mailbox +import Salmon.Op.Ref (Ref, mkRef) + +import Test.Harness (capture) + +tests :: TestTree +tests = + testGroup + "Salmon.Actions.Concurrent" + [ testCase "a predecessor is applied before its dependants" predecessorFirst + , testCase "a shared node is applied exactly once" sharedNodeOnce + , testCase "a failed node blocks its dependants, not its siblings" failureBlocksDependants + , testCase "independent nodes really do run at the same time" trulyConcurrent + , testCase "teardown waits for every dependant, concurrently" teardownWaitsForDependants + , testCase "a cycle is reported rather than hanging" cycleDoesNotHang + , testCase "a mailbox Force overrides a satisfied check" mailboxForces + , testCase "a mailbox Satisfy stops a node acting" mailboxSatisfies + , testCase "an overflowing mailbox drops the oldest and says so" mailboxOverflows + , testCase "a ConcurrencyLimit of 1 serialises otherwise-concurrent nodes" limitSerialisesNodes + , testCase "a ConcurrencyLimit does not deadlock an ordinary graph" limitDoesNotDeadlockOrdinaryGraph + ] + +------------------------------------------------------------------------------- + +dagOf :: Op -> Dag.Dag Extension +dagOf = Dag.foldDag Dag.sameRepresentative . evalDeps + +runUp :: Op -> IO ([Report Extension], Bool) +runUp = runUpLimited Nothing + +runUpLimited :: Maybe Concurrency.ConcurrencyLimit -> Op -> IO ([Report Extension], Bool) +runUpLimited limit o = do + (r, readBack) <- capture + ok <- Concurrent.upDagConcurrent alwaysRequired r Concurrent.noMailboxes limit (dagOf o) + (,) <$> readBack <*> pure ok + +runDown :: Op -> IO ([Report Extension], Bool) +runDown o = do + (r, readBack) <- capture + ok <- Concurrent.downDagConcurrent alwaysRequired r Concurrent.noMailboxes Nothing (dagOf o) + (,) <$> readBack <*> pure ok + +-- | Fail the test rather than hanging forever if ordering deadlocks. +within :: Int -> IO a -> IO a +within seconds act = do + result <- timeout (seconds * 1000000) act + case result of + Just a -> pure a + Nothing -> fail ("timed out after " <> show seconds <> "s") + +------------------------------------------------------------------------------- + +predecessorFirst :: IO () +predecessorFirst = within 10 $ do + logRef <- newIORef [] + let rec name = atomicModifyIORef' logRef (\xs -> (name : xs, ())) + shared = op "shared" nodeps $ \x -> x{ref = mkRef "leaf" ("shared" :: Text), up = rec "shared"} + a = op "a" (deps [shared]) $ \x -> x{ref = mkRef "mid" ("a" :: Text), up = rec "a"} + b = op "b" (deps [shared]) $ \x -> x{ref = mkRef "mid" ("b" :: Text), up = rec "b"} + root = op "root" (deps [a, b]) $ \x -> x{ref = mkRef "root" (), up = rec "root"} + (_, ok) <- runUp root + order <- reverse <$> readIORef logRef + assertBool "clean" ok + assertEqual "each node applied exactly once" (sort ["root", "a", "b", "shared"]) (sort order) + assertEqual "the shared predecessor went first" (Just 0) (elemIndex "shared" order) + assertEqual "and the root last" (Just 3) (elemIndex "root" order) + +sharedNodeOnce :: IO () +sharedNodeOnce = within 10 $ do + logRef <- newIORef [] + let rec name = atomicModifyIORef' logRef (\xs -> (name : xs, ())) + apex = op "apex" nodeps $ \x -> x{ref = mkRef "leaf" ("apex" :: Text), up = rec "apex"} + left = op "left" (deps [apex]) $ \x -> x{ref = mkRef "mid" ("left" :: Text), up = rec "left"} + right = op "right" (deps [apex]) $ \x -> x{ref = mkRef "mid" ("right" :: Text), up = rec "right"} + root = op "root" (deps [left, right]) $ \x -> x{ref = mkRef "root" (), up = rec "root"} + (reports, _) <- runUp root + order <- readIORef logRef + assertEqual "apex applied once" 1 (length (filter (== "apex") order)) + assertEqual "four nodes, four Evals" 4 (length [() | Eval _ <- reports]) + +failureBlocksDependants :: IO () +failureBlocksDependants = within 10 $ do + logRef <- newIORef [] + let rec name = atomicModifyIORef' logRef (\xs -> (name : xs, ())) + a = op "a" nodeps $ \x -> x{ref = mkRef "mid" ("a" :: Text), up = rec "a" >> ioError (userError "boom")} + b = op "b" nodeps $ \x -> x{ref = mkRef "mid" ("b" :: Text), up = rec "b"} + root = op "root" (deps [a, b]) $ \x -> x{ref = mkRef "root" (), up = rec "root"} + (reports, ok) <- runUp root + order <- readIORef logRef + assertBool "the run reports failure" (not ok) + assertBool "an unrelated sibling still ran" ("b" `elem` order) + assertBool "the blocked dependant did not" ("root" `notElem` order) + assertEqual "and is reported Blocked" ["root"] [act.shorthand | Blocked act <- reports] + +{- | Two independent nodes, each of which will not finish until the /other/ +has started. Under a sequential driver this deadlocks; under a concurrent one +it completes, which is the assertion. No sleeps and no timing: the overlap is +what makes it terminate at all. +-} +trulyConcurrent :: IO () +trulyConcurrent = within 10 $ do + aStarted <- newEmptyMVar + bStarted <- newEmptyMVar + let a = op "a" nodeps $ \x -> x{ref = mkRef "mid" ("a" :: Text), up = putMVar aStarted () >> readMVar bStarted} + b = op "b" nodeps $ \x -> x{ref = mkRef "mid" ("b" :: Text), up = putMVar bStarted () >> readMVar aStarted} + root = op "root" (deps [a, b]) $ \x -> x{ref = mkRef "root" ()} + (_, ok) <- runUp root + assertBool "both nodes were in flight at once" ok + +{- | The mirror of 'trulyConcurrent': the same two nodes, each unable to +finish until the /other/ has started, but under a 'Concurrency.ConcurrencyLimit' +of 1. With no limit this graph completes ('trulyConcurrent' above); with the +limit it provably cannot, since whichever node acquires the sole slot then +blocks forever waiting on the other, which can never acquire a slot to run +and signal back. A short 'timeout' standing in for "never" is the only way to +observe a real deadlock rather than a slow success, and is deterministic +here: the run either completes almost immediately (the limit did nothing) or +hangs until the deadline (it serialised the two nodes), never something in +between. +-} +limitSerialisesNodes :: IO () +limitSerialisesNodes = do + limit <- Concurrency.newConcurrencyLimit 1 + aStarted <- newEmptyMVar + bStarted <- newEmptyMVar + let a = op "a" nodeps $ \x -> x{ref = mkRef "mid" ("a" :: Text), up = putMVar aStarted () >> readMVar bStarted} + b = op "b" nodeps $ \x -> x{ref = mkRef "mid" ("b" :: Text), up = putMVar bStarted () >> readMVar aStarted} + root = op "root" (deps [a, b]) $ \x -> x{ref = mkRef "root" ()} + result <- timeout 500000 (runUpLimited (Just limit) root) + assertBool "each node needs the other to finish, but only one may ever hold the slot" (isNothing result) + +{- | The limit must not introduce a deadlock of its own on a graph with real +dependency edges: a node's slot is released before its dependants even +attempt to acquire one (see "Salmon.Actions.Concurrent"'s module header), so +a limit of 1 should still let a whole DAG converge, one node at a time. +-} +limitDoesNotDeadlockOrdinaryGraph :: IO () +limitDoesNotDeadlockOrdinaryGraph = within 10 $ do + limit <- Concurrency.newConcurrencyLimit 1 + logRef <- newIORef [] + let rec name = atomicModifyIORef' logRef (\xs -> (name : xs, ())) + shared = op "shared" nodeps $ \x -> x{ref = mkRef "leaf" ("shared" :: Text), up = rec "shared"} + a = op "a" (deps [shared]) $ \x -> x{ref = mkRef "mid" ("a" :: Text), up = rec "a"} + b = op "b" (deps [shared]) $ \x -> x{ref = mkRef "mid" ("b" :: Text), up = rec "b"} + root = op "root" (deps [a, b]) $ \x -> x{ref = mkRef "root" (), up = rec "root"} + (_, ok) <- runUpLimited (Just limit) root + order <- reverse <$> readIORef logRef + assertBool "clean, despite the limit" ok + assertEqual "each node still applied exactly once" (sort ["root", "a", "b", "shared"]) (sort order) + +{- | The teardown ordering guarantee, under concurrency: the directory two +files live in must not be removed until both files are, and the two files may +go at the same time. +-} +teardownWaitsForDependants :: IO () +teardownWaitsForDependants = within 10 $ do + logRef <- newIORef [] + aStarted <- newEmptyMVar + bStarted <- newEmptyMVar + let rec name = atomicModifyIORef' logRef (\xs -> (name : xs, ())) + shared = op "shared" nodeps $ \x -> x{ref = mkRef "leaf" ("shared" :: Text), down = rec "shared"} + -- as above: neither finishes until both have started, so this only + -- terminates if they overlap. + a = op "a" (deps [shared]) $ \x -> x{ref = mkRef "mid" ("a" :: Text), down = putMVar aStarted () >> readMVar bStarted >> rec "a"} + b = op "b" (deps [shared]) $ \x -> x{ref = mkRef "mid" ("b" :: Text), down = putMVar bStarted () >> readMVar aStarted >> rec "b"} + root = op "root" (deps [a, b]) $ \x -> x{ref = mkRef "root" (), down = rec "root"} + (_, ok) <- runDown root + order <- reverse <$> readIORef logRef + assertBool "clean" ok + assertEqual "the shared node came down last" (Just 3) (elemIndex "shared" order) + assertEqual "and the root first" (Just 0) (elemIndex "root" order) + +{- | A node on a cycle never becomes ready, so a driver that waits for +neighbours would wait forever rather than finishing and noticing. The cycle +has to be found before the walk. +-} +cycleDoesNotHang :: IO () +cycleDoesNotHang = within 10 $ do + let leaf name = op name nodeps $ \x -> x{ref = mkRef "cyc" (name :: Text)} + magma = + Map.fromList + [ (act.extension.ref, act) + | o <- [leaf "a", leaf "b"] + , Just act <- [opAct o] + ] + looped = Set.fromList [(mkRef "cyc" ("a" :: Text), mkRef "cyc" ("b" :: Text)), (mkRef "cyc" ("b" :: Text), mkRef "cyc" ("a" :: Text))] + (r, readBack) <- capture + ok <- Concurrent.upDagConcurrent alwaysRequired r Concurrent.noMailboxes Nothing (Dag.fromMagma magma looped) + reports <- readBack + assertBool "reported as a failure rather than hanging" (not ok) + assertEqual "both nodes named" 2 (length [() | Blocked _ <- reports]) + assertEqual "and neither evaluated" 0 (length [() | Eval _ <- reports]) + +------------------------------------------------------------------------------- + +-- | A node whose check says it is already satisfied, so nothing runs unless +-- an operator says otherwise. +satisfied :: Text -> IO () -> Op +satisfied name action = + op "target" nodeps $ \x -> + x{ref = mkRef "target" name, check = pure Success, up = action, down = action} + +withMailbox :: Op -> [Instruction] -> IO ([Report Extension], Bool) +withMailbox o instructions = do + box <- Mailbox.newMailbox Mailbox.defaultCapacity + mapM_ (Mailbox.post box) instructions + (r, readBack) <- capture + let dag = dagOf o + ok <- Concurrent.upDagConcurrent alwaysRequired r (Map.fromList [(rf, box) | rf <- Dag.dagOrder dag]) Nothing dag + (,) <$> readBack <*> pure ok + +mailboxForces :: IO () +mailboxForces = within 10 $ do + ran <- newIORef (0 :: Int) + let o = satisfied "forced" (atomicModifyIORef' ran (\n -> (n + 1, ()))) + (quiet, _) <- withMailbox o [] + assertEqual "with no instruction the satisfied check wins" 1 (length [() | Skip _ <- quiet]) + assertEqual "so nothing ran" 0 =<< readIORef ran + + (forced, _) <- withMailbox o [Force] + assertEqual "Force overrides it" 1 (length [() | Eval _ <- forced]) + assertEqual "and the instruction is reported" [Force] [i | Instructed _ i <- forced] + assertEqual "so it ran" 1 =<< readIORef ran + +mailboxSatisfies :: IO () +mailboxSatisfies = within 10 $ do + ran <- newIORef (0 :: Int) + let o = + op "target" nodeps $ \x -> + x{ref = mkRef "target" ("s" :: Text), up = atomicModifyIORef' ran (\n -> (n + 1, ()))} + (plain, _) <- withMailbox o [] + assertEqual "a node with no check runs by default" 1 (length [() | Eval _ <- plain]) + (told, _) <- withMailbox o [Satisfy] + assertEqual "Satisfy stops it" 1 (length [() | Skip _ <- told]) + assertEqual "so it ran only the first time" 1 =<< readIORef ran + +{- | An instruction lost silently would make forcing a node unreliable in a +way nobody could see, so the eviction is reported. +-} +mailboxOverflows :: IO () +mailboxOverflows = within 10 $ do + box <- Mailbox.newMailbox 2 + results <- mapM (Mailbox.post box) [Recheck, Recheck, Recheck, Force] + assertEqual "the first two fit, the next two evicted one each" [True, True, False, False] results + assertEqual "two evictions recorded" 2 =<< Mailbox.dropped box + held <- atomically (Mailbox.takeAll box) + assertEqual "the newest survive, oldest first" [Recheck, Force] held diff --git a/test/Test/DaemonSpec.hs b/test/Test/DaemonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/DaemonSpec.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Layer 1 coverage for "Salmon.Builtin.Nodes.Daemon": real subprocesses. + +@Test.UpkeepSpec@ covers the state machine with a plain @IO ExitCode@ standing +in for a process, because the racing, the policy and the failure accounting +are not clearer through a real one. What is only visible through a real one is +everything this module is about: that cancelling the machine actually kills +the process, that a process ignoring @SIGTERM@ is escalated to @SIGKILL@ +rather than wedging the teardown behind it, that the whole process /group/ +goes rather than just the leader, and that output reaches the node's ring +while the process is still running. + +Every case here spawns @\/bin\/sh@ and takes under a second. Nothing needs +root, a container, or anything on the machine but a shell. +-} +module Test.DaemonSpec (tests) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVar, retry, writeTVar) +import Control.Exception (try) +import Control.Monad (unless) +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as Text +import System.Exit (ExitCode (..)) +import System.Posix.Signals (nullSignal, signalProcess) +import System.Posix.Types (ProcessID) +import System.Process (proc) +import System.Timeout (timeout) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) + +import qualified Salmon.Actions.Upkeep as Upkeep +-- imported with their field selectors: OverloadedRecordDot only solves +-- HasField for fields whose selector is in scope. +import Salmon.Builtin.Extension (Extension, Op, check, down, dynamics, evalDeps, help, managed, nodeps, notes, op, ref, up) +import qualified Salmon.Builtin.Nodes.Daemon as Daemon +import Salmon.Op.Actions (Act (..)) +import qualified Salmon.Op.Dag as Dag +import Salmon.Op.Ref (Ref, mkRef) +import Salmon.Op.Status (Direction (..)) +import Salmon.Op.Supervision (millis) +import Salmon.Reporter (ReporterM (..), silent) + +tests :: TestTree +tests = + testGroup + "Salmon.Builtin.Nodes.Daemon" + [ testCase "the process runs, and stops when the machine is cancelled" runsAndStops + , testCase "a process ignoring SIGTERM is escalated to SIGKILL" escalatesToKill + , testCase "the whole process group goes, not just the leader" killsTheGroup + , testCase "output reaches the node while the process is still running" capturesOutput + , testCase "a one-shot driver is told it cannot run this" upRefuses + ] + +------------------------------------------------------------------------------- + +within :: Int -> IO a -> IO a +within secs act = do + result <- timeout (secs * 1000000) act + maybe (fail ("timed out after " <> show secs <> "s")) pure result + +sh :: Text -> Daemon.Daemon +sh script = Daemon.defaultDaemon "test-daemon" (proc "/bin/sh" ["-c", Text.unpack script]) + +daemonOp :: Daemon.Daemon -> Op +daemonOp = Daemon.daemon silent + +daemonRef :: Ref +daemonRef = mkRef "daemon" ("test-daemon" :: Text) + +dagOf :: Op -> Dag.Dag Extension +dagOf = Dag.foldDag Dag.sameRepresentative . evalDeps + +{- | Supervise this daemon, run the body, then stop — which cancels the +machine and so tears the process down through 'Daemon.runDaemon'\'s bracket. + +The node is built here rather than taken from 'Daemon.daemon' for one reason: +the node's own output ring is not readable from a test, so this tees what +would go into it somewhere a case can block on. Everything else about the +node is what 'Daemon.daemon' would have produced, and 'upRefuses' covers that +function itself. +-} +supervising :: Daemon.Daemon -> (TVar [Text] -> IO a) -> IO a +supervising d body = do + captured <- newTVarIO [] + let o = + op "test-daemon" nodeps $ \x -> + x + { ref = daemonRef + , managed = Just $ \sink -> + Daemon.runDaemon silent d $ \l -> do + sink l + atomically (modifyTVar' captured (l :)) + } + Upkeep.withUpkeep + silent + (const (Just (Upkeep.Tend TurnUp Upkeep.Unsettled))) + (dagOf o) + (const (body captured)) + +-- | Block until the captured output satisfies the predicate. +awaitLines :: TVar [Text] -> ([Text] -> Bool) -> IO () +awaitLines v p = atomically (readTVar v >>= \ls -> unless (p (reverse ls)) retry) + +-- | Signal 0: asks the kernel whether a pid exists, without sending anything. +alive :: ProcessID -> IO Bool +alive pid = do + result <- try @IOError (signalProcess nullSignal pid) + pure (either (const False) (const True) result) + +------------------------------------------------------------------------------- + +{- | The baseline: it really runs, and cancelling the machine really stops it. + +Asserted through the process's own output rather than a pid, so it holds +without this test knowing anything about how the teardown works. +-} +runsAndStops :: IO () +runsAndStops = within 20 $ do + ls <- supervising (sh "while true; do echo tick; sleep 0.05; done") $ \ls -> do + awaitLines ls (\xs -> length xs >= 2) + pure ls + -- the supervisor has stopped by here, so the loop is gone; if it were + -- not, this file descriptor would still be being written to. + before <- length <$> atomically (readTVar ls) + -- it was writing a line every 50ms, so 400ms of silence is the process + -- being gone rather than merely slow. + _ <- timeout 400000 (awaitLines ls (\xs -> length xs > before)) + after <- length <$> atomically (readTVar ls) + assertEqual "it stopped talking once the machine was cancelled" before after + +{- | The case @cancel@ alone cannot handle, and the reason the escalation is +recovered from @f9d7116@ rather than left to 'System.Process.withCreateProcess': +a process that traps @SIGTERM@ and keeps going. Without the @SIGKILL@ this +teardown never returns. +-} +escalatesToKill :: IO () +escalatesToKill = within 20 $ do + let d = (sh "trap '' TERM; echo ignoring; while true; do sleep 0.05; done"){Daemon.daemon_stop = Daemon.Stop (Daemon.stop_signal Daemon.defaultStop) (millis 300)} + -- the assertion is that this returns at all: `withUpkeep`'s release + -- cancels the machine and waits for the teardown. + ok <- timeout 10000000 $ supervising d $ \ls -> awaitLines ls (elem "ignoring") + assertBool "the teardown escalated rather than waiting forever" (ok == Just ()) + +{- | A service that forks workers has to take them with it, which is why +@create_group@ is forced on and the signal goes to the group rather than to +'System.Process.terminateProcess'\'s single pid. + +The shell prints its child's pid and then waits on it, so a teardown that +signalled only the leader would leave that child running. +-} +killsTheGroup :: IO () +killsTheGroup = within 20 $ do + pidVar <- newTVarIO Nothing + _ <- + supervising (sh "sleep 60 & echo child $!; wait") $ \ls -> do + awaitLines ls (any ("child " `Text.isPrefixOf`)) + xs <- reverse <$> atomically (readTVar ls) + atomically (writeTVar pidVar (childPid xs)) + child <- atomically (readTVar pidVar) + case child of + Nothing -> fail "the shell did not report its child's pid" + Just pid -> do + -- the group signal has been sent and waited for by the time + -- `supervising` returned; the child's reparenting and reaping is + -- the kernel's business and takes a moment. + gone <- untilGone 40 pid + assertBool "the forked child went with its parent" gone + where + childPid :: [Text] -> Maybe ProcessID + childPid xs = + case [w | l <- xs, ["child", w] <- [Text.words l]] of + (w : _) -> case reads (Text.unpack w) :: [(Integer, String)] of + [(n, "")] -> Just (fromInteger n) + _ -> Nothing + [] -> Nothing + + untilGone :: Int -> ProcessID -> IO Bool + untilGone 0 _ = pure False + untilGone n pid = do + still <- alive pid + if not still then pure True else threadDelay 25000 >> untilGone (n - 1) pid + +{- | Reading the pipes has to happen /while/ the process runs, not after it +exits: a process that fills a pipe buffer otherwise blocks forever and the +node looks wedged for a reason nobody could see. This process never exits, so +nothing but concurrent draining could produce a line at all. +-} +capturesOutput :: IO () +capturesOutput = within 20 $ do + _ <- supervising (sh "echo one; echo two >&2; while true; do sleep 0.05; done") $ \ls -> + awaitLines ls (\xs -> "one" `elem` xs && "two" `elem` xs) + pure () + +{- | @run up@ has nowhere to put an action that never returns, so the node +says so rather than no-oping into a world that then believes it is up. +-} +upRefuses :: IO () +upRefuses = within 10 $ do + let dag = dagOf (daemonOp (sh "true")) + case Dag.representativeOf dag daemonRef of + Nothing -> fail "the daemon node is not in its own dag" + Just act -> do + assertBool "the node does declare a managed action" (isJust act.extension.managed) + outcome <- try @Daemon.NeedsSupervisor act.extension.up + case outcome of + Left _ -> pure () + Right () -> fail "up should refuse rather than silently succeed" diff --git a/test/Test/DagSpec.hs b/test/Test/DagSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/DagSpec.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Layer 0 coverage for 'Salmon.Op.Dag' — the collapse of an expanded graph +to a flat, 'Ref'-keyed DAG that used to be buried inside +'Salmon.Actions.UpDown.downTreeWith'. + +Everything here is pure: no node's @up@\/@down@ is ever run, which is the +point of having lifted the fold out in the first place. The one exception is +the last test, which checks the conflict actually reaches a caller's +'Salmon.Reporter.Reporter' through a real teardown. +-} +module Test.DagSpec (tests) where + +import qualified Data.List +import Data.Text (Text) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) + +-- GHC only solves a `HasField` constraint when the field selector is in +-- scope, and `Dag.sameRepresentative` needs three of them: a selective import +-- here has to name `notes` and `dynamics` even though this module never +-- mentions either. +import Salmon.Builtin.Extension (Extension, Op, check, deps, down, dynamics, evalDeps, help, nodeps, notes, op, opAct, ref, up) +import qualified Salmon.Op.Dag as Dag +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref (Ref, mkRef) +import Salmon.Op.Supervision (Strategy (..), Supervision (..), defaultSupervision, supervised) +import qualified Salmon.Actions.UpDown as UpDown +import Salmon.Op.Actions (Act (..)) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +import Test.Harness (capture) + +import Test.Harness (runDownCapturing) + +tests :: TestTree +tests = + testGroup + "Salmon.Op.Dag" + [ testCase "a shared node is one magma entry with both its dependants" sharedNodeOneEntry + , testCase "dependants is the exact transpose of dependencies" transpose + , testCase "edges from every occurrence accumulate" edgesAccumulate + , testCase "a re-declared node is replaced, last writer wins" lastWriterWins + , testCase "a differing representative is reported as a conflict" conflictReported + , testCase "the same node reached twice is not a conflict" noSelfConflict + , testCase "roots are the nodes nothing depends on" rootsAreUndepended + , testCase "downTree reports a conflict to its caller" downTreeReportsConflict + , testCase "fromMagma rebuilds what dagEdges flattened" fromMagmaRoundTrips + , testCase "a cycle is reported Blocked, not silently skipped" cycleIsBlocked + , testCase "a changed Supervision policy is a differing representative" changedSupervisionIsAConflict + , testCase "an identical Supervision policy is not a differing representative" sameSupervisionIsNotAConflict + ] + +------------------------------------------------------------------------------- + +refOf :: Text -> Ref +refOf = mkRef "dagspec" + +leaf :: Text -> Op +leaf name = op name nodeps $ \x -> x{ref = refOf name} + +-- | A diamond: @root@ over @left@ and @right@, both over one @apex@. +diamond :: (Op, Op, Op, Op) +diamond = (root, left, right, apex) + where + apex = leaf "apex" + left = op "left" (deps [apex]) $ \x -> x{ref = refOf "left"} + right = op "right" (deps [apex]) $ \x -> x{ref = refOf "right"} + root = op "root" (deps [left, right]) $ \x -> x{ref = refOf "root"} + +foldOf :: Op -> Dag.Dag Extension +foldOf = Dag.foldDag Dag.sameRepresentative . evalDeps + +------------------------------------------------------------------------------- + +{- | The 'Cofree' holds @apex@ twice (once under each of @left@ and @right@); +the 'Dag' holds it once, and — unlike the 'Cofree' — knows that /two/ things +stand on it, which is the fact a teardown needs and cannot get by walking +predecessors. +-} +sharedNodeOneEntry :: IO () +sharedNodeOneEntry = do + let (root, _, _, _) = diamond + let dag = foldOf root + assertEqual "one entry per ref" 4 (length (Dag.dagOrder dag)) + -- first-seen, i.e. depth-first from the root: apex is reached under + -- @left@ before @right@ is. + assertEqual "first-seen order" (map refOf ["root", "left", "apex", "right"]) (Dag.dagOrder dag) + assertEqual + "apex has both dependants" + (map refOf ["left", "right"]) + (Dag.dependantsOf dag (refOf "apex")) + assertEqual "apex depends on nothing" [] (Dag.dependenciesOf dag (refOf "apex")) + assertEqual "no conflicts in a plain diamond" 0 (length (Dag.dagConflicts dag)) + +transpose :: IO () +transpose = do + let (root, _, _, _) = diamond + let dag = foldOf root + let forward = [(a, b) | a <- Dag.dagOrder dag, b <- Dag.dependenciesOf dag a] + backward = [(a, b) | b <- Dag.dagOrder dag, a <- Dag.dependantsOf dag b] + assertEqual "every dependency edge has its dependant edge" (sortP forward) (sortP backward) + assertBool "and there are some" (not (null forward)) + where + sortP = Data.List.sort + +{- | Two nodes sharing a 'Ref' but declaring different predecessors: the +collapse @downTreeWith@ used to do internally kept only the first +occurrence's edges, so the second declaration's dependency was invisible and +could be torn down while the shared node still stood on it. Both edges are +kept now — which is also what makes folding a second graph in a merge rather +than a replacement. +-} +edgesAccumulate :: IO () +edgesAccumulate = do + let p1 = leaf "p1" + p2 = leaf "p2" + -- same shorthand, same help, same ref: indistinguishable + -- representatives, so this is an edge merge and not a conflict. + x1 = op "x" (deps [p1]) $ \x -> x{ref = refOf "x"} + x2 = op "x" (deps [p2]) $ \x -> x{ref = refOf "x"} + root = op "root" (deps [x1, x2]) $ \x -> x{ref = refOf "root"} + let dag = foldOf root + assertEqual + "x depends on both declarations' predecessors" + (map refOf ["p1", "p2"]) + (Dag.dependenciesOf dag (refOf "x")) + assertEqual "and both know x stands on them" [refOf "x"] (Dag.dependantsOf dag (refOf "p1")) + assertEqual "" [refOf "x"] (Dag.dependantsOf dag (refOf "p2")) + assertEqual "merging identical representatives is not a conflict" 0 (length (Dag.dagConflicts dag)) + +lastWriterWins :: IO () +lastWriterWins = do + let dag = foldOf twoWriters + assertEqual + "the later declaration is the representative" + (Just "second") + (fmap (\act -> act.extension.help) (Dag.representativeOf dag (refOf "contested"))) + +conflictReported :: IO () +conflictReported = do + let dag = foldOf twoWriters + case Dag.dagConflicts dag of + [c] -> do + assertEqual "on the contested ref" (refOf "contested") c.conflictRef + assertEqual "kept the later one" "second" (c.conflictKept.extension.help) + assertEqual "dropped the earlier one" "first" (c.conflictReplaced.extension.help) + other -> assertEqual "exactly one conflict" 1 (length other) + +-- | One effect site, two declarations that describe it differently. +twoWriters :: Op +twoWriters = + op "root" (deps [first, second]) $ \x -> x{ref = refOf "root"} + where + first = op "contested" nodeps $ \x -> x{ref = refOf "contested", help = "first"} + second = op "contested" nodeps $ \x -> x{ref = refOf "contested", help = "second"} + +{- | The overwhelmingly common case — one node reached by several paths — +replaces a representative with an indistinguishable one on every re-encounter. +That must not be reported, or the report would be pure noise. Uses 'inject' as +well as 'deps' so the two occurrences are structurally different ('Connect' +vs 'Vertices') while the node is literally the same value. +-} +noSelfConflict :: IO () +noSelfConflict = do + let apex = leaf "apex" + left = op "left" (deps [apex]) $ \x -> x{ref = refOf "left"} + right = (op "right" nodeps $ \x -> x{ref = refOf "right"}) `inject` apex + root = op "root" (deps [left, right]) $ \x -> x{ref = refOf "root"} + assertEqual "" 0 (length (Dag.dagConflicts (foldOf root))) + +rootsAreUndepended :: IO () +rootsAreUndepended = do + let (root, _, _, _) = diamond + assertEqual "just the root" [refOf "root"] (Dag.roots (foldOf root)) + +-- | The teardown driver is the one caller of the fold today, so it is where +-- an operator actually learns about a contested node. +downTreeReportsConflict :: IO () +downTreeReportsConflict = do + reports <- runDownCapturing twoWriters + assertEqual + "one Conflicting, naming the contested ref" + [refOf "contested"] + [aref | UpDown.Conflicting aref _ _ <- reports] + +{- | 'Dag.fromMagma' is 'Dag.dagEdges'' inverse, and is how a driver that +keeps nodes and precedence separately — "Salmon.Op.Ledger", where edges have +to be retractable — gets back something walkable. +-} +fromMagmaRoundTrips :: IO () +fromMagmaRoundTrips = do + let (root, _, _, _) = diamond + dag = foldOf root + rebuilt = Dag.fromMagma (Dag.dagNodes dag) (Dag.dagEdges dag) + assertEqual "same nodes" (Map.keysSet (Dag.dagNodes dag)) (Map.keysSet (Dag.dagNodes rebuilt)) + assertEqual "same edges" (Dag.dagEdges dag) (Dag.dagEdges rebuilt) + assertEqual + "and the direction a teardown needs survives" + (Set.fromList (Dag.dependantsOf dag (refOf "apex"))) + (Set.fromList (Dag.dependantsOf rebuilt (refOf "apex"))) + +{- | (I5): 'Data.Dynamic.Dynamic' renders as its type alone by default, which +used to make two 'Salmon.Op.Supervision.Supervision' declarations compare +equal here regardless of content — the gap that let +'Salmon.Actions.Upkeep.startUpkeep' adopt a machine whose policy had changed +underneath it. 'Dag.representative' now special-cases 'Supervision' to +compare by value, so a re-declaration that only changes the policy is a +genuine conflict, exactly like 'twoWriters' changing @help@ is. +-} +changedSupervisionIsAConflict :: IO () +changedSupervisionIsAConflict = do + let dag = foldOf (supervisionTwoWriters OneForOne RestForOne) + case Dag.dagConflicts dag of + [c] -> assertEqual "on the contested ref" (refOf "contested") c.conflictRef + other -> assertEqual "exactly one conflict" 1 (length other) + +-- | The overwhelmingly common re-declaration case — same policy, reached +-- again — must not be reported, same reasoning as 'noSelfConflict'. +sameSupervisionIsNotAConflict :: IO () +sameSupervisionIsNotAConflict = do + let dag = foldOf (supervisionTwoWriters OneForOne OneForOne) + assertEqual "no conflict when the policy did not change" 0 (length (Dag.dagConflicts dag)) + +-- | One effect site, two declarations differing only in their +-- 'Salmon.Op.Supervision.Strategy', everything else ('help' included) +-- identical. +supervisionTwoWriters :: Strategy -> Strategy -> Op +supervisionTwoWriters s1 s2 = + op "root" (deps [first, second]) $ \x -> x{ref = refOf "root"} + where + withStrategy s = supervised defaultSupervision{supStrategy = s} + first = op "contested" nodeps $ \x -> x{ref = refOf "contested", dynamics = [withStrategy s1]} + second = op "contested" nodeps $ \x -> x{ref = refOf "contested", dynamics = [withStrategy s2]} + +{- | A 'Dag' built from a flat edge set can describe a cycle, which a 'Dag' +folded from an expanded 'Cofree' cannot — so this is a hazard that only +arrived with the ledger, where two declarations can each contribute one leg +of it. A node on a cycle never becomes ready, and the walk used to leave it +silently unapplied while still reporting success. It is 'Blocked' now. +-} +cycleIsBlocked :: IO () +cycleIsBlocked = do + let a = leaf "a" + b = leaf "b" + magma = + Map.fromList + [ (r, act) + | o <- [a, b] + , Just act <- [opAct o] + , let r = act.extension.ref + ] + -- a depends on b and b depends on a: neither can ever be first. + looped = Set.fromList [(refOf "a", refOf "b"), (refOf "b", refOf "a")] + dag = Dag.fromMagma magma looped + (r, readBack) <- capture + ok <- UpDown.upDag (const (pure UpDown.Required)) r dag + reports <- readBack + assertBool "the walk reports failure rather than vacuous success" (not ok) + assertEqual + "both nodes are named" + 2 + (length [() | UpDown.Blocked _ <- reports]) + assertEqual "and nothing was evaluated" 0 (length [() | UpDown.Eval _ <- reports]) diff --git a/test/Test/DebianPackageSpec.hs b/test/Test/DebianPackageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/DebianPackageSpec.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Layer 0 coverage for "Salmon.Builtin.Nodes.Debian.Package"'s @check@. + +The check exists so that a graph naming packages it already has can run as an +ordinary user (@apt-get install@ wants root even with nothing to do). Its one +subtlety is virtual packages: 'Salmon.Builtin.Nodes.Debian.OS' asks for +@ssh-client@, which @apt-get@ resolves to @openssh-client@ while +@dpkg-query@ answers @not-installed@ for that name forever. Sample lines +below are real @dpkg-query -W@ output. +-} +module Test.DebianPackageSpec (tests) where + +import GHC.IO.Exception (ExitCode (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) + +import Salmon.Actions.UpDown (CheckResult (..)) +import Salmon.Builtin.Nodes.Debian.Package (interpretDpkgCatalog) + +tests :: TestTree +tests = + testGroup + "Salmon.Builtin.Nodes.Debian.Package.interpretDpkgCatalog" + [ testCase "an installed package is satisfied" $ + assertEqual "" Success (interpretDpkgCatalog ["rsync"] ExitSuccess catalogue) + , testCase "a virtual name counts as installed when its provider is" $ + assertEqual + "apt-get install ssh-client resolves to openssh-client" + Success + (interpretDpkgCatalog ["ssh-client"] ExitSuccess catalogue) + , testCase "a provides entry carrying a version still matches" $ + assertEqual "" Success (interpretDpkgCatalog ["awk"] ExitSuccess catalogue) + , testCase "a package present but not installed is not satisfied" $ + assertBool "" (isFailure (interpretDpkgCatalog ["podman"] ExitSuccess catalogue)) + , testCase "a package dpkg has never heard of is not satisfied" $ + assertBool "" (isFailure (interpretDpkgCatalog ["nosuchpkg"] ExitSuccess catalogue)) + , testCase "every wanted package must be installed, not just one" $ + assertBool "" (isFailure (interpretDpkgCatalog ["rsync", "podman"] ExitSuccess catalogue)) + , testCase "the reason names what is missing" $ + case interpretDpkgCatalog ["podman", "rsync"] ExitSuccess catalogue of + Failure msg -> assertEqual "" "not installed: podman" msg + other -> assertBool ("expected Failure, got " <> show other) False + , testCase "dpkg-query failing outright is 'cannot tell', not 'missing'" $ + -- It exits non-zero when something else holds the dpkg lock + -- (unattended-upgrades, typically). Reading that as "missing" + -- makes the node run apt-get, which fails on the same lock -- + -- seen for real in a full test-suite run. + assertEqual "" Unknown (interpretDpkgCatalog ["rsync"] (ExitFailure 2) "") + ] + where + isFailure (Failure _) = True + isFailure _ = False + + -- real `dpkg-query -W -f='${db:Status-Status}|${binary:Package}|${Provides}\n'` lines + catalogue = + "installed|rsync|\n\ + \installed|openssh-client|ssh-client\n\ + \installed|original-awk|awk (= 2020-05-22)\n\ + \not-installed|podman|\n\ + \installed|libc6:i386|libc6-i386\n" diff --git a/test/Test/DebootstrapSpec.hs b/test/Test/DebootstrapSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/DebootstrapSpec.hs @@ -0,0 +1,94 @@ +{- | Layer 3: runs 'Debootstrap.rootTree' and 'Debootstrap.ensureVm9pBoot' as +real salmon 'Op's (not the equivalent hand-run chroot script used to +originally debug this) against a rootfs, and checks the op leaves 9p kernel +modules registered and idempotently skips on a second 'runUp' — closes out +@specs/qemu-test-vms-progress.md@ §3 item 2 ("ensureVm9pBoot itself is +untested as a salmon Op"). + +Needs root (debootstrap + the chroot bind-mount dance) — skipped loudly, +not failed, without it. The *first* run against 'freshRootPath' is a real, +from-scratch debootstrap (fetches ~100+ packages, took ~26 minutes over +this author's connection) and additionally needs the opt-in env var +@SALMON_TEST_RUN_DEBOOTSTRAP=1@ set, precisely so it never fires +unexpectedly on a metered connection just from running the suite under +sudo. Deliberately does *not* wipe 'freshRootPath' between runs (unlike a +from-scratch-every-time design): once debootstrapped, 'Debootstrap.rootTree' +and 'Debootstrap.ensureVm9pBoot''s own 'check's make every subsequent run +report @Success@ and finish in seconds with no network use at all — that +skip path is itself exactly what this test wants to exercise on reruns. +Delete @freshRootPath@ by hand to force a real re-debootstrap. +-} +module Test.DebootstrapSpec (tests) where + +import Control.Monad (unless) +import Data.List (isInfixOf) +import Data.Maybe (isJust) +import Salmon.Builtin.Extension (Track', ignoreTrack) +import qualified Salmon.Builtin.Nodes.Binary as Binary +import qualified Salmon.Builtin.Nodes.Debian.Debootstrap as Debootstrap +import Salmon.Op.OpGraph (inject) +import System.Directory (doesFileExist, findExecutable) +import System.Environment (lookupEnv) +import System.IO (hPutStrLn, stderr) +import System.Posix.User (getEffectiveUserID) +import Test.Harness +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase) + +tests :: TestTree +tests = + testGroup + "Debootstrap (Layer 3, real rootTree + ensureVm9pBoot ops)" + [testCase "debootstraps a fresh root and makes it 9p-bootable" debootstrapsAndFixes9pBoot] + +freshRootPath :: FilePath +freshRootPath = "/var/lib/salmon-test-vms/debootstrap-op-smoke/root" + +debootstrapCmdTrack :: Track' (Binary.Binary "debootstrap") +debootstrapCmdTrack = ignoreTrack + +bashTrack :: Track' (Binary.Binary "bash") +bashTrack = ignoreTrack + +debootstrapsAndFixes9pBoot :: IO () +debootstrapsAndFixes9pBoot = do + isRoot <- (== 0) <$> getEffectiveUserID + hasDebootstrap <- (/= Nothing) <$> findExecutable "debootstrap" + alreadyBootstrapped <- doesFileExist (freshRootPath <> "/etc/issue") + optedIn <- isJust <$> lookupEnv "SALMON_TEST_RUN_DEBOOTSTRAP" + case () of + _ + | not isRoot -> skip "needs root (debootstrap + chroot bind-mounts)" + | not hasDebootstrap -> skip "debootstrap not found on PATH" + | not (alreadyBootstrapped || optedIn) -> + skip + ( "first run needs a real (network-heavy) debootstrap; set " + <> "SALMON_TEST_RUN_DEBOOTSTRAP=1 to allow it (reruns after that are " + <> "free/offline via check skip, see this module's haddock)" + ) + | otherwise -> run + where + skip msg = hPutStrLn stderr ("SKIPPED: " <> msg) + + run :: IO () + run = do + (reporter, _) <- capture + let root = Debootstrap.RootTree Debootstrap.Stable freshRootPath Debootstrap.vmEssentials + vmOp = + Debootstrap.ensureVm9pBoot reporter bashTrack root + `inject` Debootstrap.rootTree reporter debootstrapCmdTrack root + + ok <- runUp vmOp + unless ok (fail "debootstrapsAndFixes9pBoot: rootTree/ensureVm9pBoot op failed") + + let modulesFile = freshRootPath <> "/etc/initramfs-tools/modules" + modulesExist <- doesFileExist modulesFile + assertBool (modulesFile <> " should exist after ensureVm9pBoot") modulesExist + contents <- readFile modulesFile + assertBool + (modulesFile <> " should list the 9p modules") + (all (`isInfixOf` contents) ["9p", "9pnet", "9pnet_virtio", "virtio", "virtio_pci", "virtio_ring"]) + + -- idempotency: rerunning should skip cleanly (both ops' checks report Success) + ok2 <- runUp vmOp + unless ok2 (fail "debootstrapsAndFixes9pBoot: second (idempotent) runUp failed") diff --git a/test/Test/DownTreeSpec.hs b/test/Test/DownTreeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/DownTreeSpec.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Layer 0/1 coverage for 'Salmon.Actions.UpDown.downTree''s teardown +ordering, in particular the shared-predecessor case that a naive top-down, +dedupe-by-'Ref' walk gets wrong: a dependency reached through two dependents +must be torn down only after /both/, not at whichever one happens to be +visited first. + +We assert on order directly by having each node's 'down' append its name to a +shared log, rather than inferring it from a filesystem side effect. +-} +module Test.DownTreeSpec (tests) where + +import Data.IORef (modifyIORef', newIORef, readIORef) +import Data.List (elemIndex, sort) +import Data.Text (Text) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) + +import Salmon.Builtin.Extension (Op, deps, down, nodeps, op, ref) +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref (mkRef) + +import Test.Harness (runDown) + +tests :: TestTree +tests = + testGroup + "Salmon.Actions.UpDown.downTree" + [ testCase "a shared predecessor is torn down after all its dependents" sharedPredecessorLast + , testCase "a diamond tears the apex down exactly once, last" diamondApexOnceLast + , testCase "a failed teardown blocks its predecessors, not its siblings" failureBlocksPredecessors + ] + +{- | @root@ depends on @a@ and @b@, both of which depend on the one @shared@ +node. Teardown must remove @root@, then @a@ and @b@ (in some order), and only +then @shared@ — never @shared@ while @a@ or @b@ still stands on it. +-} +sharedPredecessorLast :: IO () +sharedPredecessorLast = do + logRef <- newIORef [] + let rec name = modifyIORef' logRef (name :) + shared = op "shared" nodeps $ \x -> x{ref = mkRef "leaf" ("shared" :: Text), down = rec "shared"} + a = op "a" (deps [shared]) $ \x -> x{ref = mkRef "mid" ("a" :: Text), down = rec "a"} + b = op "b" (deps [shared]) $ \x -> x{ref = mkRef "mid" ("b" :: Text), down = rec "b"} + root = op "root" (deps [a, b]) $ \x -> x{ref = mkRef "root" (), down = rec "root"} + ok <- runDown root + order <- reverse <$> readIORef logRef + assertBool "everything torn down cleanly" ok + assertEqual "each node torn down exactly once" (sort ["root", "a", "b", "shared"]) (sort order) + before "root" "a" order + before "root" "b" order + before "a" "shared" order + before "b" "shared" order + +-- | Same shape reached two ways at once ('inject' + 'deps'): the apex is +-- still visited a single time and still last. +diamondApexOnceLast :: IO () +diamondApexOnceLast = do + logRef <- newIORef [] + let rec name = modifyIORef' logRef (name :) + apex = op "apex" nodeps $ \x -> x{ref = mkRef "leaf" ("apex" :: Text), down = rec "apex"} + left = op "left" (deps [apex]) $ \x -> x{ref = mkRef "mid" ("left" :: Text), down = rec "left"} + -- reach apex a second, structurally different way (Connect, not Vertices) + right = (op "right" nodeps $ \x -> x{ref = mkRef "mid" ("right" :: Text), down = rec "right"}) `inject` apex + root = op "root" (deps [left, right]) $ \x -> x{ref = mkRef "root" (), down = rec "root"} + ok <- runDown root + order <- reverse <$> readIORef logRef + assertBool "clean" ok + assertEqual "apex torn down exactly once" 1 (length (filter (== "apex") order)) + assertEqual "apex torn down last" (Just (length order - 1)) (elemIndex "apex" order) + +{- | If @a@'s @down@ throws, @a@ is still standing, so its predecessor +@shared@ must be 'Blocked' (not torn down) — but @b@, which does not depend on +@a@, is unaffected and comes down fine. +-} +failureBlocksPredecessors :: IO () +failureBlocksPredecessors = do + logRef <- newIORef [] + let rec name = modifyIORef' logRef (name :) + shared = op "shared" nodeps $ \x -> x{ref = mkRef "leaf" ("shared" :: Text), down = rec "shared"} + a = op "a" (deps [shared]) $ \x -> x{ref = mkRef "mid" ("a" :: Text), down = rec "a" >> ioError (userError "boom")} + b = op "b" nodeps $ \x -> x{ref = mkRef "mid" ("b" :: Text), down = rec "b"} + root = op "root" (deps [a, b]) $ \x -> x{ref = mkRef "root" (), down = rec "root"} + ok <- runDown root + order <- reverse <$> readIORef logRef + assertBool "a failure makes the whole run report unclean" (not ok) + assertBool "the failing node's own down still ran" ("a" `elem` order) + assertBool "an unrelated sibling was still torn down" ("b" `elem` order) + assertBool "the blocked predecessor was NOT torn down" ("shared" `notElem` order) + +------------------------------------------------------------------------------- + +before :: String -> String -> [String] -> IO () +before x y order = + assertBool + (x <> " must come before " <> y <> " in " <> show order) + (elemIndex x order < elemIndex y order) diff --git a/test/Test/EtcdSpec.hs b/test/Test/EtcdSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/EtcdSpec.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Layer 0 coverage for "Salmon.Builtin.Nodes.Etcd": rendering, the +membership verdict and the seed decision. The three-VM Layer 3 case (seed, +then a member restart without re-bootstrapping) needs the Patroni harness and +is not here. +-} +module Test.EtcdSpec (tests) where + +import Data.List (isInfixOf) +import qualified Data.Text as Text +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) + +import Salmon.Actions.UpDown (CheckResult (..)) +import Salmon.Builtin.Nodes.Etcd + +tests :: TestTree +tests = + testGroup + "Salmon.Builtin.Nodes.Etcd" + [ testCase "the config seeds with state new and lists every member" $ do + assertBool cfgText ("initial-cluster-state: new" `isInfixOf` cfgText) + assertBool cfgText ("initial-cluster: a=https://10.0.0.1:2380,b=https://10.0.0.2:2380,c=https://10.0.0.3:2380" `isInfixOf` cfgText) + assertBool cfgText ("name: b" `isInfixOf` cfgText) + , testCase "the initial cluster does not depend on declaration order" $ + assertEqual "" (renderInitialCluster members) (renderInitialCluster (reverse members)) + , testCase "TLS paths are used as given" $ + assertBool cfgText ("cert-file: /pki/peer.crt" `isInfixOf` cfgText) + , testCase "the member list parses, and an unstarted member has no name" $ + assertEqual + "" + (Right [Listed "a" ["https://10.0.0.1:2380"], Listed "" ["https://10.0.0.9:2380"]]) + (parseMemberList "{\"header\":{},\"members\":[{\"ID\":1,\"name\":\"a\",\"peerURLs\":[\"https://10.0.0.1:2380\"]},{\"ID\":2,\"peerURLs\":[\"https://10.0.0.9:2380\"]}]}") + , testCase "garbage is a Left, not an exception" $ + assertBool "" (either (const True) (const False) (parseMemberList "nope")) + , testCase "membership matching the declaration is Success" $ + assertEqual "" Success (interpretMembers members (fmap listedOf members)) + , testCase "a missing member is a Failure naming it" $ + case interpretMembers members (fmap listedOf (take 2 members)) of + Failure why -> assertBool (Text.unpack why) ("10.0.0.3" `isInfixOf` Text.unpack why) + other -> assertFailure (show other) + , testCase "an unexpected member is a Failure too" $ + case interpretMembers (take 2 members) (fmap listedOf members) of + Failure why -> assertBool (Text.unpack why) ("unexpected" `isInfixOf` Text.unpack why) + other -> assertFailure (show other) + , testCase "seed: nobody answering is a seed" $ + assertEqual "" True (ok (seedDecision self [(m, Nothing) | m <- others])) + , testCase "seed: a cluster that lists us is a late bootstrap member, not a refusal" $ + assertEqual "" True (ok (seedDecision self [(head others, Just (fmap listedOf members))])) + , testCase "seed: a cluster that does not list us is refused" $ + assertEqual "" False (ok (seedDecision self [(head others, Just (fmap listedOf others))])) + ] + where + cfgText = Text.unpack (renderConfig cfg) + ok = either (const False) (const True) + +members :: [Member] +members = + [ Member "a" "https://10.0.0.1:2380" "https://10.0.0.1:2379" + , Member "b" "https://10.0.0.2:2380" "https://10.0.0.2:2379" + , Member "c" "https://10.0.0.3:2380" "https://10.0.0.3:2379" + ] + +self :: Member +self = members !! 1 + +others :: [Member] +others = filter (/= self) members + +listedOf :: Member -> Listed +listedOf m = Listed (member_name m) [member_peer_url m] + +cfg :: EtcdConfig +cfg = + EtcdConfig + { etcd_self = self + , etcd_cluster = members + , etcd_cluster_token = "tok" + , etcd_data_dir = "/var/lib/etcd" + , etcd_config_file = "/etc/etcd/etcd.yaml" + , etcd_user = "etcd" + , etcd_client_tls = TlsFiles "/pki/ca.crt" "/pki/client.crt" "/pki/client.key" + , etcd_peer_tls = TlsFiles "/pki/ca.crt" "/pki/peer.crt" "/pki/peer.key" + , etcd_ready_timeout_seconds = 30 + } diff --git a/test/Test/FilesystemSpec.hs b/test/Test/FilesystemSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/FilesystemSpec.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Layer 1 coverage for "Salmon.Builtin.Nodes.Filesystem"'s @check@. + +'FS.checkFileContents' is the second real check in the tree (after +'Salmon.Builtin.Nodes.Systemd.checkService') and the one that reaches the +most graphs, since nearly every recipe writes a config file. These run +against a throwaway temp directory rather than a fake filesystem, because +what the check actually asserts — "the bytes on disk are these bytes" — is +not a thing a fake can be wrong about in the interesting way. + +Two of the cases below are about consequences rather than the check itself. +'skippedFileKeepsItsMtime' is the one 'Salmon.Builtin.Nodes.Systemd' depends +on: systemd decides a unit needs reloading from its file's mtime, so a node +that rewrote identical bytes on every pass made every pass look like a +changed unit. And 'redeclaredContentsAreRewritten' is the shape of (I6) — +the same path declared with different contents — which is the case a check +is the only thing that can notice. +-} +module Test.FilesystemSpec (tests) where + +import qualified Data.ByteString.Char8 as C8 +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Bits ((.&.)) +import System.Directory ( + createDirectory, + createDirectoryIfMissing, + createFileLink, + doesDirectoryExist, + doesFileExist, + getModificationTime, + pathIsSymbolicLink, + removeFile, + ) +import System.FilePath (()) +import qualified System.Posix.Files as Posix +import qualified System.Posix.User as PosixUser +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) + +import Salmon.Actions.UpDown (CheckResult (..), Report (..)) +import Salmon.Builtin.Extension (Extension) +import Salmon.Op.Actions (shorthand) +import qualified Salmon.Builtin.Nodes.Filesystem as FS + +import Test.Harness (runDown, runUp, runUpCapturing, withTempDir) + +tests :: TestTree +tests = + testGroup + "Salmon.Builtin.Nodes.Filesystem" + [ testCase "a file that is not there yet needs writing" missingIsFailure + , testCase "a file with the right bytes is satisfied" matchingIsSuccess + , testCase "a file of the right length but the wrong bytes is not" sameSizeIsNotEnough + , testCase "the reason never quotes the contents" reasonKeepsSecrets + , testCase "a second pass skips the file instead of rewriting it" secondPassSkips + , testCase "and so leaves its mtime alone, which systemd reads" skippedFileKeepsItsMtime + , testCase "a clobbered file is written again" clobberedIsRewritten + , testCase "a deleted file is written again" deletedIsRewritten + , testCase "the same path redeclared with new contents is rewritten" redeclaredContentsAreRewritten + , testGroup + "down tolerates an effect that was never created" + [ testCase "a file already gone is not a teardown failure" downOfAbsentFileSucceeds + , testCase "a directory already gone is not a teardown failure" downOfAbsentDirSucceeds + , testCase "a file's down still takes the enclosing directory with it" downRemovesBoth + , testCase "but a directory holding something undeclared still fails" downOfNonEmptyDirFails + ] + , testGroup + "ownedFile: recursive tree ownership" + [ testCase "a missing directory is a Failure, same as a missing file" ownedMissingDirIsFailure + , testCase "a directory is checkable at all (not doesFileExist's permanent 'missing')" ownedDirectoryIsCheckable + , testCase "up recurses into nested files and subdirectories" ownedUpChownsDescendants + , testCase "ownedMode is applied to the top entry only, never descendants" ownedModeNotAppliedToDescendants + , testCase "a dangling symlink inside the tree is chowned itself, never followed" ownedTreeDoesNotFollowSymlinks + ] + ] + +-- | The node under test, and the check it carries, for one path/contents pair. +contentsAt :: FilePath -> Text -> FS.FileContents Text +contentsAt path body = FS.FileContents path body + +checkOf :: FS.FileContents Text -> IO CheckResult +checkOf = FS.checkFileContents + +nodeOf :: FS.FileContents Text -> IO Bool +nodeOf = runUp . FS.filecontents + +------------------------------------------------------------------------------- + +missingIsFailure :: IO () +missingIsFailure = withTempDir $ \d -> do + verdict <- checkOf (contentsAt (d "absent.conf") "hello\n") + assertBool "missing is a Failure" (isFailure verdict) + +matchingIsSuccess :: IO () +matchingIsSuccess = withTempDir $ \d -> do + let want = contentsAt (d "a.conf") "hello\n" + assertBool "up succeeded" =<< nodeOf want + assertEqual "the bytes match" Success =<< checkOf want + +{- | The whole reason this is a byte comparison and not +'Salmon.Actions.UpDown.skipIfFileExists': a file of exactly the right length +holding the wrong thing is the failure mode a config node most needs to +catch, and it is the one an existence check calls satisfied. It also pins +that the size comparison is a fast path in front of the answer rather than +the answer. +-} +sameSizeIsNotEnough :: IO () +sameSizeIsNotEnough = withTempDir $ \d -> do + let path = d "same-size.conf" + let want = contentsAt path "aaaaa\n" + assertBool "up succeeded" =<< nodeOf want + writeFile path "bbbbb\n" + verdict <- checkOf want + assertBool "same length, different bytes, still a Failure" (isFailure verdict) + +{- | Failure text goes into reports. The files this node writes include +pgbouncer userlists and postgrest configurations with signing keys in them, +so the reason says which file and never what is in it. +-} +reasonKeepsSecrets :: IO () +reasonKeepsSecrets = withTempDir $ \d -> do + let path = d "secret.conf" + let want = contentsAt path "password = hunter2\n" + assertBool "up succeeded" =<< nodeOf want + writeFile path "password = swordfish\n" + verdict <- checkOf want + case verdict of + Failure why -> do + assertBool "names the file" (C8.pack path `C8.isInfixOf` C8.pack (show why)) + assertBool "not what we would write" (not ("hunter2" `substr` why)) + assertBool "nor what is there" (not ("swordfish" `substr` why)) + other -> fail ("expected a Failure, got " <> show other) + +{- | The behaviour change this check lands on every existing caller: a +'filecontents' node whose bytes already match stops being re-applied. +-} +secondPassSkips :: IO () +secondPassSkips = withTempDir $ \d -> do + let want = contentsAt (d "twice.conf") "hello\n" + first <- runUpCapturing (FS.filecontents want) + assertEqual "written the first time" ["file-contents"] (evals first) + second <- runUpCapturing (FS.filecontents want) + assertEqual "skipped the second time" [] (evals second) + assertEqual "and reported as a skip" ["file-contents"] (skips second) + +{- | The consequence 'Salmon.Builtin.Nodes.Systemd.checkService' was waiting +for. systemd answers @NeedDaemonReload@ from the unit file's mtime, so a node +that rewrote byte-identical contents on every pass reported a changed unit on +every pass — and the unit check would then reload and restart a service with +nothing wrong with it. Verified against a real @systemctl --user@ unit while +writing this: rewriting identical bytes flips @NeedDaemonReload@ to @yes@. +-} +skippedFileKeepsItsMtime :: IO () +skippedFileKeepsItsMtime = withTempDir $ \d -> do + let path = d "unit.service" + let want = contentsAt path "[Service]\nExecStart=/bin/true\n" + assertBool "up succeeded" =<< nodeOf want + before <- getModificationTime path + assertBool "second up succeeded" =<< nodeOf want + after <- getModificationTime path + assertEqual "the file was not touched at all" before after + +clobberedIsRewritten :: IO () +clobberedIsRewritten = withTempDir $ \d -> do + let path = d "clobbered.conf" + let want = contentsAt path "hello\n" + assertBool "up succeeded" =<< nodeOf want + writeFile path "something else entirely\n" + reports <- runUpCapturing (FS.filecontents want) + assertEqual "written again" ["file-contents"] (evals reports) + assertEqual "and back to what it should say" "hello\n" =<< readFile path + +deletedIsRewritten :: IO () +deletedIsRewritten = withTempDir $ \d -> do + let path = d "deleted.conf" + let want = contentsAt path "hello\n" + assertBool "up succeeded" =<< nodeOf want + removeFile path + reports <- runUpCapturing (FS.filecontents want) + assertEqual "written again" ["file-contents"] (evals reports) + +{- | (I6)'s shape, from the node's end. Two declarations of one path with +different contents are one 'Salmon.Op.Ref.Ref' — @filecontents@ keys on the +path alone — so nothing above the node can tell they differ. Only the check +can, and now it does. +-} +redeclaredContentsAreRewritten :: IO () +redeclaredContentsAreRewritten = withTempDir $ \d -> do + let path = d "redeclared.conf" + assertBool "the first declaration went up" =<< nodeOf (contentsAt path "first\n") + reports <- runUpCapturing (FS.filecontents (contentsAt path "second\n")) + assertEqual "the second was evaluated, not skipped" ["file-contents"] (evals reports) + assertEqual "and the file says the new thing" "second\n" =<< readFile path + +{- | A @down@ that throws is contained by marking every /predecessor/ +'Salmon.Actions.UpDown.Blocked', so a node whose effect was never created +blocks the teardown of everything it was declared on top of. Absence is this +node's effect being absent, and teardown never consults a node's check (that +answers "does my effect need creating"), so tolerating it is the node's own +business. Found by a GCP sandbox that could not remove its working directory +because an earlier teardown had already removed the file inside it. +-} +downOfAbsentFileSucceeds :: IO () +downOfAbsentFileSucceeds = withTempDir $ \d -> do + let path = d "never-written.conf" + assertBool "tearing down a file that was never written succeeds" =<< runDown (FS.filecontents (contentsAt path "unused\n")) + +downOfAbsentDirSucceeds :: IO () +downOfAbsentDirSucceeds = withTempDir $ \d -> do + let path = d "never-created" + assertBool "tearing down a directory that was never created succeeds" =<< runDown (FS.dir (FS.Directory path)) + +-- | Tolerating absence must not turn `down` into a no-op. +downRemovesBoth :: IO () +downRemovesBoth = withTempDir $ \d -> do + let dir = d "workdir" + let path = dir "written.conf" + assertBool "the node went up" =<< nodeOf (contentsAt path "body\n") + assertBool "the file is there" =<< doesFileExist path + assertBool "teardown succeeded" =<< runDown (FS.filecontents (contentsAt path "body\n")) + assertEqual "the file is gone" False =<< doesFileExist path + assertEqual "and so is the directory it brought with it" False =<< doesDirectoryExist dir + +{- | The signal worth keeping: something in the directory was never declared +(or did not go down), which is exactly the case that caught 'Podman.login' +leaving its authfile behind. +-} +downOfNonEmptyDirFails :: IO () +downOfNonEmptyDirFails = withTempDir $ \d -> do + let dir = d "occupied" + assertBool "the directory went up" =<< runUp (FS.dir (FS.Directory dir)) + writeFile (dir "undeclared.txt") "left behind\n" + assertEqual "teardown of a non-empty directory fails" False =<< runDown (FS.dir (FS.Directory dir)) + assertBool "and leaves it standing" =<< doesDirectoryExist dir + +------------------------------------------------------------------------------- + +{- | The current process's own username\/group, so tests can declare "this +tree is owned by me" -- a chown any unprivileged test process is always +allowed to perform on files it already owns -- without needing root. +-} +selfOwnership :: IO (Text, Text) +selfOwnership = do + user <- Text.pack <$> PosixUser.getEffectiveUserName + gid <- PosixUser.getEffectiveGroupID + group <- Text.pack . PosixUser.groupName <$> PosixUser.getGroupEntryForID gid + pure (user, group) + +ownedMissingDirIsFailure :: IO () +ownedMissingDirIsFailure = withTempDir $ \d -> do + (user, group) <- selfOwnership + let owner = FS.FileOwnership (d "never-made") (Just user) (Just group) 0o755 + verdict <- FS.checkOwnership owner + assertBool "missing directory is a Failure" (isFailure verdict) + +{- | Before (I5)'s fix this used 'doesFileExist', which is 'False' for a +directory -- so a directory-shaped 'ownedFile' reported permanently +"missing", however many times 'up' ran. +-} +ownedDirectoryIsCheckable :: IO () +ownedDirectoryIsCheckable = withTempDir $ \d -> do + (user, group) <- selfOwnership + let path = d "handed-over" + createDirectory path + let owner = FS.FileOwnership path (Just user) (Just group) 0o755 + assertBool "up succeeded" =<< runUp (FS.ownedFile owner) + assertEqual "the directory now checks as Success" Success =<< FS.checkOwnership owner + +{- | A rootfs handed to an unprivileged user has package-installed +subdirectories (etc\/ssh\/sshd_config.d, say) that only the top-level chown +used to reach. 'up' must walk the whole tree. +-} +ownedUpChownsDescendants :: IO () +ownedUpChownsDescendants = withTempDir $ \d -> do + (user, group) <- selfOwnership + let top = d "rootfs-etc-ssh" + let sub = top "sshd_config.d" + createDirectoryIfMissing True sub + writeFile (sub "99-salmon-test.conf") "# nothing\n" + let owner = FS.FileOwnership top (Just user) (Just group) 0o755 + assertBool "up succeeded" =<< runUp (FS.ownedFile owner) + assertEqual "the whole tree now checks as Success" Success =<< FS.checkOwnership owner + +-- | 'ownedMode' is a statement about the directory entry itself, not a +-- recursive chmod -- a config file wanting 0644 and a host key wanting +-- 0600 underneath the same handed-over directory must not both end up at +-- whatever single mode the caller gave the top of the tree. +ownedModeNotAppliedToDescendants :: IO () +ownedModeNotAppliedToDescendants = withTempDir $ \d -> do + (user, group) <- selfOwnership + let top = d "mode-scoped" + let nested = top "keep-this-mode.conf" + createDirectory top + writeFile nested "unchanged\n" + Posix.setFileMode nested 0o600 + let owner = FS.FileOwnership top (Just user) (Just group) 0o755 + assertBool "up succeeded" =<< runUp (FS.ownedFile owner) + nestedMode <- (.&. 0o7777) . Posix.fileMode <$> Posix.getFileStatus nested + assertEqual "the nested file's own mode survived untouched" 0o600 nestedMode + +{- | A symlink under a handed-over tree is chowned itself +('setSymbolicLinkOwnerAndGroup'); its target is somebody else's business, +and a dangling one must not make the walk throw trying to stat through it. +-} +ownedTreeDoesNotFollowSymlinks :: IO () +ownedTreeDoesNotFollowSymlinks = withTempDir $ \d -> do + (user, group) <- selfOwnership + let top = d "with-a-symlink" + createDirectory top + let link = top "dangling" + createFileLink "/nonexistent-salmon-test-target" link + let owner = FS.FileOwnership top (Just user) (Just group) 0o755 + assertBool "up succeeded despite the dangling symlink" =<< runUp (FS.ownedFile owner) + assertBool "the symlink is still a symlink, not resolved/replaced" =<< pathIsSymbolicLink link + assertEqual "and the tree checks as Success" Success =<< FS.checkOwnership owner + +------------------------------------------------------------------------------- + +isFailure :: CheckResult -> Bool +isFailure (Failure _) = True +isFailure _ = False + +substr :: Text -> Text -> Bool +substr needle hay = C8.pack (show needle) `C8.isInfixOf` C8.pack (show hay) + +-- | Only the file node: 'FS.filecontents' brings its enclosing directory +-- with it, and that one has no check of its own. +evals :: [Report Extension] -> [Text] +evals rs = [shorthand act | Eval act <- rs, shorthand act == "file-contents"] + +skips :: [Report Extension] -> [Text] +skips rs = [shorthand act | Skip act <- rs, shorthand act == "file-contents"] diff --git a/test/Test/FollowCacheSpec.hs b/test/Test/FollowCacheSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/FollowCacheSpec.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE DeriveGeneric #-} + +{- | Layer 1 coverage for milestone 4 of @specs/pull-mode.md@: the cached +last document and @mode@ in @status@. + +Same harness as "Test.FollowSpec" — a @run serve@ following a directory +registry over a temp dir, standard input driven from a channel — with two +knobs more: a cache directory, and 'Follow.followRefuseOlder'. What is under +test is a restart: a loop that applied a document, quit, and comes back with +the registry moved away must converge to what it last knew and say +@mode: replay@; the registry coming back with the same bytes must inject +nothing (the starvation rule, across restarts) and turn the mode to +@following@; a different document must be diffed against the replayed one. +Then the refusals: an older @published@ under the flag, a cache file that +does not parse, and what @status@ says with nothing followed at all. +-} +module Test.FollowCacheSpec (tests) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar (newEmptyMVar, putMVar) +import Control.Concurrent.STM (TChan, atomically, newTChanIO, readTChan, writeTChan) +import Control.Exception (SomeException, throwIO, try) +import Data.Aeson (FromJSON, ToJSON, encode) +import qualified Data.ByteString.Lazy as LByteString +import Data.IORef (readIORef) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (UTCTime) +import GHC.Generics (Generic) +import System.Directory (createDirectoryIfMissing, doesFileExist, listDirectory, renameDirectory) +import System.FilePath (()) +import System.Timeout (timeout) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) + +import qualified Salmon.Actions.Follow as Follow +import Salmon.Actions.Follow (Document (..), Entry (..), Label) +import qualified Salmon.Actions.Follow.Scheduler as Scheduler +import qualified Salmon.Actions.Serve as Serve +import Salmon.Actions.Serve (Convergence (..), Direction (..), Line (..), Mode (..), NodeState (..), Origin (..), Producer (..), Provenance (..), World (..)) +import qualified Salmon.Actions.UpDown as UpDown +import Salmon.Builtin.Extension (Extension, Op, Track', deps, op, ref) +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import Salmon.Op.Configure (Configure (..)) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track (Track (..)) +import Salmon.Reporter (Reporter) + +import Test.Harness (capture, withTempDir) + +tests :: TestTree +tests = + testGroup + "Salmon.Actions.Follow (cache and mode)" + [ testCase "a restart with the registry gone replays the cache (mode: replay); the registry back with the same bytes injects nothing (mode: following); a different document is diffed against the replayed one" restartOnTheCache + , testCase "no cache and no registry: nothing is declared, and the mode is following once a round succeeds" nothingWithoutCacheOrRegistry + , testCase "--follow-refuse-older: an older `published` is refused and a newer one accepted" refuseOlder + , testCase "a cache file that does not parse is reported once and ignored" corruptCacheIsIgnored + , testCase "without --follow, status says mode: interactive" interactiveWithoutFollow + ] + +------------------------------------------------------------------------------- +-- the served thing: "make these files exist", same as Test.FollowSpec + +data Spec = Spec + { specDir :: FilePath + , specNames :: [String] + } + deriving (Eq, Show, Generic) + +instance ToJSON Spec +instance FromJSON Spec + +parseSpec :: FilePath -> [String] -> Either Text Spec +parseSpec root args + | null args = Left "expected at least one file name" + | otherwise = Right (Spec (root "files") args) + +program :: Track' Spec +program = Track $ \spec -> + op "follow-cache-root" (deps (fmap (fileOp spec.specDir) spec.specNames)) $ \actions -> + actions{ref = mkRef "follow-cache-root" (spec.specDir, spec.specNames)} + +fileOp :: FilePath -> String -> Op +fileOp d n = FS.filecontents (FS.FileContents (d n) ("contents of " <> n)) + +------------------------------------------------------------------------------- +-- driving the loop + +data Driver = Driver + { typeLine :: String -> IO () + , serveReports :: IO [Serve.Report] + , followReports :: IO [Follow.Report] + , readMode :: IO Mode + } + +interval :: Int +interval = 100000 + +-- | Rounds at 'interval', no jitter, no window, a short cap: as +-- "Test.FollowSpec". +schedule :: Scheduler.Config +schedule = + Scheduler.Config + { Scheduler.schedBase = interval + , Scheduler.schedFactor = 2 + , Scheduler.schedCap = 4 * interval + , Scheduler.schedJitter = 0 + , Scheduler.schedDebounce = 0 + , Scheduler.schedMaxWait = 0 + } + +-- | The knobs a session is started with. +data Knobs = Knobs + { knobCache :: Maybe FilePath + , knobRefuseOlder :: Bool + } + +{- | One session of a following loop over @root@: the registry is +@root/reg@, the files land in @root/files@. Ends when the body returns (or +throws); the world comes back once the loop has ended. -} +withFollowing :: FilePath -> Knobs -> [Label] -> (Driver -> IO a) -> IO (World Spec Spec, [Serve.Report], [Follow.Report], a) +withFollowing root knobs labels body = do + (serveReporter, readServe) <- capture + (followReporter, readFollow) <- capture + (nodeReporter, _) <- capture :: IO (Reporter (UpDown.Report Extension), IO [UpDown.Report Extension]) + stdinChan <- newTChanIO + gate <- newEmptyMVar + pk <- Scheduler.newPoke + modeVar <- Follow.newMode + appliedVar <- Follow.newApplied + let follow = + Follow.Follow + { Follow.followRegistry = Follow.directoryRegistry (registryDir root) + , Follow.followLabels = labels + , Follow.followSchedule = schedule + , Follow.followCache = knobs.knobCache + , Follow.followRefuseOlder = knobs.knobRefuseOlder + , Follow.followVerify = Follow.noVerifier + } + producers = + [ Follow.follower followReporter pk modeVar appliedVar follow (putMVar gate ()) + , Follow.gated gate (chanProducer stdinChan) + ] + driver = + Driver + { typeLine = \l -> atomically (writeTChan stdinChan (Just l)) + , serveReports = readServe + , followReports = readFollow + , readMode = readIORef modeVar + } + resultVar <- newTChanIO + _ <- forkIO $ do + outcome <- try (body driver) + atomically (writeTChan stdinChan Nothing) + atomically (writeTChan resultVar outcome) + w <- Serve.serveFollowing [] Nothing True serveReporter nodeReporter (parseSpec root) (Configure pure) program (Just (Follow.followed pk modeVar appliedVar)) producers + outcome <- atomically (readTChan resultVar) + case outcome of + Left (ex :: SomeException) -> throwIO ex + Right a -> (,,,) w <$> readServe <*> readFollow <*> pure a + +chanProducer :: TChan (Maybe String) -> Producer +chanProducer ch = Producer go + where + go inbox = do + next <- atomically (readTChan ch) + case next of + Nothing -> atomically (writeTChan inbox (Eof Stdin)) + Just l -> atomically (writeTChan inbox (Line Stdin l)) >> go inbox + +registryDir :: FilePath -> FilePath +registryDir root = root "reg" + +cacheDir :: FilePath -> FilePath +cacheDir root = root "cache" + +label :: Text -> Label +label t = either (error . Text.unpack) id (Follow.mkLabel t) + +-- | Write a document naming these seeds under a label, published at the +-- given time if any. +publishAt :: FilePath -> Label -> Text -> Maybe UTCTime -> [[String]] -> IO () +publishAt root lbl did published seeds = do + createDirectoryIfMissing True (registryDir root) + LByteString.writeFile (Follow.documentPath (registryDir root) lbl) (encode (Document did (fmap SeedWords seeds) published)) + +publish :: FilePath -> Label -> Text -> [[String]] -> IO () +publish root lbl did = publishAt root lbl did Nothing + +waitFor :: String -> IO Bool -> IO () +waitFor what cond = do + ok <- timeout (10 * 1000000) go + case ok of + Just () -> pure () + Nothing -> assertFailure ("timed out waiting for " <> what) + where + go = do + done <- cond + if done then pure () else threadDelay 20000 >> go + +fileExists :: FilePath -> String -> IO Bool +fileExists root n = doesFileExist (root "files" n) + +injections :: [Follow.Report] -> [(Int, Int)] +injections reports = [(nup, ndown) | Follow.Injected _ _ _ nup ndown <- reports] + +-- | The modes every @status@ answered, in order. +statusModes :: [Serve.Report] -> [Mode] +statusModes reports = [m | Serve.StatusReport m _ _ <- reports] + +-- | Type @status@ and wait for one more answer than there were before. +askStatus :: Driver -> IO Mode +askStatus d = do + before <- length . statusModes <$> d.serveReports + d.typeLine "status" + waitFor "a status answer" ((> before) . length . statusModes <$> d.serveReports) + last . statusModes <$> d.serveReports + +fetchedIds :: World seed directive -> [Text] +fetchedIds w = [prov.provDocument | e <- reverse w.worldLog, Fetched prov <- [e.logOrigin]] + +allConvergedUp :: World seed directive -> Bool +allConvergedUp w = not (Map.null w.worldNodes) && all (\st -> st.nodeDirection == TurnUp && st.nodeConvergence == Converged) (Map.elems w.worldNodes) + +------------------------------------------------------------------------------- + +{- | Session one applies a document with a cache directory; session two +starts with the registry renamed away. Then, inside session two, the +registry is put back — the same bytes — and later rewritten. -} +restartOnTheCache :: IO () +restartOnTheCache = + withTempDir $ \root -> do + let web = label "web" + knobs = Knobs (Just (cacheDir root)) False + publish root web "web@1" [["a"], ["b"]] + (w1, _, freports1, ()) <- withFollowing root knobs [web] $ \_ -> + waitFor "both files" ((&&) <$> fileExists root "a" <*> fileExists root "b") + assertBool "session one converged" (allConvergedUp w1) + assertEqual "session one injected once" [(2, 0)] (injections freports1) + -- the cache holds what was applied, and only that: no temp file left + cached <- Follow.readCache (cacheDir root) web + assertEqual "the cache holds web@1" (Right (Just "web@1")) (fmap (fmap (\(c, _) -> c.cachedId)) cached) + entries <- listDirectory (cacheDir root) + assertEqual "one file, renamed into place" ["web.applied.json"] entries + -- the registry goes away, and the files go with it, so that the + -- world is visibly rebuilt from the cache rather than found there + renameDirectory (registryDir root) (root "reg.away") + renameDirectory (root "files") (root "files.away") + (w2, reports2, freports2, ()) <- withFollowing root knobs [web] $ \d -> do + waitFor "both files, from the cache" ((&&) <$> fileExists root "a" <*> fileExists root "b") + m <- askStatus d + assertEqual "status says replay" Replay m + m' <- d.readMode + assertEqual "and so does the accessor" Replay m' + -- the registry is back with the same bytes: nothing injected, + -- and the mode turns to following at the round that saw it + renameDirectory (root "reg.away") (registryDir root) + waitFor "the mode to turn" ((== Following) <$> d.readMode) + m'' <- askStatus d + assertEqual "status says following" Following m'' + threadDelay (3 * interval) + assertEqual "nothing injected beyond the replay" [(2, 0)] . injections =<< d.followReports + -- a different document is diffed against the replayed one + publish root web "web@2" [["a"], ["b"], ["c"]] + waitFor "the new file" (fileExists root "c") + assertBool "session two converged" (allConvergedUp w2) + assertEqual "the replay was reported for web@1" ["web@1"] [did | Follow.Replayed _ did _ <- freports2] + assertBool "the registry's absence was reported" (not (null [() | Follow.FetchFailed{} <- freports2])) + assertEqual "two injections: the replay, then one seed up" [(2, 0), (1, 0)] (injections freports2) + assertEqual "history: the replayed declarations name the cached document, the diff the new one" ["web@1", "web@1", "web@2"] (fetchedIds w2) + assertEqual "status answered replay, then following" [Replay, Following] (statusModes reports2) + assertBool "the render says so on its first line" $ + case [Serve.renderReport rep | rep@Serve.StatusReport{} <- reports2] of + (first : _) : _ -> first == "serve: mode: replay" + _ -> False + cached' <- Follow.readCache (cacheDir root) web + assertEqual "the cache moved on to web@2" (Right (Just "web@2")) (fmap (fmap (\(c, _) -> c.cachedId)) cached') + +{- | Neither a cache entry nor a registry: the startup round fails, nothing +is replayed, nothing is declared; the first round that succeeds leaves the +mode at following. -} +nothingWithoutCacheOrRegistry :: IO () +nothingWithoutCacheOrRegistry = + withTempDir $ \root -> do + let web = label "web" + (w, _, freports, ()) <- withFollowing root (Knobs (Just (cacheDir root)) False) [web] $ \d -> do + waitFor "the failure to be reported" (not . null <$> (\rs -> [() | Follow.FetchFailed{} <- rs]) <$> d.followReports) + threadDelay (2 * interval) + declared <- (\rs -> [() | Serve.Declared{} <- rs]) <$> d.serveReports + assertEqual "nothing declared" [] declared + publish root web "web@1" [["a"]] + waitFor "the file, once the registry exists" (fileExists root "a") + m <- askStatus d + assertEqual "following after the first successful round" Following m + assertEqual "one injection, from the registry" [(1, 0)] (injections freports) + assertEqual "nothing was replayed" [] [() | Follow.Replayed{} <- freports] + assertBool "the world converged" (allConvergedUp w) + +refuseOlder :: IO () +refuseOlder = + withTempDir $ \root -> do + let web = label "web" + t1 = read "2026-09-23 10:00:00 UTC" + t2 = read "2026-09-23 11:00:00 UTC" + t3 = read "2026-09-23 12:00:00 UTC" + publishAt root web "web@t2" (Just t2) [["a"]] + (w, _, freports, ()) <- withFollowing root (Knobs Nothing True) [web] $ \d -> do + waitFor "the first file" (fileExists root "a") + -- older: refused, and refused once rather than once per round + publishAt root web "web@t1" (Just t1) [["a"], ["b"]] + waitFor "the refusal" (not . null <$> (\rs -> [() | Follow.Stale{} <- rs]) <$> d.followReports) + threadDelay (3 * interval) + present <- fileExists root "b" + assertBool "the older document's seed is not applied" (not present) + stale <- (\rs -> [did | Follow.Stale _ did <- rs]) <$> d.followReports + assertEqual "one refusal" ["web@t1"] stale + -- newer: accepted + publishAt root web "web@t3" (Just t3) [["a"], ["b"]] + waitFor "the newer document's file" (fileExists root "b") + -- and one with no `published` at all is never refused + publish root web "web@untimed" [["a"], ["b"], ["c"]] + waitFor "the untimed document's file" (fileExists root "c") + assertEqual "three injections: t2, t3, untimed" [(1, 0), (1, 0), (1, 0)] (injections freports) + assertEqual "the ids applied" ["web@t2", "web@t3", "web@untimed"] [did | Follow.Injected _ did _ _ _ <- freports] + assertBool "the world converged" (allConvergedUp w) + +corruptCacheIsIgnored :: IO () +corruptCacheIsIgnored = + withTempDir $ \root -> do + let web = label "web" + createDirectoryIfMissing True (cacheDir root) + LByteString.writeFile (Follow.cachePath (cacheDir root) web) "{\"salmon-cache\": 1, \"id\": \"x\", \"sha256\": \"not-the-digest\", \"document\": \"{}\"}" + -- no registry either: the corrupt entry is the only thing that + -- could have declared anything + (w, _, freports, ()) <- withFollowing root (Knobs (Just (cacheDir root)) False) [web] $ \d -> do + waitFor "the complaint" (not . null <$> (\rs -> [() | Follow.BadCache{} <- rs]) <$> d.followReports) + threadDelay (2 * interval) + declared <- (\rs -> [() | Serve.Declared{} <- rs]) <$> d.serveReports + assertEqual "nothing declared" [] declared + m <- askStatus d + assertEqual "nothing replayed, so not in replay" Following m + -- the loop is fine: a registry appearing is applied + publish root web "web@1" [["a"]] + waitFor "the file" (fileExists root "a") + assertEqual "the complaint, once" 1 (length [() | Follow.BadCache{} <- freports]) + assertBool "it names the digest mismatch" (any (Text.isInfixOf "digest") [err | Follow.BadCache _ err <- freports]) + assertEqual "nothing was replayed" [] [() | Follow.Replayed{} <- freports] + assertBool "the world converged" (allConvergedUp w) + -- and the good document replaced the corrupt entry + cached <- Follow.readCache (cacheDir root) web + assertEqual "the cache now holds web@1" (Right (Just "web@1")) (fmap (fmap (\(c, _) -> c.cachedId)) cached) + +interactiveWithoutFollow :: IO () +interactiveWithoutFollow = + withTempDir $ \root -> do + (serveReporter, readServe) <- capture + (nodeReporter, _) <- capture :: IO (Reporter (UpDown.Report Extension), IO [UpDown.Report Extension]) + stdinChan <- newTChanIO + atomically (writeTChan stdinChan (Just "status")) + atomically (writeTChan stdinChan Nothing) + _ <- Serve.serveProducers [] Nothing True serveReporter nodeReporter (parseSpec root) (Configure pure) program [chanProducer stdinChan] + reports <- readServe + assertEqual "interactive" [Interactive] (statusModes reports) + assertEqual "and rendered first" ["serve: mode: interactive", "serve: no nodes"] (concat [Serve.renderReport rep | rep@Serve.StatusReport{} <- reports]) diff --git a/test/Test/FollowRegistrySpec.hs b/test/Test/FollowRegistrySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/FollowRegistrySpec.hs @@ -0,0 +1,550 @@ +{-# LANGUAGE DeriveGeneric #-} + +{- | Layer 1 coverage for milestone 6 of @specs/pull-mode.md@: the registries +beyond the directory, and the verify-before-inject hook. + +Same harness as "Test.FollowSpec" — a @run serve@ over a temp dir, standard +input driven from a channel — pointed at local fixtures: a bare git +repository committed to from a second clone, a @warp@ server answering with +@ETag@s (and, on request, @500@), a stubbed 'Dns.Resolver' over that server, +and the bucket backend as the URL template it is. Every backend is asserted +on the same three things: the world after a document, /nothing/ injected +when the registry says unchanged (a commit that does not touch the file, a +@304@, a record whose digest did not move), and what a failure climbs. +-} +module Test.FollowRegistrySpec (tests) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar (newEmptyMVar, putMVar) +import Control.Concurrent.STM (TChan, atomically, newTChanIO, readTChan, writeTChan) +import Control.Exception (SomeException, throwIO, try) +import Data.Aeson (FromJSON, ToJSON, encode) +import qualified Data.ByteString.Char8 as C8 +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as LByteString +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import GHC.Generics (Generic) +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import System.Directory (createDirectoryIfMissing, doesFileExist, renameDirectory) +import System.Exit (ExitCode (..)) +import System.FilePath (takeDirectory, ()) +import System.Process (readCreateProcessWithExitCode, proc) +import System.Timeout (timeout) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) + +import qualified Salmon.Actions.Follow as Follow +import Salmon.Actions.Follow (Digest (..), Document (..), Entry (..), Label, Registry (..), Stamp (..)) +import qualified Salmon.Actions.Follow.Registry as Registry +import qualified Salmon.Actions.Follow.Registry.Dns as Dns +import qualified Salmon.Actions.Follow.Registry.Git as Git +import qualified Salmon.Actions.Follow.Registry.Http as Http +import qualified Salmon.Actions.Follow.Scheduler as Scheduler +import qualified Salmon.Actions.Serve as Serve +import Salmon.Actions.Serve (Convergence (..), Direction (..), Line (..), NodeState (..), Origin (..), Producer (..), World (..)) +import qualified Salmon.Actions.UpDown as UpDown +import Salmon.Builtin.Extension (Extension, Op, Track', deps, op, ref) +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import Salmon.Op.Configure (Configure (..)) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track (Track (..)) +import Salmon.Reporter (Reporter) + +import Test.Harness (capture, withTempDir) + +tests :: TestTree +tests = + testGroup + "Salmon.Actions.Follow.Registry" + [ testGroup + "addresses" + [ testCase "--follow's shape picks the backend" addressShapes + , testCase "git+URL#BRANCH:SUBDIR, and the URL's own colons left alone" gitSources + , testCase "the HTTP template: {label} placed, else /