packages feed

salmon-ops-recipes (empty) → 0.1.0.0

raw patch · 84 files changed

+25230/−0 lines, 84 filesdep +QuickCheckdep +aesondep +base

Dependencies added: QuickCheck, aeson, base, 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, http-types, jose, jose-jwt, mtl, network, optparse-applicative, optparse-generic, process, process-extras, salmon-core, salmon-ops, salmon-ops-recipes, stm, tasty, tasty-hunit, tasty-quickcheck, temporary, text, time, tls, unix, wai, warp

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for salmon-ops-recipes++## 0.1.0.0 -- unreleased++* First release.
+ LICENSE view
@@ -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.
+ salmon-ops-recipes.cabal view
@@ -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
+ src/SreBox/CabalBuilding.hs view
@@ -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"]
+ src/SreBox/DNSRegistration.hs view
@@ -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}\""+        ]
+ src/SreBox/Environment.hs view
@@ -0,0 +1,6 @@+module SreBox.Environment where++data Environment+    = Production+    | Staging+    deriving (Show, Ord, Eq)
+ src/SreBox/Gcp/CloudRunAlerts.hs view
@@ -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+(@\<service\>: 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)) <> "%"
+ src/SreBox/Gcp/CloudRunDeploy.hs view
@@ -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
+ src/SreBox/Gcp/PostgrestCloudRun.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE OverloadedStrings #-}++{- | PostgREST on Cloud Run, talking to a Postgres somewhere else over a+client certificate.++This is <https://dicioccio.fr/postgrest-over-cloudrun.html the write-up>+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"+        ]
+ src/SreBox/Gcp/PreviewEnvironment.hs view
@@ -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
+ src/SreBox/Gcp/VmProvision.hs view
@@ -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+@\<key\>-cert.pub@, which is exactly the name @ssh -i \<key\>@ 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
+ src/SreBox/Initialize.hs view
@@ -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
+ src/SreBox/JWTSigning.hs view
@@ -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)
+ src/SreBox/MicroDNS.hs view
@@ -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
+ src/SreBox/PostgresBackup.hs view
@@ -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\/\<pid\>\/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\/\<pid\>\/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++-- | @\<database\>_%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: @\<database\>_@ … @.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
+ src/SreBox/PostgresInit.hs view
@@ -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)
+ src/SreBox/PostgresMigrations.hs view
@@ -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
+ src/SreBox/PostgresPair.hs view
@@ -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 <datadir>` -- which takes the+              -- configuration to be in the data directory. On Debian it is in+              -- /etc/postgresql, so that step fails and the rewind with it, in+              -- exactly the case a failover is about: the machine that died.+              -- Do the recovery here, where the config file's location is+              -- known. Single-user, never a start: a server that listens is a+              -- second primary, and this one still believes it is one.+              "state=$(\"$bindir/pg_controldata\" -D \"$datadir\" | sed -n 's/^Database cluster state: *//p')"+            , -- and it must not throw away what it is being run for: a clean+              -- shutdown ends in a checkpoint, and a checkpoint recycles the+              -- WAL before it -- which is the WAL pg_rewind then reads, from+              -- the last checkpoint the two machines share. Keeping as much+              -- as pg_wal already holds costs nothing, since it is on the+              -- disk either way.+              "keep=$(du -sm \"$datadir/pg_wal\" | awk '{print $1 + 1}')"+            , "case \"$state\" in"+            , "  'shut down'|'shut down in recovery') ;;"+            , "  *) sudo -u postgres \"$bindir/postgres\" --single -D \"$datadir\""+                <> " -c config_file=\"$confdir/postgresql.conf\" -c wal_keep_size=\"${keep}MB\""+                <> " template1 </dev/null >/dev/null ;;"+            , "esac"+            , "sudo -u postgres env PGPASSFILE=" <> shQuote pair.pair_rewind_passfile <> " \"$bindir/pg_rewind\""+                <> " --target-pgdata=\"$datadir\" -R --source-server="+                <> shQuote (sourceServer pair (other side))+            ]+                <> standbyTail pair side+                <> [ unwords ["pg_ctlcluster", "\"$version\"", cluster side, "start"]+                   , dropStaleSlot pair side+                   ]++    {- Holding the clients, rather than dropping them: with transaction+    pooling, PAUSE waits for the transactions in flight and queues what comes+    after, so a client sees latency where it would otherwise see an error.++    Asked for and then checked, because PAUSE on an already-paused database+    is an error and a pass that is resumed after being interrupted will find+    one -- and because "did the clients actually stop" is the question this+    step exists to answer, not "did a command exit zero". -}+    pauseScript b =+        unlines+            [ "set -e"+            , -- 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 <<PAIR_SQL\n" <> sql <> "\nPAIR_SQL"++    {- Created if missing, and its password set either way, so that rotating+    the passfile is enough to rotate the role. -}+    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
+ src/SreBox/PostgresTemplate.hs view
@@ -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
+ src/SreBox/PostgresTls.hs view
@@ -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+<https://dicioccio.fr/postgrest-over-cloudrun.html the PostgREST-on-Cloud-Run+write-up> 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+        ]
+ src/SreBox/Postgrest.hs view
@@ -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
+ src/SreBox/WireGuardVpn.hs view
@@ -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
+ test/Main.hs view
@@ -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+            ]
+ test/Test/AptRepositorySpec.hs view
@@ -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"
+ test/Test/CheckSpec.hs view
@@ -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
+ test/Test/ClientModelSpec.hs view
@@ -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
+ test/Test/ConcurrentSpec.hs view
@@ -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
+ test/Test/DaemonSpec.hs view
@@ -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"
+ test/Test/DagSpec.hs view
@@ -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])
+ test/Test/DebianPackageSpec.hs view
@@ -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"
+ test/Test/DebootstrapSpec.hs view
@@ -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")
+ test/Test/DownTreeSpec.hs view
@@ -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)
+ test/Test/EtcdSpec.hs view
@@ -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+        }
+ test/Test/FilesystemSpec.hs view
@@ -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"]
+ test/Test/FollowCacheSpec.hs view
@@ -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])
+ test/Test/FollowRegistrySpec.hs view
@@ -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 /<label>.json appended" httpTemplate+            , testCase "the bucket templates: virtual-hosted S3, path-style under an endpoint, GCS" bucketTemplates+            , testCase "dig +short's output: quoted strings joined, comments skipped" digOutput+            , testCase "the index record: v=salmon1 url= sha256=, and what is refused" indexRecords+            ]+        , testCase "git: a commit is applied; a commit that leaves the file alone injects nothing; a second commit is diffed; the repository gone is a failed round" gitRegistry+        , testCase "http: a document is applied; 304 injects nothing and moves no bytes; 404 is absent; 500 climbs the ladder" httpRegistry+        , testCase "dns: the record's digest is the stamp; the store disagreeing with the index is refused; no record is absent" dnsRegistry+        , testCase "bucket: an s3:// address under an endpoint is the HTTP backend at BUCKET/PREFIX/<label>.json" bucketRegistry+        , testCase "verify: a refused document is a failed round, reaches neither the loop nor the cache; a refused cache entry is not replayed" verifyHook+        ]++-------------------------------------------------------------------------------+-- 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-registry-root" (deps (fmap (fileOp spec.specDir) spec.specNames)) $ \actions ->+        actions{ref = mkRef "follow-registry-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]+    }++interval :: Int+interval = 100000++-- | Rounds at 'interval', no jitter, no window, a short cap.+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+        }++data Knobs = Knobs+    { knobCache :: Maybe FilePath+    , knobVerify :: Follow.Verifier+    }++plain :: Knobs+plain = Knobs Nothing Follow.noVerifier++{- | One session of a following loop over @root@ against the given registry;+the files land in @root/files@. Ends when the body returns (or throws). -}+withFollowing :: FilePath -> Registry -> Knobs -> [Label] -> (Driver -> IO a) -> IO (World Spec Spec, [Serve.Report], [Follow.Report], a)+withFollowing root registry 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 = registry+                , Follow.followLabels = labels+                , Follow.followSchedule = schedule+                , Follow.followCache = knobs.knobCache+                , Follow.followRefuseOlder = False+                , Follow.followVerify = knobs.knobVerify+                }+        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+                }+    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++label :: Text -> Label+label t = either (error . Text.unpack) id (Follow.mkLabel t)++-- | A document naming these seeds, as bytes.+document :: Text -> [[String]] -> ByteString+document did seeds = encode (Document did (fmap SeedWords seeds) 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]++fetchFailures :: [Follow.Report] -> [Text]+fetchFailures reports = [err | Follow.FetchFailed _ err <- reports]++backoffs :: [Follow.Report] -> [Int]+backoffs reports = [n | Follow.Backoff n _ <- reports]++allConvergedUp :: World seed directive -> Bool+allConvergedUp w = not (Map.null w.worldNodes) && all (\st -> st.nodeDirection == TurnUp && st.nodeConvergence == Converged) (Map.elems w.worldNodes)++-------------------------------------------------------------------------------+-- the pure half++addressShapes :: IO ()+addressShapes = do+    assertEqual "a path" (Right (Registry.Directory "/srv/reg")) (Registry.parseAddress "/srv/reg")+    assertEqual "a relative path" (Right (Registry.Directory "reg")) (Registry.parseAddress "reg")+    assertEqual "http" (Right (Registry.Http "http://h/p")) (Registry.parseAddress "http://h/p")+    assertEqual "https" (Right (Registry.Http "https://h/seed/latest/{label}")) (Registry.parseAddress "https://h/seed/latest/{label}")+    assertEqual "dns" (Right (Registry.Dns "fleet.example")) (Registry.parseAddress "dns:fleet.example")+    assertBool "dns without a zone" (either (const True) (const False) (Registry.parseAddress "dns:"))+    assertEqual "s3" (Right (Registry.InBucket (Registry.Bucket Registry.S3 "b" "p/q"))) (Registry.parseAddress "s3://b/p/q/")+    assertEqual "gs, no prefix" (Right (Registry.InBucket (Registry.Bucket Registry.Gcs "b" ""))) (Registry.parseAddress "gs://b")+    assertBool "a bucket without a name" (either (const True) (const False) (Registry.parseAddress "s3://"))+    assertEqual "git" (Right (Registry.Git (Git.Source "https://h/r.git" Nothing Nothing))) (Registry.parseAddress "git+https://h/r.git")++gitSources :: IO ()+gitSources = do+    let src = Git.Source+    assertEqual "url only" (Right (src "ssh://git@h:22/r" Nothing Nothing)) (Git.parseSource "ssh://git@h:22/r")+    assertEqual "branch" (Right (src "git@h:r.git" (Just "main") Nothing)) (Git.parseSource "git@h:r.git#main")+    assertEqual "branch and subdir" (Right (src "https://h/r" (Just "main") (Just "hosts/eu"))) (Git.parseSource "https://h/r#main:hosts/eu")+    assertEqual "default branch, subdir" (Right (src "https://h/r" Nothing (Just "hosts"))) (Git.parseSource "https://h/r#:hosts")+    assertBool "no url" (either (const True) (const False) (Git.parseSource "#main"))+    assertEqual "rendered back" "git+https://h/r#main:hosts/eu" (Git.renderSource (src "https://h/r" (Just "main") (Just "hosts/eu")))+    assertEqual "rendered back, plain" "git+https://h/r" (Git.renderSource (src "https://h/r" Nothing Nothing))+    assertEqual "the document's path" ("/w/hosts" </> "web.json") (Git.documentPathIn "/w" (src "u" Nothing (Just "hosts")) (label "web"))+    assertEqual "the document's path, no subdir" ("/w" </> "web.json") (Git.documentPathIn "/w" (src "u" Nothing Nothing) (label "web"))++httpTemplate :: IO ()+httpTemplate = do+    assertEqual "appended" "https://h/reg/web.json" (Http.addressFor "https://h/reg" (label "web"))+    assertEqual "trailing slash not doubled" "https://h/reg/web.json" (Http.addressFor "https://h/reg/" (label "web"))+    assertEqual "placed" "https://h/seed/latest/web" (Http.addressFor "https://h/seed/latest/{label}" (label "web"))+    assertEqual "placed twice" "https://web.h/web" (Http.addressFor "https://{label}.h/{label}" (label "web"))++bucketTemplates :: IO ()+bucketTemplates = do+    assertEqual "s3" "https://b.s3.amazonaws.com/p" (Registry.bucketTemplate Nothing (Registry.Bucket Registry.S3 "b" "p"))+    assertEqual "s3, no prefix" "https://b.s3.amazonaws.com" (Registry.bucketTemplate Nothing (Registry.Bucket Registry.S3 "b" ""))+    assertEqual "s3 under an endpoint" "https://minio.local:9000/b/p" (Registry.bucketTemplate (Just "https://minio.local:9000/") (Registry.Bucket Registry.S3 "b" "p"))+    assertEqual "gcs" "https://storage.googleapis.com/b/p" (Registry.bucketTemplate Nothing (Registry.Bucket Registry.Gcs "b" "p"))+    assertEqual "and then the label" "https://b.s3.amazonaws.com/p/web.json" (Http.addressFor (Registry.bucketTemplate Nothing (Registry.Bucket Registry.S3 "b" "p")) (label "web"))++digOutput :: IO ()+digOutput = do+    assertEqual "one string" ["v=salmon1 url=https://h/d sha256=ab"] (Dns.parseDigTxt "\"v=salmon1 url=https://h/d sha256=ab\"\n")+    assertEqual "two records" ["a", "b"] (Dns.parseDigTxt "\"a\"\n\"b\"\n")+    assertEqual "strings joined" ["abcdef"] (Dns.parseDigTxt "\"abc\" \"def\"\n")+    assertEqual "escapes" ["say \"hi\" \\ there"] (Dns.parseDigTxt "\"say \\\"hi\\\" \\\\ there\"\n")+    assertEqual "comments and blanks skipped" [] (Dns.parseDigTxt ";; communications error to 127.0.0.1#53: timed out\n\n")+    assertEqual "nothing" [] (Dns.parseDigTxt "")++indexRecords :: IO ()+indexRecords = do+    let hex = Text.replicate 64 "a"+    assertEqual "parsed" (Right (Dns.IndexRecord "https://h/d.json" (Digest hex))) (Dns.parseIndexRecord ("v=salmon1 url=https://h/d.json sha256=" <> hex))+    assertEqual "any order, upper-case hex lowered" (Right (Dns.IndexRecord "https://h/d.json" (Digest hex))) (Dns.parseIndexRecord ("v=salmon1  sha256=" <> Text.toUpper hex <> " url=https://h/d.json"))+    assertBool "another version" (either (const True) (const False) (Dns.parseIndexRecord ("v=salmon2 url=u sha256=" <> hex)))+    assertBool "no url" (either (const True) (const False) (Dns.parseIndexRecord ("v=salmon1 sha256=" <> hex)))+    assertBool "no digest" (either (const True) (const False) (Dns.parseIndexRecord "v=salmon1 url=u"))+    assertBool "a short digest" (either (const True) (const False) (Dns.parseIndexRecord "v=salmon1 url=u sha256=abc"))+    assertEqual "the name" "web.fleet.example" (Dns.recordName "fleet.example." (label "web"))++-------------------------------------------------------------------------------+-- git++-- | Run git in a directory, failing the test on a non-zero exit.+git :: FilePath -> [String] -> IO String+git dir args = do+    (code, out, err) <- readCreateProcessWithExitCode (proc "git" (["-C", dir, "-c", "user.name=test", "-c", "user.email=test@example", "-c", "commit.gpgsign=false"] ++ args)) ""+    case code of+        ExitSuccess -> pure out+        ExitFailure n -> assertFailure ("git " <> unwords args <> " exited " <> show n <> ": " <> err) >> pure out++-- | Commit a document for a label into the publisher's clone and push it.+publishGit :: FilePath -> Label -> ByteString -> String -> IO ()+publishGit pub lbl bytes message = do+    let path = Git.documentPathIn pub (Git.Source "" Nothing (Just "hosts")) lbl+    createDirectoryIfMissing True (takeDirectory path)+    LByteString.writeFile path bytes+    _ <- git pub ["add", "-A"]+    _ <- git pub ["commit", "--quiet", "-m", message]+    _ <- git pub ["push", "--quiet", "origin", "main"]+    pure ()++gitRegistry :: IO ()+gitRegistry =+    withTempDir $ \root -> do+        let bare = root </> "repo.git"+            pub = root </> "pub"+            web = label "web"+            api = label "api"+        _ <- git root ["init", "--quiet", "--bare", "-b", "main", bare]+        _ <- git root ["clone", "--quiet", bare, pub]+        _ <- git pub ["checkout", "--quiet", "-b", "main"]+        publishGit pub web (document "web@1" [["a"], ["b"]]) "web@1"+        registry <- Git.gitRegistry (root </> "checkout") (Git.Source (Text.pack ("file://" <> bare)) (Just "main") (Just "hosts"))+        assertEqual "named as given" ("git+file://" <> Text.pack bare <> "#main:hosts") registry.registryName+        (w, _, freports, ()) <- withFollowing root registry plain [web, api] $ \d -> do+            waitFor "both files" ((&&) <$> fileExists root "a" <*> fileExists root "b")+            waitFor "api reported missing" (elem (Follow.Missing api) <$> d.followReports)+            -- a commit that does not touch the document: the stamp moves,+            -- the bytes do not, nothing is injected+            _ <- git pub ["commit", "--quiet", "--allow-empty", "-m", "nothing"]+            _ <- git pub ["push", "--quiet", "origin", "main"]+            threadDelay (4 * interval)+            assertEqual "one injection so far" [(2, 0)] . injections =<< d.followReports+            -- a second commit changes it+            publishGit pub web (document "web@2" [["a"], ["c"]]) "web@2"+            waitFor "the new file" (fileExists root "c")+            waitFor "the dropped one gone" (not <$> fileExists root "b")+            -- the repository gone is a failed round, and the world stands+            renameDirectory bare (bare <> ".away")+            waitFor "the failure" (not . null . fetchFailures <$> d.followReports)+            waitFor "the ladder" (not . null . backoffs <$> d.followReports)+            present <- (&&) <$> fileExists root "a" <*> fileExists root "c"+            assertBool "the last document stays in force" present+            renameDirectory (bare <> ".away") bare+            publishGit pub web (document "web@3" [["a"], ["c"], ["d"]]) "web@3"+            waitFor "recovered: the third document's file" (fileExists root "d")+        assertEqual "three injections" [(2, 0), (1, 1), (1, 0)] (injections freports)+        assertEqual "the ids" ["web@1", "web@2", "web@3"] [did | Follow.Injected _ did _ _ _ <- freports]+        assertBool "the world converged" (allConvergedUp w)+        assertBool "the failure names git" (any (Text.isInfixOf "git") (fetchFailures freports))++-------------------------------------------------------------------------------+-- http++-- | What the fixture server holds, and how it is told to misbehave.+data Store = Store+    { storeDocs :: IORef (Map Text ByteString)+    -- ^ by path, @/reg/web.json@+    , storeFailing :: IORef Bool+    -- ^ answer 500 to everything+    , storeBodies :: IORef Int+    -- ^ how many 200s carried a body+    }++newStore :: IO Store+newStore = Store <$> newIORef Map.empty <*> newIORef False <*> newIORef 0++-- | ETags from the digest, @304@ on a matching @If-None-Match@.+storeApp :: Store -> Wai.Application+storeApp st req respond = do+    failing <- readIORef st.storeFailing+    docs <- readIORef st.storeDocs+    let path = Text.decodeUtf8 (Wai.rawPathInfo req)+    if failing+        then respond (Wai.responseLBS HTTP.status500 [] "down")+        else case Map.lookup path docs of+            Nothing -> respond (Wai.responseLBS HTTP.status404 [] "no such document")+            Just bytes -> do+                let etag = C8.pack ("\"" <> Text.unpack (Follow.digestOf bytes).unDigest <> "\"")+                if lookup "If-None-Match" (Wai.requestHeaders req) == Just etag+                    then respond (Wai.responseLBS HTTP.status304 [("ETag", etag)] "")+                    else do+                        atomicModifyIORef' st.storeBodies (\n -> (n + 1, ()))+                        respond (Wai.responseLBS HTTP.status200 [("ETag", etag), ("Content-Type", "application/json")] bytes)++withStore :: (Store -> Text -> IO a) -> IO a+withStore body = do+    st <- newStore+    Warp.testWithApplication (pure (storeApp st)) $ \port ->+        body st ("http://127.0.0.1:" <> Text.pack (show port))++put :: Store -> Text -> ByteString -> IO ()+put st path bytes = atomicModifyIORef' st.storeDocs (\m -> (Map.insert path bytes m, ()))++httpRegistry :: IO ()+httpRegistry =+    withTempDir $ \root -> withStore $ \st base -> do+        let web = label "web"+            api = label "api"+        put st "/reg/web.json" (document "web@1" [["a"], ["b"]])+        mgr <- Http.newManager Http.defaultOptions+        let registry = Http.httpRegistry mgr (base <> "/reg")+        (w, _, freports, ()) <- withFollowing root registry plain [web, api] $ \d -> do+            waitFor "both files" ((&&) <$> fileExists root "a" <*> fileExists root "b")+            waitFor "api reported missing (404)" (elem (Follow.Missing api) <$> d.followReports)+            -- rounds keep going, and every one of them is a 304: no body,+            -- no injection+            bodies <- readIORef st.storeBodies+            threadDelay (4 * interval)+            bodies' <- readIORef st.storeBodies+            assertEqual "one body was ever sent for web" 1 bodies+            assertEqual "and no more since" bodies bodies'+            assertEqual "one injection" [(2, 0)] . injections =<< d.followReports+            -- 500: the ladder+            writeIORef st.storeFailing True+            waitFor "the failure" (not . null . fetchFailures <$> d.followReports)+            waitFor "two rungs" ((>= 2) . length . backoffs <$> d.followReports)+            present <- (&&) <$> fileExists root "a" <*> fileExists root "b"+            assertBool "the last document stays in force" present+            -- back, changed+            writeIORef st.storeFailing False+            put st "/reg/web.json" (document "web@2" [["a"], ["c"]])+            waitFor "the new file" (fileExists root "c")+        assertEqual "two injections" [(2, 0), (1, 1)] (injections freports)+        assertBool "the failure names the status" (any (Text.isInfixOf "500") (fetchFailures freports))+        assertBool "the ladder climbed" (2 `elem` backoffs freports)+        assertBool "the world converged" (allConvergedUp w)++-------------------------------------------------------------------------------+-- dns++-- | A resolver over a map, counting lookups.+stubResolver :: IORef (Map Text [Text]) -> IORef Int -> Dns.Resolver+stubResolver records lookups =+    Dns.Resolver+        { Dns.resolverName = "stub"+        , Dns.resolveTxt = \name -> do+            atomicModifyIORef' lookups (\n -> (n + 1, ()))+            Map.findWithDefault [] name <$> readIORef records+        }++indexRecord :: Text -> ByteString -> Text+indexRecord url bytes = "v=salmon1 url=" <> url <> " sha256=" <> (Follow.digestOf bytes).unDigest++dnsRegistry :: IO ()+dnsRegistry =+    withTempDir $ \root -> withStore $ \st base -> do+        let web = label "web"+            api = label "api"+            zone = "fleet.test"+            doc1 = document "web@1" [["a"], ["b"]]+            doc2 = document "web@2" [["a"], ["c"]]+            url = base <> "/store/web-latest.json"+        records <- newIORef (Map.fromList [("web.fleet.test", [indexRecord url doc1])])+        lookups <- newIORef 0+        put st "/store/web-latest.json" doc1+        mgr <- Http.newManager Http.defaultOptions+        let registry = Dns.dnsRegistry (stubResolver records lookups) mgr zone+        assertEqual "named as given" "dns:fleet.test" registry.registryName+        (w, _, freports, ()) <- withFollowing root registry plain [web, api] $ \d -> do+            waitFor "both files" ((&&) <$> fileExists root "a" <*> fileExists root "b")+            waitFor "api reported missing (no record)" (elem (Follow.Missing api) <$> d.followReports)+            -- rounds are lookups only: the record's digest is the stamp,+            -- so the store is not asked again+            bodies <- readIORef st.storeBodies+            n <- readIORef lookups+            threadDelay (4 * interval)+            bodies' <- readIORef st.storeBodies+            n' <- readIORef lookups+            assertEqual "one body was ever fetched" 1 bodies+            assertEqual "and none since" bodies bodies'+            assertBool "while the resolver kept being asked" (n' > n)+            -- the index moves before the store does: refused, not applied+            writeIORef records (Map.fromList [("web.fleet.test", [indexRecord url doc2])])+            waitFor "the mismatch" (any (Text.isInfixOf "does not hash") . fetchFailures <$> d.followReports)+            waitFor "the ladder" (not . null . backoffs <$> d.followReports)+            present <- fileExists root "c"+            assertBool "the announced-but-unserved document is not applied" (not present)+            -- the store catches up+            put st "/store/web-latest.json" doc2+            waitFor "the new file" (fileExists root "c")+            -- the record going away: the last document stays in force+            writeIORef records Map.empty+            waitFor "vanished" (elem (Follow.Vanished web) <$> d.followReports)+        assertEqual "two injections" [(2, 0), (1, 1)] (injections freports)+        assertBool "the world converged" (allConvergedUp w)++-------------------------------------------------------------------------------+-- bucket++bucketRegistry :: IO ()+bucketRegistry =+    withTempDir $ \root -> withStore $ \st base -> do+        let web = label "web"+        put st "/bucket/fleet/web.json" (document "web@1" [["a"]])+        registry <-+            Registry.open+                Registry.defaultOptions{Registry.optBucketEndpoint = Just base}+                (Registry.InBucket (Registry.Bucket Registry.S3 "bucket" "fleet"))+        assertEqual "named as given" "s3://bucket/fleet" registry.registryName+        (w, _, freports, ()) <- withFollowing root registry plain [web] $ \_ ->+            waitFor "the file" (fileExists root "a")+        assertEqual "one injection" [(1, 0)] (injections freports)+        assertBool "the world converged" (allConvergedUp w)++-------------------------------------------------------------------------------+-- the verify hook++verifyHook :: IO ()+verifyHook =+    withTempDir $ \root -> do+        let web = label "web"+            reg = root </> "reg"+            cache = root </> "cache"+            -- a verifier that refuses any document mentioning the seed `evil`+            refusing :: Follow.Verifier+            refusing _ _ bytes+                | "evil" `Text.isInfixOf` Text.decodeUtf8Lenient (LByteString.toStrict bytes) = pure (Left "mentions evil")+                | otherwise = pure (Right bytes)+            knobs = Knobs (Just cache) refusing+            publish bytes = createDirectoryIfMissing True reg >> LByteString.writeFile (Follow.documentPath reg web) bytes+        publish (document "web@1" [["a"]])+        (w, _, freports, ()) <- withFollowing root (Follow.directoryRegistry reg) knobs [web] $ \d -> do+            waitFor "the file" (fileExists root "a")+            publish (document "web@evil" [["a"], ["evil"]])+            waitFor "the refusal" (not . null <$> (\rs -> [() | Follow.Rejected{} <- rs]) <$> d.followReports)+            waitFor "the ladder" (not . null . backoffs <$> d.followReports)+            threadDelay (2 * interval)+            present <- fileExists root "evil"+            assertBool "never applied" (not present)+            declared <- (\rs -> [() | Serve.Declared{} <- rs]) <$> d.serveReports+            assertEqual "one declaration, the first document's" 1 (length declared)+            cached <- Follow.readCache cache web+            assertEqual "the cache still holds the good one" (Right (Just "web@1")) (fmap (fmap (\(c, _) -> c.cachedId)) cached)+            -- a good document again is applied on top of the last good one+            publish (document "web@2" [["a"], ["b"]])+            waitFor "the next good file" (fileExists root "b")+        assertEqual "the refusal, once, with its reason" ["mentions evil"] [why | Follow.Rejected _ _ why <- freports]+        assertEqual "two injections" [(1, 0), (1, 0)] (injections freports)+        assertBool "the world converged" (allConvergedUp w)+        -- a cache entry the verifier refuses is not replayed: write one+        -- by hand and start with the registry gone+        Follow.writeCache cache web (Follow.Cached "web@evil" (Follow.digestOf evilBytes) evilBytes)+        renameDirectory reg (reg <> ".away")+        renameDirectory (root </> "files") (root </> "files.away")+        (_, sreports2, freports2, ()) <- withFollowing root (Follow.directoryRegistry reg) knobs [web] $ \d -> do+            waitFor "the refusal" (not . null <$> (\rs -> [() | Follow.Rejected{} <- rs]) <$> d.followReports)+            threadDelay (2 * interval)+        assertEqual "nothing replayed" [] [() | Follow.Replayed{} <- freports2]+        assertEqual "nothing declared" [] [() | Serve.Declared{} <- sreports2]+        assertEqual "the refusal named the cache's digest" [Follow.digestOf evilBytes] [dg | Follow.Rejected _ dg _ <- freports2]+  where+    evilBytes = document "web@evil" [["evil"]]
+ test/Test/FollowSchedulerSpec.hs view
@@ -0,0 +1,488 @@+{-# LANGUAGE DeriveGeneric #-}++{- | "Salmon.Actions.Follow.Scheduler", at two layers.++The pure step ('Scheduler.observed'\/'Scheduler.poked'\/'Scheduler.injected'+and 'Scheduler.next') is table-tested directly: the ladder toward the+registry, the quiet window and @max_wait@ toward the loop, and what @fetch@+does to both.++Then the fetcher of "Salmon.Actions.Follow" is run on that step with a+clock the test moves ('FakeClock'): a @run serve@ over a temp-dir registry,+as "Test.FollowSpec" does, except that nothing here ever sleeps — the+fetcher blocks until the test advances time past its deadline, and the+test can read what deadline it is waiting for, which is what makes "polled+on the ladder, not the base" an assertion on numbers rather than on+timing.+-}+module Test.FollowSchedulerSpec (tests) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar (newEmptyMVar, putMVar)+import Control.Concurrent.STM (TChan, TVar, atomically, check, newTChanIO, newTVarIO, orElse, readTChan, readTVar, readTVarIO, writeTChan, writeTVar)+import Control.Exception (SomeException, throwIO, try)+import Data.Aeson (FromJSON, ToJSON, encode)+import qualified Data.ByteString.Lazy as LByteString+import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import System.Directory (createDirectoryIfMissing, doesFileExist)+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 Salmon.Actions.Follow.Scheduler (Action (..), Config (..), Due (..), Outcome (..), Wake (..))+import qualified Salmon.Actions.Serve as Serve+import Salmon.Actions.Serve (Convergence (..), 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.Scheduler"+        [ testGroup+            "the step"+            [ testCase "the ladder: base, then times factor per consecutive failure, up to cap, back to base on success" ladderSteps+            , testCase "jitter scales every delay within its band, and the same seed draws the same delays" jitterBand+            , testCase "the window: changes inside it restart it, and one injection is due once it is quiet" quietWindow+            , testCase "max_wait: a registry that never goes quiet is injected at max_wait" maxWait+            , testCase "poked: a round now, the ladder forgotten, the pending batch injected right after" pokedFlushes+            , testCase "poked with nothing pending afterwards flushes nothing" pokedNothing+            ]+        , testGroup+            "the fetcher on a moved clock"+            [ testCase "three writes inside the window are one injection, diffed against the last applied document, and one pass" threeWritesOnePass+            , testCase "a registry that throws is polled on the ladder, not the base" failingRegistryOnTheLadder+            , testCase "`fetch` injects the pending batch at once, and resets the ladder" fetchCommand+            ]+        , testGroup+            "the command"+            [ testCase "`fetch` parses, takes no argument, and is in the reference" fetchParses+            , testCase "`fetch` with nothing followed says so" fetchNothingFollowed+            ]+        ]++-------------------------------------------------------------------------------+-- the step++-- | Small integers as microseconds: the units are the step's own.+cfg :: Config+cfg =+    Config+        { schedBase = 2+        , schedFactor = 2+        , schedCap = 9+        , schedJitter = 0+        , schedDebounce = 5+        , schedMaxWait = 60+        }++-- | Feed outcomes at successive round times and collect each next deadline.+rounds :: Config -> Scheduler.Sched -> [(Int, Outcome)] -> [Due]+rounds c = go+  where+    go _ [] = []+    go st ((t, o) : rest) =+        let st' = Scheduler.observed c t o st+         in Scheduler.next c st' : go st' rest++ladderSteps :: IO ()+ladderSteps = do+    assertEqual "rungs" [2, 2, 4, 8, 9, 9] (fmap (Scheduler.ladder cfg) [0, 1, 2, 3, 4, 5])+    let st0 = Scheduler.start cfg (Scheduler.mkRng 1) 0+    assertEqual "after startup, one base away" (Due 2 Fetch) (Scheduler.next cfg st0)+    -- failures at their own deadlines: each next round is a rung further+    let dues = rounds cfg st0 [(2, Failed), (4, Failed), (8, Failed), (16, Failed), (25, Failed), (34, Unchanged), (36, Failed)]+    assertEqual+        "failing: base, then doubling, then capped; success resets; a fresh failure starts over at base"+        [Due 4 Fetch, Due 8 Fetch, Due 16 Fetch, Due 25 Fetch, Due 34 Fetch, Due 36 Fetch, Due 38 Fetch]+        dues+    assertEqual "a changed round is a success too" [Due 4 Fetch, Due 6 Fetch] (fmap (\d -> d{dueAction = Fetch}) (rounds cfg st0 [(2, Failed), (4, Changed)]))++jitterBand :: IO ()+jitterBand = do+    let jc = cfg{schedBase = 1000, schedJitter = 0.2}+        draws g n = if n == (0 :: Int) then [] else let (d, g') = Scheduler.jittered jc g 1000 in d : draws g' (n - 1)+        xs = draws (Scheduler.mkRng 42) 200+    assertBool "every delay within [800, 1200]" (all (\d -> d >= 800 && d <= 1200) xs)+    assertBool "and not all the same" (any (/= 1000) xs)+    assertEqual "the same seed draws the same delays" xs (draws (Scheduler.mkRng 42) 200)+    assertEqual "no jitter is the identity" (1000, Scheduler.mkRng 7) (Scheduler.jittered cfg (Scheduler.mkRng 7) 1000)++quietWindow :: IO ()+quietWindow = do+    let st0 = Scheduler.start cfg (Scheduler.mkRng 1) 0+    -- a change at 2 opens a window closing at 7; the round at 4 is sooner+    -- than that, so it is what is due; each change restarts the window;+    -- once rounds stop seeing changes the window's close is what is due+    assertEqual+        "changes at 2, 4, 6 then quiet: the injection is due at 6 + debounce"+        [Due 4 Fetch, Due 6 Fetch, Due 8 Fetch, Due 10 Fetch, Due 11 Inject]+        (rounds cfg st0 [(2, Changed), (4, Changed), (6, Changed), (8, Unchanged), (10, Unchanged)])+    -- and after the injection nothing is pending+    let st = foldl (\s (t, o) -> Scheduler.observed cfg t o s) st0 [(2, Changed), (4, Changed), (6, Changed), (8, Unchanged), (10, Unchanged)]+    assertEqual "injected: back to plain rounds" (Due 12 Fetch) (Scheduler.next cfg (Scheduler.injected 11 st))+    assertEqual "an injection due at the same instant as a round goes second" (Due 7 Fetch) (Scheduler.next cfg (Scheduler.observed cfg 2 Changed st0){Scheduler.schedNextFetch = 7})++maxWait :: IO ()+maxWait = do+    let mc = cfg{schedMaxWait = 9}+        st0 = Scheduler.start mc (Scheduler.mkRng 1) 0+    assertEqual+        "every round changes: the window never closes, max_wait (2 + 9 = 11) does"+        [Due 4 Fetch, Due 6 Fetch, Due 8 Fetch, Due 10 Fetch, Due 11 Inject]+        (rounds mc st0 [(2, Changed), (4, Changed), (6, Changed), (8, Changed), (10, Changed)])++pokedFlushes :: IO ()+pokedFlushes = do+    let pc = cfg{schedDebounce = 50}+        st0 = Scheduler.start pc (Scheduler.mkRng 1) 0+        -- three failures deep, with a change seen before they began, its+        -- window (2 + 50) still open+        st = foldl (\s (t, o) -> Scheduler.observed pc t o s) st0 [(2, Changed), (4, Failed), (6, Failed), (10, Failed)]+    assertEqual "before: the next round is up the ladder, the injection far off" (Due 18 Fetch) (Scheduler.next pc st)+    let p = Scheduler.poked 12 st+    assertEqual "poked: a round now" (Due 12 Fetch) (Scheduler.next pc p)+    assertEqual "and the failures forgotten" 0 (Scheduler.schedFailures p)+    let p' = Scheduler.observed pc 12 Unchanged p+    assertEqual "after that round: the pending batch is due now, not at its window" (Due 12 Inject) (Scheduler.next pc p')+    assertEqual "then rounds at the base" (Due 14 Fetch) (Scheduler.next pc (Scheduler.injected 12 p'))+    -- a change the poked round itself finds is flushed just the same+    let q = Scheduler.observed pc 12 Changed (Scheduler.poked 12 st0)+    assertEqual "a change found by the poked round is injected at once" (Due 12 Inject) (Scheduler.next pc q)++pokedNothing :: IO ()+pokedNothing = do+    let st0 = Scheduler.start cfg (Scheduler.mkRng 1) 0+        p = Scheduler.observed cfg 5 Unchanged (Scheduler.poked 5 st0)+    assertEqual "nothing pending: plain rounds" (Due 7 Fetch) (Scheduler.next cfg p)+    -- a later change is not flushed by a poke that is long over+    assertEqual "a later change waits its window" (Due 12 Inject) (Scheduler.next cfg (Scheduler.observed cfg 7 Changed p){Scheduler.schedNextFetch = 20})++-------------------------------------------------------------------------------+-- 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-sched-root" (deps (fmap (fileOp spec.specDir) spec.specNames)) $ \actions ->+        actions{ref = mkRef "follow-sched-root" (spec.specDir, spec.specNames)}++fileOp :: FilePath -> String -> Op+fileOp d n = FS.filecontents (FS.FileContents (d </> n) ("contents of " <> n))++-------------------------------------------------------------------------------+-- a clock the test moves++data FakeClock = FakeClock+    { fakeNow :: TVar Int+    , fakePoke :: TVar Bool+    , fakeSleeping :: TVar (Maybe Int)+    -- ^ the deadline the fetcher is currently waiting for, if it is+    }++newFakeClock :: IO FakeClock+newFakeClock = FakeClock <$> newTVarIO 0 <*> newTVarIO False <*> newTVarIO Nothing++clockOf :: FakeClock -> Scheduler.Clock+clockOf fc =+    Scheduler.Clock+        { Scheduler.clockNow = readTVarIO fc.fakeNow+        , Scheduler.clockWaitUntil = \at -> do+            atomically (writeTVar fc.fakeSleeping (Just at))+            wake <-+                atomically $+                    (readTVar fc.fakeNow >>= \n -> check (n >= at) >> pure Elapsed)+                        `orElse` (readTVar fc.fakePoke >>= check >> writeTVar fc.fakePoke False >> pure Poked)+            atomically (writeTVar fc.fakeSleeping Nothing)+            pure wake+        }++advanceTo :: FakeClock -> Int -> IO ()+advanceTo fc t = atomically (writeTVar fc.fakeNow t)++-- | Wait for the fetcher to be asleep until exactly this deadline — which+-- asserts its schedule at the same time.+awaitSleep :: FakeClock -> Int -> IO ()+awaitSleep fc t = waitFor ("the fetcher to wait until " <> show t) ((== Just t) <$> readTVarIO fc.fakeSleeping)++-------------------------------------------------------------------------------+-- driving the loop++data Driver = Driver+    { typeLine :: String -> IO ()+    , serveReports :: IO [Serve.Report]+    , followReports :: IO [Follow.Report]+    , clock :: FakeClock+    }++-- | A registry the test can make throw, which records the fake time of+-- every call.+data Flaky = Flaky+    { flakyFailing :: IORef Bool+    , flakyCalls :: IORef [Int]+    }++newFlaky :: IO Flaky+newFlaky = Flaky <$> newIORef False <*> newIORef []++flakyRegistry :: Flaky -> FakeClock -> Follow.Registry -> Follow.Registry+flakyRegistry fl fc inner =+    inner+        { Follow.registryFetch = \lbl stamp -> do+            now <- readTVarIO fc.fakeNow+            modifyIORef' fl.flakyCalls (now :)+            failing <- readIORef fl.flakyFailing+            if failing+                then throwIO (userError "registry unreachable")+                else Follow.registryFetch inner lbl stamp+        }++withFollowing :: FilePath -> Config -> Flaky -> [Label] -> (Driver -> IO a) -> IO (World Spec Spec, [Serve.Report], [Follow.Report], a)+withFollowing root schedule fl labels body = do+    (serveReporter, readServe) <- capture+    (followReporter, readFollow) <- capture+    (nodeReporter, _) <- capture :: IO (Reporter (UpDown.Report Extension), IO [UpDown.Report Extension])+    stdinChan <- newTChanIO+    gate <- newEmptyMVar+    fc <- newFakeClock+    modeVar <- Follow.newMode+    appliedVar <- Follow.newApplied+    let follow =+            Follow.Follow+                { Follow.followRegistry = flakyRegistry fl fc (Follow.directoryRegistry (registryDir root))+                , Follow.followLabels = labels+                , Follow.followSchedule = schedule+                , Follow.followCache = Nothing+                , Follow.followRefuseOlder = False+                , Follow.followVerify = Follow.noVerifier+                }+        producers =+            [ Follow.followerWith followReporter (clockOf fc) (Scheduler.mkRng 1) modeVar appliedVar follow (putMVar gate ())+            , Follow.gated gate (chanProducer stdinChan)+            ]+        driver =+            Driver+                { typeLine = \l -> atomically (writeTChan stdinChan (Just l))+                , serveReports = readServe+                , followReports = readFollow+                , clock = fc+                }+    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 (Serve.Followed (atomically (writeTVar fc.fakePoke True)) (readIORef modeVar) (Follow.appliedDocuments 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"++label :: Text -> Label+label t = either (error . Text.unpack) id (Follow.mkLabel t)++publish :: FilePath -> Label -> Text -> [[String]] -> IO ()+publish root lbl did seeds = do+    createDirectoryIfMissing True (registryDir root)+    LByteString.writeFile (Follow.documentPath (registryDir root) lbl) (encode (Document did (fmap SeedWords seeds) 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 5000 >> go++fileExists :: FilePath -> String -> IO Bool+fileExists root n = doesFileExist (root </> "files" </> n)++convergences :: [Serve.Report] -> Int+convergences reports = length [() | Serve.ConvergeStop{} <- reports]++injections :: [Follow.Report] -> [(Int, Int)]+injections reports = [(nup, ndown) | Follow.Injected _ _ _ nup ndown <- reports]++-------------------------------------------------------------------------------++-- | Rounds every 2000, a window of 5000, so a change is seen by up to+-- three rounds before the window closes.+windowed :: Config+windowed = Config{schedBase = 2000, schedFactor = 2, schedCap = 100000, schedJitter = 0, schedDebounce = 5000, schedMaxWait = 60000}++threeWritesOnePass :: IO ()+threeWritesOnePass =+    withTempDir $ \root -> do+        fl <- newFlaky+        publish root (label "web") "web@1" [["a"]]+        (w, reports, freports, ()) <- withFollowing root windowed fl [label "web"] $ \d -> do+            let fc = d.clock+            waitFor "the startup document's file" (fileExists root "a")+            awaitSleep fc 2000+            -- three writes, each seen by its own round, each inside the window+            publish root (label "web") "web@2" [["a"], ["b"]]+            advanceTo fc 2000+            awaitSleep fc 4000+            publish root (label "web") "web@3" [["a"], ["b"], ["c"]]+            advanceTo fc 4000+            awaitSleep fc 6000+            publish root (label "web") "web@4" [["a"], ["b"], ["c"], ["d"]]+            advanceTo fc 6000+            awaitSleep fc 8000+            -- two quiet rounds; the window (6000 + 5000) closes before the next+            advanceTo fc 8000+            awaitSleep fc 10000+            advanceTo fc 10000+            awaitSleep fc 11000+            nothingYet <- not <$> fileExists root "b"+            assertBool "nothing injected while the window is open" nothingYet+            deferred <- length . filter isDeferred <$> d.followReports+            assertEqual "each round that saw a change said so" 3 deferred+            advanceTo fc 11000+            waitFor "the three files" (and <$> traverse (fileExists root) ["b", "c", "d"])+            awaitSleep fc 12000+        assertEqual "two injections in all: startup, then the one batch, diffed against web@1" [(1, 0), (3, 0)] (injections freports)+        assertEqual "the batch names the latest document" ["web@1", "web@4"] [did | Follow.Injected _ did _ _ _ <- freports]+        assertEqual "one convergence for the batch" 2 (convergences reports)+        assertBool "everything converged up" (all (\st -> st.nodeConvergence == Converged) (Map.elems w.worldNodes))+  where+    isDeferred Follow.Deferred{} = True+    isDeferred _ = False++-- | Rounds every 1000, doubling to a cap of 4000, nothing held back.+laddered :: Config+laddered = Config{schedBase = 1000, schedFactor = 2, schedCap = 4000, schedJitter = 0, schedDebounce = 0, schedMaxWait = 0}++failingRegistryOnTheLadder :: IO ()+failingRegistryOnTheLadder =+    withTempDir $ \root -> do+        fl <- newFlaky+        publish root (label "web") "web@1" [["a"]]+        (_, _, freports, ()) <- withFollowing root laddered fl [label "web"] $ \d -> do+            let fc = d.clock+            waitFor "the startup document's file" (fileExists root "a")+            awaitSleep fc 1000+            writeIORef fl.flakyFailing True+            advanceTo fc 1000+            awaitSleep fc 2000 -- first failure: base+            advanceTo fc 2000+            awaitSleep fc 4000 -- second: base * 2+            advanceTo fc 4000+            awaitSleep fc 8000 -- third: base * 4+            advanceTo fc 8000+            awaitSleep fc 12000 -- fourth: capped+            writeIORef fl.flakyFailing False+            publish root (label "web") "web@2" [["a"], ["b"]]+            advanceTo fc 12000+            waitFor "the recovered round's file" (fileExists root "b")+            awaitSleep fc 13000 -- back to the base+            calls <- reverse <$> readIORef fl.flakyCalls+            assertEqual "the registry was asked on the ladder" [0, 1000, 2000, 4000, 8000, 12000] calls+        assertEqual "the failure was reported once, not once per round" 1 (length [() | Follow.FetchFailed{} <- freports])+        assertEqual "each failed round said how long until the next" [(1, 1000), (2, 2000), (3, 4000), (4, 4000)] [(n, us) | Follow.Backoff n us <- freports]+        assertEqual "the recovered round's document was injected" [(1, 0), (1, 0)] (injections freports)++fetchCommand :: IO ()+fetchCommand =+    withTempDir $ \root -> do+        fl <- newFlaky+        publish root (label "web") "web@1" [["a"]]+        let schedule = laddered{schedCap = 100000, schedDebounce = 5000, schedMaxWait = 100000}+        (_, reports, freports, ()) <- withFollowing root schedule fl [label "web"] $ \d -> do+            let fc = d.clock+            waitFor "the startup document's file" (fileExists root "a")+            awaitSleep fc 1000+            -- a change seen, waiting for its window+            publish root (label "web") "web@2" [["a"], ["b"]]+            advanceTo fc 1000+            awaitSleep fc 2000+            nothingYet <- not <$> fileExists root "b"+            assertBool "held back by the window" nothingYet+            -- `fetch`: the pending batch goes in without the window+            d.typeLine "fetch"+            waitFor "the flushed file" (fileExists root "b")+            -- now three failures deep+            writeIORef fl.flakyFailing True+            advanceTo fc 2000+            awaitSleep fc 3000+            advanceTo fc 3000+            awaitSleep fc 5000+            advanceTo fc 5000+            awaitSleep fc 9000+            writeIORef fl.flakyFailing False+            publish root (label "web") "web@3" [["a"], ["b"], ["c"]]+            -- `fetch`: a round now rather than at 9000, its change applied+            -- at once, and the next round one base away rather than+            -- further up the ladder+            d.typeLine "fetch"+            waitFor "the fetched file" (fileExists root "c")+            awaitSleep fc 6000+            calls <- reverse <$> readIORef fl.flakyCalls+            assertEqual "the rounds `fetch` asked for ran when typed" [0, 1000, 1000, 2000, 3000, 5000, 5000] calls+        assertEqual "the loop acknowledged both" [True, True] [f | Serve.FetchRequested f <- reports]+        assertEqual "three injections: startup, flushed, fetched" [(1, 0), (1, 0), (1, 0)] (injections freports)+        assertEqual "one convergence each" 3 (convergences reports)++-------------------------------------------------------------------------------++fetchParses :: IO ()+fetchParses = do+    assertEqual "fetch" (Right Serve.Fetch) (Serve.parseServeCommand "fetch")+    assertBool "fetch takes no argument" (either (const True) (const False) (Serve.parseServeCommand "fetch now"))+    assertBool "the reference lists it" (any (Text.isInfixOf "fetch") (Serve.renderReport (Serve.HelpText Nothing)))+    assertBool "and it has a topic" (any (Text.isInfixOf "quiet window") (Serve.renderReport (Serve.HelpText (Just "fetch"))))++fetchNothingFollowed :: IO ()+fetchNothingFollowed =+    withTempDir $ \root -> do+        (serveReporter, readServe) <- capture+        (nodeReporter, _) <- capture :: IO (Reporter (UpDown.Report Extension), IO [UpDown.Report Extension])+        stdinChan <- newTChanIO+        atomically (writeTChan stdinChan (Just "fetch"))+        atomically (writeTChan stdinChan Nothing)+        _ <- Serve.serveProducers [] Nothing True serveReporter nodeReporter (parseSpec root) (Configure pure) program [chanProducer stdinChan]+        reports <- readServe+        assertEqual "nothing is being followed" [False] [f | Serve.FetchRequested f <- reports]
+ test/Test/FollowSignatureSpec.hs view
@@ -0,0 +1,578 @@+{-# LANGUAGE DeriveGeneric #-}++{- | Signed documents (the "Signed documents" section of @specs/pull-mode.md@):+"Salmon.Actions.Follow.Signature" at Layer 0 — the envelope, its+canonicalisation, and every refusal with its reason — and at Layer 1 the+verifier in a following loop over a directory registry with a cache: a+signed document is applied, a tampered one is refused and never cached, and+the cache written by the good one replays through the verifier, so that+swapping the host's key refuses it too.++Keys are generated here, in the test, and never touch the working tree.+-}+module Test.FollowSignatureSpec (tests) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar (newEmptyMVar, putMVar)+import Control.Monad (forM_)+import Control.Concurrent.STM (TChan, atomically, newTChanIO, readTChan, writeTChan)+import Control.Exception (SomeException, throwIO, try)+import Data.Aeson (FromJSON, ToJSON, Value (..), eitherDecode, encode)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as LByteString+import Data.List (sortOn)+import qualified Data.Map.Strict as Map+import Data.Ord (Down (..))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Foldable (toList)+import GHC.Generics (Generic)+import System.Directory (createDirectoryIfMissing, doesFileExist, 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.Follow.Signature as Signature+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.Signature"+        [ testGroup+            "Layer 0: the envelope"+            [ testCase "sign then verify: the inner document comes back, canonical, and parses as the document signed" roundTrip+            , testCase "a document altered inside its envelope is refused, and the reason says so" tampered+            , testCase "a document signed by a key the host does not hold is refused, naming the unknown key" unknownKey+            , testCase "one of several keys suffices, whichever order they are given in" severalKeys+            , testCase "an unsigned document under a key is refused as unsigned" unsignedUnderKey+            , testCase "an envelope re-serialised with other key order and whitespace still verifies, to the same bytes" reserialised+            , testCase "no signatures, an envelope that does not parse, `none`, and a key file that is not one: each refused with its reason" refusals+            , testCase "the key id is the public key's SHA-256 thumbprint, the same from either half of the pair" keyIds+            ]+        , testGroup+            "Layer 0: a signature is worth something only at the address it was signed for"+            [ testCase "a document signed for canary is refused at prod, naming both labels; at canary it is accepted" labelMismatch+            , testCase "a key bound to canary does not verify a prod document, and the reason says the key may not speak there" keyBoundToLabel+            , testCase "a bare key speaks for any label; a key bound to two labels speaks for both" bareAndMultiKeys+            , testCase "a signed document naming no label is refused by default, and accepted under the migration policy" legacyUnlabelled+            , testCase "the label is inside what is signed: rewriting it in the envelope breaks the signature" labelIsSigned+            , testCase "signing refuses a document that already names another label, and keeps the same one" signRefusesOtherLabel+            , testCase "--follow-key arguments: FILE, LABEL=FILE, and a path containing an = stays a path" keySpecs+            ]+        , testCase "Layer 1: a document validly signed for canary and planted at prod's address is refused, at fetch and on cache replay, and never applied" plantedAtOtherLabel+        , testCase "Layer 1: a signed document is applied through a directory registry; a tampered one is refused and never cached; the cache replays through the verifier, and a swapped key refuses it" followingSigned+        ]++-------------------------------------------------------------------------------+-- Layer 0++-- | A document naming these seeds, as bytes — a publisher's own spelling+-- (pretty-ish, keys in the order a human writes them), not aeson's.+document :: Text -> [[String]] -> ByteString+document did seeds =+    LByteString.fromStrict . Text.encodeUtf8 $+        "{ \"salmon\": 1,\n  \"id\": " <> quote did <> ",\n  \"seeds\": [" <> Text.intercalate ", " (fmap seed seeds) <> "],\n  \"note\": \"a publisher's annotation\" }\n"+  where+    seed ws = "{\"seed\": [" <> Text.intercalate ", " (fmap (quote . Text.pack) ws) <> "]}"+    quote t = Text.decodeUtf8 (LByteString.toStrict (encode (String t)))++sign :: Signature.PrivateKey -> ByteString -> IO ByteString+sign key bytes = do+    signed <- Signature.signDocument key bytes+    either (assertFailure . ("signing failed: " <>) . Text.unpack) pure signed++-- | Signed for a label: the document names it, inside what is signed.+signFor :: Signature.PrivateKey -> Text -> ByteString -> IO ByteString+signFor key lbl bytes = do+    signed <- Signature.signDocumentFor key (Just (label lbl)) bytes+    either (assertFailure . ("signing failed: " <>) . Text.unpack) pure signed++-- | Every key speaks for every label; unlabelled documents refused.+anyLabel :: [Signature.PublicKey] -> [Signature.TrustedKey]+anyLabel = fmap Signature.trustsAnyLabel++-- | Rewrite the @document@ member of an envelope, keeping everything else.+withDocument :: (Value -> Value) -> ByteString -> ByteString+withDocument f envelope = case eitherDecode envelope of+    Right (Object o) -> encode (Object (KeyMap.mapWithKey (\k v -> if k == "document" then f v else v) o))+    _ -> error "not an envelope"++-- | Give the document another id: a content change a signature must catch.+retitle :: Text -> Value -> Value+retitle did (Object o) = Object (KeyMap.insert "id" (String did) o)+retitle _ v = v++parsed :: ByteString -> Document+parsed bytes = either (error . ("document does not parse: " <>)) id (eitherDecode bytes)++expectLeft :: String -> Text -> Either Text a -> IO ()+expectLeft what needle verdict = case verdict of+    Right _ -> assertFailure (what <> ": accepted, expected a refusal mentioning " <> show needle)+    Left why -> assertBool (what <> ": the reason " <> show why <> " does not mention " <> show needle) (needle `Text.isInfixOf` why)++roundTrip :: IO ()+roundTrip = do+    key <- Signature.generateKeyPair+    let pub = Signature.publicKey key+        original = document "web@1" [["a"], ["b", "--flag"]]+    envelope <- sign key original+    -- the envelope is what a host fetches; it is not the document+    assertBool "the envelope is not the document" (envelope /= original)+    case Signature.verifyEnvelope [pub] envelope of+        Left why -> assertFailure ("refused: " <> Text.unpack why)+        Right inner -> do+            assertEqual "the inner document is the canonical form of what was signed" (encodeCanonical original) inner+            assertEqual "and parses as the document" (parsed original) (parsed inner)+            assertEqual "seeds intact" [SeedWords ["a"], SeedWords ["b", "--flag"]] (parsed inner).docSeeds+  where+    encodeCanonical bytes = case eitherDecode bytes :: Either String Value of+        Right v -> Signature.canonicalBytes v+        Left err -> error err++tampered :: IO ()+tampered = do+    key <- Signature.generateKeyPair+    envelope <- sign key (document "web@1" [["a"]])+    let evil = withDocument (retitle "web@evil") envelope+    -- the tampered envelope still parses as an envelope, so the refusal is+    -- the signature's, not the parser's+    expectLeft "tampered" "does not verify" (Signature.verifyEnvelope [Signature.publicKey key] evil)+    expectLeft "tampered" "altered after signing" (Signature.verifyEnvelope [Signature.publicKey key] evil)++unknownKey :: IO ()+unknownKey = do+    signer <- Signature.generateKeyPair+    other <- Signature.generateKeyPair+    envelope <- sign signer (document "web@1" [["a"]])+    let verdict = Signature.verifyEnvelope [Signature.publicKey other] envelope+    expectLeft "unknown key" "names no configured key" verdict+    expectLeft "unknown key" (Text.take 12 (Signature.keyId (Signature.publicKey signer))) verdict+    expectLeft "unknown key" "1 configured key" verdict++severalKeys :: IO ()+severalKeys = do+    k1 <- Signature.generateKeyPair+    k2 <- Signature.generateKeyPair+    k3 <- Signature.generateKeyPair+    envelope <- sign k2 (document "web@1" [["a"]])+    let pubs = fmap Signature.publicKey [k1, k2, k3]+    assertBool "k2 among three accepts" (either (const False) (const True) (Signature.verifyEnvelope pubs envelope))+    assertBool "in any order" (either (const False) (const True) (Signature.verifyEnvelope (reverse pubs) envelope))+    expectLeft "without k2" "2 configured key" (Signature.verifyEnvelope (fmap Signature.publicKey [k1, k3]) envelope)++unsignedUnderKey :: IO ()+unsignedUnderKey = do+    key <- Signature.generateKeyPair+    let verdict = Signature.verifyEnvelope [Signature.publicKey key] (document "web@1" [["a"]])+    expectLeft "unsigned" "unsigned document" verdict+    expectLeft "unsigned" "--follow-key" verdict++reserialised :: IO ()+reserialised = do+    key <- Signature.generateKeyPair+    let pub = Signature.publicKey key+    envelope <- sign key (document "web@1" [["a", "--n", "1"], ["b"]])+    let other = rerender envelope+    assertBool "the rendering differs" (other /= envelope)+    assertBool "and is still JSON with the same content" (eitherDecode other == (eitherDecode envelope :: Either String Value))+    case (Signature.verifyEnvelope [pub] envelope, Signature.verifyEnvelope [pub] other) of+        (Right a, Right b) -> assertEqual "both verify to the same inner bytes" a b+        (a, b) -> assertFailure ("expected both to verify: " <> show (a, b))++{- | The same JSON value with every object's keys in /descending/ order,+spaces everywhere aeson puts none, and a trailing newline: what a+pretty-printer, a proxy or a registry written in another language might+turn an envelope into. -}+rerender :: ByteString -> ByteString+rerender bytes = case eitherDecode bytes of+    Left err -> error err+    Right v -> LByteString.fromStrict (Text.encodeUtf8 (go v)) <> "\n"+  where+    go :: Value -> Text+    go (Object o) =+        "{ " <> Text.intercalate " , " [quoteKey k <> " : " <> go x | (k, x) <- sortOn (Down . fst) (KeyMap.toList o)] <> " }"+    go (Array xs) = "[ " <> Text.intercalate " , " (fmap go (toList xs)) <> " ]"+    go scalar = Text.decodeUtf8 (LByteString.toStrict (encode scalar))+    quoteKey k = go (String (Key.toText k))++refusals :: IO ()+refusals = withTempDir $ \dir -> do+    key <- Signature.generateKeyPair+    let pub = Signature.publicKey key+        envelopeWith :: Text -> ByteString+        envelopeWith sigs = LByteString.fromStrict (Text.encodeUtf8 ("{\"salmon-signed\": 1, \"document\": {}, \"signatures\": " <> sigs <> "}"))+    expectLeft "no signatures" "carries no signatures" (Signature.verifyEnvelope [pub] (envelopeWith "[]"))+    expectLeft "signatures not a list" "does not parse" (Signature.verifyEnvelope [pub] (envelopeWith "\"nope\""))+    expectLeft "a signature without its key" "does not parse" (Signature.verifyEnvelope [pub] (envelopeWith "[{\"alg\": \"EdDSA\", \"sig\": \"\"}]"))+    expectLeft "not JSON" "not even JSON" (Signature.verifyEnvelope [pub] "{{{")+    expectLeft "another version" "does not parse" (Signature.verifyEnvelope [pub] "{\"salmon-signed\": 2, \"document\": {}, \"signatures\": []}")+    -- `none` with an empty signature is what jose's own `verify` would+    -- accept; the verifier must not hand it that+    let none = envelopeWith ("[{\"key\": \"" <> Signature.keyId pub <> "\", \"alg\": \"none\", \"sig\": \"\"}]")+    expectLeft "alg none" "no public key can verify" (Signature.verifyEnvelope [pub] none)+    -- an HMAC named by the key id: same refusal, a public key has no secret+    let hmac = envelopeWith ("[{\"key\": \"" <> Signature.keyId pub <> "\", \"alg\": \"HS256\", \"sig\": \"AAAA\"}]")+    expectLeft "alg HS256" "no public key can verify" (Signature.verifyEnvelope [pub] hmac)+    -- no key at all refuses rather than accepts+    envelope <- sign key (document "web@1" [["a"]])+    expectLeft "no keys" "no signing key" (Signature.verifyEnvelope [] envelope)+    -- key files+    LByteString.writeFile (dir </> "garbage") "not a key\n"+    badFile <- Signature.readPublicKeyFile (dir </> "garbage")+    expectLeft "not a JWK" "not a JWK" (() <$ badFile)+    missing <- Signature.readPublicKeyFile (dir </> "absent")+    expectLeft "missing file" "absent" (() <$ missing)+    Signature.writeKeyPair (dir </> "k") key+    onlyPublic <- Signature.readPrivateKeyFile (dir </> "k.pub")+    expectLeft "the public half cannot sign" "no private material" (() <$ onlyPublic)++keyIds :: IO ()+keyIds = withTempDir $ \dir -> do+    key <- Signature.generateKeyPair+    Signature.writeKeyPair (dir </> "k") key+    fromPrivate <- Signature.readPublicKeyFile (dir </> "k")+    fromPublic <- Signature.readPublicKeyFile (dir </> "k.pub")+    case (fromPrivate, fromPublic) of+        (Right a, Right b) -> do+            assertEqual "the same public key from either file" a b+            assertEqual "the same id" (Signature.keyId a) (Signature.keyId (Signature.publicKey key))+            assertEqual "64 hex characters" 64 (Text.length (Signature.keyId a))+            assertBool "hex" (Text.all (`elem` ("0123456789abcdef" :: String)) (Signature.keyId a))+        other -> assertFailure ("could not read the pair back: " <> show other)+    another <- Signature.generateKeyPair+    assertBool "two keys, two ids" (Signature.keyId (Signature.publicKey another) /= Signature.keyId (Signature.publicKey key))++-------------------------------------------------------------------------------+-- Layer 1: the served thing and the loop, same harness as Test.FollowRegistrySpec++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-signature-root" (deps (fmap (fileOp spec.specDir) spec.specNames)) $ \actions ->+        actions{ref = mkRef "follow-signature-root" (spec.specDir, spec.specNames)}++fileOp :: FilePath -> String -> Op+fileOp d n = FS.filecontents (FS.FileContents (d </> n) ("contents of " <> n))++data Driver = Driver+    { typeLine :: String -> IO ()+    , serveReports :: IO [Serve.Report]+    , followReports :: IO [Follow.Report]+    }++interval :: Int+interval = 100000++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+        }++withFollowing :: FilePath -> FilePath -> Follow.Verifier -> [Label] -> (Driver -> IO a) -> IO (World Spec Spec, [Serve.Report], [Follow.Report], a)+withFollowing root reg verifier 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 reg+                , Follow.followLabels = labels+                , Follow.followSchedule = schedule+                , Follow.followCache = Just (root </> "cache")+                , Follow.followRefuseOlder = False+                , Follow.followVerify = verifier+                }+        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+                }+    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++label :: Text -> Label+label t = either (error . Text.unpack) id (Follow.mkLabel t)++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]++rejections :: [Follow.Report] -> [(Follow.Digest, Text)]+rejections reports = [(dg, why) | Follow.Rejected _ dg why <- reports]++allConvergedUp :: World seed directive -> Bool+allConvergedUp w = not (Map.null w.worldNodes) && all (\st -> st.nodeDirection == TurnUp && st.nodeConvergence == Converged) (Map.elems w.worldNodes)++followingSigned :: IO ()+followingSigned =+    withTempDir $ \root -> do+        key <- Signature.generateKeyPair+        other <- Signature.generateKeyPair+        let web = label "web"+            reg = root </> "reg"+            cache = root </> "cache"+            verifier = Signature.signedVerifier Signature.RefuseUnlabelled (anyLabel [Signature.publicKey key])+            publish bytes = createDirectoryIfMissing True reg >> LByteString.writeFile (Follow.documentPath reg web) bytes+        good <- signFor key "web" (document "web@1" [["a"]])+        let evil = withDocument (retitle "web@evil") good+        publish good+        (w, _, freports, good2) <- withFollowing root reg verifier [web] $ \d -> do+            waitFor "the file" (fileExists root "a")+            -- the tampered envelope: refused, never applied, never cached+            publish evil+            waitFor "the refusal" (not . null . rejections <$> d.followReports)+            threadDelay (2 * interval)+            declared <- (\rs -> [() | Serve.Declared{} <- rs]) <$> d.serveReports+            assertEqual "one declaration, the signed document's" 1 (length declared)+            cached <- Follow.readCacheEntry cache web+            assertEqual "the cache still holds the signed document, envelope and all" (Right (Just ("web@1", Follow.digestOf good, good))) (fmap (fmap (\c -> (c.cachedId, c.cachedDigest, c.cachedBytes))) cached)+            -- and a good document again is applied on top+            good2 <- signFor key "web" (document "web@2" [["a"], ["b"]])+            publish good2+            waitFor "the next file" (fileExists root "b")+            pure good2+        case rejections freports of+            [(dg, why)] -> do+                assertBool ("the one refusal is the signature's: " <> Text.unpack why) ("does not verify" `Text.isInfixOf` why)+                assertEqual "and it names the envelope's digest, the bytes as fetched" (Follow.digestOf evil) dg+            rs -> assertFailure ("expected exactly one refusal, got " <> show rs)+        assertEqual "two injections" [(1, 0), (1, 0)] (injections freports)+        assertBool "the world converged" (allConvergedUp w)+        -- what the fetcher records is the document's id, from inside the+        -- envelope+        assertEqual "the injections name the documents' ids" ["web@1", "web@2"] [did | Follow.Injected _ did _ _ _ <- freports]+        -- the registry goes away: the cache replays through the same key+        renameDirectory reg (reg <> ".away")+        renameDirectory (root </> "files") (root </> "files.away")+        (w2, _, freports2, ()) <- withFollowing root reg verifier [web] $ \_ ->+            waitFor "the files, rebuilt from the cache" ((&&) <$> fileExists root "a" <*> fileExists root "b")+        assertEqual "replayed, once" ["web@2"] [did | Follow.Replayed _ did _ <- freports2]+        assertEqual "nothing refused" [] (rejections freports2)+        assertBool "the replayed world converged" (allConvergedUp w2)+        -- the host's key is swapped: the same cache entry is refused on replay+        renameDirectory (root </> "files") (root </> "files.away2")+        (_, sreports3, freports3, ()) <- withFollowing root reg (Signature.signedVerifier Signature.RefuseUnlabelled (anyLabel [Signature.publicKey other])) [web] $ \d -> do+            waitFor "the refusal" (not . null . rejections <$> d.followReports)+            threadDelay (2 * interval)+        assertEqual "nothing replayed" [] [() | Follow.Replayed{} <- freports3]+        assertEqual "nothing declared" [] [() | Serve.Declared{} <- sreports3]+        present <- fileExists root "a"+        assertBool "nothing rebuilt" (not present)+        case rejections freports3 of+            [(dg, why)] -> do+                assertBool ("the refusal names the unknown key: " <> Text.unpack why) ("names no configured key" `Text.isInfixOf` why)+                assertEqual "the refusal names the cache entry's digest, the last good envelope's" (Follow.digestOf good2) dg+            rs -> assertFailure ("expected exactly one refusal, got " <> show rs)++-------------------------------------------------------------------------------+-- labels++verdictFor :: Signature.Legacy -> [Signature.TrustedKey] -> Text -> ByteString -> Either Text ByteString+verdictFor legacy keys lbl = Signature.verifyEnvelopeFor legacy keys (label lbl)++labelMismatch :: IO ()+labelMismatch = do+    key <- Signature.generateKeyPair+    let keys = anyLabel [Signature.publicKey key]+    canary <- signFor key "canary" (document "web@1" [["a"]])+    assertBool "accepted at the label it was signed for" (either (const False) (const True) (verdictFor Signature.RefuseUnlabelled keys "canary" canary))+    case verdictFor Signature.RefuseUnlabelled keys "prod" canary of+        Right _ -> assertFailure "a canary document was accepted at prod"+        Left why -> do+            assertBool ("names the label it was signed for: " <> Text.unpack why) ("signed for label canary" `Text.isInfixOf` why)+            assertBool ("names the label it was fetched for: " <> Text.unpack why) ("fetched for label prod" `Text.isInfixOf` why)++keyBoundToLabel :: IO ()+keyBoundToLabel = do+    canaryKey <- Signature.generateKeyPair+    prodKey <- Signature.generateKeyPair+    let keys =+            [ Signature.trustsOnly (label "canary") (Signature.publicKey canaryKey)+            , Signature.trustsOnly (label "prod") (Signature.publicKey prodKey)+            ]+    fromCanaryKey <- signFor canaryKey "prod" (document "web@1" [["a"]])+    -- the document even names prod, but the key that signed it may not speak there+    expectLeft "canary's key at prod" "may not speak for label prod" (verdictFor Signature.RefuseUnlabelled keys "prod" fromCanaryKey)+    fromProdKey <- signFor prodKey "prod" (document "web@1" [["a"]])+    assertBool "prod's key at prod" (either (const False) (const True) (verdictFor Signature.RefuseUnlabelled keys "prod" fromProdKey))+    expectLeft "a label no key speaks for" "no signing key" (verdictFor Signature.RefuseUnlabelled keys "staging" fromProdKey)++bareAndMultiKeys :: IO ()+bareAndMultiKeys = do+    bare <- Signature.generateKeyPair+    two <- Signature.generateKeyPair+    let keys =+            [ Signature.trustsAnyLabel (Signature.publicKey bare)+            , Signature.TrustedKey (Signature.publicKey two) (Just [label "a", label "b"])+            ]+    forM_ ["a", "b", "c"] $ \l -> do+        d <- signFor bare l (document "web@1" [["x"]])+        assertBool ("bare key at " <> Text.unpack l) (either (const False) (const True) (verdictFor Signature.RefuseUnlabelled keys l d))+    forM_ ["a", "b"] $ \l -> do+        d <- signFor two l (document "web@1" [["x"]])+        assertBool ("two-label key at " <> Text.unpack l) (either (const False) (const True) (verdictFor Signature.RefuseUnlabelled keys l d))+    dc <- signFor two "c" (document "web@1" [["x"]])+    expectLeft "two-label key at c" "may not speak for label c" (verdictFor Signature.RefuseUnlabelled keys "c" dc)++legacyUnlabelled :: IO ()+legacyUnlabelled = do+    key <- Signature.generateKeyPair+    let keys = anyLabel [Signature.publicKey key]+    old <- sign key (document "web@1" [["a"]])+    expectLeft "unlabelled, by default" "names no label" (verdictFor Signature.RefuseUnlabelled keys "prod" old)+    expectLeft "and the reason says how to migrate" "--follow-accept-unlabelled" (verdictFor Signature.RefuseUnlabelled keys "prod" old)+    assertBool "accepted under the migration policy" (either (const False) (const True) (verdictFor Signature.AcceptUnlabelled keys "prod" old))+    -- the flag does not weaken a document that does name a label+    canary <- signFor key "canary" (document "web@1" [["a"]])+    expectLeft "a mismatch under the migration policy" "signed for label canary" (verdictFor Signature.AcceptUnlabelled keys "prod" canary)++labelIsSigned :: IO ()+labelIsSigned = do+    key <- Signature.generateKeyPair+    let keys = anyLabel [Signature.publicKey key]+    canary <- signFor key "canary" (document "web@1" [["a"]])+    -- what a registry that can write but not sign would try: relabel the document+    let relabelled = withDocument (\v -> case v of Object o -> Object (KeyMap.insert "label" (String "prod") o); other -> other) canary+    expectLeft "relabelled in the envelope" "does not verify" (verdictFor Signature.RefuseUnlabelled keys "prod" relabelled)++signRefusesOtherLabel :: IO ()+signRefusesOtherLabel = do+    key <- Signature.generateKeyPair+    canary <- signFor key "canary" (document "web@1" [["a"]])+    -- sign the labelled document's own bytes again for another label+    let inner = case eitherDecode canary of+            Right (Object o) | Just d <- KeyMap.lookup "document" o -> encode d+            _ -> error "not an envelope"+    refused <- Signature.signDocumentFor key (Just (label "prod")) inner+    case refused of+        Left why -> assertBool ("names both: " <> Text.unpack why) ("prod" `Text.isInfixOf` why)+        Right _ -> assertFailure "re-signed a canary document for prod"+    same <- Signature.signDocumentFor key (Just (label "canary")) inner+    assertBool "the same label is fine" (either (const False) (const True) same)++keySpecs :: IO ()+keySpecs = do+    assertEqual "bare" (Right (Nothing, "keys/a.pub")) (Signature.parseKeySpec "keys/a.pub")+    assertEqual "labelled" (Right (Just (label "canary"), "keys/a.pub")) (Signature.parseKeySpec "canary=keys/a.pub")+    assertEqual "a path containing = stays a path" (Right (Nothing, "keys/a=b.pub")) (Signature.parseKeySpec "keys/a=b.pub")+    assertBool "a bad label is refused" (either (const True) (const False) (Signature.parseKeySpec "bad label=keys/a.pub"))++-- | The attack, end to end: a document validly signed for `canary` is copied+-- to `prod`'s address. Refused as fetched, and refused again when it sits in+-- the cache and is replayed; nothing is declared and nothing is built.+plantedAtOtherLabel :: IO ()+plantedAtOtherLabel =+    withTempDir $ \root -> do+        key <- Signature.generateKeyPair+        let prod = label "prod"+            reg = root </> "reg"+            cache = root </> "cache"+            verifier = Signature.signedVerifier Signature.RefuseUnlabelled (anyLabel [Signature.publicKey key])+            publish bytes = createDirectoryIfMissing True reg >> LByteString.writeFile (Follow.documentPath reg prod) bytes+        forCanary <- signFor key "canary" (document "canary@1" [["a"]])+        publish forCanary+        (_, sreports, freports, ()) <- withFollowing root reg verifier [prod] $ \d -> do+            waitFor "the refusal" (not . null . rejections <$> d.followReports)+            threadDelay (2 * interval)+        assertEqual "nothing declared" [] [() | Serve.Declared{} <- sreports]+        present <- fileExists root "a"+        assertBool "nothing built" (not present)+        case rejections freports of+            [(dg, why)] -> do+                assertEqual "it names the envelope's digest" (Follow.digestOf forCanary) dg+                assertBool ("naming both labels: " <> Text.unpack why) ("signed for label canary" `Text.isInfixOf` why && "fetched for label prod" `Text.isInfixOf` why)+            rs -> assertFailure ("expected exactly one refusal, got " <> show rs)+        -- the same bytes as a cache entry for prod, read back through the same verifier+        forProd <- signFor key "prod" (document "prod@1" [["b"]])+        publish forProd+        (_, _, freports2, ()) <- withFollowing root reg verifier [prod] $ \_ ->+            waitFor "the file" (fileExists root "b")+        assertEqual "the properly labelled document is applied" ["prod@1"] [did | Follow.Injected _ did _ _ _ <- freports2]+        -- now plant the canary envelope as prod's cache entry, with the registry gone+        renameDirectory reg (reg <> ".away")+        renameDirectory (root </> "files") (root </> "files.away")+        Follow.writeCache cache prod (Follow.Cached "canary@1" (Follow.digestOf forCanary) forCanary)+        (_, sreports3, freports3, ()) <- withFollowing root reg verifier [prod] $ \d -> do+            waitFor "the refusal on replay" (not . null . rejections <$> d.followReports)+            threadDelay (2 * interval)+        assertEqual "nothing replayed" [] [() | Follow.Replayed{} <- freports3]+        assertEqual "nothing declared on replay" [] [() | Serve.Declared{} <- sreports3]+        present2 <- fileExists root "b"+        assertBool "nothing rebuilt from the planted cache entry" (not present2)
+ test/Test/FollowSpec.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE DeriveGeneric #-}++{- | Layer 1 coverage for "Salmon.Actions.Follow": a @run serve@ following a+directory registry over a throwaway temp dir, with the loop's standard input+driven from a channel the test writes into.++The seed is 'Test.ServeSpec''s (a list of file names under the temp dir); what+is under test is the fetcher — that a document written to the registry+becomes the world, that rewriting it byte-for-byte injects /nothing/ (the+starvation rule of @specs/pull-mode.md@, as a test), that a seed dropped from+a document goes down unless another label still carries it, and that a+document that cannot be read, or a seed in it that cannot be configured, is+reported without ending the loop.+-}+module Test.FollowSpec (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, eitherDecode, encode, toJSON)+import qualified Data.ByteString.Lazy as LByteString+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import Data.Time (UTCTime)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import System.Directory (createDirectoryIfMissing, doesFileExist)+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 (..), 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"+        [ testCase "a document written to the registry becomes the world, before stdin is read" documentBecomesTheWorld+        , testCase "rewriting the same bytes injects nothing (the starvation rule)" identicalRewriteInjectsNothing+        , testCase "a seed dropped from the document goes down" droppedSeedGoesDown+        , testCase "two labels: a seed stays up while any label still carries it" unionAcrossLabels+        , testCase "a document that cannot be read is reported and the loop keeps serving" malformedIsReported+        , testCase "a seed the binary cannot parse or configure is reported and the rest is applied" badSeedIsContained+        , testCase "the document format round-trips and refuses what it does not understand" documentFormat+        ]++-------------------------------------------------------------------------------+-- the served thing: "make these files exist", same as Test.ServeSpec++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)++-- | A seed naming a file called @boom@ cannot be configured: the+-- 'Configure' throws, which is the failure a fetched document must not be+-- able to take the loop down with.+configure :: Configure IO Spec Spec+configure = Configure $ \spec ->+    if "boom" `elem` spec.specNames+        then throwIO (userError "boom: refusing to configure")+        else pure spec++program :: Track' Spec+program = Track $ \spec ->+    op "follow-spec-root" (deps (fmap (fileOp spec.specDir) spec.specNames)) $ \actions ->+        actions{ref = mkRef "follow-spec-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]+    }++-- | The poll interval the fetcher runs at under test: short enough that a+-- test waiting several rounds stays cheap, long enough that "several rounds+-- passed" is unambiguous.+interval :: Int+interval = 100000++-- | The schedule under test: rounds at 'interval', no jitter (so "several+-- rounds' worth" means what it says), no quiet window (a change is injected+-- at the round that saw it, as milestone 2 did — the window has its own+-- spec, "Test.FollowSchedulerSpec"), and a short cap so that a test that+-- leaves a document malformed for a few rounds is not left waiting on the+-- ladder for long once it fixes it.+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+        }++{- | Run a following loop over @root@: the registry is @root/reg@, the files+land in @root/files@. The body drives it through the 'Driver' and must end+with @quit@ (or let the block do it); the world comes back once the loop+has ended. -}+withFollowing :: FilePath -> [Label] -> (Driver -> IO a) -> IO (World Spec Spec, [Serve.Report], [Follow.Report], a)+withFollowing root 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 = Nothing+                , Follow.followRefuseOlder = False+                , 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+                }+    -- the loop runs on this thread, the body on another: whatever the body+    -- concludes (or throws — an assertion inside it must fail the test, not+    -- hang it) is handed back once it has closed standard input, which is+    -- what ends the loop.+    resultVar <- newTChanIO+    _ <- forkIO $ do+        outcome <- try (body driver)+        atomically (writeTChan stdinChan Nothing)+        atomically (writeTChan resultVar outcome)+    w <- Serve.serveProducers [] Nothing True serveReporter nodeReporter (parseSpec root) configure program producers+    outcome <- atomically (readTChan resultVar)+    case outcome of+        Left (ex :: SomeException) -> throwIO ex+        Right a -> (,,,) w <$> readServe <*> readFollow <*> pure a++-- | A 'Stdin'-origin producer fed from a channel; 'Nothing' is end of input.+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"++label :: Text -> Label+label t = either (error . Text.unpack) id (Follow.mkLabel t)++-- | Write a document naming these seeds (one file name each) under a label.+publish :: FilePath -> Label -> Text -> [[String]] -> IO ()+publish root lbl did seeds = do+    createDirectoryIfMissing True (registryDir root)+    LByteString.writeFile (Follow.documentPath (registryDir root) lbl) (encode (Document did (fmap SeedWords seeds) Nothing))++-- | Poll until the condition holds, or fail after a generous bound.+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)++assertFile :: FilePath -> String -> Bool -> IO ()+assertFile root n expected = do+    found <- fileExists root n+    assertEqual (n <> " exists") expected found++convergences :: [Serve.Report] -> Int+convergences reports = length [() | Serve.ConvergeStop{} <- reports]++injections :: [Follow.Report] -> Int+injections reports = length [() | Follow.Injected{} <- reports]++fetchedOrigins :: World seed directive -> [(Serve.Declaration, Provenance, [String])]+fetchedOrigins w = [(e.logDeclaration, prov, e.logTokens) | e <- reverse w.worldLog, Fetched prov <- [e.logOrigin]]++-------------------------------------------------------------------------------++{- | The registry's document is the first thing the loop sees: a @history@+queued on stdin before the loop even starts is answered /after/ the fetched+declarations, because standard input is held behind the fetcher's first+round. -}+documentBecomesTheWorld :: IO ()+documentBecomesTheWorld =+    withTempDir $ \root -> do+        publish root (label "web") "web@1" [["a"], ["b"]]+        (w, reports, freports, ()) <- withFollowing root [label "web"] $ \d -> do+            typeLine d "history"+            waitFor "both files" ((&&) <$> fileExists root "a" <*> fileExists root "b")+        assertBool "every node converged up" (all (\st -> st.nodeDirection == TurnUp && st.nodeConvergence == Converged) (Map.elems w.worldNodes))+        assertEqual "one injection, two seeds up" [2] [nup | Follow.Injected _ _ _ nup _ <- freports]+        assertEqual "one convergence for the batch" 1 (convergences reports)+        let origins = fetchedOrigins w+        assertEqual "both declarations carry the fetcher's origin" 2 (length origins)+        assertBool "the origin names the registry, the label and the document" $+            all+                ( \(decl, prov, _) ->+                    decl == Serve.Add+                        && prov.provRegistry == Text.pack (registryDir root)+                        && prov.provLabel == "web"+                        && prov.provDocument == "web@1"+                        && Text.length prov.provDigest == 64+                )+                origins+        -- the queued history saw the fetched epochs: stdin came second+        assertEqual+            "history, typed before the loop started, lists the two fetched epochs"+            [2]+            [length xs | Serve.HistoryReport xs <- reports]+        assertBool "and history renders the fetcher origin" $+            any (Text.isInfixOf "[fetched") (concatMap Serve.renderReport [rep | rep@Serve.HistoryReport{} <- reports])++{- | The starvation rule. Rewriting the document with identical bytes moves+its mtime, so the registry re-reads it, and the digest says nothing changed:+no batch is injected, no command reaches the loop, no convergence runs. -}+identicalRewriteInjectsNothing :: IO ()+identicalRewriteInjectsNothing =+    withTempDir $ \root -> do+        publish root (label "web") "web@1" [["a"]]+        (_, reports, freports, (nConv, nInj)) <- withFollowing root [label "web"] $ \d -> do+            waitFor "the file" (fileExists root "a")+            waitFor "the batch's convergence" ((>= 1) . convergences <$> serveReports d)+            nConv <- convergences <$> serveReports d+            nInj <- injections <$> followReports d+            -- same bytes, new mtime; then several rounds' worth of waiting+            threadDelay 20000+            publish root (label "web") "web@1" [["a"]]+            threadDelay (5 * interval)+            pure (nConv, nInj)+        assertEqual "no further injection" nInj (injections freports)+        assertEqual "no further convergence" nConv (convergences reports)+        assertEqual "no further declaration either" 1 (length [() | Serve.Declared{} <- reports])++droppedSeedGoesDown :: IO ()+droppedSeedGoesDown =+    withTempDir $ \root -> do+        publish root (label "web") "web@1" [["a"], ["b"]]+        (w, _, freports, ()) <- withFollowing root [label "web"] $ \d -> do+            waitFor "both files" ((&&) <$> fileExists root "a" <*> fileExists root "b")+            publish root (label "web") "web@2" [["a"]]+            waitFor "b torn down" (not <$> fileExists root "b")+            waitFor "the second injection" ((>= 2) . injections <$> followReports d)+        assertFile root "a" True+        assertEqual "second injection: nothing up, one down" [(2, 0), (0, 1)] [(nup, ndown) | Follow.Injected _ _ _ nup ndown <- freports]+        assertBool "a's node is still converged up" (any (\st -> st.nodeDirection == TurnUp && st.nodeConvergence == Converged) (Map.elems w.worldNodes))+        assertEqual+            "history has the fetched down, from the second document"+            [(Serve.Remove, "web@2", ["b"])]+            [(decl, prov.provDocument, toks) | (decl, prov, toks) <- fetchedOrigins w, decl == Serve.Remove]++{- | Two labels sharing a seed. Dropping it from one document changes+nothing (the other still carries it, so the diff is empty and is reported as+such rather than injected); dropping it from the last one takes it down. -}+unionAcrossLabels :: IO ()+unionAcrossLabels =+    withTempDir $ \root -> do+        publish root (label "web") "web@1" [["a"], ["shared"]]+        publish root (label "api") "api@1" [["b"], ["shared"]]+        (_, _, freports, ()) <- withFollowing root [label "web", label "api"] $ \d -> do+            waitFor "all three files" (and <$> traverse (fileExists root) ["a", "b", "shared"])+            publish root (label "web") "web@2" [["a"]]+            waitFor "the web document's empty diff" (any isNoDiff <$> followReports d)+            threadDelay (2 * interval)+            assertFile root "shared" True+            publish root (label "api") "api@2" [["b"]]+            waitFor "shared torn down" (not <$> fileExists root "shared")+        assertFile root "a" True+        assertFile root "b" True+        assertEqual "the empty diff was for web@2" [("web@2")] [did | Follow.NoDiff _ did _ <- freports]+        assertEqual "the teardown came from api@2" ["api@2"] [did | Follow.Injected _ did _ 0 1 <- freports]+  where+    isNoDiff Follow.NoDiff{} = True+    isNoDiff _ = False++malformedIsReported :: IO ()+malformedIsReported =+    withTempDir $ \root -> do+        createDirectoryIfMissing True (registryDir root)+        LByteString.writeFile (Follow.documentPath (registryDir root) (label "web")) "{\"salmon\": 1, \"id\": \"x\", \"seeds\": [{\"neither\": 1}]}"+        (w, _, freports, ()) <- withFollowing root [label "web"] $ \d -> do+            waitFor "the complaint" (any isMalformed <$> followReports d)+            threadDelay (3 * interval)+            -- one complaint, not one per round+            n <- length . filter isMalformed <$> followReports d+            assertEqual "reported once" 1 n+            -- the loop is still serving: a good document is applied+            publish root (label "web") "web@1" [["a"]]+            waitFor "the file" (fileExists root "a")+        assertBool "the world converged after the bad document" (all (\st -> st.nodeConvergence == Converged) (Map.elems w.worldNodes))+        assertEqual "exactly one injection, from the good document" ["web@1"] [did | Follow.Injected _ did _ _ _ <- freports]+  where+    isMalformed Follow.Malformed{} = True+    isMalformed _ = False++{- | A seed the binary's own parser rejects (here, an empty word list) and a+seed whose 'Configure' throws are both reported as bad seeds by the loop; the+document's other seeds are applied and the loop lives on to apply the next+document. -}+badSeedIsContained :: IO ()+badSeedIsContained =+    withTempDir $ \root -> do+        publish root (label "web") "web@1" [[], ["boom"], ["a"]]+        (w, reports, _, ()) <- withFollowing root [label "web"] $ \_ -> do+            waitFor "the good seed's file" (fileExists root "a")+            -- the bad seeds stay in the document, so this diff is one `up`+            -- and does not re-declare (and re-report) them on the way down+            publish root (label "web") "web@2" [[], ["boom"], ["a"], ["b"]]+            waitFor "the next document's file" (fileExists root "b")+        assertEqual "two bad seeds reported" 2 (length [() | Serve.BadSeed{} <- reports])+        assertBool "one of them is the configure that threw" (any (Text.isInfixOf "configure threw") [err | Serve.BadSeed err <- reports])+        assertBool "everything else converged" (all (\st -> st.nodeConvergence == Converged) (Map.elems w.worldNodes))++documentFormat :: IO ()+documentFormat = do+    let doc = Document "web@1" [SeedWords ["app", "--version", "42"], SeedDirective (toJSON (Spec "/x" ["a"]))] Nothing+    assertEqual "round-trips" (Right doc) (eitherDecode (encode doc))+    assertBool "a future format version is refused" (isLeft (decodeDoc "{\"salmon\": 2, \"id\": \"x\", \"seeds\": []}"))+    assertBool "an entry needs exactly one of seed/directive" (isLeft (decodeDoc "{\"salmon\": 1, \"id\": \"x\", \"seeds\": [{\"seed\": [\"a\"], \"directive\": {}}]}"))+    assertEqual "unknown top-level keys are ignored" (Right (Document "x" [] Nothing)) (decodeDoc "{\"salmon\": 1, \"id\": \"x\", \"seeds\": [], \"note\": \"yesterday\"}")+    assertBool "`published` is a known key, and one that does not parse is refused rather than ignored" (isLeft (decodeDoc "{\"salmon\": 1, \"id\": \"x\", \"seeds\": [], \"published\": \"yesterday\"}"))+    assertEqual "`published` round-trips" (Right (Document "x" [] (Just (read "2026-09-23 10:41:07 UTC")))) (decodeDoc "{\"salmon\": 1, \"id\": \"x\", \"seeds\": [], \"published\": \"2026-09-23T10:41:07Z\"}")+    assertBool "a label cannot escape the directory" (isLeft (Follow.mkLabel "../etc"))+    assertBool "a label cannot start with a dot" (isLeft (Follow.mkLabel ".hidden"))+    assertEqual "the file name convention" "/reg/web-api.json" (Follow.documentPath "/reg" (label "web-api"))+  where+    decodeDoc :: LByteString.ByteString -> Either String Document+    decodeDoc = eitherDecode+    isLeft = either (const True) (const False)
+ test/Test/GcpSpec.hs view
@@ -0,0 +1,892 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 0 coverage for the pure @check@-verdict interpreters under+"Salmon.Builtin.Nodes.Gcp" -- each node shells out to @gcloud@/@ssh@ to get+its raw exit code and output, then hands that to a pure function that draws+the 'CheckResult'. Splitting the decision out (the same shape as+"Salmon.Builtin.Nodes.Systemd"'s @interpretShow@, see @Test.SystemdSpec@) is+what makes it testable without a real GCP project.+-}+module Test.GcpSpec (tests) where++import Data.Aeson (Value (..), encode, object, (.=))+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Lazy as LByteString+import Data.Char (isAsciiLower, isDigit)+import Data.List (isInfixOf, isSubsequenceOf, nub)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Foldable (toList)+import qualified Data.Map as Map+import GHC.IO.Exception (ExitCode (..))+import System.Process (readProcessWithExitCode)+import System.Process.ListLike (CmdSpec (..), CreateProcess, cmdspec)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Nodes.Binary (prepare)+import qualified Salmon.Builtin.Nodes.Gcp.ArtifactRegistry as ArtifactRegistry+import qualified Salmon.Builtin.Nodes.Gcp.Billing as Billing+import qualified Salmon.Builtin.Nodes.Gcp.CloudRun as CloudRun+import qualified Salmon.Builtin.Nodes.Gcp.Compute as Compute+import qualified Salmon.Builtin.Nodes.Gcp.Core as Core+import qualified Salmon.Builtin.Nodes.Gcp.Iam as Iam+import qualified Salmon.Builtin.Nodes.Gcp.LoadBalancing as LoadBalancing+import qualified Salmon.Builtin.Nodes.Gcp.Monitoring as Monitoring+import qualified Salmon.Builtin.Nodes.Gcp.ResourceManager as ResourceManager+import qualified Salmon.Builtin.Nodes.Gcp.SecretManager as SecretManager+import qualified Salmon.Builtin.Nodes.Gcp.ServiceUsage as ServiceUsage+import qualified Salmon.Builtin.Nodes.Gcp.Storage as Storage+import qualified Salmon.Builtin.Nodes.Rsync as Rsync+import qualified Salmon.Builtin.Nodes.Ssh as Ssh+import qualified SreBox.Gcp.CloudRunAlerts as CloudRunAlerts++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Nodes.Gcp"+        [ testGroup "Core.interpretAdc" adcTests+        , testGroup "Compute.interpretInstanceStatus" instanceTests+        , testGroup "Storage.interpretBucketDescribe" bucketTests+        , testGroup "ArtifactRegistry.interpretRepoDescribe" repoTests+        , testGroup "CloudRun.interpretServiceDescribe" cloudRunTests+        , testGroup "Iam" iamTests+        , testGroup "LoadBalancing" lbTests+        , testGroup "ServiceUsage" serviceUsageTests+        , testGroup "Billing.interpretBillingDescribe" billingTests+        , testGroup "ResourceManager" projectTests+        , testGroup "Compute (tier 2 resources)" vmTests+        , testGroup "Compute (tier 3 resources)" lbBackendTests+        , testGroup "SecretManager" secretTests+        , testGroup "CloudRun options" cloudRunOptionTests+        , testGroup "Ssh.ClientOpts" clientOptsTests+        , testGroup "Monitoring" monitoringTests+        , testGroup "SreBox.Gcp.CloudRunAlerts" cloudRunAlertsTests+        ]++-- | Extracts the argument list of a prepared gcloud 'CreateProcess', for+-- asserting on rendered command-line shape without actually invoking gcloud.+processArgs :: CreateProcess -> [String]+processArgs p = case cmdspec p of+    RawCommand _path args -> args+    ShellCommand s -> [s]++isFailure :: CheckResult -> Bool+isFailure (Failure _) = True+isFailure _ = False++-------------------------------------------------------------------------------++adcTests :: [TestTree]+adcTests =+    [ testCase "a printed token means ADC is usable" $+        assertEqual "" Success (Core.interpretAdc ExitSuccess)+    , testCase "no token means ADC is not configured" $+        assertBool "" (isFailure (Core.interpretAdc (ExitFailure 1)))+    ]++-------------------------------------------------------------------------------++instanceTests :: [TestTree]+instanceTests =+    [ testCase "RUNNING is satisfied" $+        assertEqual "" Success (Compute.interpretInstanceStatus on ExitSuccess "RUNNING")+    , testCase "TERMINATED needs bringing up" $+        assertBool "" (isFailure (Compute.interpretInstanceStatus on ExitSuccess "TERMINATED"))+    , testCase "transitional states are Unknown, not Failure" $ do+        assertEqual "provisioning" Unknown (Compute.interpretInstanceStatus on ExitSuccess "PROVISIONING")+        assertEqual "staging" Unknown (Compute.interpretInstanceStatus on ExitSuccess "STAGING")+        assertEqual "stopping" Unknown (Compute.interpretInstanceStatus on ExitSuccess "STOPPING")+    , testCase "an unrecognized status is a Failure, not a crash" $+        assertBool "" (isFailure (Compute.interpretInstanceStatus on ExitSuccess "SOME-NEW-STATUS"))+    , testCase "describe failing outright (e.g. instance absent) is a Failure" $+        assertBool "" (isFailure (Compute.interpretInstanceStatus on (ExitFailure 1) ""))+    , testCase "up creates an absent instance" $+        assertEqual "" Compute.CreateInstance (Compute.planInstanceUp on (ExitFailure 1) "")+    , testCase "up starts a stopped instance rather than re-creating it" $+        assertEqual "" Compute.StartInstance (Compute.planInstanceUp on ExitSuccess "TERMINATED")+    , testCase "up resumes a suspended instance" $+        assertEqual "" Compute.ResumeInstance (Compute.planInstanceUp on ExitSuccess "SUSPENDED")+    , testCase "up leaves a running instance alone" $+        assertEqual "" Compute.AlreadyThere (Compute.planInstanceUp on ExitSuccess "RUNNING")+    , testCase "up refuses to act on a transitional status" $+        assertEqual "" (Compute.CannotActYet "STOPPING") (Compute.planInstanceUp on ExitSuccess "STOPPING")+    , testCase "declared stopped: TERMINATED is satisfied and RUNNING is not" $ do+        assertEqual "" Success (Compute.interpretInstanceStatus off ExitSuccess "TERMINATED")+        assertBool "" (isFailure (Compute.interpretInstanceStatus off ExitSuccess "RUNNING"))+    , testCase "declared stopped: up stops a running instance and leaves a stopped one alone" $ do+        assertEqual "" Compute.StopInstance (Compute.planInstanceUp off ExitSuccess "RUNNING")+        assertEqual "" Compute.AlreadyThere (Compute.planInstanceUp off ExitSuccess "TERMINATED")+        assertEqual "" Compute.CreateInstance (Compute.planInstanceUp off (ExitFailure 1) "")+    , testCase "declared stopped: a suspended instance is not stopped blindly" $+        assertBool "" (case Compute.planInstanceUp off ExitSuccess "SUSPENDED" of Compute.CannotActYet _ -> True; _ -> False)+    , testCase "for down, a stopped instance is still present; an absent one is not" $ do+        assertEqual "" Success (Compute.interpretInstancePresence ExitSuccess "TERMINATED")+        assertBool "" (isFailure (Compute.interpretInstancePresence (ExitFailure 1) ""))+    , testCase "stop is rendered like start" $+        assertEqual+            ""+            (RawCommand "gcloud" ["compute", "instances", "stop", "toy-vm", "--zone", "europe-west1-b", "--project", "p"])+            (cmdspec (prepare Compute.computeCommand (Compute.InstancesStop toyInstance)))+    ]+  where+    on = Compute.PoweredOn+    off = Compute.PoweredOff+    toyInstance =+        Compute.Instance+            { Compute.instanceName = "toy-vm"+            , Compute.instanceProject = Core.Project "p"+            , Compute.instanceZone = Core.Zone "europe-west1-b"+            , Compute.instanceMachineType = Compute.Custom "e2-micro"+            , Compute.instanceBootDisk = Compute.BootDisk 10 Nothing (Just "ubuntu-2404-lts-amd64") (Just "ubuntu-os-cloud")+            , Compute.instanceNetwork = "default"+            , Compute.instanceSubnet = "default"+            , Compute.instanceServiceAccount = Nothing+            , Compute.instanceMetadata = Map.fromList [("enable-oslogin", "FALSE")]+            , Compute.instanceMetadataFiles = Map.fromList [("startup-script", "/tmp/w/startup-script.sh")]+            , Compute.instanceAddress = Just "toy-ip"+            , Compute.instanceTags = ["toy-ssh"]+            , Compute.instancePower = Compute.PoweredOn+            }++-------------------------------------------------------------------------------++bucketTests :: [TestTree]+bucketTests =+    [ testCase "describe succeeding means the bucket exists" $+        assertEqual "" Success (Storage.interpretBucketDescribe "my-bucket" ExitSuccess)+    , testCase "describe failing means the bucket is absent" $+        assertBool "" (isFailure (Storage.interpretBucketDescribe "my-bucket" (ExitFailure 1)))+    ]++-------------------------------------------------------------------------------++repoTests :: [TestTree]+repoTests =+    [ testCase "gcloud artifacts takes --location, not --region" $+        assertEqual+            ""+            ["artifacts", "repositories", "create", "my-repo", "--repository-format", "docker", "--location", "us-west1", "--project", "p"]+            ( processArgs+                ( prepare+                    ArtifactRegistry.artifactRegistryCommand+                    (ArtifactRegistry.ReposCreate (ArtifactRegistry.ArtifactRepo "my-repo" (Core.Project "p") (Core.Region "us-west1") ArtifactRegistry.Docker))+                )+            )+    , testCase "describe succeeding means the repo exists" $+        assertEqual "" Success (ArtifactRegistry.interpretRepoDescribe "my-repo" ExitSuccess)+    , testCase "describe failing means the repo is absent" $+        assertBool "" (isFailure (ArtifactRegistry.interpretRepoDescribe "my-repo" (ExitFailure 1)))+    ]++-------------------------------------------------------------------------------++cloudRunTests :: [TestTree]+cloudRunTests =+    [ testCase "describe succeeding with what was declared is satisfied" $+        assertEqual "" Success (verdict declared (describeJson "us-docker.pkg.dev/p/r/img:1" (Just "sa@p.iam.gserviceaccount.com") [plain "A" "1", secret "S"]))+    , testCase "a stale image is not satisfied, and the reason names both" $+        case verdict declared (describeJson "us-docker.pkg.dev/p/r/img:0" (Just "sa@p.iam.gserviceaccount.com") [plain "A" "1"]) of+            Failure why -> do+                assertBool (Text.unpack why) ("img:0" `Text.isInfixOf` why)+                assertBool (Text.unpack why) ("img:1" `Text.isInfixOf` why)+            other -> assertBool (show other) False+    , -- the substring match this replaces called these the same+      testCase "img:1 is not img:10" $ do+        assertBool "" (isFailure (verdict declared (describeJson "us-docker.pkg.dev/p/r/img:10" (Just "sa@p.iam.gserviceaccount.com") [plain "A" "1"])))+        assertBool "" (isFailure (verdict declared{CloudRun.crsImage = "us-docker.pkg.dev/p/r/img:10"} (describeJson "us-docker.pkg.dev/p/r/img:1" (Just "sa@p.iam.gserviceaccount.com") [plain "A" "1"])))+    , testCase "an image that merely appears elsewhere in the output is not the image" $+        assertBool "" (isFailure (verdict declared (Text.replace "\"containers\"" "\"note\": \"us-docker.pkg.dev/p/r/img:1\", \"containers\"" (describeJson "other:2" (Just "sa@p.iam.gserviceaccount.com") [plain "A" "1"]))))+    , testCase "a changed service account is drift" $+        assertBool "" (isFailure (verdict declared (describeJson "us-docker.pkg.dev/p/r/img:1" (Just "someone-else@p.iam.gserviceaccount.com") [plain "A" "1"])))+    , testCase "a service with no service account at all is drift" $+        assertBool "" (isFailure (verdict declared (describeJson "us-docker.pkg.dev/p/r/img:1" Nothing [plain "A" "1"])))+    , testCase "a changed, missing and extra environment variable are each drift, named and never quoted" $ do+        let why env = case verdict declared (describeJson "us-docker.pkg.dev/p/r/img:1" (Just "sa@p.iam.gserviceaccount.com") env) of+                Failure w -> w+                other -> Text.pack (show other)+        assertBool "" ("A" `Text.isInfixOf` why [plain "A" "changed-value-9"])+        assertBool "the value is not in the reason" (not ("changed-value-9" `Text.isInfixOf` why [plain "A" "changed-value-9"]))+        assertBool "" ("environment variable A is missing" `Text.isInfixOf` why [])+        assertBool "" ("environment variable EXTRA is set but not declared" `Text.isInfixOf` why [plain "A" "1", plain "EXTRA" "x"])+    , testCase "a secret-bound variable is not a plain one: extra secrets are not env drift" $+        assertEqual "" Success (verdict declared (describeJson "us-docker.pkg.dev/p/r/img:1" (Just "sa@p.iam.gserviceaccount.com") [plain "A" "1", secret "PGRST_JWT_SECRET"]))+    , testCase "output that is not the expected JSON is Unknown, not a redeploy" $ do+        assertEqual "" Unknown (verdict declared "image: us-docker.pkg.dev/p/r/img:1\n")+        assertEqual "" Unknown (verdict declared "{\"spec\": {}}")+    , testCase "describe failing means the service is absent" $+        assertBool "" (isFailure (CloudRun.interpretServiceDescribe declared (ExitFailure 1) ""))+    , testCase "the describe asks for JSON" $+        assertBool "" ("--format=json" `elem` processArgs (prepare CloudRun.cloudRunCommand (CloudRun.RunDescribe declared)))+    , testCase "for down, a service on a stale image is still present" $ do+        -- down deletes what exists; the image only matters for up.+        assertEqual "" Success (CloudRun.interpretServicePresence ExitSuccess "image: us-docker.pkg.dev/p/r/img:1\n")+        assertBool "" (isFailure (CloudRun.interpretServicePresence (ExitFailure 1) ""))+    ]++declared :: CloudRun.CloudRunService+declared =+    CloudRun.CloudRunService+        { CloudRun.crsName = "svc"+        , CloudRun.crsProject = Core.Project "p"+        , CloudRun.crsRegion = Core.Region "europe-west1"+        , CloudRun.crsImage = "us-docker.pkg.dev/p/r/img:1"+        , CloudRun.crsEnv = Map.fromList [("A", "1")]+        , CloudRun.crsServiceAccount = "sa@p.iam.gserviceaccount.com"+        , CloudRun.crsIngress = CloudRun.All+        , CloudRun.crsMaxInstances = Nothing+        , CloudRun.crsOptions = CloudRun.defaultCloudRunOptions+        }++verdict :: CloudRun.CloudRunService -> Text.Text -> CheckResult+verdict svc = CloudRun.interpretServiceDescribe svc ExitSuccess++plain :: Text.Text -> Text.Text -> Value+plain k v = object ["name" .= k, "value" .= v]++secret :: Text.Text -> Value+secret k = object ["name" .= k, "valueFrom" .= object ["secretKeyRef" .= object ["name" .= ("s" :: Text.Text), "key" .= ("latest" :: Text.Text)]]]++-- | The parts of @gcloud run services describe --format=json@ the check reads.+describeJson :: Text.Text -> Maybe Text.Text -> [Value] -> Text.Text+describeJson image sa env =+    Text.decodeUtf8 . LByteString.toStrict . encode $+        object+            [ "spec"+                .= object+                    [ "template"+                        .= object+                            [ "spec"+                                .= object+                                    ( [ "containers" .= [object ["image" .= image, "env" .= env]]+                                      ]+                                        <> maybe [] (\a -> ["serviceAccountName" .= a]) sa+                                    )+                            ]+                    ]+            , "status" .= object ["latestReadyRevisionName" .= ("svc-00001" :: Text.Text)]+            ]++-------------------------------------------------------------------------------++iamTests :: [TestTree]+iamTests =+    [ testCase "service account describe succeeding means it exists" $+        assertEqual "" Success (Iam.interpretServiceAccountDescribe "sa-1" ExitSuccess)+    , testCase "service account describe failing means it is absent" $+        assertBool "" (isFailure (Iam.interpretServiceAccountDescribe "sa-1" (ExitFailure 1)))+    , testCase "a binding present in the policy is satisfied" $+        assertEqual+            ""+            Success+            ( Iam.interpretBindingPolicy+                binding+                ExitSuccess+                "bindings:\n- members:\n  - serviceAccount:sa-1@p.iam.gserviceaccount.com\n  role: roles/storage.objectViewer\n"+            )+    , testCase "a binding absent from the policy is not satisfied" $+        assertBool+            ""+            ( isFailure+                ( Iam.interpretBindingPolicy+                    binding+                    ExitSuccess+                    "bindings:\n- members:\n  - user:someone@example.com\n  role: roles/viewer\n"+                )+            )+    , testCase "get-iam-policy failing outright is not satisfied" $+        assertBool "" (isFailure (Iam.interpretBindingPolicy binding (ExitFailure 1) ""))+    , testCase "a secrets/ resource binds against the secrets group" $+        assertEqual+            ""+            ["secrets", "add-iam-policy-binding", "my-secret", "--member", "serviceAccount:sa-1@p.iam.gserviceaccount.com", "--role", "roles/secretmanager.secretAccessor"]+            (processArgs (prepare Iam.iamCommand (Iam.IamPolicyAddBinding secretBinding)))+    , testCase "an artifacts/repositories/ resource carries its location as a trailing flag, after the resource" $+        assertEqual+            ""+            ["artifacts", "repositories", "add-iam-policy-binding", "my-repo", "--location", "us-west1", "--member", "serviceAccount:sa-1@p.iam.gserviceaccount.com", "--role", "roles/uploader"]+            (processArgs (prepare Iam.iamCommand (Iam.IamPolicyAddBinding repoBinding)))+    , testCase "a project-qualified repository passes --project rather than relying on gcloud's configured project" $+        assertEqual+            ""+            ["artifacts", "repositories", "get-iam-policy", "my-repo", "--location", "us-west1", "--project", "p"]+            (processArgs (prepare Iam.iamCommand (Iam.IamPolicyGetBinding (binding {Iam.iamResource = "projects/p/locations/us-west1/repositories/my-repo"}))))+    , testCase "a project-qualified secret passes --project" $+        assertEqual+            ""+            ["secrets", "get-iam-policy", "my-secret", "--project", "p"]+            (processArgs (prepare Iam.iamCommand (Iam.IamPolicyGetBinding (binding {Iam.iamResource = "projects/p/secrets/my-secret"}))))+    , testCase "a bucket resource is rendered as the gs:// URL gcloud storage requires" $+        assertEqual+            ""+            ["storage", "buckets", "get-iam-policy", "gs://my-bucket"]+            (processArgs (prepare Iam.iamCommand (Iam.IamPolicyGetBinding (binding {Iam.iamResource = "buckets/my-bucket"}))))+    , testCase "role describe succeeding means the custom role exists" $+        assertEqual "" Success (Iam.interpretRoleDescribe "registryUploader" ExitSuccess)+    , testCase "role describe failing means the custom role is absent" $+        assertBool "" (isFailure (Iam.interpretRoleDescribe "registryUploader" (ExitFailure 1)))+    , testCase "a custom role is created from its definition file" $+        assertEqual+            ""+            ["iam", "roles", "create", "registryUploader", "--file", "infra/roles/registryUploader.yaml", "--project", "p"]+            (processArgs (prepare Iam.iamCommand (Iam.RolesCreate role)))+    , testCase "a service account key is written to its target path" $+        assertEqual+            ""+            ["iam", "service-accounts", "keys", "create", "secrets/gh-ci/uploader.key.json", "--iam-account", "uploader@p.iam.gserviceaccount.com", "--project", "p"]+            (processArgs (prepare Iam.iamCommand (Iam.ServiceAccountKeysCreate key)))+    ]+  where+    binding =+        Iam.IamBinding+            { Iam.iamPrincipal = Iam.ServiceAccount "sa-1@p.iam.gserviceaccount.com"+            , Iam.iamRole = "roles/storage.objectViewer"+            , Iam.iamResource = "projects/p"+            }+    secretBinding =+        binding+            { Iam.iamRole = "roles/secretmanager.secretAccessor"+            , Iam.iamResource = "secrets/my-secret"+            }+    repoBinding =+        binding+            { Iam.iamRole = "roles/uploader"+            , Iam.iamResource = "artifacts/repositories/us-west1/my-repo"+            }+    role =+        Iam.CustomRole+            { Iam.roleId = "registryUploader"+            , Iam.roleProject = Core.Project "p"+            , Iam.roleDefinitionFile = "infra/roles/registryUploader.yaml"+            }+    key =+        Iam.ServiceAccountKey+            { Iam.sakProject = Core.Project "p"+            , Iam.sakAccountId = "uploader"+            , Iam.sakPath = "secrets/gh-ci/uploader.key.json"+            }++-------------------------------------------------------------------------------++serviceUsageTests :: [TestTree]+serviceUsageTests =+    [ testCase "the API appearing in the enabled listing is satisfied" $+        assertEqual+            ""+            Success+            (ServiceUsage.interpretServiceList (ServiceUsage.Api "run.googleapis.com") ExitSuccess "NAME\nrun.googleapis.com\n")+    , testCase "the API absent from the enabled listing is not satisfied" $+        assertBool+            ""+            (isFailure (ServiceUsage.interpretServiceList (ServiceUsage.Api "run.googleapis.com") ExitSuccess "NAME\n"))+    , testCase "listing failing outright is not satisfied" $+        assertBool "" (isFailure (ServiceUsage.interpretServiceList (ServiceUsage.Api "run.googleapis.com") (ExitFailure 1) ""))+    ]++-------------------------------------------------------------------------------++secretTests :: [TestTree]+secretTests =+    [ testCase "a version is added from a file, never from argv" $ do+        -- argv is world-readable through /proc for the life of the process.+        let args = processArgs (prepare SecretManager.secretManagerCommand (SecretManager.VersionsAdd version))+        assertBool (show args) (["--data-file", "/certs/db.key"] `isSubsequenceOf` args)+        assertBool (show args) (["secrets", "versions", "add", "db-key"] `isSubsequenceOf` args)+    , testCase "reading back compares the exact bytes, trailing newline included" $ do+        -- Trimming would make a node that had just uploaded its own PEM+        -- report a difference on every later pass.+        assertEqual "" Success (SecretManager.interpretSecretContents "s" "abc\n" ExitSuccess "abc\n")+        assertBool "" (isFailure (SecretManager.interpretSecretContents "s" "abc\n" ExitSuccess "abc"))+        assertBool "" (isFailure (SecretManager.interpretSecretContents "s" "abc" (ExitFailure 1) ""))+    , testCase "a secret that does not describe is absent" $ do+        assertEqual "" Success (SecretManager.interpretSecretDescribe "s" ExitSuccess)+        assertBool "" (isFailure (SecretManager.interpretSecretDescribe "s" (ExitFailure 1)))+    ]+  where+    sec = SecretManager.Secret "db-key" (Core.Project "p") "automatic"+    version = SecretManager.SecretVersion sec "/certs/db.key"++cloudRunOptionTests :: [TestTree]+cloudRunOptionTests =+    [ testCase "every secret rides on ONE --set-secrets flag" $ do+        -- gcloud treats a repeated --set-secrets as a replacement, so the+        -- one-flag-per-binding form silently deploys with only the last.+        let args = processArgs (prepare CloudRun.cloudRunCommand (CloudRun.RunDeploy svc))+            flags = length (filter (== "--set-secrets") args)+        assertEqual (show args) 1 flags+        assertBool (show args) ("/opt/vault/cert.pem=svc-cert:latest,PGRST_JWT_SECRET=svc-jwt:latest" `elem` args)+    , testCase "resource knobs are passed only when set" $ do+        let bare = processArgs (prepare CloudRun.cloudRunCommand (CloudRun.RunDeploy svc{CloudRun.crsOptions = CloudRun.defaultCloudRunOptions}))+        assertBool (show bare) (not ("--set-secrets" `elem` bare))+        assertBool (show bare) (not ("--cpu" `elem` bare))+        assertBool (show bare) (not ("--allow-unauthenticated" `elem` bare))+        assertBool (show bare) (not ("--no-invoker-iam-check" `elem` bare))+        let full = processArgs (prepare CloudRun.cloudRunCommand (CloudRun.RunDeploy svc))+        assertBool (show full) (["--cpu", "1000m"] `isSubsequenceOf` full)+        assertBool (show full) (["--memory", "256Mi"] `isSubsequenceOf` full)+        assertBool (show full) (["--concurrency", "80"] `isSubsequenceOf` full)+    , testCase "disabling the invoker IAM check is a deploy flag, not an IAM write" $ do+        -- Under iam.allowedPolicyMemberDomains, --allow-unauthenticated+        -- deploys and only warns that allUsers was refused; the flag form is+        -- part of the spec, so it either lands or the deploy fails.+        let opts = CloudRun.defaultCloudRunOptions{CloudRun.croInvokerIamCheckDisabled = True}+            args = processArgs (prepare CloudRun.cloudRunCommand (CloudRun.RunDeploy svc{CloudRun.crsOptions = opts}))+        assertBool (show args) ("--no-invoker-iam-check" `elem` args)+        assertBool (show args) (not ("--allow-unauthenticated" `elem` args))+    ]+  where+    svc =+        CloudRun.CloudRunService+            { CloudRun.crsName = "svc"+            , CloudRun.crsProject = Core.Project "p"+            , CloudRun.crsRegion = Core.Region "europe-west1"+            , CloudRun.crsImage = "img:1"+            , CloudRun.crsEnv = Map.empty+            , CloudRun.crsServiceAccount = "sa@p.iam.gserviceaccount.com"+            , CloudRun.crsIngress = CloudRun.All+            , CloudRun.crsMaxInstances = Just 1+            , CloudRun.crsOptions =+                CloudRun.defaultCloudRunOptions+                    { CloudRun.croSecrets =+                        [ CloudRun.SecretFile "/opt/vault/cert.pem" "svc-cert" "latest"+                        , CloudRun.SecretEnvVar "PGRST_JWT_SECRET" "svc-jwt" "latest"+                        ]+                    , CloudRun.croCpu = Just "1000m"+                    , CloudRun.croMemory = Just "256Mi"+                    , CloudRun.croConcurrency = Just 80+                    }+            }++lbBackendTests :: [TestTree]+lbBackendTests =+    [ testCase "a proxy-only subnet is created ACTIVE, with its purpose" $ do+        let args = processArgs (prepare Compute.computeCommand (Compute.SubnetsCreate proxySubnet))+        assertBool (show args) (["--purpose", "REGIONAL_MANAGED_PROXY"] `isSubsequenceOf` args)+        assertBool (show args) (["--role", "ACTIVE"] `isSubsequenceOf` args)+        assertBool (show args) (["--range", "192.168.100.0/24"] `isSubsequenceOf` args)+    , testCase "an ordinary subnet is not given a role" $ do+        let args = processArgs (prepare Compute.computeCommand (Compute.SubnetsCreate proxySubnet{Compute.subnetPurpose = Compute.PrivateSubnet}))+        assertBool (show args) (not ("--role" `elem` args))+    , testCase "a subnet of the wrong purpose is not the subnet that was asked for" $ do+        assertEqual "" Success (Compute.interpretSubnetDescribe "s" "REGIONAL_MANAGED_PROXY" ExitSuccess "REGIONAL_MANAGED_PROXY")+        assertBool "a plain subnet under that name" (isFailure (Compute.interpretSubnetDescribe "s" "REGIONAL_MANAGED_PROXY" ExitSuccess "PRIVATE"))+        assertBool "absent" (isFailure (Compute.interpretSubnetDescribe "s" "REGIONAL_MANAGED_PROXY" (ExitFailure 1) ""))+    , testCase "gcloud leaving an ordinary subnet's purpose empty still satisfies PRIVATE" $+        assertEqual "" Success (Compute.interpretSubnetDescribe "s" "PRIVATE" ExitSuccess "")+    , testCase "the instance group is unmanaged and zonal" $ do+        let args = processArgs (prepare Compute.computeCommand (Compute.InstanceGroupsCreate group))+        assertBool (show args) (["instance-groups", "unmanaged", "create", "ig"] `isSubsequenceOf` args)+        assertBool (show args) (["--zone", "europe-west1-b"] `isSubsequenceOf` args)+    , testCase "membership is read off the listing's last path segment" $ do+        let listing = "https://www.googleapis.com/compute/v1/projects/p/zones/europe-west1-b/instances/web\n"+        assertEqual "" Success (Compute.interpretGroupMembership "web" ExitSuccess listing)+        -- the whole reason not to use a substring match+        assertBool "a longer name containing this one" (isFailure (Compute.interpretGroupMembership "web" ExitSuccess "projects/p/zones/z/instances/web-canary\n"))+        assertBool "empty listing" (isFailure (Compute.interpretGroupMembership "web" ExitSuccess ""))+        assertBool "listing failed" (isFailure (Compute.interpretGroupMembership "web" (ExitFailure 1) ""))+    ]+  where+    proxySubnet =+        Compute.Subnet+            { Compute.subnetName = "proxy"+            , Compute.subnetProject = Core.Project "p"+            , Compute.subnetRegion = Core.Region "europe-west1"+            , Compute.subnetNetwork = "default"+            , Compute.subnetRange = "192.168.100.0/24"+            , Compute.subnetPurpose = Compute.RegionalManagedProxy+            }+    group = Compute.InstanceGroup "ig" (Core.Project "p") (Core.Zone "europe-west1-b")++-------------------------------------------------------------------------------++lbTests :: [TestTree]+lbTests =+    [ testCase "describe succeeding means the url map exists" $+        assertEqual "" Success (LoadBalancing.interpretLbDescribe ExitSuccess)+    , testCase "describe failing means the load balancer is absent" $+        assertBool "" (isFailure (LoadBalancing.interpretLbDescribe (ExitFailure 1)))+    , testCase "shellQuote neutralizes a value that would otherwise break out of quoting" $ do+        assertEqual "no special characters" "'tenant-1'" (LoadBalancing.shellQuote "tenant-1")+        assertEqual+            "an embedded single quote and shell metacharacters stay inside the quoting"+            "'tenant'\\''; rm -rf / #'"+            (LoadBalancing.shellQuote "tenant'; rm -rf / #")+    , testCase "create/delete run the script with bash, not as a gcloud subcommand" $ do+        assertBool "create" (isBash (prepare LoadBalancing.loadBalancingCommand (LoadBalancing.LbCreate alb)))+        assertBool "delete" (isBash (prepare LoadBalancing.loadBalancingCommand (LoadBalancing.LbDelete alb)))+    , testCase "scripts never swallow failures with || true" $ do+        let scripts = concatMap (processArgs . prepare LoadBalancing.loadBalancingCommand) [LoadBalancing.LbCreate alb, LoadBalancing.LbDelete alb]+        assertBool "" (not (any ("|| true" `isInfixOf`) scripts))+    , testCase "a zonal instance group is addressed by zone, not by the balancer's region" $ do+        -- The bug this pins: every gcloud call naming the group used to get+        -- the balancer's --region, which an unmanaged (zonal) group rejects+        -- outright -- so the one backend kind made of VMs salmon declared+        -- could never be attached at all.+        assertBool script ("--instance-group-zone='europe-west1-b'" `isInfixOf` script)+        assertBool script (not ("--instance-group-region" `isInfixOf` script))+        assertBool script ("set-named-ports 'ig' --project=\"$PROJECT\" --zone='europe-west1-b'" `isInfixOf` script)+    , testCase "exists() is a bare predicate, so each caller says where its resource lives" $ do+        -- It used to append --project/--region to whatever it was handed,+        -- which silently made every describe a regional one.+        assertBool script ("exists() { \"$@\" >/dev/null 2>&1; }" `isInfixOf` script)+        assertBool script ("exists gcloud compute url-maps describe 'web-url-map' --project=\"$PROJECT\" --region=\"$REGION\"" `isInfixOf` script)+    , testCase "a regional instance group keeps the regional flag" $ do+        let regionalScript = createScript alb{LoadBalancing.albBackends = [LoadBalancing.InstanceGroupBackend "ig" (LoadBalancing.InstanceGroupRegion "europe-west1") [8080]]}+        assertBool regionalScript ("--instance-group-region='europe-west1'" `isInfixOf` regionalScript)+    , testCase "rendered scripts parse as bash" $ do+        let scripts = [s' | cmd <- [LoadBalancing.LbCreate alb, LoadBalancing.LbDelete alb], (_ : s' : _) <- [processArgs (prepare LoadBalancing.loadBalancingCommand cmd)]]+        mapM_+            ( \script -> do+                (code, _, err) <- readProcessWithExitCode "bash" ["-n", "-c", script] ""+                assertEqual err ExitSuccess code+            )+            scripts+    ]+  where+    isBash p = case cmdspec p of+        RawCommand "bash" ("-c" : _) -> True+        _ -> False+    createScript a = case processArgs (prepare LoadBalancing.loadBalancingCommand (LoadBalancing.LbCreate a)) of+        (_ : s : _) -> s+        other -> error (show other)+    script = createScript alb+    alb =+        LoadBalancing.ApplicationLoadBalancer+            { LoadBalancing.albName = "web"+            , LoadBalancing.albProject = Core.Project "p"+            , LoadBalancing.albRegion = Core.Region "europe-west1"+            , LoadBalancing.albNetwork = Just "default"+            , LoadBalancing.albBackends =+                [ LoadBalancing.InstanceGroupBackend "ig" (LoadBalancing.InstanceGroupZone "europe-west1-b") [8080, 8081]+                , LoadBalancing.CloudRunBackend "svc"+                ]+            , LoadBalancing.albHealthCheck = Just (LoadBalancing.HealthCheck "hc" 8080)+            }++-------------------------------------------------------------------------------++billingTests :: [TestTree]+billingTests =+    [ testCase "a project linked and billing-enabled is satisfied" $+        assertEqual+            ""+            Success+            (Billing.interpretBillingDescribe account ExitSuccess "billingAccountName: billingAccounts/XXXXXX-XXXXXX-XXXXXX\nbillingEnabled: true\nname: projects/p\n")+    , testCase "a project linked to a different account is not satisfied" $+        assertBool+            ""+            (isFailure (Billing.interpretBillingDescribe account ExitSuccess "billingAccountName: billingAccounts/OTHER-ACCOUNT\nbillingEnabled: true\n"))+    , testCase "a project with billing disabled is not satisfied" $+        assertBool+            ""+            (isFailure (Billing.interpretBillingDescribe account ExitSuccess "billingAccountName: billingAccounts/XXXXXX-XXXXXX-XXXXXX\nbillingEnabled: false\n"))+    , testCase "describe failing outright is not satisfied" $+        assertBool "" (isFailure (Billing.interpretBillingDescribe account (ExitFailure 1) ""))+    ]+  where+    account = Billing.BillingAccount "XXXXXX-XXXXXX-XXXXXX"++-------------------------------------------------------------------------------++projectTests :: [TestTree]+projectTests =+    [ testCase "an ACTIVE project is satisfied" $+        assertEqual "" Success (ResourceManager.interpretProjectState "p" ExitSuccess "ACTIVE")+    , testCase "a project pending deletion is not satisfied, and says why" $+        case ResourceManager.interpretProjectState "p" ExitSuccess "DELETE_REQUESTED" of+            Failure msg -> assertBool "mentions the id cannot be reused" ("cannot be reused" `isInfixOf` show msg)+            other -> assertBool ("expected Failure, got " <> show other) False+    , testCase "describe failing means the project is absent" $+        assertBool "" (isFailure (ResourceManager.interpretProjectState "p" (ExitFailure 1) ""))+    , testCase "create passes the parent and labels" $ do+        let args =+                processArgs $+                    prepare+                        ResourceManager.resourceManagerCommand+                        ( ResourceManager.ProjectsCreate+                            (ResourceManager.ProjectSpec (Core.Project "p") (ResourceManager.Folder "123") (Map.fromList [("purpose", "salmon-toy")]))+                        )+        assertEqual "" ["projects", "create", "p", "--folder", "123", "--labels", "purpose=salmon-toy"] args+    ]++-------------------------------------------------------------------------------++vmTests :: [TestTree]+vmTests =+    [ testCase "an address is reserved regionally, and read back as a bare IP" $ do+        assertEqual+            "create"+            ["compute", "addresses", "create", "toy-ip", "--region", "europe-west1", "--project", "p"]+            (processArgs (prepare Compute.computeCommand (Compute.AddressesCreate addr)))+        assertEqual+            "describe asks for the address itself, which is what a driver needs"+            ["compute", "addresses", "describe", "toy-ip", "--region", "europe-west1", "--format=value(address)", "--project", "p"]+            (processArgs (prepare Compute.computeCommand (Compute.AddressesDescribe addr)))+    , testCase "a reserved address with no IP yet is not satisfied" $+        assertBool "" (isFailure (Compute.interpretAddressDescribe "toy-ip" ExitSuccess ""))+    , testCase "a reserved address with an IP is satisfied" $+        assertEqual "" Success (Compute.interpretAddressDescribe "toy-ip" ExitSuccess "34.1.2.3")+    , testCase "a firewall rule carries its allow, ranges and target tags" $+        assertEqual+            ""+            [ "compute", "firewall-rules", "create", "toy-ssh"+            , "--network", "default", "--allow", "tcp:22"+            , "--source-ranges", "0.0.0.0/0", "--project", "p"+            , "--target-tags", "toy-ssh"+            ]+            (processArgs (prepare Compute.computeCommand (Compute.FirewallCreate fw)))+    , testCase "an instance boots from an image family, in its publisher's project" $+        assertBool+            "--image-family and --image-project are passed"+            (["--image-family", "ubuntu-2404-lts-amd64"] `isSubsequenceOf` args && ["--image-project", "ubuntu-os-cloud"] `isSubsequenceOf` args)+    , testCase "a multi-line startup script goes through --metadata-from-file" $+        assertBool+            "a newline-bearing value cannot ride in --metadata KEY=VALUE"+            (["--metadata-from-file", "startup-script=/tmp/w/startup-script.sh"] `isSubsequenceOf` args)+    , testCase "the instance claims the reserved address by name" $+        assertBool "" (["--address", "toy-ip"] `isSubsequenceOf` args)+    ]+  where+    args = processArgs (prepare Compute.computeCommand (Compute.InstancesCreate inst))+    addr = Compute.Address "toy-ip" (Core.Project "p") (Core.Region "europe-west1")+    fw =+        Compute.FirewallRule+            { Compute.firewallName = "toy-ssh"+            , Compute.firewallProject = Core.Project "p"+            , Compute.firewallNetwork = "default"+            , Compute.firewallAllow = "tcp:22"+            , Compute.firewallSourceRanges = ["0.0.0.0/0"]+            , Compute.firewallTargetTags = ["toy-ssh"]+            }+    inst =+        Compute.Instance+            { Compute.instanceName = "toy-vm"+            , Compute.instanceProject = Core.Project "p"+            , Compute.instanceZone = Core.Zone "europe-west1-b"+            , Compute.instanceMachineType = Compute.Custom "e2-micro"+            , Compute.instanceBootDisk = Compute.BootDisk 10 Nothing (Just "ubuntu-2404-lts-amd64") (Just "ubuntu-os-cloud")+            , Compute.instanceNetwork = "default"+            , Compute.instanceSubnet = "default"+            , Compute.instanceServiceAccount = Nothing+            , Compute.instanceMetadata = Map.fromList [("enable-oslogin", "FALSE")]+            , Compute.instanceMetadataFiles = Map.fromList [("startup-script", "/tmp/w/startup-script.sh")]+            , Compute.instanceAddress = Just "toy-ip"+            , Compute.instanceTags = ["toy-ssh"]+            , Compute.instancePower = Compute.PoweredOn+            }++-------------------------------------------------------------------------------++clientOptsTests :: [TestTree]+clientOptsTests =+    [ testCase "no options means ssh authenticates as it always did" $+        assertEqual "" [] (Ssh.clientArgs Ssh.noClientOpts)+    , testCase "an identity is offered exclusively" $+        assertEqual+            "IdentitiesOnly, or an agent key can be tried first and the cert never reached"+            ["-i", "/w/ssh/toy-client", "-o", "IdentitiesOnly=yes"]+            (Ssh.clientArgs Ssh.noClientOpts{Ssh.optIdentity = Just "/w/ssh/toy-client"})+    , testCase "a known-hosts file comes with accept-new" $+        assertEqual+            ""+            ["-o", "UserKnownHostsFile=/w/ssh/known_hosts", "-o", "StrictHostKeyChecking=accept-new"]+            (Ssh.clientArgs Ssh.noClientOpts{Ssh.optKnownHosts = Just "/w/ssh/known_hosts"})+    , testCase "rsync carries the same options through --rsh" $+        assertEqual+            "rsync has no -i of its own"+            [ "--copy-links"+            , "--rsh"+            , "ssh -i /w/ssh/toy-client -o IdentitiesOnly=yes -o UserKnownHostsFile=/w/ssh/known_hosts -o StrictHostKeyChecking=accept-new"+            , "/local/bin"+            , "salmon@1.2.3.4:/home/salmon/bin"+            ]+            (processArgs (prepare Rsync.rsyncRun (Rsync.SendFile "/local/bin" (Rsync.Remote "salmon" "1.2.3.4") "/home/salmon/bin" opts)))+    , testCase "a directory upload carries them too" $+        assertEqual+            "sendDirWith is sendFileWith's --rsh treatment, recursively"+            [ "--copy-links"+            , "--recursive"+            , "--rsh"+            , "ssh -i /w/ssh/toy-client -o IdentitiesOnly=yes -o UserKnownHostsFile=/w/ssh/known_hosts -o StrictHostKeyChecking=accept-new"+            , "/local/files"+            , "salmon@1.2.3.4:/home/salmon/files"+            ]+            (processArgs (prepare Rsync.rsyncRun (Rsync.SendDir "/local/files" (Rsync.Remote "salmon" "1.2.3.4") "/home/salmon/files" opts)))+    , testCase "a directory upload without options is the same command as before" $+        assertEqual+            ""+            ["--copy-links", "--recursive", "/local/files", "salmon@1.2.3.4:/home/salmon/files"]+            (processArgs (prepare Rsync.rsyncRun (Rsync.SendDir "/local/files" (Rsync.Remote "salmon" "1.2.3.4") "/home/salmon/files" Ssh.noClientOpts)))+    , testCase "a changed host key is recognised as such" $+        assertBool+            "the one ssh failure that never resolves by waiting"+            (Ssh.isHostKeyMismatch "@@@@\nWARNING: REMOTE HOST IDENTIFICATION HAS CHANGED!\n")+    , testCase "an ordinary refusal is not a host key mismatch" $+        assertBool+            "a VM still booting must be waited out, not have its host key forgotten"+            (not (Ssh.isHostKeyMismatch "salmon@1.2.3.4: Permission denied (publickey)."))+    ]+  where+    opts = Ssh.ClientOpts (Just "/w/ssh/toy-client") (Just "/w/ssh/known_hosts")++-------------------------------------------------------------------------------++monitoringTests :: [TestTree]+monitoringTests =+    [ testCase "an email channel is created with its type and address as channel labels" $ do+        let args = processArgs (prepare Monitoring.monitoringCommand (Monitoring.ChannelsCreate channel))+        assertBool (show args) (["beta", "monitoring", "channels", "create"] `isSubsequenceOf` args)+        assertBool (show args) (["--type", "email"] `isSubsequenceOf` args)+        assertBool (show args) (["--channel-labels", "email_address=ops@example.org"] `isSubsequenceOf` args)+        assertBool (show args) (["--display-name", "ops mail"] `isSubsequenceOf` args)+        assertBool (show args) (["--project", "p"] `isSubsequenceOf` args)+    , testCase "channels and policies are looked up by display name, as JSON" $ do+        let cargs = processArgs (prepare Monitoring.monitoringCommand (Monitoring.ChannelsList channel))+            pargs = processArgs (prepare Monitoring.monitoringCommand (Monitoring.PoliciesList policy))+        assertBool (show cargs) (["--filter", "display_name=\"ops mail\"", "--format", "json"] `isSubsequenceOf` cargs)+        assertBool (show pargs) (["--filter", "display_name=\"svc: 5xx ratio\"", "--format", "json"] `isSubsequenceOf` pargs)+    , testCase "channel lookup: failed, absent, present matching, present with another address" $ do+        assertEqual "" (Monitoring.LookupFailed "exit 1: boom") (Monitoring.lookupChannel channel (ExitFailure 1) "" "boom\n")+        assertEqual "" Monitoring.Absent (Monitoring.lookupChannel channel ExitSuccess "[]" "")+        assertEqual+            ""+            (Monitoring.Present (Monitoring.FoundChannel "projects/p/notificationChannels/1" True))+            (Monitoring.lookupChannel channel ExitSuccess (channelJson "ops@example.org") "")+        assertEqual+            ""+            (Monitoring.Present (Monitoring.FoundChannel "projects/p/notificationChannels/1" False))+            (Monitoring.lookupChannel channel ExitSuccess (channelJson "other@example.org") "")+        -- and as a check: only the matching one is satisfied+        assertEqual "" Success (Monitoring.interpretChannelList channel (ExitSuccess, channelJson "ops@example.org", ""))+        assertBool "" (isFailure (Monitoring.interpretChannelList channel (ExitSuccess, channelJson "other@example.org", "")))+        assertBool "" (isFailure (Monitoring.interpretChannelList channel (ExitSuccess, "[]", "")))+        assertBool "" (isFailure (Monitoring.interpretChannelList channel (ExitFailure 1, "", "")))+    , testCase "the 5xx condition is a ratio: numerator on the 5xx class, denominator on every request, same service" $ do+        let v = Monitoring.renderCondition target (Monitoring.ServerErrorRatio 0.05 300)+            threshold = fieldAt ["conditionThreshold"] v+            filt = textAt ["conditionThreshold", "filter"] v+            denom = textAt ["conditionThreshold", "denominatorFilter"] v+        assertBool (show filt) (maybe False ("metric.labels.response_code_class=\"5xx\"" `Text.isInfixOf`) filt)+        assertBool (show filt) (maybe False ("resource.labels.service_name=\"svc\"" `Text.isInfixOf`) filt)+        assertBool (show filt) (maybe False ("resource.labels.location=\"europe-west1\"" `Text.isInfixOf`) filt)+        assertBool (show denom) (maybe False (\d -> "request_count" `Text.isInfixOf` d && not ("5xx" `Text.isInfixOf` d)) denom)+        assertEqual "" (Just "300s") (textAt ["conditionThreshold", "duration"] v)+        assertBool (show threshold) (threshold /= Nothing)+    , testCase "latency and memory read the 99th percentile; instance count sums active instances" $ do+        let lat = Monitoring.renderCondition target (Monitoring.RequestLatencyP99 2000 300)+            mem = Monitoring.renderCondition target (Monitoring.MemoryUtilization 0.9 300)+            cnt = Monitoring.renderCondition target (Monitoring.InstanceCount 3 300)+        assertEqual "" (Just "ALIGN_PERCENTILE_99") (textAt ["conditionThreshold", "aggregations", "0", "perSeriesAligner"] lat)+        assertBool "" (maybe False ("request_latencies" `Text.isInfixOf`) (textAt ["conditionThreshold", "filter"] lat))+        assertEqual "" (Just "ALIGN_PERCENTILE_99") (textAt ["conditionThreshold", "aggregations", "0", "perSeriesAligner"] mem)+        assertBool "" (maybe False ("memory/utilizations" `Text.isInfixOf`) (textAt ["conditionThreshold", "filter"] mem))+        assertEqual "" (Just "REDUCE_SUM") (textAt ["conditionThreshold", "aggregations", "0", "crossSeriesReducer"] cnt)+        assertBool "" (maybe False ("metric.labels.state=\"active\"" `Text.isInfixOf`) (textAt ["conditionThreshold", "filter"] cnt))+    , testCase "the rendered policy names its channels and carries the fingerprint as a user label" $ do+        let names = ["projects/p/notificationChannels/1"]+            v = Monitoring.renderPolicy policy names+        assertEqual "" (Just "svc: 5xx ratio") (textAt ["displayName"] v)+        assertEqual "" (Just "OR") (textAt ["combiner"] v)+        assertEqual "" (Just "projects/p/notificationChannels/1") (textAt ["notificationChannels", "0"] v)+        assertEqual "" (Just (Monitoring.policyFingerprint policy names)) (textAt ["userLabels", Monitoring.fingerprintLabel] v)+        -- and it is what --policy carries, inline+        let args = processArgs (prepare Monitoring.monitoringCommand (Monitoring.PoliciesCreate policy names))+        assertBool (show args) (["alpha", "monitoring", "policies", "create", "--policy"] `isSubsequenceOf` args)+        assertBool (show args) (Text.unpack (Text.decodeUtf8 (LByteString.toStrict (encode v))) `elem` args)+    , testCase "the fingerprint is label-safe, and moves with a threshold or a channel id" $ do+        let names = ["projects/p/notificationChannels/1"]+            fp = Monitoring.policyFingerprint policy names+        assertEqual (show fp) 16 (Text.length fp)+        assertBool (show fp) (Text.all (\c -> isAsciiLower c || isDigit c) fp)+        assertBool "same declaration, same fingerprint" (fp == Monitoring.policyFingerprint policy names)+        assertBool "threshold" (fp /= Monitoring.policyFingerprint policy{Monitoring.apConditions = [Monitoring.ServerErrorRatio 0.1 300]} names)+        assertBool "channel id" (fp /= Monitoring.policyFingerprint policy ["projects/p/notificationChannels/2"])+        assertBool "documentation" (fp /= Monitoring.policyFingerprint policy{Monitoring.apDocumentation = "other"} names)+    , testCase "policy lookup: a matching fingerprint is satisfied, anything else is not" $ do+        let names = ["projects/p/notificationChannels/1"]+            fp = Monitoring.policyFingerprint policy names+        assertEqual "" Success (Monitoring.interpretPolicyList policy names (ExitSuccess, policyJson (Just fp), ""))+        assertBool "edited or older" (isFailure (Monitoring.interpretPolicyList policy names (ExitSuccess, policyJson (Just "0000000000000000"), "")))+        assertBool "no label" (isFailure (Monitoring.interpretPolicyList policy names (ExitSuccess, policyJson Nothing, "")))+        assertBool "absent" (isFailure (Monitoring.interpretPolicyList policy names (ExitSuccess, "[]", "")))+        assertBool "unreachable" (isFailure (Monitoring.interpretPolicyList policy names (ExitFailure 1, "", "")))+        assertEqual+            ""+            (Monitoring.Present (Monitoring.FoundPolicy "projects/p/alertPolicies/9" (Just fp)))+            (Monitoring.lookupPolicy policy ExitSuccess (policyJson (Just fp)) "")+    , testCase "an update names the policy found, a delete the resource, both under the project" $ do+        let up = processArgs (prepare Monitoring.monitoringCommand (Monitoring.PoliciesUpdate "projects/p/alertPolicies/9" policy []))+            del = processArgs (prepare Monitoring.monitoringCommand (Monitoring.PoliciesDelete (Core.Project "p") "projects/p/alertPolicies/9"))+            cdel = processArgs (prepare Monitoring.monitoringCommand (Monitoring.ChannelsDelete (Core.Project "p") "projects/p/notificationChannels/1"))+        assertBool (show up) (["policies", "update", "projects/p/alertPolicies/9", "--policy"] `isSubsequenceOf` up)+        assertBool (show del) (["policies", "delete", "projects/p/alertPolicies/9", "--quiet", "--project", "p"] `isSubsequenceOf` del)+        assertBool (show cdel) (["channels", "delete", "projects/p/notificationChannels/1", "--quiet"] `isSubsequenceOf` cdel)+    ]+  where+    channel = Monitoring.NotificationChannel (Core.Project "p") "ops mail" (Monitoring.Email "ops@example.org")+    target = Monitoring.CloudRunTarget (Core.Project "p") (Core.Region "europe-west1") "svc"+    policy =+        Monitoring.AlertPolicy+            { Monitoring.apProject = Core.Project "p"+            , Monitoring.apDisplayName = "svc: 5xx ratio"+            , Monitoring.apTarget = target+            , Monitoring.apConditions = [Monitoring.ServerErrorRatio 0.05 300]+            , Monitoring.apChannels = [channel]+            , Monitoring.apDocumentation = "doc"+            }+    channelJson address =+        "[{\"name\": \"projects/p/notificationChannels/1\", \"type\": \"email\", \"displayName\": \"ops mail\", \"labels\": {\"email_address\": \"" <> Text.encodeUtf8 address <> "\"}, \"enabled\": true}]"+    policyJson mfp =+        "[{\"name\": \"projects/p/alertPolicies/9\", \"displayName\": \"svc: 5xx ratio\", \"combiner\": \"OR\""+            <> maybe "" (\fp -> ", \"userLabels\": {\"salmon-fingerprint\": \"" <> Text.encodeUtf8 fp <> "\"}") mfp+            <> "}]"++-- | A field of a JSON value by path; an array index is spelled as a number.+fieldAt :: [Text.Text] -> Value -> Maybe Value+fieldAt [] v = Just v+fieldAt (k : ks) (Object o) = KeyMap.lookup (Key.fromText k) o >>= fieldAt ks+fieldAt (k : ks) (Array xs) = case reads (Text.unpack k) of+    [(i, "")] | i >= 0, i < length xs -> fieldAt ks (toList xs !! i)+    _ -> Nothing+fieldAt _ _ = Nothing++textAt :: [Text.Text] -> Value -> Maybe Text.Text+textAt ks v = case fieldAt ks v of+    Just (String t) -> Just t+    _ -> Nothing++cloudRunAlertsTests :: [TestTree]+cloudRunAlertsTests =+    [ testCase "three policies without a maximum, four with; one channel shared by all" $ do+        let without = CloudRunAlerts.standardPolicies cfg{CloudRunAlerts.cra_maxInstances = Nothing}+            with = CloudRunAlerts.standardPolicies cfg+        assertEqual "" 3 (length without)+        assertEqual "" 4 (length with)+        assertEqual "" 1 (length (nub (concatMap (.apChannels) with)))+        assertBool "" (any (\p -> p.apConditions == [Monitoring.InstanceCount 2 300]) with)+    , testCase "display names are distinct per service, so two services' alerts are distinct resources" $ do+        let a = map (.apDisplayName) (CloudRunAlerts.standardPolicies cfg)+            b = map (.apDisplayName) (CloudRunAlerts.standardPolicies cfg{CloudRunAlerts.cra_service = "other"})+        assertEqual "" 4 (length (nub a))+        assertBool (show (a, b)) (null (filter (`elem` b) a))+        assertBool "" (all ("svc: " `Text.isPrefixOf`) a)+    , testCase "the defaults are the documented ones" $ do+        let t = CloudRunAlerts.defaultAlertThresholds+        assertEqual "" 0.05 t.at_errorRatio+        assertEqual "" 2000 t.at_latencyP99Ms+        assertEqual "" 0.9 t.at_memoryUtilization+        assertEqual "" 300 t.at_duration+    ]+  where+    cfg =+        CloudRunAlerts.CloudRunAlertsConfig+            { CloudRunAlerts.cra_project = Core.Project "p"+            , CloudRunAlerts.cra_region = Core.Region "europe-west1"+            , CloudRunAlerts.cra_service = "svc"+            , CloudRunAlerts.cra_email = "ops@example.org"+            , CloudRunAlerts.cra_channelName = "ops mail"+            , CloudRunAlerts.cra_maxInstances = Just 2+            , CloudRunAlerts.cra_thresholds = CloudRunAlerts.defaultAlertThresholds+            }
+ test/Test/Harness.hs view
@@ -0,0 +1,722 @@+-- | Generic plumbing to run 'Op' graphs for real (no mocking) and observe+-- what happened, on top of the existing 'Salmon.Actions.UpDown' machinery.+--+-- The rest of the test suite is organized in tiers by IO cost/blast-radius:+--+--   * Layer 0 (structural): 'evalDeps' on an 'Op', no side effects at all.+--   * Layer 1 (sandboxed IO): real 'up'\/'down' against a throwaway temp dir+--     or ephemeral resource, via 'runUpCapturing'\/'runDown'.+--   * Layer 2 (system services): real IO against a service that only exists+--     inside a disposable podman container, dogfooding "Podman.pullImage"\/+--     "Podman.runContainer" as the sandbox provisioner (see "Test.PodmanSpec").+--   * Layer 3 (whole-machine): real IO against a qemu VM booted from a+--     caller-prepared "Salmon.Builtin.Nodes.Debian.Debootstrap" rootfs,+--     dogfooding "Salmon.Builtin.Nodes.LinuxBridge"\/"Salmon.Builtin.Nodes.Qemu"+--     as the sandbox provisioner, for recipes Layer 2's containers can't+--     exercise well (real systemd-as-PID-1, real network interfaces). See+--     @specs/qemu-test-vms.md@ for the design.+module Test.Harness (+    -- * capturing UpDown traversal reports+    capture,+    runUpCapturing,+    runUp,+    runDown,+    runDownCapturing,++    -- * scratch filesystem+    withTempDir,+    privatePipe,++    -- * skipping tests when a precondition isn't met+    requireExecutable,++    -- * podman-backed sandboxes (Layer 2)+    podmanTrack,+    withContainer,+    podmanExec_,+    podmanExecCapture,++    -- * redirecting a recipe's system binaries into a container via PATH shims+    withShimmedPath,++    -- * qemu-backed sandboxes (Layer 3)+    testBridge,+    testBridgeCidr,+    testVmAddr,+    testVmAddr2,+    testVmAddr3,+    testVmAddr4,+    ensureTestBridge,+    withVm,+    withVmAt,+    VmAccess (..),+    sshToVm,+    quoteForRemoteShell,+    scpToVm,+    testHarnessUser,+    hasVmPrivileges,+) where++import Control.Concurrent (threadDelay)+import Control.Exception (bracket, bracket_)+import Control.Monad (forM_, unless, void)+import Control.Monad.Identity (Identity, runIdentity)+import Data.IORef+import Data.List (isInfixOf)+import qualified Data.List as List+import qualified Data.Text as Text+import Numeric (showHex)+import qualified Salmon.Actions.UpDown as UpDown+import Salmon.Actions.UpDown (downTree, upTree)+import Salmon.Builtin.Extension (Extension (..), Op, Track', ignoreTrack)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import qualified Salmon.Builtin.Nodes.Keys as Keys+import qualified Salmon.Builtin.Nodes.LinuxBridge as LinuxBridge+import qualified Salmon.Builtin.Nodes.Podman as Podman+import qualified Salmon.Builtin.Nodes.Qemu as Qemu+import qualified Salmon.Builtin.Nodes.Ssh as Ssh+import qualified Salmon.Builtin.Nodes.Systemd as Systemd+import Salmon.Reporter (Reporter, ReporterM (..))+import System.CPUTime (getCPUTime)+import System.Directory (XdgDirectory (XdgConfig), canonicalizePath, createDirectoryIfMissing, findExecutable, getPermissions, getXdgDirectory, setOwnerExecutable, setPermissions)+import System.Environment (lookupEnv, setEnv, unsetEnv)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.IO (Handle, hPutStrLn, stderr)+import System.Posix.IO (FdOption (CloseOnExec), createPipe, fdToHandle, setFdOption)+import System.IO.Temp (withSystemTempDirectory)+import System.Posix.User (getEffectiveUserID, getLoginName)+import System.Process (readProcessWithExitCode)++-- | Build a reporter that accumulates every emitted value, in order, plus a+-- way to read them back out. Good enough for single-threaded test runs.+capture :: IO (Reporter a, IO [a])+capture = do+    ref <- newIORef []+    let r = ReporterM $ \x -> atomicModifyIORef' ref (\xs -> (x : xs, ()))+    pure (r, reverse <$> readIORef ref)++-- | 'Op'-graph traversal is 'Identity'-effectful in this codebase; both+-- entry points below hardcode that natural transformation.+nat :: Identity a -> IO a+nat = pure . runIdentity++-- | Run 'upTree' and return the full traversal trace (Eval\/Skip\/Blocked+-- per node, one report per node), so idempotency\/dedup can be asserted on+-- directly instead of only inferring it from side effects.+runUpCapturing :: Op -> IO [UpDown.Report Extension]+runUpCapturing o = do+    (r, readBack) <- capture+    _ <- upTree r nat o+    readBack++{- | Run 'upTree' when you only care about the side effects, not the trace.+Returns whether everything actually succeeded (see 'UpDown.upTree') — most+callers that don't check it explicitly still get a real postcondition+assertion elsewhere in the test, but the result is there for callers that+want to assert on it directly instead.+-}+runUp :: Op -> IO Bool+runUp o = do+    (r, _) <- capture+    upTree r nat o++runDown :: Op -> IO Bool+runDown o = do+    (r, _) <- capture+    downTree r nat o++-- | 'runDown', keeping the trace — the teardown counterpart of+-- 'runUpCapturing'. Note 'downTree' reports more than per-node outcomes:+-- 'Salmon.Actions.UpDown.Conflicting' comes from the 'Salmon.Op.Dag' fold,+-- before any node runs.+runDownCapturing :: Op -> IO [UpDown.Report Extension]+runDownCapturing o = do+    (r, readBack) <- capture+    _ <- downTree r nat o+    readBack++{- | A pipe neither end of which a child process may inherit.++The suite runs spec groups in parallel in one process, some of them spawn+processes, and nothing in the tree passes @close_fds@, so a child spawned+meanwhile inherits every descriptor not marked close-on-exec. A child holding+a copy of a loop's stdin write end keeps the loop from ever reading end of+input. @process@'s 'System.Process.createPipe' is plain; use this instead for+any pipe a test expects to see EOF on.+-}+privatePipe :: IO (Handle, Handle)+privatePipe = do+    (r, w) <- createPipe+    forM_ [r, w] $ \fd -> setFdOption fd CloseOnExec True+    (,) <$> fdToHandle r <*> fdToHandle w++-- | A fresh, auto-cleaned-up temp directory for filesystem-touching nodes.+withTempDir :: (FilePath -> IO a) -> IO a+withTempDir = withSystemTempDirectory "salmon-ops-recipes-test"++-- | Layer-2 tests need a real binary on PATH (podman, postgres, ...). Rather+-- than failing the suite on a machine that doesn't have it, skip loudly:+-- print a note and report the test as passing-vacuously.+requireExecutable :: String -> IO () -> IO ()+requireExecutable name act = do+    found <- findExecutable name+    case found of+        Just _ -> act+        Nothing ->+            hPutStrLn stderr $+                "SKIPPED: `" <> name <> "` not found on PATH; this Layer 2 test needs it installed to run for real"++-------------------------------------------------------------------------------+-- Podman-backed sandboxes.+--+-- Dogfoods "Podman.pullImage"\/"Podman.runContainer"\/"Podman.runContainer"'s+-- 'down' (i.e. runs them for real through 'runUp'\/'runDown', exactly like+-- production code would) as the sandbox provisioner and cleaner-upper —+-- there is no hand-rolled @podman rm -f@ shell-out here at all, since the+-- Podman nodes now carry a real teardown of their own. We pick the+-- container's name ourselves (so it's known up front and 'down' has a+-- stable target), rather than needing to recover an id from `podman run`'s+-- stdout.++-- | Assumes podman is already installed on the host\/CI image running the+-- test (checked by 'requireExecutable' at the call site).+podmanTrack :: Track' (Binary.Binary "podman")+podmanTrack = ignoreTrack++-- | Pull an image and run it under a fresh, unique name (dogfooding the+-- project's own Podman ops both ways), and guarantee cleanup via the+-- production 'down' action afterwards, however the action exits (including+-- on exception). The pulled image itself is left in the local cache — only+-- the container is torn down — since removing shared image cache on every+-- test run would be needlessly destructive and slow subsequent runs down.+withContainer :: Podman.Image -> Podman.PortMapping -> (String -> IO a) -> IO a+withContainer img pm act =+    bracket bringUp cleanup (act . fst)+  where+    cleanup :: (String, Op) -> IO ()+    cleanup (_, runOp) = void (runDown runOp)++    bringUp :: IO (String, Op)+    bringUp = do+        cname <- freshContainerName+        (reporter, _) <- capture+        let reg = Podman.dockerRegistry+            opts = Podman.noRunOptions{Podman.runPorts = [pm]}+            pullOp = Podman.pullImage reporter podmanTrack reg img+            runOp = Podman.runContainer reporter podmanTrack reg img cname opts+        pullOk <- runUp pullOp+        unless pullOk (fail "withContainer: pulling the sandbox image failed")+        runOk <- runUp runOp+        unless runOk (fail "withContainer: starting the sandbox container failed")+        pure (Text.unpack (Podman.getContainerName cname), runOp)++-- | CPU time at picosecond resolution is more than enough entropy to keep+-- concurrent\/successive test containers from colliding on a name.+freshContainerName :: IO Podman.ContainerName+freshContainerName = do+    t <- getCPUTime+    pure (Podman.ContainerName (Text.pack ("salmon-ops-recipes-test-" <> show t)))++-- | Run a command inside an already-running container, discarding its output.+-- Used for sandbox setup steps (installing prerequisites) that are not+-- themselves the thing under test.+podmanExec_ :: String -> [String] -> IO ()+podmanExec_ containerId args = do+    (code, out, err) <- readProcessWithExitCode "podman" (["exec", "-i", containerId] <> args) ""+    case code of+        ExitSuccess -> pure ()+        ExitFailure n ->+            error $+                "podmanExec_ " <> show args <> " failed with exit " <> show n <> "\nstdout: " <> out <> "\nstderr: " <> err++-- | Like 'podmanExec_', but for postcondition checks: hands back the full+-- (exit code, stdout, stderr) instead of throwing on failure.+podmanExecCapture :: String -> [String] -> IO (ExitCode, String, String)+podmanExecCapture containerId args =+    readProcessWithExitCode "podman" (["exec", "-i", containerId] <> args) ""++-------------------------------------------------------------------------------+-- Redirecting a recipe's real system binaries (apt-get, sudo, pg_ctlcluster,+-- ...) into a podman container.+--+-- Recipes call these binaries directly by name via 'System.Process.proc',+-- with no indirection to hook into — so the only way to run their *real*+-- logic against a sandbox instead of the host is to put lookalike wrapper+-- scripts earlier on PATH that forward the invocation into the container via+-- @podman exec@. This tests the recipe's actual command construction and+-- graph wiring for real, unmodified, while keeping the destructive parts+-- (apt installs, service starts) confined to the disposable container.++-- | Create shims for the given command names that all forward into+-- @containerId@, prepend them to PATH for the duration of the action, and+-- restore the original PATH afterwards.+withShimmedPath :: String -> [String] -> IO a -> IO a+withShimmedPath containerId commands act =+    withSystemTempDirectory "salmon-ops-recipes-test-shims" $ \dir -> do+        mapM_ (writeShim dir) commands+        withPrependedPath dir act+  where+    writeShim :: FilePath -> String -> IO ()+    writeShim dir cmd = do+        let path = dir </> cmd+        writeFile path $+            unlines+                [ -- Absolute shebang on purpose: `#!/usr/bin/env bash` would+                  -- have `env` resolve "bash" via the (now shim-prepended)+                  -- PATH, which — if "bash" is itself one of the shimmed+                  -- commands — finds this very script and recurses into+                  -- itself forever instead of running real bash.+                  "#!/bin/bash"+                , "exec podman exec -i " <> containerId <> " " <> cmd <> " \"$@\""+                ]+        perms <- getPermissions path+        setPermissions path (setOwnerExecutable True perms)++withPrependedPath :: FilePath -> IO a -> IO a+withPrependedPath dir act = do+    original <- lookupEnv "PATH"+    bracket_+        (setEnv "PATH" (dir <> maybe "" (":" <>) original))+        (maybe (unsetEnv "PATH") (setEnv "PATH") original)+        act++-------------------------------------------------------------------------------+-- qemu-backed sandboxes (Layer 3).+--+-- Mirrors the podman section above in spirit: dogfoods+-- "Salmon.Builtin.Nodes.LinuxBridge"'s and "Salmon.Builtin.Nodes.Qemu"'s own+-- up\/down through 'runUp'\/'runDown' as the sandbox provisioner, real IO, no+-- mocking. Unlike podman, this needs real host privilege (@CAP_NET_ADMIN@+-- for the bridge\/tap devices, plus whatever qemu itself needs) that is+-- assumed already available to whoever runs this tier — a documented+-- prerequisite, same stance @specs/qemu-test-vms.md@'s privilege open+-- question leans towards, rather than this harness trying to sudo on its+-- own behalf. As of the tap-owner\/unprivileged-qemu change (see+-- 'testHarnessUser'\/'hasVmPrivileges'), that prerequisite no longer has to+-- mean root: a one-time @setcap@ on @ip@ and @qemu-system-x86_64@ plus+-- @kvm@ group membership is enough for routine test runs, with root (or+-- @sudo@) only still needed for building rootfses (@debootstrap@ itself+-- always needs a real chroot) and, once, granting those capabilities.+--+-- Caveat carried over from the spec: the guest-networking scheme here+-- (static IP via the kernel @ip=@ cmdline parameter, assumed @eth0@ naming)+-- is a first cut, not yet checked against a real boot — @specs/qemu-test-vms.md@'s+-- phased plan puts "hand-validate a boot" before wrapping things in a node,+-- and that hand-validation hasn't happened yet. Expect to revisit the exact+-- cmdline\/interface-naming details here once a real VM has actually booted.++ipTrack :: Track' (Binary.Binary "ip")+ipTrack = ignoreTrack++qemuBinTrack :: Track' (Binary.Binary "qemu-system-x86_64")+qemuBinTrack = ignoreTrack++systemctlTrack :: Track' (Binary.Binary "systemctl")+systemctlTrack = ignoreTrack++{- | The unprivileged host user this tier's tap device and qemu process+itself now run as (see 'withVmAt'), instead of root — prefers @SUDO_USER@+(set when this suite is still invoked via a transitional @sudo@, e.g. for+the one-time steps in 'hasVmPrivileges''s haddock) and falls back to the+process's own login name, which is what a non-sudo invocation already is.+Both the tap's owner and the systemd unit's @User=@\/@Group=@ use this same+name — relies on the Debian\/Ubuntu convention of a private group sharing+the user's name (true for any normal, non-system account).+-}+testHarnessUser :: IO Text.Text+testHarnessUser = do+    viaSudo <- lookupEnv "SUDO_USER"+    case viaSudo of+        Just u | not (null u) -> pure (Text.pack u)+        _ -> Text.pack <$> getLoginName++{- | Whether the calling process can plausibly bring up this tier without+being root: either it already is root (the original, still-supported+mode), or the two binaries this tier shells out to for privileged+operations have been granted just enough Linux capability to do those+operations as an unprivileged user —++* @capsh@ (not @ip@ itself!) needs @cap_net_admin@, to raise it into its+  own ambient set before exec'ing the real, uncapped @ip@ —+  'Salmon.Builtin.Nodes.LinuxBridge.ipLinkCommand's haddock has the full+  story, but the short version: granting @cap_net_admin@ to @ip@ directly+  does not work, because iproute2 unconditionally drops its entire+  effective\/permitted\/inheritable capability set at startup and only+  trusts the *ambient* set afterwards — which a plain file-capability grant+  can never populate (the kernel zeroes ambient for any exec of a+  "privileged" file). Hand-validated 2026-09-08 via @strace@ on a real+  failing, then real passing, unprivileged @ip link add@.+* @qemu-system-x86_64@ needs @cap_dac_override@ (plus @cap_chown@\/+  @cap_fowner@ for guest-side @chown@\/@chmod@ over 9p) so its+  @security_model=passthrough@ export can still act on behalf of whichever+  uid\/gid a file inside the debootstrapped rootfs actually belongs to+  (e.g. the guest's own @postgres@ account) — without this, an+  unprivileged qemu could only ever access files it happens to already own+  on the host, which a real multi-user rootfs is not. Root granted this+  for free; a plain unprivileged process needs the capability instead of+  full root, not on top of it. Unlike @ip@, qemu does not appear to+  self-drop its capabilities this way — it's a plain file-capability grant.++Both are one-time host setup (@setcap cap_net_admin+eip $(command -v+capsh)@, @setcap cap_dac_override,cap_chown,cap_fowner+eip $(command -v+qemu-system-x86_64)@), same spirit as the KVM group membership already+assumed — see @specs/qemu-test-vms-progress.md@ for the exact commands run+to validate this. @\/dev\/kvm@ access itself is deliberately not re-checked+here: it's already gated by 'Salmon.Builtin.Nodes.Qemu.vm_enable_kvm' being+best-effort (see 'withVmAt') and by plain group membership, no capability+needed.+-}+hasVmPrivileges :: IO Bool+hasVmPrivileges = do+    isRoot <- (== 0) <$> getEffectiveUserID+    if isRoot+        then pure True+        else+            (&&)+                <$> hasCapability "cap_net_admin" "capsh"+                <*> hasCapability "cap_dac_override" "qemu-system-x86_64"++{- | Whether @exe@ (looked up on @PATH@) has been granted @capName@ via+@setcap@. Canonicalizes past any symlink first (e.g. Debian's usrmerge+makes @\/usr\/sbin\/ip@, which @PATH@ finds before the real @\/bin\/ip@, a+symlink) — @getcap@ reports nothing at all for a symlink path, only for the+real file the capability is actually stored on, same reason+'Salmon.Builtin.Nodes.Capabilities.grantCapabilities' itself needs the+canonical path to set it in the first place.+-}+hasCapability :: String -> String -> IO Bool+hasCapability capName exe = do+    mPath <- findExecutable exe+    case mPath of+        Nothing -> pure False+        Just linkedPath -> do+            path <- canonicalizePath linkedPath+            (code, out, _err) <- readProcessWithExitCode "getcap" [path] ""+            pure (code == ExitSuccess && capName `isInfixOf` out)++-- | One shared bridge, left standing across test runs rather than torn down+-- per test — matches @specs/qemu-test-vms.md@'s leaning on bridge lifecycle+-- scope. Only each VM's own tap is created\/destroyed per test.+testBridge :: LinuxBridge.Bridge+testBridge = LinuxBridge.Bridge "salmontest0"++testBridgeCidr :: LinuxBridge.Cidr+testBridgeCidr = LinuxBridge.Cidr "10.99.0.1" 24++{- | Fixed guest address — v1 assumes a single VM under test at a time (see+@specs/qemu-test-vms.md@'s phased plan: proving the tier end to end comes+before anything like a real address pool).+-}+testVmAddr :: Text.Text+testVmAddr = "10.99.0.2"++-- | A second fixed guest address, for tests that need two VMs up at once+-- (e.g. a primary\/standby pair) via two nested 'withVmAt' calls.+testVmAddr2 :: Text.Text+testVmAddr2 = "10.99.0.3"++{- | A third address, so a spec that is not part of the primary\/standby pair+can boot without waiting for one of theirs to be free.++Sharing an address between specs does not stop at "they must not run at the+same time": a VM that is still shutting down answers for the next spec's VM,+and ssh reports @Connection closed by 10.99.0.2@ from a host that is not the+one under test. Serializing the specs makes that window small, not absent, so+a spec with no reason to share should not.+-}+testVmAddr3 :: Text.Text+testVmAddr3 = "10.99.0.4"++-- | A fourth, for "Test.MigratorTemplateSpec", on the same reasoning as 'testVmAddr3'.+testVmAddr4 :: Text.Text+testVmAddr4 = "10.99.0.5"++-- | Ensures the shared test bridge (and its address) exist. Idempotent via+-- the production 'LinuxBridge.bridgeAddr' op's own @check@ — safe to call+-- before every test.+ensureTestBridge :: IO ()+ensureTestBridge = do+    (nodeReporter, _) <- capture+    (traceReporter, readBack) <- capture+    ok <- upTree traceReporter nat (LinuxBridge.bridgeAddr nodeReporter ipTrack testBridge testBridgeCidr)+    unless ok $ do+        trace <- readBack+        fail ("ensureTestBridge: failed to bring up the shared test bridge:\n" <> unlines (map show trace))++-- | CPU time at picosecond resolution, truncated to fit Linux's 15-character+-- interface name limit — same entropy source as 'freshContainerName' above,+-- just shorter (an interface name, unlike a container name, can't be long).+freshTapName :: IO LinuxBridge.DevName+freshTapName = do+    t <- getCPUTime+    pure (Text.pack ("vmtap" <> take 6 (reverse (show t))))++{- | A locally-administered MAC in qemu's own default OUI (@52:54:00@), with+three CPU-time-derived bytes.++One byte is not enough, and the way it fails is worth remembering: two+guests that draw the same address are on one bridge claiming one IP, so the+host's ARP entry for the first is overwritten by the second and the first+goes unreachable /after/ it has already answered SSH. That reads as a VM+that died for no reason, in whichever spec boots two at once.++The odds were far worse than one in 256, too: 'getCPUTime' counts+picoseconds but the clock underneath it ticks in nanoseconds, so the low+digits are always zero and a single byte of it ranges over a fraction of its+values. The three bytes here are taken /above/ that dead range.+-}+freshMac :: IO Text.Text+freshMac = do+    t <- getCPUTime+    let ticks = t `div` 1000+        byteAt k = fromInteger ((ticks `div` (256 ^ (k :: Int))) `mod` 256) :: Int+        hex2 n = let h = showHex n "" in if length h < 2 then '0' : h else h+    pure (Text.pack (List.intercalate ":" (["52", "54", "00"] <> map (hex2 . byteAt) [2, 1, 0])))++-- | What 'withVm' hands its action: the guest's login plus the private key+-- to authenticate with (see 'sshToVm' — always pass this explicitly rather+-- than relying on an ssh-agent\/default identity file, see 'VmAccess's+-- construction site in 'withVm' for why that doesn't work here).+data VmAccess = VmAccess {vmRemote :: Ssh.Remote, vmIdentityFile :: FilePath}++{- | Boots a VM from an already-prepared 'Salmon.Builtin.Nodes.Debian.Debootstrap.RootTree'+directory (built and populated by the caller — this harness does not run+debootstrap itself, see @specs/qemu-test-vms.md@) — waits for SSH to answer,+runs the action, and guarantees teardown afterwards via the production+'Qemu.setup' down action, however the action exits (including on+exception), same bracket-based shape as 'withContainer'.++Login access is entirely this harness's own doing, not the caller's: a+fresh SSH CA and a client key signed by it (via+"Salmon.Builtin.Nodes.Keys"'s production 'Keys.sshKey'\/'Keys.signKey', the+same primitives a real CA-backed recipe would use) are generated per boot+into the VM's own tmpdir, and the CA's public half plus a+@TrustedUserCAKeys@\/@PasswordAuthentication no@ sshd drop-in are written+straight into @rootfs@ before qemu starts — the 9p export means that's the+guest's own @\/etc\/ssh@, no separate transport step needed. This+sidesteps two problems hand-validation on 2026-08-20 ran into with relying+on a developer's own key instead (see @specs/qemu-test-vms-progress.md@):+running the whole privileged tier under @sudo@ doesn't forward the+invoking user's ssh-agent, so pubkey auth via a personal key silently never+succeeds and 'waitForSsh' just times out; and a per-run generated identity+means nothing here depends on a human having pre-populated+@root\/.ssh\/authorized_keys@ by hand at all.++@rootfs@ only needs 'Salmon.Builtin.Nodes.Debian.Debootstrap.vmEssentials'+and 'Salmon.Builtin.Nodes.Debian.Debootstrap.ensureVm9pBoot' already+applied; no key material needs pre-provisioning by the caller any more.++Fixed at 'testVmAddr' — for more than one VM at a time on the shared test+bridge (e.g. a primary/standby pair), see 'withVmAt'.+-}+withVm :: FilePath -> (VmAccess -> IO a) -> IO a+withVm = withVmAt testVmAddr++{- | Like 'withVm', but at a caller-chosen guest address on the shared test+bridge instead of the hardcoded 'testVmAddr' — lets a test bring up more+than one VM at once (e.g. nesting two calls, one per address, for a+primary/standby pair) without them fighting over the same IP. Caller picks+addresses inside 'testBridgeCidr' that don't collide with each other or+with 'testVmAddr' (still used by single-VM tests like+"Test.QemuSmokeSpec" running concurrently in the same tasty run).++Teardown ('runDown vmOp') is guaranteed from the moment 'upTree' has+actually brought the qemu process up, whatever happens afterwards —+including 'waitForSsh' timing out. That's the point of the inner+'bracket' below: 'bringUp' used to run 'upTree' /then/ 'waitForSsh' as+one action, so a 'waitForSsh' timeout threw out of 'bringUp' itself+before it ever returned @(access, vmOp)@ — and the outer 'bracket''s+cleanup only ever runs on a value 'bringUp' actually returned, so the+qemu process it had just started was orphaned on the shared bridge+(squatting its fixed test address for whichever spec runs next). Here,+once 'upTree' succeeds, an inner @bracket _ (const (void (runDown+vmOp)))@ owns teardown outright, and 'waitForSsh' runs strictly inside+that scope.+-}+withVmAt :: Text.Text -> FilePath -> (VmAccess -> IO a) -> IO a+withVmAt addr rootfs act =+    withSystemTempDirectory "salmon-ops-recipes-test-vm" $ \tmpdir -> do+        identityFile <- ensureVmSshAccess tmpdir rootfs+        vmOp <- bringUpVm tmpdir identityFile+        -- Once 'upTree' above has returned successfully, the qemu process+        -- exists — from here on, 'runDown vmOp' must run no matter what,+        -- including a 'waitForSsh' timeout. This inner 'bracket' owns that+        -- teardown outright; the outer 'withSystemTempDirectory' can no+        -- longer be the only thing standing between a thrown exception and+        -- an orphaned qemu process.+        bracket+            (pure (VmAccess (Ssh.Remote "root" addr) identityFile))+            (const (void (runDown vmOp)))+            (\access -> waitForSsh access >> act access)+  where+    bringUpVm :: FilePath -> FilePath -> IO Op+    bringUpVm tmpdir identityFile = do+        ensureTestBridge+        tapName <- freshTapName+        mac <- freshMac+        user <- testHarnessUser+        unitDir <- getXdgDirectory XdgConfig "systemd/user"+        (kernel, initrd) <- Qemu.resolveKernelInitrd rootfs+        (reporter, _) <- capture+        (reporterTap, _) <- capture+        let cfg =+                Qemu.VmConfig+                    { Qemu.vm_name = Text.pack ("salmon-test-vm-" <> takeWhile (/= '/') (reverse tmpdir))+                    , Qemu.vm_memory_mb = 512+                    , Qemu.vm_smp = 1+                    , Qemu.vm_rootfs = rootfs+                    , Qemu.vm_kernel = kernel+                    , Qemu.vm_initrd = initrd+                    , Qemu.vm_extra_kernel_args =+                        [ "ip=" <> addr <> "::" <> testBridgeCidr.cidrAddr <> ":255.255.255.0::eth0:off"+                        ]+                    , Qemu.vm_tap = LinuxBridge.Tap tapName testBridge (Just user)+                    , Qemu.vm_mac = mac+                    , Qemu.vm_monitor_socket = tmpdir </> "monitor.sock"+                    , Qemu.vm_enable_kvm = True+                    , Qemu.vm_user = user+                    , Qemu.vm_group = user+                    , Qemu.vm_working_dir = tmpdir+                    , Qemu.vm_systemd_scope = Systemd.User+                    , Qemu.vm_unit_dir = unitDir+                    }+            vmOp = Qemu.setup reporter reporterTap systemctlTrack qemuBinTrack ipTrack cfg+        (traceReporter, readBack) <- capture+        ok <- upTree traceReporter nat vmOp+        unless ok $ do+            trace <- readBack+            fail ("withVmAt: starting the sandbox VM failed:\n" <> unlines (map show trace))+        -- Note: no cleanup on this path's own failure — 'upTree' returning+        -- 'False' (or throwing) here means the VM never came up in the+        -- first place (or 'upTree' itself already unwound whatever partial+        -- state it made), so there is nothing yet for an inner 'bracket' to+        -- guarantee teardown of. It's only once we have a 'vmOp' that+        -- successfully started that this function returns, at which point+        -- the caller's 'bracket' above takes over.+        pure vmOp++{- | Generates a fresh SSH CA and a client key signed by it (both kept in+the VM's own @tmpdir@, torn down with everything else there), and wires+@rootfs@'s sshd to trust that CA instead of relying on+@root\/.ssh\/authorized_keys@ — see 'withVm's haddock for why. Returns the+signed client's private key path, for use with 'sshToVm'.+-}+ensureVmSshAccess :: FilePath -> FilePath -> IO FilePath+ensureVmSshAccess tmpdir rootfs = do+    (reporter, _) <- capture+    let keygenTrack = ignoreTrack :: Track' (Binary.Binary "ssh-keygen")+        ca = Keys.SSHKeyPair Keys.ED25519 tmpdir "test-ca"+        client = Keys.SSHKeyPair Keys.ED25519 tmpdir "test-client"+    okCa <- runUp (Keys.sshKey reporter keygenTrack ca)+    unless okCa (fail "ensureVmSshAccess: failed to generate the test CA key")+    okSign <- runUp (Keys.signKey reporter keygenTrack (Keys.SSHCertificateAuthority ca) (Keys.KeyIdentifier "salmon-test-vm") [Keys.Principal "root"] client)+    unless okSign (fail "ensureVmSshAccess: failed to sign the test client key")+    caPub <- readFile (Keys.publicKeyPath ca)+    let sshdDropinDir = rootfs </> "etc/ssh/sshd_config.d"+    createDirectoryIfMissing True sshdDropinDir+    writeFile (rootfs </> "etc/ssh/ca.pub") caPub+    writeFile+        (sshdDropinDir </> "99-salmon-test.conf")+        ( unlines+            [ "TrustedUserCAKeys /etc/ssh/ca.pub"+            , "PasswordAuthentication no"+            , "KbdInteractiveAuthentication no"+            ]+        )+    pure (Keys.privateKeyPath client)++-- | Every ssh call this harness makes against a booted VM goes through+-- this: explicit identity file (never an agent\/default identity, see+-- 'withVm's haddock), 'IdentitiesOnly' so ssh doesn't also try any other+-- key it happens to find first.+--+-- @ssh@ joins every element of 'args' with a single space and ships the+-- result as one string for the remote shell to tokenize — same as typing+-- the words after the hostname by hand at a terminal. That means an 'args'+-- element containing its own whitespace (a whole SQL statement, a+-- @cmd 2>&1@ redirection) does NOT arrive remotely as one token: the+-- remote shell re-splits it on spaces just like everything else, so e.g.+-- @["psql", "-tAc", "SELECT state FROM t;"]@ arrives as+-- @psql -tAc SELECT state FROM t;@ — @-tAc@ only captures @SELECT@, and+-- @state@\/@FROM@\/@t;@ become stray extra arguments. Callers that need an+-- element to survive as a single remote token (a full SQL statement, a+-- whole @bash -c@ script) must pre-quote it themselves with+-- 'quoteForRemoteShell' before it goes in 'args' — see that function's+-- haddock for why this isn't done unconditionally for every element here.+sshToVm :: VmAccess -> [String] -> IO (ExitCode, String, String)+sshToVm access args =+    readProcessWithExitCode+        "ssh"+        ( [ "-o"+          , "BatchMode=yes"+          , "-o"+          , "StrictHostKeyChecking=no"+          , "-o"+          , "UserKnownHostsFile=/dev/null"+          , "-o"+          , "IdentitiesOnly=yes"+          , "-i"+          , access.vmIdentityFile+          , Text.unpack (Ssh.loginAtHost access.vmRemote)+          ]+            <> args+        )+        ""++{- | Single-quotes a string so it survives 'sshToVm''s ssh-level space-join+as one remote token, e.g. a whole SQL statement or @bash -c@ script that+must not be re-split by the remote shell. Not applied to every 'sshToVm'+argument automatically: some existing callers (e.g. "Test.QemuSmokeSpec"'s+@sshToVm access ["echo smoke-ok"]@) rely on the remote shell's own+re-splitting to turn one Haskell-level string into several remote words,+same as typing @echo smoke-ok@ by hand — quoting unconditionally would+instead hand the remote shell one literal token @"echo smoke-ok"@ (a+program name with a space in it) and break that. Use this only for an+argument you specifically want to arrive remotely as a single word.+-}+quoteForRemoteShell :: String -> String+quoteForRemoteShell s = "'" <> concatMap (\c -> if c == '\'' then "'\\''" else [c]) s <> "'"++-- | Copies a local file onto the VM at the given remote path, using the+-- same identity\/options as 'sshToVm' (never an agent\/default identity).+-- Used to get a compiled fixture\/recipe binary onto the guest without+-- needing it preinstalled in the rootfs.+scpToVm :: VmAccess -> FilePath -> String -> IO ()+scpToVm access localPath remotePath = do+    (code, out, err) <-+        readProcessWithExitCode+            "scp"+            [ "-o"+            , "BatchMode=yes"+            , "-o"+            , "StrictHostKeyChecking=no"+            , "-o"+            , "UserKnownHostsFile=/dev/null"+            , "-o"+            , "IdentitiesOnly=yes"+            , "-i"+            , access.vmIdentityFile+            , localPath+            , Text.unpack (Ssh.loginAtHost access.vmRemote) <> ":" <> remotePath+            ]+            ""+    case code of+        ExitSuccess -> pure ()+        ExitFailure n ->+            error $+                "scpToVm " <> localPath <> " -> " <> remotePath <> " failed with exit " <> show n <> "\nstdout: " <> out <> "\nstderr: " <> err++-- | Polls SSH every two seconds (a VM takes real seconds to boot, unlike a+-- podman container being "up") for up to two minutes, then fails loudly+-- rather than hanging the test suite indefinitely — same "skip\/fail loudly,+-- don't hang" spirit as 'requireExecutable'.+waitForSsh :: VmAccess -> IO ()+waitForSsh access = go (60 :: Int)+  where+    go 0 = fail ("withVm: " <> show (Ssh.loginAtHost access.vmRemote) <> " never answered SSH within the timeout")+    go n = do+        (code, _, _) <- sshToVm access ["-o", "ConnectTimeout=2", "true"]+        case code of+            ExitSuccess -> pure ()+            _ -> threadDelay 2000000 >> go (n - 1)
+ test/Test/JWTSigningSpec.hs view
@@ -0,0 +1,79 @@+-- | Layer 0 (structural) + Layer 1 (sandboxed real IO) tests for+-- "SreBox.JWTSigning", picked as the first target because it is+-- self-contained: it only touches the filesystem, no daemons/root needed.+module Test.JWTSigningSpec (tests) where++import Control.Comonad.Cofree (Cofree (..))+import qualified Data.ByteString.Char8 as C8+import qualified Salmon.Actions.UpDown as UpDown+import qualified Salmon.Builtin.Nodes.Secrets as Secrets+import Salmon.Builtin.Extension (Op, evalDeps, ignoreTrack)+import Salmon.Op.Track (pureTracked)+import Salmon.Reporter (silent)+import qualified SreBox.JWTSigning as JWT+import System.Directory (doesFileExist)+import System.FilePath ((</>))+import Test.Harness+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase, (@?=))++tests :: TestTree+tests =+    testGroup+        "SreBox.JWTSigning"+        [ testCase "Layer 0: ref is stable and derived from the output path" layer0Ref+        , testCase "Layer 1: up writes a token file, a second up is a no-op" layer1UpIsIdempotent+        ]++-- A secret that is entirely test-managed: we write the raw key bytes+-- ourselves and hand it in via 'ignoreTrack', so the op under test has no+-- dependency to provision (mirrors how a real caller would pass in an+-- already-existing secret file).+mkOp :: FilePath -> FilePath -> Op+mkOp secretPath jwtPath =+    JWT.signHmac silent secretTracked "{\"sub\":\"test\"}" jwtPath+  where+    secret = Secrets.Secret Secrets.Hex 32 secretPath+    secretTracked = pureTracked ignoreTrack secret++layer0Ref :: IO ()+layer0Ref = do+    let o1 = mkOp "/tmp/does-not-matter-key" "/tmp/a.jwt"+        o2 = mkOp "/tmp/does-not-matter-key" "/tmp/a.jwt"+        o3 = mkOp "/tmp/does-not-matter-key" "/tmp/b.jwt"+        r1 :< _ = evalDeps o1+        r2 :< _ = evalDeps o2+        r3 :< _ = evalDeps o3+    -- same output path => same identity (so upTree dedups correctly)+    assertEqual "same jwtPath yields the same node" (show r1) (show r2)+    -- different output path => different identity+    assertBool "different jwtPath yields a different node" (show r1 /= show r3)++layer1UpIsIdempotent :: IO ()+layer1UpIsIdempotent = withTempDir $ \dir -> do+    let secretPath = dir </> "hmac.key"+        jwtPath = dir </> "token.jwt"+    -- test manages the secret material directly: 32 raw bytes, hex-decodable+    C8.writeFile secretPath (C8.replicate 64 'a')++    let o = mkOp secretPath jwtPath++    -- first up: the file doesn't exist yet, check must report Failure, and the+    -- token gets written for real+    reports1 <- runUpCapturing o+    assertBool "first up evaluates (file did not exist)" (any isEval reports1)+    exists1 <- doesFileExist jwtPath+    exists1 @?= True++    -- second up: skipIfFileExists now sees the file, check must skip, and+    -- content is left untouched (no re-signing)+    contentsAfterFirstUp <- C8.readFile jwtPath+    reports2 <- runUpCapturing o+    assertBool "second up is skipped (file now exists)" (any isSkip reports2 && not (any isEval reports2))+    contentsAfterSecondUp <- C8.readFile jwtPath+    contentsAfterSecondUp @?= contentsAfterFirstUp+  where+    isEval (UpDown.Eval _) = True+    isEval _ = False+    isSkip (UpDown.Skip _) = True+    isSkip _ = False
+ test/Test/LedgerSpec.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 0 coverage for 'Salmon.Op.Ledger': who still wants which nodes,+and which edges are still the description of how to take them down.++Pure throughout — a 'Ledger' holds nothing but 'Ref's and pairs of them, so+none of this needs a graph, an 'Salmon.Builtin.Extension.Op', or an effect.+The four cases in the middle are the four ways refcounting a node instead of+keeping a set goes wrong; they are here as tests rather than as a comment+because each of them is a bug someone would otherwise reintroduce.+-}+module Test.LedgerSpec (tests) where++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Text (Text)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import Salmon.Builtin.Extension (Op, deps, dynamics, evalDeps, help, nodeps, notes, op, ref)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Ledger (Contribution (..))+import qualified Salmon.Op.Ledger as Ledger+import Salmon.Op.Ref (Ref, mkRef)++tests :: TestTree+tests =+    testGroup+        "Salmon.Op.Ledger"+        [ testCase "a contribution is a graph's nodes and edges, flattened" contributionFromDag+        , testCase "two declarations wanting one node do not cancel out" unionNotCancel+        , testCase "a node reached twice in one graph is one membership" oneMembership+        , testCase "retracting what was never declared is a no-op" retractAbsent+        , testCase "re-declaring the same key replaces rather than adds" redeclareReplaces+        , testCase "a retraction keeps its edges but drops its refs from desired" retractKeepsEdges+        , testCase "collect drops a retired declaration once its nodes settle" collectSettled+        , testCase "collect never drops a live declaration" collectKeepsLive+        , testCase "`only` retires every other declaration" retractOthers+        ]++-------------------------------------------------------------------------------++refOf :: Text -> Ref+refOf = mkRef "ledgerspec"++leaf :: Text -> Op+leaf name = op name nodeps $ \x -> x{ref = refOf name}++over :: Text -> [Op] -> Op+over name ps = op name (deps ps) $ \x -> x{ref = refOf name}++contributionOf :: Op -> Contribution+contributionOf = Ledger.contribution . Dag.foldDag Dag.sameRepresentative . evalDeps++-------------------------------------------------------------------------------++contributionFromDag :: IO ()+contributionFromDag = do+    let c = contributionOf (over "root" [leaf "a", leaf "b"])+    assertEqual "all three nodes" (Set.fromList (map refOf ["root", "a", "b"])) c.contribRefs+    assertEqual+        "one edge per dependency, as (dependency, dependant)"+        (Set.fromList [(refOf "a", refOf "root"), (refOf "b", refOf "root")])+        c.contribEdges+    assertBool "and it starts live" c.contribLive++{- | The hazard: under refcounting, @down g1@ takes the shared node's count to+zero via a decrement that @g2@ never agreed to. Under sets, @g2@'s set still+has it.+-}+unionNotCancel :: IO ()+unionNotCancel = do+    let shared = leaf "shared"+        l =+            Ledger.declare "g2" (contributionOf (over "r2" [shared])) $+                Ledger.declare "g1" (contributionOf (over "r1" [shared])) Ledger.emptyLedger+        l' = Ledger.retract "g1" l+    assertBool "shared is still wanted by g2" (Set.member (refOf "shared") (Ledger.desired l'))+    assertBool "but g1's own node is not" (Set.notMember (refOf "r1") (Ledger.desired l'))++-- | The hazard: a diamond double-counts its apex, so one @down@ leaves it up.+oneMembership :: IO ()+oneMembership = do+    let apex = leaf "apex"+        c = contributionOf (over "root" [over "left" [apex], over "right" [apex]])+    assertEqual "four nodes, apex once" 4 (Set.size c.contribRefs)+    let l = Ledger.retract "g" (Ledger.declare "g" c Ledger.emptyLedger)+    assertEqual "and one retraction wants nothing" Set.empty (Ledger.desired l)++-- | The hazard: a decrement of a key that was never incremented goes negative.+retractAbsent :: IO ()+retractAbsent = do+    let l = Ledger.declare "g" (contributionOf (leaf "a")) Ledger.emptyLedger+    assertEqual "retracting a stranger changes nothing" l (Ledger.retract "other" l)++-- | The hazard: a second @up@ of the same seed takes the count to 2, so the+-- @down@ that follows leaves everything stranded up.+redeclareReplaces :: IO ()+redeclareReplaces = do+    let c = contributionOf (leaf "a")+        l = Ledger.declare "g" c (Ledger.declare "g" c Ledger.emptyLedger)+    assertEqual "one entry" 1 (Map.size l)+    assertEqual "and one retraction empties it" Set.empty (Ledger.desired (Ledger.retract "g" l))++{- | The reason edges live in the ledger at all: retracting is the moment the+teardown order matters most, so a retraction must not take the edges with it.+-}+retractKeepsEdges :: IO ()+retractKeepsEdges = do+    let c = contributionOf (over "root" [leaf "a"])+        l = Ledger.retract "g" (Ledger.declare "g" c Ledger.emptyLedger)+    assertEqual "nothing is wanted up any more" Set.empty (Ledger.desired l)+    assertEqual+        "but the edge saying root comes down before a is still there"+        (Set.fromList [(refOf "a", refOf "root")])+        (Ledger.precedenceOf l)+    assertEqual "and the nodes are still known" 2 (Set.size (Ledger.knownRefs l))++collectSettled :: IO ()+collectSettled = do+    let l = Ledger.retract "g" (Ledger.declare "g" (contributionOf (leaf "a")) Ledger.emptyLedger)+    assertEqual "kept while its node is still coming down" 1 (Map.size (Ledger.collect (const True) l))+    assertEqual "collected once it has settled" 0 (Map.size (Ledger.collect (const False) l))++collectKeepsLive :: IO ()+collectKeepsLive = do+    let l = Ledger.declare "g" (contributionOf (leaf "a")) Ledger.emptyLedger+    assertEqual+        "a live declaration is what holds its nodes up, however settled they are"+        1+        (Map.size (Ledger.collect (const False) l))++retractOthers :: IO ()+retractOthers = do+    let l =+            Ledger.declare "g2" (contributionOf (leaf "b")) $+                Ledger.declare "g1" (contributionOf (leaf "a")) Ledger.emptyLedger+        l' = Ledger.retractOthers "g2" l+    assertEqual "only g2 is live" (Set.singleton "g2") (Ledger.liveKeys l')+    assertEqual "so only b is wanted" (Set.singleton (refOf "b")) (Ledger.desired l')+    assertEqual "both are still known, for the teardown" 2 (Set.size (Ledger.knownRefs l'))
+ test/Test/LlamaServerSpec.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Coverage for "Salmon.Builtin.Nodes.LlamaServer".++Layer 0 is the argument rendering and the verdicts. The Layer 2 part needs no+model: a small warp server speaks what @llama-server@ was seen to speak+(@GET \/health@ with no key, @POST \/v1\/embeddings@ wanting a bearer key and+answering @data[0].embedding@), and 'llamaCheck' asks it with the real+@curl@ (skipped loudly without one) -- which is the part worth running for+real, since it is @curl@'s configuration syntax, on stdin, that carries the+key.+-}+module Test.LlamaServerSpec (tests) where++import Data.Aeson (Value, encode, object, (.=))+import qualified Data.ByteString.Char8 as C8+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.IO.Exception (ExitCode (..))+import qualified Network.HTTP.Types as HTTP+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)+import System.Posix.Files (setFileMode)+import System.FilePath ((</>))++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Nodes.LlamaServer+import Test.Harness (requireExecutable, withTempDir)++release :: LlamaRelease+release = LlamaRelease "b11195" "https://example.invalid/llama.tar.gz" "abc123" "/opt/llama"++model :: ModelFile+model = ModelFile "/var/lib/models/bge-small.gguf" "def456" Nothing++server :: LlamaServer+server = defaultLlamaServer "embed" release model 384 PoolCls++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Nodes.LlamaServer"+        [ testGroup+            "arguments"+            [ testCase "an embedding server on loopback, pooling explicit" $+                assertEqual+                    ""+                    ["-m", "/var/lib/models/bge-small.gguf", "--embedding", "--pooling", "cls", "--host", "127.0.0.1", "--port", "8080"]+                    (serverArgs server)+            , testCase "the key file is passed by path, and context and threads when given" $+                assertEqual+                    ""+                    ["--api-key-file", "/etc/llama.key", "-c", "512", "-t", "4"]+                    (drop 9 (serverArgs server{lsApiKeyFile = Just "/etc/llama.key", lsContext = Just 512, lsThreads = Just 4}))+            , testCase "a unix socket is a host with no port" $+                assertEqual "" ["--host", "/run/llama.sock"] (take 2 (drop 5 (serverArgs server{lsListen = UnixSocket "/run/llama.sock"})))+            , testCase "the binary is inside the archive's top directory" $+                assertEqual "" "/opt/llama/llama-b11195/llama-server" (llamaBinary release)+            ]+        , testGroup+            "verdicts"+            [ testCase "healthy" $ assertEqual "" Success (interpretHealth ExitSuccess 200)+            , testCase "not listening is a failure" $ assertEqual "" (Failure "llama-server is not listening") (interpretHealth (ExitFailure 7) 0)+            , testCase "a model still loading is cannot-tell, so it is waited out" $ assertEqual "" Unknown (interpretHealth ExitSuccess 503)+            , testCase "the right dimension" $ assertEqual "" Success (interpretEmbedding 3 200 embedding3)+            , testCase "the wrong dimension names both" $+                assertEqual "" (Failure "the model produces 3 dimensions, 384 declared") (interpretEmbedding 384 200 embedding3)+            , testCase "a refused key" $ assertEqual "" (Failure "the api key was refused") (interpretEmbedding 3 401 "{}")+            , testCase "an unreadable answer is cannot-tell" $ assertEqual "" Unknown (interpretEmbedding 3 200 "not json")+            , testCase "a dimension pgvector cannot index is noted, and one it can is not" $ do+                assertEqual "" Nothing (dimensionNote 384)+                assertEqual "" Nothing (dimensionNote 2000)+                assertBool "halfvec" (maybe False ("halfvec" `Text.isInfixOf`) (dimensionNote 3072))+                assertBool "truncate" (maybe False ("truncate" `Text.isInfixOf`) (dimensionNote 8192))+            ]+        , testCase "the key is in curl's stdin configuration and never its argv" $ do+            let cfg = curlConfig (Loopback 8080) "/v1/embeddings" (Just "{\"input\":\"x\"}") (Just "s3cret\"key")+            assertBool "in the config, quoted" ("header = \"Authorization: Bearer s3cret\\\"key\"" `Text.isInfixOf` cfg)+            assertBool "not in argv" (not (any ("s3cret" `isInfixOf'`) curlBase))+        , testCase "against a fake server, over the real curl: healthy, wrong width, wrong key, nobody home" fakeServer+        ]+  where+    embedding3 = "{\"data\":[{\"embedding\":[0.1,0.2,0.3],\"index\":0,\"object\":\"embedding\"}],\"object\":\"list\"}"+    isInfixOf' needle hay = Text.pack needle `Text.isInfixOf` Text.pack hay++-- | What @llama-server@ was seen to answer, with a key it insists on.+fakeApp :: Int -> Text -> IORef Bool -> Wai.Application+fakeApp dim key healthy req respond =+    case (Wai.requestMethod req, Wai.pathInfo req) of+        ("GET", ["health"]) -> do+            ok <- readIORef healthy+            respond (json (if ok then HTTP.status200 else HTTP.status503) (object ["status" .= ("ok" :: Text)]))+        ("POST", ["v1", "embeddings"])+            | lookup "Authorization" (Wai.requestHeaders req) == Just (C8.pack ("Bearer " <> Text.unpack key)) -> do+                body <- Wai.strictRequestBody req+                respond+                    ( json+                        HTTP.status200+                        (object ["object" .= ("list" :: Text), "data" .= [object ["index" .= (0 :: Int), "object" .= ("embedding" :: Text), "embedding" .= replicate dim (0.25 :: Double)]], "echo" .= (fromIntegral (length (show body)) :: Int)])+                    )+            | otherwise -> respond (json HTTP.status401 (object ["error" .= object ["message" .= ("Invalid API Key" :: Text), "code" .= (401 :: Int)]]))+        _ -> respond (json HTTP.status404 (object ["error" .= ("no" :: Text)]))+  where+    json st v = Wai.responseLBS st [(HTTP.hContentType, "application/json")] (encode (v :: Value))++fakeServer :: IO ()+fakeServer = requireExecutable "curl" $ withTempDir $ \tmp -> do+    healthy <- newIORef True+    let keyFile = tmp </> "key"+    writeFile keyFile "top-secret\n"+    setFileMode keyFile 0o600+    Warp.testWithApplication (pure (fakeApp 384 "top-secret" healthy)) $ \port -> do+        let s = server{lsListen = Loopback port, lsApiKeyFile = Just keyFile}+        assertEqual "healthy, the declared width" Success =<< llamaCheck s+        assertEqual+            "a model of another width"+            (Failure "the model produces 384 dimensions, 768 declared")+            =<< llamaCheck s{lsDimension = 768}+        writeFile keyFile "another-key\n"+        assertEqual "the file's key is not the server's" (Failure "the api key was refused") =<< llamaCheck s+        writeFile keyFile "top-secret\n"+        writeIORef healthy False+        assertEqual "still loading" Unknown =<< llamaCheck s+    -- the server is gone: refused connections+    assertEqual "nobody home" (Failure "llama-server is not listening") =<< llamaCheck server{lsListen = Loopback 1}
+ test/Test/MigratorTemplateSpec.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 3 for @salmon-migrator config template@: the real binary, on a real+Postgres, in a VM.++"Test.PostgresTemplateSpec" already covers the nodes against a container,+with a hand-written build. This covers what only the shipped binary can: that+the migrator's own graph -- cluster, owner role and password file, admin+migrations, owner migrations over TCP -- runs as the template's nested build,+and that what comes out is a template anybody can clone with plain SQL.++What the test drives, all inside the guest:++1. @config template … | run up@ from two migration files;+2. checks the result is locked, stamped, and refuses a connection;+3. runs it again and checks the template was __not__ rebuilt (same oid);+4. clones it with @CREATE DATABASE … TEMPLATE@ and looks inside: the row the+   owner migration wrote, the extension the superuser migration created, and+   the owner role still owning the table -- roles are cluster-wide, so a+   clone inherits the template's ownership rather than its creator's;+5. changes a migration, runs again, and checks the template __was__ rebuilt+   (new oid), a new clone sees the change, and the old clone does not.++= Prerequisites++Everything "Test.PgBackupSpec" needs except rsync (the binary goes over+@scp@), and a rootfs of its own for the reason given there -- two VMs on one+9p rootfs corrupt it:++> sudo mkdir -p /var/lib/salmon-test-vms/pg-template/root+> sudo rsync -aHAX --numeric-ids /var/lib/salmon-test-vms/pg-master/root/ /var/lib/salmon-test-vms/pg-template/root/+> sudo $(cabal list-bin salmon-qemu-host-setup-fixture) "$USER" /var/lib/salmon-test-vms/pg-template/root++and @cabal build salmon-migrator@ first. The guest has no route out, so every+package the migrator's graph installs must already be in the rootfs;+@pg-master@'s has them all (postgresql, postgresql-client, postgresql-common,+openssl).+-}+module Test.MigratorTemplateSpec (tests) where++import Control.Concurrent (threadDelay)+import Control.Monad (unless)+import Data.List (isInfixOf, isPrefixOf)+import qualified Data.Text as Text+import System.Directory (doesFileExist, findExecutable)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.Process (readProcessWithExitCode)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import Test.Harness (VmAccess (..), hasVmPrivileges, quoteForRemoteShell, scpToVm, sshToVm, testVmAddr4, withTempDir, withVmAt)++tests :: TestTree+tests =+    testGroup+        "salmon-migrator config template (Layer 3, a real database in a VM)"+        [ testCase "builds, skips, clones with plain SQL, and rebuilds on a changed migration" buildsAndRebuilds+        ]++-- | This spec's __own__ rootfs; see the module header.+rootfs :: FilePath+rootfs = "/var/lib/salmon-test-vms/pg-template/root"++templateDb, ownerRole, workDir :: String+templateDb = "fixture_tpl"+ownerRole = "fixture_owner"+workDir = "/root/tpl"++canaryRow :: String+canaryRow = "salmon-template-canary"++-------------------------------------------------------------------------------++buildsAndRebuilds :: IO ()+buildsAndRebuilds = requirePrereqs $ \binary ->+    withVmAt testVmAddr4 rootfs $ \vm -> withTempDir $ \tmp -> do+        waitForPostgres vm+        resetGuest vm++        run_ vm ["mkdir", "-p", workDir </> "migrations/superuser", workDir </> "migrations/owner"]+        scpToVm vm binary "/root/salmon-migrator"++        -- CREATE EXTENSION needs a superuser, so finding it in a clone shows+        -- the admin migrations went into the template too, not only the+        -- owner's.+        let superuser = "CREATE EXTENSION IF NOT EXISTS pgcrypto;\n"+            ownerV1 =+                unlines+                    [ "CREATE TABLE IF NOT EXISTS fixture (v text);"+                    , "INSERT INTO fixture VALUES ('" <> canaryRow <> "');"+                    ]+            ownerV2 = ownerV1 <> "CREATE TABLE IF NOT EXISTS fixture_two (v text);\n"+        upload vm tmp "superuser.sql" superuser (workDir </> "migrations/superuser/tip.sql")+        upload vm tmp "owner.sql" ownerV1 (workDir </> "migrations/owner/tip.sql")++        -- 1. build+        migrate vm+        (sql vm "postgres" (catalogQuery "datistemplate::text || '|' || datallowconn::text") >>=) $+            assertEqual "the template is locked" "true|false"+        comment <- sql vm "postgres" (catalogQuery "shobj_description(oid, 'pg_database')")+        assertBool ("the template is stamped with its inputs: " <> comment) ("salmon-template:" `isPrefixOf` comment)+        (code, _, err) <- sshToVm vm ["sudo", "-u", "postgres", "psql", "-d", templateDb, "-tAc", quoteForRemoteShell "SELECT 1"]+        assertBool "a locked template refuses a connection" (code /= ExitSuccess)+        assertBool ("and says why: " <> err) ("not currently accepting connections" `isInfixOf` err)++        -- 2. unchanged inputs are not rebuilt+        built <- templateOid vm+        migrate vm+        (templateOid vm >>=) $ assertEqual "unchanged migrations leave the template as it was" built++        -- 3. clone with plain SQL, as any consumer would+        run_ vm ["sudo", "-u", "postgres", "psql", "-tAc", quoteForRemoteShell ("CREATE DATABASE fixture_copy TEMPLATE " <> templateDb)]+        (sql vm "fixture_copy" "SELECT v FROM fixture" >>=) $+            assertEqual "the owner migration's row is in the copy" canaryRow+        (sql vm "fixture_copy" "SELECT extname FROM pg_extension WHERE extname = 'pgcrypto'" >>=) $+            assertEqual "the superuser migration's extension is in the copy" "pgcrypto"+        (sql vm "fixture_copy" "SELECT tableowner FROM pg_tables WHERE tablename = 'fixture'" >>=) $+            assertEqual "the copy keeps the template's owner, not its creator" ownerRole++        -- 4. a changed migration rebuilds+        upload vm tmp "owner.sql" ownerV2 (workDir </> "migrations/owner/tip.sql")+        migrate vm+        rebuilt <- templateOid vm+        assertBool "a changed migration rebuilds the template" (rebuilt /= built)+        run_ vm ["sudo", "-u", "postgres", "psql", "-tAc", quoteForRemoteShell ("CREATE DATABASE fixture_copy_two TEMPLATE " <> templateDb)]+        (sql vm "fixture_copy_two" "SELECT count(*) FROM pg_tables WHERE tablename = 'fixture_two'" >>=) $+            assertEqual "a new copy sees the change" "1"+        (sql vm "fixture_copy_two" "SELECT count(*) FROM fixture" >>=) $+            assertEqual "rebuilt from nothing: the row is written once, not twice" "1"+        (sql vm "fixture_copy" "SELECT count(*) FROM pg_tables WHERE tablename = 'fixture_two'" >>=) $+            assertEqual "an existing copy was taken once, and does not" "0"+  where+    catalogQuery :: String -> String+    catalogQuery col = "SELECT " <> col <> " FROM pg_database WHERE datname = '" <> templateDb <> "'"++    templateOid vm = sql vm "postgres" (catalogQuery "oid::text")++{- | @config template … | run up@, run inside the guest from its work+directory, so the migration paths in the directive are the guest's.+-}+migrate :: VmAccess -> IO ()+migrate vm =+    run_+        vm+        [ "bash"+        , "-c"+        , quoteForRemoteShell $+            unwords+                [ "set -eo pipefail;"+                , "cd " <> workDir <> ";"+                , "/root/salmon-migrator config template"+                , "--superuser-root migrations/superuser"+                , "--owner-root migrations/owner"+                , "--db " <> templateDb+                , "--db-owner " <> ownerRole+                , "--db-passfile " <> workDir <> "/owner.pass"+                , "> directive.json;"+                , "/root/salmon-migrator run up < directive.json"+                ]+        ]++upload :: VmAccess -> FilePath -> FilePath -> String -> FilePath -> IO ()+upload vm tmp name contents remote = do+    writeFile (tmp </> name) contents+    scpToVm vm (tmp </> name) remote++-- | One value, as the @postgres@ OS user.+sql :: VmAccess -> String -> String -> IO String+sql vm db query = do+    (code, out, err) <- sshToVm vm ["sudo", "-u", "postgres", "psql", "-X", "-d", db, "-tAc", quoteForRemoteShell query]+    unless (code == ExitSuccess) $+        assertBool ("query failed on " <> db <> ": " <> query <> "\n" <> err) False+    pure (filter (/= '\n') out)++run_ :: VmAccess -> [String] -> IO ()+run_ vm args = do+    (code, out, err) <- sshToVm vm args+    unless (code == ExitSuccess) $+        assertBool ("command failed in the guest: " <> show args <> "\n--- stdout ---\n" <> lastLines out <> "\n--- stderr ---\n" <> err) False+  where+    -- `run up` reports every node; the failure is at the end+    lastLines = unlines . reverse . take 40 . reverse . lines++{- | Undoes whatever a previous run left in the rootfs, which persists (9p).++The role goes too, not only the databases: the migrator creates it with the+password in the pass file, and never changes the password of a role that+already exists, so a fresh pass file against a surviving role fails the+owner migrations on authentication.+-}+resetGuest :: VmAccess -> IO ()+resetGuest vm = do+    let psql q = run_ vm ["sudo", "-u", "postgres", "psql", "-X", "-tAc", quoteForRemoteShell q]+    psql "DROP DATABASE IF EXISTS fixture_copy WITH (FORCE)"+    psql "DROP DATABASE IF EXISTS fixture_copy_two WITH (FORCE)"+    -- a DO block rather than \\gexec: psql -c will not mix SQL with a meta-command+    psql ("DO $$ BEGIN IF EXISTS (SELECT FROM pg_database WHERE datname = '" <> templateDb <> "') THEN ALTER DATABASE " <> templateDb <> " IS_TEMPLATE false; END IF; END $$")+    psql ("DROP DATABASE IF EXISTS " <> templateDb <> " WITH (FORCE)")+    psql ("DROP ROLE IF EXISTS " <> ownerRole)+    run_ vm ["rm", "-rf", workDir]++-- | As in "Test.PgBackupSpec": sshd answering says nothing about Postgres.+waitForPostgres :: VmAccess -> IO ()+waitForPostgres vm = go (30 :: Int)+  where+    go 0 = fail "postgres never accepted a connection in the VM"+    go n = do+        (code, _, _) <- sshToVm vm ["sudo", "-u", "postgres", "psql", "-tAc", quoteForRemoteShell "SELECT 1"]+        if code == ExitSuccess+            then pure ()+            else threadDelay 2000000 >> go (n - 1)++-------------------------------------------------------------------------------++requirePrereqs :: (FilePath -> IO ()) -> IO ()+requirePrereqs act = do+    privileged <- hasVmPrivileges+    qemu <- findExecutable "qemu-system-x86_64"+    scp <- findExecutable "scp"+    rootfsOk <- doesFileExist (rootfs </> "etc/issue")+    case () of+        _+            | not privileged -> skip "no VM privileges (run salmon-qemu-host-setup-fixture, or use sudo)"+            | Nothing <- qemu -> skip "qemu-system-x86_64 not on PATH"+            | Nothing <- scp -> skip "scp not on PATH on the host"+            | not rootfsOk ->+                skip+                    ( "no rootfs at "+                        <> rootfs+                        <> ". It must be this spec's own (two VMs on one 9p rootfs corrupt it). Build it with:\n"+                        <> "  sudo mkdir -p "+                        <> rootfs+                        <> "\n  sudo rsync -aHAX --numeric-ids /var/lib/salmon-test-vms/pg-master/root/ "+                        <> rootfs+                        <> "/\n  sudo $(cabal list-bin salmon-qemu-host-setup-fixture) \"$USER\" "+                        <> rootfs+                    )+            | otherwise -> resolveBinary >>= act++skip :: String -> IO ()+skip why = putStrLn ("SKIPPED: " <> why)++-- | @cabal list-bin@, last non-blank line: under sudo, cabal prints notices first.+resolveBinary :: IO FilePath+resolveBinary = do+    (code, out, err) <- readProcessWithExitCode "cabal" ["list-bin", "salmon-migrator"] ""+    case (code, reverse (filter (not . null) (lines out))) of+        (ExitSuccess, path : _) -> pure path+        _ -> error ("could not locate salmon-migrator (build it first): " <> err)
+ test/Test/PatroniHarnessSpec.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 3: the harness itself. Done when three guests answer ssh with the+Patroni, etcd and HAProxy binaries present (@specs\/pg-patroni.md@). Every+later scenario (T1..T7) starts from 'withPatroniVms', so this is the test+that says the ground is there.++Skips loudly if the rootfses were never built; see "Test.PatroniVms".+-}+module Test.PatroniHarnessSpec (tests) where++import Test.PatroniVms+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertEqual, testCase)++tests :: TestTree+tests =+    testGroup+        "Patroni harness (Layer 3, three guests)"+        [ testCase "three guests answer ssh with patroni, etcd and haproxy installed" guestsCarryBinaries+        ]++guestsCarryBinaries :: IO ()+guestsCarryBinaries = requirePatroniVmPrereqs $+    withPatroniVms $ \vms -> do+        assertEqual "three guests" 3 (length vms)+        missing <- mapM missingBinaries vms+        assertEqual "binaries missing per guest" [[], [], []] missing
+ test/Test/PatroniVms.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE OverloadedStrings #-}++{- | What the Patroni Layer 3 specs share: three guests booted at once on the+test bridge, each carrying @postgresql@, @patroni@, @etcd-server@ and+@haproxy@, and a way to start every scenario from the same state+(@specs\/pg-patroni.md@, "Disaster scenarios").++The rootfses are built by @salmon-patroni-rootfs@ (see @PatroniRootfs@ in+salmon-apps), because the guests cannot reach the network past boot:++> sudo $(cabal list-bin salmon-patroni-rootfs) config prereqs | sudo $(cabal list-bin salmon-patroni-rootfs) run up++As in "Test.PostgresVms", a rootfs is a host directory that outlives its VM,+so a scenario that killed a leader leaves the next one a cluster with a+history. 'withPatroniVms' therefore /normalizes/ each guest on the way in+('resetGuest') instead of assuming a blank machine: it stops the three+services and removes what they persist (etcd's data, Patroni's cluster+directory, the Postgres cluster the package created). It starts nothing:+what runs where is the scenario's declaration.+-}+module Test.PatroniVms (+    patroniRootfs,+    patroniAddrs,+    requirePatroniVmPrereqs,+    withPatroniVms,+    resetGuest,+    requiredBinaries,+    missingBinaries,+) where++import Control.Monad (forM, unless)+import Data.Text (Text)+import System.Directory (doesFileExist, findExecutable)+import System.Exit (ExitCode (..))+import System.IO (hPutStrLn, stderr)++import Test.Harness++-- | One rootfs per guest, numbered from 1.+patroniRootfs :: [FilePath]+patroniRootfs =+    [ "/var/lib/salmon-test-vms/patroni-" <> show n <> "/root"+    | n <- [1 .. 3 :: Int]+    ]++-- | The guests' addresses on the shared test bridge, in the order of 'patroniRootfs'.+patroniAddrs :: [Text]+patroniAddrs = [testVmAddr, testVmAddr2, testVmAddr3]++{- | Skips loudly rather than failing when the machine cannot run these:+qemu, the bridge privileges, and the three rootfses.+-}+requirePatroniVmPrereqs :: IO () -> IO ()+requirePatroniVmPrereqs act = do+    privileged <- hasVmPrivileges+    hasQemu <- (/= Nothing) <$> findExecutable "qemu-system-x86_64"+    present <- forM patroniRootfs $ \r -> (,) r <$> doesFileExist (r <> "/etc/issue")+    case () of+        _+            | not privileged -> skip "needs root, or ip/qemu-system-x86_64 setcap'd (see Test.Harness.hasVmPrivileges)"+            | not hasQemu -> skip "qemu-system-x86_64 not found on PATH"+            | ((r, _) : _) <- filter (not . snd) present ->+                skip ("no VM rootfs at " <> r <> " (build them with salmon-patroni-rootfs, see Test.PatroniVms)")+            | otherwise -> act+  where+    skip msg = hPutStrLn stderr ("SKIPPED: " <> msg)++{- | Boots the three guests (nested 'withVmAt's, so all three are torn down+however the action exits), normalizes each, and hands over their accesses in+the order of 'patroniAddrs'.+-}+withPatroniVms :: ([VmAccess] -> IO a) -> IO a+withPatroniVms act =+    withVmAt (patroniAddrs !! 0) (patroniRootfs !! 0) $ \a ->+        withVmAt (patroniAddrs !! 1) (patroniRootfs !! 1) $ \b ->+            withVmAt (patroniAddrs !! 2) (patroniRootfs !! 2) $ \c -> do+                let vms = [a, b, c]+                mapM_ resetGuest vms+                act vms++{- | Puts one guest in the state every scenario starts from: the three+services stopped and disabled from starting on their own (the Debian+packages start a cluster and an etcd on install, and a rootfs remembers), and+everything they persist removed.++Removing the Postgres cluster is what lets Patroni initialize its own: it+refuses a data directory that already holds a cluster it did not create. The+etcd data directory goes for the same reason from the other side, since a+stale member list makes a fresh three-member cluster refuse to bootstrap.+-}+resetGuest :: VmAccess -> IO ()+resetGuest vm = do+    (code, out, err) <-+        sshToVm+            vm+            [ "bash"+            , "-c"+            , quoteForRemoteShell . unwords $+                [ "set -e;"+                , "systemctl stop patroni haproxy etcd postgresql 2>/dev/null || true;"+                , "systemctl disable patroni haproxy etcd 2>/dev/null || true;"+                , "pkill -u postgres 2>/dev/null || true;"+                , "rm -rf /var/lib/etcd/* /var/lib/postgresql/*/main /etc/postgresql/*/main;"+                , "rm -f /etc/patroni/*.yml /etc/patroni.yml"+                ]+            ]+    unless (code == ExitSuccess) (fail ("could not normalize a guest: " <> out <> err))++-- | The binaries each guest must have: the "done" condition for the harness.+requiredBinaries :: [String]+requiredBinaries = ["patroni", "patronictl", "etcd", "etcdctl", "haproxy", "pg_ctlcluster", "psql"]++-- | Which of 'requiredBinaries' this guest lacks, checked the way a shell would find them.+missingBinaries :: VmAccess -> IO [String]+missingBinaries vm = do+    results <- forM requiredBinaries $ \bin -> do+        (code, _, _) <- sshToVm vm ["bash", "-c", quoteForRemoteShell ("command -v " <> bin)]+        pure (if code == ExitSuccess then [] else [bin])+    pure (concat results)
+ test/Test/PgBackupSpec.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 3 for @salmon-pg-backup@: a real Postgres in a real VM, dumped by+a binary that uploads itself to reach it.++This is the tier that can actually answer the question the binary exists to+answer. Layer 0 can check that the generated script says @pipefail@; only a+machine with a database on it can show that the dump is a dump, that it+arrived, and that it contains the row that was written before it was taken.++What the test drives, end to end:++1. boot a VM from the Postgres rootfs and create a database with one known row;+2. run @salmon-pg-backup --action dump --over root\@\<vm\>@ __from the host__,+   which rsyncs the binary into the guest, runs it there over ssh with a+   directive, and pulls the resulting dump back;+3. gunzip the fetched file and look for the row;+4. run the same binary with @--action schedule@ and check the guest now has+   a @\/etc\/cron.d@ entry.++= Prerequisites++Everything "Test.PostgresReplicationSpec" needs (see its header: a+debootstrapped rootfs, @qemu-system-x86_64@, and either root or the+capability grant from @salmon-qemu-host-setup-fixture@), plus a rootfs of its+own:++> sudo mkdir -p /var/lib/salmon-test-vms/pg-backup/root+> sudo rsync -aHAX --numeric-ids /var/lib/salmon-test-vms/pg-master/root/ /var/lib/salmon-test-vms/pg-backup/root/+> sudo chroot /var/lib/salmon-test-vms/pg-backup/root apt-get install -y rsync+> sudo $(cabal list-bin salmon-qemu-host-setup-fixture) "$USER" /var/lib/salmon-test-vms/pg-backup/root++(the @mkdir@ is not optional: @rsync@ creates the last component of a+destination path and no more, so without it the copy fails on the missing+parent and every later step fails on the missing rootfs.)++and the binary built first (@cabal build salmon-pg-backup@), the same way the+replication fixture must be.++= Why a rootfs of its own++__A rootfs must never back two VMs that are up at the same time.__ It is+exported over 9p in @passthrough@ mode, so the guest writes straight into the+host directory with no locking whatsoever; two kernels mounting it read and+write the same bytes, and the first casualty is the Postgres data directory.+This test was originally pointed at @pg-primary@, which+"Test.PostgresReplicationSpec" also boots, and the pair of them destroyed+that cluster's checkpoint record — @PANIC: could not locate a valid+checkpoint record@, repaired only by re-syncing the rootfs from+@pg-master@.++Serializing the VM specs (see @test/Main.hs@) makes the overlap unlikely+rather than impossible, because a VM that leaks past its own teardown is+still up when the next one starts. Separate rootfses make it harmless.++The @rsync@ requirement is this test's own: 'Self' uploads over rsync and the+fetch pulls back the same way, and the test bridge has no route to the+internet, so nothing can be installed at test time.+-}+module Test.PgBackupSpec (tests) where++import Control.Concurrent (threadDelay)+import Control.Monad (unless)+import Data.List (isInfixOf)+import System.Directory (doesFileExist, findExecutable, listDirectory)+import System.Environment (getEnv)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import qualified Data.Text as Text+import System.Process (CreateProcess (..), proc, readCreateProcessWithExitCode, readProcessWithExitCode)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase)++import Test.Harness (VmAccess (..), hasVmPrivileges, quoteForRemoteShell, sshToVm, testVmAddr3, withTempDir, withVmAt)++tests :: TestTree+tests =+    testGroup+        "salmon-pg-backup (Layer 3, a real database in a VM)"+        [ testCase "dumps over ssh, fetches the dump back, and installs a schedule" dumpsAndSchedules+        ]++{- | This test's __own__ rootfs — never one another VM spec boots. See the+module header for why that is not a preference.+-}+pgRootfs :: FilePath+pgRootfs = "/var/lib/salmon-test-vms/pg-backup/root"++testDatabase :: String+testDatabase = "backup_test"++-- | Written before the dump, looked for inside it afterwards.+canaryRow :: String+canaryRow = "salmon-backup-canary-42"++-------------------------------------------------------------------------------++dumpsAndSchedules :: IO ()+dumpsAndSchedules = requirePrereqs $ \binary ->+    -- An address of this spec's own, for the same reason as the rootfs: a+    -- VM still shutting down on a shared address answers for the next one,+    -- and ssh reports a connection closed by a host that is not under test.+    withVmAt testVmAddr3 pgRootfs $ \vm -> withTempDir $ \tmp -> do+        -- `withVm` waits for sshd, which says nothing about Postgres: the+        -- cluster is still replaying when the first psql lands, and answers+        -- "the database system is starting up".+        waitForPostgres vm++        -- The rootfs is exported over 9p in passthrough mode, so everything+        -- the guest writes lands in the host directory and survives the VM.+        -- Without this the second run of this test fails on CREATE DATABASE,+        -- and -- worse -- its cron assertion passes on the entry the *first*+        -- run installed, which is a test that no longer tests anything.+        resetGuest vm++        -- A database whose contents we know, so "the dump contains this" is a+        -- statement about the dump rather than about the fixture.+        run_ vm ["sudo", "-u", "postgres", "psql", "-tAc", quoteForRemoteShell ("CREATE DATABASE " <> testDatabase)]+        run_+            vm+            [ "sudo"+            , "-u"+            , "postgres"+            , "psql"+            , "-d"+            , testDatabase+            , "-tAc"+            , quoteForRemoteShell ("CREATE TABLE canary (v text); INSERT INTO canary VALUES ('" <> canaryRow <> "')")+            ]++        let identity = vm.vmIdentityFile+            common =+                [ "--database"+                , testDatabase+                , "--over"+                , "root@" <> vmAddr+                , "--ssh-identity"+                , identity+                , "--ssh-known-hosts"+                , tmp </> "known_hosts"+                , "--remote-dir"+                , "/root"+                , "--dir"+                , "/var/backups/postgresql"+                ]++        -- 1. dump, driven from here+        salmon binary (common <> ["--action", "dump", "--fetch-into", tmp </> "dumps"])++        fetched <- listDirectory (tmp </> "dumps")+        assertBool ("nothing was fetched into " <> (tmp </> "dumps")) (not (null fetched))+        let dump = tmp </> "dumps" </> head fetched+        assertBool ("fetched file is not named like a dump: " <> dump) (".sql.gz" `isInfixOf` dump)++        -- gunzip -t would only say it is a valid archive; a failed pg_dump+        -- piped into gzip produces one of those too. The row is the assertion.+        (code, out, err) <- readProcessWithExitCode "zcat" [dump] ""+        assertBool ("zcat failed on " <> dump <> ": " <> err) (code == ExitSuccess)+        assertBool+            ("the dump does not contain the canary row; first 500 bytes:\n" <> take 500 out)+            (canaryRow `isInfixOf` out)++        -- 2. install the periodic job on the same machine+        salmon binary (common <> ["--action", "schedule"])++        (cronCode, cronOut, _) <- sshToVm vm ["cat", "/etc/cron.d/salmon-pg-backup-" <> testDatabase]+        assertBool "the cron entry was not installed in the guest" (cronCode == ExitSuccess)+        assertBool+            ("the cron entry does not run the backup script: " <> cronOut)+            (("backup-" <> testDatabase <> ".sh") `isInfixOf` cronOut)+  where+    vmAddr = Text.unpack testVmAddr3++-- | A setup step that failed silently would make the real assertion fail much+-- later and much less clearly.+run_ :: VmAccess -> [String] -> IO ()+run_ vm args = do+    (code, out, err) <- sshToVm vm args+    unless (code == ExitSuccess) $+        assertBool ("setup command failed: " <> show args <> "\n" <> out <> "\n" <> err) False++{- | Undoes everything a previous run of this test left in the rootfs.++Not a nicety: a persistent rootfs turns "the cron entry is present" from an+assertion about this run into an assertion about the first run that ever+passed.+-}+resetGuest :: VmAccess -> IO ()+resetGuest vm = do+    run_ vm ["rm", "-f", "/etc/cron.d/salmon-pg-backup-" <> testDatabase]+    run_ vm ["rm", "-rf", "/var/backups/postgresql"]+    run_ vm ["sudo", "-u", "postgres", "psql", "-tAc", quoteForRemoteShell ("DROP DATABASE IF EXISTS " <> testDatabase)]++{- | Polls until the cluster accepts a connection, 30 × 2s.++Separate from the harness's own wait because they are different questions+with different answers: sshd is up within a second or two of boot, and+Postgres takes as long as its last shutdown left it needing.+-}+waitForPostgres :: VmAccess -> IO ()+waitForPostgres vm = go (30 :: Int)+  where+    go 0 = fail "postgres never accepted a connection in the VM"+    go n = do+        (code, _, _) <- sshToVm vm ["sudo", "-u", "postgres", "psql", "-tAc", quoteForRemoteShell "SELECT 1"]+        if code == ExitSuccess+            then pure ()+            else threadDelay 2000000 >> go (n - 1)++{- | Runs @salmon-pg-backup config … | salmon-pg-backup run up@, the two-phase+protocol every salmon binary speaks, and fails loudly with both streams.+-}+salmon :: FilePath -> [String] -> IO ()+salmon binary args = do+    (code, directive, err) <- runSalmon binary ("config" : args) ""+    unless (code == ExitSuccess) $+        assertBool ("config rejected " <> show args <> ":\n" <> err) False+    (upCode, upOut, upErr) <- runSalmon binary ["run", "up"] directive+    unless (upCode == ExitSuccess) $+        assertBool+            ( "run up failed for "+                <> show args+                <> "\n--- directive ---\n"+                <> directive+                <> "\n--- stdout ---\n"+                <> upOut+                <> "\n--- stderr ---\n"+                <> upErr+            )+            False++{- | Runs the binary with a __clean PATH__ rather than this process's.++Not fussiness. "Test.PostgresInitSpec" shims @apt-get@ and @dpkg-query@ onto+@PATH@ so a recipe's package nodes act on its podman sandbox instead of the+developer's machine, and @PATH@ is process-global: a subprocess spawned from+this test inherits whatever is in effect. The symptom is memorable —+salmon's own @deb@ nodes report++> E: Could not get lock /var/lib/dpkg/lock-frontend. It is held by process 1269++naming a PID that does not exist on the host, because the apt-get really ran+inside somebody else's container.+-}+runSalmon :: FilePath -> [String] -> String -> IO (ExitCode, String, String)+runSalmon binary args input = do+    -- the real HOME: ssh reads it even when told which identity to use+    home <- getEnv "HOME"+    readCreateProcessWithExitCode+        (proc binary args){env = Just [("PATH", "/usr/local/bin:/usr/bin:/bin:/usr/sbin:/sbin"), ("HOME", home)]}+        input++-------------------------------------------------------------------------------++{- | Every reason this test cannot run, each announced rather than failing.++Layer 3 is opt-in by having built the machine for it; a developer who has+not should see why, not a red test.+-}+requirePrereqs :: (FilePath -> IO ()) -> IO ()+requirePrereqs act = do+    privileged <- hasVmPrivileges+    qemu <- findExecutable "qemu-system-x86_64"+    rootfsOk <- doesFileExist (pgRootfs </> "etc/issue")+    -- Self uploads over rsync and the fetch pulls over rsync, and the test+    -- bridge has no internet, so it cannot be installed at test time.+    guestRsync <- anyExists [pgRootfs </> "usr/bin/rsync", pgRootfs </> "bin/rsync"]+    hostRsync <- findExecutable "rsync"+    hostSsh <- findExecutable "ssh"+    case () of+        _+            | not privileged -> skip "no VM privileges (run salmon-qemu-host-setup-fixture, or use sudo)"+            | Nothing <- qemu -> skip "qemu-system-x86_64 not on PATH"+            | not rootfsOk ->+                skip+                    ( "no rootfs at "+                        <> pgRootfs+                        <> ". It must be this spec's own (two VMs on one 9p rootfs corrupt it). Build it with:\n"+                        <> "  sudo mkdir -p "+                        <> pgRootfs+                        <> "\n  sudo rsync -aHAX --numeric-ids /var/lib/salmon-test-vms/pg-master/root/ "+                        <> pgRootfs+                        <> "/\n  sudo chroot "+                        <> pgRootfs+                        <> " apt-get install -y rsync\n"+                        <> "  sudo $(cabal list-bin salmon-qemu-host-setup-fixture) \"$USER\" "+                        <> pgRootfs+                    )+            | not guestRsync ->+                skip+                    ( "the guest rootfs has no rsync; salmon uploads itself with it and there is no route out of the test bridge. Fix with:\n"+                        <> "  sudo chroot "+                        <> pgRootfs+                        <> " apt-get install -y rsync"+                    )+            | Nothing <- hostRsync -> skip "rsync not on PATH on the host"+            | Nothing <- hostSsh -> skip "ssh not on PATH on the host"+            | otherwise -> resolveBinary >>= act++anyExists :: [FilePath] -> IO Bool+anyExists paths = or <$> traverse doesFileExist paths++skip :: String -> IO ()+skip why = putStrLn ("SKIPPED: " <> why)++{- | @cabal list-bin@, taking the last non-blank line: under sudo, cabal+prints notices before the path.+-}+resolveBinary :: IO FilePath+resolveBinary = do+    (code, out, err) <- readProcessWithExitCode "cabal" ["list-bin", "salmon-pg-backup"] ""+    case (code, reverse (filter (not . null) (lines out))) of+        (ExitSuccess, path : _) -> pure path+        _ -> error ("could not locate salmon-pg-backup (build it first): " <> err)
+ test/Test/PgBouncerSpec.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 0 coverage for "Salmon.Builtin.Nodes.PgBouncer"'s rendering.++Two of the fields here exist for @specs\/pg-switchover.md@ phase 4, and both+are about the same thing: moving traffic without dropping it. The admin+console is how a pause and a reload are asked for at all, and the routing+file is what keeps the node that moves traffic from fighting the node that+owns the service -- the ini is watched, so a change to it is applied by a+restart, and a restart drops every client the bouncer is holding.+-}+module Test.PgBouncerSpec (tests) where++import Data.List (isInfixOf)+import qualified Data.Text as Text+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import qualified Salmon.Builtin.Nodes.PgBouncer as PgBouncer++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Nodes.PgBouncer"+        [ testCase "a database line says where its upstream is" $+            assertBool ini ("app = host=10.0.0.1 port=5432 dbname=app" `isInfixOf` ini)+        , testCase "the admin console is opened to the users named, and nobody else" $ do+            assertBool ini ("admin_users = router" `isInfixOf` ini)+            assertBool minimalIni (not ("admin_users" `isInfixOf` minimalIni))+        , -- an include pgbouncer cannot read is a service that will not start+          testCase "the routing file is included when there is one" $ do+            assertBool ini ("%include /etc/pgbouncer/routing.ini" `isInfixOf` ini)+            assertBool minimalIni (not ("%include" `isInfixOf` minimalIni))+        , -- the whole point of the seam: this node restarts on a change to+          -- what it watches, and the routing file must never be that.+          testCase "and it is not one of the files a change to which restarts the service" $+            assertEqual+                ""+                ["/etc/pgbouncer/pgbouncer.ini", "/etc/pgbouncer/userlist.txt"]+                [PgBouncer.configPath cfg, PgBouncer.userlistPath cfg]+        ]+  where+    ini = Text.unpack (PgBouncer.renderIni cfg)+    minimalIni = Text.unpack (PgBouncer.renderIni cfg{PgBouncer.bouncer_admin_users = [], PgBouncer.bouncer_routing_file = Nothing})++cfg :: PgBouncer.BouncerConfig+cfg =+    PgBouncer.BouncerConfig+        { PgBouncer.bouncer_config_dir = "/etc/pgbouncer"+        , PgBouncer.bouncer_listen_addr = "0.0.0.0"+        , PgBouncer.bouncer_listen_port = 6432+        , PgBouncer.bouncer_databases = [PgBouncer.BouncerDatabase "app" (PgBouncer.UpstreamDb "10.0.0.1" 5432 "app")]+        , PgBouncer.bouncer_users = [PgBouncer.AuthUser "router" "hunter2"]+        , PgBouncer.bouncer_pool_mode = PgBouncer.TransactionPooling+        , PgBouncer.bouncer_max_client_conn = 100+        , PgBouncer.bouncer_default_pool_size = 20+        , PgBouncer.bouncer_admin_users = ["router"]+        , PgBouncer.bouncer_routing_file = Just "/etc/pgbouncer/routing.ini"+        }
+ test/Test/PgPairDemoSpec.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 3, and the demo: three machines, a client that never stops+writing, and a primary that moves twice underneath it.++This is scenario S1 of @specs\/pg-switchover.md@ with the half that was+missing until pgbouncer was wired up -- /the client saw zero errors/ -- and+it drives the @salmon-pgpair@ binary rather than the library, because the+claim being made is about what an operator types:++> salmon-pgpair config --primary A ... | salmon-pgpair run up+> salmon-pgpair config --primary B ... | salmon-pgpair run up++Nothing else changes between those two lines. What the pair does about them+-- stop the old primary cleanly, promote the new one, rewind the old one+onto it, and hold the clients for as long as that takes -- is the recipe's+business, and the client's only evidence of it is a pause.++The machines are the two Postgres rootfses the other specs use, plus a third+with pgbouncer on it:++> sudo debootstrap --include=linux-image-amd64,openssh-server,pgbouncer,postgresql-client stable /var/lib/salmon-test-vms/pg-bouncer/root++followed by 'Salmon.Builtin.Nodes.Debian.Debootstrap.ensureVm9pBoot' on it,+same as the others.++What the test does /not/ do for you is provision secrets, because the recipe+does not either: the @.pgpass@ files and pgbouncer's @userlist.txt@ are put+in place here the way a deployment would put them there, and salmon is+handed paths.+-}+module Test.PgPairDemoSpec (tests) where++import Control.Monad (forM_, unless)+import Data.List (isInfixOf)+import qualified Data.Text as Text+import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode)+import Test.Harness+import Test.PostgresVms+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++tests :: TestTree+tests =+    testGroup+        "salmon-pgpair (Layer 3, a primary moved under a live client)"+        [ testCase "a client writing through pgbouncer sees a pause, not an error" clientKeepsWriting+        ]++bouncerRootfs :: FilePath+bouncerRootfs = "/var/lib/salmon-test-vms/pg-bouncer/root"++appPassword, consolePassword :: String+appPassword = "demo-app-password"+consolePassword = "demo-console-password"++clientKeepsWriting :: IO ()+clientKeepsWriting = requirePgVmPrereqs $ requireBouncerRootfs $ do+    binary <- resolvePgPairBinary+    withVmAt testVmAddr primaryRootfs $ \a ->+        withVmAt testVmAddr2 standbyRootfs $ \b ->+            withVmAt testVmAddr3 bouncerRootfs $ \bouncer -> do+                -- what a deployment provisions, and salmon is only given paths to+                mapM_ provisionMemberSecrets [a, b]+                provisionBouncerSecrets bouncer++                -- a machine with a database on it, and a machine with nothing+                ensurePrimary a+                resetCluster b+                psqlOrDie a "DROP DATABASE IF EXISTS app;"+                psqlOrDie a "CREATE DATABASE app;"+                -- created if missing, and its password set either way: a+                -- role left over from something else with a password of its+                -- own is drift, and the failure it causes is an+                -- authentication error a long way from here.+                psqlOrDie a "DO $$ BEGIN CREATE ROLE app LOGIN; EXCEPTION WHEN duplicate_object THEN NULL; END $$;"+                psqlOrDie a ("ALTER ROLE app LOGIN PASSWORD '" <> appPassword <> "';")+                sshOrDie a ["bash", "-c", quoteForRemoteShell ("sudo -u postgres psql -d app -c " <> quoteForRemoteShell "CREATE TABLE IF NOT EXISTS canary (n int primary key); GRANT ALL ON canary TO app;")]+                appendHba a "host all app 10.99.0.4/32 md5"+                appendHba b "host all app 10.99.0.4/32 md5"++                -- one command stands the whole thing up+                runPgPair binary (a, b, bouncer) ["--primary", "A", "--seed", "B"]+                assertPrimaryIs a+                assertStandbyOf b testVmAddr++                startClient bouncer+                waitForClientProgress bouncer 10++                -- and one word of it moves the primary, twice+                runPgPair binary (a, b, bouncer) ["--primary", "B"]+                assertPrimaryIs b+                waitForClientProgress bouncer 10++                runPgPair binary (a, b, bouncer) ["--primary", "A"]+                assertPrimaryIs a+                waitForClientProgress bouncer 10++                (acknowledged, failures, stderrs) <- stopClient bouncer+                assertBool+                    ( "the client saw "+                        <> show (length failures)+                        <> " failed inserts (of "+                        <> show (length acknowledged + length failures)+                        <> "), the first few being "+                        <> show (take 5 failures)+                        <> "; what they said:\n"+                        <> unlines (take 6 (lines stderrs))+                    )+                    (null failures)+                assertBool "the client never got anywhere" (length acknowledged > 20)++                -- every insert the client was told had happened, did+                missing <- rowsMissing a acknowledged+                assertEqual+                    ("acknowledged but absent after the switchovers: " <> show (take 20 missing))+                    []+                    missing++                -- the demo's whole point, in three numbers+                putStrLn ""+                putStrLn ("  inserts acknowledged through the bouncer: " <> show (length acknowledged))+                putStrLn ("  client errors across two switchovers:     " <> show (length failures))+                putStrLn ("  acknowledged rows missing afterwards:     " <> show (length missing))++-------------------------------------------------------------------------------++{- | Runs the binary the way the demo does: a seed on one side of a pipe, a+directive on the other.+-}+runPgPair :: FilePath -> (VmAccess, VmAccess, VmAccess) -> [String] -> IO ()+runPgPair binary (a, b, bouncer) args = do+    let common =+            [ "--a"+            , Text.unpack testVmAddr+            , "--b"+            , Text.unpack testVmAddr2+            , "--bouncer"+            , Text.unpack testVmAddr3+            , -- one key per guest, because this harness mints a CA per guest;+              -- a deployment passes --ssh-identity once+              "--ssh-identity-a"+            , vmIdentityFile a+            , "--ssh-identity-b"+            , vmIdentityFile b+            , "--ssh-identity-bouncer"+            , vmIdentityFile bouncer+            , "--ssh-known-hosts"+            , "/dev/null"+            ]+    (code, directive, err) <- readProcessWithExitCode binary ("config" : args <> common) ""+    unless (code == ExitSuccess) (fail ("salmon-pgpair config failed: " <> err))+    (upCode, out, upErr) <- readProcessWithExitCode binary ["run", "up"] directive+    unless (upCode == ExitSuccess) (fail ("salmon-pgpair run up " <> unwords args <> " failed:\n" <> out <> upErr))++resolvePgPairBinary :: IO FilePath+resolvePgPairBinary = do+    (code, out, err) <- readProcessWithExitCode "cabal" ["list-bin", "salmon-pgpair"] ""+    case (code, filter (not . null) (lines out)) of+        (ExitSuccess, ls@(_ : _)) -> pure (last ls)+        _ -> fail ("could not find salmon-pgpair; build it first\n" <> err)++{- | Skips loudly rather than failing, and distinguishes the two ways this+rootfs is not ready -- because the second one fails a long way from its+cause: a guest whose initrd cannot mount a 9p root panics at boot, and what+the test sees is an ssh that never connects.+-}+requireBouncerRootfs :: IO () -> IO ()+requireBouncerRootfs act = do+    there <- fileExists (bouncerRootfs <> "/etc/issue")+    bootable <- grepQuiet "9pnet_virtio" (bouncerRootfs <> "/etc/initramfs-tools/modules")+    -- the harness signs a CA into the guest's sshd config before boot, and+    -- that write happens on the host as whoever runs the tests+    writableSsh <- writable (bouncerRootfs <> "/etc/ssh")+    case () of+        _+            | not there ->+                skip ("no VM rootfs at " <> bouncerRootfs <> " (see this module's haddock for the debootstrap)")+            | not writableSsh ->+                skip+                    ( bouncerRootfs+                        <> "/etc/ssh is not writable: the harness puts its SSH CA there before the guest boots."+                        <> " chown it to whoever runs the tests, as the other rootfses have it"+                    )+            | not bootable ->+                skip+                    ( bouncerRootfs+                        <> " cannot boot its root over 9p: run Salmon.Builtin.Nodes.Debian.Debootstrap.ensureVm9pBoot"+                        <> " on it, as the other rootfses have had"+                    )+            | otherwise -> act+  where+    skip msg = putStrLn ("SKIPPED: " <> msg)+    fileExists path = do+        (code, _, _) <- readProcessWithExitCode "test" ["-e", path] ""+        pure (code == ExitSuccess)+    writable path = do+        (code, _, _) <- readProcessWithExitCode "test" ["-w", path] ""+        pure (code == ExitSuccess)+    grepQuiet needle path = do+        (code, _, _) <- readProcessWithExitCode "grep" ["-q", needle, path] ""+        pure (code == ExitSuccess)++-------------------------------------------------------------------------------+-- What a deployment provisions, and this recipe never ships.++provisionMemberSecrets :: VmAccess -> IO ()+provisionMemberSecrets vm =+    forM_+        [ ("/etc/postgresql/salmon-replication.pgpass", "replicator", "fixture-replication-password")+        , ("/etc/postgresql/salmon-rewind.pgpass", "rewinder", "fixture-rewind-password")+        ]+        $ \(path, role, pwd) ->+            sshOrDie+                vm+                [ "bash"+                , "-c"+                , quoteForRemoteShell . unwords $+                    [ "set -e;"+                    , "printf '*:*:*:" <> role <> ":" <> pwd <> "\\n' > " <> path <> ";"+                    , "chown postgres:postgres " <> path <> ";"+                    , "chmod 0600 " <> path+                    ]+                ]++{- | The bouncer's own secrets: the console password the pair uses to pause+it, and the userlist both it and the client authenticate against.+-}+provisionBouncerSecrets :: VmAccess -> IO ()+provisionBouncerSecrets vm =+    sshOrDie+        vm+        [ "bash"+        , "-c"+        , quoteForRemoteShell . unlines $+            [ "set -e"+            , "mkdir -p /etc/pgbouncer"+            , "md5() { printf 'md5%s' \"$(printf '%s%s' \"$2\" \"$1\" | md5sum | cut -d' ' -f1)\"; }"+            , "{"+            , "  printf '\"router\" \"%s\"\\n' \"$(md5 router " <> consolePassword <> ")\""+            , "  printf '\"app\" \"%s\"\\n' \"$(md5 app " <> appPassword <> ")\""+            , "} > /tmp/userlist.txt"+            , "printf '*:*:*:router:" <> consolePassword <> "\\n' > /etc/pgbouncer/console.pgpass"+            , "printf '*:*:*:app:" <> appPassword <> "\\n' > /root/app.pgpass"+            , "chmod 0600 /etc/pgbouncer/console.pgpass /root/app.pgpass"+            , "chown postgres:postgres /etc/pgbouncer/console.pgpass"+            , -- pgbouncer reads its auth file when it starts and not again,+              -- so a userlist written under a running process is a password+              -- that does not work yet. Only when it changed: a restart+              -- otherwise drops the very clients this test is watching.+              "if ! cmp -s /tmp/userlist.txt /etc/pgbouncer/userlist.txt; then"+            , "  install -m 0644 -o postgres -g postgres /tmp/userlist.txt /etc/pgbouncer/userlist.txt"+            , "  systemctl restart pgbouncer"+            , "fi"+            , "rm -f /tmp/userlist.txt"+            ]+        ]++appendHba :: VmAccess -> String -> IO ()+appendHba vm line =+    sshOrDie+        vm+        [ "bash"+        , "-c"+        , quoteForRemoteShell . unwords $+            [ "set -e;"+            , "version=$(pg_lsclusters --no-header | awk '{print $1}' | head -n1);"+            , "hba=/etc/postgresql/$version/main/pg_hba.conf;"+            , "grep -qxF '" <> line <> "' \"$hba\" || echo '" <> line <> "' >> \"$hba\";"+            , "pg_ctlcluster \"$version\" main reload"+            ]+        ]++-------------------------------------------------------------------------------+-- The client: one insert at a time, through the bouncer, recording what it+-- was told had happened.++startClient :: VmAccess -> IO ()+startClient vm = do+    sshOrDie+        vm+        [ "bash"+        , "-c"+        , quoteForRemoteShell . unlines $+            [ "set -e"+            , -- every one of them, including the failures: a rootfs outlives+              -- its VM, so a file left behind here is read by the next run as+              -- evidence about itself. Leaving client.fail out of this list+              -- cost an afternoon -- eleven failures that no error text ever+              -- explained, because the errors were cleared and the failures+              -- were not.+              "rm -f /root/client.ok /root/client.fail /root/client.err /root/client.stop"+            , "cat > /root/client.sh <<'CLIENT'"+            , "#!/bin/bash"+            , "n=0"+            , "export PGPASSFILE=/root/app.pgpass"+            , -- Debian's psql is a perl wrapper, and perl complains to+              -- stderr about every locale it cannot find. Left alone it+              -- writes two lines of noise per insert into the file this test+              -- reads for evidence.+              "export LANG=C LC_ALL=C"+            , "while [ ! -e /root/client.stop ]; do"+            , "  n=$((n+1))"+            , "  if out=$(psql -h 127.0.0.1 -p 6432 -U app -d app -v ON_ERROR_STOP=1 -tAXc \"INSERT INTO canary VALUES ($n)\" 2>&1); then"+            , "    echo \"$n\" >> /root/client.ok"+            , "  else"+            , "    echo \"$n\" >> /root/client.fail"+            , "    echo \"$n: $out\" >> /root/client.err"+            , "  fi"+            , "  sleep 0.2"+            , "done"+            , "CLIENT"+            , "chmod +x /root/client.sh"+            , "setsid /root/client.sh >/dev/null 2>&1 </dev/null &"+            ]+        ]++-- | Waits until the client has had at least @n@ more inserts acknowledged.+waitForClientProgress :: VmAccess -> Int -> IO ()+waitForClientProgress vm n = do+    before <- countOk vm+    waitForUpTo 60 ("the client stopped making progress past " <> show before) $ do+        now <- countOk vm+        pure (now >= before + n, show now <> " acknowledged")++countOk :: VmAccess -> IO Int+countOk vm = do+    (_, out, _) <- sshToVm vm ["bash", "-c", quoteForRemoteShell "wc -l < /root/client.ok 2>/dev/null || echo 0"]+    pure (maybe 0 fst (listToMaybe (reads (takeWhile (/= '\n') out))))+  where+    listToMaybe [] = Nothing+    listToMaybe (x : _) = Just x++{- | Stops it, and says what it was told: the inserts acknowledged, the ones+that failed, and whatever the client wrote to stderr.++A failure is an insert that came back non-zero, not a line on stderr --+Debian's psql is a perl wrapper that warns there about locales, which says+nothing about whether the write happened.+-}+stopClient :: VmAccess -> IO ([String], [String], String)+stopClient vm = do+    sshOrDie vm ["bash", "-c", quoteForRemoteShell "touch /root/client.stop; sleep 2"]+    (_, ok, _) <- sshToVm vm ["bash", "-c", quoteForRemoteShell "cat /root/client.ok 2>/dev/null"]+    (_, failed, _) <- sshToVm vm ["bash", "-c", quoteForRemoteShell "cat /root/client.fail 2>/dev/null"]+    (_, errs, _) <- sshToVm vm ["bash", "-c", quoteForRemoteShell "cat /root/client.err 2>/dev/null"]+    pure (lines ok, filter (not . null) (lines failed), errs)++-- | Of the inserts the client was told had happened, which are not there.+rowsMissing :: VmAccess -> [String] -> IO [String]+rowsMissing vm acknowledged = do+    (code, out, err) <- sshToVm vm ["bash", "-c", quoteForRemoteShell "sudo -u postgres psql -d app -tAXc 'SELECT n FROM canary ORDER BY n'"]+    unless (code == ExitSuccess) (fail ("could not read the canary table: " <> out <> err))+    let present = words out+    pure [n | n <- acknowledged, n `notElem` present]
+ test/Test/PgVectorSpec.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 0 coverage for "Salmon.Builtin.Nodes.PgVector" and the+'Salmon.Builtin.Nodes.Postgres.extension' node under it: the SQL it renders+(the version floor comes first, the drop has no @CASCADE@), the verdict drawn+from the catalogue, and the shape of the graph (one package however many+databases, the repository only when a caller supplied one).+-}+module Test.PgVectorSpec (tests) where++import Data.Functor.Identity (runIdentity)+import Data.List (nub)+import qualified Data.Text as Text+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Actions.Query (pathedNodes)+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Debian.AptRepository (pgdg, viaRepository)+import Salmon.Builtin.Nodes.Debian.Package (Package (..))+import Salmon.Builtin.Nodes.PgVector+import Salmon.Builtin.Nodes.Postgres+import Salmon.Op.Eval (expand)+import Salmon.Op.Track (Track (..))+import Salmon.Reporter (silent)++ext :: PgExtension+ext = PgExtension{extName = "vector", extDatabase = "app", extMinServerVersion = Just 130000, extUpgrade = False}++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Nodes.PgVector"+        [ testGroup+            "SQL"+            [ testCase "the version floor is checked before the extension is created" $ do+                let sql = createExtensionSql ext+                    (before, after) = Text.breakOn "CREATE EXTENSION" sql+                assertBool "floor first" ("server_version_num')::int < 130000" `Text.isInfixOf` before)+                assertBool "create present" ("CREATE EXTENSION IF NOT EXISTS \"vector\";" `Text.isPrefixOf` after)+            , testCase "no floor, no check" $+                assertBool "" (not ("server_version_num" `Text.isInfixOf` createExtensionSql ext{extMinServerVersion = Nothing}))+            , testCase "an upgrade is only issued when asked" $ do+                assertBool "" (not ("UPDATE" `Text.isInfixOf` createExtensionSql ext))+                assertBool "" ("ALTER EXTENSION \"vector\" UPDATE;" `Text.isInfixOf` createExtensionSql ext{extUpgrade = True})+            , testCase "the drop has no CASCADE" $+                assertEqual "" "DROP EXTENSION IF EXISTS \"vector\";\n" (dropExtensionSql ext)+            , testCase "a hostile extension name is quoted" $+                assertBool "" ("\"a\"\"b\"" `Text.isInfixOf` createExtensionSql ext{extName = "a\"b"})+            ]+        , testGroup+            "interpretExtensionRow"+            [ testCase "absent is missing" $+                assertEqual "" (Failure "extension vector is not installed in app") (interpretExtensionRow ext "")+            , testCase "present is satisfied" $+                assertEqual "" Success (interpretExtensionRow ext "0.8.0|0.8.6\n")+            , testCase "older than the package is reported only when upgrading" $ do+                assertEqual "" Success (interpretExtensionRow ext "0.7.4|0.8.6")+                assertEqual "" (Failure "extension vector is at 0.7.4, the package has 0.8.6") (interpretExtensionRow ext{extUpgrade = True} "0.7.4|0.8.6")+            , testCase "versions compare numerically, not as text" $+                assertEqual "" Success (interpretExtensionRow ext{extUpgrade = True} "0.10.0|0.9.9")+            , testCase "no package default means nothing to upgrade to" $+                assertEqual "" Success (interpretExtensionRow ext{extUpgrade = True} "0.7.4|")+            ]+        , testGroup+            "graph"+            [ testCase "the package name follows the declared major" $+                assertEqual "" (Package "postgresql-16-pgvector") (pgvectorPackage 16)+            , testCase "the only package is the versioned pgvector one" $+                assertEqual "" [Package "postgresql-16-pgvector"] (nub (packagesOf (node ignoreTrack)))+            , testCase "a supplied source is part of the graph, and ignoreTrack leaves it out" $ do+                let withRepo = node (viaRepository (pgdg "/k/pgdg.asc" "AAAA"))+                assertBool "repo node present" (any ("apt index" `Text.isInfixOf`) (shorthands withRepo))+                assertBool "no repo node" (not (any ("apt index" `Text.isInfixOf`) (shorthands (node ignoreTrack))))+            ]+        ]+  where+    node source =+        pgvector silent silent ignoreTrack source ignoreTrack (PgVector 16 5432 ["app", "other"] False)+    packagesOf :: Op -> [Package]+    packagesOf = concatMap snd . collectDynamics+    shorthands :: Op -> [Text.Text]+    shorthands o = [h | (_, _, h) <- pathedNodes (runIdentity (expand o))]
+ test/Test/PlakarSpec.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Coverage for "Salmon.Builtin.Nodes.Plakar".++Layer 0 is the verdicts, the refusals and the rendered script. Layer 2 runs a+real @plakar@ if there is one on PATH (skipped loudly otherwise): it makes a+store through the node, runs the generated script, and reads the freshness+verdict off a real listing, empty store included -- the parts whose format+this module could only get right by running plakar.+-}+module Test.PlakarSpec (tests) where++import qualified Data.ByteString.Char8 as C8+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.Time (UTCTime (..), addUTCTime, getCurrentTime)+import Data.Time.Calendar (fromGregorian)+import GHC.IO.Exception (ExitCode (..))+import System.Directory (createDirectoryIfMissing, doesFileExist)+import Control.Exception (finally)+import System.Environment (lookupEnv, setEnv, unsetEnv)+import System.FilePath ((</>))+import System.Posix.Files (setFileMode)+import System.Process (readProcessWithExitCode)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension (ignoreTrack)+import Salmon.Builtin.Nodes.CronTask (dailyAt)+import Salmon.Builtin.Nodes.Plakar+import Test.Harness++now :: UTCTime+now = UTCTime (fromGregorian 2026 9 26) 36000 -- 2026-09-26T10:00:00Z++store :: KlosetStore+store = KlosetStore "/var/backups/kloset" "/etc/plakar.key"++job :: PlakarJob+job = PlakarJob "nightly" store "/srv/data" (dailyAt "3" "17") "root" (keepDays 30) (26 * 3600) "/opt/salmon/plakar/nightly.sh"++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Nodes.Plakar"+        [ testGroup+            "verdicts"+            [ testCase "version is found among the welcome text" $+                assertEqual "" Success (interpretVersion "1.1.7" "Welcome to plakar !\n\nEOT\nplakar/v1.1.7\n")+            , testCase "another version is not the wanted one" $+                assertEqual "" (Failure "plakar is not at 1.1.7") (interpretVersion "1.1.7" "plakar/v1.1.6\n")+            , testCase "a snapshot inside the limit is fresh" $+                assertEqual "" Success (interpretSnapshotList now (26 * 3600) ExitSuccess "2026-09-25T20:00:00Z   28ff740a       6 B        0s /srv/data\n" "")+            , testCase "an old one is reported with its age and the limit" $+                assertEqual+                    ""+                    (Failure "newest snapshot is 30h old, the limit is 26h")+                    (interpretSnapshotList now (26 * 3600) ExitSuccess "2026-09-25T04:00:00Z   28ff740a       6 B        0s /srv/data\n" "")+            , testCase "the welcome text before the listing is skipped" $+                assertEqual "" Success (interpretSnapshotList now (26 * 3600) ExitSuccess "Welcome to plakar !\n2026-09-26T09:00:00Z   28ff740a   6 B  0s /d\n" "")+            , testCase "nothing printed, nothing said: the store has no snapshot" $+                assertEqual "" (Failure "the store has no snapshot") (interpretSnapshotList now 3600 ExitSuccess "" "")+            , testCase "nothing printed and stderr complaining: cannot tell (plakar exits 0 when its cache process fails)" $+                assertEqual "" Unknown (interpretSnapshotList now 3600 ExitSuccess "" "plakar: failed to run cached\n")+            , testCase "a failing listing is cannot tell" $+                assertEqual "" Unknown (interpretSnapshotList now 3600 (ExitFailure 77) "" "failed to unlock repository")+            ]+        , testGroup+            "refusals"+            [ testCase "an empty keyfile" $ assertEqual "" (Just "is empty") (keyfileProblem 0 0o600)+            , testCase "a keyfile others can read" $+                assertBool "" (keyfileProblem 32 0o640 /= Nothing)+            , testCase "an owner-only keyfile is fine" $ assertEqual "" Nothing (keyfileProblem 32 0o400)+            , testCase "a retention policy needs a rule" $+                assertBool "" (either (const True) (const False) (pruneArgs (KeepPolicy Nothing Nothing Nothing)))+            , testCase "a retention rule must be positive" $+                assertBool "" (either (const True) (const False) (pruneArgs (keepDays 0)))+            , testCase "the rules become prune filters" $+                assertEqual "" (Right ["-hours", "6", "-days", "30"]) (pruneArgs (KeepPolicy (Just 6) (Just 30) Nothing))+            ]+        , testGroup+            "script"+            [ testCase "backs up, insists on the success line, then prunes with the declared policy" $ do+                let s = renderBackupScript job ["-days", "30"]+                    ls = Text.lines s+                assertBool "strict shell" ("set -euo pipefail" `elem` ls)+                assertBool "backup" (any ("backup '/srv/data'" `Text.isInfixOf`) ls)+                assertBool "success line" (any ("completed without errors" `Text.isInfixOf`) ls)+                assertEqual "prune last" "plakar -keyfile '/etc/plakar.key' at '/var/backups/kloset' prune -days 30 -apply" (last ls)+            , testCase "a path with a quote is quoted" $+                assertBool "" ("'/srv/it'\\''s'" `Text.isInfixOf` renderBackupScript job{jobSource = "/srv/it's"} ["-days", "1"])+            , testCase "the digest is lower-case hex" $+                assertEqual "" "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" (sha256Hex "")+            ]+        , testCase "a job with no retention rule is refused rather than run" $+            assertBool "" (either (const True) (const False) (pruneArgs (jobKeep job{jobKeep = KeepPolicy Nothing Nothing Nothing})))+        , testCase "against a real plakar: store, backup script, freshness" realPlakar+        ]++realPlakar :: IO ()+realPlakar = requireExecutable "plakar" $ withTempDir $ \tmp -> do+  -- the suite runs in one process: put HOME back for whoever runs next+  oldHome <- lookupEnv "HOME"+  (`finally` maybe (unsetEnv "HOME") (setEnv "HOME") oldHome) $ do+      -- plakar's cache process listens on a unix socket under $HOME/.cache, so+      -- the path must stay short.+      let home = tmp </> "h"+          st = KlosetStore (tmp </> "s") (tmp </> "key")+          empty = KlosetStore (tmp </> "e") (tmp </> "key")+          src = tmp </> "d"+      createDirectoryIfMissing True home+      createDirectoryIfMissing True src+      setEnv "HOME" home+      writeFile (src </> "a.txt") "hello\n"+      writeFile (tmp </> "key") "correct horse battery staple, at some length\n"+      setFileMode (tmp </> "key") 0o600+      ok1 <- runUp (kloset ignoreTrack st)+      ok2 <- runUp (kloset ignoreTrack empty)+      assertBool "stores made" (ok1 && ok2)+      made <- doesFileExist (tmp </> "s" </> "CONFIG")+      assertBool "CONFIG written" made+      let script = tmp </> "job.sh"+          j = job{jobStore = st, jobSource = src, jobScriptPath = script}+      Text.writeFile script (renderBackupScript j ["-days", "1"])+      (code, _, err) <- readProcessWithExitCode "bash" [script] ""+      assertEqual ("script: " <> err) ExitSuccess code+      t <- getCurrentTime+      (_, out, lerr) <- readProcessWithExitCode "plakar" ["-keyfile", tmp </> "key", "at", tmp </> "s", "ls", "-latest"] ""+      assertEqual "fresh after the script" Success (interpretSnapshotList t 3600 ExitSuccess (Text.pack out) (Text.pack lerr))+      assertEqual "stale an hour on" (Failure "newest snapshot is 2h old, the limit is 1h") (interpretSnapshotList (addUTCTime 7200 t) 3600 ExitSuccess (Text.pack out) (Text.pack lerr))+      (_, out2, lerr2) <- readProcessWithExitCode "plakar" ["-keyfile", tmp </> "key", "at", tmp </> "e", "ls", "-latest"] ""+      assertEqual "empty store" (Failure "the store has no snapshot") (interpretSnapshotList t 3600 ExitSuccess (Text.pack out2) (Text.pack lerr2))
+ test/Test/PodmanCommandSpec.hs view
@@ -0,0 +1,50 @@+{- | Layer 0 coverage for "Salmon.Builtin.Nodes.Podman"'s command rendering --+pure, so it needs no real @podman@ (that's what @Test.PodmanSpec@, Layer 2,+is for).+-}+module Test.PodmanCommandSpec (tests) where++import System.Process (CmdSpec (..), cmdspec)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertEqual, testCase)++import Salmon.Builtin.Nodes.Binary (Command (..))+import qualified Salmon.Builtin.Nodes.Podman as Podman++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Nodes.Podman.podmanCommand"+        [ testCase "push with no authfile runs `podman push <tag>`, the same tag build produced" pushRendersTagNoAuth+        , testCase "push with an authfile passes --authfile to push, not to podman itself" pushRendersTagWithAuth+        , testCase "logout targets the same authfile login wrote to" logoutRendersAuthFile+        , testCase "rmi tolerates an image that is already gone" rmiIgnoresMissing+        ]++pushRendersTagNoAuth :: IO ()+pushRendersTagNoAuth =+    assertEqual+        ""+        (RawCommand "podman" ["push", "us-docker.pkg.dev/p/r/img:1"])+        (cmdspec (prepare Podman.podmanCommand (Podman.Push Nothing "us-docker.pkg.dev/p/r/img:1")))++pushRendersTagWithAuth :: IO ()+pushRendersTagWithAuth =+    assertEqual+        ""+        (RawCommand "podman" ["push", "--authfile", "/tmp/auth.json", "us-docker.pkg.dev/p/r/img:1"])+        (cmdspec (prepare Podman.podmanCommand (Podman.Push (Just (Podman.AuthFile "/tmp/auth.json")) "us-docker.pkg.dev/p/r/img:1")))++logoutRendersAuthFile :: IO ()+logoutRendersAuthFile =+    assertEqual+        ""+        (RawCommand "podman" ["logout", "--authfile", "/tmp/auth.json", "us-docker.pkg.dev"])+        (cmdspec (prepare Podman.podmanCommand (Podman.Logout (Podman.AuthFile "/tmp/auth.json") (Podman.Registry "us-docker.pkg.dev"))))++rmiIgnoresMissing :: IO ()+rmiIgnoresMissing =+    assertEqual+        ""+        (RawCommand "podman" ["rmi", "--ignore", "us-docker.pkg.dev/p/r/img:1"])+        (cmdspec (prepare Podman.podmanCommand (Podman.RmiTag "us-docker.pkg.dev/p/r/img:1")))
+ test/Test/PodmanSpec.hs view
@@ -0,0 +1,33 @@+-- | Layer 2: real system-service testing, dogfooded through the project's+-- own Podman nodes ("Salmon.Builtin.Nodes.Podman") instead of hand-rolled+-- shell-outs. Container lifecycle itself (bring-up, id recovery, teardown)+-- lives in "Test.Harness"."withContainer" so other Layer 2 tests can reuse+-- it (see "Test.PostgresInitSpec" for a heavier recipe sandboxed this way).+--+-- The Podman builtins currently only expose 'up' (pull/build/run) and have+-- no 'down' — there is nothing to reuse for teardown, so "withContainer"+-- manages cleanup itself via raw @podman rm -f@. That gap is itself a+-- finding: any recipe that provisions containers via these nodes has no+-- accompanying teardown story yet.+module Test.PodmanSpec (tests) where++import Data.List (isInfixOf)+import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode)+import Test.Harness+import qualified Salmon.Builtin.Nodes.Podman as Podman+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase)++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Nodes.Podman (Layer 2, dogfooded)"+        [ testCase "pullImage + runContainer bring up a real, reachable container" pullAndRun+        ]++pullAndRun :: IO ()+pullAndRun = requireExecutable "podman" $+    withContainer (Podman.Image "alpine:latest") (Podman.PortMapping "18080" "80" Podman.TCPPort) $ \cid -> do+        (code, out, _) <- readProcessWithExitCode "podman" ["inspect", "--format", "{{.State.Running}}", cid] ""+        assertBool "podman reports the container as Running" (code == ExitSuccess && "true" `isInfixOf` out)
+ test/Test/PostgresBackupSpec.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 0 coverage for "SreBox.PostgresBackup".++Two things are worth testing without a database, and they are the two things+that go wrong in practice. The first is the /script/: it is generated text+that ends up running unattended as @postgres@, so what matters is that it+parses, that values are quoted, and above all that it sets @pipefail@ — the+hand-written version of this script checks @$?@ after @pg_dump | gzip@, which+is gzip's status, so a failed dump is stored as a valid archive and reported+as a success. The second is 'interpretBackupAge', which is the whole of the+"is there actually a recent backup" verdict.+-}+module Test.PostgresBackupSpec (tests) where++import Data.List (isInfixOf)+import qualified Data.Text as Text+import Data.Time (UTCTime (..), addUTCTime, fromGregorian, secondsToDiffTime)+import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import Salmon.Actions.UpDown (CheckResult (..))+import qualified Salmon.Builtin.Nodes.CronTask as Cron+import qualified Salmon.Builtin.Nodes.Postgres as Postgres+import qualified SreBox.PostgresBackup as Backup++tests :: TestTree+tests =+    testGroup+        "SreBox.PostgresBackup"+        [ testGroup "the generated script" scriptTests+        , testGroup "interpretBackupAge" freshnessTests+        , testGroup "schedules" scheduleTests+        ]++script :: Backup.PgBackupConfig -> String+script = Text.unpack . Backup.renderBackupScript++plain :: Backup.PgBackupConfig+plain = Backup.defaultBackupConfig "newco_api" (Just "newco_api_owner")++shipped :: Backup.PgBackupConfig+shipped = plain{Backup.pgb_gcs = Just (Backup.GcsDestination "acme-backups" "newco/api")}++scriptTests :: [TestTree]+scriptTests =+    [ testCase "sets pipefail, so a failed pg_dump is not stored as a valid archive" $+        -- The regression this whole module exists around: `pg_dump | gzip`+        -- followed by a check of $? tests gzip, not pg_dump.+        assertBool (script plain) ("set -euo pipefail" `isInfixOf` script plain)+    , testCase "the default connects over the unix socket as postgres, where peer auth lives" $ do+        -- Naming 127.0.0.1 turns the same call into TCP, which pg_hba wants a+        -- password for -- the most common way a backup job on the database+        -- host fails.+        let s = script plain+        assertBool s ("sudo -u 'postgres' pg_dump" `isInfixOf` s)+        assertBool s (not ("-h " `isInfixOf` s))+    , testCase "a TCP server and role are passed when asked for" $ do+        let s = script plain{Backup.pgb_server = Just (Postgres.Server "db.example" 5433), Backup.pgb_sudoUser = Nothing}+        assertBool s ("-h 'db.example'" `isInfixOf` s)+        assertBool s ("-p 5433" `isInfixOf` s)+        assertBool s ("-U 'newco_api_owner'" `isInfixOf` s)+        assertBool s (not ("sudo" `isInfixOf` s))+    , testCase "prunes only this database's dumps, by the configured age" $ do+        let s = script plain+        assertBool s ("-name 'newco_api_*.sql.gz'" `isInfixOf` s)+        assertBool s ("-mtime +7 -delete" `isInfixOf` s)+    , testCase "a database name that would break out of quoting cannot" $ do+        let s = script plain{Backup.pgb_database = "db'; rm -rf / #"}+        assertBool s ("'db'\\''; rm -rf / #'" `isInfixOf` s)+    , testCase "no bucket means no upload" $+        assertBool (script plain) (not ("gcloud storage cp" `isInfixOf` script plain))+    , testCase "the upload names the bucket and prefix" $+        assertBool (script shipped) ("gcloud storage cp \"$BACKUP_FILE\" 'gs://acme-backups/newco/api/'" `isInfixOf` script shipped)+    , testCase "an empty prefix does not produce a doubled slash" $ do+        let s = script plain{Backup.pgb_gcs = Just (Backup.GcsDestination "acme-backups" "")}+        assertBool s ("'gs://acme-backups/'" `isInfixOf` s)+    , testCase "the upload happens before the prune" $ do+        -- Ordering is load-bearing: under `set -e` a failed upload stops the+        -- script, so a dump that never reached the bucket is still on disk.+        let s = script shipped+            Just uploadAt = substringIndex "gcloud storage cp" s+            Just pruneAt = substringIndex "-delete" s+        assertBool s (uploadAt < pruneAt)+    , testCase "credentials become environment, never arguments" $ do+        -- /proc/<pid>/cmdline is world-readable; /proc/<pid>/environ is not.+        assertBool (script plain) (not ("PGPASSFILE" `isInfixOf` script plain))+        let s = script plain{Backup.pgb_credentials = Backup.PassFile "/var/lib/postgresql/.pgpass"}+        assertBool s ("export PGPASSFILE='/var/lib/postgresql/.pgpass'" `isInfixOf` s)+        let c = script plain{Backup.pgb_credentials = Backup.ClientCertificate "/c/c.pem" "/c/k.pem" "/c/ca.pem"}+        assertBool c ("export PGSSLKEY='/c/k.pem'" `isInfixOf` c)+        assertBool c ("export PGSSLMODE=verify-ca" `isInfixOf` c)+    , testCase "a frozen timestamp is used verbatim, so another machine can name the dump" $ do+        let s = script plain{Backup.pgb_fixedTimestamp = Just "20260919_101500"}+        assertBool s ("TIMESTAMP='20260919_101500'" `isInfixOf` s)+        assertBool s (not ("date +" `isInfixOf` s))+    , testCase "rendered scripts parse as bash" $+        mapM_+            ( \cfg -> do+                (code, _, err) <- readProcessWithExitCode "bash" ["-n", "-c", script cfg] ""+                assertEqual err ExitSuccess code+            )+            [plain, shipped, plain{Backup.pgb_credentials = Backup.PassFile "/tmp/pass"}]+    ]++substringIndex :: String -> String -> Maybe Int+substringIndex needle haystack =+    case [i | (i, rest) <- zip [0 ..] (tails' haystack), needle `isPrefixOf'` rest] of+        (i : _) -> Just i+        [] -> Nothing+  where+    tails' [] = [[]]+    tails' s@(_ : rest) = s : tails' rest+    isPrefixOf' p s = take (length p) s == p++freshnessTests :: [TestTree]+freshnessTests =+    [ testCase "no dump at all is the most actionable failure there is" $+        assertBool "" (isFailure (Backup.interpretBackupAge day now Nothing))+    , testCase "a dump inside the window is satisfying" $+        assertEqual+            ""+            Success+            (Backup.interpretBackupAge day now (Just ("/b/db_1.sql.gz", addUTCTime (-3600) now)))+    , testCase "a dump exactly at the window is still satisfying" $+        assertEqual+            ""+            Success+            (Backup.interpretBackupAge day now (Just ("/b/db_1.sql.gz", addUTCTime (negate day) now)))+    , testCase "an older dump names itself and its age" $+        case Backup.interpretBackupAge day now (Just ("/b/db_1.sql.gz", addUTCTime (-3 * day) now)) of+            Failure msg -> do+                assertBool (show msg) ("/b/db_1.sql.gz" `Text.isInfixOf` msg)+                assertBool (show msg) ("72h" `Text.isInfixOf` msg)+            other -> assertBool (show other) False+    ]+  where+    day = 86400+    now = UTCTime (fromGregorian 2026 9 19) (secondsToDiffTime 0)++isFailure :: CheckResult -> Bool+isFailure (Failure _) = True+isFailure _ = False++scheduleTests :: [TestTree]+scheduleTests =+    [ testCase "dailyAt puts the minute first, as crontab wants" $+        assertEqual "" ("17", "3", "*", "*", "*") (fields (Cron.dailyAt "3" "17"))+    , testCase "hourlyAt runs every hour" $+        assertEqual "" ("5", "*", "*", "*", "*") (fields (Cron.hourlyAt "5"))+    , testCase "weeklyAt pins the day of week" $+        assertEqual "" ("0", "4", "*", "*", "7") (fields (Cron.weeklyAt "7" "4" "0"))+    , testCase "the default config backs up a week's worth, daily, off the hour" $ do+        let cfg = Backup.defaultBackupConfig "db" (Just "owner")+        assertEqual "" 7 cfg.pgb_retentionDays+        assertEqual "" ("17", "3", "*", "*", "*") (fields cfg.pgb_schedule)+        -- slack over the period, so a merely late run is not a missing backup+        assertBool "" (cfg.pgb_maxAge > 86400)+        assertEqual "" Nothing cfg.pgb_server+    ]+  where+    fields :: Cron.Schedule -> (Text.Text, Text.Text, Text.Text, Text.Text, Text.Text)+    fields s = (s.minute, s.hour, s.dayOfMonth, s.month, s.dayOfWeek)
+ test/Test/PostgresClusterSpec.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 0 coverage for cluster lifecycle and streaming replication in+"Salmon.Builtin.Nodes.Postgres": the clone guard, the cluster-state and+pending-restart verdicts, and the settings a primary is given.++The clone guard is the reason this module exists. @cloneFromPrimaryScript@+runs @rm -rf@ on a data directory, and what decides whether it gets that far+is a shell script -- so the assertions here are about /order/: that the+script has learned whose cluster is in that directory, and had a chance to+refuse, before anything is deleted. See @specs\/pg-switchover.md@ (P1).+-}+module Test.PostgresClusterSpec (tests) where++import Data.List (isInfixOf, isPrefixOf, tails)+import Data.Text (Text)+import qualified Data.Text as Text+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import Salmon.Actions.UpDown (CheckResult (..))+import qualified Salmon.Builtin.Nodes.Postgres as Postgres++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Nodes.Postgres (clusters and replication)"+        [ testGroup "the clone guard" cloneGuardTests+        , testGroup "interpretClusterStatus" clusterStatusTests+        , testGroup "interpretPendingRestart" pendingRestartTests+        , testGroup "replicationSettings" settingsTests+        ]++-------------------------------------------------------------------------------++setup :: Postgres.StandbySetup+setup =+    Postgres.StandbySetup+        { Postgres.standby_cluster = "replica"+        , Postgres.standby_primary_host = "10.0.0.1"+        , Postgres.standby_primary_port = 5432+        , Postgres.standby_repl_user = Postgres.User "replicator"+        , Postgres.standby_repl_passfile = "/etc/postgresql/repl.pass"+        , Postgres.standby_slot = Just "replica_slot"+        }++script :: String+script = Postgres.cloneFromPrimaryScript setup++-- | Where a fragment first appears, for asserting on order.+at :: String -> Int+at needle+    | not (needle `isInfixOf` script) = error ("fragment not in the script: " <> needle)+    | otherwise = length (takeWhile (not . (needle `isPrefixOf`)) (tails script))++cloneGuardTests :: [TestTree]+cloneGuardTests =+    [ testCase "asks the primary for its system identifier" $+        assertBool script ("IDENTIFY_SYSTEM" `isInfixOf` script)+    , testCase "reads the local system identifier from pg_controldata" $+        assertBool script ("pg_controldata" `isInfixOf` script && "Database system identifier" `isInfixOf` script)+    , testCase "both identifiers are known before anything is deleted" $ do+        assertBool "primary identifier" (at "primary_sysid=$(" < at "rm -rf")+        assertBool "local identifier" (at "local_sysid=$(" < at "rm -rf")+    , testCase "a matching identifier leaves the directory alone" $+        assertBool script (at "if [ \"$local_sysid\" = \"$primary_sysid\" ]" < at "rm -rf")+    , testCase "the refusal comes before the deletion" $+        assertBool script (at "refusing to clone over" < at "rm -rf")+    , testCase "a foreign cluster is judged by its user databases" $+        assertBool script ("16384" `isInfixOf` script && at "others=" < at "rm -rf")+    , -- the guard this replaced: promotion deletes standby.signal, so a+      -- promoted standby read as "never cloned" and was wiped.+      testCase "does not depend on standby.signal" $+        assertBool script (not ("standby.signal" `isInfixOf` script))+    , testCase "stops at the first failing command" $+        assertBool script ("set -e" `isInfixOf` script)+    , -- a script is visible in `ps` and printed by every report on the way.+      -- PGPASSFILE rather than PGPASSWORD: a path, not the secret, and the+      -- same .pgpass that `primary_conninfo`'s passfile= reads once this is+      -- streaming -- so one file serves the clone and the streaming, and a+      -- pair has one secret per role rather than two spellings of it.+      testCase "reads the password from its file, and never carries it" $ do+        assertBool script ("PGPASSFILE='/etc/postgresql/repl.pass'" `isInfixOf` script)+        assertBool script (not ("PGPASSWORD" `isInfixOf` script))+        assertBool script (not ("hunter2" `isInfixOf` script))+    , testCase "streams from the declared slot" $+        assertBool script ("-S replica_slot" `isInfixOf` script)+    , testCase "no slot declared, no -S" $+        assertBool "" (not ("-S " `isInfixOf` Postgres.cloneFromPrimaryScript setup{Postgres.standby_slot = Nothing}))+    ]++-------------------------------------------------------------------------------++-- | @pg_lsclusters --no-header@: Ver Cluster Port Status Owner DataDirectory LogFile+lsclusters :: Text -> Text+lsclusters status =+    Text.unlines+        [ "15 main    5432 online postgres /var/lib/postgresql/15/main /var/log/postgresql/a.log"+        , "15 replica 5433 " <> status <> " postgres /var/lib/postgresql/15/replica /var/log/postgresql/b.log"+        ]++clusterStatusTests :: [TestTree]+clusterStatusTests =+    [ testCase "online, and online is wanted" $+        assertEqual "" Success (Postgres.interpretClusterStatus Postgres.Online "replica" (lsclusters "online"))+    , testCase "down, and online is wanted" $+        assertEqual "" (Failure "replica is down") (Postgres.interpretClusterStatus Postgres.Online "replica" (lsclusters "down"))+    , testCase "down, and down is wanted" $+        assertEqual "" Success (Postgres.interpretClusterStatus Postgres.Down "replica" (lsclusters "down"))+    , testCase "the other cluster's status is not this one's" $+        assertEqual "" Success (Postgres.interpretClusterStatus Postgres.Online "main" (lsclusters "down"))+    , -- a cluster replaying WAL has started but is not yet serving, and+      -- reading that as "already up" lets a dependant run against it.+      testCase "recovering is neither online nor down" $+        assertBool "" (isFailure (Postgres.interpretClusterStatus Postgres.Online "replica" (lsclusters "online,recovery")))+    , testCase "a cluster that is not listed at all" $+        assertEqual "" (Failure "no cluster named ghost") (Postgres.interpretClusterStatus Postgres.Online "ghost" (lsclusters "online"))+    , testCase "no clusters at all" $+        assertEqual "" (Failure "no cluster named main") (Postgres.interpretClusterStatus Postgres.Online "main" "")+    ]++pendingRestartTests :: [TestTree]+pendingRestartTests =+    [ testCase "nothing pending" $+        assertEqual "" Success (Postgres.interpretPendingRestart "\n")+    , testCase "names what is waiting" $+        assertEqual+            ""+            (Failure "settings waiting for a restart: max_wal_senders,wal_log_hints")+            (Postgres.interpretPendingRestart "max_wal_senders,wal_log_hints\n")+    ]++-------------------------------------------------------------------------------++settingsTests :: [TestTree]+settingsTests =+    [ testCase "pg_rewind is possible on a default primary" $+        assertEqual "" (Just "on") (lookup "wal_log_hints" defaults)+    , testCase "a lagging standby cannot fill the primary's disk" $+        assertEqual "" (Just "10GB") (lookup "max_slot_wal_keep_size" defaults)+    , testCase "an uncapped slot is expressible, and says so by its absence" $+        assertEqual+            ""+            Nothing+            (lookup "max_slot_wal_keep_size" (Postgres.replicationSettings Postgres.defaultReplicationTuning{Postgres.repl_max_slot_wal_keep_size = Nothing}))+    , testCase "hint logging can be turned off explicitly" $+        assertEqual+            ""+            (Just "off")+            (lookup "wal_log_hints" (Postgres.replicationSettings Postgres.defaultReplicationTuning{Postgres.repl_wal_log_hints = False}))+    , testCase "the senders and slots come from the tuning" $ do+        assertEqual "" (Just "10") (lookup "max_wal_senders" defaults)+        assertEqual "" (Just "10") (lookup "max_replication_slots" defaults)+    , testCase "replication is explicitly enabled" $+        assertEqual "" (Just "replica") (lookup "wal_level" defaults)+    ]+  where+    defaults = Postgres.replicationSettings Postgres.defaultReplicationTuning++isFailure :: CheckResult -> Bool+isFailure (Failure _) = True+isFailure _ = False
+ test/Test/PostgresInitSpec.hs view
@@ -0,0 +1,86 @@+-- | Layer 2: run the real, unmodified 'SreBox.PostgresInit.setupNakedPG'+-- recipe against a disposable Debian container, instead of only checking+-- its graph shape.+--+-- The recipe shells out directly to \"apt-get\", \"sudo\", \"pg_ctlcluster\"+-- by name (there is no indirection to hook into), so the only way to run+-- its *real* logic against a sandbox is 'Test.Harness.withShimmedPath':+-- lookalike scripts earlier on PATH that forward each invocation into the+-- container via @podman exec@. Nothing in the recipe is touched or aware of+-- this — it is exercising unmodified production code.+--+-- IMPORTANT (historical): this test is what originally caught a real bug —+-- 'Postgres.pgLocalCluster' used to hardcode @hardcodedVersion = 12@, which+-- silently failed to start on Debian bookworm (which ships postgresql 15 by+-- default): @pg_ctlcluster 12 main start@ exited 1 and nobody noticed,+-- because at the time 'Salmon.Actions.UpDown.upTree' never inspected a+-- failing subprocess's exit code (@Binary.untrackedExec@ recorded the+-- 'ExitCode' into a 'Report' but never threw on non-zero), so a Haskell+-- exception from 'runUp' not being thrown was NOT proof the recipe worked.+-- 'Postgres.pgLocalCluster' now detects the installed cluster version at+-- 'up' time instead of hardcoding it, and separately, 'untrackedExec' now+-- throws on a non-zero exit and 'upTree'/'runUp' surface that as a real+-- @False@ return instead of silently continuing — so the explicit+-- postcondition check below is now belt-and-suspenders rather than the only+-- thing standing between this test and a false green. Both are kept: the+-- 'runUp' result proves the graph traversal itself didn't skip/fail+-- anything, the postcondition proves the *specific* effect we care about+-- actually happened.+module Test.PostgresInitSpec (tests) where++import Data.List (isInfixOf)+import qualified Salmon.Builtin.Nodes.Podman as Podman+import Salmon.Reporter (silent)+import qualified SreBox.PostgresInit as PostgresInit+import Test.Harness+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase)++tests :: TestTree+tests =+    testGroup+        "SreBox.PostgresInit (Layer 2, dogfooded via a podman sandbox)"+        [ testCase "setupNakedPG against a fresh debian:bookworm container" setupNakedPGAgainstSandbox+        ]++-- | These are exactly the binaries 'PostgresInit.setupNakedPG' invokes by+-- name along its dependency chain: apt-get to install postgresql, sudo to+-- run psql as the postgres user, and bash (which in turn resolves+-- pg_ctlcluster/pg_lsclusters *inside* the container, so those two don't+-- need their own shims) to detect and start the cluster.+shimmedCommands :: [String]+-- "dpkg-query" is here because 'Salmon.Builtin.Nodes.Debian.Package.deb'+-- now /checks/ before installing, and a check that shells out has to be+-- redirected into the sandbox exactly like the `up` it guards. Unshimmed, it+-- answers about the host: this machine has postgresql installed, so the+-- container never got it and the recipe failed one step later.+shimmedCommands = ["apt-get", "dpkg-query", "sudo", "bash", "chmod"]++setupNakedPGAgainstSandbox :: IO ()+setupNakedPGAgainstSandbox = requireExecutable "podman" $+    withContainer (Podman.Image "debian:bookworm") (Podman.PortMapping "15432" "5432" Podman.TCPPort) $ \cid -> do+        -- sandbox prep, not part of the recipe under test: a fresh base+        -- image has no apt cache and no sudo, both of which a real target+        -- server is assumed to already have.+        podmanExec_ cid ["apt-get", "update", "-qq"]+        podmanExec_ cid ["bash", "-c", "DEBIAN_FRONTEND=noninteractive apt-get install -y -qq sudo"]++        withShimmedPath cid shimmedCommands $ do+            let op = PostgresInit.setupNakedPG silent "appdb"+            -- this is the real recipe, unmodified, run exactly like+            -- production code would via upTree — only the binaries it+            -- shells out to have been redirected into the container.+            ok <- runUp op+            assertBool "expected the recipe's graph traversal to fully succeed (no failed/blocked node)" ok++        -- postcondition: did "appdb" actually get created for real?+        (code, out, err) <- podmanExecCapture cid ["sudo", "-u", "postgres", "psql", "-lqt"]+        assertBool+            ("expected \"appdb\" to be a real database inside the container; `psql -l` said ("+                <> show code+                <> "):\nstdout:\n"+                <> out+                <> "\nstderr:\n"+                <> err+            )+            ("appdb" `isInfixOf` out)
+ test/Test/PostgresPairSpec.hs view
@@ -0,0 +1,684 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 0 coverage for "SreBox.PostgresPair": what the machines are+(@parseObserved@) and what to do about it (@nextStep@).++The whole design rests on this being decidable from an observation alone --+no progress file, so a switchover killed half-way is finished by the next+pass. That makes the table below the specification: every row is a state two+machines can genuinely be found in, including the ones where the answer is+to refuse.++The refusals are the cases worth staring at. Two primaries, a peer that+cannot be reached, a standby that is ahead of the machine we were told to+promote: each is a state where acting would lose somebody's writes, and each+becomes /allowed/ only when the operator has said so through+'PostgresPair.pair_may_discard'.+-}+module Test.PostgresPairSpec (tests) where++import Data.List (isInfixOf, isPrefixOf)+import Data.Text (Text)+import qualified Data.Text as Text+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)++import qualified SreBox.PostgresPair as Pair++tests :: TestTree+tests =+    testGroup+        "SreBox.PostgresPair"+        [ testGroup "what a member needs" memberTests+        , testGroup "slot names" slotNameTests+        , testGroup "what a bouncer is doing" bouncerTests+        , testGroup "parseLsn" lsnTests+        , testGroup "parseObserved" observedTests+        , testGroup "the probe script" probeTests+        , testGroup "nextStep, with the primary declared on B" stepTests+        , testGroup "nextStep, with the primary declared on A" mirrorTests+        , testGroup "stepCommand" commandTests+        , testGroup "re-seeding a standby whose slot is lost (pair_reseed)" reseedTests+        ]++{- | What a step actually does to a machine. Pure, so the destructive half of+this recipe is readable without a machine to destroy.+-}+commandTests :: [TestTree]+commandTests =+    [ testCase "stopping the old primary is clean, so the standby gets the last checkpoint" $+        assertBool (script (Pair.StopMember Pair.A)) ("stop -m fast" `isInfixOf` script (Pair.StopMember Pair.A))+    , -- that same clean shutdown checkpoints, and a checkpoint recycles the+      -- WAL a later rewind reads back to where the histories parted.+      testCase "stopping a member keeps the WAL a rewind of it would need" $ do+        let s' = script (Pair.StopMember Pair.A)+        assertBool s' ("wal_keep_size" `isInfixOf` s')+        assertBool s' ("pg_reload_conf" `isInfixOf` s')+        assertBool s' (at "wal_keep_size" s' < at "stop -m fast" s')+    , testCase "and the rejoin takes that pin off again" $+        assertBool (script (Pair.Rejoin Pair.A)) ("/^wal_keep_size/d" `isInfixOf` script (Pair.Rejoin Pair.A))+    , testCase "each step runs on the machine it names" $ do+        assertEqual "" (Just "10.0.0.1") (host (Pair.StopMember Pair.A))+        assertEqual "" (Just "10.0.0.2") (host (Pair.Promote Pair.B))+    , testCase "promotion waits for the server to say it promoted" $+        assertBool (script (Pair.Promote Pair.B)) ("pg_promote(true, 60)" `isInfixOf` script (Pair.Promote Pair.B))+    , testCase "starting is a no-op on a cluster already running" $+        assertBool (script (Pair.StartMember Pair.A)) ("status" `isInfixOf` script (Pair.StartMember Pair.A))+    , testCase "rejoining rewinds onto the peer, and never re-clones" $ do+        let s = script (Pair.Rejoin Pair.A)+        assertBool s ("pg_rewind" `isInfixOf` s)+        assertBool s ("-R" `isInfixOf` s)+        assertBool s ("host=10.0.0.2" `isInfixOf` s)+        assertBool s ("user=rewinder" `isInfixOf` s)+        assertBool s (not ("pg_basebackup" `isInfixOf` s))+        assertBool s (not ("rm -rf" `isInfixOf` s))+    , -- pg_rewind finishes a crashed target's recovery by running+      -- `postgres --single -D <datadir>`, which looks for the configuration+      -- in the data directory. Debian keeps it in /etc/postgresql, so that+      -- step fails on exactly the machine a failover is about.+      testCase "a crashed member is recovered before the rewind, with a config file it can find" $ do+        let s' = script (Pair.Rejoin Pair.A)+        assertBool s' ("pg_controldata" `isInfixOf` s')+        assertBool s' ("--single" `isInfixOf` s')+        assertBool s' ("config_file=" `isInfixOf` s')+        -- and that recovery must not recycle the WAL the rewind then reads+        assertBool s' ("wal_keep_size=" `isInfixOf` s')+        -- and never a start: a server that listens is a second primary+        assertBool s' (not ("main start" `isInfixOf` takeWhile' "pg_rewind" s'))+    , testCase "a member that shut down cleanly is not recovered twice" $+        assertBool (script (Pair.Rejoin Pair.A)) ("'shut down'" `isInfixOf` script (Pair.Rejoin Pair.A))+    , -- nothing else creates it, and a standby naming a slot that is not+      -- there retries forever while looking healthy. The quoting these+      -- assertions avoid is the shell's: a slot name arrives inside SQL+      -- inside a single-quoted script, so it is spelled three ways at once.+      testCase "a rejoining member creates the slot it will stream with, and checks" $ do+        let s' = script (Pair.Rejoin Pair.A)+        assertBool s' ("CREATE_REPLICATION_SLOT salmon_pair_app_a PHYSICAL" `isInfixOf` s')+        assertBool s' ("replication=true" `isInfixOf` s')+        assertBool s' ("pg_replication_slots WHERE slot_name = " `isInfixOf` s')+        assertBool s' ("primary_slot_name = " `isInfixOf` s')+        assertBool s' (at "CREATE_REPLICATION_SLOT" s' < at "primary_slot_name = " s')+    , testCase "and drops the one it held for the peer, which nothing consumes here" $ do+        let s' = script (Pair.Rejoin Pair.A)+        assertBool s' ("pg_drop_replication_slot(slot_name)" `isInfixOf` s')+        assertBool s' ("salmon_pair_app_b" `isInfixOf` s')+        -- after the start: dropping a slot needs a server to ask+        assertBool s' (at "main start" s' < at "pg_drop_replication_slot" s')+    , testCase "a rejoined member comes back as a standby, whatever pg_rewind decided" $ do+        let s = script (Pair.Rejoin Pair.A)+        assertBool s ("standby.signal" `isInfixOf` s)+        assertBool s ("primary_conninfo" `isInfixOf` s)+        -- a slot the new primary never heard of is not a smaller problem+        -- than a conninfo pointing at the wrong machine: it is a bigger one,+        -- since the standby then retries forever instead of failing.+        assertBool s ("/^primary_slot_name/d" `isInfixOf` s)+        assertBool s ("host=10.0.0.2 port=5432 user=replicator" `isInfixOf` s)+        assertBool s ("passfile=/etc/postgresql/repl.pgpass" `isInfixOf` s)+    , testCase "the rewind password is read from its file, never carried" $+        assertBool (script (Pair.Rejoin Pair.A)) ("PGPASSFILE='/etc/postgresql/rewind.pass'" `isInfixOf` script (Pair.Rejoin Pair.A))+    , testCase "the steps that are arrivals, waits or refusals run nothing" $+        mapM_+            (\st -> assertBool (show st) (isLeft (Pair.stepCommand pair st)))+            [Pair.Done, Pair.Degraded "x", Pair.Refuse "x", Pair.AwaitCatchUp Pair.B (lsn "0/1"), Pair.AwaitStreaming Pair.A]+    , -- holding the clients, rather than dropping them+      testCase "pausing asks every bouncer, and checks that it really paused" $ do+        let s' = script Pair.PauseBouncers+        assertEqual "" (Just "10.0.0.3") (bouncerHost Pair.PauseBouncers)+        assertBool s' ("PAUSE app" `isInfixOf` s')+        assertBool s' ("-d pgbouncer" `isInfixOf` s')+        -- as awk variables, not as words spliced into its program: the+        -- shell eats the quotes on the way and awk reads a bare word, which+        -- is an empty variable that matches nothing.+        assertBool s' ("-v col='paused'" `isInfixOf` s')+        assertBool s' ("-v want='app'" `isInfixOf` s')+    , testCase "repointing rewrites the routing file, reloads, and lets the clients go" $ do+        let s' = script (Pair.RepointBouncers Pair.B)+        assertBool s' ("/etc/pgbouncer/routing.ini" `isInfixOf` s')+        assertBool s' ("app = host=10.0.0.2 port=5432 dbname=app" `isInfixOf` s')+        assertBool s' ("RELOAD" `isInfixOf` s')+        assertBool s' ("RESUME app" `isInfixOf` s')+        -- and in that order: a reload before the file is written moves+        -- nobody, and a resume before the reload moves them to the old one+        assertBool s' (at "routing.ini" s' < at "RELOAD" s')+        assertBool s' (at "RELOAD" s' < at "RESUME" s')+    , -- a restart would drop every client, which is the one thing a bouncer+      -- is in the way to prevent+      testCase "and never restarts the bouncer to do it" $+        mapM_+            (\st -> mapM_ (\verb -> assertBool (verb <> " has no business moving traffic") (not (verb `isInfixOf` script st))) ["systemctl", "restart", "pkill"])+            [Pair.PauseBouncers, Pair.RepointBouncers Pair.B]+    , testCase "a pair nothing routes through has no bouncer steps to run" $+        mapM_+            (\st -> assertEqual (show st) (Right []) (Pair.stepCommand pair{Pair.pair_bouncers = []} st))+            [Pair.PauseBouncers, Pair.RepointBouncers Pair.B]+    ]+  where+    scripts st = case Pair.stepCommand pair st of+        Right cs -> map snd cs+        Left why -> error ("expected a command for " <> show st <> ": " <> Text.unpack why)+    script st = case scripts st of+        (s : _) -> s+        [] -> error ("expected a command for " <> show st)+    host st = case Pair.stepCommand pair st of+        Right ((Pair.OnMember m, _) : _) -> Just (Pair.member_host m)+        _ -> Nothing+    isLeft (Left _) = True+    isLeft _ = False+    bouncerHost st = case Pair.stepCommand pair st of+        Right ((Pair.OnBouncer b, _) : _) -> Just (Pair.bouncer_ssh_host b)+        _ -> Nothing+    -- where a word first appears, so that two of them can be ordered+    at needle hay = length (takeWhile (not . isPrefixOf needle) (tails' hay))+    tails' [] = [[]]+    tails' xs@(_ : rest) = xs : tails' rest+    -- what the script does before the given word+    takeWhile' needle hay = case breakOn needle hay of (before, _) -> before+    breakOn needle hay = go "" hay+      where+        go acc [] = (reverse acc, [])+        go acc rest@(c : cs)+            | needle `isPrefixOf` rest = (reverse acc, rest)+            | otherwise = go (c : acc) cs++-------------------------------------------------------------------------------++pair :: Pair.Pair+pair =+    Pair.Pair+        { Pair.pair_name = "app"+        , Pair.pair_a = member "10.0.0.1"+        , Pair.pair_b = member "10.0.0.2"+        , Pair.pair_primary = Pair.B+        , Pair.pair_seed = Nothing+        , Pair.pair_bouncers = [bouncer]+        , Pair.pair_may_discard = Nothing+        , Pair.pair_reseed = Nothing+        , Pair.pair_repl_role = "replicator"+        , Pair.pair_repl_passfile = "/etc/postgresql/repl.pgpass"+        , Pair.pair_rewind_role = "rewinder"+        , Pair.pair_rewind_passfile = "/etc/postgresql/rewind.pass"+        , Pair.pair_ssh_known_hosts = Nothing+        , Pair.pair_catch_up_seconds = 60+        }+  where+    member host = Pair.Member "root" host "main" 5432 Nothing++bouncer :: Pair.Bouncer+bouncer =+    Pair.Bouncer+        { Pair.bouncer_name = "bouncer-1"+        , Pair.bouncer_ssh_user = "root"+        , Pair.bouncer_ssh_host = "10.0.0.3"+        , Pair.bouncer_ssh_identity = Nothing+        , Pair.bouncer_console_user = "router"+        , Pair.bouncer_console_port = 6432+        , Pair.bouncer_console_passfile = "/etc/pgbouncer/console.pgpass"+        , Pair.bouncer_alias = "app"+        , Pair.bouncer_dbname = "app"+        , Pair.bouncer_routing_path = "/etc/pgbouncer/routing.ini"+        }++lsn :: Text -> Pair.Lsn+lsn t = maybe (error ("bad lsn in test: " <> Text.unpack t)) id (Pair.parseLsn t)++-- | A standby streaming from the machine it should be streaming from.+streamingFrom :: Text -> Text -> Pair.Observed+streamingFrom host at = Pair.Standby "7000" 1 (Just host) (Just host) (lsn at) (lsn at)++{- | A standby pointed at a machine it is not connected to: a partition, a+standby still starting, a primary that was promoted a second ago. The+configuration is the same as 'streamingFrom''s -- only the connection is+missing, and only one of the two fields says so.+-}+pointedAt :: Text -> Text -> Pair.Observed+pointedAt host at = Pair.Standby "7000" 1 Nothing (Just host) (lsn at) (lsn at)++primaryAt :: Text -> Pair.Observed+primaryAt at = Pair.Primary "7000" 1 (lsn at) [(Pair.slotNameFor pair Pair.A, "reserved")]++-- | A primary whose slot for the peer has fallen off the end of the budget.+primaryWithLostSlot :: Text -> Pair.Observed+primaryWithLostSlot at = Pair.Primary "7000" 1 (lsn at) [(Pair.slotNameFor pair Pair.A, "lost")]++-- | A cluster that was shut down: its last checkpoint is the end of its WAL.+stoppedAt :: Text -> Pair.Observed+stoppedAt at = Pair.Stopped "7000" 1 (lsn at) True++{- | A cluster that stopped without shutting down. The position is the same+field, and it no longer means the same thing: there may be any amount of WAL+after it that nothing on disk records.+-}+crashedAt :: Text -> Pair.Observed+crashedAt at = Pair.Stopped "7000" 1 (lsn at) False++-- | Bouncers doing what they should: pointed at B, nobody held.+settled :: [Pair.BouncerState]+settled = [Pair.BouncerState (Just "10.0.0.2") False]++paused :: [Pair.BouncerState]+paused = [Pair.BouncerState (Just "10.0.0.1") True]++atOldPrimary :: [Pair.BouncerState]+atOldPrimary = [Pair.BouncerState (Just "10.0.0.1") False]++step :: Pair.Observed -> Pair.Observed -> [Pair.BouncerState] -> Pair.Step+step = Pair.nextStep pair++-------------------------------------------------------------------------------++{- | The member node is the one that says nothing about roles: both machines+get the same declaration, and which of them is the primary is somebody+else's sentence.+-}+memberTests :: [TestTree]+memberTests =+    [ testCase "it configures a machine to be either half of the pair" $ do+        let s' = Pair.memberScript pair Pair.A+        mapM_+            (\k -> assertBool (k <> " missing") (k `isInfixOf` s'))+            ["wal_level", "wal_log_hints", "max_slot_wal_keep_size", "max_wal_senders"]+    , -- without these the peer cannot stream from it, whichever way round+      -- the pair ends up+      testCase "and to accept the peer, in both of the ways the peer arrives" $ do+        let s' = Pair.memberScript pair Pair.A+        assertBool s' ("host replication replicator 10.0.0.2/32 md5" `isInfixOf` s')+        assertBool s' ("host all rewinder 10.0.0.2/32 md5" `isInfixOf` s')+        assertBool s' ("grep -qxF" `isInfixOf` s')+    , testCase "the roles are made where roles can be made, and reach the other machine as rows" $ do+        let s' = Pair.memberScript pair Pair.A+        assertBool s' ("pg_is_in_recovery()" `isInfixOf` s')+        assertBool s' ("CREATE ROLE replicator REPLICATION LOGIN" `isInfixOf` s')+        assertBool s' ("CREATE ROLE rewinder LOGIN" `isInfixOf` s')+        assertBool s' ("pg_read_binary_file(text, bigint, bigint, boolean) TO rewinder" `isInfixOf` s')+    , -- a password on a command line is a password in ps+      testCase "a password is read on the machine and fed in on stdin, never written here" $ do+        let s' = Pair.memberScript pair Pair.A+        assertBool s' ("<<PAIR_SQL" `isInfixOf` s')+        assertBool s' ("$replpw" `isInfixOf` s')+        assertBool s' (not ("PASSWORD 'hunter" `isInfixOf` s'))+        assertBool s' (at "replpw=$(" s' < at "PASSWORD" s')+    , testCase "a setting that needs a restart gets one, and nothing else does" $ do+        let s' = Pair.memberScript pair Pair.A+        assertBool s' ("pg_settings WHERE pending_restart" `isInfixOf` s')+        assertBool s' ("pg_reload_conf()" `isInfixOf` s')+    , -- the whole reason this node exists as one node rather than two+      testCase "and it says nothing at all about which side is the primary" $ do+        let s' = Pair.memberScript pair Pair.A <> Pair.memberScript pair Pair.B+        mapM_+            (\w -> assertBool (w <> " has no business in a member's script") (not (w `isInfixOf` s')))+            ["pg_promote", "standby.signal", "primary_conninfo", "pg_rewind", "primary", "standby"]+    ]+  where+    at needle hay = length (takeWhile (not . isPrefixOf needle) (tails' hay))+    tails' [] = [[]]+    tails' xs@(_ : rest) = xs : tails' rest++{- | A slot name is derived, never declared, so that a member that rejoins+computes the same one the member it rejoins would.+-}+slotNameTests :: [TestTree]+slotNameTests =+    [ testCase "one per side, since both of them are somebody's standby eventually" $ do+        assertEqual "" "salmon_pair_app_a" (Pair.slotNameFor pair Pair.A)+        assertEqual "" "salmon_pair_app_b" (Pair.slotNameFor pair Pair.B)+    , -- a pair is named by whoever declares it; a slot name is Postgres's to+      -- accept, and it accepts rather less.+      testCase "anything Postgres will not take becomes an underscore" $+        assertEqual+            ""+            "salmon_pair_orders_eu_west_a"+            (Pair.slotNameFor pair{Pair.pair_name = "Orders-EU.west"} Pair.A)+    , testCase "and the whole thing fits in the 63 characters Postgres allows" $+        assertBool "" (Text.length (Pair.slotNameFor pair{Pair.pair_name = Text.replicate 200 "x"} Pair.B) <= 63)+    ]++{- | @SHOW DATABASES@ has grown columns between pgbouncer versions, so the+answer is read by column name rather than by counting.+-}+bouncerTests :: [TestTree]+bouncerTests =+    [ testCase "where it is sending clients, and that it is not holding them" $+        assertEqual+            ""+            (Pair.BouncerState (Just "10.0.0.2") False)+            (Pair.parseBouncerState bouncer "name|host|port|database|paused|disabled\napp|10.0.0.2|5432|app|0|0\npgbouncer|||pgbouncer|0|0\n")+    , testCase "holding them" $+        assertEqual+            ""+            (Pair.BouncerState (Just "10.0.0.1") True)+            (Pair.parseBouncerState bouncer "name|host|port|database|paused|disabled\napp|10.0.0.1|5432|app|1|0\n")+    , -- the columns moved, and nothing read the wrong one+      testCase "in whatever order the columns come in" $+        assertEqual+            ""+            (Pair.BouncerState (Just "10.0.0.2") True)+            (Pair.parseBouncerState bouncer "paused|pool_mode|host|name|port\n1|transaction|10.0.0.2|app|5432\n")+    , testCase "another database's row is not this pair's answer" $+        assertEqual+            ""+            (Pair.BouncerState Nothing False)+            (Pair.parseBouncerState bouncer "name|host|paused\nsomething_else|10.0.0.9|1\n")+    , testCase "and nothing readable at all is not an arrival" $+        assertEqual "" (Pair.BouncerState Nothing False) (Pair.parseBouncerState bouncer "psql: could not connect\n")+    ]++lsnTests :: [TestTree]+lsnTests =+    [ testCase "positions are compared as numbers, not as text" $+        assertBool "" (lsn "0/9000000" < lsn "1/1000000")+    , testCase "the low half is hexadecimal" $+        assertBool "" (lsn "0/A000000" > lsn "0/9FFFFFF")+    , testCase "equal positions compare equal" $+        assertEqual "" (lsn "2/3000028") (lsn "2/3000028")+    , testCase "anything else is not a position" $ do+        assertEqual "" Nothing (Pair.parseLsn "")+        assertEqual "" Nothing (Pair.parseLsn "0")+        assertEqual "" Nothing (Pair.parseLsn "0/zzz")+    ]++observedTests :: [TestTree]+observedTests =+    [ testCase "a primary" $+        assertEqual+            ""+            (Pair.Primary "7412" 3 (lsn "0/3000028") [])+            (Pair.parseObserved "status=running\nsysid=7412\ntimeline=3\nin_recovery=f\nlsn=0/3000028\nreplayed=\nupstream=\nconfigured=\n")+    , -- the one field that is a list: a machine may hold several slots, and+      -- what matters is what each one's WAL is still worth.+      testCase "a primary, with the slots it holds" $+        assertEqual+            ""+            (Pair.Primary "7412" 3 (lsn "0/3000028") [("salmon_pair_app_a", "lost"), ("other", "reserved")])+            (Pair.parseObserved "status=running\nsysid=7412\ntimeline=3\nin_recovery=f\nlsn=0/3000028\nreplayed=\nupstream=\nconfigured=\nslot=salmon_pair_app_a:lost\nslot=other:reserved\n")+    , testCase "a standby, with where it streams from" $+        assertEqual+            ""+            (Pair.Standby "7412" 3 (Just "10.0.0.1") (Just "10.0.0.1") (lsn "0/4000000") (lsn "0/3FFFFFF"))+            (Pair.parseObserved "status=running\nsysid=7412\ntimeline=3\nin_recovery=t\nlsn=0/4000000\nreplayed=0/3FFFFFF\nupstream=10.0.0.1\nconfigured=10.0.0.1\n")+    , -- the partition's shape: told where to stream from, connected to nobody+      testCase "a standby that is pointed somewhere and connected to nobody" $+        assertEqual+            ""+            (Pair.Standby "7412" 3 Nothing (Just "10.0.0.1") (lsn "0/4000000") (lsn "0/4000000"))+            (Pair.parseObserved "status=running\nsysid=7412\ntimeline=3\nin_recovery=t\nlsn=0/4000000\nreplayed=\nupstream=\nconfigured=10.0.0.1\n")+    , testCase "a standby streaming from nowhere" $+        assertEqual+            ""+            (Pair.Standby "7412" 3 Nothing Nothing (lsn "0/4000000") (lsn "0/4000000"))+            (Pair.parseObserved "status=running\nsysid=7412\ntimeline=3\nin_recovery=t\nlsn=0/4000000\nreplayed=\nupstream=\nconfigured=\n")+    , testCase "a stopped cluster, read off pg_controldata" $+        assertEqual+            ""+            (Pair.Stopped "7412" 3 (lsn "0/2000060") True)+            (Pair.parseObserved "status=stopped\nsysid=7412\nstate=shut down\ncheckpoint=0/2000060\ntimeline=3\nmin_recovery=0/0\n")+    , testCase "a stopped standby replayed past its last checkpoint" $+        assertEqual+            ""+            (Pair.Stopped "7412" 3 (lsn "0/4000000") True)+            (Pair.parseObserved "status=stopped\nsysid=7412\nstate=shut down in recovery\ncheckpoint=0/2000060\ntimeline=3\nmin_recovery=0/4000000\n")+    , -- "in production" on a cluster that is not running is a crash.+      testCase "a cluster that stopped without shutting down" $+        assertEqual+            ""+            (Pair.Stopped "7412" 3 (lsn "0/2000060") False)+            (Pair.parseObserved "status=stopped\nsysid=7412\nstate=in production\ncheckpoint=0/2000060\ntimeline=3\nmin_recovery=0/0\n")+    , -- an old pg_controldata, a translated one, a field that moved: none of+      -- them is a reason to believe a cluster shut down cleanly.+      testCase "a cluster state nobody recognises is not a clean stop" $+        assertEqual+            ""+            (Pair.Stopped "7412" 3 (lsn "0/2000060") False)+            (Pair.parseObserved "status=stopped\nsysid=7412\ncheckpoint=0/2000060\ntimeline=3\n")+    , testCase "no cluster there at all" $+        assertEqual "" Pair.Absent (Pair.parseObserved "status=absent\n")+    , -- half an answer is not an answer: acting on it is acting on a guess.+      testCase "a truncated answer is not a state" $ do+        assertBool "" (unreachable (Pair.parseObserved "status=running\nsysid=7412\n"))+        assertBool "" (unreachable (Pair.parseObserved "status=stopped\nsysid=7412\n"))+        assertBool "" (unreachable (Pair.parseObserved ""))+        assertBool "" (unreachable (Pair.parseObserved "ssh: connect to host 10.0.0.1 port 22: No route to host"))+    ]+  where+    unreachable (Pair.Unreachable _) = True+    unreachable _ = False++probeTests :: [TestTree]+probeTests =+    [ testCase "asks a running cluster, reads a stopped one off disk" $ do+        assertBool script ("pg_is_in_recovery()" `isInfixOf` script)+        assertBool script ("pg_controldata" `isInfixOf` script)+    , testCase "a running cluster reports every field the parser needs" $+        mapM_ (\k -> assertBool (k <> " missing from the probe") ((k <> "=") `isInfixOf` script)) ["sysid", "timeline", "in_recovery", "lsn", "replayed", "upstream", "configured", "slot"]+    , testCase "a stopped cluster reports what the promotion turns on" $+        mapM_ (\k -> assertBool (k <> " missing from the probe") ((k <> "=") `isInfixOf` script)) ["checkpoint", "state", "min_recovery"]+    , -- the standby whose primary is gone has received nothing this+      -- session, and that is the one whose position decides a failover.+      testCase "a standby's position falls back on what it replayed" $ do+        assertBool script ("GREATEST" `isInfixOf` script)+        assertBool script ("pg_last_wal_replay_lsn" `isInfixOf` script)+    , testCase "it reads, and never writes" $+        mapM_ (\verb -> assertBool (verb <> " has no business in a probe") (not (verb `isInfixOf` script))) ["rm ", "promote", "pg_rewind", "DROP", "pg_ctlcluster \"$version\" main stop"]+    ]+  where+    script = Pair.probeScript (Pair.pair_b pair)++-------------------------------------------------------------------------------++stepTests :: [TestTree]+stepTests =+    [ testCase "B primary, A streaming from it, clients on B: nothing to do" $+        assertEqual "" Pair.Done (step (streamingFrom "10.0.0.2" "0/5000000") (primaryAt "0/5000000") settled)+    , testCase "arrived, but the clients are still held: let them go first" $+        assertEqual "" (Pair.RepointBouncers Pair.B) (step (streamingFrom "10.0.0.2" "0/5") (primaryAt "0/5") paused)+    , testCase "arrived, but the clients are still sent to the old primary" $+        assertEqual "" (Pair.RepointBouncers Pair.B) (step (streamingFrom "10.0.0.2" "0/5") (primaryAt "0/5") atOldPrimary)+    , -- a partition, and the single most tempting moment to do damage: the+      -- peer looks exactly like a standby that belongs to somebody else.+      testCase "the peer is pointed at us but not streaming: wait, do not rewind it" $+        assertEqual "" (Pair.AwaitStreaming Pair.A) (step (pointedAt "10.0.0.2" "0/5") (primaryAt "0/5") settled)+    , -- a lost slot is WAL that has been recycled: there is nothing left to+      -- stream, so waiting is not a plan and rewinding is not a fix.+      testCase "the peer's slot is lost: say so, and wait for nobody" $+        assertBool "" (degraded (step (pointedAt "10.0.0.2" "0/5") (primaryWithLostSlot "0/5") settled))+    , testCase "the peer is stopped and its slot is lost: do not rewind it either" $+        assertBool "" (degraded (step (stoppedAt "0/4") (primaryWithLostSlot "0/5") settled))+    , testCase "somebody else's lost slot is not this pair's business" $+        assertEqual+            ""+            (Pair.Rejoin Pair.A)+            (step (stoppedAt "0/4") (Pair.Primary "7000" 1 (lsn "0/5") [("somebody_elses", "lost")]) settled)+    , testCase "the peer streams from the wrong machine: rejoin it" $+        assertEqual "" (Pair.Rejoin Pair.A) (step (streamingFrom "10.0.0.9" "0/5") (primaryAt "0/5") settled)+    , testCase "the peer streams from nobody: rejoin it" $+        assertEqual "" (Pair.Rejoin Pair.A) (step (Pair.Standby "7000" 1 Nothing Nothing (lsn "0/5") (lsn "0/5")) (primaryAt "0/5") settled)+    , testCase "the peer is stopped: rejoin it" $+        assertEqual "" (Pair.Rejoin Pair.A) (step (stoppedAt "0/4") (primaryAt "0/5") settled)+    , testCase "the peer is unreachable: serve, and say the pair is one machine short" $+        assertBool "" (degraded (step (Pair.Unreachable "no route to host") (primaryAt "0/5") settled))+    , testCase "the peer has no cluster: seeding is not this node's job" $+        assertBool "" (degraded (step Pair.Absent (primaryAt "0/5") settled))+    , testCase "two primaries, nothing said: refuse" $+        assertBool "" (refuses (step (primaryAt "0/6") (primaryAt "0/5") settled))+    , testCase "two primaries, and the operator accepted losing A's writes" $+        assertEqual+            ""+            (Pair.StopMember Pair.A)+            (Pair.nextStep pair{Pair.pair_may_discard = Just Pair.A} (primaryAt "0/6") (primaryAt "0/5") settled)+    , -- the ordinary switchover, step by step+      testCase "switchover: hold the clients before stopping anything" $+        assertEqual "" Pair.PauseBouncers (step (primaryAt "0/5") (streamingFrom "10.0.0.1" "0/5") atOldPrimary)+    , -- the old rule stopped the primary whatever the standby was doing,+      -- which during a partition strands every record it had not got.+      testCase "switchover: the standby is not streaming, so do not stop the primary" $+        assertEqual "" (Pair.AwaitStreaming Pair.B) (step (primaryAt "0/5") (pointedAt "10.0.0.1" "0/5") atOldPrimary)+    , testCase "switchover: clients held, so stop the old primary cleanly" $+        assertEqual "" (Pair.StopMember Pair.A) (step (primaryAt "0/5") (streamingFrom "10.0.0.1" "0/5") paused)+    , testCase "switchover: the old primary stopped and the new one has its last checkpoint" $+        assertEqual "" (Pair.Promote Pair.B) (step (stoppedAt "0/5000060") (streamingFrom "10.0.0.1" "0/5000060") paused)+    , -- a crash is the case the checkpoint comparison cannot see: the peer+      -- may have written and acknowledged anything at all after it.+      testCase "failover: the peer crashed, so its checkpoint proves nothing" $+        assertBool "" (refuses (step (crashedAt "0/5000060") (streamingFrom "10.0.0.1" "0/5000060") paused))+    , testCase "failover: the peer crashed, and its writes are declared expendable" $+        assertEqual+            ""+            (Pair.Promote Pair.B)+            (Pair.nextStep pair{Pair.pair_may_discard = Just Pair.A} (crashedAt "0/5000060") (streamingFrom "10.0.0.1" "0/5000060") paused)+    , -- with the flag, waiting for a machine that will send nothing more is+      -- only a slower way to reach the same place.+      testCase "failover: expendable writes are not waited for" $+        assertEqual+            ""+            (Pair.Promote Pair.B)+            (Pair.nextStep pair{Pair.pair_may_discard = Just Pair.A} (stoppedAt "0/5000060") (streamingFrom "10.0.0.1" "0/4000000") paused)+    , -- both stopped, the declared one behind, and nothing left to stream+      -- from: waiting is a slower way of failing, so start the machine that+      -- holds the records and let the standby catch up from it.+      testCase "the declared primary is behind a stopped peer: start the peer, do not wait" $+        assertEqual+            ""+            (Pair.StartMember Pair.A)+            (step (stoppedAt "0/5000060") (Pair.Standby "7000" 1 Nothing (Just "10.0.0.1") (lsn "0/4000000") (lsn "0/4000000")) paused)+    , testCase "switchover: not caught up yet, so wait rather than lose the tail" $+        assertEqual+            ""+            (Pair.AwaitCatchUp Pair.B (lsn "0/5000060"))+            (step (stoppedAt "0/5000060") (streamingFrom "10.0.0.1" "0/4000000") paused)+    , testCase "failover: the peer cannot be confirmed stopped, so refuse" $+        assertBool "" (refuses (step (Pair.Unreachable "timed out") (streamingFrom "10.0.0.1" "0/5") atOldPrimary))+    , testCase "failover: with the writes declared expendable, hold the clients first" $+        assertEqual+            ""+            Pair.PauseBouncers+            (Pair.nextStep pair{Pair.pair_may_discard = Just Pair.A} (Pair.Unreachable "timed out") (streamingFrom "10.0.0.1" "0/5") atOldPrimary)+    , testCase "failover: clients held, promote" $+        assertEqual+            ""+            (Pair.Promote Pair.B)+            (Pair.nextStep pair{Pair.pair_may_discard = Just Pair.A} (Pair.Unreachable "timed out") (streamingFrom "10.0.0.1" "0/5") paused)+    , testCase "two standbys: promote the declared one, it is not behind" $+        assertEqual "" (Pair.Promote Pair.B) (step (streamingFrom "10.0.0.9" "0/4") (streamingFrom "10.0.0.9" "0/5") paused)+    , testCase "two standbys, and the peer is ahead: refuse rather than lose its tail" $+        assertBool "" (refuses (step (streamingFrom "10.0.0.9" "0/6") (streamingFrom "10.0.0.9" "0/5") paused))+    , testCase "both stopped: start the declared primary first" $+        assertEqual "" (Pair.StartMember Pair.B) (step (stoppedAt "0/5") (stoppedAt "0/5") paused)+    , testCase "the declared primary is stopped while the peer serves: start it" $+        assertEqual "" (Pair.StartMember Pair.B) (step (primaryAt "0/5") (stoppedAt "0/4") atOldPrimary)+    , testCase "the declared primary is unreachable: refuse, whatever the peer is" $+        assertBool "" (refuses (step (primaryAt "0/5") (Pair.Unreachable "timed out") atOldPrimary))+    , testCase "the declared primary has no cluster: refuse" $+        assertBool "" (refuses (step (primaryAt "0/5") Pair.Absent atOldPrimary))+    , -- an identifier apart is two clusters, whatever the names say, and+      -- every step below would then be applied to a stranger's data.+      testCase "different clusters: refuse before anything else" $+        assertBool+            ""+            (refuses (step (Pair.Standby "7000" 1 (Just "10.0.0.2") (Just "10.0.0.2") (lsn "0/5") (lsn "0/5")) (Pair.Primary "9999" 1 (lsn "0/5") []) settled))+    , -- the flag says which side's writes may go, which presumes the two+      -- sides are the same cluster. It is not a licence to wipe a machine+      -- that was never part of this pair.+      testCase "different clusters: saying whose writes may go does not license it" $+        assertBool+            ""+            ( refuses+                ( Pair.nextStep+                    pair{Pair.pair_may_discard = Just Pair.A}+                    (Pair.Primary "7000" 1 (lsn "0/6") [])+                    (Pair.Primary "9999" 1 (lsn "0/5") [])+                    settled+                )+            )+    , testCase "no bouncers declared: their state cannot hold a pass back" $+        assertEqual "" Pair.Done (step (streamingFrom "10.0.0.2" "0/5") (primaryAt "0/5") [])+    ]++{- | The same pair with the declaration the other way round. The table is+written in terms of "the declared primary" and "the peer", and these say so:+a rule that reached for @pair_a@ by accident would show up here.+-}+mirrorTests :: [TestTree]+mirrorTests =+    [ testCase "A primary, B streaming from it, clients on A: nothing to do" $+        assertEqual "" Pair.Done (mirror (primaryAt "0/5") (streamingFrom "10.0.0.1" "0/5") [Pair.BouncerState (Just "10.0.0.1") False])+    , testCase "switchover the other way: stop B once the clients are held" $+        assertEqual "" (Pair.StopMember Pair.B) (mirror (streamingFrom "10.0.0.2" "0/5") (primaryAt "0/5") paused)+    , testCase "promote A once B has stopped and A has its checkpoint" $+        assertEqual "" (Pair.Promote Pair.A) (mirror (streamingFrom "10.0.0.2" "0/5000060") (stoppedAt "0/5000060") paused)+    , testCase "clients are sent to A now, not to B" $+        assertEqual "" (Pair.RepointBouncers Pair.A) (mirror (primaryAt "0/5") (streamingFrom "10.0.0.1" "0/5") settled)+    ]+  where+    mirror = Pair.nextStep pair{Pair.pair_primary = Pair.A}++refuses :: Pair.Step -> Bool+refuses (Pair.Refuse _) = True+refuses _ = False++degraded :: Pair.Step -> Bool+degraded (Pair.Degraded _) = True+degraded _ = False++-------------------------------------------------------------------------------++{- | The re-seeding half of S6: the one place a pass wipes a data directory+that belongs to the pair, so it has to be shown to need /both/ things at+once -- the primary saying the slot is lost, and the operator naming the+side -- and to do nothing otherwise.+-}+reseedTests :: [TestTree]+reseedTests =+    [ testCase "lost, declared, standby not streaming: re-seed it" $+        assertEqual "" (Pair.Reseed Pair.A) (stepR (Just Pair.A) (pointedAt "10.0.0.2" "0/5") (primaryWithLostSlot "0/5"))+    , testCase "lost, declared, standby stopped: re-seed it, not rewind it" $+        assertEqual "" (Pair.Reseed Pair.A) (stepR (Just Pair.A) (stoppedAt "0/4") (primaryWithLostSlot "0/5"))+    , testCase "lost, declared, and the data directory is already gone: carry on" $ do+        assertEqual "" (Pair.Reseed Pair.A) (stepR (Just Pair.A) Pair.Absent (primaryWithLostSlot "0/5"))+        assertEqual "" (Pair.Reseed Pair.A) (stepR (Just Pair.A) (Pair.Unreachable "the probe reported no status") (primaryWithLostSlot "0/5"))+    , testCase "lost but not declared: still only said, never done" $+        assertBool "" (degraded (stepR Nothing (stoppedAt "0/4") (primaryWithLostSlot "0/5")))+    , testCase "declared for the other side: nothing about this one" $+        assertBool "" (degraded (stepR (Just Pair.B) (stoppedAt "0/4") (primaryWithLostSlot "0/5")))+    , testCase "declared, but the slot is fine: a lagging standby is never wiped" $ do+        assertEqual "" (Pair.Rejoin Pair.A) (stepR (Just Pair.A) (stoppedAt "0/4") (primaryAt "0/5"))+        assertEqual "" (Pair.AwaitStreaming Pair.A) (stepR (Just Pair.A) (pointedAt "10.0.0.2" "0/5") (primaryAt "0/5"))+    , testCase "declared, and somebody else's slot is the lost one: nothing to do with this pair" $+        assertEqual "" (Pair.Rejoin Pair.A) (stepR (Just Pair.A) (stoppedAt "0/4") (Pair.Primary "7000" 1 (lsn "0/5") [("somebody_elses", "lost")]))+    , testCase "declared and healthy: the pair is done" $+        assertEqual "" Pair.Done (stepR (Just Pair.A) (streamingFrom "10.0.0.2" "0/5") (primaryAt "0/5"))+    , testCase "two different clusters are refused before anything is wiped" $+        assertBool "" (isRefuse (stepR (Just Pair.A) (Pair.Stopped "OTHER" 1 (lsn "0/4") True) (primaryWithLostSlot "0/5")))+    , testCase "the lost slot's reason says what to declare" $+        case stepR Nothing (stoppedAt "0/4") (primaryWithLostSlot "0/5") of+            Pair.Degraded why -> assertBool (Text.unpack why) ("pair_reseed" `Text.isInfixOf` why)+            other -> assertFailure (show other)+    , testCase "the script wipes only the pair's own data, then clones, then swaps the slot" $ do+        let s = reseedScriptOn Pair.A+        -- the wipe is behind the system identifier comparison+        assertBool s ("[ \"$local_sysid\" = \"$primary_sysid\" ]" `isInfixOf` s)+        assertBool s (at "IDENTIFY_SYSTEM" s < at "rm -rf" s)+        assertBool s (at "$local_sysid\" = \"$primary_sysid" s < at "rm -rf" s)+        -- and the rest is the seed script: the clone (whose own guard refuses+        -- a foreign cluster), the drop of the lost slot only after it, then+        -- the member's own slot+        assertBool s (at "rm -rf" s < at "pg_basebackup" s)+        assertBool s (at "pg_basebackup" s < at "DROP_REPLICATION_SLOT salmon_pair_app_a" s)+        assertBool s (at "DROP_REPLICATION_SLOT salmon_pair_app_a" s < at "CREATE_REPLICATION_SLOT salmon_pair_app_a" s)+        assertBool s ("could not drop the lost slot" `isInfixOf` s)+    , testCase "the script runs on the side being rebuilt and reads the primary's identity from the other" $ do+        case Pair.stepCommand pairReseed (Pair.Reseed Pair.A) of+            Right [(Pair.OnMember m, sc)] -> do+                assertEqual "" "10.0.0.1" (Pair.member_host m)+                assertBool sc ("host=10.0.0.2" `isInfixOf` sc)+            other -> assertFailure (show other)+    ]+  where+    stepR r a b = Pair.nextStep pair{Pair.pair_reseed = r} a b settled+    isRefuse (Pair.Refuse _) = True+    isRefuse _ = False+    pairReseed = pair{Pair.pair_reseed = Just Pair.A}+    reseedScriptOn side = case Pair.stepCommand pairReseed (Pair.Reseed side) of+        Right [(_, sc)] -> sc+        _ -> ""+    at needle hay = length (takeWhile (not . isPrefixOf needle) (tails' hay))+    tails' [] = [[]]+    tails' xs@(_ : rest) = xs : tails' rest
+ test/Test/PostgresReplicationSpec.hs view
@@ -0,0 +1,205 @@+{- | Layer 3: exercises "Salmon.Builtin.Nodes.Postgres"'s WAL streaming+replication primitives (@primaryReplicationSetup@\/@standbyReplicationSetup@)+for real, against two real qemu VMs — a primary and a standby, both booted+via 'Test.Harness.withVmAt' on the shared test bridge — asserting+replication actually catches up (a row written on the primary shows up on+the standby), not just that @pg_stat_replication@ says @streaming@.++It then exercises the clone's guard, which is the part of this recipe that+deletes things. Two claims, both about a second @up@ with an unchanged+directive: a __promoted__ standby is left alone (it used to be deleted, the+guard being @standby.signal@, which promotion removes), and a __stranger's__+cluster in the standby's place is refused rather than cloned over. See+@specs\/pg-switchover.md@ (P1).++A guest's rootfs is a host directory that survives the VM, so the standby's+cluster is dropped and recreated at the start of the test rather than+assumed: the previous run deliberately left a stranger's cluster there.++This is the Layer 3 port of @salmon-ops/fixtures/PostgresReplicationFixture.hs@,+which until now was the only way to exercise this recipe at all: a hand-run+fixture against two podman containers, driven by a human reading+@psql@ output off their terminal (see that module's own haddock). Podman is+a poor fit for this recipe specifically — WAL streaming replication wants+two independently-addressable, systemd-managed hosts talking over the+network, which containers-on-one-kernel don't give you for free the way two+qemu guests do. This test drives the exact same fixture binary, just+copied onto real VMs over SSH instead of @podman cp@/@podman exec@, with+real assertions instead of a human eyeballing @psql@.++Needs the same qemu/bridge privilege requirement as "Test.QemuSmokeSpec"+(root, or the one-time capability setup in 'Test.Harness.hasVmPrivileges')+and two pre-built rootfses, one per role, each with+'Salmon.Builtin.Nodes.Debian.Debootstrap.vmEssentials' @<>@+@[Package \"postgresql\", Package \"sudo\"]@ and+'Salmon.Builtin.Nodes.Debian.Debootstrap.ensureVm9pBoot' already applied+(postgres is baked into the rootfs rather than apt-installed at test time,+same reasoning as 'Test.Harness.withVm''s own SSH-CA design: the test+bridge has no NAT\/internet route out of the guest, so nothing here can+depend on the guest reaching the network past boot). Both preconditions+skip loudly, not fail, if unmet — see 'Test.PostgresVms.requirePgVmPrereqs'.++> sudo debootstrap --include=linux-image-amd64,openssh-server,postgresql,sudo stable /var/lib/salmon-test-vms/pg-primary/root+> sudo debootstrap --include=linux-image-amd64,openssh-server,postgresql,sudo stable /var/lib/salmon-test-vms/pg-standby/root+-}+module Test.PostgresReplicationSpec (tests) where++import Control.Concurrent (threadDelay)+import Control.Exception (SomeException, catch)+import Control.Monad (unless)+import Data.List (isInfixOf)+import qualified Data.Text as Text+import System.Exit (ExitCode (..))+import Test.Harness+import Test.PostgresVms+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase)++tests :: TestTree+tests =+    testGroup+        "Postgres replication (Layer 3, real primary/standby VMs)"+        [testCase "replicates a row, keeps a promoted standby, refuses a stranger's cluster" replicatesARow]++replicatesARow :: IO ()+replicatesARow = requirePgVmPrereqs $ do+    fixtureBin <- resolveFixtureBinary+    withVmAt testVmAddr primaryRootfs $ \primary ->+        withVmAt testVmAddr2 standbyRootfs $ \standby -> do+            -- whatever the last spec left behind: the switchover spec ends+            -- with the primary on the other machine, and this one's fixture+            -- cannot make a read-only server into a primary. Before copying+            -- anything onto these guests, not after: a cluster that cannot+            -- start crash-loops, and a crash loop on a 512MB guest starves+            -- the sshd the copy needs -- so the failure arrives as a dead+            -- scp, a long way from its cause.+            ensurePrimary primary+            resetCluster standby+            mapM_ (`installFixture` fixtureBin) [primary, standby]++            runFixture primary ["primary", Text.unpack testVmAddr2 <> "/32"]+            runFixture standby ["standby", Text.unpack testVmAddr]++            waitForStreaming primary `catch` dumpDiagAnd primary standby+            insertRow primary+            waitForRowOnStandby standby++            -- The clone guard, which is what keeps `rm -rf` off a data+            -- directory that is not a fresh one. Both halves run against the+            -- standby that was just built, in order: a promoted standby is+            -- left alone, and a stranger's cluster in its place is refused.+            promotedStandbyIsLeftAlone standby+            strangersClusterIsRefused standby+  where+    -- Promotion deletes `standby.signal`, which used to be the whole guard:+    -- the next run read the new primary as "never cloned" and deleted it.+    promotedStandbyIsLeftAlone :: VmAccess -> IO ()+    promotedStandbyIsLeftAlone standby = do+        psqlOrDie standby "SELECT pg_promote(true, 60);"+        psqlOrDie standby "INSERT INTO salmon_repl_test VALUES ('written-after-promotion');"+        runFixture standby ["standby", Text.unpack testVmAddr]+        (_, rows, _) <- psql standby "SELECT v FROM salmon_repl_test ORDER BY v;"+        assertBool+            ("a rerun after promotion lost the promoted standby's data: " <> rows)+            ("written-after-promotion" `isInfixOf` rows && "replicated-ok" `isInfixOf` rows)+        (_, recovery, _) <- psql standby "SELECT pg_is_in_recovery();"+        assertBool ("the promoted standby was put back into recovery: " <> recovery) ("f" `isInfixOf` recovery)++    -- A different cluster at the same path is somebody else's data, whatever+    -- the directive says. The clone must refuse rather than delete it.+    strangersClusterIsRefused :: VmAccess -> IO ()+    strangersClusterIsRefused standby = do+        (code, out, err) <-+            sshToVm+                standby+                [ "bash"+                , "-c"+                , quoteForRemoteShell . unwords $+                    [ -- ssh forwards the host's LANG, and pg_createcluster+                      -- refuses a locale the guest does not have.+                      "export LANG=C LC_ALL=C;"+                    , "set -e;"+                    , "version=$(pg_lsclusters --no-header | awk '{print $1}' | sort -n | tail -n1);"+                    , "pg_dropcluster \"$version\" main --stop;"+                    , "pg_createcluster \"$version\" main -p 5432 -- --auth-local=peer --auth-host=md5;"+                    , "pg_ctlcluster \"$version\" main start;"+                    , "sudo -u postgres psql -c 'CREATE DATABASE precious';"+                    ]+                ]+        unless (code == ExitSuccess) (fail ("could not put a stranger's cluster in place: " <> out <> err))+        (rerun, rerunOut, rerunErr) <- sshToVm standby ["/root/fixture", "standby", Text.unpack testVmAddr]+        assertBool ("the clone did not refuse a stranger's cluster: " <> rerunOut <> rerunErr) (rerun /= ExitSuccess)+        assertBool+            ("refused, but not for the documented reason: " <> rerunOut <> rerunErr)+            ("refusing to clone over" `isInfixOf` (rerunOut <> rerunErr))+        (_, dbs, _) <- psql standby "SELECT datname FROM pg_database WHERE datname = 'precious';"+        assertBool ("the refused cluster was deleted anyway: " <> dbs) ("precious" `isInfixOf` dbs)++    dumpDiagAnd :: VmAccess -> VmAccess -> SomeException -> IO ()+    dumpDiagAnd primary standby e = do+        (_, primRepl, _) <- sshToVm primary ["sudo", "-u", "postgres", "psql", "-tAc", quoteForRemoteShell "SELECT * FROM pg_stat_replication;"]+        (_, primLog, _) <- sshToVm primary ["bash", "-c", quoteForRemoteShell "tail -n 80 /var/log/postgresql/*.log 2>&1"]+        (_, standRecv, _) <- sshToVm standby ["sudo", "-u", "postgres", "psql", "-tAc", quoteForRemoteShell "SELECT * FROM pg_stat_wal_receiver;"]+        (_, standLog, _) <- sshToVm standby ["bash", "-c", quoteForRemoteShell "tail -n 80 /var/log/postgresql/*.log 2>&1"]+        (_, standSignal, _) <-+            sshToVm+                standby+                ["bash", "-c", quoteForRemoteShell "ls -la /var/lib/postgresql/17/main/ | grep -i standby; cat /var/lib/postgresql/17/main/postgresql.auto.conf 2>&1"]+        (_, pingOut, _) <- sshToVm standby ["bash", "-c", quoteForRemoteShell ("ping -c2 " <> Text.unpack testVmAddr <> " 2>&1")]+        fail $+            "waitForStreaming diagnostics after: "+                <> show e+                <> "\n--- primary pg_stat_replication ---\n"+                <> primRepl+                <> "\n--- primary log tail ---\n"+                <> primLog+                <> "\n--- standby pg_stat_wal_receiver ---\n"+                <> standRecv+                <> "\n--- standby log tail ---\n"+                <> standLog+                <> "\n--- standby signal/auto.conf ---\n"+                <> standSignal+                <> "\n--- standby ping primary ---\n"+                <> pingOut++-- | Polls @pg_stat_replication@ on the primary until the standby shows up+-- streaming, or fails after a timeout -- same "skip/fail loudly, don't+-- hang" spirit as 'Test.Harness.waitForSsh'.+waitForStreaming :: VmAccess -> IO ()+waitForStreaming access = go (30 :: Int)+  where+    go 0 = fail "waitForStreaming: standby never reached 'streaming' state within the timeout"+    go n = do+        (code, out, _err) <- sshToVm access ["sudo", "-u", "postgres", "psql", "-tAc", quoteForRemoteShell "SELECT state FROM pg_stat_replication;"]+        if code == ExitSuccess && "streaming" `isInfixOf` out+            then pure ()+            else threadDelay 2000000 >> go (n - 1)++insertRow :: VmAccess -> IO ()+insertRow primary = do+    (code, out, err) <-+        sshToVm+            primary+            [ "sudo"+            , "-u"+            , "postgres"+            , "psql"+            , "-c"+            , quoteForRemoteShell "CREATE TABLE IF NOT EXISTS salmon_repl_test (v text); INSERT INTO salmon_repl_test VALUES ('replicated-ok');"+            ]+    unless (code == ExitSuccess) (fail ("insertRow: failed on primary: " <> out <> err))++-- | Polls the standby (read-only, since it's a streaming replica) for the+-- row 'insertRow' wrote on the primary, or fails after a timeout.+waitForRowOnStandby :: VmAccess -> IO ()+waitForRowOnStandby standby = go (30 :: Int)+  where+    go 0 = fail "waitForRowOnStandby: replicated row never showed up on the standby within the timeout"+    go n = do+        (code, out, _err) <-+            sshToVm+                standby+                ["sudo", "-u", "postgres", "psql", "-tAc", quoteForRemoteShell "SELECT v FROM salmon_repl_test WHERE v = 'replicated-ok';"]+        if code == ExitSuccess && "replicated-ok" `isInfixOf` out+            then pure ()+            else threadDelay 2000000 >> go (n - 1)
+ test/Test/PostgresSwitchoverSpec.hs view
@@ -0,0 +1,727 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 3: a real switchover between two real machines, driven by+"SreBox.PostgresPair" from a third (the test process, standing in for the+controller a deployment would run this from).++This is scenario S1 of @specs\/pg-switchover.md@, minus the client-error+assertions, which need the bouncers of phase 4. What it does claim is the+part no Layer 0 table can: that the steps in 'SreBox.PostgresPair.Step'+really do move a primary from one machine to the other, that the machine+left behind comes back as a standby of the new primary through @pg_rewind@+rather than a re-clone, and that running the whole thing again when it is+already true changes nothing.++It reuses the two rootfses and the fixture binary of+"Test.PostgresReplicationSpec" (see that module for what they need and how+to build them), plus what a switchover needs and plain replication does not:+a rewind role, and @pg_hba.conf@ lines on /both/ machines, since after the+first switchover each of them has to accept the other streaming from it.+-}+module Test.PostgresSwitchoverSpec (tests) where++import Control.Exception (SomeException, try)+import Control.Monad (forM_, unless)+import Data.List (isInfixOf)+import qualified Data.Text as Text+import System.Exit (ExitCode (..))+import Test.Harness+import Test.Tasty (DependencyType (..), TestTree, sequentialTestGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Reporter (silent)+import qualified SreBox.PostgresPair as Pair+import Test.PostgresVms++tests :: TestTree+tests =+    -- one pair of VMs, one bridge, two addresses: these cases cannot run at+    -- the same time as each other any more than the specs around them can.+    sequentialTestGroup+        "Postgres switchover (Layer 3, a primary moved between two VMs)"+        AllFinish+        [ testCase "switches the primary over, and back, without losing a row" switchesOverAndBack+        , testCase "a switchover stopped part-way is finished by the next pass" resumesAfterInterruption+        , testCase "a crashed primary is failed over only when its writes are declared expendable" failsOverFromACrash+        , testCase "a partition is waited out, not acted on" holdsThroughAPartition+        , testCase "a failover across a partition leaves two primaries, and rewinds one" splitBrainIsRewound+        , testCase "a standby that falls off the slot budget is said so, not silently re-seeded, and re-seeded once declared" theSlotBudgetBoundsTheDisk+        , testCase "a pair stopped in either order comes back with the declared primary, losing nothing" recoversFromBothStopped+        , testCase "a stranger's cluster where a member should be is refused, and nothing is deleted" refusesAStrangersCluster+        ]++{- | S8: a stranger's cluster where a member of the pair should be.++A machine is rebuilt, or a name is reused, or a directive is pointed at the+wrong address: the address answers, the cluster name matches, the port is+right, and what is there has never met the other machine. Every step in the+table would then be applied to somebody else's data, which is why the system+identifiers are compared before anything else is decided.++The direction that matters is the one with 'SreBox.PostgresPair.pair_may_discard'+set. That flag says which side's writes may go, and it presumes the two sides+are the same cluster; read as a general licence to destroy, it would let a+pass rewind a real cluster onto a stranger's. So the test declares it both+ways round and asserts the refusal survives both -- and then that neither+data directory was touched, which is the assertion a refusal is actually+about.+-}+refusesAStrangersCluster :: IO ()+refusesAStrangersCluster = requirePgVmPrereqs $ do+    fixtureBin <- resolveFixtureBinary+    withVmAt testVmAddr primaryRootfs $ \a ->+        withVmAt testVmAddr2 standbyRootfs $ \b -> do+            buildPair a b fixtureBin+            resetRows a+            insertRow a "on-the-real-cluster"+            waitForRows b ["on-the-real-cluster"]++            -- the standby's machine is rebuilt: same address, same cluster+            -- name, same port, and a cluster that has never met A.+            resetCluster b+            psqlOrDie b "CREATE DATABASE precious;"+            strangers <- dataDirectoryIdentity b+            ours <- dataDirectoryIdentity a++            -- nothing about the declaration has changed+            let declared = pairWith a b Pair.A+            step <- Pair.decide declared+            assertBool ("expected a refusal, got " <> show step) (refuses step)+            assertBool ("the reason does not say what is wrong: " <> show step) ("cluster" `isInfixOf` show step)+            ok <- runUp (Pair.pairRole silent declared)+            assertBool "a pass across two different clusters was reported a success" (not ok)++            -- and saying whose writes may go does not change it, in either+            -- direction: declared at the real cluster or at the stranger.+            forM_ [Pair.A, Pair.B] $ \side -> do+                let p = (pairWith a b (Pair.other side)){Pair.pair_may_discard = Just side}+                flagged <- Pair.decide p+                assertBool ("expected a refusal with may_discard = " <> show side <> ", got " <> show flagged) (refuses flagged)+                acted <- runUp (Pair.pairRole silent p)+                assertBool ("a pass with may_discard = " <> show side <> " was reported a success") (not acted)++            -- neither machine was touched by any of that+            assertEqual "the stranger's data directory was replaced" strangers =<< dataDirectoryIdentity b+            assertEqual "our own data directory was replaced" ours =<< dataDirectoryIdentity a+            (_, dbs, _) <- psql b "SELECT datname FROM pg_database WHERE datname = 'precious';"+            assertBool ("the stranger's database is gone: " <> dbs) ("precious" `isInfixOf` dbs)+            assertPrimaryIs a+            waitForRows a ["on-the-real-cluster"]++{- | S7: both machines are stopped, and the one declared primary is the one+that stopped first.++The easy half is a maintenance window: the primary goes down first, so its+last record reaches the standby on the way out, and bringing the pair back up+with the roles swapped costs nothing. The interesting half is the other+order. Stop the /standby/ first, let the primary write one more thing, then+stop that too, and declare the machine that was already gone: what the pair+must not do is promote it, because the other machine holds a write it has+never seen.++There is no waiting its way out of that, either. A standby catches up by+streaming, and the machine it would stream from is stopped -- so the only way+to converge on the declaration without losing the write is to start the old+primary again, let the standby catch up from it, and then do the ordinary+switchover. The test asserts the write survives, which is the only assertion+that can tell that apart from a promotion that happened to be quick.+-}+recoversFromBothStopped :: IO ()+recoversFromBothStopped = requirePgVmPrereqs $ do+    fixtureBin <- resolveFixtureBinary+    withVmAt testVmAddr primaryRootfs $ \a ->+        withVmAt testVmAddr2 standbyRootfs $ \b -> do+            buildPair a b fixtureBin+            resetRows a+            insertRow a "before-the-maintenance-window"+            waitForRows b ["before-the-maintenance-window"]++            -- the primary goes down first, so the standby has its last record+            stopCluster a+            stopCluster b+            let toB = pairWith a b Pair.B+            passOrExplain "bringing the pair up with B declared" toB+            assertPrimaryIs b+            assertStandbyOf a testVmAddr2++            -- and now the other order, with the declared primary the one+            -- that stopped first and so missed what came after+            stopCluster a+            insertRow b "written-after-the-standby-stopped"+            stopCluster b+            let toA = pairWith a b Pair.A+            passOrExplain "bringing the pair up with A declared" toA+            assertPrimaryIs a+            assertStandbyOf b testVmAddr++            -- declaring the machine that was behind lost nothing+            waitForRows a ["before-the-maintenance-window", "written-after-the-standby-stopped"]+            waitForRows b ["before-the-maintenance-window", "written-after-the-standby-stopped"]++{- | S6: the standby goes away and stays away, and the primary's disk does+not follow it down.++A replication slot is a promise to keep WAL until the standby has it, and an+unbounded promise is how a machine that is merely /down/ takes the machine+that is /up/ with it. @max_slot_wal_keep_size@ is the price cap on that+promise: past it the slot is invalidated, the WAL is recycled, and the+standby -- which can now never catch up -- is the only thing that was lost.++That is a good trade and a terrible surprise, so the pair has to say it out+loud. A lost slot is not a state to rewind out of: @pg_rewind@ would succeed,+change nothing, and hand back a standby that still cannot replay what is no+longer there. The only way back is a re-seed, which is a decision about+throwing a machine's data away and therefore an operator's, so the check says+'Salmon.Actions.UpDown.Unknown' with the slot named in it, and the pass does+nothing at all.+-}+theSlotBudgetBoundsTheDisk :: IO ()+theSlotBudgetBoundsTheDisk = requirePgVmPrereqs $ do+    fixtureBin <- resolveFixtureBinary+    withVmAt testVmAddr primaryRootfs $ \a ->+        withVmAt testVmAddr2 standbyRootfs $ \b -> do+            buildPair a b fixtureBin+            resetRows a+            insertRow a "before-the-slot-budget"++            -- one switchover first, so that the slot in play is the pair's+            -- own: what the fixture set up streams with a slot of the+            -- fixture's making, and this is a test about the pair's.+            let p = pairWith a b Pair.B+            passOrExplain "the switchover" p+            assertStandbyOf a testVmAddr2+            let slot = Text.unpack (Pair.slotNameFor p Pair.A)++            -- a budget small enough to go past on purpose+            psqlOrDie b "ALTER SYSTEM SET max_slot_wal_keep_size = '32MB';"+            psqlOrDie b "ALTER SYSTEM SET max_wal_size = '64MB';"+            psqlOrDie b "SELECT pg_reload_conf();"++            stopCluster a+            churnWal b 24++            waitFor ("the slot " <> slot <> " never fell off the budget") $ do+                (_, out, _) <- psql b ("SELECT wal_status FROM pg_replication_slots WHERE slot_name = '" <> slot <> "';")+                pure ("lost" `isInfixOf` out, out)+            wal <- walMegabytes b+            assertBool+                ("the primary's WAL followed the standby down: " <> show wal <> "MB of pg_wal")+                (wal < 250)++            -- the pair says what happened, names the slot, and touches nothing+            identity <- dataDirectoryIdentity a+            step <- Pair.decide p+            assertEqual ("a lost slot is not a failure and not a success: " <> show step) Unknown (Pair.verdict step)+            assertBool ("the reason does not name the slot: " <> show step) (slot `isInfixOf` show step)+            ok <- runUp (Pair.pairRole silent p)+            assertBool "a pass over a pair with a lost slot failed" ok+            identity' <- dataDirectoryIdentity a+            assertEqual "the standby was re-seeded without anybody asking" identity identity'++            -- and the machine that is still up is still serving+            assertPrimaryIs b+            insertRow b "written-after-the-slot-was-lost"+            waitForRows b ["before-the-slot-budget", "written-after-the-slot-was-lost"]++            -- the operator now says that machine may be rebuilt: the same pass+            -- that only said so before wipes it, clones it again, swaps the+            -- lost slot for a live one, and the pair is whole (S6, continued).+            let reseed = p{Pair.pair_reseed = Just Pair.A}+            okReseed <- runUp (Pair.pairRole silent reseed)+            assertBool "the re-seeding pass failed" okReseed+            identity'' <- dataDirectoryIdentity a+            assertBool "the standby was declared rebuildable and was not rebuilt" (identity'' /= identity)+            assertStandbyOf a testVmAddr2+            after <- Pair.decide reseed+            assertEqual ("the pair is not whole after the re-seed: " <> show after) Success (Pair.verdict after)+            waitFor ("the slot " <> slot <> " is not live again") $ do+                (_, out, _) <- psql b ("SELECT wal_status FROM pg_replication_slots WHERE slot_name = '" <> slot <> "';")+                pure (any (`isInfixOf` out) ["reserved", "extended"], out)+            -- and it is a standby again in the sense that matters+            insertRow b "written-after-the-reseed"+            waitForRows a ["before-the-slot-budget", "written-after-the-slot-was-lost", "written-after-the-reseed"]++            -- put the budget back: this rootfs outlives the VM, and a 32MB+            -- cap is a trap to leave lying around for the next spec.+            psqlOrDie b "ALTER SYSTEM RESET max_slot_wal_keep_size;"+            psqlOrDie b "ALTER SYSTEM RESET max_wal_size;"+            psqlOrDie b "SELECT pg_reload_conf();"+            psqlOrDie b "DROP TABLE IF EXISTS salmon_churn;"++{- | Writes enough WAL to go past a small budget, in the cheapest way there+is: a row so that the segment is not empty (@pg_switch_wal@ does nothing to+one that is), then a switch to the next, then a checkpoint to make the+primary act on what it now may throw away.+-}+churnWal :: VmAccess -> Int -> IO ()+churnWal vm n = do+    psqlOrDie vm "CREATE TABLE IF NOT EXISTS salmon_churn (v int);"+    forM_ [1 .. n] $ \i -> do+        psqlOrDie vm ("INSERT INTO salmon_churn VALUES (" <> show (i :: Int) <> ");")+        psqlOrDie vm "SELECT pg_switch_wal();"+    psqlOrDie vm "CHECKPOINT;"+    psqlOrDie vm "CHECKPOINT;"++{- | S5: fail over while the old primary is still up and still taking+writes, then let the partition heal and watch salmon find two primaries.++This is the scenario the whole design is careful about, and the only one+where salmon knowingly destroys writes that were acknowledged to a client.+It needs a partition that hides A from /the controller/ as well as from B --+otherwise there is nothing to fail over from: a primary that can be reached+is simply stopped, and that is a switchover.++Three refusals are asserted along the way, because each is the difference+between this scenario and losing data nobody offered. While A cannot be+reached and nothing has been declared, the pass refuses. Once the partition+heals and both machines call themselves primaries, a pass without the flag+refuses again. Only 'SreBox.PostgresPair.pair_may_discard', which names the+side whose writes may go, turns either one into an action.+-}+splitBrainIsRewound :: IO ()+splitBrainIsRewound = requirePgVmPrereqs $ do+    fixtureBin <- resolveFixtureBinary+    withVmAt testVmAddr primaryRootfs $ \a ->+        withVmAt testVmAddr2 standbyRootfs $ \b -> do+            buildPair a b fixtureBin+            resetRows a+            insertRow a "replicated-before-the-partition"+            waitForRows b ["replicated-before-the-partition"]++            psqlOrDie b "ALTER SYSTEM SET wal_receiver_timeout = '5s';"+            psqlOrDie b "SELECT pg_reload_conf();"+            partitionFrom b [testVmAddr]+            waitForNoStreaming b++            -- written on A with the standby already cut off: these are the+            -- writes the flag is about, and a client had them acknowledged.+            insertRow a "written-on-a-behind-the-partition"++            -- and now A disappears from the controller too, until the+            -- machine itself lifts the rule again.+            partitionFromEverythingFor a [controllerAddr, testVmAddr2] 120+            let declared = pairWith a b Pair.B+            waitFor "A stayed reachable through the partition" $ do+                obs <- Pair.observe declared Pair.A+                pure (unreachable obs, show obs)++            -- nothing declared: a machine that cannot be reached is not a+            -- machine that has stopped, and salmon will not guess.+            refused <- runUp (Pair.pairRole silent declared)+            assertBool "promoted without being told whose writes may go" (not refused)+            assertInRecovery b++            -- the operator accepts losing whatever A has that B does not+            let failover = declared{Pair.pair_may_discard = Just Pair.A}+            passOrExplain "the failover" failover+            assertPrimaryIs b+            insertRow b "written-on-b-after-the-failover"++            -- the partition lifts itself, and now both machines are primaries+            waitForUpTo 120 "A never came back" $ do+                obs <- Pair.observe failover Pair.A+                pure (not (unreachable obs), show obs)+            healPartition b+            twoPrimaries <- Pair.decide declared+            assertBool+                ("two primaries, nothing declared, and the step was " <> show twoPrimaries)+                (refuses twoPrimaries)++            -- with the flag, A is stopped and rewound onto B's history+            passOrExplain "the split-brain resolution" failover+            assertStandbyOf a testVmAddr2+            assertPrimaryIs b++            waitForRows a ["replicated-before-the-partition", "written-on-b-after-the-failover"]+            -- and the writes A took behind the partition are gone, which is+            -- exactly what the flag said would happen to them+            assertNoRow a "written-on-a-behind-the-partition"+            assertNoRow b "written-on-a-behind-the-partition"++unreachable :: Pair.Observed -> Bool+unreachable (Pair.Unreachable _) = True+unreachable _ = False++refuses :: Pair.Step -> Bool+refuses (Pair.Refuse _) = True+refuses _ = False++{- | S4: cut the two machines off from each other, change nothing, and let it+heal.++The declaration still says what it said, and both machines are still doing+what they were told, so there is nothing here for salmon to do -- which is+the whole assertion. A partition is the state where acting is most tempting+and least safe: the standby has stopped streaming and looks, to a check that+asks the wrong question, exactly like a standby that was never pointed here+at all.++What makes the difference is asking a standby /where it is told to stream+from/ rather than only where it /is/ streaming from. The first is a+declaration it keeps through a partition; the second is empty the moment the+connection drops.+-}+holdsThroughAPartition :: IO ()+holdsThroughAPartition = requirePgVmPrereqs $ do+    fixtureBin <- resolveFixtureBinary+    withVmAt testVmAddr primaryRootfs $ \a ->+        withVmAt testVmAddr2 standbyRootfs $ \b -> do+            buildPair a b fixtureBin+            resetRows a+            insertRow a "before-the-partition"+            waitForRows b ["before-the-partition"]++            -- how long a standby takes to notice that its primary has gone+            -- quiet is a setting, and the default minute is longer than this+            -- test's patience.+            -- two calls, not one: psql sends a multi-statement line as one+            -- implicit transaction, and ALTER SYSTEM refuses to run in one.+            psqlOrDie b "ALTER SYSTEM SET wal_receiver_timeout = '5s';"+            psqlOrDie b "SELECT pg_reload_conf();"+            partitionFrom b [testVmAddr]+            waitForNoStreaming b++            -- the declaration has not changed: A is still the primary+            let p = pairWith a b Pair.A+            -- what the pair's own check says while the partition is up:+            -- Unknown, the one verdict that starts nothing and keeps looking.+            step <- Pair.decide p+            assertEqual+                ("a partition is not a reason to touch anything, but the step was " <> show step)+                Unknown+                (Pair.verdict step)+            ok <- runUp (Pair.pairRole silent p)+            assertBool "a pass over a partitioned pair failed" ok+            -- in particular, the standby was not stopped, rewound or re-seeded+            assertPrimaryIs a+            assertInRecovery b++            insertRow a "written-during-the-partition"+            healPartition b+            waitForRows b ["before-the-partition", "written-during-the-partition"]+            settled <- Pair.decide p+            assertEqual "the pair did not settle once the partition healed" Pair.Done settled++++{- | S3: crash the primary, fail over to the standby, and let the machine+that crashed rejoin.++Two things separate this from the switchover above, and both are the point.+The old primary is not stopped, it /dies/ -- so its last checkpoint is no+longer the end of its WAL, and nothing on either machine can say what it+wrote after it. That is a state salmon is not entitled to decide about, so+the first pass here refuses and the second one is given+'SreBox.PostgresPair.pair_may_discard': the operator saying which side's+writes they accept losing, which is the only thing that makes a failover+different from a guess.++And the machine that comes back is rewound rather than re-seeded. The two+are hard to tell apart afterwards -- same rows, same system identifier, same+timeline -- so the test holds on to something only a re-clone destroys.+-}+failsOverFromACrash :: IO ()+failsOverFromACrash = requirePgVmPrereqs $ do+    fixtureBin <- resolveFixtureBinary+    withVmAt testVmAddr primaryRootfs $ \a ->+        withVmAt testVmAddr2 standbyRootfs $ \b -> do+            buildPair a b fixtureBin+            resetRows a+            insertRow a "replicated-before-the-crash"+            waitForRows b ["replicated-before-the-crash"]++            -- with the standby down, what A writes now reaches nobody: these+            -- are the writes the flag below is about.+            stopCluster b+            insertRow a "written-while-b-was-down"+            identity <- dataDirectoryIdentity a+            crashCluster a++            -- nothing declared: a pass may start what is stopped, and may+            -- not promote over a machine whose WAL it cannot account for.+            let declared = pairWith a b Pair.B+            refused <- runUp (Pair.pairRole silent declared)+            assertBool "promoted over a crashed primary with nothing declared" (not refused)+            assertInRecovery b++            -- the operator accepts losing A's un-replicated writes+            let failover = declared{Pair.pair_may_discard = Just Pair.A}+            passOrExplain "the failover" failover+            assertPrimaryIs b+            insertRow b "written-on-b-after-the-failover"+            assertStandbyOf a testVmAddr2++            identity' <- dataDirectoryIdentity a+            assertEqual "the old primary was re-cloned rather than rewound" identity identity'++            -- what was replicated survived, on both machines+            waitForRows a ["replicated-before-the-crash", "written-on-b-after-the-failover"]+            waitForRows b ["replicated-before-the-crash", "written-on-b-after-the-failover"]+            -- and what was not is gone, which is what the flag said+            assertNoRow b "written-while-b-was-down"+            assertNoRow a "written-while-b-was-down"++{- | S2: kill the controller after each step of a switchover in turn, and+let an ordinary pass pick it up.++This is the scenario the design is /for/. 'SreBox.PostgresPair.nextStep'+reads the machines rather than a note about where a previous pass got to,+and the claim that buys -- an interrupted switchover needs no repair, only+another pass -- is a claim about states nobody writes down and so nobody+tests by accident.++The interruption is a budget: a controller allowed @k@ steps does @k@ and+throws, which is what a controller being killed looks like from the+machines' side. The direction alternates, so each @k@ lands part-way through+a switchover going the other way than the last one did.+-}+resumesAfterInterruption :: IO ()+resumesAfterInterruption = requirePgVmPrereqs $ do+    fixtureBin <- resolveFixtureBinary+    withVmAt testVmAddr primaryRootfs $ \a ->+        withVmAt testVmAddr2 standbyRootfs $ \b -> do+            buildPair a b fixtureBin+            insertRow a "before-any-interruption"++            forM_ (zip [1 :: Int, 2, 3] (cycle [Pair.B, Pair.A])) $ \(k, side) -> do+                let p = pairWith a b side+                -- a controller that dies part-way+                outcome <- try (Pair.convergeUpTo silent k p) :: IO (Either SomeException ())+                -- ... which, for a budget short of the three steps a+                -- switchover takes, must really have stopped part-way:+                -- otherwise the pass below is being credited with finishing+                -- something that was never started.+                unless (k >= 3) $ do+                    assertBool ("a budget of " <> show k <> " steps finished a whole switchover") (isLeft outcome)+                    midA <- Pair.observe p Pair.A+                    midB <- Pair.observe p Pair.B+                    assertBool+                        ("interrupted at step " <> show k <> ", yet already settled: " <> show midA <> " / " <> show midB)+                        (Pair.nextStep p midA midB [] /= Pair.Done)+                -- and an ordinary pass afterwards, with nothing else done+                ok <- runUp (Pair.pairRole silent p)+                assertBool ("a pass after an interruption at step " <> show k <> " failed") ok+                obsA <- Pair.observe p Pair.A+                obsB <- Pair.observe p Pair.B+                assertEqual+                    ("interrupted at step " <> show k <> ", not finished: " <> show obsA <> " / " <> show obsB)+                    Pair.Done+                    (Pair.nextStep p obsA obsB [])+                insertRow (vmFor a b side) ("after-interruption-at-" <> show k)++            -- nothing written along the way was lost by any of it+            let rows = "before-any-interruption" : ["after-interruption-at-" <> show k | k <- [1 :: Int, 2, 3]]+            waitForRows a rows+            waitForRows b rows++{- | Runs the node, and on failure says what the machines looked like.++The node reports through a 'Salmon.Reporter.Reporter', which these tests+leave 'silent' -- so a pass that failed is otherwise just @False@, and the+one thing worth knowing, which of the steps refused or threw, is exactly+what was thrown away. Deciding again costs two ssh round trips and turns+that into a sentence.+-}+passOrExplain :: String -> Pair.Pair -> IO ()+passOrExplain what p = do+    ok <- runUp (Pair.pairRole silent p)+    unless ok $ do+        obsA <- Pair.observe p Pair.A+        obsB <- Pair.observe p Pair.B+        retried <- try (Pair.converge silent p) :: IO (Either SomeException ())+        fail . unlines $+            [ what <> " failed"+            , "  A: " <> show obsA+            , "  B: " <> show obsB+            , "  next step: " <> show (Pair.nextStep p obsA obsB [])+            , "  running it again said: " <> show retried+            ]++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False++vmFor :: VmAccess -> VmAccess -> Pair.Side -> VmAccess+vmFor a _ Pair.A = a+vmFor _ b Pair.B = b++replPassword, rewindPassword :: String+replPassword = "fixture-replication-password"+rewindPassword = "fixture-rewind-password"++replPgpass, rewindPgpass :: FilePath+replPgpass = "/etc/postgresql/salmon-replication.pgpass"+rewindPgpass = "/etc/postgresql/salmon-rewind.pgpass"++switchesOverAndBack :: IO ()+switchesOverAndBack = requirePgVmPrereqs $ do+    fixtureBin <- resolveFixtureBinary+    withVmAt testVmAddr primaryRootfs $ \a ->+        withVmAt testVmAddr2 standbyRootfs $ \b -> do+            buildPair a b fixtureBin+            insertRow a "before-any-switchover"++            -- A -> B+            switchTo a b Pair.B+            assertPrimaryIs b+            assertStandbyOf a testVmAddr2+            insertRow b "written-on-b"++            -- doing it again when it is already true must do nothing at all+            assertSettled a b Pair.B+            ok <- runUp (Pair.pairRole silent (pairWith a b Pair.B))+            assertBool "a second pass over a settled pair failed" ok+            assertPrimaryIs b++            -- B -> A+            switchTo a b Pair.A+            assertPrimaryIs a+            assertStandbyOf b testVmAddr+            insertRow a "written-on-a-again"++            -- every row, on both machines+            waitForRows b ["before-any-switchover", "written-on-b", "written-on-a-again"]+            waitForRows a ["before-any-switchover", "written-on-b", "written-on-a-again"]+  where+    switchTo :: VmAccess -> VmAccess -> Pair.Side -> IO ()+    switchTo a b side = do+        ok <- runUp (Pair.pairRole silent (pairWith a b side))+        unless ok (fail ("the switchover to " <> show side <> " failed"))++    assertSettled :: VmAccess -> VmAccess -> Pair.Side -> IO ()+    assertSettled a b side = do+        let p = pairWith a b side+        obsA <- Pair.observe p Pair.A+        obsB <- Pair.observe p Pair.B+        assertEqual+            ("the pair is not settled: " <> show obsA <> " / " <> show obsB)+            Pair.Done+            (Pair.nextStep p obsA obsB [])++pairWith :: VmAccess -> VmAccess -> Pair.Side -> Pair.Pair+pairWith a b side =+    Pair.Pair+        { Pair.pair_name = "test-pair"+        , Pair.pair_a = member testVmAddr (vmIdentityFile a)+        , Pair.pair_b = member testVmAddr2 (vmIdentityFile b)+        , Pair.pair_primary = side+        , Pair.pair_repl_role = "replicator"+        , Pair.pair_repl_passfile = replPgpass+        , Pair.pair_rewind_role = "rewinder"+        , Pair.pair_rewind_passfile = rewindPgpass+        , -- the guests are rebuilt at fixed addresses, so remembering host+          -- keys across runs would only ever be wrong+          Pair.pair_ssh_known_hosts = Just "/dev/null"+        , Pair.pair_catch_up_seconds = 60+        , -- the scenarios below route no clients; S1's client assertions are+          -- the one case that declares a bouncer.+          Pair.pair_bouncers = []+        , Pair.pair_seed = Nothing+        , Pair.pair_may_discard = Nothing+        , Pair.pair_reseed = Nothing+        }+  where+    member host identity = Pair.Member "root" host "main" 5432 (Just identity)++-------------------------------------------------------------------------------++{- | A pair as it stands before any switchover: A primary, B its standby,+and both machines ready to swap those roles.+-}+buildPair :: VmAccess -> VmAccess -> FilePath -> IO ()+buildPair a b fixtureBin = do+    -- whatever the last spec left: A may well be a standby of B, and the+    -- fixture's primary half cannot run on a read-only server.+    ensurePrimary a+    resetCluster b+    mapM_ (\(vm, path) -> scpToVm vm fixtureBin path) [(a, "/root/fixture"), (b, "/root/fixture")]+    mapM_ (\vm -> sshOrDie vm ["chmod", "+x", "/root/fixture"]) [a, b]+    runFixture a ["primary", Text.unpack testVmAddr2 <> "/32"]+    runFixture b ["standby", Text.unpack testVmAddr]+    waitForStandby b+    prepareForSwitchover a b++{- | What a switchover needs and plain streaming replication does not: a+rewind role, its password file and the replication one on both machines, and+@pg_hba.conf@ lines letting each machine be the other's primary.++The role and its grants are created on the primary only, since roles and+grants are catalog rows and reach the standby through the WAL like any other.+-}+prepareForSwitchover :: VmAccess -> VmAccess -> IO ()+prepareForSwitchover a b = do+    psqlOrDie a . unwords $+        [ "DO $$ BEGIN CREATE ROLE rewinder LOGIN PASSWORD '" <> rewindPassword <> "';"+        , "EXCEPTION WHEN duplicate_object THEN NULL; END $$;"+        , "GRANT EXECUTE ON FUNCTION pg_ls_dir(text, boolean, boolean) TO rewinder;"+        , "GRANT EXECUTE ON FUNCTION pg_stat_file(text, boolean) TO rewinder;"+        , "GRANT EXECUTE ON FUNCTION pg_read_binary_file(text) TO rewinder;"+        , "GRANT EXECUTE ON FUNCTION pg_read_binary_file(text, bigint, bigint, boolean) TO rewinder;"+        ]+    mapM_ prepareMachine [(a, testVmAddr2), (b, testVmAddr)]+  where+    prepareMachine (vm, peer) = do+        sshOrDie vm+            [ "bash"+            , "-c"+            , quoteForRemoteShell . unwords $+                [ "set -e;"+                , "version=$(pg_lsclusters --no-header | awk '{print $1}' | sort -n | tail -n1);"+                , "hba=/etc/postgresql/$version/main/pg_hba.conf;"+                , line "host replication replicator " peer <> ";"+                , line "host all rewinder " peer <> ";"+                , writePgpass replPgpass "replicator" replPassword <> ";"+                , writePgpass rewindPgpass "rewinder" rewindPassword <> ";"+                , "pg_ctlcluster \"$version\" main reload"+                ]+            ]++    line prefix peer =+        let l = prefix <> Text.unpack peer <> "/32 md5"+         in "grep -qxF '" <> l <> "' \"$hba\" || echo '" <> l <> "' >> \"$hba\""++    -- .pgpass format, which is what primary_conninfo's passfile= and+    -- pg_rewind's PGPASSFILE both read: host:port:database:user:password.+    writePgpass path role pwd =+        unwords+            [ "printf '*:*:*:" <> role <> ":" <> pwd <> "\\n' > " <> path <> ";"+            , "chown postgres:postgres " <> path <> ";"+            , "chmod 0600 " <> path+            ]++-------------------------------------------------------------------------------++insertRow :: VmAccess -> String -> IO ()+insertRow vm v =+    psqlOrDie vm ("CREATE TABLE IF NOT EXISTS salmon_switchover (v text); INSERT INTO salmon_switchover VALUES ('" <> v <> "');")++{- | Starts the canaries over. The rootfses outlive the VMs, so a row from a+previous run is otherwise still there -- which matters to the one assertion+here that a row is /absent/.+-}+resetRows :: VmAccess -> IO ()+resetRows vm = psqlOrDie vm "DROP TABLE IF EXISTS salmon_switchover;"++waitForRows :: VmAccess -> [String] -> IO ()+waitForRows vm vs =+    waitFor ("expected " <> show vs) $ do+        (_, out, _) <- psql vm "SELECT v FROM salmon_switchover ORDER BY v;"+        pure (all (`isInfixOf` out) vs, out)++assertNoRow :: VmAccess -> String -> IO ()+assertNoRow vm v = do+    (_, out, _) <- psql vm "SELECT v FROM salmon_switchover ORDER BY v;"+    assertBool ("expected " <> v <> " to be gone, got: " <> out) (not (v `isInfixOf` out))++waitForNoStreaming :: VmAccess -> IO ()+waitForNoStreaming vm =+    waitFor "the standby never noticed the partition" $ do+        (_, out, _) <- psql vm "SELECT count(*) FROM pg_stat_wal_receiver;"+        pure ("0" `isInfixOf` out, out)++waitForStandby :: VmAccess -> IO ()+waitForStandby vm =+    waitFor "the standby never started streaming" $ do+        (code, out, _) <- psql vm "SELECT status FROM pg_stat_wal_receiver;"+        pure (code == ExitSuccess && "streaming" `isInfixOf` out, out)
+ test/Test/PostgresTemplateSpec.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Coverage for template databases: the builtins in+"Salmon.Builtin.Nodes.Postgres" and "SreBox.PostgresTemplate" on top.++Layer 0 is the verdicts and the rendered SQL, which is where the safety+lives: every statement that drops or adopts a database is guarded by a+marker, and the guard has to come first and survive a hostile name.++Layer 2 builds, rebuilds, clones and drops against a real cluster in a+podman container, because the claims that matter are Postgres's to judge --+that a locked template refuses connections, that a rebuild really starts+from nothing, that the guard really stops a drop.+-}+module Test.PostgresTemplateSpec (tests, sandboxTests) where++import Data.IORef+import Data.Text (Text)+import qualified Data.Text as Text+import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import Salmon.Actions.UpDown (CheckResult (..))+import qualified Salmon.Actions.UpDown as UpDown+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (prepare)+import qualified Salmon.Builtin.Nodes.Debian.OS as Debian+import qualified Salmon.Builtin.Nodes.Podman as Podman+import qualified Salmon.Builtin.Nodes.Postgres as Postgres+import Salmon.Op.Ref (mkRef)+import Salmon.Op.Track (Track (..))+import Salmon.Op.Actions (Act (..))+import Salmon.Reporter (silent)+import qualified SreBox.PostgresTemplate as PGTemplate+import System.Process.ListLike (CmdSpec (..), cmdspec)+import Test.Harness++tests :: TestTree+tests =+    testGroup+        "SreBox.PostgresTemplate"+        [ testGroup "interpretTemplateRow" templateVerdicts+        , testGroup "interpretCloneRow" cloneVerdicts+        , testGroup "the rendered SQL" sqlTests+        , testGroup "refs" refTests+        , testCase "fingerprint frames its parts" $+            assertBool "" (PGTemplate.fingerprint ["ab", "c"] /= PGTemplate.fingerprint ["a", "bc"])+        ]++-- | Kept apart from 'tests' so "Main" can serialize it: it shims @PATH@.+sandboxTests :: TestTree+sandboxTests =+    testGroup+        "SreBox.PostgresTemplate (Layer 2, dogfooded via a podman sandbox)"+        [testCase "build, skip, rebuild, clone, refuse, drop" templateLifecycle]++isFailure :: CheckResult -> Bool+isFailure (Failure _) = True+isFailure _ = False++failureText :: CheckResult -> Text+failureText (Failure t) = t+failureText _ = ""++-------------------------------------------------------------------------------++templateVerdicts :: [TestTree]+templateVerdicts =+    [ testCase "locked and stamped with these inputs is satisfied" $+        assertEqual "" Success (verdict "t|f|salmon-template:abc\n")+    , testCase "no row means no template" $+        assertBool "" ("does not exist" `Text.isInfixOf` failureText (verdict ""))+    , testCase "other inputs is a rebuild" $+        assertBool "" ("different inputs" `Text.isInfixOf` failureText (verdict "t|f|salmon-template:old"))+    , testCase "a build that died is recognisably half-built" $+        assertBool "" ("half-built" `Text.isInfixOf` failureText (verdict "f|t|salmon-template:building"))+    , testCase "stamped but connectable is not a template to trust" $ do+        assertBool "" ("not locked" `Text.isInfixOf` failureText (verdict "t|t|salmon-template:abc"))+        assertBool "" ("not locked" `Text.isInfixOf` failureText (verdict "f|f|salmon-template:abc"))+    , testCase "a database salmon did not build says so" $ do+        assertBool "" ("did not build" `Text.isInfixOf` failureText (verdict "f|t|"))+        assertBool "" ("did not build" `Text.isInfixOf` failureText (verdict "t|f|hand-made template"))+    , testCase "a comment containing the separator is still read whole" $+        assertBool "" (isFailure (verdict "t|f|salmon-template:abc|x"))+    , testCase "output that is not a row is not a verdict" $+        assertEqual "" Unknown (verdict "garbage")+    ]+  where+    verdict = Postgres.interpretTemplateRow "tpl" "abc"++cloneVerdicts :: [TestTree]+cloneVerdicts =+    [ testCase "a clone salmon made is satisfied, from whichever template" $+        assertEqual "" Success (Postgres.interpretCloneRow "c" "row:salmon-clone:older_tpl\n")+    , testCase "no row means no clone" $+        assertBool "" ("does not exist" `Text.isInfixOf` failureText (Postgres.interpretCloneRow "c" ""))+    , testCase "an uncommented database is present, and not ours" $+        assertBool "" ("did not clone" `Text.isInfixOf` failureText (Postgres.interpretCloneRow "c" "row:"))+    ]++-------------------------------------------------------------------------------++sqlTests :: [TestTree]+sqlTests =+    [ testCase "the batch stops at the first error" $ do+        -- without ON_ERROR_STOP a refused guard is followed by the DROP it+        -- guards, and psql still exits 0.+        let args = processArgs (prepare (Postgres.psqlBatchRun_Sudo 5433) Postgres.PsqlBatch)+        assertBool (show args) ("ON_ERROR_STOP=1" `elem` args)+        assertBool (show args) ("5433" `elem` args)+    , testCase "a rebuild refuses before it drops" $+        guardPrecedes "DROP DATABASE" (Postgres.prepareTemplateSql "tpl")+    , testCase "a template teardown refuses before it drops" $+        guardPrecedes "DROP DATABASE" (Postgres.dropTemplateSql "tpl")+    , testCase "a clone refuses to adopt before it creates" $+        guardPrecedes "CREATE DATABASE" (Postgres.cloneDatabaseSql plainClone)+    , testCase "a clone teardown refuses before it drops" $+        guardPrecedes "DROP DATABASE" (Postgres.dropCloneSql "c")+    , testCase "a fresh build is marked half-built until it is locked" $ do+        let sql = Postgres.prepareTemplateSql "tpl"+        assertBool (Text.unpack sql) ("salmon-template:building" `Text.isInfixOf` sql)+    , testCase "locking stamps, disallows connections and evicts sessions" $ do+        let sql = Postgres.lockTemplateSql "tpl" "abc"+        assertBool (Text.unpack sql) ("IS 'salmon-template:abc'" `Text.isInfixOf` sql)+        assertBool (Text.unpack sql) ("IS_TEMPLATE true ALLOW_CONNECTIONS false" `Text.isInfixOf` sql)+        assertBool (Text.unpack sql) ("pg_terminate_backend" `Text.isInfixOf` sql)+    , testCase "a clone is created conditionally, with its owner" $ do+        let sql = Postgres.cloneDatabaseSql plainClone{Postgres.clone_owner = Just "app"}+        assertBool (Text.unpack sql) ("\\gexec" `Text.isInfixOf` sql)+        assertBool (Text.unpack sql) ("TEMPLATE \"tpl\" OWNER \"app\"" `Text.isInfixOf` sql)+    , testCase "a hostile name stays inside its quotes" $ do+        let hostile = "x\"; DROP TABLE t; '$$ $salmon0$"+            sql = Postgres.dropTemplateSql hostile+        assertBool (Text.unpack sql) ("\"x\"\"; DROP TABLE t; '$$ $salmon0$\"" `Text.isInfixOf` sql)+        assertBool (Text.unpack sql) ("'x\"; DROP TABLE t; ''$$ $salmon0$'" `Text.isInfixOf` sql)+        -- the DO body's tag is one the name does not contain+        assertBool (Text.unpack sql) ("DO $salmon1$" `Text.isInfixOf` sql)+    ]+  where+    plainClone = Postgres.Clone "c" "tpl" Nothing+    processArgs p = case cmdspec p of+        RawCommand _ args -> args+        ShellCommand s -> [s]+    guardPrecedes stmt sql =+        case (Text.breakOn "RAISE EXCEPTION" sql, Text.breakOn stmt sql) of+            ((before, rest), (beforeStmt, _)) -> do+                assertBool (Text.unpack sql) (not (Text.null rest))+                assertBool (Text.unpack sql) (Text.length before < Text.length beforeStmt)++refTests :: [TestTree]+refTests =+    [ testCase "a database is keyed by its port as well as its name" $ do+        let at port = refOf (Postgres.database silent ignoreTrack ignoreTrack port (Postgres.Database "appdb"))+        assertBool "" (at 5432 /= at 5433)+        assertEqual "" (at 5432) (at 5432)+    , testCase "a clone and a database of one name are one site" $+        assertEqual+            ""+            (refOf (Postgres.database silent ignoreTrack ignoreTrack 5432 (Postgres.Database "c")))+            (refOf (Postgres.disposableClone silent ignoreTrack 5432 ignoreTrack (Postgres.Clone "c" "tpl" Nothing)))+    , testCase "retention is visible in a clone's description" $ do+        -- so `run serve` sees a flip from Retain to Discard as a change to+        -- the node, rather than keeping the old one's no-op teardown.+        let notesOf mk = fmap (\act -> act.extension.notes) (opAct (mk silent ignoreTrack 5432 ignoreTrack (Postgres.Clone "c" "tpl" Nothing)))+        assertBool "" (notesOf Postgres.retainedClone /= notesOf Postgres.disposableClone)+        assertEqual "" (refOf (Postgres.retainedClone silent ignoreTrack 5432 ignoreTrack (Postgres.Clone "c" "tpl" Nothing))) (refOf (Postgres.disposableClone silent ignoreTrack 5432 ignoreTrack (Postgres.Clone "c" "tpl" Nothing)))+    ]+  where+    refOf o = fmap (\act -> act.extension.ref) (opAct o)++-------------------------------------------------------------------------------++-- | The binaries the recipe reaches along its chain, as in "Test.PostgresInitSpec".+shimmedCommands :: [String]+shimmedCommands = ["apt-get", "dpkg-query", "sudo", "bash", "chmod"]++templateLifecycle :: IO ()+templateLifecycle = requireExecutable "podman" $+    withContainer (Podman.Image "debian:bookworm") (Podman.PortMapping "15434" "5432" Podman.TCPPort) $ \cid -> do+        podmanExec_ cid ["apt-get", "update", "-qq"]+        podmanExec_ cid ["bash", "-c", "DEBIAN_FRONTEND=noninteractive apt-get install -y -qq sudo"]+        builds <- newIORef (0 :: Int)++        let cluster = Track $ Postgres.pgLocalCluster silent Debian.postgres Debian.pg_ctlcluster+            tplOp fp table =+                PGTemplate.template+                    silent+                    cluster+                    Debian.psql+                    Postgres.localServer+                    (PGTemplate.Template "fixture_tpl" fp)+                    (createTable builds "fixture_tpl" table)+            -- teardown needs none of the dependencies: tearing those down+            -- would uninstall postgres from under the next step.+            bare fp = PGTemplate.template silent ignoreTrack ignoreTrack Postgres.localServer (PGTemplate.Template "fixture_tpl" fp) realNoop+            clone name = Postgres.disposableClone silent ignoreTrack 5432 ignoreTrack (Postgres.Clone name "fixture_tpl" Nothing)+            kept name = Postgres.retainedClone silent ignoreTrack 5432 ignoreTrack (Postgres.Clone name "fixture_tpl" Nothing)+            catalog db = psqlIn cid "postgres" ("SELECT datistemplate, datallowconn FROM pg_database WHERE datname = '" <> db <> "'")++        withShimmedPath cid shimmedCommands $ do+            ok1 <- runUp (tplOp "v1" "one")+            assertBool "the first build succeeds" ok1+            (catalog "fixture_tpl" >>=) $ assertEqual "locked as a template" "t|f"++            reports <- runUpCapturing (tplOp "v1" "one")+            assertBool ("the second pass succeeds: " <> show [(a.extension.help, e) | UpDown.Failed a e <- reports]) (null [() | UpDown.Failed _ _ <- reports])+            (readIORef builds >>=) $ assertEqual "unchanged inputs are not rebuilt" 1++            ok3 <- runUp (tplOp "v2" "two")+            assertBool "the rebuild succeeds" ok3+            (readIORef builds >>=) $ assertEqual "changed inputs are rebuilt" 2++            okc <- runUp (clone "copy")+            assertBool "the clone succeeds" okc+            tables <- psqlIn cid "copy" "SELECT string_agg(tablename, ',') FROM pg_tables WHERE schemaname = 'public'"+            assertEqual "a rebuild starts from nothing: only v2's table is in the copy" "two" tables++            podmanExec_ cid ["sudo", "-u", "postgres", "psql", "-c", "CREATE DATABASE precious"]+            okt <- runUp (PGTemplate.template silent ignoreTrack ignoreTrack Postgres.localServer (PGTemplate.Template "precious" "v1") realNoop)+            assertBool "a template refuses to replace a foreign database" (not okt)+            okp <- runUp (clone "precious")+            assertBool "a clone refuses to adopt a foreign database" (not okp)+            (catalog "precious" >>=) $ assertEqual "and the foreign database is untouched" "f|t"++            okk <- runDown (kept "copy")+            assertBool "a retained clone's teardown succeeds" okk+            (catalog "copy" >>=) $ assertEqual "and leaves the database, data included" "f|t"+            (psqlIn cid "copy" "SELECT count(*) FROM two" >>=) $ assertEqual "" "0"++            okd <- runDown (clone "copy")+            assertBool "the clone goes down" okd+            (catalog "copy" >>=) $ assertEqual "and is gone" ""+            okdt <- runDown (bare "v2")+            assertBool "the template goes down" okdt+            (catalog "fixture_tpl" >>=) $ assertEqual "and is gone" ""+            okdp <- runDown (clone "precious")+            assertBool "a foreign database is not dropped as a clone" (not okdp)+            (catalog "precious" >>=) $ assertEqual "and survives" "f|t"+  where+    psqlIn :: String -> String -> String -> IO String+    psqlIn cid db sql = do+        (code, out, err) <- podmanExecCapture cid ["sudo", "-u", "postgres", "psql", "-tAX", "-d", db, "-c", sql]+        assertEqual err ExitSuccess code+        pure (filter (/= '\n') out)++-- | The build under test: one table, and a count of how often it ran.+createTable :: IORef Int -> String -> String -> Op+createTable builds db table =+    op "create-fixture-table" nodeps $ \actions ->+        actions+            { ref = mkRef "create-fixture-table" (db, table)+            , up = do+                modifyIORef' builds (+ 1)+                (code, _, err) <- readProcessWithExitCode "sudo" ["-u", "postgres", "psql", "-X", "-d", db, "-c", "CREATE TABLE " <> table <> " (id int)"] ""+                assertEqual err ExitSuccess code+            }
+ test/Test/PostgresTlsSpec.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Coverage for "SreBox.PostgresTls" and the certificate/ownership builtins+it is built on.++Mostly Layer 0 -- the rendered @openssl@ and @pg_ctlcluster@ command lines,+and the connection string a client is handed. The ownership check is Layer 1,+against a real temp file, because what it asserts ("this file is @0600@") is+not something a fake can be wrong about in the way that matters: Postgres+refuses to start on a key one bit wider, and libpq refuses to connect.+-}+module Test.PostgresTlsSpec (tests) where++import Data.List (isInfixOf, isSubsequenceOf)+import qualified Data.Text as Text+import System.FilePath ((</>))+import System.Posix.Files (setFileMode)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Nodes.Binary (prepare)+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 qualified SreBox.PostgresTls as Tls++import System.Process.ListLike (CmdSpec (..), CreateProcess, cmdspec)+import Test.Harness (withTempDir)++tests :: TestTree+tests =+    testGroup+        "SreBox.PostgresTls"+        [ testGroup "certificate authority" caTests+        , testGroup "pg_hba" hbaTests+        , testGroup "client connection string" connStringTests+        , testGroup "file ownership" ownershipTests+        ]++processArgs :: CreateProcess -> [String]+processArgs p = case cmdspec p of+    RawCommand _ args -> args+    ShellCommand s -> [s]++isFailure :: CheckResult -> Bool+isFailure (Failure _) = True+isFailure _ = False++-------------------------------------------------------------------------------++caTests :: [TestTree]+caTests =+    [ testCase "the CA is created with req -x509, which is what marks it as an issuer" $ do+        -- `openssl x509 -req -signkey` (what selfSign does) produces a+        -- certificate that looks fine and is rejected as a CA.+        let args = processArgs (prepare Certs.openssl (Certs.GenSelfSignedCa "/k/ca.key" "/k/ca.pem" (Certs.Domain "salmon-pg-ca") 3650))+        assertBool (show args) (["req", "-x509", "-new"] `isSubsequenceOf` args)+        assertBool (show args) (["-days", "3650"] `isSubsequenceOf` args)+        assertBool (show args) ("/CN=salmon-pg-ca" `elem` args)+    , testCase "signing names the CA's certificate and key, and creates a serial" $ do+        let args = processArgs (prepare Certs.openssl (Certs.SignCSRWithCa "/k/c.csr" "/k/ca.pem" "/k/ca.key" "/k/c.pem" 397))+        assertBool (show args) (["-CA", "/k/ca.pem"] `isSubsequenceOf` args)+        assertBool (show args) (["-CAkey", "/k/ca.key"] `isSubsequenceOf` args)+        assertBool (show args) ("-CAcreateserial" `elem` args)+        assertBool (show args) (["-days", "397"] `isSubsequenceOf` args)+    , testCase "a client's certificate is requested under the role's own name" $ do+        -- clientcert=verify-full compares the CN against the role, so these+        -- two strings being the same is the whole authentication.+        let cfg =+                Tls.ClientMaterialConfig+                    { Tls.cmc_role = "postgrest_authenticator"+                    , Tls.cmc_authority = authority+                    , Tls.cmc_dir = "/certs"+                    , Tls.cmc_keyType = Certs.RSA4096+                    , Tls.cmc_validityDays = 397+                    }+            (cert, key, ca) = Tls.clientMaterialPaths cfg+        assertEqual "" "/certs/postgrest_authenticator.pem" cert+        assertEqual "" "/certs/postgrest_authenticator.key" key+        assertEqual "" "/certs/ca.pem" ca+    ]+  where+    authority =+        Certs.CertificateAuthority+            { Certs.caKey = Certs.Key Certs.RSA4096 "/ca" "ca.key"+            , Certs.caCertPath = "/ca/ca.pem"+            , Certs.caCommonName = Certs.Domain "salmon-pg-ca"+            , Certs.caValidityDays = 3650+            }++-------------------------------------------------------------------------------++hbaTests :: [TestTree]+hbaTests =+    [ testCase "the line demands TLS and a certificate whose CN is the role" $ do+        let s = hbaScript (Postgres.EnsureHbaLine "main" line)+        assertBool s ("hostssl api_db postgrest_authenticator 0.0.0.0/0 cert clientcert=verify-full" `isInfixOf` s)+    , testCase "the line is appended only if missing, then the cluster is reloaded" $ do+        let s = hbaScript (Postgres.EnsureHbaLine "main" line)+        assertBool s ("grep -qxF" `isInfixOf` s)+        assertBool s ("reload" `isInfixOf` s)+    ]+  where+    line = Text.unwords ["hostssl", "api_db", "postgrest_authenticator", "0.0.0.0/0", "cert", "clientcert=verify-full"]+    hbaScript cmd = case processArgs (prepare Postgres.pgctlRun cmd) of+        (_ : s : _) -> s+        other -> error (show other)++-------------------------------------------------------------------------------++connStringTests :: [TestTree]+connStringTests =+    [ testCase "the connection string is the one libpq wants, with no password in it" $+        assertEqual+            ""+            "host=db.example port=5432 dbname=api_db user=postgrest_authenticator sslmode=verify-ca sslcert=/opt/secrets/cert.pem sslkey=/opt/secrets/key.pem sslrootcert=/opt/secrets/ca.pem"+            ( Tls.clientConnString+                (Postgres.Server "db.example" 5432)+                "api_db"+                "postgrest_authenticator"+                Tls.VerifyCa+                ("/opt/secrets/cert.pem", "/opt/secrets/key.pem", "/opt/secrets/ca.pem")+            )+    , testCase "verify-full is available for a CA that also issues elsewhere" $+        assertEqual "" "verify-full" (Tls.renderSslMode Tls.VerifyFull)+    ]++-------------------------------------------------------------------------------++ownershipTests :: [TestTree]+ownershipTests =+    [ testCase "a key Postgres would refuse is reported, and the mode is named" $+        withTempDir $ \tmp -> do+            let path = tmp </> "server.key"+            writeFile path "not really a key\n"+            setFileMode path 0o644+            result <- FS.checkOwnership (ownership path)+            case result of+                Failure msg -> do+                    assertBool (show msg) ("0o644" `Text.isInfixOf` msg)+                    assertBool (show msg) ("0o600" `Text.isInfixOf` msg)+                other -> assertBool (show other) False+    , testCase "a key at 0600 is satisfying" $+        withTempDir $ \tmp -> do+            let path = tmp </> "server.key"+            writeFile path "not really a key\n"+            setFileMode path 0o600+            assertEqual "" Success =<< FS.checkOwnership (ownership path)+    , testCase "applying the ownership is what makes the check pass" $+        withTempDir $ \tmp -> do+            let path = tmp </> "server.key"+            writeFile path "not really a key\n"+            setFileMode path 0o666+            FS.applyOwnership (ownership path)+            assertEqual "" Success =<< FS.checkOwnership (ownership path)+    , testCase "a missing file is this node failing, not this node's job to fix" $+        withTempDir $ \tmp ->+            assertBool "" . isFailure =<< FS.checkOwnership (ownership (tmp </> "absent.key"))+    ]+  where+    -- user/group left alone: the test process cannot chown to postgres, and+    -- the mode is the half that matters to both Postgres and libpq.+    ownership path =+        FS.FileOwnership+            { FS.ownedPath = path+            , FS.ownedUser = Nothing+            , FS.ownedGroup = Nothing+            , FS.ownedMode = 0o600+            }
+ test/Test/PostgresVms.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE OverloadedStrings #-}++{- | What the Layer 3 Postgres specs share: the two VM rootfses, the+replication fixture binary, and the handful of remote commands every one of+them needs.++The reason this module exists is the state a guest leaves behind. A rootfs+is a directory on the host, so it outlives its VM and a spec starts from+whatever the last one did -- which, once a switchover is in the picture,+includes "the machine that used to be the primary is now a standby". Every+spec here therefore /normalizes/ on the way in rather than assuming, and+'ensurePrimary' and 'resetCluster' are that normalization.+-}+module Test.PostgresVms (+    primaryRootfs,+    standbyRootfs,+    requirePgVmPrereqs,+    resolveFixtureBinary,+    installFixture,+    runFixture,+    psql,+    psqlOrDie,+    sshOrDie,+    ensurePrimary,+    resetCluster,+    startCluster,+    stopCluster,+    crashCluster,+    dataDirectoryIdentity,+    walMegabytes,+    assertPrimaryIs,+    assertInRecovery,+    assertStandbyOf,+    waitFor,+    waitForUpTo,+    partitionFrom,+    partitionFromEverythingFor,+    healPartition,+    controllerAddr,+) where++import Control.Concurrent (threadDelay)+import Control.Monad (unless)+import Data.List (isInfixOf)+import System.Directory (doesFileExist, findExecutable)+import System.Exit (ExitCode (..))+import System.IO (hPutStrLn, stderr)+import Data.Text (Text)+import qualified Data.Text as Text+import System.Process (CmdSpec (..), cmdspec, readProcessWithExitCode)++import qualified Salmon.Builtin.Nodes.Binary as Binary+import qualified Salmon.Builtin.Nodes.Netfilter as Netfilter+import Test.Harness+import Test.Tasty.HUnit (assertBool)++primaryRootfs, standbyRootfs :: FilePath+primaryRootfs = "/var/lib/salmon-test-vms/pg-primary/root"+standbyRootfs = "/var/lib/salmon-test-vms/pg-standby/root"++{- | Skips loudly rather than failing when the machine cannot run these:+qemu, the bridge privileges, and the two rootfses. See+"Test.PostgresReplicationSpec" for how to build them.+-}+requirePgVmPrereqs :: IO () -> IO ()+requirePgVmPrereqs act = do+    privileged <- hasVmPrivileges+    hasQemu <- (/= Nothing) <$> findExecutable "qemu-system-x86_64"+    hasA <- doesFileExist (primaryRootfs <> "/etc/issue")+    hasB <- doesFileExist (standbyRootfs <> "/etc/issue")+    case () of+        _+            | not privileged -> skip "needs root, or ip/qemu-system-x86_64 setcap'd (see Test.Harness.hasVmPrivileges)"+            | not hasQemu -> skip "qemu-system-x86_64 not found on PATH"+            | not hasA -> skip ("no VM rootfs at " <> primaryRootfs <> " (see Test.PostgresReplicationSpec)")+            | not hasB -> skip ("no VM rootfs at " <> standbyRootfs <> " (see Test.PostgresReplicationSpec)")+            | otherwise -> act+  where+    skip msg = hPutStrLn stderr ("SKIPPED: " <> msg)++{- | The fixture binary isn't on PATH; resolve its build location via cabal+itself rather than hardcoding a dist-newstyle path that'd break on a+different GHC\/cabal version.+-}+resolveFixtureBinary :: IO FilePath+resolveFixtureBinary = do+    (code, out, err) <- readProcessWithExitCode "cabal" ["list-bin", "salmon-postgres-replication-fixture"] ""+    case code of+        -- `cabal` can print extra notices before the path on stdout (e.g. as+        -- root under sudo, with no prior cabal config); the bin path is+        -- always the last non-blank line.+        ExitSuccess -> case filter (not . null) (lines out) of+            [] -> error "resolveFixtureBinary: `cabal list-bin` produced no output"+            ls -> pure (last ls)+        ExitFailure n ->+            error $+                "resolveFixtureBinary: `cabal list-bin salmon-postgres-replication-fixture` failed with exit "+                    <> show n+                    <> " -- build it first: cabal build salmon-postgres-replication-fixture\n"+                    <> err++-- | Copies the fixture onto a guest and makes it executable.+installFixture :: VmAccess -> FilePath -> IO ()+installFixture vm bin = do+    scpToVm vm bin "/root/fixture"+    -- scp doesn't reliably carry the exec bit over without -p; set it explicitly.+    sshOrDie vm ["chmod", "+x", "/root/fixture"]++-- | Runs the fixture, and on failure says what the machine looked like.+runFixture :: VmAccess -> [String] -> IO ()+runFixture vm args = do+    (code, out, err) <- sshToVm vm (["/root/fixture"] <> args)+    unless (code == ExitSuccess) $ do+        (_, lsOut, _) <- sshToVm vm ["pg_lsclusters"]+        (_, logOut, _) <-+            sshToVm+                vm+                [ "bash"+                , "-c"+                , quoteForRemoteShell "cat /var/log/postgresql/*.log 2>&1; echo ---journal---; journalctl --no-pager -n 100 2>&1 | grep -i postgres; echo ---run---; ls -la /var/run/postgresql 2>&1"+                ]+        assertBool+            ( "fixture "+                <> unwords args+                <> " failed: "+                <> show code+                <> "\n"+                <> out+                <> err+                <> "\n--- pg_lsclusters ---\n"+                <> lsOut+                <> "\n--- logs ---\n"+                <> logOut+            )+            False++psql :: VmAccess -> String -> IO (ExitCode, String, String)+psql vm sql = sshToVm vm ["sudo", "-u", "postgres", "psql", "-tAXc", quoteForRemoteShell sql]++psqlOrDie :: VmAccess -> String -> IO ()+psqlOrDie vm sql = do+    (code, out, err) <- psql vm sql+    unless (code == ExitSuccess) (fail ("psql failed: " <> sql <> "\n" <> out <> err))++sshOrDie :: VmAccess -> [String] -> IO ()+sshOrDie vm args = do+    (code, out, err) <- sshToVm vm args+    unless (code == ExitSuccess) (fail ("remote command failed: " <> unwords args <> "\n" <> out <> err))++{- | Makes this machine a primary, whatever it was.++A spec that ends with the primary on the other machine leaves this one a+standby, and everything a later spec does -- creating a role, writing a row+-- then fails with "cannot execute ... in a read-only transaction", which+names the symptom and not the cause. Promoting is enough: a standby that has+been promoted is an ordinary primary, and one that already was one says so+and is left alone.+-}+ensurePrimary :: VmAccess -> IO ()+ensurePrimary vm = do+    -- a spec is allowed to end with a cluster stopped -- S6 does, having+    -- stopped the standby to see what the primary's disk does about it --+    -- and the next one still starts from a machine, not from an error.+    started <- startCluster vm+    unless started $ do+        -- and a guest killed mid-write leaves a data directory that no+        -- longer has a valid checkpoint to start from, which this tier does+        -- routinely: every run that is interrupted stops a VM with postgres+        -- writing. A scratch fixture that cannot start is not data anybody+        -- is keeping, and the alternative is every spec after this one+        -- failing on the same corpse -- including in ways that do not look+        -- like a broken cluster at all, since a cluster crash-looping on a+        -- 512MB guest starves the sshd the next spec needs.+        hPutStrLn stderr "NOTE: the cluster would not start; recreating it (see Test.PostgresVms.ensurePrimary)"+        resetCluster vm+    (_, out, _) <- psql vm "SELECT pg_is_in_recovery();"+    unless ("f" `isInfixOf` out) $ do+        psqlOrDie vm "SELECT pg_promote(true, 60);"+        waitOut (30 :: Int)+  where+    waitOut 0 = fail "a standby never finished promoting"+    waitOut n = do+        (_, out, _) <- psql vm "SELECT pg_is_in_recovery();"+        if "f" `isInfixOf` out then pure () else threadDelay 2000000 >> waitOut (n - 1)++{- | Drops this machine's cluster and creates an empty one.++For the standby, whose data directory is about to be replaced by a clone+anyway: starting from a cluster that was just created is also the state the+clone's own "pristine" branch is written for.++It removes both directories by hand rather than trusting @pg_dropcluster@+with the job, because the state this has to survive is a /half/ a cluster. A+run interrupted between "remove the data directory" and "clone into it", or+between the drop's two halves, leaves one of the two directories without the+other -- and then @pg_lsclusters@ lists nothing, so there is nothing to drop,+while @pg_createcluster@ finds a data directory to adopt and fails on the+config files a clone does not have. That is a wreck no amount of asking+politely gets rid of.+-}+resetCluster :: VmAccess -> IO ()+resetCluster vm =+    sshOrDie+        vm+        [ "bash"+        , "-c"+        , quoteForRemoteShell . unwords $+            [ -- ssh forwards the host's LANG, and pg_createcluster refuses a+              -- locale the guest does not have.+              "export LANG=C LC_ALL=C;"+            , "set -e;"+            , -- not pg_lsclusters: there may be no cluster to list.+              "version=$(ls /usr/lib/postgresql | sort -n | tail -n1);"+            , "if pg_lsclusters --no-header | awk '{print $2}' | grep -qx main;"+            , "then pg_dropcluster \"$version\" main --stop || true; fi;"+            , "rm -rf \"/etc/postgresql/$version/main\" \"/var/lib/postgresql/$version/main\";"+            , "pg_createcluster \"$version\" main -p 5432 -- --auth-local=peer --auth-host=md5;"+            , "pg_ctlcluster \"$version\" main start"+            ]+        ]++{- | Starts the cluster if it is not running, and says whether it is running+now. Unlike the rest of these helpers, it does not die on failure: its+callers have somewhere better to go than an exception.+-}+startCluster :: VmAccess -> IO Bool+startCluster vm = do+    (code, _, _) <-+        sshToVm+            vm+            [ "bash"+            , "-c"+            , quoteForRemoteShell . unwords $+                [ "version=$(pg_lsclusters --no-header | awk '{print $1}' | head -n1);"+                , "pg_ctlcluster \"$version\" main status >/dev/null 2>&1 ||"+                , "pg_ctlcluster \"$version\" main start"+                ]+            ]+    pure (code == ExitSuccess)++{- | Stops this machine's cluster the way an operator would, leaving a+shutdown checkpoint behind: what it stopped at is then on disk, and a+promotion elsewhere can prove it lost nothing.+-}+stopCluster :: VmAccess -> IO ()+stopCluster vm = pgCtl vm "stop"++{- | Kills this machine's cluster the way a crash would, leaving nothing+behind: whatever it wrote after its last checkpoint is in the WAL and in no+control file, which is the state a failover cannot reason about.+-}+crashCluster :: VmAccess -> IO ()+crashCluster vm = do+    sshOrDie+        vm+        [ "bash"+        , "-c"+        , quoteForRemoteShell . unwords $+            [ "version=$(pg_lsclusters --no-header | awk '{print $1}' | head -n1);"+            , -- the unit's whole cgroup, so no backend outlives the postmaster+              "systemctl kill -s KILL postgresql@\"$version\"-main 2>/dev/null;"+            , "pkill -9 -u postgres 2>/dev/null;"+            , "true"+            ]+        ]+    waitFor "the cluster never died" $ do+        (code, out, _) <- sshToVm vm ["pg_lsclusters", "--no-header"]+        pure (code /= ExitSuccess || not ("online" `isInfixOf` out), out)++pgCtl :: VmAccess -> String -> IO ()+pgCtl vm action =+    sshOrDie+        vm+        [ "bash"+        , "-c"+        , quoteForRemoteShell . unwords $+            [ "set -e;"+            , "version=$(pg_lsclusters --no-header | awk '{print $1}' | head -n1);"+            , "pg_ctlcluster \"$version\" main " <> action+            ]+        ]++{- | Something about this cluster's data directory that survives a rewind and+cannot survive a re-clone: the inodes of the directory and of the one file in+it that never changes.++This is how a test tells "the old primary was rewound onto the new one" from+"the old primary was thrown away and copied back", which from the outside+look alike -- same rows, same system identifier, same timeline. Only one of+them unlinks anything.+-}+dataDirectoryIdentity :: VmAccess -> IO String+dataDirectoryIdentity vm = do+    (code, out, err) <-+        sshToVm+            vm+            [ "bash"+            , "-c"+            , quoteForRemoteShell . unwords $+                [ "set -e;"+                , "version=$(pg_lsclusters --no-header | awk '{print $1}' | head -n1);"+                , "datadir=/var/lib/postgresql/$version/main;"+                , "stat -c %i \"$datadir\" \"$datadir/PG_VERSION\""+                ]+            ]+    unless (code == ExitSuccess) (fail ("could not read the data directory: " <> out <> err))+    pure (unwords (words out))++-- | How much disk the write-ahead log is taking, in megabytes.+walMegabytes :: VmAccess -> IO Int+walMegabytes vm = do+    (code, out, err) <-+        sshToVm+            vm+            [ "bash"+            , "-c"+            , quoteForRemoteShell . unwords $+                [ "set -e;"+                , "version=$(pg_lsclusters --no-header | awk '{print $1}' | head -n1);"+                , "du -sm \"/var/lib/postgresql/$version/main/pg_wal\" | awk '{print $1}'"+                ]+            ]+    unless (code == ExitSuccess) (fail ("could not measure pg_wal: " <> out <> err))+    case reads (takeWhile (/= '\n') out) of+        [(n, _)] -> pure n+        _ -> fail ("could not read a size from: " <> out)++assertPrimaryIs :: VmAccess -> IO ()+assertPrimaryIs vm = do+    (_, out, _) <- psql vm "SELECT pg_is_in_recovery();"+    assertBool ("expected a primary, got: " <> out) ("f" `isInfixOf` out)++{- | Polls: a standby takes a moment to connect to its primary, and every+spec that moves one waits for the same thing.+-}+assertStandbyOf :: VmAccess -> Text -> IO ()+assertStandbyOf vm host =+    waitFor ("never became a standby of " <> Text.unpack host) $ do+        (_, out, _) <- psql vm "SELECT coalesce((SELECT sender_host FROM pg_stat_wal_receiver LIMIT 1), 'none');"+        pure (Text.unpack host `isInfixOf` out, out)++assertInRecovery :: VmAccess -> IO ()+assertInRecovery vm = do+    (_, out, _) <- psql vm "SELECT pg_is_in_recovery();"+    assertBool ("expected a standby, got: " <> out) ("t" `isInfixOf` out)++{- | Polls every two seconds for a minute, and says what it last saw rather+than only that it gave up. Every one of these waits is on a machine doing+something in its own time -- a standby connecting, a promotion finishing, a+row arriving -- and none of them is instant.+-}+waitFor :: String -> IO (Bool, String) -> IO ()+waitFor = waitForUpTo 30++-- | 'waitFor' with a different number of two-second tries.+waitForUpTo :: Int -> String -> IO (Bool, String) -> IO ()+waitForUpTo tries what probe = go tries+  where+    go :: Int -> IO ()+    go 0 = do+        (_, seen) <- probe+        fail (what <> "; last seen: " <> seen)+    go n = do+        (ok, _) <- probe+        unless ok (threadDelay 2000000 >> go (n - 1))++{- | The host's address on the test bridge, which is where the controller+runs: a partition that is meant to cut a machine off from the /operator/ has+to drop this one too, and one that is only between the members must not.+-}+controllerAddr :: Text+controllerAddr = "10.99.0.1"++{- | Cuts this machine off from those addresses, which is what a partition+looks like from inside one of them.++The rules are built out of "Salmon.Builtin.Nodes.Netfilter"'s own vocabulary+and rendered by its own @nft@ command, so this says what a salmon-declared+firewall would say. It is only the /running/ of it that differs: these guests+have no salmon on them, so the argv goes over ssh instead of into an 'Op'.++Dropping by source address in @input@ breaks the connection in both+directions, since neither end gets an answer -- including, if+'controllerAddr' is among them, the ssh session that adds the rule. Hence+'healPartition' and, for that case, a caller that detaches.+-}+partitionFrom :: VmAccess -> [Text] -> IO ()+partitionFrom vm addrs = mapM_ (sshOrDie vm . map quoteForRemoteShell) (partitionCommands addrs)++-- | Removes the whole table, whatever it held: a heal is not a negotiation.+{- | Cuts this machine off from everything named, the controller included,+and heals it again after @seconds@ with nobody asking.++A partition that hides a machine from its operator cannot be lifted by that+operator: the command that would lift it has to travel the path it cut. So+the machine is handed the whole sequence -- cut, wait, heal -- and left to+run it detached, which is also what anyone sensible does before touching the+firewall of a box they can only reach over the network.+-}+partitionFromEverythingFor :: VmAccess -> [Text] -> Int -> IO ()+partitionFromEverythingFor vm addrs seconds = do+    sshOrDie vm ["bash", "-c", quoteForRemoteShell heredoc]+    sshOrDie vm ["bash", "-c", quoteForRemoteShell "setsid bash /root/partition.sh >/dev/null 2>&1 </dev/null &"]+  where+    heredoc = "cat > /root/partition.sh <<'SALMON_EOF'\n" <> script <> "SALMON_EOF\n"+    script =+        unlines $+            [unwords (map quoteForRemoteShell argv) | argv <- partitionCommands addrs]+                <> [ "sleep " <> show seconds+                   , unwords ["nft", "delete", "table", "inet", Text.unpack partitionTable.tableName]+                   ]++healPartition :: VmAccess -> IO ()+healPartition vm = do+    _ <- sshToVm vm ["nft", "delete", "table", "inet", Text.unpack partitionTable.tableName]+    pure ()++partitionCommands :: [Text] -> [[String]]+partitionCommands addrs =+    map+        nftArgv+        ( [ Netfilter.AddTable partitionTable+          , Netfilter.AddChain partitionChain+          ]+            <> [Netfilter.AddRule partitionChain (Netfilter.RawRule ["ip", "saddr", addr, "drop"]) | addr <- addrs]+        )++partitionTable :: Netfilter.Table+partitionTable = Netfilter.Table "salmon_test_partition" Netfilter.Inet++partitionChain :: Netfilter.Chain+partitionChain =+    Netfilter.baseChain+        "input"+        partitionTable+        (Netfilter.BaseChainSpec Netfilter.FilterChain Netfilter.Input 0 Netfilter.Accept)++{- | What the builtin would run, as words to send somewhere else.++Each word is quoted where it is used rather than here: ssh joins its+arguments with spaces and the remote shell splits them again, so a chain+spec's @{@, @;@ and @}@ arrive as shell syntax unless something stops them.+-}+nftArgv :: Netfilter.NftCommand -> [String]+nftArgv cmd = case cmdspec (Binary.prepare Netfilter.nftcommand cmd) of+    RawCommand bin args -> bin : args+    ShellCommand sh -> ["sh", "-c", sh]
+ test/Test/PostgrestCloudRunSpec.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 0 coverage for "SreBox.Gcp.PostgrestCloudRun".++The interesting assertions are all about one seam: the credentials are+mounted at one set of paths and /used/ at another, because Cloud Run's mount+is read-only at @0444@ and libpq refuses a key that wide. So the entrypoint+copies them, and the connection string has to name the copies. Getting those+two out of step produces a service that deploys cleanly, starts, and then+fails every request with a permissions error naming a file the operator can+see is present.+-}+module Test.PostgrestCloudRunSpec (tests) where++import Data.List (isInfixOf)+import qualified Data.Map as Map+import qualified Data.Text as Text+import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++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.Podman as Podman+import qualified Salmon.Builtin.Nodes.Postgres as Postgres+import qualified SreBox.Gcp.PostgrestCloudRun as PCR+import qualified SreBox.PostgresTls as Tls++tests :: TestTree+tests =+    testGroup+        "SreBox.Gcp.PostgrestCloudRun"+        [ testGroup "the entrypoint" entrypointTests+        , testGroup "the image" containerfileTests+        , testGroup "secret bindings" bindingTests+        ]++cfg :: PCR.PostgrestCloudRunConfig+cfg =+    PCR.PostgrestCloudRunConfig+        { PCR.pcr_service = "api"+        , PCR.pcr_project = Core.Project "acme"+        , PCR.pcr_region = Core.Region "europe-west1"+        , PCR.pcr_serviceAccount = "api-sa@acme.iam.gserviceaccount.com"+        , PCR.pcr_repo = ArtifactRegistry.ArtifactRepo "repo" (Core.Project "acme") (Core.Region "europe-west1") ArtifactRegistry.Docker+        , PCR.pcr_image = "europe-west1-docker.pkg.dev/acme/repo/postgrest:v1"+        , PCR.pcr_authFile = Podman.AuthFile "/tmp/auth.json"+        , PCR.pcr_workDir = "/tmp/work"+        , PCR.pcr_postgrestImage = "postgrest/postgrest:v12.2.1"+        , PCR.pcr_db = Postgres.Server "db.example" 5432+        , PCR.pcr_database = "api_db"+        , PCR.pcr_role = "api_authenticator"+        , PCR.pcr_anonRole = "api_anonymous"+        , PCR.pcr_jwtRoleClaimKey = Just ".acme.jwt-claims.postgrest-role"+        , PCR.pcr_schemas = Nothing+        , PCR.pcr_sslMode = Tls.VerifyCa+        , PCR.pcr_clientMaterial = ("/certs/api_authenticator.pem", "/certs/api_authenticator.key", "/certs/ca.pem")+        , PCR.pcr_jwtSecretFile = Just "/secrets/jwt"+        , PCR.pcr_ingress = CloudRun.All+        , PCR.pcr_maxInstances = Just 1+        , PCR.pcr_cpu = Just "1000m"+        , PCR.pcr_memory = Just "256Mi"+        , PCR.pcr_concurrency = Just 80+        , PCR.pcr_allowUnauthenticated = False+        }++entrypoint :: String+entrypoint = Text.unpack (PCR.renderEntrypoint cfg)++entrypointTests :: [TestTree]+entrypointTests =+    [ testCase "narrows the copied credentials to 0600, which is the whole point" $ do+        assertBool entrypoint ("-type f -exec chmod 0600" `isInfixOf` entrypoint)+        assertBool entrypoint ("chmod 0700 /opt/secrets" `isInfixOf` entrypoint)+    , testCase "dereferences the mount, which is a symlink farm" $+        assertBool entrypoint ("cp -L /opt/vault/* /opt/secrets/" `isInfixOf` entrypoint)+    , testCase "execs, so PostgREST gets the SIGTERM Cloud Run sends when draining" $+        assertBool entrypoint ("exec /bin/postgrest" `isInfixOf` entrypoint)+    , testCase "takes the port from Cloud Run rather than from configuration" $+        assertBool entrypoint ("PGRST_SERVER_PORT=\"${PORT:-3000}\"" `isInfixOf` entrypoint)+    , testCase "parses as bash" $ do+        (code, _, err) <- readProcessWithExitCode "bash" ["-n", "-c", entrypoint] ""+        assertEqual err ExitSuccess code+    ]++containerfileTests :: [TestTree]+containerfileTests =+    [ testCase "copies the binary out of the pinned upstream image" $ do+        let c = Text.unpack (PCR.renderContainerfile cfg)+        assertBool c ("FROM postgrest/postgrest:v12.2.1 AS upstream" `isInfixOf` c)+        assertBool c ("COPY --from=upstream /bin/postgrest /bin/postgrest" `isInfixOf` c)+    , testCase "the base has libpq, without which nothing connects" $ do+        let c = Text.unpack (PCR.renderContainerfile cfg)+        assertBool c ("libpq5" `isInfixOf` c)+    ]++bindingTests :: [TestTree]+bindingTests =+    [ testCase "the connection string names where the files END UP, not where they are mounted" $ do+        -- The seam this module exists around. Naming the mount here gives a+        -- service that starts and then fails every request.+        let (rc, rk, rca) = PCR.runtimeMaterial+            uri =+                Tls.clientConnString+                    (Postgres.Server "db.example" 5432)+                    "api_db"+                    "api_authenticator"+                    Tls.VerifyCa+                    (rc, rk, rca)+        assertBool (Text.unpack uri) ("sslcert=/opt/secrets/cert.pem" `Text.isInfixOf` uri)+        assertBool (Text.unpack uri) (not ("/opt/vault" `Text.isInfixOf` uri))+    , testCase "the mounted paths are the ones the entrypoint copies from" $ do+        let (mc, _, _) = PCR.mountedMaterial+        assertEqual "" "/opt/vault/cert.pem" mc+        assertBool entrypoint (PCR.vaultDir `isInfixOf` entrypoint)+    , testCase "secret names are scoped to the service" $ do+        assertEqual "" "api-db-cert" (PCR.certSecretName cfg)+        assertEqual "" "api-db-key" (PCR.keySecretName cfg)+        assertEqual "" "api-db-ca" (PCR.caSecretName cfg)+        assertEqual "" "api-jwt" (PCR.jwtSecretName cfg)+    , testCase "the deployed environment points PostgREST at the copies" $ do+        let env = PCR.environment cfg+        case Map.lookup "PGRST_DB_URI" env of+            Just uri -> do+                assertBool (Text.unpack uri) ("sslkey=/opt/secrets/key.pem" `Text.isInfixOf` uri)+                assertBool (Text.unpack uri) ("user=api_authenticator" `Text.isInfixOf` uri)+                -- no password anywhere: the certificate is the whole credential+                assertBool (Text.unpack uri) (not ("password" `Text.isInfixOf` uri))+            Nothing -> assertBool "PGRST_DB_URI missing" False+        assertEqual "" (Just "api_anonymous") (Map.lookup "PGRST_DB_ANON_ROLE" env)+    , testCase "no jwt file means no jwt secret is referenced" $ do+        -- A revision naming a secret that was never uploaded fails to start.+        let without = cfg{PCR.pcr_jwtSecretFile = Nothing}+            rendered = map CloudRun.renderSecretBinding (PCR.secretBindings without)+        assertBool (show rendered) (not (any ("api-jwt" `Text.isInfixOf`) rendered))+        assertEqual "" 3 (length (PCR.secretBindings without))+        assertEqual "" 4 (length (PCR.secretBindings cfg))+    ]
+ test/Test/QemuResolveKernelSpec.hs view
@@ -0,0 +1,62 @@+{- | Layer 1 (pure filesystem, no root/VM needed): exercises+'Salmon.Builtin.Nodes.Qemu.resolveKernelInitrd''s three cases —+exactly one match, none, and more than one — against a scratch+@boot/@ directory built with 'System.IO.Temp.withSystemTempDirectory'.++Closes @specs/qemu-test-vms-progress.md@ §3 item 3: the prefix-match+assumption was previously only reasoned about from code review, unverified+against a rootfs holding a held-over old kernel (two @vmlinuz-*@\/+@initrd.img-*@ pairs). This confirms 'resolveKernelInitrd' throws a+caller-visible "ambiguous" error rather than silently picking one, and does+so without needing an actual multi-kernel debootstrap chroot.+-}+module Test.QemuResolveKernelSpec (tests) where++import Control.Exception (try)+import Data.List (isInfixOf)+import Salmon.Builtin.Nodes.Qemu (resolveKernelInitrd)+import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>))+import System.IO (IOMode (WriteMode), withFile)+import System.IO.Error (isUserError)+import System.IO.Temp (withSystemTempDirectory)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+    testGroup+        "Qemu.resolveKernelInitrd"+        [ testCase "resolves the single vmlinuz/initrd pair" resolvesSinglePair+        , testCase "throws when no kernel is present" (throwsContaining [] "no vmlinuz-")+        , testCase+            "throws when a held-over old kernel makes the match ambiguous"+            (throwsContaining ["vmlinuz-6.1.0-amd64", "initrd.img-6.1.0-amd64", "vmlinuz-5.10.0-amd64", "initrd.img-5.10.0-amd64"] "ambiguous vmlinuz-")+        ]++touch :: FilePath -> IO ()+touch path = withFile path WriteMode (const (pure ()))++withBoot :: [FilePath] -> (FilePath -> IO a) -> IO a+withBoot bootFiles act =+    withSystemTempDirectory "resolveKernelInitrd-spec" $ \rootfs -> do+        let bootDir = rootfs </> "boot"+        createDirectoryIfMissing True bootDir+        mapM_ (touch . (bootDir </>)) bootFiles+        act rootfs++resolvesSinglePair :: IO ()+resolvesSinglePair = withBoot ["vmlinuz-6.1.0-amd64", "initrd.img-6.1.0-amd64", "System.map-6.1.0-amd64"] $ \rootfs -> do+    (kernel, initrd) <- resolveKernelInitrd rootfs+    kernel @?= rootfs </> "boot" </> "vmlinuz-6.1.0-amd64"+    initrd @?= rootfs </> "boot" </> "initrd.img-6.1.0-amd64"++-- | Asserts 'resolveKernelInitrd' throws a 'userError' whose message+-- contains @needle@, given a @boot/@ populated with @bootFiles@.+throwsContaining :: [FilePath] -> String -> IO ()+throwsContaining bootFiles needle = withBoot bootFiles $ \rootfs -> do+    result <- try (resolveKernelInitrd rootfs)+    case result of+        Left e | isUserError e -> assertBool ("expected error containing " <> show needle <> ", got: " <> show e) (needle `isInfixOf` show e)+        Left e -> assertFailure ("expected a userError, got: " <> show e)+        Right r -> assertFailure ("expected resolveKernelInitrd to throw, got: " <> show r)
+ test/Test/QemuShutdownSpec.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ScopedTypeVariables #-}++{- | Layer 1 (a unix socket in a temp directory, no qemu, no root): the+monitor-socket half of "Salmon.Builtin.Nodes.Qemu".'shutdown' against a fake+monitor. It shows the three answers the down hook depends on: a guest that+powers off (the socket goes away, no hard stop needed), one that ignores ACPI+(still listening at the deadline, so the caller must stop it hard) and a VM+that was never running (nothing to send to).+-}+module Test.QemuShutdownSpec (tests) where++import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, modifyMVar_, readMVar, tryPutMVar)+import Control.Exception (SomeException, bracket, try)+import Control.Monad (forever, void)+import qualified Data.ByteString.Char8 as C8+import Network.Socket hiding (shutdown)+import qualified Network.Socket.ByteString as SocketBS+import Salmon.Builtin.Nodes.Qemu (reset, shutdown)+import System.Directory (removeFile)+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++tests :: TestTree+tests =+    testGroup+        "Qemu.shutdown (monitor socket)"+        [ testCase "a guest that powers off: True, and the command was sent" powersOff+        , testCase "a guest that ignores ACPI: False at the deadline" ignoresAcpi+        , testCase "no monitor listening: True, nothing sent" neverRan+        , testCase "reset sends system_reset" sendsReset+        ]++-- | The commands received: the liveness probes (connect, hang up) send nothing and are dropped.+commands :: Fake -> IO [String]+commands fake = filter (not . null) <$> readMVar (received fake)++-- | What the fake monitor received, and whether it exits on @system_powerdown@.+data Fake = Fake {received :: MVar [String]}++withFake :: Bool -> (FilePath -> Fake -> IO a) -> IO a+withFake exitsOnPowerdown act =+    withSystemTempDirectory "qemu-mon" $ \dir -> do+        let path = dir </> "mon.sock"+        got <- newMVar []+        listener <- socket AF_UNIX Stream defaultProtocol+        bind listener (SockAddrUnix path)+        listen listener 5+        gone <- newEmptyMVar+        tid <- forkIO $ forever $ do+            (conn, _) <- accept listener+            void $ forkIO $ do+                line <- readLine conn+                modifyMVar_ got (pure . (line :))+                if exitsOnPowerdown && line == "system_powerdown"+                    then do+                        close listener+                        void (try @SomeException (removeFile path))+                        void (tryPutMVar gone ())+                    else pure ()+                close conn+        r <- act path (Fake got)+        killThread tid+        void (try @SomeException (close listener))+        pure r+  where+    readLine conn = do+        bs <- SocketBS.recv conn 4096+        pure (takeWhile (/= '\n') (C8.unpack bs))++powersOff :: IO ()+powersOff = withFake True $ \path fake -> do+    ok <- shutdown 5 path+    ok @?= True+    commands fake >>= (@?= ["system_powerdown"])++ignoresAcpi :: IO ()+ignoresAcpi = withFake False $ \path fake -> do+    ok <- shutdown 1 path+    ok @?= False+    commands fake >>= (@?= ["system_powerdown"])++neverRan :: IO ()+neverRan = withSystemTempDirectory "qemu-mon" $ \dir -> do+    ok <- shutdown 1 (dir </> "absent.sock")+    ok @?= True++sendsReset :: IO ()+sendsReset = withFake False $ \path fake -> do+    ok <- reset path+    ok @?= True+    threadDelay 100000+    commands fake >>= (@?= ["system_reset"])
+ test/Test/QemuSmokeSpec.hs view
@@ -0,0 +1,60 @@+{- | Layer 3 smoke test: boots a real qemu VM via 'Test.Harness.withVm' and+proves SSH into it actually works end to end (bridge/tap up, kernel boots,+9p root mounts, network configures, sshd answers) — see+@specs/qemu-test-vms-progress.md@ for the design/validation history this+closes out (step 4 of its "exact next steps").++Needs either root or the one-time capability setup described in+'Test.Harness.hasVmPrivileges' (bridge/tap + a systemd unit running qemu,+matching this whole VM tier's documented privilege assumption — see+"Salmon.Builtin.Nodes.Qemu"'s haddock) and a pre-built VM rootfs at+'smokeRootfs', with+'Salmon.Builtin.Nodes.Debian.Debootstrap.vmEssentials' and+'Salmon.Builtin.Nodes.Debian.Debootstrap.ensureVm9pBoot' already applied+(this test does not run debootstrap itself, same stance as+'Test.Harness.withVm') — no SSH key pre-provisioning needed, 'withVm'+generates and trusts its own per-boot CA-signed key:++> sudo debootstrap --include=linux-image-amd64,openssh-server stable /var/lib/salmon-test-vms/smoke/root++Both preconditions are checked and skipped loudly (not failed) if unmet,+same "skip/fail loudly, don't hang" spirit as 'Test.Harness.requireExecutable'.+-}+module Test.QemuSmokeSpec (tests) where++import System.Directory (doesFileExist, findExecutable)+import System.Exit (ExitCode (..))+import System.IO (hPutStrLn, stderr)+import Test.Harness+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase)++tests :: TestTree+tests =+    testGroup+        "Qemu (Layer 3, real VM boot via withVm)"+        [testCase "boots the smoke rootfs and answers SSH" bootsAndAnswersSsh]++smokeRootfs :: FilePath+smokeRootfs = "/var/lib/salmon-test-vms/smoke/root"++bootsAndAnswersSsh :: IO ()+bootsAndAnswersSsh = do+    privileged <- hasVmPrivileges+    hasQemu <- (/= Nothing) <$> findExecutable "qemu-system-x86_64"+    hasRootfs <- doesFileExist (smokeRootfs <> "/etc/issue")+    if not privileged+        then skip "needs root, or ip/qemu-system-x86_64 setcap'd (see Test.Harness.hasVmPrivileges)"+        else+            if not hasQemu+                then skip "qemu-system-x86_64 not found on PATH"+                else+                    if not hasRootfs+                        then skip ("no VM rootfs at " <> smokeRootfs <> " (run debootstrap by hand first, see this module's haddock)")+                        else+                            withVm smokeRootfs $ \access -> do+                                (code, out, _err) <- sshToVm access ["echo smoke-ok"]+                                assertBool ("ssh into VM failed: " <> show code <> " / " <> out) (code == ExitSuccess)+                                assertBool ("unexpected ssh output: " <> out) ("smoke-ok" `elem` lines out)+  where+    skip msg = hPutStrLn stderr ("SKIPPED: " <> msg)
+ test/Test/QuerySpec.hs view
@@ -0,0 +1,256 @@+{- | Layer 0 coverage for "Salmon.Actions.Query" per @specs/advance-querying.md@:+pattern matching, selector resolution against a graph with a repeated+subtree (the same @Ref@ reachable at two paths — the "passwordless"/"chown"+shape the spec calls out), and 'Salmon.Actions.Query.forceSkip' actually+turning an excluded node into a 'Salmon.Actions.UpDown.Skip' at 'upTree'+time while leaving everything else unaffected.+-}+module Test.QuerySpec (tests) where++import Control.Monad.Identity (runIdentity)+import Data.IORef (modifyIORef', newIORef, readIORef)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Text (Text)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)++import qualified Salmon.Actions.Query as Query+import Salmon.Actions.UpDown (Report (..))+import Salmon.Builtin.Extension (Extension (..), Op, deps, evalDeps, nodeps, op, ref, up)+import qualified Salmon.Builtin.Nodes.Debian.Package as Debian+import Salmon.Op.Actions (extension)+import Salmon.Op.Eval (expand)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.OpGraph (inject)+import Salmon.Op.Ref (Ref, mkRef)+import qualified Salmon.Op.Rewrite as Rewrite+import Salmon.Reporter (silent)++import Test.Harness (runUpCapturing)++tests :: TestTree+tests =+    testGroup+        "Salmon.Actions.Query"+        [ testCase "* matches exactly one segment, ** matches any depth including zero" patternMatching+        , testCase "resolveSelectors: a shared predecessor is one Ref, matched at both its paths" sharedPredecessorRefs+        , testCase "resolveSelectors: empty --select means everything, minus --exclude" selectDefaultsToEverything+        , testCase "forceSkip makes upTree report Skip for the excluded node, Eval for the rest" forceSkipSkipsOnlyExcluded+        , testCase "pathedNodes carries each node's help text alongside its path/Ref" pathedNodesCarriesHelp+        , testCase "renderAnnotated tags same-path, distinct-Ref siblings with a stable shortRef so they aren't mistaken for duplicates" renderAnnotatedDisambiguatesSameTextSiblings+        , testCase "resolveRewrittenSelectors: a plain path selector behaves exactly as resolveSelectors" rewrittenPathSelectorUnchanged+        , testCase "resolveRewrittenSelectors: a #ref selector addresses a declared node directly" rewrittenRefSelectorAddressesDeclaredNode+        , testCase "resolveRewrittenSelectors: a #ref selector addressing a batch expands to its declared members" rewrittenRefSelectorExpandsABatch+        , testCase "resolveRewrittenSelectors: a path and a #ref selector combine" rewrittenPathAndRefSelectorsCombine+        , testCase "resolveRewrittenSelectors: an empty --select still means everything when --exclude is #ref-only" rewrittenEmptySelectStillMeansEverything+        ]++patternMatching :: IO ()+patternMatching = do+    assertBool "exact path matches itself" (Query.matchPattern (Query.parsePattern "/a/b/c") ["a", "b", "c"])+    assertBool "exact path does not match a different one" (not (Query.matchPattern (Query.parsePattern "/a/b/c") ["a", "b", "d"]))+    assertBool "* matches exactly one segment" (Query.matchPattern (Query.parsePattern "/a/*/c") ["a", "b", "c"])+    assertBool "* does not match zero segments" (not (Query.matchPattern (Query.parsePattern "/a/*/c") ["a", "c"]))+    assertBool "* does not match two segments" (not (Query.matchPattern (Query.parsePattern "/a/*/c") ["a", "b", "b2", "c"]))+    assertBool "** matches any depth" (Query.matchPattern (Query.parsePattern "/a/**") ["a", "b", "c", "d"])+    assertBool "** matches zero segments" (Query.matchPattern (Query.parsePattern "/a/**") ["a"])+    assertBool "** alone matches everything" (Query.matchPattern (Query.parsePattern "/**") ["a", "b", "c"])++-- | @root@ depends on @a@ and @b@, both of which depend on the one @shared@+-- node — same shape 'Test.DownTreeSpec.sharedPredecessorLast' uses.+sharedGraph :: Op+sharedGraph = root+  where+    shared = op "shared" nodeps $ \x -> x{ref = mkRef "leaf" ("shared" :: Text)}+    a = op "a" (deps [shared]) $ \x -> x{ref = mkRef "mid" ("a" :: Text)}+    b = op "b" (deps [shared]) $ \x -> x{ref = mkRef "mid" ("b" :: Text)}+    root = op "root" (deps [a, b]) $ \x -> x{ref = mkRef "root" ()}++sharedPredecessorRefs :: IO ()+sharedPredecessorRefs = do+    let cograph = runIdentity (expand sharedGraph)+        entries = Query.pathedRefs cograph+        sharedPaths = [path | (path, r) <- entries, r == mkRef "leaf" ("shared" :: Text)]+    assertEqual "the shared Ref appears at two distinct paths" 2 (length sharedPaths)+    assertBool "reachable through /root/a/shared" (["root", "a", "shared"] `elem` sharedPaths)+    assertBool "reachable through /root/b/shared" (["root", "b", "shared"] `elem` sharedPaths)+    let (selected, excluded) = Query.resolveSelectors cograph [] ["/root/a/**"]+    assertBool "excluding through one path excludes the shared Ref" (mkRef "leaf" ("shared" :: Text) `Set.member` excluded)+    assertBool "the shared Ref is therefore not selected either" (mkRef "leaf" ("shared" :: Text) `Set.notMember` selected)+    assertBool "'a' itself is excluded" (mkRef "mid" ("a" :: Text) `Set.member` excluded)+    assertBool "'b' is untouched" (mkRef "mid" ("b" :: Text) `Set.notMember` excluded)++selectDefaultsToEverything :: IO ()+selectDefaultsToEverything = do+    let cograph = runIdentity (expand sharedGraph)+        allRefs = Set.fromList (map snd (Query.pathedRefs cograph))+        (selectedAll, _) = Query.resolveSelectors cograph [] []+        (selectedSubtree, _) = Query.resolveSelectors cograph ["/root/a/**"] []+    assertEqual "no --select at all means every node is selected" allRefs selectedAll+    assertBool "a --select scopes down to a subtree" (mkRef "mid" ("a" :: Text) `Set.member` selectedSubtree)+    assertBool "a --select excludes what it doesn't match" (mkRef "mid" ("b" :: Text) `Set.notMember` selectedSubtree)++-- | Diamond shape reached two ways ('inject' + 'deps', like+-- 'Test.DownTreeSpec.diamondApexOnceLast'), so dedup-by-'Ref' at 'upTree'+-- time is exercised alongside the force-skip itself: 'apex' is excluded, and+-- must be reported 'Skip'ped — once, because the collapse to a+-- 'Salmon.Op.Dag.Dag' makes it one node, and never 'Eval'ed.+forceSkipSkipsOnlyExcluded :: IO ()+forceSkipSkipsOnlyExcluded = do+    ranRef <- newIORef []+    let rec name = modifyIORef' ranRef (name :)+        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" nodeps $ \x -> x{ref = mkRef "mid" ("right" :: Text), up = rec "right"}) `inject` apex+        root = op "root" (deps [left, right]) $ \x -> x{ref = mkRef "root" (), up = rec "root"}+        excluded = Set.singleton (mkRef "leaf" ("apex" :: Text))+        skipped = Query.forceSkip excluded root+    reports <- runUpCapturing skipped+    ran <- reverse <$> readIORef ranRef+    assertBool "apex's up never actually ran" ("apex" `notElem` ran)+    assertBool "everything else's up did run" (["left", "right", "root"] == ran || ["right", "left", "root"] == ran)+    let isApex act = ref (extension act) == mkRef "leaf" ("apex" :: Text)+    let skips = [() | Skip act <- reports, isApex act]+    let evals = [() | Eval act <- reports, isApex act]+    assertEqual "apex reported Skip exactly once, however many paths reach it" 1 (length skips)+    assertEqual "apex never reported Eval" 0 (length evals)++-- | 'query show --dedupe' collapses a shared node's repeated occurrences down+-- to its first-encountered path; 'query show --descriptions' needs each+-- node's help text alongside it, which is what 'pathedNodes' adds over+-- 'pathedRefs'.+pathedNodesCarriesHelp :: IO ()+pathedNodesCarriesHelp = do+    let shared = op "shared" nodeps $ \x -> x{ref = mkRef "leaf" ("shared" :: Text), help = "the shared leaf"}+        a = op "a" (deps [shared]) $ \x -> x{ref = mkRef "mid" ("a" :: Text)}+        b = op "b" (deps [shared]) $ \x -> x{ref = mkRef "mid" ("b" :: Text)}+        root = op "root" (deps [a, b]) $ \x -> x{ref = mkRef "root" ()}+        cograph = runIdentity (expand root)+        entries = Query.pathedNodes cograph+        sharedEntries = [(path, h) | (path, r, h) <- entries, r == mkRef "leaf" ("shared" :: Text)]+    assertEqual "the shared Ref still occurs at both its paths" 2 (length sharedEntries)+    assertBool "each occurrence carries the node's help text" (all ((== "the shared leaf") . snd) sharedEntries)+    let dedupedRefs = go Set.empty [r | (_, r, _) <- entries]+        go _ [] = []+        go seen (r : rest)+            | r `Set.member` seen = go seen rest+            | otherwise = r : go (Set.insert r seen) rest+    assertEqual "dedupe-by-Ref keeps one occurrence per distinct node" 4 (length dedupedRefs)++-- | Two siblings built with the same 'ShortHand' (e.g. two migration files+-- both going through a "pg-script" builder) render identical path text but+-- carry distinct 'Ref's — 'query show's disambiguation tags every occurrence+-- of a colliding path with a stable, content-derived 'Query.shortRef' of its+-- own node (not an arbitrary, traversal-order-dependent counter), so the+-- lines don't look like an accidental exact duplicate and the tag doesn't+-- shift around if the graph is walked in a different order.+renderAnnotatedDisambiguatesSameTextSiblings :: IO ()+renderAnnotatedDisambiguatesSameTextSiblings = do+    let refA = mkRef "migration" ("a" :: Text)+        refB = mkRef "migration" ("b" :: Text)+        a = op "pg-script" nodeps $ \x -> x{ref = refA, help = "runs a"}+        b = op "pg-script" nodeps $ \x -> x{ref = refB, help = "runs b"}+        root = op "root" (deps [a, b]) $ \x -> x{ref = mkRef "root" ()}+        cograph = runIdentity (expand root)+        rendered = Query.renderAnnotated cograph Set.empty Set.empty True True+        lineA = "/root/pg-script #" <> Query.shortRef refA+        lineB = "/root/pg-script #" <> Query.shortRef refB+    assertBool "shortRef tags are distinct for distinct refs" (lineA /= lineB)+    assertBool "the first sibling's path is tagged with its own shortRef" (lineA `elem` rendered)+    assertBool "the second sibling's path is tagged with its own shortRef" (lineB `elem` rendered)+    assertBool "each sibling's own description follows its own tagged line" ("  # runs a" `elem` rendered && "  # runs b" `elem` rendered)+    assertEqual "no plain, untagged occurrence of the colliding path remains" 0 (length (Prelude.filter (== "/root/pg-script") rendered))+    assertBool "the non-colliding root path itself is left untagged" ("/root" `elem` rendered)++-------------------------------------------------------------------------------+-- resolveRewrittenSelectors (R4)++pkg :: Text -> Op+pkg = Debian.deb . Debian.Package++pkgRef :: Text -> Ref+pkgRef name = mkRef "debian-deb" name++-- | The computed 'Rewritten' 'Salmon.Op.Rewrite.batchPackages' would produce+-- from this graph, everything desired, nothing ignored — the same 'Phase'+-- @run tree@\/@run dag@\/@query@ use for a whole-graph view.+computedFor :: [Rewrite.Rewrite Extension] -> Op -> Rewrite.Rewritten Extension+computedFor rewrites o =+    let dag = Dag.foldDag Dag.sameRepresentative (evalDeps o)+     in Rewrite.rewrite rewrites (Rewrite.wholeGraph dag) dag++onlyBatch :: Rewrite.Rewritten Extension -> IO Ref+onlyBatch c =+    case Map.keys (Rewrite.computedMembers c) of+        [r] -> pure r+        rs -> assertFailure ("expected exactly one batch, got " <> show (length rs))++-- | Two independent packages, no rewrite registered: a plain-path selector+-- must resolve exactly as 'Query.resolveSelectors' already does, since+-- 'resolveRewrittenSelectors' must not change existing behaviour when no+-- '#'-pattern is involved.+rewrittenPathSelectorUnchanged :: IO ()+rewrittenPathSelectorUnchanged = do+    let root = op "root" (deps [pkg "curl", pkg "git"]) $ \x -> x{ref = mkRef "root" ()}+        cograph = runIdentity (expand root)+        computed = computedFor [] root+        (plainSel, plainExc) = Query.resolveSelectors cograph ["/root/deb"] []+        (rwSel, rwExc) = Query.resolveRewrittenSelectors cograph computed ["/root/deb"] []+    assertEqual "same selection with no '#' patterns involved" plainSel rwSel+    assertEqual "same exclusion with no '#' patterns involved" plainExc rwExc++-- | A '#' pattern matches a plain (un-batched) declared node by its own+-- 'Query.shortRef', the same text a tree\/dag render would show it as.+rewrittenRefSelectorAddressesDeclaredNode :: IO ()+rewrittenRefSelectorAddressesDeclaredNode = do+    let root = op "root" (deps [pkg "curl", pkg "git"]) $ \x -> x{ref = mkRef "root" ()}+        cograph = runIdentity (expand root)+        computed = computedFor [] root+        frag = Query.shortRef (pkgRef "curl")+        (selected, _) = Query.resolveRewrittenSelectors cograph computed ["#" <> frag] []+    assertEqual "exactly the matching declared node" (Set.singleton (pkgRef "curl")) selected++-- | A '#' pattern matching a rewrite-introduced (batch) node's own ref+-- expands, through 'Salmon.Op.Rewrite.membersOf', to every declared node the+-- batch stands in for — this is the fallback lookup a path glob cannot give,+-- since the batch was never declared and so has no path of its own.+rewrittenRefSelectorExpandsABatch :: IO ()+rewrittenRefSelectorExpandsABatch = do+    let root = op "root" (deps [pkg "curl", pkg "git"]) $ \x -> x{ref = mkRef "root" ()}+        cograph = runIdentity (expand root)+        computed = computedFor [Debian.batchPackages silent] root+    batchRef <- onlyBatch computed+    let frag = Query.shortRef batchRef+        (selected, _) = Query.resolveRewrittenSelectors cograph computed ["#" <> frag] []+    assertEqual+        "both declared packages the batch was built from, not the batch's own ref"+        (Set.fromList [pkgRef "curl", pkgRef "git"])+        selected++-- | The two kinds of selector union rather than override each other.+rewrittenPathAndRefSelectorsCombine :: IO ()+rewrittenPathAndRefSelectorsCombine = do+    let root = op "root" (deps [pkg "curl", pkg "git", pkg "vim"]) $ \x -> x{ref = mkRef "root" ()}+        cograph = runIdentity (expand root)+        computed = computedFor [] root+        frag = Query.shortRef (pkgRef "vim")+        (selected, _) = Query.resolveRewrittenSelectors cograph computed ["/root/**"] ["#" <> frag]+    assertBool "the root itself, matched by path" (mkRef "root" () `Set.member` selected)+    assertBool "curl and git, matched by path under root" (pkgRef "curl" `Set.member` selected && pkgRef "git" `Set.member` selected)+    assertBool "vim is excluded by its '#' pattern" (pkgRef "vim" `Set.notMember` selected)++-- | The bug this function's first draft had: 'resolveSelectors' treats an+-- empty select list as "everything", and that must still hold when the+-- overall select list is empty even though the exclude list is '#'-only —+-- checked against the *combined* pattern list, not just its path half.+rewrittenEmptySelectStillMeansEverything :: IO ()+rewrittenEmptySelectStillMeansEverything = do+    let root = op "root" (deps [pkg "curl", pkg "git"]) $ \x -> x{ref = mkRef "root" ()}+        cograph = runIdentity (expand root)+        computed = computedFor [] root+        frag = Query.shortRef (pkgRef "git")+        (selected, excluded) = Query.resolveRewrittenSelectors cograph computed [] ["#" <> frag]+        allRefs = Set.fromList (map snd (Query.pathedRefs cograph))+    assertEqual "everything but the excluded ref" (allRefs `Set.difference` Set.singleton (pkgRef "git")) selected+    assertEqual "exactly the excluded ref" (Set.singleton (pkgRef "git")) excluded
+ test/Test/ReportJsonSpec.hs view
@@ -0,0 +1,554 @@+{- | Layer 0 coverage for "Salmon.Reporter.Tagged" (milestone 1 of+@specs\/generic-server.md@): the JSON encoding of the four report streams,+and the composition of the text reporters beside a JSON one.++Every constructor of 'UpDown.Report', 'Upkeep.Report', 'Serve.Report' and+'Follow.Report' has a golden object here, written out as JSON text and compared structurally+(key order is not part of the contract; the set of keys and their values+are). The one thing a golden cannot spell out literally is a 'Ref' — one is+only ever made by hashing — so each golden carries @<REF>@\/@<SHORT>@+placeholders spliced from the one fixture ref before parsing. A constructor+added to any of the three streams is an incomplete-pattern warning in the+sentinels at the bottom of this module, which is the cue to add its golden.+The status sink's document ("Salmon.Actions.Serve.StatusSink") has its+golden here too, since it is built from these same objects.+-}+module Test.ReportJsonSpec (tests, goldens, sinkDocumentText) where++import Control.Exception (ErrorCall (..), toException)+import Data.Aeson (Value (..), eitherDecode, encode, toJSON)+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Lazy as LByteString+import qualified Data.ByteString.Lazy.Char8 as LChar8+import Data.IORef (modifyIORef', newIORef, readIORef)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.Encoding as LText+import System.IO (hClose)+import System.IO.Temp (withSystemTempFile)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase)++import qualified Salmon.Actions.Follow as Follow+import qualified Salmon.Actions.Follow.Scheduler as Scheduler+import qualified Salmon.Actions.Serve as Serve+import qualified Salmon.Actions.Serve.StatusSink as StatusSink+import qualified Salmon.Actions.UpDown as UpDown+import qualified Salmon.Actions.Upkeep as Upkeep+import Salmon.Builtin.Extension (Extension (..), Op, nodeps, op)+import Salmon.Op.Actions (Act (..), Actions (..))+import Salmon.Op.OpGraph (OpGraph (..))+import qualified Salmon.Op.Mailbox as Mailbox+import Salmon.Op.Ref (Ref, mkRef, shortRef, unRef)+import qualified Salmon.Op.Status as Status+import Salmon.Op.Supervision (Micros (..), Restart (..), Strategy (..), Supervision (..), defaultSupervision)+import Salmon.Reporter (ReporterM (..), reportBoth, runReporter, silent)+import qualified Salmon.Reporter.Tagged as Tagged++tests :: TestTree+tests =+    testGroup+        "Salmon.Reporter.Tagged"+        [ testGroup "golden JSON, one per constructor" [testCase name (golden rep expected) | (name, rep, expected) <- goldens]+        , testCase "Tagged adds a stream to the inner object and nothing else" taggedOrigin+        , testCase "a Ref encodes as its short tag and its full text" refShape+        , testCase "a Mode encodes as the word status prints" modeShape+        , testCase "the text reporters print the same lines beside a JSON one as they do alone" textUnchangedBesideJson+        , testCase "reportJSONLines writes one object per line" oneObjectPerLine+        , testCase "the status sink document" sinkDocumentGolden+        ]++-------------------------------------------------------------------------------++-- | The one node every golden is about.+fixtureRef :: Ref+fixtureRef = mkRef "report-json-spec" ("fixture" :: Text)++-- | A second ref, for the reports that mention two.+otherRef :: Ref+otherRef = mkRef "report-json-spec" ("other" :: Text)++fixtureAct :: Act Extension+fixtureAct = actOf fixtureOp+  where+    fixtureOp :: Op+    fixtureOp = op "fixture-node" nodeps $ \ext ->+        ext+            { help = "a node for the goldens"+            , notes = ["first note", "second note"]+            , ref = fixtureRef+            }++otherAct :: Act Extension+otherAct = actOf otherOp+  where+    otherOp :: Op+    otherOp = op "other-node" nodeps $ \ext ->+        ext{help = "the other declaration", notes = [], ref = fixtureRef}++actOf :: Op -> Act Extension+actOf o = case o.node of+    Actions act -> act+    Actionless -> error "fixture op is Actionless"++boom :: ErrorCall+boom = ErrorCall "boom"++-- | The JSON text of the fixture node, as every per-node report carries it.+nodeJson :: Text+nodeJson = "{\"shorthand\":\"fixture-node\",\"help\":\"a node for the goldens\",\"notes\":[\"first note\",\"second note\"]}"++otherNodeJson :: Text+otherNodeJson = "{\"shorthand\":\"other-node\",\"help\":\"the other declaration\",\"notes\":[]}"++refJson :: Text+refJson = "{\"short\":\"<SHORT>\",\"full\":\"<REF>\"}"++otherRefJson :: Text+otherRefJson = "{\"short\":\"<OSHORT>\",\"full\":\"<OREF>\"}"++-- | @ref@ and @node@, the pair every report about one node opens with.+about :: Text+about = "\"ref\":" <> refJson <> ",\"node\":" <> nodeJson++splice :: Text -> Text+splice =+    Text.replace "<SHORT>" (shortRef fixtureRef)+        . Text.replace "<REF>" (unRef fixtureRef)+        . Text.replace "<OSHORT>" (shortRef otherRef)+        . Text.replace "<OREF>" (unRef otherRef)++golden :: Tagged.Tagged -> Text -> Assertion+golden tagged expectedText = do+    expected <- case eitherDecode (LText.encodeUtf8 (LText.fromStrict (splice expectedText))) of+        Left err -> assertFailure ("golden is not valid JSON: " <> err <> "\n" <> Text.unpack expectedText)+        Right v -> pure (v :: Value)+    let actual = stripOrigin (toJSON tagged)+    assertEqual ("encoding of " <> show tagged <> "\n  as " <> LChar8.unpack (encode actual)) expected actual+  where+    -- the goldens are about each stream's own object; 'taggedOrigin' covers+    -- what 'Tagged' adds on top.+    stripOrigin (Object o) = Object (KeyMap.delete "stream" o)+    stripOrigin v = v++-------------------------------------------------------------------------------++goldens :: [(String, Tagged.Tagged, Text)]+goldens = updownGoldens ++ upkeepGoldens ++ serveGoldens ++ followGoldens++updownGoldens :: [(String, Tagged.Tagged, Text)]+updownGoldens =+    [ ("UpDown.Skip", Tagged.FromUpDown (UpDown.Skip fixtureAct), "{\"kind\":\"skip\"," <> about <> "}")+    , ("UpDown.Eval", Tagged.FromUpDown (UpDown.Eval fixtureAct), "{\"kind\":\"eval\"," <> about <> "}")+    , ("UpDown.Done", Tagged.FromUpDown (UpDown.Done fixtureAct), "{\"kind\":\"done\"," <> about <> "}")+    , ("UpDown.Failed", Tagged.FromUpDown (UpDown.Failed fixtureAct (toException boom)), "{\"kind\":\"failed\"," <> about <> ",\"error\":\"boom\"}")+    , ("UpDown.Blocked", Tagged.FromUpDown (UpDown.Blocked fixtureAct), "{\"kind\":\"blocked\"," <> about <> "}")+    ,+        ( "UpDown.Conflicting"+        , Tagged.FromUpDown (UpDown.Conflicting fixtureRef fixtureAct otherAct)+        , "{\"kind\":\"conflicting\",\"ref\":" <> refJson <> ",\"kept\":" <> nodeJson <> ",\"replaced\":" <> otherNodeJson <> "}"+        )+    , ("UpDown.Instructed", Tagged.FromUpDown (UpDown.Instructed fixtureAct Mailbox.Force), "{\"kind\":\"instructed\"," <> about <> ",\"instruction\":\"force\"}")+    , ("UpDown.DroppedInstructions", Tagged.FromUpDown (UpDown.DroppedInstructions fixtureAct 3), "{\"kind\":\"dropped-instructions\"," <> about <> ",\"dropped\":3}")+    ]++upkeepGoldens :: [(String, Tagged.Tagged, Text)]+upkeepGoldens =+    [ ("Upkeep.Acted", Tagged.FromUpkeep (Upkeep.Acted (UpDown.Done fixtureAct)), "{\"kind\":\"acted\",\"report\":{\"kind\":\"done\"," <> about <> "}}")+    , ("Upkeep.Upkeep", Tagged.FromUpkeep (Upkeep.Upkeep fixtureAct Upkeep.WaitUp), "{\"kind\":\"upkeep\"," <> about <> ",\"state\":\"wait-up\"}")+    , ("Upkeep.Downkeep", Tagged.FromUpkeep (Upkeep.Downkeep fixtureAct Upkeep.Downing), "{\"kind\":\"downkeep\"," <> about <> ",\"state\":\"downing\"}")+    ,+        ( "Upkeep.NextLook"+        , Tagged.FromUpkeep (Upkeep.NextLook fixtureAct (UpDown.Failure "gone") (Micros 500000))+        , "{\"kind\":\"next-look\"," <> about <> ",\"check\":{\"verdict\":\"failure\",\"reason\":\"gone\"},\"delay_us\":500000}"+        )+    , ("Upkeep.Wedged", Tagged.FromUpkeep (Upkeep.Wedged fixtureAct (Micros 30000000)), "{\"kind\":\"wedged\"," <> about <> ",\"silent_us\":30000000}")+    , ("Upkeep.Unwedged", Tagged.FromUpkeep (Upkeep.Unwedged fixtureAct), "{\"kind\":\"unwedged\"," <> about <> "}")+    , ("Upkeep.Output", Tagged.FromUpkeep (Upkeep.Output fixtureAct "hello"), "{\"kind\":\"output\"," <> about <> ",\"line\":\"hello\"}")+    , ("Upkeep.Demoted", Tagged.FromUpkeep (Upkeep.Demoted fixtureAct otherRef), "{\"kind\":\"demoted\"," <> about <> ",\"dependency\":" <> otherRefJson <> "}")+    , ("Upkeep.Parked", Tagged.FromUpkeep (Upkeep.Parked fixtureAct), "{\"kind\":\"parked\"," <> about <> "}")+    , ("Upkeep.Reapplying", Tagged.FromUpkeep (Upkeep.Reapplying fixtureAct (Micros 1000)), "{\"kind\":\"reapplying\"," <> about <> ",\"delay_us\":1000}")+    , ("Upkeep.Paused", Tagged.FromUpkeep (Upkeep.Paused fixtureAct), "{\"kind\":\"paused\"," <> about <> "}")+    , ("Upkeep.Resumed", Tagged.FromUpkeep (Upkeep.Resumed fixtureAct), "{\"kind\":\"resumed\"," <> about <> "}")+    , ("Upkeep.GaveUp", Tagged.FromUpkeep (Upkeep.GaveUp fixtureAct 5), "{\"kind\":\"gave-up\"," <> about <> ",\"failures\":5}")+    , ("Upkeep.Adopted", Tagged.FromUpkeep (Upkeep.Adopted fixtureAct), "{\"kind\":\"adopted\"," <> about <> "}")+    , ("Upkeep.Released", Tagged.FromUpkeep (Upkeep.Released fixtureAct), "{\"kind\":\"released\"," <> about <> "}")+    ,+        ( "Upkeep.Policy"+        , Tagged.FromUpkeep (Upkeep.Policy fixtureAct defaultSupervision [restForOne])+        , "{\"kind\":\"policy\","+            <> about+            <> ",\"supervision\":{\"restart\":\"on-failure\",\"strategy\":\"one-for-one\",\"reapply\":false,\"watchdog_us\":null,\"stable_after_us\":10000000,\"demote_every_us\":10000000,\"give_up_after\":null}"+            <> ",\"ignored\":[{\"restart\":\"always\",\"strategy\":\"rest-for-one\",\"reapply\":true,\"watchdog_us\":2000000,\"stable_after_us\":10000000,\"demote_every_us\":10000000,\"give_up_after\":4}]}"+        )+    , ("Upkeep.Untended", Tagged.FromUpkeep (Upkeep.Untended fixtureAct), "{\"kind\":\"untended\"," <> about <> "}")+    , ("Upkeep.Escaped", Tagged.FromUpkeep (Upkeep.Escaped fixtureAct (toException boom)), "{\"kind\":\"escaped\"," <> about <> ",\"error\":\"boom\"}")+    , ("Upkeep.Supervising", Tagged.FromUpkeep (Upkeep.Supervising 7 2), "{\"kind\":\"supervising\",\"up\":7,\"down\":2}")+    , ("Upkeep.Retired", Tagged.FromUpkeep (Upkeep.Retired 9), "{\"kind\":\"retired\",\"machines\":9}")+    , ("Upkeep.Holding", Tagged.FromUpkeep (Upkeep.Holding 1), "{\"kind\":\"holding\",\"machines\":1}")+    ]+  where+    restForOne =+        defaultSupervision+            { supRestart = Always+            , supStrategy = RestForOne+            , supReapply = True+            , supWatchdog = Just (Micros 2000000)+            , supGiveUpAfter = Just 4+            }++serveGoldens :: [(String, Tagged.Tagged, Text)]+serveGoldens =+    [ ("Serve.Started", Tagged.FromServe Serve.Started, "{\"kind\":\"started\"}")+    , ("Serve.Stopped", Tagged.FromServe Serve.Stopped, "{\"kind\":\"stopped\"}")+    , ("Serve.HungUp", Tagged.FromServe (Serve.HungUp (Serve.Origin "/tmp/x.sock#0")), "{\"kind\":\"hung-up\",\"from\":\"/tmp/x.sock#0\"}")+    , ("Serve.BadCommand", Tagged.FromServe (Serve.BadCommand "unknown command"), "{\"kind\":\"bad-command\",\"error\":\"unknown command\"}")+    , ("Serve.BadSeed", Tagged.FromServe (Serve.BadSeed "missing --dir"), "{\"kind\":\"bad-seed\",\"error\":\"missing --dir\"}")+    , ("Serve.BadDirective", Tagged.FromServe (Serve.BadDirective "not json"), "{\"kind\":\"bad-directive\",\"error\":\"not json\"}")+    , ("Serve.BadLoad", Tagged.FromServe (Serve.BadLoad "nesting too deep"), "{\"kind\":\"bad-load\",\"error\":\"nesting too deep\"}")+    , ("Serve.Loading", Tagged.FromServe (Serve.Loading "/tmp/script"), "{\"kind\":\"loading\",\"path\":\"/tmp/script\"}")+    , ("Serve.LoadDone", Tagged.FromServe (Serve.LoadDone "/tmp/script" 4), "{\"kind\":\"load-done\",\"path\":\"/tmp/script\",\"lines\":4}")+    ,+        ( "Serve.Declared"+        , Tagged.FromServe (Serve.Declared (Serve.EpochId 3) Status.TurnUp 12 2)+        , "{\"kind\":\"declared\",\"epoch\":3,\"direction\":\"up\",\"nodes\":12,\"active_seeds\":2}"+        )+    , ("Serve.Cleared", Tagged.FromServe (Serve.Cleared 2), "{\"kind\":\"cleared\",\"retired\":2}")+    , ("Serve.Supervised", Tagged.FromServe (Serve.Supervised False), "{\"kind\":\"supervised\",\"on\":false}")+    , ("Serve.AutoConverged", Tagged.FromServe (Serve.AutoConverged True), "{\"kind\":\"auto-converged\",\"on\":true}")+    , ("Serve.Instructed", Tagged.FromServe (Serve.Instructed Mailbox.Recheck 3), "{\"kind\":\"instructed\",\"instruction\":\"recheck\",\"nodes\":3}")+    , ("Serve.FetchRequested", Tagged.FromServe (Serve.FetchRequested False), "{\"kind\":\"fetch-requested\",\"following\":false}")+    ,+        ( "Serve.Tended"+        , Tagged.FromServe (Serve.Tended (Upkeep.Acted (UpDown.Eval fixtureAct)))+        , "{\"kind\":\"tended\",\"report\":{\"kind\":\"acted\",\"report\":{\"kind\":\"eval\"," <> about <> "}}}"+        )+    , ("Serve.ConvergeStart", Tagged.FromServe (Serve.ConvergeStart 1 4), "{\"kind\":\"converge-start\",\"down\":1,\"up\":4}")+    , ("Serve.ConvergeStop", Tagged.FromServe (Serve.ConvergeStop False 2), "{\"kind\":\"converge-stop\",\"ok\":false,\"remaining\":2}")+    ,+        ( "Serve.StatusReport"+        , Tagged.FromServe (Serve.StatusReport Serve.Interactive [(fixtureRef, tendedState), (otherRef, untendedState)] paths)+        , "{\"kind\":\"status\",\"mode\":\"interactive\",\"nodes\":[" <> tendedJson <> "," <> untendedJson <> "]}"+        )+    , ("Serve.StatusReport (following)", Tagged.FromServe (Serve.StatusReport Serve.Following [] Map.empty), "{\"kind\":\"status\",\"mode\":\"following\",\"nodes\":[]}")+    , ("Serve.StatusReport (replay)", Tagged.FromServe (Serve.StatusReport Serve.Replay [] Map.empty), "{\"kind\":\"status\",\"mode\":\"replay\",\"nodes\":[]}")+    ,+        ( "Serve.HistoryReport"+        , Tagged.FromServe+            ( Serve.HistoryReport+                [ (Serve.EpochId 1, Serve.Add, True, Serve.Stdin, ["--dir", "/tmp/play"])+                , (Serve.EpochId 2, Serve.Remove, False, Serve.Loaded "/tmp/script", [])+                , (Serve.EpochId 3, Serve.Add, True, Serve.Fetched (Serve.Provenance "/srv/reg" "web-api" "web-api@2026-09-23T10:41:07Z" "32ea59311d97"), ["--name", "web"])+                ]+            )+        , "{\"kind\":\"history\",\"seeds\":["+            <> "{\"epoch\":1,\"declaration\":\"up\",\"active\":true,\"origin\":{\"kind\":\"stdin\"},\"args\":[\"--dir\",\"/tmp/play\"]},"+            <> "{\"epoch\":2,\"declaration\":\"down\",\"active\":false,\"origin\":{\"kind\":\"loaded\",\"path\":\"/tmp/script\"},\"args\":[]},"+            <> "{\"epoch\":3,\"declaration\":\"up\",\"active\":true,\"origin\":{\"kind\":\"fetched\",\"registry\":\"/srv/reg\",\"label\":\"web-api\",\"document\":\"web-api@2026-09-23T10:41:07Z\",\"sha256\":\"32ea59311d97\"},\"args\":[\"--name\",\"web\"]}]}"+        )+    , ("Serve.HistoryElided", Tagged.FromServe (Serve.HistoryElided 40), "{\"kind\":\"history-elided\",\"elided\":40}")+    , ("Serve.SinkFailed", Tagged.FromServe (Serve.SinkFailed "/var/lib/salmon/status.json" "permission denied"), "{\"kind\":\"sink-failed\",\"path\":\"/var/lib/salmon/status.json\",\"error\":\"permission denied\"}")+    ,+        ( "Serve.QueryReport"+        , Tagged.FromServe (Serve.QueryReport [(fixtureRef, tendedState), (otherRef, untendedState)] (Set.singleton fixtureRef) (Set.singleton otherRef) paths)+        , "{\"kind\":\"query\",\"nodes\":["+            <> Text.init tendedJson+            <> ",\"selected\":true,\"excluded\":false},"+            <> Text.init untendedJson+            <> ",\"selected\":false,\"excluded\":true}]}"+        )+    ,+        ( "Serve.HelpText"+        , Tagged.FromServe (Serve.HelpText (Just "no-such-topic"))+        , "{\"kind\":\"help\",\"topic\":\"no-such-topic\",\"lines\":" <> jsonStrings (Serve.renderReport (Serve.HelpText (Just "no-such-topic"))) <> "}"+        )+    ]+  where+    paths = Map.fromList [(fixtureRef, ["/program/fixture-node", "/other/fixture-node"])]+    tendedState =+        Serve.NodeState+            { Serve.nodeShorthand = "fixture-node"+            , Serve.nodeHelp = "a node for the goldens"+            , Serve.nodeDirection = Status.TurnUp+            , Serve.nodeConvergence = Serve.Converged+            , Serve.nodeStatus =+                Just+                    Status.Status+                        { Status.statusCheck = UpDown.Success+                        , Status.statusDirection = Status.TurnUp+                        , Status.statusStability = Status.Stable+                        , Status.statusLastActive = 123456789+                        , Status.statusEpoch = 2+                        , Status.statusOutput = Status.pushRing "second line" (Status.pushRing "first line" Status.emptyRing)+                        }+            }+    untendedState =+        Serve.NodeState+            { Serve.nodeShorthand = "other-node"+            , Serve.nodeHelp = "the other declaration"+            , Serve.nodeDirection = Status.TurnDown+            , Serve.nodeConvergence = Serve.Stale+            , Serve.nodeStatus = Nothing+            }+    tendedJson =+        "{\"ref\":"+            <> refJson+            <> ",\"shorthand\":\"fixture-node\",\"help\":\"a node for the goldens\",\"direction\":\"up\",\"convergence\":\"converged\""+            <> ",\"status\":{\"check\":{\"verdict\":\"success\"},\"direction\":\"up\",\"stability\":\"stable\",\"epoch\":2,\"output\":[\"first line\",\"second line\"]}"+            <> ",\"paths\":[\"/program/fixture-node\",\"/other/fixture-node\"]}"+    untendedJson =+        "{\"ref\":"+            <> otherRefJson+            <> ",\"shorthand\":\"other-node\",\"help\":\"the other declaration\",\"direction\":\"down\",\"convergence\":\"stale\",\"status\":null,\"paths\":[]}"+    jsonStrings :: [Text] -> Text+    jsonStrings = LText.toStrict . LText.decodeUtf8 . encode++followGoldens :: [(String, Tagged.Tagged, Text)]+followGoldens =+    [+        ( "Follow.Following"+        , Tagged.FromFollow (Follow.Following "/srv/reg" [web, canary] schedule)+        , "{\"kind\":\"following\",\"registry\":\"/srv/reg\",\"labels\":[\"web\",\"canary\"]"+            <> ",\"schedule\":{\"base_us\":30000000,\"factor\":2,\"cap_us\":600000000,\"jitter\":0.2,\"debounce_us\":5000000,\"max_wait_us\":60000000}}"+        )+    , ("Follow.Injected", Tagged.FromFollow (Follow.Injected web "web@2" digest 2 1), "{\"kind\":\"injected\",\"label\":\"web\",\"document\":\"web@2\",\"sha256\":\"" <> hex <> "\",\"up\":2,\"down\":1}")+    , ("Follow.NoDiff", Tagged.FromFollow (Follow.NoDiff web "web@2" digest), "{\"kind\":\"no-diff\",\"label\":\"web\",\"document\":\"web@2\",\"sha256\":\"" <> hex <> "\"}")+    , ("Follow.Deferred", Tagged.FromFollow (Follow.Deferred web "web@2" digest), "{\"kind\":\"deferred\",\"label\":\"web\",\"document\":\"web@2\",\"sha256\":\"" <> hex <> "\"}")+    , ("Follow.Backoff", Tagged.FromFollow (Follow.Backoff 3 120000000), "{\"kind\":\"backoff\",\"failures\":3,\"next_us\":120000000}")+    , ("Follow.Missing", Tagged.FromFollow (Follow.Missing web), "{\"kind\":\"missing\",\"label\":\"web\"}")+    , ("Follow.Vanished", Tagged.FromFollow (Follow.Vanished web), "{\"kind\":\"vanished\",\"label\":\"web\"}")+    , ("Follow.Malformed", Tagged.FromFollow (Follow.Malformed web digest "not json"), "{\"kind\":\"malformed\",\"label\":\"web\",\"sha256\":\"" <> hex <> "\",\"error\":\"not json\"}")+    , ("Follow.FetchFailed", Tagged.FromFollow (Follow.FetchFailed web "no such directory"), "{\"kind\":\"fetch-failed\",\"label\":\"web\",\"error\":\"no such directory\"}")+    , ("Follow.Replayed", Tagged.FromFollow (Follow.Replayed web "web@1" digest), "{\"kind\":\"replayed\",\"label\":\"web\",\"document\":\"web@1\",\"sha256\":\"" <> hex <> "\"}")+    , ("Follow.Stale", Tagged.FromFollow (Follow.Stale web "web@0"), "{\"kind\":\"stale\",\"label\":\"web\",\"document\":\"web@0\"}")+    , ("Follow.BadCache", Tagged.FromFollow (Follow.BadCache web "digest mismatch"), "{\"kind\":\"bad-cache\",\"label\":\"web\",\"error\":\"digest mismatch\"}")+    , ("Follow.CacheFailed", Tagged.FromFollow (Follow.CacheFailed web "read-only file system"), "{\"kind\":\"cache-failed\",\"label\":\"web\",\"error\":\"read-only file system\"}")+    , ("Follow.Rejected", Tagged.FromFollow (Follow.Rejected web digest "signature does not verify"), "{\"kind\":\"rejected\",\"label\":\"web\",\"sha256\":\"" <> hex <> "\",\"reason\":\"signature does not verify\"}")+    ]+  where+    web = labelOf "web"+    canary = labelOf "canary"+    labelOf t = either (error . Text.unpack) id (Follow.mkLabel t)+    hex = "32ea59311d97a7c0"+    digest = Follow.Digest hex+    schedule = Scheduler.defaultConfig++-------------------------------------------------------------------------------++taggedOrigin :: Assertion+taggedOrigin = do+    assertEqual "serve" (Just (String "serve")) (originOf (Tagged.FromServe Serve.Started))+    assertEqual "updown" (Just (String "updown")) (originOf (Tagged.FromUpDown (UpDown.Done fixtureAct)))+    assertEqual "upkeep" (Just (String "upkeep")) (originOf (Tagged.FromUpkeep (Upkeep.Holding 1)))+    assertEqual "follow" (Just (String "follow")) (originOf (Tagged.FromFollow (Follow.Backoff 1 1)))+    -- the inner object is carried whole: removing the stream gives it back+    let inner = toJSON (UpDown.Done fixtureAct)+    case toJSON (Tagged.FromUpDown (UpDown.Done fixtureAct)) of+        Object o -> assertEqual "inner object, untouched" inner (Object (KeyMap.delete "stream" o))+        v -> assertFailure ("not an object: " <> show v)+  where+    originOf tagged = case toJSON tagged of+        Object o -> KeyMap.lookup "stream" o+        _ -> Nothing++refShape :: Assertion+refShape = do+    case Tagged.refValue fixtureRef of+        Object o -> do+            assertEqual "short" (Just (String (shortRef fixtureRef))) (KeyMap.lookup "short" o)+            assertEqual "full" (Just (String (unRef fixtureRef))) (KeyMap.lookup "full" o)+            assertEqual "two keys and no more" 2 (KeyMap.size o)+        v -> assertFailure ("not an object: " <> show v)+    assertBool "the short tag is a prefix-searchable 8 characters" (Text.length (shortRef fixtureRef) == 8)++{- | 'Serve.Mode' is on the wire twice (@status@'s object, @\/dag@'s+envelope) through one instance; this is its golden, and what it must keep+saying for either.+-}+modeShape :: Assertion+modeShape = do+    assertEqual "interactive" (String "interactive") (toJSON Serve.Interactive)+    assertEqual "following" (String "following") (toJSON Serve.Following)+    assertEqual "replay" (String "replay") (toJSON Serve.Replay)+    assertEqual "encoded as its rendering" (LText.encodeUtf8 (LText.fromStrict ("\"" <> Serve.renderMode Serve.Replay <> "\""))) (encode Serve.Replay)++{- | The composition "Salmon.Builtin.CommandLine" would make if it ever ran+both: the three text reporters behind one 'Tagged' reporter, 'reportBoth'+a JSON one. The text side must print exactly what the three print on their+own — a report is dispatched, never reshaped — and the JSON side must see+every report the text side did.+-}+textUnchangedBesideJson :: Assertion+textUnchangedBesideJson = do+    aloneServe <- newIORef []+    aloneUpdown <- newIORef []+    besideServe <- newIORef []+    besideUpdown <- newIORef []+    jsonSeen <- newIORef []+    let serveText ref = ReporterM $ \rep -> modifyIORef' ref (++ Serve.renderReport rep)+        updownText ref = ReporterM $ \rep -> modifyIORef' ref (++ [Text.pack (show rep)])+        jsonR = ReporterM $ \tagged -> modifyIORef' jsonSeen (++ [encode tagged])+        composed = reportBoth (Tagged.reportTexts (serveText besideServe) (updownText besideUpdown) silent silent) jsonR+        serveReports = [Serve.Started, Serve.ConvergeStart 0 2, Serve.Tended (Upkeep.Wedged fixtureAct (Micros 5)), Serve.ConvergeStop True 0]+        updownReports = [UpDown.Eval fixtureAct, UpDown.Done fixtureAct, UpDown.Failed otherAct (toException boom)]+    mapM_ (runReporter (serveText aloneServe)) serveReports+    mapM_ (runReporter (updownText aloneUpdown)) updownReports+    mapM_ (runReporter (Tagged.serveStream composed)) serveReports+    mapM_ (runReporter (Tagged.updownStream composed)) updownReports+    expectedServe <- readIORef aloneServe+    expectedUpdown <- readIORef aloneUpdown+    actualServe <- readIORef besideServe+    actualUpdown <- readIORef besideUpdown+    assertEqual "serve text, beside JSON" expectedServe actualServe+    assertEqual "updown text, beside JSON" expectedUpdown actualUpdown+    assertBool "the text reporters actually printed something" (not (null expectedServe) && not (null expectedUpdown))+    seen <- readIORef jsonSeen+    assertEqual "every report reached the JSON side" (length serveReports + length updownReports) (length seen)++oneObjectPerLine :: Assertion+oneObjectPerLine =+    withSystemTempFile "reports.jsonl" $ \path h -> do+        let r = Tagged.reportJSONLines h+        runReporter r (Tagged.FromUpDown (UpDown.Eval fixtureAct))+        runReporter r (Tagged.FromUpDown (UpDown.Failed fixtureAct (toException (ErrorCall "multi\nline\nerror"))))+        runReporter r (Tagged.FromServe (Serve.HelpText Nothing))+        hClose h+        contents <- LByteString.readFile path+        let ls = LChar8.lines contents+        assertEqual "three reports, three lines" 3 (length ls)+        assertBool "the file ends with a newline" (LChar8.isSuffixOf "\n" contents)+        mapM_ decodesToTaggedObject ls+  where+    decodesToTaggedObject line =+        case eitherDecode line of+            Right (Object o) -> assertBool "has a stream" (KeyMap.member "stream" o)+            Right v -> assertFailure ("not an object: " <> show v)+            Left err -> assertFailure ("not a JSON line: " <> err <> ": " <> LChar8.unpack line)++{- | The status sink's document: the @status@ object is the one+'Serve.StatusReport' encodes to, the two @last@ objects are tagged reports+as @--json@ prints them (@stream@ included), the labels are what the+fetcher applied. Round-trips through its own 'FromJSON', which is what the+fleet fold reads it with. -}+sinkDocumentGolden :: Assertion+sinkDocumentGolden = do+    let written = read "2026-09-24 10:41:07 UTC"+        applied = read "2026-09-24 10:40:00 UTC"+        doc =+            StatusSink.Document+                { StatusSink.docHost = "web-3"+                , StatusSink.docWritten = written+                , StatusSink.docMode = "following"+                , StatusSink.docLabels = [Serve.AppliedDocument "web" "web@42" "32ea59311d97a7c0" applied]+                , StatusSink.docStatus = toJSON (Serve.StatusReport Serve.Following [] Map.empty)+                , StatusSink.docLastConverge = Just (toJSON (Tagged.FromServe (Serve.ConvergeStop True 0)))+                , StatusSink.docLastFollow = Just (toJSON (Tagged.FromFollow (Follow.Backoff 2 60000000)))+                }+        expectedText = sinkDocumentText+    expected <- case eitherDecode (LText.encodeUtf8 (LText.fromStrict expectedText)) of+        Left err -> assertFailure ("golden is not valid JSON: " <> err)+        Right v -> pure (v :: Value)+    assertEqual "the document" expected (toJSON doc)+    assertEqual "round-trips" (Right doc) (eitherDecode (encode doc))+    -- the two `last` objects are optional on the way in: an older writer's+    -- document without them still folds+    assertEqual+        "without `last`"+        (Right doc{StatusSink.docLastConverge = Nothing, StatusSink.docLastFollow = Nothing})+        (eitherDecode "{\"salmon-status\":1,\"host\":\"web-3\",\"written\":\"2026-09-24T10:41:07Z\",\"mode\":\"following\",\"labels\":[{\"label\":\"web\",\"id\":\"web@42\",\"sha256\":\"32ea59311d97a7c0\",\"applied\":\"2026-09-24T10:40:00Z\"}],\"status\":{\"kind\":\"status\",\"mode\":\"following\",\"nodes\":[]}}")++-- | The status sink's document as the golden above spells it.+sinkDocumentText :: Text+sinkDocumentText =+    "{\"salmon-status\":1,\"host\":\"web-3\",\"written\":\"2026-09-24T10:41:07Z\",\"mode\":\"following\""+        <> ",\"labels\":[{\"label\":\"web\",\"id\":\"web@42\",\"sha256\":\"32ea59311d97a7c0\",\"applied\":\"2026-09-24T10:40:00Z\"}]"+        <> ",\"status\":{\"kind\":\"status\",\"mode\":\"following\",\"nodes\":[]}"+        <> ",\"last\":{\"converge\":{\"stream\":\"serve\",\"kind\":\"converge-stop\",\"ok\":true,\"remaining\":0}"+        <> ",\"follow\":{\"stream\":\"follow\",\"kind\":\"backoff\",\"failures\":2,\"next_us\":60000000}}}"++-------------------------------------------------------------------------------++{- | Exhaustiveness sentinels: a constructor added to a stream shows up here+as an incomplete-pattern warning, which is the cue to add its golden above.+Never called.+-}+_updownCovered :: UpDown.Report Extension -> ()+_updownCovered rep = case rep of+    UpDown.Skip{} -> ()+    UpDown.Eval{} -> ()+    UpDown.Done{} -> ()+    UpDown.Failed{} -> ()+    UpDown.Blocked{} -> ()+    UpDown.Conflicting{} -> ()+    UpDown.Instructed{} -> ()+    UpDown.DroppedInstructions{} -> ()++_upkeepCovered :: Upkeep.Report Extension -> ()+_upkeepCovered rep = case rep of+    Upkeep.Acted{} -> ()+    Upkeep.Upkeep{} -> ()+    Upkeep.Downkeep{} -> ()+    Upkeep.NextLook{} -> ()+    Upkeep.Wedged{} -> ()+    Upkeep.Unwedged{} -> ()+    Upkeep.Output{} -> ()+    Upkeep.Demoted{} -> ()+    Upkeep.Parked{} -> ()+    Upkeep.Reapplying{} -> ()+    Upkeep.Paused{} -> ()+    Upkeep.Resumed{} -> ()+    Upkeep.GaveUp{} -> ()+    Upkeep.Adopted{} -> ()+    Upkeep.Released{} -> ()+    Upkeep.Policy{} -> ()+    Upkeep.Untended{} -> ()+    Upkeep.Escaped{} -> ()+    Upkeep.Supervising{} -> ()+    Upkeep.Retired{} -> ()+    Upkeep.Holding{} -> ()++_serveCovered :: Serve.Report -> ()+_serveCovered rep = case rep of+    Serve.Started -> ()+    Serve.Stopped -> ()+    Serve.HungUp{} -> ()+    Serve.BadCommand{} -> ()+    Serve.BadSeed{} -> ()+    Serve.BadDirective{} -> ()+    Serve.BadLoad{} -> ()+    Serve.Loading{} -> ()+    Serve.LoadDone{} -> ()+    Serve.Declared{} -> ()+    Serve.Cleared{} -> ()+    Serve.Supervised{} -> ()+    Serve.AutoConverged{} -> ()+    Serve.Instructed{} -> ()+    Serve.Tended{} -> ()+    Serve.ConvergeStart{} -> ()+    Serve.ConvergeStop{} -> ()+    Serve.StatusReport{} -> ()+    Serve.HistoryReport{} -> ()+    Serve.HistoryElided{} -> ()+    Serve.QueryReport{} -> ()+    Serve.HelpText{} -> ()+    Serve.SinkFailed{} -> ()++_followCovered :: Follow.Report -> ()+_followCovered rep = case rep of+    Follow.Following{} -> ()+    Follow.Injected{} -> ()+    Follow.NoDiff{} -> ()+    Follow.Deferred{} -> ()+    Follow.Backoff{} -> ()+    Follow.Missing{} -> ()+    Follow.Vanished{} -> ()+    Follow.Malformed{} -> ()+    Follow.FetchFailed{} -> ()+    Follow.Replayed{} -> ()+    Follow.Stale{} -> ()+    Follow.BadCache{} -> ()+    Follow.CacheFailed{} -> ()+    Follow.Rejected{} -> ()
+ test/Test/RewriteSpec.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 0 coverage for "Salmon.Op.Rewrite" and the one rewrite that ships+with it, 'Salmon.Builtin.Nodes.Debian.Package.batchPackages'.++Nothing here runs @apt-get@: what is under test is the /shape/ of the+computed graph — which nodes a batch swallowed, which way round the batches+are ordered, what the edges into a swallowed node were redirected onto, and+that the membership bookkeeping keeps a batch legible in terms of the nodes+an operator actually declared.+-}+module Test.RewriteSpec (tests) where++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Set (Set)+import Data.Text (Text)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)++import Salmon.Builtin.Extension (Extension, Op, deps, dynamics, evalDeps, help, nodeps, notes, op, ref)+import qualified Salmon.Builtin.Nodes.Debian.Package as Debian+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Actions (Act (..))+import Salmon.Op.Ref (Ref, mkRef)+import Salmon.Op.Rewrite (Phase (..))+import qualified Salmon.Op.Rewrite as Rewrite+import Salmon.Reporter (silent)++tests :: TestTree+tests =+    testGroup+        "Salmon.Op.Rewrite"+        [ testCase "a run-up phase batches every package into one install node" allInstalled+        , testCase "a run-down phase batches every package into one removal node" allRemoved+        , testCase "a mixed phase splits by direction, removals first" splitByDirection+        , testCase "still-wanted wins: one live declaration protects a package" conservativePartition+        , testCase "edges into a batched node are redirected onto the batch" edgesRedirect+        , testCase "an ignored node is left out of the batch" ignoredIsLeftAlone+        , testCase "a batch stands in for its members, other nodes for themselves" membership+        , testCase "no packages means no rewrite at all" noPackagesNoOp+        ]++-------------------------------------------------------------------------------++pkg :: Text -> Op+pkg = Debian.deb . Debian.Package++pkgRef :: Text -> Ref+pkgRef name = mkRef "debian-deb" name++-- | A consumer that depends on a package, the way a recipe would.+consumer :: Text -> [Op] -> Op+consumer name ds = op name (deps ds) $ \x -> x{ref = mkRef "consumer" name}++computeWith :: Phase -> Op -> Rewrite.Rewritten Extension+computeWith phase o =+    Rewrite.rewrite [Debian.batchPackages silent] phase (Dag.foldDag Dag.sameRepresentative (evalDeps o))++-- | Every node of the computed graph, by shorthand.+shorthands :: Rewrite.Rewritten Extension -> [Text]+shorthands c = [act.shorthand | act <- Map.elems (Dag.dagNodes (Rewrite.computedDag c))]++-- | Only rewrites record membership, so these are exactly the nodes a+-- rewrite introduced.+batchRefs :: Rewrite.Rewritten Extension -> [Ref]+batchRefs = Map.keys . Rewrite.computedMembers++-- | The one batch this graph produced; fails the test rather than throwing+-- if a rewrite produced none or several.+onlyBatch :: Rewrite.Rewritten Extension -> IO Ref+onlyBatch c =+    case batchRefs c of+        [r] -> pure r+        rs -> assertFailure ("expected exactly one batch, got " <> show (length rs))++helpOf :: Rewrite.Rewritten Extension -> Ref -> Text+helpOf c r = maybe "" (\act -> act.extension.help) (Dag.representativeOf (Rewrite.computedDag c) r)++-------------------------------------------------------------------------------++root3 :: Op+root3 = op "root" (deps [pkg "curl", pkg "git", pkg "jq"]) $ \x -> x{ref = mkRef "root" ()}++allRefs :: Op -> Set Ref+allRefs = Set.fromList . Dag.dagOrder . Dag.foldDag Dag.sameRepresentative . evalDeps++allInstalled :: IO ()+allInstalled = do+    let c = computeWith (Phase (allRefs root3) Set.empty) root3+    assertEqual "three deb nodes became one" 1 (length (filter (== "debs") (shorthands c)))+    assertEqual "and no deb node survives" 0 (length (filter (== "deb") (shorthands c)))+    batch <- onlyBatch c+    assertEqual+        "which stands in for all three"+        (Set.fromList (map pkgRef ["curl", "git", "jq"]))+        (Rewrite.membersOf c batch)++allRemoved :: IO ()+allRemoved = do+    -- `run down`: nothing is desired, so the same registered phase emits a+    -- teardown batch instead of an install batch.+    let c = computeWith (Phase Set.empty Set.empty) root3+    batch <- onlyBatch c+    assertEqual+        "described as a removal, not an install"+        "removes 3 packages in one apt-get"+        (helpOf c batch)+    assertEqual+        "still standing in for all three"+        (Set.fromList (map pkgRef ["curl", "git", "jq"]))+        (Rewrite.membersOf c batch)++{- | The case nothing before the fold can express: some packages on their way+in, others on their way out, in one graph. Two batches, and a precedence edge+putting the removal first because both want the dpkg lock.+-}+splitByDirection :: IO ()+splitByDirection = do+    let desired = Set.fromList [pkgRef "curl", mkRef "root" ()]+        c = computeWith (Phase desired Set.empty) root3+    assertEqual "two batches" 2 (length (batchRefs c))+    let [(installRef, _)] = [(r, m) | (r, m) <- Map.toList (Rewrite.computedMembers c), m == Set.singleton (pkgRef "curl")]+        [(removeRef, _)] = [(r, m) | (r, m) <- Map.toList (Rewrite.computedMembers c), m == Set.fromList [pkgRef "git", pkgRef "jq"]]+    assertEqual+        "the install batch waits on the removal batch"+        [removeRef]+        (Dag.dependenciesOf (Rewrite.computedDag c) installRef)++{- | Two declarations disagree about @curl@ — one is being retracted, the+other still wants it. The ledger already answered that by union, and the+rewrite inherits the answer rather than deriving its own: @curl@ must not end+up in a removal batch, or the retraction would uninstall it out from under+the declaration still standing on it.+-}+conservativePartition :: IO ()+conservativePartition = do+    let c = computeWith (Phase (Set.singleton (pkgRef "curl")) Set.empty) root3+    let inRemoval = Set.unions [m | (_, m) <- Map.toList (Rewrite.computedMembers c), Set.notMember (pkgRef "curl") m]+    assertBool "curl is not swept into the removal batch" (Set.notMember (pkgRef "curl") inRemoval)+    assertEqual "the other two are" (Set.fromList [pkgRef "git", pkgRef "jq"]) inRemoval++{- | The old @removeSinglePackages@ blanked the per-package nodes and injected+the batch under the root, which only worked because the batch depended on+nothing. A rewrite redirects the actual edges, so a node that depended on+@deb curl@ now depends on whatever installs curl.+-}+edgesRedirect :: IO ()+edgesRedirect = do+    let one = pkg "curl"+        user = consumer "needs-curl" [one]+        root = op "root" (deps [user]) $ \x -> x{ref = mkRef "root" ()}+        c = computeWith (Phase (allRefs root) Set.empty) root+    batch <- onlyBatch c+    assertEqual+        "the consumer now waits on the batch"+        [batch]+        (Dag.dependenciesOf (Rewrite.computedDag c) (mkRef "consumer" ("needs-curl" :: Text)))+    assertEqual+        "and the batch knows who waits on it"+        [mkRef "consumer" ("needs-curl" :: Text)]+        (Dag.dependantsOf (Rewrite.computedDag c) batch)++{- | A plan's excluded refs, or a @converge --select@'s complement. Batching+one of those would run the work the operator asked to skip, under another+node's name.+-}+ignoredIsLeftAlone :: IO ()+ignoredIsLeftAlone = do+    let c = computeWith (Phase (allRefs root3) (Set.singleton (pkgRef "jq"))) root3+    assertEqual "jq survives as its own node" 1 (length (filter (== "deb") (shorthands c)))+    assertBool+        "and is in no batch"+        (all (Set.notMember (pkgRef "jq")) (Map.elems (Rewrite.computedMembers c)))+    assertEqual+        "jq stands in for itself"+        (Set.singleton (pkgRef "jq"))+        (Rewrite.membersOf c (pkgRef "jq"))++membership :: IO ()+membership = do+    let c = computeWith (Phase (allRefs root3) Set.empty) root3+    assertEqual+        "a node no rewrite touched stands in for itself"+        (Set.singleton (mkRef "root" ()))+        (Rewrite.membersOf c (mkRef "root" ()))++noPackagesNoOp :: IO ()+noPackagesNoOp = do+    let root = op "root" (deps [consumer "a" []]) $ \x -> x{ref = mkRef "root" ()}+        dag = Dag.foldDag Dag.sameRepresentative (evalDeps root)+        c = computeWith (Phase (allRefs root) Set.empty) root+    assertEqual "no batch introduced" [] (batchRefs c)+    assertEqual "same nodes as declared" (Dag.dagOrder dag) (Dag.dagOrder (Rewrite.computedDag c))
+ test/Test/ServeApi.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE OverloadedStrings #-}++{- | A small JSON Schema checker for the OpenAPI document the loop serves+('Salmon.Actions.Serve.Http.openApiDocument'), and the lookups the drift+tests need: the schema of a named component, the schema of a documented+response.++It understands only what the document uses: @$ref@ into @#/components/schemas@,+@type@ (a name or a list), @const@, @enum@, @properties@, @required@,+@additionalProperties@, @items@ and @oneOf@. That is deliberate: a validator+library would be a new dependency for a test suite, and a keyword the document+starts using that this ignores is caught by 'unsupportedKeywords'.++'strict' is what makes it a drift guard rather than a shape check: an object+carrying a key its schema does not declare is an error, so a field added to an+encoder without an entry in the document fails a test.+-}+module Test.ServeApi (+    document,+    schemaNamed,+    validateAs,+    validateAgainst,+    validateResponse,+    validateEventData,+    documentedRoutes,+    unixRoutes,+    unsupportedKeywords,+) where++import Data.Aeson (Value (..), eitherDecodeStrict)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Char8 as C8+import Data.Foldable (toList)+import Data.List (nub)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import Test.Tasty.HUnit (assertFailure)++import Salmon.Actions.Serve.Http (openApiDocument)++-- | The document the binary embeds.+document :: Value+document = either (error . ("the embedded OpenAPI document is not JSON: " <>)) id (eitherDecodeStrict openApiDocument)++lookupPath :: [Text] -> Value -> Maybe Value+lookupPath [] v = Just v+lookupPath (k : ks) (Object o) = KeyMap.lookup (Key.fromText k) o >>= lookupPath ks+lookupPath _ _ = Nothing++schemaNamed :: Text -> Maybe Value+schemaNamed n = lookupPath ["components", "schemas", n] document++-- | Errors validating a value against a named component schema (empty: valid).+validateAs :: Bool -> Text -> Value -> [String]+validateAs strict name v = case schemaNamed name of+    Nothing -> ["no schema named " <> Text.unpack name]+    Just s -> validateAgainst strict s v++validateAgainst :: Bool -> Value -> Value -> [String]+validateAgainst strict = go "$"+  where+    go :: String -> Value -> Value -> [String]+    go path schema v = case schema of+        Object o+            | Just (String r) <- KeyMap.lookup "$ref" o -> case resolve r of+                Nothing -> [path <> ": unresolvable " <> Text.unpack r]+                Just target -> go path target v+            | otherwise ->+                concat+                    [ maybe [] (\c -> [path <> ": expected " <> show c | c /= v]) (KeyMap.lookup "const" o)+                    , maybe [] (\e -> [path <> ": not one of " <> show e | not (isElem v e)]) (KeyMap.lookup "enum" o)+                    , maybe [] (typeCheck path v) (KeyMap.lookup "type" o)+                    , objectChecks path o v+                    , arrayChecks path o v+                    , maybe [] (oneOf path v) (KeyMap.lookup "oneOf" o)+                    ]+        _ -> []++    isElem v (Array xs) = v `elem` toList xs+    isElem _ _ = False++    resolve r = case Text.stripPrefix "#/components/schemas/" r of+        Just n -> schemaNamed n+        Nothing -> Nothing++    typeCheck path v (String t) = [path <> ": expected " <> Text.unpack t | not (isType t v)]+    typeCheck path v (Array ts) = [path <> ": expected one of " <> show ts | not (any (\t -> case t of String t' -> isType t' v; _ -> False) ts)]+    typeCheck _ _ _ = []++    isType "string" (String _) = True+    isType "integer" (Number n) = n == fromIntegral (round n :: Integer)+    isType "number" (Number _) = True+    isType "boolean" (Bool _) = True+    isType "object" (Object _) = True+    isType "array" (Array _) = True+    isType "null" Null = True+    isType _ _ = False++    objectChecks path o (Object vo) =+        let props = case KeyMap.lookup "properties" o of Just (Object p) -> p; _ -> KeyMap.empty+            required = case KeyMap.lookup "required" o of Just (Array rs) -> [r | String r <- toList rs]; _ -> []+            missing = [path <> ": missing " <> Text.unpack r | r <- required, not (KeyMap.member (Key.fromText r) vo)]+            declared =+                concat+                    [ go (path <> "." <> Key.toString k) s x+                    | (k, x) <- KeyMap.toList vo+                    , Just s <- [KeyMap.lookup k props]+                    ]+            open = KeyMap.lookup "additionalProperties" o == Just (Bool True)+            unknown =+                [ path <> ": undocumented field " <> Key.toString k+                | strict+                , not (KeyMap.null props)+                , not open+                , (k, _) <- KeyMap.toList vo+                , not (KeyMap.member k props)+                ]+         in missing <> declared <> unknown+    objectChecks _ _ _ = []++    arrayChecks path o (Array xs) = case KeyMap.lookup "items" o of+        Just s -> concat [go (path <> "[" <> show i <> "]") s x | (i, x) <- zip [0 :: Int ..] (toList xs)]+        Nothing -> []+    arrayChecks _ _ _ = []++    oneOf path v (Array branches) =+        let results = [(b, go path b v) | b <- toList branches]+            valid = [b | (b, []) <- results]+         in case valid of+                [_] -> []+                [] -> [path <> ": no branch matches: " <> shorten (blame v results)]+                _ -> [path <> ": several branches match"]+    oneOf _ _ _ = []++    -- of the failing branches, the ones whose kind/stream the value names, else all+    blame v results =+        let named = [es | (b, es) <- results, sameTag v b]+         in concat (if null named then map snd results else named)+    sameTag (Object vo) b = case resolveBranch b of+        Object bo | Just (Object ps) <- KeyMap.lookup "properties" bo ->+            all (\k -> case (KeyMap.lookup k vo, KeyMap.lookup k ps >>= constOf) of+                    (Just x, Just c) -> x == c+                    _ -> True) ["kind", "stream", "verb"]+        _ -> False+    sameTag _ _ = False+    resolveBranch b@(Object o) | Just (String r) <- KeyMap.lookup "$ref" o = fromMaybe b (resolve r)+    resolveBranch b = b+    constOf (Object o) = KeyMap.lookup "const" o+    constOf _ = Nothing+    shorten es = take 600 (unwords (take 6 es))++-- | The documented schema for this method, path (query stripped) and status,+-- and the errors validating the body against it. A status the operation does+-- not list is an error unless it is one every route may answer (404, 405).+validateResponse :: C8.ByteString -> C8.ByteString -> Int -> Value -> [String]+validateResponse method rawPath status body =+    case matchPath path of+        Nothing+            | status == 404 -> validateAs True "Error" body+            | otherwise -> ["undocumented path " <> Text.unpack path]+        Just template ->+            let op = lookupPath ["paths", template, Text.toLower (Text.pack (C8.unpack method))] document+                resp = op >>= lookupPath ["responses", Text.pack (show status)]+             in case (op, resp) of+                    (Nothing, _)+                        | status == 405 -> validateAs True "Error" body+                        | otherwise -> ["undocumented operation " <> C8.unpack method <> " " <> Text.unpack template]+                    (_, Nothing)+                        | status `elem` [404, 405, 401] -> validateAs True "Error" body+                        | otherwise -> ["undocumented status " <> show status <> " for " <> C8.unpack method <> " " <> Text.unpack template]+                    (_, Just r) -> case lookupPath ["content", "application/json", "schema"] r of+                        Just s -> validateAgainst True s body+                        Nothing -> []+  where+    path = Text.pack (C8.unpack (C8.takeWhile (/= '?') rawPath))++-- | Errors in the @data:@ of one server-sent event, whichever kind it is: the+-- synthetic @gap@, the server's own @enqueued@, or a report with @seq@ (and+-- @origin@ when it belongs to a command) added.+validateEventData :: Value -> [String]+validateEventData v = case (field "stream" v, field "kind" v) of+    (Just (String "server"), Just (String "gap")) -> validateAs True "GapEvent" v+    (Just (String "server"), Just (String "enqueued")) -> validateAs True "EnqueuedEvent" v+    _ ->+        validateAs True "Report" (without "origin" (without "seq" v))+            <> validateAs False "EventData" v+            <> maybe [] (validateAs True "Origin") (field "origin" v)+  where+    field k (Object o) = KeyMap.lookup (Key.fromText k) o+    field _ _ = Nothing+    without k (Object o) = Object (KeyMap.delete (Key.fromText k) o)+    without _ x = x++-- | The document's path template a request path matches.+matchPath :: Text -> Maybe Text+matchPath path = case lookupPath ["paths"] document of+    Just (Object ps) ->+        case [Key.toText k | (k, _) <- KeyMap.toList ps, matches (Key.toText k)] of+            (t : _) -> Just t+            [] -> Nothing+    _ -> Nothing+  where+    segs = filter (not . Text.null) . Text.splitOn "/"+    matches template =+        let ts = segs template+            ps = segs path+         in length ts == length ps && and (zipWith (\t p -> t == p || ("{" `Text.isPrefixOf` t)) ts ps)++-- | Every @(METHOD, template)@ the document describes.+documentedRoutes :: [(Text, Text)]+documentedRoutes = case lookupPath ["paths"] document of+    Just (Object ps) ->+        [ (Text.toUpper (Key.toText m), Key.toText p)+        | (p, Object item) <- KeyMap.toList ps+        , (m, _) <- KeyMap.toList item+        , Key.toText m `elem` ["get", "post", "put", "delete", "patch"]+        ]+    _ -> []++-- | 'documentedRoutes' without the operations marked @x-tcp-only@: the ones+-- the middleware of the TCP listener answers and the unix socket does not.+unixRoutes :: [(Text, Text)]+unixRoutes = case lookupPath ["paths"] document of+    Just (Object ps) ->+        [ (Text.toUpper (Key.toText m), Key.toText p)+        | (p, Object item) <- KeyMap.toList ps+        , (m, op) <- KeyMap.toList item+        , Key.toText m `elem` ["get", "post", "put", "delete", "patch"]+        , lookupPath ["x-tcp-only"] op /= Just (Bool True)+        ]+    _ -> []++-- | Keywords used anywhere in the document's schemas that 'validateAgainst' ignores.+unsupportedKeywords :: [Text]+unsupportedKeywords = nub (filter (`notElem` known) (concatMap collect schemas))+  where+    schemas = case lookupPath ["components", "schemas"] document of+        Just (Object ss) -> KeyMap.elems ss+        _ -> []+    known =+        [ "$ref", "type", "const", "enum", "properties", "required", "additionalProperties", "items", "oneOf"+        , "description", "format", "discriminator", "propertyName"+        ]+    -- keys that are schema keywords: the keys of a schema object, not of a `properties` map+    collect :: Value -> [Text]+    collect (Object o) = concat [keyword k v | (k, v) <- KeyMap.toList o]+    collect _ = []+    keyword k v+        | Key.toText k `elem` ["properties"] = case v of Object ps -> concatMap (collect . snd) (KeyMap.toList ps); _ -> []+        | Key.toText k `elem` ["items"] = collect v+        | Key.toText k `elem` ["oneOf"] = case v of Array bs -> concatMap collect (toList bs); _ -> []+        | otherwise = [Key.toText k]
+ test/Test/ServeApiSpec.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedStrings #-}++{- | The drift guard for @salmon-ops\/openapi\/serve-api.openapi.json@, the+machine-readable description of @run serve@'s HTTP API that the loop also+serves at @GET \/openapi.json@.++Three things are compared with the document, none of them by hand:++* every golden of "Test.ReportJsonSpec" (one per constructor of all four+  report streams), as the object @--json@ prints and as the @data:@ of an+  event, and the status sink's document;+* the set of @(stream, kind)@ the document lists, with the set the goldens+  cover, both ways: a report constructor with no schema, or a schema for one+  that is gone, is a failure here rather than in a client;+* the routes in @Salmon.Actions.Serve.Http@'s source with the document's+  operations, both ways. "Test.ServeHttpSpec" does the rest live: it checks+  every response it gets against the schema of the operation and status, and+  that each documented route answers.++Strict checking (a field the schema does not declare is an error) is what+makes an added field fail rather than pass unnoticed.+-}+module Test.ServeApiSpec (tests) where++import Data.Aeson (Value (..), eitherDecode, toJSON)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Lazy.Char8 as LChar8+import Data.Foldable (toList)+import Data.List (nub, sort, (\\))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.Encoding as LText+import System.Directory (doesFileExist)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)++import qualified Salmon.Actions.Serve as Serve+import qualified Salmon.Actions.Serve.Events as Events+import Salmon.Reporter.Tagged (Tagged)+import Test.ReportJsonSpec (goldens, sinkDocumentText)+import Test.ServeApi++tests :: TestTree+tests =+    testGroup+        "the OpenAPI description of run serve"+        [ testCase "it is OpenAPI 3.1 and uses only keywords the checker understands" $ do+            assertEqual "" (Just (String "3.1.0")) (field "openapi" document)+            assertEqual "keywords the checker ignores" [] unsupportedKeywords+        , testCase "every $ref resolves" $+            assertEqual "" [] [r | r <- refsIn document, Text.stripPrefix "#/components/schemas/" r `notElem` map (Just . fst) schemaNames]+        , testGroup "reports" [testCase name (assertValid (validateAs True "Report" (toJSON tagged))) | (name, tagged, _) <- goldens]+        , testCase "the kinds the document lists are exactly the constructors that have a golden" $ do+            let goldenKinds = nub (sort [k | (_, t, _) <- goldens, Just k <- [streamKind (toJSON t)]])+            assertEqual "in goldens, not in the document" [] (goldenKinds \\ documentKinds)+            assertEqual "in the document, not in goldens" [] (documentKinds \\ goldenKinds)+        , testGroup+            "as the data of an event"+            [ testCase name $ do+                let ev = Events.eventValue (Events.Event 7 (Just (Serve.Origin "sock#3")) (Events.Reported tagged))+                assertValid (validateEvent ev)+            | (name, tagged, _) <- goldens+            ]+        , testCase "an event with no origin, an enqueued event and a gap" $ do+            assertValid (validateEvent (Events.eventValue (Events.Event 1 Nothing (Events.Reported (taggedOf "started")))))+            assertValid (validateAs True "EnqueuedEvent" (Events.eventValue (Events.Event 2 (Just (Serve.Origin "sock#1")) (Events.Enqueued "up a"))))+            assertValid (validateAs True "GapEvent" (Events.gapValue 40))+        , testCase "the status sink's document" $+            case eitherDecode (LText.encodeUtf8 (LText.fromStrict sinkDocumentText)) of+                Left err -> assertFailure err+                Right v -> assertValid (validateAs True "StatusDocument" v)+        , testCase "a report with a field the schema does not declare fails (the guard bites)" $+            assertBool "" (not (null (validateAs True "Report" (addField "surprise" (toJSON (taggedOf "started"))))))+        , testCase "a report missing a declared field fails" $+            assertBool "" (not (null (validateAs True "Report" (dropField "error" (toJSON (taggedOf "bad-command"))))))+        , testCase "the routes in Http.hs and the document's operations agree" routesAgree+        ]+  where+    assertValid errs = assertEqual "schema errors" [] errs++    -- what a client does with an event: the report is the object minus the two+    -- fields the event adds+    validateEvent = validateEventData++    taggedOf :: Text -> Tagged+    taggedOf k = head [t | (_, t, _) <- goldens, streamKind (toJSON t) == Just ("serve", k)]++field :: Text -> Value -> Maybe Value+field k (Object o) = KeyMap.lookup (Key.fromText k) o+field _ _ = Nothing++addField :: Text -> Value -> Value+addField k (Object o) = Object (KeyMap.insert (Key.fromText k) (String "x") o)+addField _ v = v++dropField :: Text -> Value -> Value+dropField k (Object o) = Object (KeyMap.delete (Key.fromText k) o)+dropField _ v = v++streamKind :: Value -> Maybe (Text, Text)+streamKind v = case (field "stream" v, field "kind" v) of+    (Just (String s), Just (String k)) -> Just (s, k)+    _ -> Nothing++schemaNames :: [(Text, Value)]+schemaNames = case field "components" document >>= field "schemas" of+    Just (Object o) -> [(Key.toText k, v) | (k, v) <- KeyMap.toList o]+    _ -> []++-- | The @(stream, kind)@ of every tagged report schema of the four streams.+documentKinds :: [(Text, Text)]+documentKinds =+    nub . sort $+        [ (s, k)+        | (name, schema) <- schemaNames+        , any (`Text.isPrefixOf` name) ["UpDown_", "Upkeep_", "Serve_", "Follow_"]+        , Just props <- [field "properties" schema]+        , Just (String s) <- [field "stream" props >>= field "const"]+        , Just (String k) <- [field "kind" props >>= field "const"]+        ]++refsIn :: Value -> [Text]+refsIn (Object o) = [r | Just (String r) <- [KeyMap.lookup "$ref" o]] <> concatMap refsIn (KeyMap.elems o)+refsIn (Array xs) = concatMap refsIn (toList xs)+refsIn _ = []++-- | @(METHOD, template)@ pairs the routes in the source name, against the document's.+routesAgree :: IO ()+routesAgree = do+    let path = "../salmon-ops/src/Salmon/Actions/Serve/Http.hs"+    there <- doesFileExist path+    if not there+        then putStrLn "SKIPPED: Http.hs is not next to the test suite; the route table comparison needs the source tree"+        else do+            src <- readFile path+            let coded = nub (sort (concatMap routesOf (lines src)))+                documented = nub (sort [(m, normalise p) | (m, p) <- documentedRoutes])+            assertEqual "routes in the code the document lacks" [] (coded \\ documented)+            assertEqual "operations in the document the code lacks" [] (documented \\ coded)+  where+    normalise p+        | p == "/ui/{file}" = "/ui"+        | otherwise = p++    -- lines like   ("GET", ["dag"]) ->    /   ("POST", ["auth", "logout"]) ->   /   ("GET", ("ui" : rest)) ->+    routesOf :: String -> [(Text, Text)]+    routesOf line =+        case Text.stripPrefix "(\"" (Text.strip (Text.pack line)) of+            Just rest+                | (m, after) <- Text.breakOn "\"" rest+                , m `elem` ["GET", "POST"]+                , Just r <- Text.stripPrefix "\", " after ->+                    [(m, routePath (Text.takeWhile (/= '>') r))]+            _ -> []++    routePath r+        | "[]" `Text.isPrefixOf` r = "/"+        | "(\"ui\"" `Text.isPrefixOf` r = "/ui"+        | "[" `Text.isPrefixOf` r =+            "/" <> Text.intercalate "/" (Text.splitOn "," (Text.filter (`notElem` ['[', ']', ' ', '"']) (Text.takeWhile (/= ']') r)))+        | otherwise = r
+ test/Test/ServeEventsSpec.hs view
@@ -0,0 +1,710 @@+{-# LANGUAGE DeriveGeneric #-}++{- | Coverage for "Salmon.Actions.Serve.Events" and @GET \/events@ in+"Salmon.Actions.Serve.Http" (milestone 4 of @specs\/generic-server.md@).++Layer 0 on the record itself: the ring's replay and gap arithmetic, the+gap event's golden JSON, and the shape of an event object. Layer 1 over a+real unix socket and a real @http-client@ reading a @text\/event-stream@+response chunk by chunk: a client that disconnects at a seeded random point+in a pass and comes back with @?since=@ sees, end to end, exactly what a+client that never left saw; sequence numbers are strictly increasing across+the @serve@, @updown@ and @upkeep@ streams with supervision on and a node+whose check keeps failing, so that machine threads are reporting beside the+loop; a ring too small for what happened answers a resumption with a @gap@+first; an @?async@ command's number is the cursor its reports follow; the+@seq@ on @\/status@ and @\/dag@ is the cursor from which nothing after the+snapshot is missed; the filters narrow; and a client hanging up drops its+subscription.+-}+module Test.ServeEventsSpec (tests) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)+import qualified Control.Concurrent.STM as STM+import Control.Exception (try)+import Control.Monad (forM, forM_, when)+import Data.Aeson (FromJSON, ToJSON, Value (..), eitherDecode, eitherDecodeStrict)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Lazy.Char8 as LChar8+import Data.Foldable (toList)+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust, isNothing, mapMaybe)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Word (Word64)+import GHC.Generics (Generic)+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Client.Internal (makeConnection)+import qualified Network.HTTP.Types as HTTP+import qualified Network.Socket as Socket+import qualified Network.Socket.ByteString as SocketBS+import System.Environment (lookupEnv)+import System.FilePath ((</>))+import System.IO (Handle, hClose)+import System.Posix.IO (FdOption (CloseOnExec), createPipe, fdToHandle, setFdOption)+import System.Posix.Types (Fd (..))+import System.Timeout (timeout)+import qualified Test.ServeApi as Api+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)+import Text.Read (readMaybe)++import qualified Salmon.Actions.Follow as Follow+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 qualified Salmon.Actions.UpDown as UpDown+import qualified Salmon.Actions.Upkeep as Upkeep+import Salmon.Builtin.Extension (Track', check, deps, down, help, nodeps, op, opAct, ref, up)+import Salmon.Op.Configure (Configure (..))+import Salmon.Op.Ref (mkRef)+import Salmon.Op.Track (Track (..))+import Salmon.Reporter (contramap, runReporter)+import qualified Salmon.Reporter.Tagged as Tagged++import Test.Harness (capture, withTempDir)++tests :: TestTree+tests =+    testGroup+        "Salmon.Actions.Serve.Events"+        [ testGroup+            "the record"+            [ testCase "replay is everything after since that the ring still holds; a gap when it does not" ringArithmetic+            , testCase "golden JSON for the gap event" gapGolden+            , testCase "an event is the Tagged object plus seq, plus origin when it belongs to a command" eventShape+            ]+        , testGroup+            "GET /events"+            [ testCase "a client that reconnects mid-pass misses nothing" reconnectMissesNothing+            , testCase "sequence numbers are strictly increasing across serve, updown and upkeep" strictlyIncreasingAcrossStreams+            , testCase "a ring that no longer reaches since answers with a gap first" ringOverflowGap+            , testCase "?async then ?since= sees that command's reports" asyncThenSince+            , testCase "/status and /dag carry seq, and ?since= that seq misses nothing after" snapshotSeq+            , testCase "?stream= and ?origin= narrow the stream" filters+            , testCase "the pull-mode fetcher's reports are the follow stream: numbered with the rest, no origin, filterable" followStream+            , testCase "an idle stream is kept alive, and a client hanging up drops its subscription" keepAliveAndCleanup+            ]+        ]++-------------------------------------------------------------------------------+-- Layer 0: the record++anOrigin :: Serve.Origin+anOrigin = Serve.Origin "test#1"++ringArithmetic :: IO ()+ringArithmetic = do+    ev <- Events.newEvents Events.defaultConfig{Events.configRing = 3}+    forM_ [1 :: Int .. 5] $ \i -> Events.publish ev Nothing (Events.Enqueued ("line " <> show i))+    lastSeq <- Events.lastSequence ev+    assertEqual "five numbers handed out, from 1" 5 lastSeq+    let subscribe since = Events.withSubscription ev since $ \sub ->+            pure (Events.subscriptionGap sub, fmap Events.eventSeq (Events.subscriptionReplay sub))+    assertEqual "live only: nothing to replay, no gap" (Nothing, []) =<< subscribe Nothing+    assertEqual "from 0: 1 and 2 fell off, so a gap from 3" (Just 3, [3, 4, 5]) =<< subscribe (Just 0)+    assertEqual "from 1: 2 fell off, a gap" (Just 3, [3, 4, 5]) =<< subscribe (Just 1)+    assertEqual "from 2: the next event is the oldest kept, no gap" (Nothing, [3, 4, 5]) =<< subscribe (Just 2)+    assertEqual "from 4: the last one" (Nothing, [5]) =<< subscribe (Just 4)+    assertEqual "from 5: caught up" (Nothing, []) =<< subscribe (Just 5)+    assertEqual "from beyond: nothing, and no gap either" (Nothing, []) =<< subscribe (Just 9)+    -- the live feed starts exactly after the replay+    Events.withSubscription ev (Just 4) $ \sub -> do+        n <- Events.publish ev Nothing (Events.Enqueued "line 6")+        e <- atomicallyNext sub+        assertEqual "the first live event is the one published after subscribing" n (Events.eventSeq e)+    assertEqual "no subscriber left" 0 =<< Events.subscribers ev+  where+    atomicallyNext sub = do+        r <- timeout (5 * 1000000) (STM.atomically (Events.subscriptionLive sub))+        maybe (assertFailure "no live event") pure r++gapGolden :: IO ()+gapGolden = do+    let expected = "{\"kind\":\"gap\",\"from\":42,\"stream\":\"server\"}"+    expectedValue <- either (assertFailure . ("golden is not JSON: " <>)) pure (eitherDecode expected)+    assertEqual "the gap event" (expectedValue :: Value) (Events.gapValue 42)+    -- and on the wire it is one data line with no id, so a client resumes+    -- from the last real number+    let rendered = Builder.toLazyByteString (Events.renderGap 42)+    assertEqual "one data line, then the blank line" (Just ("data: ", "\n\n")) (stripAround rendered)+    assertEqual "carrying the object" (Right expectedValue) (eitherDecode (LChar8.drop 6 (LChar8.dropEnd 2 rendered)))+  where+    stripAround bs+        | LChar8.length bs > 8 = Just (LChar8.take 6 bs, LChar8.takeEnd 2 bs)+        | otherwise = Nothing++eventShape :: IO ()+eventShape = do+    let reported = Events.Event 7 (Just anOrigin) (Events.Reported (Tagged.FromServe Serve.Started))+        tending = Events.Event 8 Nothing (Events.Reported (Tagged.FromUpkeep (Upkeep.Retired 2)))+        queued = Events.Event 9 (Just anOrigin) (Events.Enqueued "up n1")+    assertEqual "a report keeps its stream and kind, and gains seq and origin"+        (Just ("serve", "started", Just 7, Just "test#1"))+        (shape (Events.eventValue reported))+    assertEqual "a tending report is on the upkeep stream with no origin"+        (Just ("upkeep", "retired", Just 8, Nothing))+        (shape (Events.eventValue tending))+    assertEqual "an enqueued command is the server's own"+        (Just ("server", "enqueued", Just 9, Just "test#1"))+        (shape (Events.eventValue queued))+    assertEqual "with the line" (Just "up n1") (textAt ["line"] (Events.eventValue queued))+    -- a line of a node's output is its own stream, so `?stream=output` is a live tail+    case opAct (op "tail-node" nodeps id) of+        Nothing -> assertFailure "an op with an extension has an act"+        Just act -> do+            let line = Events.Event 10 Nothing (Events.Reported (Tagged.FromUpkeep (Upkeep.Output act "hello")))+            assertEqual "an output line is on the output stream, with its text"+                (Just ("output", "output", Just 10, Nothing))+                (shape (Events.eventValue line))+            assertEqual "with the line" (Just "hello") (textAt ["line"] (Events.eventValue line))+            assertBool "and a ?stream=upkeep client does not get it" (not (Events.matches (Events.Filter (Just (Set.fromList ["upkeep"])) Nothing) line))+    -- and a Tended report is unwrapped by the reporter+    ev <- Events.newEvents Events.defaultConfig+    runReporter (Events.eventsReporter ev) (Attributed Nothing (Tagged.FromServe (Serve.Tended (Upkeep.Holding 1))))+    Events.withSubscription ev (Just 0) $ \sub ->+        case Events.subscriptionReplay sub of+            [e] -> assertEqual "unwrapped" (Just ("upkeep", "holding", Just 1, Nothing)) (shape (Events.eventValue e))+            es -> assertFailure ("one event expected: " <> show es)+  where+    shape v = do+        stream <- textAt ["stream"] v+        kind <- textAt ["kind"] v+        pure (stream, kind, seqOf v, textAt ["origin", "name"] v)++-------------------------------------------------------------------------------+-- the thing served: counters per node name, and one node that is never satisfied++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)++-- | The node whose @check@ always says its effect is gone, so its machine+-- keeps acting under supervision and reports from its own thread.+flakyName :: String+flakyName = "flaky"++spyProgram :: IORef (Map String Int) -> Track' Spec+spyProgram upsRef = Track $ \spec ->+    op "events-root" (deps (fmap nodeOp spec.specNames)) $ \actions ->+        actions{ref = mkRef "events-root" spec.specNames, help = "the root of " <> Text.pack (unwords spec.specNames)}+  where+    nodeOp name =+        op "events-node" nodeps $ \actions ->+            actions+                { ref = mkRef "events-node" name+                , help = "node " <> Text.pack name+                , up = bump name+                , down = pure ()+                , check = if name == flakyName then pure (UpDown.Failure "never satisfied") else actions.check+                }+    bump name = atomicModifyIORef' upsRef (\m -> (Map.insertWith (+) name 1 m, ()))++-------------------------------------------------------------------------------+-- a running loop with an HTTP server++data Running = Running+    { runningStdin :: Handle+    , runningWorld :: MVar (World Spec Spec)+    , runningServer :: Http.Server+    , runningManager :: HTTP.Manager+    , runningUps :: IORef (Map String Int)+    }++withRunning :: (Running -> IO a) -> IO a+withRunning = withRunningWith Events.defaultConfig++{- | Every file descriptor a test here opens is marked close-on-exec, and+the reason is worth spelling out: the suite runs its groups in parallel in+one process, some of them spawn processes, and a child spawned while this+test is running inherits every descriptor not so marked (nothing in the+tree passes @close_fds@). A child holding a copy of the loop's stdin pipe+keeps the loop from ever reading end of input, and one holding a copy of a+client socket keeps the server's writes succeeding after the client hung+up — each of which is a ten-second wait for something that is never going+to happen. @network@'s 'Socket.socket' sets @SOCK_NONBLOCK@ but not+@SOCK_CLOEXEC@ (its 'Socket.accept' does), and @process@'s pipe is plain.+-}+withRunningWith :: Events.Config -> (Running -> IO a) -> IO a+withRunningWith cfg act =+    withTempDir $ \dir -> do+        let path = dir </> "events.http"+        (stdinR, stdinW) <- privatePipe+        worldVar <- newEmptyMVar+        (own, _) <- capture+        upsRef <- newIORef Map.empty+        Http.withHttpServerWith cfg 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+            manager <- unixManager path+            r <- act (Running stdinW worldVar server manager upsRef)+            _ <- try (hClose stdinW) :: IO (Either IOError ())+            ended <- timeout (10 * 1000000) (takeMVar worldVar)+            when (isNothing ended) (assertFailure "the loop did not end")+            pure r++-- | A pipe neither end of which a child process may inherit; see 'withRunningWith'.+privatePipe :: IO (Handle, Handle)+privatePipe = do+    (r, w) <- createPipe+    forM_ [r, w] $ \fd -> setFdOption fd CloseOnExec True+    (,) <$> fdToHandle r <*> fdToHandle w++unixManager :: FilePath -> IO HTTP.Manager+unixManager path =+    HTTP.newManager+        HTTP.defaultManagerSettings+            { HTTP.managerRawConnection = pure $ \_ _ _ -> do+                sock <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol+                Socket.withFdSocket sock $ \fd -> setFdOption (Fd fd) CloseOnExec True+                Socket.connect sock (Socket.SockAddrUnix path)+                makeConnection (SocketBS.recv sock 4096) (SocketBS.sendAll sock) (Socket.close sock)+            }++get :: Running -> String -> IO (Int, Value)+get running route = do+    req <- HTTP.parseRequest ("http://salmon" <> route)+    exchange running req++post :: Running -> String -> String -> IO (Int, Value)+post running route line = do+    req0 <- HTTP.parseRequest ("http://salmon" <> route)+    let req =+            req0+                { HTTP.method = "POST"+                , HTTP.requestHeaders = [(HTTP.hContentType, "text/plain")]+                , HTTP.requestBody = HTTP.RequestBodyLBS (LChar8.pack line)+                }+    exchange running req++exchange :: Running -> HTTP.Request -> IO (Int, Value)+exchange running req = do+    r <- timeout (10 * 1000000) (HTTP.httpLbs req (runningManager running))+    case r of+        Nothing -> assertFailure ("no answer within 10s to " <> show (HTTP.path req))+        Just resp ->+            case eitherDecode (HTTP.responseBody resp) of+                Left err -> assertFailure ("not JSON: " <> err <> ": " <> LChar8.unpack (HTTP.responseBody resp))+                Right v -> do+                    let status = HTTP.statusCode (HTTP.responseStatus resp)+                    assertEqual+                        ("schema errors in " <> show (HTTP.method req) <> " " <> show (HTTP.path req) <> " -> " <> show status)+                        []+                        (Api.validateResponse (HTTP.method req) (HTTP.path req) status v)+                    pure (status, v)++-- | A synchronous command: the kinds of the reports it answered with.+sync :: Running -> String -> IO [Text]+sync running line = do+    (code, v) <- post running "/command" line+    assertEqual ("status of sync " <> line) 200 code+    pure (fmap kindOf (arrayOf v))++-- | An asynchronous command: its number and the origin it was queued under.+async :: Running -> String -> IO (Word64, Text)+async running line = do+    (code, v) <- post running "/command?async" line+    assertEqual ("status of async " <> line) 202 code+    case (seqOf v, textAt ["origin"] v) of+        (Just n, Just origin) -> pure (n, origin)+        _ -> assertFailure ("async answer has no seq/origin: " <> show v)++-------------------------------------------------------------------------------+-- an SSE client++-- | One event as the stream carried it: the @id@ line, and the @data@ object.+data Sse = Sse+    { sseId :: Maybe Word64+    , sseData :: Value+    }+    deriving (Eq, Show)++-- | An open stream: the next event (blocking, 10s at most), and how many+-- comment lines have gone by.+data Stream = Stream+    { streamNext :: IO Sse+    , streamComments :: IO Int+    }++{- | Open @\/events@ with a query string, hand the stream to the action, and+close the connection when it returns — which is how a client hangs up.+-}+withEvents :: Running -> String -> (Stream -> IO a) -> IO a+withEvents running query act = do+    req <- HTTP.parseRequest ("http://salmon/events" <> query)+    HTTP.withResponse req (runningManager running) $ \resp -> do+        assertEqual ("status of /events" <> query) 200 (HTTP.statusCode (HTTP.responseStatus resp))+        assertEqual "content type" (Just "text/event-stream") (lookup HTTP.hContentType (HTTP.responseHeaders resp))+        buf <- newIORef ByteString.empty+        pending <- newIORef []+        comments <- newIORef (0 :: Int)+        let next = do+                ps <- readIORef pending+                case ps of+                    (e : es) -> writeIORef pending es >> pure e+                    [] -> do+                        chunk <- timeout (10 * 1000000) (HTTP.brRead (HTTP.responseBody resp))+                        case chunk of+                            Nothing -> assertFailure ("no event within 10s on /events" <> query)+                            Just c | ByteString.null c -> assertFailure ("/events" <> query <> " ended")+                            Just c -> do+                                b <- readIORef buf+                                let (blocks, rest) = splitBlocks (b <> c)+                                writeIORef buf rest+                                parsed <- forM blocks parseBlock+                                let (cs, es) = (length (filter isNothing parsed), mapMaybe id parsed)+                                modifyIORef' comments (+ cs)+                                writeIORef pending es+                                next+        act (Stream next (readIORef comments))+  where+    -- complete blocks (ended by a blank line) and whatever is left+    splitBlocks :: ByteString.ByteString -> ([ByteString.ByteString], ByteString.ByteString)+    splitBlocks bs =+        case ByteString.breakSubstring "\n\n" bs of+            (block, rest)+                | ByteString.null rest -> ([], bs)+                | otherwise ->+                    let (more, left) = splitBlocks (ByteString.drop 2 rest)+                     in (block : more, left)+    -- Nothing for a comment block+    parseBlock :: ByteString.ByteString -> IO (Maybe Sse)+    parseBlock block = do+        let ls = Char8.lines block+            fieldOf name = [ByteString.drop (ByteString.length name) l | l <- ls, name `ByteString.isPrefixOf` l]+        if all (": " `ByteString.isPrefixOf`) ls+            then pure Nothing+            else case fieldOf "data: " of+                [raw] -> case eitherDecodeStrict raw of+                    Left err -> assertFailure ("event data is not JSON: " <> err <> ": " <> Char8.unpack raw)+                    Right v -> do+                        -- every event any test in this spec reads is also checked+                        -- against the OpenAPI document+                        assertEqual ("schema errors in event " <> Char8.unpack raw) [] (Api.validateEventData v)+                        pure (Just (Sse (readMaybe . Char8.unpack =<< headMay (fieldOf "id: ")) v))+                _ -> assertFailure ("not one data line: " <> Char8.unpack block)+    headMay (x : _) = Just x+    headMay [] = Nothing++-- | Read until an event satisfies the predicate; that event is included.+readUntil :: (Sse -> Bool) -> Stream -> IO [Sse]+readUntil done stream = go []+  where+    go acc = do+        e <- streamNext stream+        if done e then pure (reverse (e : acc)) else go (e : acc)++-- | Read at most @n@ events, stopping early at one satisfying the predicate.+readUpTo :: Int -> (Sse -> Bool) -> Stream -> IO [Sse]+readUpTo n done stream = go n []+  where+    go 0 acc = pure (reverse acc)+    go k acc = do+        e <- streamNext stream+        if done e then pure (reverse (e : acc)) else go (k - 1) (e : acc)++-- | The loop's @hung-up@ for an origin: the last thing it says about a command.+hungUpFrom :: Text -> Sse -> Bool+hungUpFrom origin e = kindOf (sseData e) == "hung-up" && textAt ["from"] (sseData e) == Just origin++-------------------------------------------------------------------------------+-- reading the JSON++kindOf :: Value -> Text+kindOf = maybe "<no kind>" id . textAt ["kind"]++textAt :: [Text] -> Value -> Maybe Text+textAt [] (String t) = Just t+textAt (k : ks) (Object o) = KeyMap.lookup (Key.fromText k) o >>= textAt ks+textAt _ _ = Nothing++seqOf :: Value -> Maybe Word64+seqOf = numberAt "seq"++numberAt :: Text -> Value -> Maybe Word64+numberAt k (Object o) = case KeyMap.lookup (Key.fromText k) o of+    Just (Number n) -> Just (truncate n)+    _ -> Nothing+numberAt _ _ = Nothing++field :: Text -> Value -> Maybe Value+field k (Object o) = KeyMap.lookup (Key.fromText k) o+field _ _ = Nothing++arrayOf :: Value -> [Value]+arrayOf (Array xs) = toList xs+arrayOf _ = []++streamOf :: Sse -> Maybe Text+streamOf = textAt ["stream"] . sseData++originOf :: Sse -> Maybe Text+originOf = textAt ["origin", "name"] . sseData++-- | Every id present, and strictly increasing, and equal to the object's seq.+assertNumbered :: String -> [Sse] -> IO ()+assertNumbered label es = do+    ids <- forM es $ \e -> case sseId e of+        Nothing -> assertFailure (label <> ": an event without an id: " <> show e)+        Just n -> do+            assertEqual (label <> ": id and seq agree") (Just n) (seqOf (sseData e))+            pure n+    assertBool (label <> ": strictly increasing: " <> show ids) (and (zipWith (<) ids (drop 1 ids)))++-------------------------------------------------------------------------------+-- a seed for the random cut, printed so a failure can be replayed++-- | @SALMON_EVENTS_SEED@ if set, else the clock; printed either way.+pickSeed :: IO Word64+pickSeed = do+    env <- lookupEnv "SALMON_EVENTS_SEED"+    s <- case env >>= readMaybe of+        Just n -> pure n+        Nothing -> truncate . (* 1000) <$> getPOSIXTime+    putStrLn ("  ServeEventsSpec seed: " <> show s <> " (SALMON_EVENTS_SEED to replay)")+    pure s++-- | A step of a 64-bit LCG (Knuth's constants).+lcg :: Word64 -> Word64+lcg s = s * 6364136223846793005 + 1442695040888963407++-------------------------------------------------------------------------------+-- Layer 1++reconnectMissesNothing :: IO ()+reconnectMissesNothing = do+    seed <- pickSeed+    withRunning $ \running -> do+        _ <- sync running "supervise off"+        -- two clients attach before anything happens; A never leaves+        withEvents running "?since=0" $ \streamA -> do+            (bs1, marker) <- withEvents running "?since=0" $ \streamB -> do+                forM_ script (async running)+                (_, marker) <- async running "history"+                -- B reads a random prefix of the pass, then hangs up+                let cut = fromIntegral (lcg seed `mod` 60)+                bs1 <- readUpTo cut (hungUpFrom marker) streamB+                pure (bs1, marker)+            let sawMarker = any (hungUpFrom marker) bs1+                lastSeen = case reverse (mapMaybe sseId bs1) of+                    (n : _) -> n+                    [] -> 0+            bs2 <-+                if sawMarker+                    then pure []+                    else withEvents running ("?since=" <> show lastSeen) (readUntil (hungUpFrom marker))+            as <- readUntil (hungUpFrom marker) streamA+            assertNumbered ("seed " <> show seed <> ", A") as+            assertBool "no gap event on the way back" (all (\e -> kindOf (sseData e) /= "gap") bs2)+            assertEqual ("seed " <> show seed <> ": B's two halves are A's stream") as (bs1 ++ bs2)+            assertBool "the pass was actually observed" (any (\e -> kindOf (sseData e) == "done") as)+  where+    script = ["up n1 n2", "up n2 n3", "down n1 n2", "up n4 n5 n6", "only n7"]++strictlyIncreasingAcrossStreams :: IO ()+strictlyIncreasingAcrossStreams =+    withRunning $ \running -> do+        _ <- sync running ("up " <> flakyName <> " n1")+        -- the loop is now idle, so the machines are tending; the flaky+        -- node's check keeps failing, so its machine keeps re-applying+        -- it from its own thread while the supervisor reports around it+        -- read until the machines have been seen at work: the supervisor's+        -- own stream, and a node report with no origin, which only a+        -- machine emits (a pass's are stamped with the command's)+        es <- withEvents running "?since=0" $ \stream ->+            let go acc seen+                    | Set.fromList ["serve", "upkeep", "machine"] `Set.isSubsetOf` seen = pure (reverse acc)+                    | otherwise = do+                        e <- streamNext stream+                        let tag = case (streamOf e, originOf e, kindOf (sseData e)) of+                                (Just "updown", Nothing, "done") -> Just "machine"+                                (st, _, _) -> st+                        go (e : acc) (maybe seen (`Set.insert` seen) tag)+             in go [] Set.empty+        assertNumbered "across streams" es+        let streams = Set.fromList (mapMaybe streamOf es)+        assertBool ("all three streams seen: " <> show streams) (Set.fromList ["serve", "updown", "upkeep"] `Set.isSubsetOf` streams)+        -- what the machines report has no origin; what the command did has+        assertBool "machine reports carry no origin" (all (isNothing . originOf) [e | e <- es, streamOf e == Just "upkeep"])+        assertBool "the command's reports carry its origin" (any (isJust . originOf) [e | e <- es, kindOf (sseData e) == "declared"])+        ups <- readIORef (runningUps running)+        assertBool "the flaky node was re-applied by its machine" (Map.findWithDefault 0 flakyName ups >= 2)++ringOverflowGap :: IO ()+ringOverflowGap =+    withRunningWith Events.defaultConfig{Events.configRing = 8} $ \running -> do+        _ <- sync running "supervise off"+        _ <- sync running "up n1 n2"+        _ <- sync running "up n3"+        (_, marker) <- async running "history"+        lastSeq <- Events.lastSequence (Http.serverEvents (runningServer running))+        assertBool "more happened than the ring holds" (lastSeq > 8)+        es <- withEvents running "?since=0" (readUntil (hungUpFrom marker))+        case es of+            (gap : rest) -> do+                assertEqual "the first event is the gap" "gap" (kindOf (sseData gap))+                assertEqual "with no id" Nothing (sseId gap)+                assertEqual "stream server" (Just "server") (streamOf gap)+                let from = numberAt "from" (sseData gap)+                assertEqual "from is the oldest event kept" from (sseId =<< headMay rest)+                assertEqual "which is the ring's size back from the end" (Just (lastSeq - 8 + 1)) from+                assertNumbered "after the gap" rest+                assertEqual "contiguous to the end" [lastSeq - 8 + 1 .. lastSeq] (mapMaybe sseId rest)+            [] -> assertFailure "no events"+        -- resuming from inside the ring: no gap+        es' <- withEvents running ("?since=" <> show (lastSeq - 2)) (readUntil (hungUpFrom marker))+        assertEqual "two events, no gap" [lastSeq - 1, lastSeq] (mapMaybe sseId es')+  where+    headMay (x : _) = Just x+    headMay [] = Nothing++asyncThenSince :: IO ()+asyncThenSince =+    withRunning $ \running -> do+        _ <- sync running "supervise off"+        (n, origin) <- async running "up a1 a2"+        es <- withEvents running ("?since=" <> show n) (readUntil (hungUpFrom origin))+        assertNumbered "after the enqueue" es+        assertBool "everything is numbered after the enqueue" (all (maybe False (> n)) (fmap sseId es))+        let mine = [kindOf (sseData e) | e <- es, originOf e == Just origin]+        forM_ ["declared", "converge-start", "converge-stop"] $ \k ->+            assertBool (Text.unpack k <> " is among the command's reports: " <> show mine) (k `elem` mine)+        assertBool "node reports are stamped too" ("done" `elem` mine)+        -- and the enqueued event itself is the number handed back+        withEvents running ("?since=" <> show (n - 1)) $ \stream -> do+            e <- streamNext stream+            assertEqual "the enqueue is event n" (Just n) (sseId e)+            assertEqual "kind" "enqueued" (kindOf (sseData e))+            assertEqual "line" (Just "up a1 a2") (textAt ["line"] (sseData e))+            assertEqual "origin" (Just origin) (originOf e)++snapshotSeq :: IO ()+snapshotSeq =+    withRunning $ \running -> do+        _ <- sync running "supervise off"+        _ <- sync running "up s1"+        (_, st) <- get running "/status"+        (_, dag) <- get running "/dag"+        s <- maybe (assertFailure "no seq on /status") pure (seqOf st)+        assertEqual "/dag carries the same cursor, nothing having happened in between" (Just s) (seqOf dag)+        lastSeq <- Events.lastSequence (Http.serverEvents (runningServer running))+        assertEqual "the cursor is the last number handed out" lastSeq s+        -- something happens after the snapshot+        _ <- sync running "up s2"+        (_, marker) <- async running "history"+        es <- withEvents running ("?since=" <> show s) (readUntil (hungUpFrom marker))+        assertNumbered "after the snapshot" es+        assertEqual "the first event after the snapshot is the very next number" (Just (s + 1)) (sseId =<< headMay es)+        assertEqual "which is the command typed after it" (Just "up s2") (textAt ["line"] . sseData =<< headMay es)+        assertBool "and its pass is there" (any (\e -> kindOf (sseData e) == "converge-stop") es)+  where+    headMay (x : _) = Just x+    headMay [] = Nothing++filters :: IO ()+filters =+    withRunning $ \running -> do+        _ <- sync running "supervise off"+        _ <- sync running "up f1"+        (_, origin) <- async running "up f2"+        _ <- sync running "status"+        (_, marker) <- async running "history"+        -- by stream+        serveOnly <- withEvents running "?since=0&stream=serve" (readUntil (hungUpFrom marker))+        assertBool "only the serve stream" (all ((== Just "serve") . streamOf) serveOnly)+        assertBool "and it is not empty" (not (null serveOnly))+        twoStreams <- withEvents running "?since=0&stream=updown,server" (readUntil (\e -> kindOf (sseData e) == "enqueued" && textAt ["line"] (sseData e) == Just "history"))+        let seen = Set.fromList (mapMaybe streamOf twoStreams)+        assertEqual "exactly the two asked for" (Set.fromList ["updown", "server"]) seen+        -- by origin: the last thing said under an origin is its converge-stop+        -- (the origin names the socket path and a `#`, so it is escaped)+        mine <- withEvents running ("?since=0&origin=" <> Char8.unpack (HTTP.urlEncode True (Text.encodeUtf8 origin))) (readUntil (\e -> kindOf (sseData e) == "converge-stop"))+        assertBool "only that origin" (all ((== Just origin) . originOf) mine)+        assertBool "the enqueue, the declaration and the pass" (all (`elem` fmap (kindOf . sseData) mine) ["enqueued", "declared", "converge-stop"])+        -- a bad cursor is refused+        req <- HTTP.parseRequest "http://salmon/events?since=soon"+        resp <- HTTP.httpLbs req (runningManager running)+        assertEqual "since must be a number" 400 (HTTP.statusCode (HTTP.responseStatus resp))++{- | The fetcher is a producer with a reporter of its own, so what puts its+reports on the ring is a reporter composed beside that one+('Http.serverFollowReporter'). They are numbered from the same counter as+everything else, carry no @origin@ (nobody typed them), and are a stream a+client can ask for or leave out. -}+followStream :: IO ()+followStream =+    withRunning $ \running -> do+        _ <- sync running "supervise off"+        let lbl = either (error . Text.unpack) id (Follow.mkLabel "web")+            say = runReporter (Http.serverFollowReporter (runningServer running))+        say (Follow.Missing lbl)+        say (Follow.Backoff 2 4000000)+        (_, marker) <- async running "history"+        everything <- withEvents running "?since=0" (readUntil (hungUpFrom marker))+        let followed = [e | e <- everything, streamOf e == Just "follow"]+        assertEqual "the two reports, in the order they were said" ["missing", "backoff"] (fmap (kindOf . sseData) followed)+        assertBool "nobody typed them: no origin" (all ((== Nothing) . originOf) followed)+        assertNumbered "one counter across the follow stream and the rest" everything+        -- asked for, and left out+        only <- withEvents running "?since=0&stream=follow" (readUntil ((== "backoff") . kindOf . sseData))+        assertEqual "only the follow stream" [Just "follow", Just "follow"] (fmap streamOf only)+        without <- withEvents running "?since=0&stream=serve,updown,upkeep,server" (readUntil (hungUpFrom marker))+        assertBool "and not there when not asked for" (all ((/= Just "follow") . streamOf) without)+        assertBool "the rest is" (not (null without))++keepAliveAndCleanup :: IO ()+keepAliveAndCleanup =+    withRunningWith Events.defaultConfig{Events.configKeepAlive = 100 * 1000} $ \running -> do+        _ <- sync running "supervise off"+        let ev = Http.serverEvents (runningServer running)+        withEvents running "" $ \stream -> do+            assertEqual "one subscriber" 1 =<< Events.subscribers ev+            -- nothing happens; the stream is kept alive with comments+            threadDelay (500 * 1000)+            (_, marker) <- async running "history"+            _ <- readUntil (hungUpFrom marker) stream+            n <- streamComments stream+            assertBool ("keep-alive comments arrived while idle: " <> show n) (n >= 2)+        -- the client hung up: the next keep-alive write fails and the+        -- subscription is dropped+        let waitGone k = do+                left <- Events.subscribers ev+                if left == 0+                    then pure ()+                    else+                        if k <= (0 :: Int)+                            then assertFailure ("subscription not dropped after hang-up: " <> show left)+                            else threadDelay (100 * 1000) >> waitGone (k - 1)+        waitGone 100
+ test/Test/ServeHttpSpec.hs view
@@ -0,0 +1,711 @@+{-# LANGUAGE DeriveGeneric #-}++{- | Layer 1 coverage for "Salmon.Actions.Serve.Http" (milestone 3 of+@specs\/generic-server.md@): the @run serve@ loop with an HTTP server on a+unix socket beside its standard input, driven by a real @http-client@ over+real connections.++The nodes are the counter-bumping stubs 'Test.ServeSocketSpec' uses, plus+one whose @up@ blocks until the test lets it go. The claims: @\/dag@ is,+node for node and edge for edge, what 'Help.printDagTree' prints for the+same world; it is populated the moment something is declared, before any+pass; a retired seed's nodes stay in it wanted @down@ until they are gone;+a script typed through @POST \/command@ synchronously, asynchronously, and+on standard input leaves the same world, and the synchronous form answers+with exactly the reports each line produced; and a read answers while the+loop is inside a node's @up@. Milestone 7's static files: @GET \/@ is the+page, @\/ui\/ui.js@ is the script with its content type — one that subscribes+from a snapshot's @seq@, writes only through @POST \/command?async@, reads+@\/help\/seed@ for its seed form and never sends @quit@ — and a path outside+the embedded set is the ordinary @404@.+-}+module Test.ServeHttpSpec (tests) where++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)+import Control.Exception (try)+import Control.Monad (forM, forM_)+import Data.Aeson (FromJSON, ToJSON, Value (..), eitherDecode, toJSON)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Lazy.Char8 as LChar8+import Data.Foldable (toList)+import Data.List (isInfixOf, sort)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust, mapMaybe)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Client.Internal (makeConnection)+import qualified Network.HTTP.Types as HTTP+import qualified Network.Socket as Socket+import qualified Network.Socket.ByteString as SocketBS+import System.FilePath ((</>))+import System.IO (Handle, IOMode (ReadMode), hClose, hPutStr, withFile)+import System.IO.Temp (withSystemTempFile)+import System.Timeout (timeout)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)++import qualified Salmon.Actions.Help as Help+import qualified Test.ServeApi as Api+import qualified Salmon.Actions.Serve as Serve+import Salmon.Actions.Serve (Attributed (..), Convergence (..), Direction (..), NodeState (..), World (..))+import qualified Salmon.Actions.Serve.Http as Http+import Salmon.Builtin.Extension (Track', deps, down, help, nodeps, op, ref, up)+import Salmon.Op.Configure (Configure (..))+import Salmon.Op.Ref (Ref, mkRef)+import Salmon.Op.Track (Track (..))+import Salmon.Reporter (contramap)+import qualified Salmon.Reporter.Tagged as Tagged++import Test.Harness (capture, privatePipe, withTempDir)++tests :: TestTree+tests =+    testGroup+        "Salmon.Actions.Serve.Http"+        [ testCase "/dag is what printDagTree prints, node for node and edge for edge" dagMatchesPrintDagTree+        , testCase "/dag is populated from the first declaration on, before any pass" dagBeforeAnyPass+        , testCase "a retired seed's nodes stay in /dag wanted down until they are gone" retiredNodesAreDown+        , testCase "sync, async and stdin leave the same world; sync answers with the line's reports" syncAndAsyncAgree+        , testCase "a text line, {\"line\"} and {\"verb\", \"seed\"} bodies give the same reports and world" bodyFormsAgree+        , testCase "a malformed JSON command body is a 400, not a command" badStructuredBodies+        , testCase "a structured body renders to a line that tokenizes back to its seed" structuredRoundTrips+        , testCase "reads answer while the loop is inside a long up" readsDuringLongUp+        , testCase "/help/seed, /history and the error responses" theOtherReads+        , testCase "GET /openapi.json is the embedded document, and every route it documents answers" openApiServed+        , testCase "/dag carries the mode the loop's accessor answers at the moment of the read" dagCarriesMode+        , testCase "GET / is the web UI's page, /ui/* its files, and a missing one is 404" theWebUi+        , testCase "two seeds colliding on one ref: /dag carries the kept and replaced pair while both are wanted" conflictingPairOnDag+        ]++-------------------------------------------------------------------------------+-- the thing served: counters per node name, plus one node that blocks++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)++-- | The name of the node whose @up@ waits to be let go.+slowName :: String+slowName = "slow"++data Slow = Slow+    { slowStarted :: MVar ()+    -- ^ filled when the slow node's @up@ is entered+    , slowGate :: MVar ()+    -- ^ filled by the test to let it return+    }++spyProgram :: Slow -> IORef (Map String Int) -> IORef (Map String Int) -> Track' Spec+spyProgram slow upsRef downsRef = Track $ \spec ->+    op "http-root" (deps (fmap nodeOp spec.specNames)) $ \actions ->+        actions{ref = mkRef "http-root" spec.specNames, help = "the root of " <> Text.pack (unwords spec.specNames)}+  where+    -- @NAME:VARIANT@ is the same node (ref keyed on @NAME@) described+    -- differently (help carries the whole word): two seeds colliding on+    -- one ref, for the /dag conflict case+    nodeOp name =+        op "http-node" nodeps $ \actions ->+            actions+                { ref = mkRef "http-node" (takeWhile (/= ':') name)+                , help = "node " <> Text.pack name+                , up =+                    if name == slowName+                        then putMVar (slowStarted slow) () >> takeMVar (slowGate slow)+                        else bump upsRef name+                , down = bump downsRef name+                }+    bump r name = atomicModifyIORef' r (\m -> (Map.insertWith (+) name 1 m, ()))++-------------------------------------------------------------------------------+-- a running loop with an HTTP server++data Running = Running+    { runningStdin :: Handle+    -- ^ the writing end of the loop's standard input; closing it ends the loop+    , runningWorld :: MVar (World Spec Spec)+    , runningOwn :: IO [Tagged.Tagged]+    -- ^ everything the loop's own reporter saw+    , runningUps :: IORef (Map String Int)+    , runningDowns :: IORef (Map String Int)+    , runningSlow :: Slow+    , runningManager :: HTTP.Manager+    }++seedHelp :: Text+seedHelp = "usage: config NAME...\n"++{- | Start the loop on a temp socket with a pipe for standard input, hand+it to the test, and make sure it has ended before the temp dir goes.+-}+withRunning :: (Running -> IO a) -> IO a+withRunning = withRunningMode (pure Serve.Interactive)++-- | 'withRunning' with the server's mode accessor chosen by the test.+withRunningMode :: IO Serve.Mode -> (Running -> IO a) -> IO a+withRunningMode mode act =+    withTempDir $ \dir -> do+        let path = dir </> "serve.http"+        (stdinR, stdinW) <- privatePipe+        worldVar <- newEmptyMVar+        (own, seen) <- capture+        upsRef <- newIORef Map.empty+        downsRef <- newIORef Map.empty+        slow <- Slow <$> newEmptyMVar <*> newEmptyMVar+        Http.withHttpServer path seedHelp mode $ \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 slow upsRef downsRef)+                        Nothing+                        [Serve.stdinProducer stdinR, Http.serverProducer server]+                putMVar worldVar w+            manager <- unixManager path+            let running = Running stdinW worldVar seen upsRef downsRef slow manager+            r <- act running+            _ <- try (hClose stdinW) :: IO (Either IOError ())+            _ <- awaitWorld running+            pure r++awaitWorld :: Running -> IO (World Spec Spec)+awaitWorld running = do+    mw <- timeout (10 * 1000000) (takeMVar (runningWorld running))+    case mw of+        Nothing -> assertFailure "the loop did not end"+        Just w -> do+            putMVar (runningWorld running) w+            pure w++-- | End the loop through standard input and hand back the world it left.+finish :: Running -> IO (World Spec Spec)+finish running = do+    hClose (runningStdin running)+    awaitWorld running++-------------------------------------------------------------------------------+-- an http client over the unix socket++unixManager :: FilePath -> IO HTTP.Manager+unixManager path =+    HTTP.newManager+        HTTP.defaultManagerSettings+            { HTTP.managerRawConnection = pure $ \_ _ _ -> do+                sock <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol+                Socket.connect sock (Socket.SockAddrUnix path)+                makeConnection (SocketBS.recv sock 4096) (SocketBS.sendAll sock) (Socket.close sock)+            }++-- | A GET, decoded; the status and the body.+get :: Running -> String -> IO (Int, Value)+get running route = do+    req <- HTTP.parseRequest ("http://salmon" <> route)+    exchange running req++-- | A text @POST \/command@, decoded.+post :: Running -> String -> String -> IO (Int, Value)+post running route line = do+    req0 <- HTTP.parseRequest ("http://salmon" <> route)+    let req =+            req0+                { HTTP.method = "POST"+                , HTTP.requestHeaders = [(HTTP.hContentType, "text/plain")]+                , HTTP.requestBody = HTTP.RequestBodyLBS (LChar8.pack line)+                }+    exchange running req++-- | A @POST \/command@ with a given content type and body, decoded.+postAs :: Running -> String -> String -> IO (Int, Value)+postAs running ctype body = do+    req0 <- HTTP.parseRequest "http://salmon/command"+    let req =+            req0+                { HTTP.method = "POST"+                , HTTP.requestHeaders = [(HTTP.hContentType, LChar8.toStrict (LChar8.pack ctype))]+                , HTTP.requestBody = HTTP.RequestBodyLBS (LChar8.pack body)+                }+    exchange running req++-- | A GET left undecoded: the status, the content type, and the body.+getRaw :: Running -> String -> IO (Int, Maybe LChar8.ByteString, LChar8.ByteString)+getRaw running route = do+    req <- HTTP.parseRequest ("http://salmon" <> route)+    r <- timeout (10 * 1000000) (HTTP.httpLbs req (runningManager running))+    case r of+        Nothing -> assertFailure ("no answer within 10s to " <> route)+        Just resp ->+            pure+                ( HTTP.statusCode (HTTP.responseStatus resp)+                , LChar8.fromStrict <$> lookup HTTP.hContentType (HTTP.responseHeaders resp)+                , HTTP.responseBody resp+                )++exchange :: Running -> HTTP.Request -> IO (Int, Value)+exchange running req = do+    r <- timeout (10 * 1000000) (HTTP.httpLbs req (runningManager running))+    case r of+        Nothing -> assertFailure ("no answer within 10s to " <> show (HTTP.path req))+        Just resp ->+            case eitherDecode (HTTP.responseBody resp) of+                Left err -> assertFailure ("not JSON: " <> err <> ": " <> LChar8.unpack (HTTP.responseBody resp))+                Right v -> do+                    let status = HTTP.statusCode (HTTP.responseStatus resp)+                    -- every JSON answer this spec gets is also checked against+                    -- the schema the OpenAPI document gives that operation and status+                    assertEqual+                        ("schema errors in " <> show (HTTP.method req) <> " " <> show (HTTP.path req) <> " -> " <> show status)+                        []+                        (Api.validateResponse (HTTP.method req) (HTTP.path req) status v)+                    pure (status, v)++-- | A synchronous command: the kinds of the reports it answered with.+sync :: Running -> String -> IO [Text]+sync running line = do+    (code, v) <- post running "/command" line+    assertEqual ("status of sync " <> line) 200 code+    case v of+        Array xs -> pure (fmap kindOf (toList xs))+        _ -> assertFailure ("sync answer is not an array: " <> show v)++-- | An asynchronous command: the sequence number it was queued at.+async :: Running -> String -> IO Integer+async running line = do+    (code, v) <- post running "/command?async" line+    assertEqual ("status of async " <> line) 202 code+    case v of+        Object o | Just (Number n) <- KeyMap.lookup "seq" o -> pure (truncate n)+        _ -> assertFailure ("async answer has no seq: " <> show v)++-------------------------------------------------------------------------------+-- reading the JSON++kindOf :: Value -> Text+kindOf v = maybe "<no kind>" id (textAt ["kind"] v)++textAt :: [Text] -> Value -> Maybe Text+textAt [] (String t) = Just t+textAt (k : ks) (Object o) = KeyMap.lookup (Key.fromText k) o >>= textAt ks+textAt _ _ = Nothing++field :: Text -> Value -> Maybe Value+field k (Object o) = KeyMap.lookup (Key.fromText k) o+field _ _ = Nothing++withoutSeq :: Value -> Value+withoutSeq (Object o) = Object (KeyMap.delete "seq" o)+withoutSeq v = v++arrayOf :: Value -> [Value]+arrayOf (Array xs) = toList xs+arrayOf _ = []++-- | The @nodes@ of a @\/dag@ answer.+dagNodes :: Value -> IO [Value]+dagNodes v = case field "nodes" v of+    Just (Array xs) -> pure (toList xs)+    _ -> assertFailure ("/dag without nodes: " <> show v)++-- | The lines 'Help.printDagTree' would print, rebuilt from a @\/dag@ answer.+dagLinesOf :: [Value] -> [Text]+dagLinesOf nodes = concatMap nodeLines nodes+  where+    shorthandByRef :: Map Text Text+    shorthandByRef = Map.fromList (mapMaybe (\n -> (,) <$> textAt ["ref", "full"] n <*> textAt ["shorthand"] n) nodes)+    nodeLines n =+        let sh = orNothing (textAt ["shorthand"] n)+            full = orNothing (textAt ["ref", "full"] n)+            hlp = orNothing (textAt ["help"] n)+            depLine d =+                let dref = orNothing (textAt ["full"] d)+                 in "  <- " <> Map.findWithDefault dref dref shorthandByRef+         in (sh <> " (" <> full <> ") " <> hlp) : fmap depLine (maybe [] arrayOf (field "dependencies" n))+    orNothing = maybe "<missing>" id++-------------------------------------------------------------------------------++dagMatchesPrintDagTree :: IO ()+dagMatchesPrintDagTree =+    withRunning $ \running -> do+        _ <- sync running "supervise off"+        _ <- sync running "up n1 n2"+        _ <- sync running "up n2 n3"+        (code, v) <- get running "/dag"+        assertEqual "status" 200 code+        nodes <- dagNodes v+        w <- finish running+        let dag = Serve.worldDag w+        assertEqual "the same lines printDagTree prints" (Help.dagLines dag) (dagLinesOf nodes)+        assertEqual "one node per world node" (Map.size w.worldNodes) (length nodes)+        -- edges in both directions agree: every dependency edge is a+        -- dependant edge on the other node, and vice versa+        let refOf n = orMissing (textAt ["ref", "full"] n)+            edgesOut = Set.fromList [(orMissing (textAt ["full"] d), refOf n) | n <- nodes, d <- maybe [] arrayOf (field "dependencies" n)]+            edgesIn = Set.fromList [(refOf n, orMissing (textAt ["full"] d)) | n <- nodes, d <- maybe [] arrayOf (field "dependants" n)]+        assertEqual "dependants are the transpose of dependencies" edgesOut edgesIn+        assertBool "there are edges" (not (Set.null edgesOut))+        -- and every node carries the loop's state and the representative's fields+        forM_ nodes $ \n -> do+            assertEqual ("direction of " <> show (refOf n)) (Just "up") (textAt ["direction"] n)+            assertEqual ("convergence of " <> show (refOf n)) (Just "converged") (textAt ["convergence"] n)+            assertBool "notes present" (field "notes" n /= Nothing)+            assertBool "dynamics present" (field "dynamics" n /= Nothing)+            assertBool "status present (null: never tended)" (field "status" n /= Nothing)+  where+    orMissing = maybe "<missing>" id++{- | @up n1:a@ then @up n1:b@ describe one ref two ways. The second+declaration is reported @conflicting@ and, from then on, @\/dag@\'s node for+it carries the pair — @kept@ being what the magma holds, @replaced@ what it+beat — where every other node carries none. Re-declaring the winner keeps the+pair (the loser is still wanted); retiring the loser and converging clears+it, since nothing wants that version any more.+-}+conflictingPairOnDag :: IO ()+conflictingPairOnDag =+    withRunning $ \running -> do+        _ <- sync running "supervise off"+        _ <- sync running "autoconverge off"+        first <- sync running "up n1:a n2"+        assertBool ("no conflict on a first declaration: " <> show first) ("conflicting" `notElem` first)+        second <- sync running "up n1:b"+        assertBool ("the collision is reported: " <> show second) ("conflicting" `elem` second)+        (_, v) <- get running "/dag"+        nodes <- dagNodes v+        let n1 = filter (\n -> textAt ["help"] n == Just "node n1:b") nodes+        assertEqual "the magma holds the last writer" 1 (length n1)+        forM_ n1 $ \n -> do+            assertEqual "kept is the winner" (Just "node n1:b") (textAt ["conflict", "kept", "help"] n)+            assertEqual "replaced is the loser" (Just "node n1:a") (textAt ["conflict", "replaced", "help"] n)+            assertEqual "kept carries the shorthand" (Just "http-node") (textAt ["conflict", "kept", "shorthand"] n)+        forM_ (filter (\n -> textAt ["help"] n /= Just "node n1:b") nodes) $ \n ->+            assertEqual ("no conflict on " <> show (textAt ["help"] n)) Nothing (field "conflict" n)+        -- the winner re-declared: nothing changed, the loser is still wanted+        again <- sync running "up n1:b"+        assertBool ("an unchanged re-declaration is not a new collision: " <> show again) ("conflicting" `notElem` again)+        (_, v') <- get running "/dag"+        nodes' <- dagNodes v'+        assertEqual "the pair stands" [Just "node n1:a"] [textAt ["conflict", "replaced", "help"] n | n <- nodes', textAt ["help"] n == Just "node n1:b"]+        -- the loser retired and gone: nobody wants its version, the pair goes+        _ <- sync running "down n1:a n2"+        _ <- sync running "converge"+        _ <- sync running "up n1:b"+        (_, v'') <- get running "/dag"+        nodes'' <- dagNodes v''+        forM_ nodes'' $ \n -> assertEqual ("no conflict left on " <> show (textAt ["help"] n)) Nothing (field "conflict" n)++dagBeforeAnyPass :: IO ()+dagBeforeAnyPass =+    withRunning $ \running -> do+        _ <- sync running "supervise off"+        _ <- sync running "autoconverge off"+        declared <- sync running "up n1 n2"+        assertEqual "no pass ran" ["declared"] declared+        (_, v) <- get running "/dag"+        nodes <- dagNodes v+        assertEqual "three nodes, no pass" 3 (length nodes)+        forM_ nodes $ \n -> do+            assertEqual "pending" (Just "pending") (textAt ["convergence"] n)+            assertEqual "up" (Just "up") (textAt ["direction"] n)+        ups <- readIORef (runningUps running)+        assertEqual "nothing was applied" Map.empty ups+        converged <- sync running "converge"+        assertBool ("the pass ran: " <> show converged) ("converge-stop" `elem` converged)+        (_, v') <- get running "/dag"+        nodes' <- dagNodes v'+        forM_ nodes' $ \n -> assertEqual "converged" (Just "converged") (textAt ["convergence"] n)++retiredNodesAreDown :: IO ()+retiredNodesAreDown =+    withRunning $ \running -> do+        _ <- sync running "supervise off"+        _ <- sync running "up n1 n2"+        _ <- sync running "autoconverge off"+        _ <- sync running "down n1 n2"+        (_, v) <- get running "/dag"+        nodes <- dagNodes v+        assertEqual "still there, on their way down" 3 (length nodes)+        forM_ nodes $ \n -> do+            assertEqual "down" (Just "down") (textAt ["direction"] n)+            assertEqual "pending" (Just "pending") (textAt ["convergence"] n)+        -- the edges survive the retraction: they are what orders the teardown+        assertBool "edges kept" (any (\n -> not (null (maybe [] arrayOf (field "dependencies" n)))) nodes)+        _ <- sync running "converge"+        (_, v') <- get running "/dag"+        nodes' <- dagNodes v'+        assertEqual "gone once down" 0 (length nodes')+        downs <- readIORef (runningDowns running)+        assertEqual "both nodes went down" (Map.fromList [("n1", 1), ("n2", 1)]) downs++syncAndAsyncAgree :: IO ()+syncAndAsyncAgree = do+    (stdinUps, stdinDowns, stdinWorld, stdinKinds) <- runScript script+    -- synchronously: each line answered with its reports+    (syncUps, syncDowns, syncWorld, syncKinds) <- withRunning $ \running -> do+        kinds <- concat <$> forM script (sync running)+        w <- finish running+        (,,,) <$> readIORef (runningUps running) <*> readIORef (runningDowns running) <*> pure w <*> pure kinds+    -- as a multiset: a convergence pass is concurrent, so two nodes ready+    -- at the same time report in whichever order their threads ran, on+    -- stdin and over HTTP alike+    assertEqual "sync answers with exactly the reports the lines produced on stdin" (sort stdinKinds) (sort syncKinds)+    assertEqual "the first line's reports come first" (take 2 stdinKinds) (take 2 syncKinds)+    -- asynchronously: queued, then a sync `status` that is handled after them all+    (asyncUps, asyncDowns, asyncWorld) <- withRunning $ \running -> do+        seqs <- forM script (async running)+        assertBool ("sequence numbers are assigned at enqueue, in order: " <> show seqs) (and (zipWith (<) seqs (drop 1 seqs)))+        _ <- sync running "status"+        own <- runningOwn running+        let handled = length (filter isConvergeStop own)+        assertEqual "every declaring line was handled before the status" (length (filter isDeclaring script)) handled+        w <- finish running+        (,,) <$> readIORef (runningUps running) <*> readIORef (runningDowns running) <*> pure w+    assertEqual "ups (sync)" stdinUps syncUps+    assertEqual "downs (sync)" stdinDowns syncDowns+    assertEqual "world (sync)" (worldShape stdinWorld) (worldShape syncWorld)+    assertEqual "ups (async)" stdinUps asyncUps+    assertEqual "downs (async)" stdinDowns asyncDowns+    assertEqual "world (async)" (worldShape stdinWorld) (worldShape asyncWorld)+  where+    script = ["supervise off", "up n1", "up n1 n2", "down n1", "history"]+    isDeclaring l = any (`Text.isPrefixOf` Text.pack l) ["up ", "down "]+    isConvergeStop t = case t of+        Tagged.FromServe Serve.ConvergeStop{} -> True+        _ -> False++-- | The same script sent as text, as @{"line"}@ and as @{"verb", "seed"}@.+bodyFormsAgree :: IO ()+bodyFormsAgree = do+    results <- forM forms $ \(name, encodeBody) -> withRunning $ \running -> do+        kinds <- fmap concat $ forM script $ \l -> do+            (code, v) <- uncurry (postAs running) (encodeBody l)+            assertEqual ("status of " <> name <> ": " <> l) 200 code+            pure (maybe [] (fmap kindOf) (arrayMaybe v))+        w <- finish running+        ups <- readIORef (runningUps running)+        pure (sort kinds, ups, worldShape w)+    case results of+        (r0 : rest) -> forM_ rest (assertEqual "every body form gives the text form's reports, ups and world" r0)+        [] -> pure ()+  where+    script = ["supervise off", "up n1", "up n1 n2", "down n1", "history"]+    forms =+        [ ("text", \l -> ("text/plain", l))+        , ("line", \l -> ("application/json", jsonObject [("line", jsonString l)]))+        , ("verb+seed", \l -> let (v : seed) = words l in ("application/json", jsonObject [("verb", jsonString v), ("seed", "[" <> commaSep (fmap jsonString seed) <> "]")]))+        ]+    jsonString x = show x+    jsonObject kvs = "{" <> commaSep [show k <> ":" <> v | (k, v) <- kvs] <> "}"+    commaSep = foldr1' (\a b -> a <> "," <> b)+    foldr1' _ [] = ""+    foldr1' f xs = foldr1 f xs+    arrayMaybe v = case v of Array xs -> Just (toList xs); _ -> Nothing++badStructuredBodies :: IO ()+badStructuredBodies =+    withRunning $ \running -> do+        forM_+            [ ("both forms", "{\"line\": \"up n1\", \"verb\": \"up\"}")+            , ("neither form", "{}")+            , ("a seed with a line", "{\"line\": \"up n1\", \"seed\": [\"n1\"]}")+            , ("a seed that is not a list of words", "{\"verb\": \"up\", \"seed\": 3}")+            , ("a newline in a word", "{\"verb\": \"up\", \"seed\": [\"a\\nhistory\"]}")+            ]+            $ \(why, body) -> do+                (code, _) <- postAs running "application/json" body+                assertEqual ("400 for " <> why) 400 code+        -- and nothing was declared by any of them+        (_, hist) <- get running "/history"+        assertEqual "no declaration was made" 0 (length (maybe [] arrayOf (field "seeds" hist)))++structuredRoundTrips :: IO ()+structuredRoundTrips =+    forM_ seeds $ \seed ->+        assertEqual ("the seed " <> show seed) (Right (Serve.Declare Serve.Add seed)) (Serve.parseServeCommand (Http.renderStructured "up" seed))+  where+    seeds = [["a", "b"], ["with space", "x"], ["it's", "say \"hi\""], ["back\\slash"], [""], []]++readsDuringLongUp :: IO ()+readsDuringLongUp =+    withRunning $ \running -> do+        _ <- sync running "supervise off"+        _ <- sync running "up n1"+        seqNo <- async running ("up " <> slowName)+        assertBool "a later number than the earlier commands'" (seqNo >= 2)+        -- the loop is now inside the slow node's up+        started <- timeout (10 * 1000000) (takeMVar (slowStarted (runningSlow running)))+        assertEqual "the slow up was entered" (Just ()) started+        -- and reads answer without waiting for it+        (code, v) <- get running "/status"+        assertEqual "status answers" 200 code+        let nodes = maybe [] arrayOf (field "nodes" v)+        assertEqual "the earlier seed's nodes plus the slow seed's" 4 (length nodes)+        let slowNode = [n | n <- nodes, textAt ["help"] n == Just ("node " <> Text.pack slowName)]+        assertEqual "the slow node is still pending" [Just "pending"] (fmap (textAt ["convergence"]) slowNode)+        (code', v') <- get running "/dag"+        assertEqual "dag answers" 200 code'+        nodes' <- dagNodes v'+        assertEqual "dag has the same nodes" 4 (length nodes')+        (code'', _) <- get running "/history"+        assertEqual "history answers" 200 code''+        -- let it go, and make sure the loop is past it before ending+        putMVar (slowGate (runningSlow running)) ()+        _ <- sync running "status"+        (_, after) <- get running "/status"+        let slowAfter = [n | n <- maybe [] arrayOf (field "nodes" after), textAt ["help"] n == Just ("node " <> Text.pack slowName)]+        assertEqual "the slow node converged once let go" [Just "converged"] (fmap (textAt ["convergence"]) slowAfter)++theOtherReads :: IO ()+theOtherReads =+    withRunning $ \running -> do+        _ <- sync running "supervise off"+        _ <- sync running "up n1"+        _ <- sync running "down n1"+        (code, h) <- get running "/help/seed"+        assertEqual "help status" 200 code+        assertEqual "the seed help is the text the binary supplied" (Just seedHelp) (textAt ["seed"] h)+        assertBool "the command reference is there" (not (null (maybe [] arrayOf (field "commands" h))))+        (hcode, hist) <- get running "/history"+        assertEqual "history status" 200 hcode+        assertEqual "kind" (Just "history") (textAt ["kind"] hist)+        assertEqual "two declarations" 2 (length (maybe [] arrayOf (field "seeds" hist)))+        assertEqual "nothing elided" (Just (Number 0)) (field "elided" hist)+        (scode, st) <- get running "/status"+        assertEqual "status status" 200 scode+        assertEqual "kind" (Just "status") (textAt ["kind"] st)+        -- and the same object the loop's own `status` produces, plus the+        -- event stream's cursor (milestone 4)+        assertBool "the read carries seq" (isJust (field "seq" st))+        _ <- sync running "status"+        own <- runningOwn running+        let fromLoop = [toJSON t | t@(Tagged.FromServe Serve.StatusReport{}) <- own]+        assertEqual "the same object --json prints" [withoutSeq st] fromLoop+        (nf, _) <- get running "/nope"+        assertEqual "unknown route" 404 nf+        (mna, _) <- post running "/dag" "status"+        assertEqual "wrong method" 405 mna+        (bad, _) <- post running "/command" "status\nhistory"+        assertEqual "two lines in one body" 400 bad++theWebUi :: IO ()+theWebUi =+    withRunning $ \running -> do+        (code, ctype, body) <- getRaw running "/"+        assertEqual "the page's status" 200 code+        assertEqual "the page's content type" (Just "text/html; charset=utf-8") ctype+        assertBool "the page is HTML" ("<!doctype html>" `LChar8.isPrefixOf` body)+        assertBool "the page loads the script" ("ui/ui.js" `isInfixOf` LChar8.unpack body)+        (jcode, jtype, js) <- getRaw running "/ui/ui.js"+        assertEqual "the script's status" 200 jcode+        assertEqual "the script's content type" (Just "text/javascript; charset=utf-8") jtype+        assertBool "the script subscribes from the snapshot's seq" ("events?since=" `isInfixOf` LChar8.unpack js)+        assertBool "the script's writes are asynchronous commands" ("command?async" `isInfixOf` LChar8.unpack js)+        assertBool "the script's seed form reads the seed's help" ("help/seed" `isInfixOf` LChar8.unpack js)+        assertBool "the script never sends quit" (not ("post(\"quit\"" `isInfixOf` LChar8.unpack js) && not ("data-line=\"quit\"" `isInfixOf` LChar8.unpack body))+        (ccode, ctype', _) <- getRaw running "/ui/ui.css"+        assertEqual "the stylesheet's status" 200 ccode+        assertEqual "the stylesheet's content type" (Just "text/css; charset=utf-8") ctype'+        (missing, _) <- get running "/ui/missing"+        assertEqual "a file outside the embedded set" 404 missing+        (mna, _) <- post running "/" "status"+        assertEqual "the page takes no POST" 405 mna+        _ <- finish running+        pure ()++-------------------------------------------------------------------------------++-- | The same script on one stdin, for the comparison: side effects, world,+-- and the kinds of every report the loop produced for its lines.+runScript :: [String] -> IO (Map String Int, Map String Int, World Spec Spec, [Text])+runScript script = do+    upsRef <- newIORef Map.empty+    downsRef <- newIORef Map.empty+    slow <- Slow <$> newEmptyMVar <*> newEmptyMVar+    (own, seen) <- capture+    w <- withScript script $ \h ->+        Serve.serveWith [] Nothing True (Tagged.serveStream own) (Tagged.updownStream own) parseSpec (Configure pure) (spyProgram slow upsRef downsRef) h+    reports <- seen+    let kinds = [k | t <- reports, let k = kindOf (toJSON t), k `notElem` ["started", "stopped"]]+    (,,,) <$> readIORef upsRef <*> readIORef downsRef <*> pure w <*> pure kinds++withScript :: [String] -> (Handle -> IO a) -> IO a+withScript ls act =+    withSystemTempFile "salmon-serve-http-script" $ \path h -> do+        hPutStr h (unlines ls)+        hClose h+        withFile path ReadMode act++-- | The comparable part of a 'World', as 'Test.ServeSocketSpec' takes it.+worldShape :: World Spec Spec -> (Map Ref (Direction, Convergence), Set.Set Ref, Int, Int, Int)+worldShape w =+    ( Map.map (\st -> (st.nodeDirection, st.nodeConvergence)) w.worldNodes+    , Map.keysSet w.worldMagma+    , Map.size w.worldLedger+    , length w.worldEpochs+    , length w.worldLog+    )+++{- | The @mode@ on @\/dag@ is read from the server's accessor at the moment+of the read, not fixed when the server starts: the same accessor is what+@\/status@ opens with, and the loop's mode moves (@replay@ turns to+@following@ at the first full round, "Salmon.Actions.Follow").+-}+dagCarriesMode :: IO ()+dagCarriesMode = do+    modeRef <- newIORef Serve.Replay+    withRunningMode (readIORef modeRef) $ \running -> do+        _ <- sync running "supervise off"+        _ <- sync running "up n1"+        (code, v) <- get running "/dag"+        assertEqual "status" 200 code+        assertEqual "the mode the accessor answered" (Just "replay") (textAt ["mode"] v)+        (_, st) <- get running "/status"+        assertEqual "/status agrees" (Just "replay") (textAt ["mode"] st)+        atomicModifyIORef' modeRef (const (Serve.Following, ()))+        (_, v') <- get running "/dag"+        assertEqual "the mode after the accessor moved" (Just "following") (textAt ["mode"] v')+        (_, st') <- get running "/status"+        assertEqual "/status moved with it" (Just "following") (textAt ["mode"] st')+        _ <- finish running+        pure ()++{- | @GET \/openapi.json@ answers the very bytes the binary embeds, and every+operation the document describes is one the loop answers (anything but the+@404@ of an unknown route). The other direction — a route in the code the+document does not describe — is "Test.ServeApiSpec"'s source comparison.+-}+openApiServed :: IO ()+openApiServed =+    withRunning $ \running -> do+        (code, ctype, body) <- getRaw running "/openapi.json"+        assertEqual "status" 200 code+        assertEqual "content type" (Just "application/json") ctype+        assertEqual "the embedded document" (LChar8.fromStrict Http.openApiDocument) body+        forM_ Api.unixRoutes $ \(method, template) -> do+            let route = Text.unpack (Text.replace "{file}" "ui.js" template)+            req0 <- HTTP.parseRequest ("http://salmon" <> route)+            let req = req0{HTTP.method = LChar8.toStrict (LChar8.pack (Text.unpack method))}+            -- the status line only: /events never ends+            status <- HTTP.withResponse req (runningManager running) (pure . HTTP.statusCode . HTTP.responseStatus)+            assertBool (Text.unpack method <> " " <> route <> " is documented but answers 404") (status /= 404)
+ test/Test/ServeModelSpec.hs view
@@ -0,0 +1,455 @@+{-# LANGUAGE DeriveGeneric #-}++{- | Property-based coverage for "Salmon.Actions.Serve", per+@specs/serve-property-testing.md@: generate a random sequence of+declare\/converge commands, fold it through a small independent shadow model+of "which seeds are live, which nodes are up", and check the real+'Serve.serveWith' loop (driven in piped-script mode, exactly as+'Test.ServeSpec' drives it) agrees with the model both in its final+'Serve.World' and in exactly how many times each node's @up@\/@down@ ran.++Deliberately scoped to v1 per the spec: no @autoconverge@\/@force@\/@Rewrite@+commands (those need real idle time or batching, and stay example-based in+'Test.ServeSpec'), and every generated node's @up@\/@down@ always succeeds —+this suite is about the bookkeeping (invariants 1, 2, 3, 6), not about+failure/retry, which 'Test.ServeSpec' already covers by hand.+-}+module Test.ServeModelSpec (tests) where++import Control.Concurrent.STM (TChan, TVar, atomically, modifyTVar', newTVarIO, readTVar, retry, writeTChan)+import Data.Aeson (FromJSON, ToJSON)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.List (foldl')+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import qualified Data.Set as Set+import Data.Set (Set)+import Data.Text (Text)+import GHC.Generics (Generic)+import System.IO (Handle, IOMode (ReadMode), hClose, hPutStr, withFile)+import System.IO.Temp (withSystemTempFile)+import Test.QuickCheck (Gen, Property, choose, conjoin, counterexample, forAllShrink, frequency, ioProperty, shrinkList, sized, vectorOf)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import qualified Salmon.Actions.Serve as Serve+import Salmon.Actions.Serve (Convergence (..), Direction (..), Line (..), NodeState (..), Origin (..), Producer (..), World (..))+import Salmon.Builtin.Extension (Track', deps, nodeps, op, ref, up, down)+import Salmon.Op.Configure (Configure (..))+import Salmon.Op.Ref (Ref, mkRef)+import Salmon.Op.Track (Track (..))+import Salmon.Reporter (silent)++tests :: TestTree+tests =+    testGroup+        "Salmon.Actions.Serve (property-based)"+        [ testProperty "convergence matches an independent shadow model" prop_convergesLikeModel+        , testProperty "clear settles the world to empty, whatever came before" prop_clearSettlesToEmpty+        , testGroup+            "input producers"+            [ testProperty "two producers taking turns agree with the one-script run" prop_producersTakingTurnsAgree+            ]+        ]++-------------------------------------------------------------------------------+-- The thing being served: a fixed, small alphabet of node names. Real seeds+-- overlap on purpose, mirroring 'Test.ServeSpec''s own fixture, so+-- shared-node teardown (invariant 3) actually gets exercised.++type NodeName = String++nodeNames :: [NodeName]+nodeNames = ["n1", "n2", "n3"]++-- | Three fixed seeds sharing nodes pairwise: (n1) / (n1,n2) / (n2,n3).+seedNodeNames :: [[NodeName]]+seedNodeNames = [["n1"], ["n1", "n2"], ["n2", "n3"]]++seedCount :: Int+seedCount = length seedNodeNames++newtype Spec = Spec {specNames :: [NodeName]}+    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)++-- | A stub 'Track'' whose nodes touch nothing but two 'IORef' counters —+-- same shape as 'Test.ServeSpec''s @neverRuns@/@watched@, generalized to one+-- counter per node name rather than one global/two hand-picked ones.+spyProgram :: IORef (Map NodeName Int) -> IORef (Map NodeName Int) -> Track' Spec+spyProgram upsRef downsRef = Track $ \spec ->+    op "model-root" (deps (fmap nodeOp spec.specNames)) $ \actions ->+        actions{ref = mkRef "model-root" spec.specNames}+  where+    nodeOp name =+        op "model-node" nodeps $ \actions ->+            actions+                { ref = nodeRef name+                , up = bump upsRef name+                , down = bump downsRef name+                }+    bump r name = atomicModifyIORef' r (\m -> (Map.insertWith (+) name 1 m, ()))++-- | The 'Ref' a node named @name@ is given — computed the same way+-- 'spyProgram' computes it, so the test can look a node up in 'worldNodes'+-- without needing the real system to hand identities back out.+nodeRef :: NodeName -> Ref+nodeRef = mkRef "model-node"++-------------------------------------------------------------------------------+-- Commands and their shadow model.++data ServeCommand+    = CmdUp Int+    | CmdDown Int+    | CmdOnly Int+    | CmdClear+    | CmdConverge+    deriving (Show, Eq)++renderCommand :: ServeCommand -> String+renderCommand (CmdUp i) = "up " <> unwords (seedNodeNames !! i)+renderCommand (CmdDown i) = "down " <> unwords (seedNodeNames !! i)+renderCommand (CmdOnly i) = "only " <> unwords (seedNodeNames !! i)+renderCommand CmdClear = "clear"+renderCommand CmdConverge = "converge"++genCommand :: Gen ServeCommand+genCommand =+    frequency+        [ (3, CmdUp <$> seedIx)+        , (3, CmdDown <$> seedIx)+        , (2, CmdOnly <$> seedIx)+        , (1, pure CmdClear)+        , (2, pure CmdConverge)+        ]+  where+    seedIx = choose (0, seedCount - 1)++genCommands :: Gen [ServeCommand]+genCommands = sized $ \n -> do+    len <- choose (1, max 1 (min 30 (n + 5)))+    vectorOf len genCommand++shrinkCommand :: ServeCommand -> [ServeCommand]+shrinkCommand (CmdUp i) = [CmdUp i' | i' <- shrinkIx i]+shrinkCommand (CmdDown i) = [CmdDown i' | i' <- shrinkIx i]+shrinkCommand (CmdOnly i) = CmdUp i : [CmdOnly i' | i' <- shrinkIx i]+shrinkCommand CmdClear = []+shrinkCommand CmdConverge = []++shrinkIx :: Int -> [Int]+shrinkIx 0 = []+shrinkIx _ = [0]++shrinkCommands :: [ServeCommand] -> [[ServeCommand]]+shrinkCommands = shrinkList shrinkCommand++{- | The shadow model: an independent restatement of "which seeds are live,+which nodes 'Serve.worldNodes' currently still holds and in what state, and+how many times each node's up\/down should have fired so far" — written+against the domain (seeds, node names), not against 'Serve.hs''s own types.++Two subtleties below were found empirically (failing runs of this very+property, before this comment existed) rather than reasoned out in advance —+which is exactly the case this suite exists to catch automatically instead+of by hand:++1. A node's own history of having been up is irrelevant to whether @down@+   fires. Every builtin here has no @check@ (the ordinary 'Immaterial'+   default — see @CLAUDE.md@'s "check, not prelim" section), so a node is+   applied whenever it is freshly tracked in a direction, regardless of+   which direction that is. @down n1@ as the very first command ever to+   name @n1@ still calls @down@ once: @n1@ becomes tracked, wanted+   'TurnDown' since no live declaration claims it, starts untracked+   (equivalent to 'Pending'), and gets applied on that basis alone.+2. A node that reaches 'TurnDown'/converged is *dropped* from+   'Serve.worldNodes' (see its own haddock) — so a later declaration that+   names it again finds no trace of it and starts over from scratch, even if+   the direction it ends up wanting is the same 'TurnDown' as before. This+   is why @up n1@, @clear@, @down n1@ calls @down@ *twice*: once when+   @clear@ retires the live seed and @n1@ is torn down and dropped, and+   again when @down n1@ names it afresh — 'modelTracked' models exactly+   this by deleting a node's entry the moment it settles 'TurnDown', so a+   later mention of it has nothing to compare against and is applied+   unconditionally.+-}+data Model = Model+    { modelLive :: !(Set Int)+    -- ^ seeds currently declared up (via @up@\/@only@) and not yet retired.+    -- @down@ never adds to this; only removes, if present.+    , modelTracked :: !(Map NodeName (Direction, Bool))+    -- ^ nodes 'Serve.worldNodes' would currently still hold: each one's+    -- (direction, converged-in-that-direction). Absent entirely once it has+    -- settled 'TurnDown', exactly as 'Serve.worldNodes' drops it.+    , modelUpCount :: !(Map NodeName Int)+    , modelDownCount :: !(Map NodeName Int)+    }++emptyModel :: Model+emptyModel = Model Set.empty Map.empty Map.empty Map.empty++-- | Every command triggers a convergence pass in this suite (autoconverge+-- is left on throughout — see module haddock), so folding a command is:+-- update the live set, (re-)track any node names this command names, then+-- settle every currently-tracked node toward whether it is wanted by the+-- resulting live set.+stepModel :: Model -> ServeCommand -> Model+stepModel m cmd = settle (retrack (applyCommand cmd))+  where+    applyCommand (CmdUp i) = m{modelLive = Set.insert i (modelLive m)}+    applyCommand (CmdDown i) = m{modelLive = Set.delete i (modelLive m)}+    applyCommand (CmdOnly i) = m{modelLive = Set.singleton i}+    applyCommand CmdClear = m{modelLive = Set.empty}+    applyCommand CmdConverge = m++    mentionedNames = case cmd of+        CmdUp i -> seedNodeNames !! i+        CmdDown i -> seedNodeNames !! i+        CmdOnly i -> seedNodeNames !! i+        CmdClear -> []+        CmdConverge -> []++    -- | A declaration naming a node that isn't currently tracked (never+    -- seen, or previously torn down and dropped) puts it back with no+    -- verdict yet — 'settleNode' below treats that exactly like a brand+    -- new node.+    retrack m' = foldl' insertUntracked m' mentionedNames+      where+        insertUntracked acc name+            | Map.member name (modelTracked acc) = acc+            | otherwise = acc{modelTracked = Map.insert name (TurnDown, False) (modelTracked acc)}++    settle m' = foldl' settleNode m' (Map.keys (modelTracked m'))+      where+        desired = Set.fromList (concatMap (seedNodeNames !!) (Set.toList (modelLive m')))++        settleNode m'' name =+            let wantedDir = if Set.member name desired then TurnUp else TurnDown+                apply TurnUp acc =+                    acc+                        { modelTracked = Map.insert name (TurnUp, True) (modelTracked acc)+                        , modelUpCount = Map.insertWith (+) name 1 (modelUpCount acc)+                        }+                apply TurnDown acc =+                    acc+                        { modelTracked = Map.delete name (modelTracked acc) -- settled TurnDown: dropped, like 'Serve.worldNodes'+                        , modelDownCount = Map.insertWith (+) name 1 (modelDownCount acc)+                        }+             in case Map.lookup name (modelTracked m'') of+                    Just (dir, True) | dir == wantedDir -> m'' -- already converged this way: no-op+                    _ -> apply wantedDir m''++runModel :: [ServeCommand] -> Model+runModel = foldl' stepModel emptyModel++-------------------------------------------------------------------------------++prop_convergesLikeModel :: Property+prop_convergesLikeModel =+    forAllShrink genCommands shrinkCommands $ \cmds ->+        counterexample ("script:\n" <> unlines (fmap renderCommand cmds)) $+            runAgainstModel cmds++runAgainstModel :: [ServeCommand] -> Property+runAgainstModel cmds = ioProperty $ do+    upsRef <- newIORef Map.empty+    downsRef <- newIORef Map.empty+    w <- runServe (spyProgram upsRef downsRef) (fmap renderCommand cmds)+    ups <- readIORef upsRef+    downs <- readIORef downsRef+    let m = runModel cmds+    pure $+        counterexample ("model up counts:   " <> show (modelUpCount m)) $+            counterexample ("real  up counts:   " <> show ups) $+                counterexample ("model down counts: " <> show (modelDownCount m)) $+                    counterexample ("real  down counts: " <> show downs) $+                        conjoin+                            [ counterexample "up counts matched the model" (ups == modelUpCount m)+                            , counterexample "down counts matched the model" (downs == modelDownCount m)+                            , counterexample "final World state matched the model" (worldMatchesModel m w)+                            , counterexample "worldEpochs/worldLedger/worldMagma emptiness matched the model" (worldBookkeepingMatchesModel m w)+                            ]++{- | A dedicated property for invariant (6): whatever arbitrary history came+before, @clear@ (itself autoconverging, plus one extra @converge@ for+margin) must drive every one of 'worldNodes'\/'worldEpochs'\/'worldLedger'\/+'worldMagma' empty. Unlike 'prop_convergesLikeModel', which only happens to+land on that state when a random tail ends up there (rare, given+'CmdClear''s low generator weight), this one forces the terminal state+directly, so it shrinks straight to a short "history + clear" script whenever+something leaks.+-}+prop_clearSettlesToEmpty :: Property+prop_clearSettlesToEmpty =+    forAllShrink genCommands shrinkCommands $ \cmds ->+        let cmds' = cmds <> [CmdClear, CmdConverge]+         in counterexample ("script:\n" <> unlines (fmap renderCommand cmds')) $+                ioProperty $ do+                    upsRef <- newIORef Map.empty+                    downsRef <- newIORef Map.empty+                    w <- runServe (spyProgram upsRef downsRef) (fmap renderCommand cmds')+                    pure $+                        conjoin+                            [ counterexample "no node left to manage" (Map.null w.worldNodes)+                            , counterexample "no graph left to walk" (null w.worldEpochs)+                            , counterexample "no contribution left in the ledger" (Map.null w.worldLedger)+                            , counterexample "no representative left in the magma" (Map.null w.worldMagma)+                            ]++{- | 'modelTracked' only ever rests holding 'TurnUp'/'Converged' entries (see+its own haddock: a node settling 'TurnDown' is deleted in the same step), so+a node the model tracks should be present in 'worldNodes' as 'TurnUp'+\/'Converged', and a node the model doesn't track should be entirely absent+— 'Serve.World' drops a node once it has converged 'TurnDown'. Nothing here+ever fails an up\/down, so by the end of the script nothing should be left+mid-flight either side.+-}+worldMatchesModel :: Model -> World Spec Spec -> Bool+worldMatchesModel m w = all checkName nodeNames+  where+    checkName name =+        case (Map.lookup name (modelTracked m), Map.lookup (nodeRef name) w.worldNodes) of+            (Just (TurnUp, True), Just st) -> st.nodeDirection == TurnUp && st.nodeConvergence == Converged+            (Nothing, Nothing) -> True+            _ -> False++{- | Invariant (6), "settling is total", names 'worldEpochs'\/'worldLedger'\/+'worldMagma' explicitly, not just 'worldNodes' — so check them too. The model+has no independent notion of these (it only tracks nodes/seeds), but it does+know when it considers everything settled and gone: no seed live, no node+still tracked. Whenever that holds, the real world's other bookkeeping must+have collected everything as well, or something is leaking behind+'worldNodes''s back.+-}+worldBookkeepingMatchesModel :: Model -> World Spec Spec -> Bool+worldBookkeepingMatchesModel m w+    | Set.null (modelLive m) && Map.null (modelTracked m) =+        null w.worldEpochs && Map.null w.worldLedger && Map.null w.worldMagma+    | otherwise = True++-------------------------------------------------------------------------------+-- Input producers: the same script, typed by two producers taking turns.++{- | The refactor that let 'Serve.serveProducers' take a list of producers+claims no behaviour change: what the loop sees is one inbox, and a line is+a line whoever typed it. So a script split line by line between two+producers — every even line from one, every odd from the other, in lockstep+so that the inbox receives them in script order — must leave the world, and+the up\/down tally, exactly where the one-handle run leaves them.++Lockstep is what keeps this a comparison and not a race: two free-running+producers would interleave differently every run, and a script whose lines+arrive in a different order is a different script. The one thing the+producers /cannot/ control is whether the loop catches the inbox empty+between two turns and starts tending; @supervise off@ heads both scripts so+that a tending machine, which is not what this property is about, never+gets to touch a node either way.++Only the 'Stdin' producer's 'Eof' ends the loop, so it is the one that+sends its 'Eof' last — after the other producer's, which the loop must read+past rather than stop on. That order is the one new decision in the+refactor, and this is the test of it.+-}+prop_producersTakingTurnsAgree :: Property+prop_producersTakingTurnsAgree =+    forAllShrink genCommands shrinkCommands $ \cmds ->+        let script = "supervise off" : fmap renderCommand cmds+         in counterexample ("script:\n" <> unlines script) $+                ioProperty $ do+                    (upsA, downsA, wA) <- tally (\prog -> runServe prog script)+                    (upsB, downsB, wB) <- tally (\prog -> runProducers prog script)+                    pure $+                        counterexample ("one-handle world: " <> show (worldShape wA)) $+                            counterexample ("two-producer world: " <> show (worldShape wB)) $+                                conjoin+                                    [ counterexample "up counts agreed" (upsA == upsB)+                                    , counterexample "down counts agreed" (downsA == downsB)+                                    , counterexample "worlds agreed" (worldShape wA == worldShape wB)+                                    ]+  where+    tally run = do+        upsRef <- newIORef Map.empty+        downsRef <- newIORef Map.empty+        w <- run (spyProgram upsRef downsRef)+        ups <- readIORef upsRef+        downs <- readIORef downsRef+        pure (ups, downs, w)++{- | The comparable part of a 'World': 'NodeState' has no 'Eq' (it carries a+machine's status snapshot), so project each node down to where it is wanted+and whether it got there, and take the bookkeeping by its keys and sizes.+-}+worldShape :: World Spec Spec -> (Map Ref (Direction, Convergence), Set Ref, Int, Int, Int)+worldShape w =+    ( Map.map (\st -> (st.nodeDirection, st.nodeConvergence)) w.worldNodes+    , Map.keysSet w.worldMagma+    , Map.size w.worldLedger+    , length w.worldEpochs+    , length w.worldLog+    )++{- | Drive the loop over the same script typed by two producers taking+turns, line for line, in script order. Lines are numbered; a producer sends+its line only when the shared turn counter has reached that number, then+passes the turn. The non-'Stdin' producer sends its 'Eof' as soon as its+lines are out (which the loop must ignore); the 'Stdin' one waits for every+line to be out first, so its 'Eof' is what ends the loop, exactly as the+end of a script file does.+-}+runProducers :: Track' Spec -> [String] -> IO (World Spec Spec)+runProducers prog script = do+    turn <- newTVarIO 0+    let numbered = zip [0 :: Int ..] script+        total = length script+        mine k = [(n, l) | (n, l) <- numbered, n `mod` 2 == k]+        producers =+            [ turnProducer turn total Stdin (mine 0)+            , turnProducer turn total (Origin "second") (mine 1)+            ]+    Serve.serveProducers [] Nothing True silent silent parseSpec (Configure pure) prog producers++turnProducer :: TVar Int -> Int -> Origin -> [(Int, String)] -> Producer+turnProducer turn total origin ls = Producer $ \inbox -> do+    mapM_ (say inbox) ls+    -- the 'Stdin' producer's 'Eof' ends the loop, so it must come after the+    -- last line whoever typed it; the other producer's is read past, so it+    -- may come whenever.+    case origin of+        Stdin -> await (>= total)+        _ -> pure ()+    atomically (writeTChan inbox (Eof origin))+  where+    say :: TChan Line -> (Int, String) -> IO ()+    say inbox (n, l) = do+        await (== n)+        atomically $ do+            writeTChan inbox (Line origin l)+            modifyTVar' turn (+ 1)+    await :: (Int -> Bool) -> IO ()+    await p = atomically $ do+        t <- readTVar turn+        if p t then pure () else retry++-------------------------------------------------------------------------------++-- | Drive the loop over a scripted stdin, piped-script mode (never idle, so+-- deterministic) — same shape as 'Test.ServeSpec.runServe'/'withScript',+-- inlined here since 'Test.ServeSpec' exports only its 'tests'.+runServe :: Track' Spec -> [String] -> IO (World Spec Spec)+runServe prog script =+    withScript script $ \h ->+        Serve.serveWith [] Nothing True silent silent parseSpec (Configure pure) prog h++withScript :: [String] -> (Handle -> IO a) -> IO a+withScript ls act =+    withSystemTempFile "salmon-serve-model-script" $ \path h -> do+        hPutStr h (unlines ls)+        hClose h+        withFile path ReadMode act
+ test/Test/ServeSocketSpec.hs view
@@ -0,0 +1,443 @@+{-# LANGUAGE DeriveGeneric #-}++{- | Layer 1 coverage for "Salmon.Actions.Serve.Socket" (milestone 2 of+@specs\/generic-server.md@): the @run serve@ loop with a unix socket+listener beside its standard input, driven by real clients over real+connections.++What is under test is the plumbing, not the recipe — the nodes are the+same counter-bumping stubs 'Test.ServeModelSpec' uses. The claims: two+clients interleaving commands each read exactly the reports for their own+lines and nothing else, and the world they leave is the one the same+script typed on one stdin would leave; a client hanging up is reported and+does not end the loop; @quit@ from a client does; a client that half-closes+after typing still gets its reports; and the socket file is owner-only,+refused while something listens on it, and replaced when stale.+-}+module Test.ServeSocketSpec (tests) where++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)+import Control.Exception (bracket, try)+import Control.Monad (unless, when)+import Data.Aeson (FromJSON, ToJSON, Value (..), eitherDecodeStrict)+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Bits ((.&.))+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as Char8+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import qualified Network.Socket as Socket+import Network.Socket (Socket)+import qualified Network.Socket.ByteString as SocketBS+import System.FilePath ((</>))+import System.IO (Handle, IOMode (ReadMode), hClose, hPutStr, withFile)+import System.IO.Temp (withSystemTempFile)+import System.Posix.Files (fileMode, getFileStatus)+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 (Convergence (..), Direction (..), NodeState (..), World (..))+import qualified Salmon.Actions.Serve.Socket as Socket+import Salmon.Builtin.Extension (Track', deps, down, nodeps, op, ref, up)+import Salmon.Op.Configure (Configure (..))+import Salmon.Op.Ref (Ref, mkRef)+import Salmon.Op.Track (Track (..))+import Salmon.Reporter (silent)+import qualified Salmon.Reporter.Tagged as Tagged++import Test.Harness (capture, privatePipe, withTempDir)++tests :: TestTree+tests =+    testGroup+        "Salmon.Actions.Serve.Socket"+        [ testCase "two clients interleaving commands each read only their own reports" twoClientsInterleave+        , testCase "a client hanging up is reported and does not end the loop" hangUpDoesNotEndTheLoop+        , testCase "`quit` from a client ends the loop" quitFromAClientEndsTheLoop+        , testCase "a client that half-closes after typing still gets its reports" halfCloseStillAnswered+        , testCase "the socket is owner-only, refused while live, replaced when stale, refused when too long" socketFileRules+        ]++-------------------------------------------------------------------------------+-- the thing served: counters per node name, as in Test.ServeModelSpec++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) -> IORef (Map String Int) -> Track' Spec+spyProgram upsRef downsRef = Track $ \spec ->+    op "socket-root" (deps (fmap nodeOp spec.specNames)) $ \actions ->+        actions{ref = mkRef "socket-root" spec.specNames}+  where+    nodeOp name =+        op "socket-node" nodeps $ \actions ->+            actions+                { ref = mkRef "socket-node" name+                , up = bump upsRef name+                , down = bump downsRef name+                }+    bump r name = atomicModifyIORef' r (\m -> (Map.insertWith (+) name 1 m, ()))++-------------------------------------------------------------------------------+-- a running loop with a listener++data Running = Running+    { runningPath :: FilePath+    , runningStdin :: Handle+    -- ^ the writing end of the loop's standard input; closing it ends the loop+    , runningWorld :: MVar (World Spec Spec)+    , runningOwn :: IO [Tagged.Tagged]+    -- ^ everything the loop's own reporter saw+    , runningUps :: IORef (Map String Int)+    , runningDowns :: IORef (Map String Int)+    }++{- | Start the loop on a temp socket with a pipe for standard input, hand+it to the test, and make sure it has ended before the temp dir goes.+-}+withRunning :: (Running -> IO a) -> IO a+withRunning act =+    withTempDir $ \dir -> do+        let path = dir </> "serve.sock"+        (stdinR, stdinW) <- privatePipe+        worldVar <- newEmptyMVar+        (own, seen) <- capture+        upsRef <- newIORef Map.empty+        downsRef <- newIORef Map.empty+        Socket.withUnixListener path $ \listener -> do+            let (serveR, updownR) = Socket.listenerReporters listener own+            _ <- forkIO $ do+                w <-+                    Serve.serveAttributed+                        []+                        Nothing+                        True+                        serveR+                        updownR+                        parseSpec+                        (Configure pure)+                        (spyProgram upsRef downsRef)+                        Nothing+                        [Serve.stdinProducer stdinR, Socket.listenerProducer listener]+                putMVar worldVar w+            let running = Running path stdinW worldVar seen upsRef downsRef+            r <- act running+            -- whatever the test did, the loop must be gone before the socket+            -- and the directory are: close stdin (harmless if the loop+            -- already ended on `quit`) and wait for it.+            _ <- try (hClose stdinW) :: IO (Either IOError ())+            _ <- awaitWorld running+            pure r++awaitWorld :: Running -> IO (World Spec Spec)+awaitWorld running = do+    mw <- timeout (10 * 1000000) (takeMVar (runningWorld running))+    case mw of+        Nothing -> assertFailure "the loop did not end"+        Just w -> do+            -- put it back so a second wait (withRunning's own) finds it+            putMVar (runningWorld running) w+            pure w++-------------------------------------------------------------------------------+-- a client: a raw socket, so a test can half-close it++data Client = Client+    { clientSocket :: Socket+    , clientBuffer :: IORef ByteString.ByteString+    , clientSeen :: IORef [Value]+    -- ^ every object read so far, oldest first once reversed+    }++withClient :: Running -> (Client -> IO a) -> IO a+withClient running = bracket (connectClient running) (Socket.close . clientSocket)++connectClient :: Running -> IO Client+connectClient running = do+    sock <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol+    Socket.connect sock (Socket.SockAddrUnix (runningPath running))+    Client sock <$> newIORef ByteString.empty <*> newIORef []++send :: Client -> String -> IO ()+send c line = SocketBS.sendAll (clientSocket c) (Char8.pack (line <> "\n"))++-- | One line off the connection, or 'Nothing' at end of file.+readLine :: Client -> IO (Maybe ByteString.ByteString)+readLine c = do+    buf <- readIORef (clientBuffer c)+    case Char8.elemIndex '\n' buf of+        Just i -> do+            let (line, rest) = ByteString.splitAt i buf+            atomicModifyIORef' (clientBuffer c) (const (ByteString.drop 1 rest, ()))+            pure (Just line)+        Nothing -> do+            chunk <- SocketBS.recv (clientSocket c) 4096+            if ByteString.null chunk+                then pure Nothing+                else do+                    atomicModifyIORef' (clientBuffer c) (\b -> (b <> chunk, ()))+                    readLine c++-- | Read JSON objects until one of the given kind arrives, and return the+-- kinds read in this call, that one included.+readUntil :: Client -> Text -> IO [Text]+readUntil c wanted = do+    r <- timeout (10 * 1000000) (go [])+    case r of+        Nothing -> do+            seen <- readIORef (clientSeen c)+            assertFailure ("timed out waiting for " <> Text.unpack wanted <> "; seen so far: " <> show (fmap kindOf (reverse seen)))+        Just ks -> pure ks+  where+    go acc = do+        mline <- readLine c+        case mline of+            Nothing -> assertFailure ("connection closed while waiting for " <> Text.unpack wanted <> "; got " <> show (reverse acc))+            Just line ->+                case eitherDecodeStrict line of+                    Left err -> assertFailure ("not a JSON line: " <> err <> ": " <> Char8.unpack line)+                    Right v -> do+                        atomicModifyIORef' (clientSeen c) (\vs -> (v : vs, ()))+                        let k = kindOf v+                        if k == wanted then pure (reverse (k : acc)) else go (k : acc)++-- | Send a line and read its reports through to the one that ends them.+ask :: Client -> String -> Text -> IO [Text]+ask c line lastKind = send c line >> readUntil c lastKind++kindOf :: Value -> Text+kindOf (Object o) = case KeyMap.lookup "kind" o of+    Just (String k) -> k+    _ -> "<no kind>"+kindOf _ = "<not an object>"++kindsSeen :: Client -> IO [Text]+kindsSeen c = fmap kindOf . reverse <$> readIORef (clientSeen c)++-------------------------------------------------------------------------------++{- | The script both halves of the comparison run: A declares and asks for+history, B asks for status and retires; each waits for the previous+command's last report before the next client types, so the inbox order is+the script order.+-}+twoClientsInterleave :: IO ()+twoClientsInterleave = do+    (sequentialUps, sequentialDowns, sequentialWorld) <- runScript script+    withRunning $ \running -> do+        withClient running $ \a -> withClient running $ \b -> do+            _ <- ask a "supervise off" "supervised"+            _ <- ask a "up n1" "converge-stop"+            _ <- ask b "status" "status"+            _ <- ask a "up n1 n2" "converge-stop"+            _ <- ask b "status" "status"+            _ <- ask b "down n1" "converge-stop"+            _ <- ask a "history" "history"+            aKinds <- kindsSeen a+            bKinds <- kindsSeen b+            -- A never asked for status; B never declared, asked for history,+            -- or changed supervision+            assertBool ("A read a status that B asked for: " <> show aKinds) ("status" `notElem` aKinds)+            assertBool ("B read something only A asked for: " <> show bKinds) $+                not (any (`elem` ["supervised", "history"]) bKinds)+            -- and each read the shape its own lines produce+            assertEqual "A's first report" (Just "supervised") (headMay aKinds)+            assertEqual "A's last report" (Just "history") (lastMay aKinds)+            assertEqual "B's first two reports" ["status", "status"] (take 2 bKinds)+            assertEqual "B's last report" (Just "converge-stop") (lastMay bKinds)+            assertEqual "declarations A read" 2 (length (filter (== "declared") aKinds))+            assertEqual "declarations B read" 1 (length (filter (== "declared") bKinds))+            -- neither read anything the loop said outside a command+            assertBool "no hang-up reached a client" (all (`notElem` ["hung-up", "started", "stopped"]) (aKinds <> bKinds))+            -- the loop's own reporter saw every one of those reports too,+            -- and nothing more than its own bookends+            own <- runningOwn running+            let ownKinds = fmap kindOf' own+            assertEqual+                "the loop's own reporter saw each client's reports"+                (length aKinds + length bKinds)+                (length (filter (`notElem` ["started", "stopped", "hung-up"]) ownKinds))+        hClose (runningStdin running)+        w <- awaitWorld running+        ups <- readIORef (runningUps running)+        downs <- readIORef (runningDowns running)+        assertEqual "ups agree with the one-stdin run" sequentialUps ups+        assertEqual "downs agree with the one-stdin run" sequentialDowns downs+        assertEqual "the world agrees with the one-stdin run" (worldShape sequentialWorld) (worldShape w)+  where+    script = ["supervise off", "up n1", "status", "up n1 n2", "status", "down n1", "history"]+    headMay xs = case xs of+        [] -> Nothing+        (x : _) -> Just x+    lastMay xs = case xs of+        [] -> Nothing+        _ -> Just (last xs)+    kindOf' t = case t of+        Tagged.FromServe rep -> case rep of+            Serve.Started -> "started"+            Serve.Stopped -> "stopped"+            Serve.HungUp{} -> "hung-up"+            _ -> "serve"+        _ -> "node"++hangUpDoesNotEndTheLoop :: IO ()+hangUpDoesNotEndTheLoop =+    withRunning $ \running -> do+        withClient running $ \a -> do+            _ <- ask a "supervise off" "supervised"+            _ <- ask a "up n1" "converge-stop"+            pure ()+        -- A is gone. The loop says so on its own reporter, once its lines+        -- are handled, and keeps going.+        waitFor "the hang-up to be reported" $ do+            own <- runningOwn running+            pure (any isHangUp own)+        withClient running $ \b -> do+            _ <- ask b "status" "status"+            seen <- readIORef (clientSeen b)+            case seen of+                [Object o] -> case KeyMap.lookup "nodes" o of+                    Just (Array nodes) -> assertEqual "B still sees A's nodes" 2 (length nodes)+                    _ -> assertFailure "status without nodes"+                _ -> assertFailure ("B expected exactly one status object, got " <> show seen)+        -- B's hang-up too, before stdin ends the loop: the two 'Eof's are+        -- pushed by different threads and would otherwise race.+        waitFor "the second hang-up" $ do+            own <- runningOwn running+            pure (length (filter isHangUp own) == 2)+        hClose (runningStdin running)+        _ <- awaitWorld running+        own <- runningOwn running+        assertEqual "hang-ups reported" 2 (length (filter isHangUp own))+        assertBool "the loop ended on stdin's end of input" (any isStopped own)+  where+    isHangUp t = case t of+        Tagged.FromServe Serve.HungUp{} -> True+        _ -> False+    isStopped t = case t of+        Tagged.FromServe Serve.Stopped -> True+        _ -> False++quitFromAClientEndsTheLoop :: IO ()+quitFromAClientEndsTheLoop =+    withRunning $ \running -> do+        withClient running $ \a -> do+            _ <- ask a "up n1" "converge-stop"+            send a "quit"+            -- standard input is still open: only the client's quit can end this+            w <- awaitWorld running+            assertEqual "the declaration survived" 1 (Map.size (worldLedger w))+            -- the loop is gone and so is the connection+            rest <- timeout (10 * 1000000) (readLine a)+            assertEqual "the client reads end of file" (Just Nothing) rest+        own <- runningOwn running+        assertBool "quit is not stdin closing" (not (any isStopped own))+  where+    isStopped t = case t of+        Tagged.FromServe Serve.Stopped -> True+        _ -> False++halfCloseStillAnswered :: IO ()+halfCloseStillAnswered =+    withRunning $ \running ->+        withClient running $ \a -> do+            send a "supervise off"+            send a "up n1 n2"+            send a "status"+            -- nothing more to say, and the loop has not necessarily read a+            -- word of it yet+            Socket.shutdown (clientSocket a) Socket.ShutdownSend+            kinds <- readUntil a "status"+            assertBool ("all three commands were answered: " <> show kinds) $+                all (`elem` kinds) ["supervised", "declared", "converge-stop", "status"]+            -- and then the loop closes the connection, having said hung-up+            -- on its own reporter only+            rest <- timeout (10 * 1000000) (readLine a)+            assertEqual "the connection is closed after the last report" (Just Nothing) rest+            own <- runningOwn running+            assertBool "the hang-up was reported" (any isHangUp own)+  where+    isHangUp t = case t of+        Tagged.FromServe Serve.HungUp{} -> True+        _ -> False++socketFileRules :: IO ()+socketFileRules =+    withTempDir $ \dir -> do+        let path = dir </> "rules.sock"+        Socket.withUnixListener path $ \_ -> do+            st <- getFileStatus path+            assertEqual "owner-only" 0o600 (fileMode st .&. 0o777)+            r <- try (Socket.withUnixListener path (const (pure ())))+            assertEqual "a live socket is refused" (Left (Socket.AlreadyListening path)) r+        -- a stale socket file: bound once, never listened on again+        stale <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol+        Socket.bind stale (Socket.SockAddrUnix path)+        Socket.close stale+        replaced <- try (Socket.withUnixListener path (const (pure ())))+        assertEqual "a stale socket file is replaced" (Right ()) (replaced :: Either Socket.ListenError ())+        -- a file that is not a socket is nobody's to remove+        writeFile path "not a socket\n"+        notSock <- try (Socket.withUnixListener path (const (pure ())))+        assertEqual "a regular file is refused" (Left (Socket.NotASocket path)) notSock+        -- the longest path a unix address holds binds; one character more is+        -- refused by name, not by network's crash from inside bind+        let sized n = dir </> replicate (n - length dir - 1) 'x'+            longest = sized (Socket.unixPathMax - 1)+            tooLong = sized Socket.unixPathMax+        fits <- try (Socket.withUnixListener longest (const (pure ())))+        assertEqual "the longest path binds" (Right ()) (fits :: Either Socket.ListenError ())+        over <- try (Socket.withUnixListener tooLong (const (pure ())))+        assertEqual "one more is refused" (Left (Socket.PathTooLong tooLong Socket.unixPathMax (Socket.unixPathMax - 1))) over++-------------------------------------------------------------------------------++waitFor :: String -> IO Bool -> IO ()+waitFor what cond = do+    r <- timeout (10 * 1000000) go+    when (r == Nothing) (assertFailure ("timed out waiting for " <> what))+  where+    go = do+        ok <- cond+        unless ok go++-- | The same script on one stdin, for the comparison.+runScript :: [String] -> IO (Map String Int, Map String Int, World Spec Spec)+runScript script = do+    upsRef <- newIORef Map.empty+    downsRef <- newIORef Map.empty+    w <- withScript script $ \h ->+        Serve.serveWith [] Nothing True silent silent parseSpec (Configure pure) (spyProgram upsRef downsRef) h+    (,,) <$> readIORef upsRef <*> readIORef downsRef <*> pure w++withScript :: [String] -> (Handle -> IO a) -> IO a+withScript ls act =+    withSystemTempFile "salmon-serve-socket-script" $ \path h -> do+        hPutStr h (unlines ls)+        hClose h+        withFile path ReadMode act++-- | The comparable part of a 'World', as 'Test.ServeModelSpec' takes it.+worldShape :: World Spec Spec -> (Map Ref (Direction, Convergence), Set.Set Ref, Int, Int, Int)+worldShape w =+    ( Map.map (\st -> (st.nodeDirection, st.nodeConvergence)) w.worldNodes+    , Map.keysSet w.worldMagma+    , Map.size w.worldLedger+    , length w.worldEpochs+    , length w.worldLog+    )
+ test/Test/ServeSpec.hs view
@@ -0,0 +1,1321 @@+{-# LANGUAGE DeriveGeneric #-}++{- | Layer 1 coverage for "Salmon.Actions.Serve": drive the @run serve@ loop+with a scripted stdin over a throwaway temp dir, and assert on both the real+filesystem effects and the 'World' it hands back.++The seed here is deliberately trivial (a list of file names, configured+straight through to the directive) — what is under test is the convergence+bookkeeping, not the recipe: that re-declaring a converged seed does nothing,+that retiring one tears down exactly the nodes no other seed still wants+(nodes unify by 'Ref' across seeds), and that a node whose @up@ threw is left+non-converged and picked up again by the next pass.+-}+module Test.ServeSpec (tests) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVar, readTVarIO, retry)+import Control.Exception (IOException, throwIO, try)+import Control.Monad (unless, when)+import Data.Aeson (FromJSON, ToJSON, encode)+import qualified Data.ByteString.Lazy as LByteString+import Data.Dynamic (toDyn)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import qualified Data.List+import qualified Data.Set as Set+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import System.Directory (doesDirectoryExist, doesFileExist)+import System.FilePath ((</>))+import System.IO (BufferMode (LineBuffering), Handle, IOMode (ReadMode), hClose, hPutStr, hPutStrLn, hSetBuffering, withFile)+import System.IO.Temp (withSystemTempFile)+import System.Process (createPipe, proc)+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 (Convergence (..), Direction (..), NodeState (..), World (..))+import qualified Salmon.Actions.UpDown as UpDown+import Salmon.Actions.UpDown (CheckResult (..))+import qualified Salmon.Actions.Upkeep as Upkeep+import Salmon.Builtin.Extension (Extension, Op, Track', check, deps, down, dynamics, managed, nodeps, op, opAct, ref, up)+import qualified Salmon.Builtin.Nodes.Daemon as Daemon+import qualified Salmon.Builtin.Nodes.Filesystem as FS+import Salmon.Op.Configure (Configure (..))+import qualified Salmon.Op.Ledger as Ledger+import qualified Salmon.Op.Mailbox as Mailbox+import Salmon.Op.Ref (Ref, mkRef, unRef)+import Salmon.Op.Rewrite (Phase (..), Rewrite)+import qualified Salmon.Op.Status as MachineStatus+import Salmon.Op.Supervision (Strategy (..), Supervision (..), defaultSupervision, supervised)+import qualified Salmon.Op.Rewrite as Rewrite+import Salmon.Op.Track (Track (..))+import Salmon.Reporter (ReporterM (..), silent)++import Test.Harness (capture, withTempDir)++tests :: TestTree+tests =+    testGroup+        "Salmon.Actions.Serve"+        [ testCase "a declared seed converges and stays converged" declaredSeedConverges+        , testCase "re-declaring a converged seed is a no-op" reDeclareIsNoop+        , testCase "retiring a seed tears its nodes down" retireTearsDown+        , testCase "retiring a multi-file bundle removes its shared directory cleanly" retireMultiFileBundle+        , testCase "`only` retires the previous seed but keeps shared nodes" onlySupersedes+        , testCase "a node whose up threw is retried by the next pass" failedNodeIsRetried+        , testCase "a retired declaration survives a failed down" retiredContributionSurvives+        , testCase "re-declaring a seed does not accumulate graphs" reDeclareDoesNotAccumulate+        , testCase "history outlives the graph it declared" historyOutlivesTheGraph+        , testCase "the history log is capped and says how much it dropped" historyLogIsCapped+        , testCase "unparseable input does not disturb the world" badInputIsInert+        , testCase "`load` runs a file of declarations as if typed" loadRunsAScript+        , testCase "`up-directive` declares straight from a directive file" upDirectiveDeclares+        , testCase "`status --exclude **` hides every node" statusExcludeAllHidesEverything+        , testCase "`history --exclude **` hides every epoch" historyExcludeAllHidesEverything+        , testCase "`converge --select` restricted to nothing leaves a failed node untouched" convergeSelectRestricts+        , testCase "`help` prints the command reference and touches nothing" helpPrintsReference+        , testCase "`help TOPIC` prints a longer, topic-specific block" helpTopicIsLonger+        , testCase "`help` with an unrecognised topic falls back to the full reference" helpUnknownTopicFallsBack+        , testCase "a registered rewrite batches across seeds and converges its members" rewriteBatchesAcrossSeeds+        , testCase "a rewrite's batch splits by direction when a seed is retired" rewriteSplitsOnRetire+        , testCase "an idle loop tends its nodes and puts a vanished effect back" idleLoopTends+        , testCase "`supervise off` leaves a vanished effect alone" superviseOffLeavesItAlone+        , testCase "a node that owns a process keeps it across commands, and loses it on clear" ownedProcessSurvivesCommands+        , testCase "an adopted process still follows the config it stands on" adoptedDaemonFollowsItsConfig+        , testCase "status shows a failing node's check and its last output" statusShowsAFailingNodesOutput+        , testCase "`force` re-applies a node its own check still calls satisfied" forceOverridesASatisfiedCheck+        , testCase "`pause` stops a node coming back, `resume` lets it" pauseThenResume+        , testCase "(I6) a re-declaration with changed content is applied by the pass itself, not just the tending loop" reDeclareWithChangedContentIsAppliedByThePass+        , testCase "`autoconverge off` records a declaration without converging it" autoConvergeOffDefersConvergence+        , testCase "`autoconverge off` also keeps the idle tending loop from applying a deferred declaration" autoConvergeOffAlsoStopsIdleTending+        , testCase "`autoconverge off` keeps a checkless node's `up` from ever running" autoConvergeOffKeepsAChecklessNodeFromRunning+        , testCase "`autoconverge off` defers a `down` the same way it defers an `up`" autoConvergeOffDefersTeardown+        , testCase "`autoconverge off` defers a `clear` the same way" autoConvergeOffDefersClear+        , testCase "several declarations made while autoconverge is off land in one combined converge" autoConvergeOffStacksDeclarationsIntoOneConverge+        , testCase "a managed node still starts under `autoconverge off` — it has no other path to" managedNodeStartsDespiteAutoConvergeOff+        , testCase "turning autoconverge back on lets idle tending pick up what was deferred, with no explicit converge" autoConvergeBackOnLetsTendingCatchUp+        , testCase "`status` prints each node's path, and it round-trips as a `--select` pattern" statusPathsRoundTripAsSelectors+        , testCase "two nodes sharing one shorthand-derived path are told apart by `#ref` instead" ambiguousPathsAreDisambiguatedByRef+        , testCase "`force` still reaches a node deferred by `autoconverge off`, without converging anything else" autoConvergeOffForceStillReachesANamedNode+        ]++-------------------------------------------------------------------------------+-- The thing being served: "make these files exist in this directory".++data Spec = Spec+    { specDir :: FilePath+    , specNames :: [String]+    }+    deriving (Eq, Show, Generic)++instance ToJSON Spec+instance FromJSON Spec++-- | @up a b@ in the serve script means "these file names".+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 "serve-spec-root" (deps (fmap (fileOp spec.specDir) spec.specNames)) $ \actions ->+        actions{ref = mkRef "serve-spec-root" (spec.specDir, spec.specNames)}++-- | Note both the file and (via 'FS.filecontents') its enclosing directory+-- are real nodes with a real teardown, and the directory node is shared by+-- every seed here — that shared node is the unification this spec leans on.+fileOp :: FilePath -> String -> Op+fileOp d n = FS.filecontents (FS.FileContents (d </> n) ("contents of " <> n))++-------------------------------------------------------------------------------++declaredSeedConverges :: IO ()+declaredSeedConverges =+    withTempDir $ \root -> do+        (w, reports, _) <- runServe program root ["up a"]+        assertFileExists root "a" True+        assertAllConverged TurnUp w+        assertEqual "one converge, nothing left over" [True] (convergeOutcomes reports)++-- | `autoconverge off` lets a declaration record itself (visible to+-- `status`) without touching the filesystem, until a later `converge`+-- catches it up.+autoConvergeOffDefersConvergence :: IO ()+autoConvergeOffDefersConvergence =+    withTempDir $ \root -> do+        (w1, reports1, _) <- runServe program root ["autoconverge off", "up a"]+        assertFileExists root "a" False+        assertEqual "the declaration itself does not converge" [] (convergeOutcomes reports1)+        assertBool+            "declared node is recorded but still pending"+            (all (\st -> st.nodeConvergence == Pending) (Map.elems w1.worldNodes))+        (w2, reports2, _) <- runServe program root ["autoconverge off", "up a", "converge"]+        assertFileExists root "a" True+        assertEqual "the explicit converge runs exactly once" [True] (convergeOutcomes reports2)+        assertAllConverged TurnUp w2++-- | @down@ is exactly as deferrable as @up@: the ledger records the+-- retraction and the node's direction flips to 'TurnDown' right away, but+-- the file itself is untouched until an explicit @converge@.+autoConvergeOffDefersTeardown :: IO ()+autoConvergeOffDefersTeardown =+    withTempDir $ \root -> do+        (w1, reports1, _) <- runServe program root ["up a", "autoconverge off", "down a"]+        assertFileExists root "a" True+        assertEqual "only the initial `up` converged; the `down` did not" [True] (convergeOutcomes reports1)+        assertBool+            "wanted down, but not yet converged there"+            (all (\st -> st.nodeDirection == TurnDown && st.nodeConvergence /= Converged) (Map.elems w1.worldNodes))+        (w2, reports2, _) <- runServe program root ["up a", "autoconverge off", "down a", "converge"]+        assertFileExists root "a" False+        assertEqual "one converge for the `up`, one for the explicit `converge`" [True, True] (convergeOutcomes reports2)+        assertWorldSettled w2++-- | @clear@ retires every seed at once but goes through the same+-- 'commitEpoch' path as any other declaration, so it defers exactly the+-- same way.+autoConvergeOffDefersClear :: IO ()+autoConvergeOffDefersClear =+    withTempDir $ \root -> do+        (w, reports, _) <- runServe program root ["up a", "autoconverge off", "clear"]+        assertFileExists root "a" True+        assertEqual "the `clear` itself did not converge" [True] (convergeOutcomes reports)+        assertBool+            "every node wanted down, none converged there yet"+            (all (\st -> st.nodeDirection == TurnDown && st.nodeConvergence /= Converged) (Map.elems w.worldNodes))++{- | Several declarations made back to back while autoconverge is off — a+teardown and a bring-up — land in the /one/ pass the next explicit+@converge@ runs, exactly as if they had been typed as a single combined+change. This is the scenario the feature exists for: stack up several+declarations, inspect, then act on all of them at once.+-}+autoConvergeOffStacksDeclarationsIntoOneConverge :: IO ()+autoConvergeOffStacksDeclarationsIntoOneConverge =+    withTempDir $ \root -> do+        (w, reports, _) <-+            runServe+                program+                root+                [ "up a" -- converges immediately: autoconverge is still on+                , "autoconverge off"+                , "down a"+                , "up b"+                , "converge" -- the one pass that actually does both+                ]+        assertFileExists root "a" False+        assertFileExists root "b" True+        assertEqual+            "one converge for the initial `up a`, one for the combined explicit `converge`"+            [True, True]+            (convergeOutcomes reports)+        let (finalDown, finalUp) = last [(ndown, nup) | Serve.ConvergeStart ndown nup <- reports]+        assertBool "the explicit converge's own pass saw the teardown" (finalDown >= 1)+        assertBool "...and the bring-up, together in the same pass" (finalUp >= 1)+        assertAllConverged TurnUp w++reDeclareIsNoop :: IO ()+reDeclareIsNoop =+    withTempDir $ \root -> do+        (w, reports, _) <- runServe program root ["up a", "up a"]+        assertFileExists root "a" True+        assertAllConverged TurnUp w+        -- the first declaration has work to do, the second finds everything+        -- already converged and evaluates nothing at all.+        assertEqual+            "second declaration has nothing pending"+            [(0, 3), (0, 0)]+            (convergeStarts reports)+        assertEqual "history keeps both declarations" 2 (length w.worldLog)+        assertEqual "but they are one live declaration" 1 (Ledger.liveCount w.worldLedger)+        -- the superseded epoch is no longer the newest for its key and none+        -- of its nodes is on its way down, so its graph is collected rather+        -- than piling up.+        assertEqual "and only the live graph is retained" 1 (length w.worldEpochs)++retireTearsDown :: IO ()+retireTearsDown =+    withTempDir $ \root -> do+        (w, _, _) <- runServe program root ["up a", "down a"]+        assertFileExists root "a" False+        assertDirExists root False+        assertWorldSettled w++{- | Two files in one bundle share the enclosing-directory node. Tearing the+bundle down must remove both files before that directory, or @removeDirectory@+throws "directory not empty" — the shared-predecessor ordering fixed in+'Salmon.Actions.UpDown.downTree'. With one convergence and no retry, a wrong+order would leave the directory 'Errored'.+-}+retireMultiFileBundle :: IO ()+retireMultiFileBundle =+    withTempDir $ \root -> do+        (w, _, nodeReports) <- runServe program root ["up a b c", "down a b c"]+        assertFileExists root "a" False+        assertFileExists root "b" False+        assertFileExists root "c" False+        assertDirExists root False+        assertWorldSettled w+        assertEqual "nothing failed while tearing down" [] [() | UpDown.Failed{} <- nodeReports]++onlySupersedes :: IO ()+onlySupersedes =+    withTempDir $ \root -> do+        (w, _, _) <- runServe program root ["up a", "only b"]+        assertFileExists root "a" False+        assertFileExists root "b" True+        -- the enclosing directory is one node shared by both seeds' graphs:+        -- it must survive the teardown of the seed that is going away.+        assertDirExists root True+        assertEqual "one live declaration" 1 (Ledger.liveCount w.worldLedger)+        assertBool+            "every node converged, whichever way it is wanted"+            (all (\st -> st.nodeConvergence == Converged) (Map.elems w.worldNodes))+        -- the retired seed's graph has nothing left to describe: the node it+        -- alone held is down, and the shared directory belongs to `b` now.+        assertEqual "only the surviving seed's graph is retained" 1 (length w.worldEpochs)++failedNodeIsRetried :: IO ()+failedNodeIsRetried =+    withTempDir $ \root -> do+        attempts <- newIORef (0 :: Int)+        (w1, _, _) <- runServe (flaky attempts) root ["up a"]+        assertEqual "attempted once" 1 =<< readIORef attempts+        assertEqual+            "a node that threw is left non-converged"+            [Errored]+            (convergences w1)++        attempts2 <- newIORef (0 :: Int)+        (w2, reports, _) <- runServe (flaky attempts2) root ["up a", "converge"]+        assertEqual "retried by the explicit converge" 2 =<< readIORef attempts2+        assertEqual "and then it stuck" [Converged] (convergences w2)+        assertEqual "first pass failed, second one did not" [False, True] (convergeOutcomes reports)+  where+    convergences :: World Spec Spec -> [Convergence]+    convergences w = fmap nodeConvergence (Map.elems w.worldNodes)++{- | A contribution is collected once nothing could still walk it — so the+one thing that must never happen is collecting the description a teardown has+not finished with. This is what pins 'Salmon.Actions.Serve.resettle''s+ordering: prune before retune and the @down a@ declaration's own nodes still+look up-and-converged, so its contribution would be dropped and the retry+would have nothing to walk.++Note what is /not/ retained: the graph. A retired declaration's epoch goes+immediately, and what survives is its 'Salmon.Op.Ledger.Contribution' (nodes+and edges) plus those nodes' representatives in the magma — which is what+'Salmon.Actions.Serve.downDag' rebuilds the teardown from.+-}+retiredContributionSurvives :: IO ()+retiredContributionSurvives =+    withTempDir $ \root -> do+        attempts <- newIORef (0 :: Int)+        (w1, _, _) <- runServe (flakyDown attempts) root ["up a", "down a"]+        assertEqual "the teardown was attempted once" 1 =<< readIORef attempts+        assertEqual "and left the node non-converged" [Errored] (convergences w1)+        assertEqual "the retired declaration's graph is gone" 0 (length w1.worldEpochs)+        assertBool+            "but its contribution is still held, so the retry has something to walk"+            (not (null (Map.elems w1.worldLedger)))+        assertBool+            "and the node still has a representative to run down"+            (not (Map.null w1.worldMagma))++        attempts2 <- newIORef (0 :: Int)+        (w2, _, _) <- runServe (flakyDown attempts2) root ["up a", "down a", "converge"]+        assertEqual "retried by the explicit converge" 2 =<< readIORef attempts2+        assertWorldSettled w2+  where+    convergences :: World Spec Spec -> [Convergence]+    convergences w = fmap nodeConvergence (Map.elems w.worldNodes)++reDeclareDoesNotAccumulate :: IO ()+reDeclareDoesNotAccumulate =+    withTempDir $ \root -> do+        (w, _, _) <- runServe program root (replicate 5 "up a")+        assertEqual "every declaration is logged" 5 (length w.worldLog)+        assertEqual "but they describe one live graph between them" 1 (length w.worldEpochs)++historyOutlivesTheGraph :: IO ()+historyOutlivesTheGraph =+    withTempDir $ \root -> do+        (w, reports, _) <- runServe program root ["up a", "down a", "history"]+        assertWorldSettled w+        assertEqual+            "both declarations are still listed after their graphs are gone"+            [2]+            [length xs | Serve.HistoryReport xs <- reports]++historyLogIsCapped :: IO ()+historyLogIsCapped =+    withTempDir $ \root -> do+        let overflow = 5+        let script = replicate (Serve.worldLogLimit + overflow) "up a" <> ["history"]+        (w, reports, _) <- runServe program root script+        assertEqual "the log stops at the limit" Serve.worldLogLimit (length w.worldLog)+        assertEqual+            "and history says how much it is not showing"+            [overflow]+            [n | Serve.HistoryElided n <- reports]++badInputIsInert :: IO ()+badInputIsInert =+    withTempDir $ \root -> do+        (w, reports, _) <- runServe program root ["nonsense", "up", "up a"]+        assertFileExists root "a" True+        assertAllConverged TurnUp w+        assertEqual "only the well-formed declaration made an epoch" 1 (length w.worldLog)+        assertEqual "one unknown command, one unusable seed" (1, 1) (badCounts reports)+  where+    badCounts reports =+        ( length [() | Serve.BadCommand _ <- reports]+        , length [() | Serve.BadSeed _ <- reports]+        )++loadRunsAScript :: IO ()+loadRunsAScript =+    withTempDir $ \root -> do+        let scriptPath = root </> "commands.txt"+        writeFile scriptPath (unlines ["up a"])+        (w, reports, _) <- runServe program root ["load " <> scriptPath]+        assertFileExists root "a" True+        assertAllConverged TurnUp w+        assertEqual "loaded exactly one line" [1] [n | Serve.LoadDone _ n <- reports]++upDirectiveDeclares :: IO ()+upDirectiveDeclares =+    withTempDir $ \root -> do+        let directivePath = root </> "directive.json"+        LByteString.writeFile directivePath (encode (Spec (root </> "files") ["a"]))+        (w, _, _) <- runServe program root ["up-directive " <> directivePath]+        assertFileExists root "a" True+        assertAllConverged TurnUp w+        assertEqual "one epoch, declared from a directive file" [Nothing] (fmap Serve.epochSeed w.worldEpochs)+        assertEqual+            "history records the file, not seed args"+            [["<directive-file>", directivePath]]+            (fmap Serve.logTokens w.worldLog)++statusExcludeAllHidesEverything :: IO ()+statusExcludeAllHidesEverything =+    withTempDir $ \root -> do+        (_, reports, _) <- runServe program root ["up a", "status --exclude **"]+        -- `up a`'s own auto-converge never emits a StatusReport, so the only+        -- one here is the explicit `status` call's.+        assertEqual "every node excluded" [0] [length xs | Serve.StatusReport _ xs _ <- reports]++historyExcludeAllHidesEverything :: IO ()+historyExcludeAllHidesEverything =+    withTempDir $ \root -> do+        (_, reports, _) <- runServe program root ["up a", "history --exclude **"]+        assertEqual "every epoch excluded" [[]] [xs | Serve.HistoryReport xs <- reports]++convergeSelectRestricts :: IO ()+convergeSelectRestricts =+    withTempDir $ \root -> do+        attempts <- newIORef (0 :: Int)+        (w, reports, _) <-+            runServe (flaky attempts) root ["up a", "converge --select nope-does-not-match", "converge"]+        assertEqual "attempted twice: the initial failure, then the unrestricted retry" 2 =<< readIORef attempts+        assertEqual "eventually converged" [Converged] (convergences w)+        assertEqual+            -- the restricted pass reports True ("nothing it attempted+            -- failed") even though the excluded node is still pending —+            -- that's why `ConvergeStop`'s remaining-node count matters too.+            "three passes: declare's auto-converge (fails), the restricted no-op, the unrestricted retry"+            [False, True, True]+            (convergeOutcomes reports)+        assertEqual+            "the restricted pass leaves the node pending rather than wrongly marking it converged"+            [(0, 1), (0, 1), (0, 1)]+            [(ndown, nup) | Serve.ConvergeStart ndown nup <- reports]+  where+    convergences :: World Spec Spec -> [Convergence]+    convergences w = fmap nodeConvergence (Map.elems w.worldNodes)++helpPrintsReference :: IO ()+helpPrintsReference =+    withTempDir $ \root -> do+        (w, reports, _) <- runServe program root ["help"]+        assertEqual "help declares nothing" 0 (length w.worldLog)+        assertEqual "exactly one HelpText report, no topic" [Nothing] [t | Serve.HelpText t <- reports]++helpTopicIsLonger :: IO ()+helpTopicIsLonger =+    withTempDir $ \root -> do+        (_, reports, _) <- runServe program root ["help converge", "help"]+        let [topicLines, fullLines] = [Serve.renderReport rep | rep@Serve.HelpText{} <- reports]+        assertBool "a topic's own text is shorter than the full reference" (length topicLines < length fullLines)+        assertBool "a topic's text mentions its own command" (any (Text.isInfixOf "converge") topicLines)+        assertBool "a topic's text does not repeat unrelated commands" (not (any (Text.isInfixOf "up-directive") topicLines))++helpUnknownTopicFallsBack :: IO ()+helpUnknownTopicFallsBack =+    withTempDir $ \root -> do+        (_, reports, _) <- runServe program root ["help there-is-no-such-topic", "help"]+        let [unknownLines, fullLines] = [Serve.renderReport rep | rep@Serve.HelpText{} <- reports]+        assertEqual "an unrecognised topic renders exactly like no topic at all" fullLines unknownLines++-------------------------------------------------------------------------------++{- | A program with exactly one node, which throws the first time its @up@ is+run and succeeds afterwards.+-}+flaky :: IORef Int -> Track' Spec+flaky attempts = Track $ \spec ->+    op "flaky" nodeps $ \actions ->+        actions+            { ref = mkRef "flaky" spec.specNames+            , up = do+                n <- atomicModifyIORef' attempts (\k -> (k + 1, k))+                when (n == 0) $ throwIO (userError "flaky node failing on purpose")+            }++-- | Like 'flaky', but never recovers: every attempt throws. Used to pin+-- (R3) — a node whose failure is genuinely the /tending/ loop's doing, not+-- the declaring pass's, needs one that is still broken when the loop gets+-- to it.+flakyForever :: IORef Int -> Track' Spec+flakyForever attempts = Track $ \spec ->+    op "flaky-forever" nodeps $ \actions ->+        actions+            { ref = mkRef "flaky-forever" spec.specNames+            , up = do+                atomicModifyIORef' attempts (\k -> (k + 1, ()))+                throwIO (userError "flaky-forever node failing on purpose")+            }++{- | The mirror of 'flaky': one node whose @down@ throws the first time, so+the world is left holding a teardown it has not finished.+-}+flakyDown :: IORef Int -> Track' Spec+flakyDown attempts = Track $ \spec ->+    op "flaky-down" nodeps $ \actions ->+        actions+            { ref = mkRef "flaky-down" spec.specNames+            , down = do+                n <- atomicModifyIORef' attempts (\k -> (k + 1, k))+                when (n == 0) $ throwIO (userError "flaky node refusing to go down on purpose")+            }++-- | Run the serve loop over a scripted stdin, capturing both report streams.+runServe ::+    Track' Spec ->+    FilePath ->+    [String] ->+    IO (World Spec Spec, [Serve.Report], [UpDown.Report Extension])+runServe = runServeWith []++-- | 'runServe' with "Salmon.Op.Rewrite" phases registered.+runServeWith ::+    [Rewrite Extension] ->+    Track' Spec ->+    FilePath ->+    [String] ->+    IO (World Spec Spec, [Serve.Report], [UpDown.Report Extension])+runServeWith rewrites prog root script = do+    (serveReporter, readServeReports) <- capture+    (nodeReporter, readNodeReports) <- capture+    w <-+        withScript script $+            Serve.serveWith rewrites Nothing True serveReporter nodeReporter (parseSpec root) (Configure pure) prog+    (,,) w <$> readServeReports <*> readNodeReports++withScript :: [String] -> (Handle -> IO a) -> IO a+withScript ls act =+    withSystemTempFile "salmon-serve-script" $ \path h -> do+        hPutStr h (unlines ls)+        hClose h+        withFile path ReadMode act++-- | (nodes to turn down, nodes to turn up) at the start of each convergence.+convergeStarts :: [Serve.Report] -> [(Int, Int)]+convergeStarts reports = [(ndown, nup) | Serve.ConvergeStart ndown nup <- reports]++-- | Whether each convergence applied everything it attempted cleanly.+convergeOutcomes :: [Serve.Report] -> [Bool]+convergeOutcomes reports = [ok | Serve.ConvergeStop ok _ <- reports]++assertAllConverged :: Direction -> World seed directive -> IO ()+assertAllConverged dir w = do+    assertBool "expected at least one node" (not (Map.null w.worldNodes))+    mapM_ (uncurry check) (Map.toList w.worldNodes)+  where+    check :: Ref -> NodeState -> IO ()+    check _ st = do+        assertEqual (Text.unpack st.nodeShorthand <> ": direction") dir st.nodeDirection+        assertEqual (Text.unpack st.nodeShorthand <> ": convergence") Converged st.nodeConvergence++{- | A world whose seeds have all been retired and converged keeps nothing:+the nodes are off the machine, and every structure that described them has+nothing left to say. @history@ is what still remembers they existed.+-}+assertWorldSettled :: World seed directive -> IO ()+assertWorldSettled w = do+    assertEqual "no node left to manage" 0 (Map.size w.worldNodes)+    assertEqual "no graph left to walk" 0 (length w.worldEpochs)+    assertEqual "no contribution left in the ledger" 0 (Map.size w.worldLedger)+    assertEqual "no representative left in the magma" 0 (Map.size w.worldMagma)++assertFileExists :: FilePath -> String -> Bool -> IO ()+assertFileExists root name expected = do+    found <- doesFileExist (root </> "files" </> name)+    assertEqual (name <> " exists") expected found++assertDirExists :: FilePath -> Bool -> IO ()+assertDirExists root expected = do+    found <- doesDirectoryExist (root </> "files")+    assertEqual "enclosing directory exists" expected found++-------------------------------------------------------------------------------+-- A rewrite, without needing apt on the machine running the tests.+--+-- The same shape as 'Salmon.Builtin.Nodes.Debian.Package.batchPackages' —+-- collect every node carrying a 'Widget' into one node per direction, keyed+-- on 'phaseDesired' — but the batch just appends to an 'IORef' instead of+-- shelling out. What is under test is 'Salmon.Actions.Serve''s side of it:+-- that a node no declaration ever mentioned is still gated correctly (via+-- its members) and that its outcome is recorded against the nodes an+-- operator actually declared.++newtype Widget = Widget Text+    deriving (Eq, Ord, Show)++-- | A seed whose file names each also declare a 'Widget'.+widgetProgram :: Track' Spec+widgetProgram = Track $ \spec ->+    op "widget-root" (deps (fmap widget spec.specNames)) $ \actions ->+        actions{ref = mkRef "widget-root" (spec.specDir, spec.specNames)}+  where+    widget n =+        op "widget" nodeps $ \actions ->+            actions+                { ref = mkRef "widget" (Text.pack n)+                , dynamics = [toDyn (Widget (Text.pack n))]+                }++batchWidgets :: IORef [(Text, [Widget])] -> Rewrite Extension+batchWidgets ranRef phase computed =+    batch "install" (filter (isDesired . fst) declared) $+        batch "remove" (filter (not . isDesired . fst) declared) computed+  where+    declared = Rewrite.collectDynamic computed+    isDesired rf = Set.member rf phase.phaseDesired++    batch what members c+        | null members = c+        | otherwise =+            case opAct (batchOp what (concatMap snd members)) of+                Nothing -> c+                Just act -> Rewrite.introduce act (Set.fromList (fmap fst members)) c++    batchOp what ws =+        op "widget-batch" nodeps $ \actions ->+            actions+                { ref = mkRef "widget-batch" (what :: Text, [w | Widget w <- ws])+                , up = record what ws+                , down = record what ws+                }++    record what ws = atomicModifyIORef' ranRef (\xs -> ((what, ws) : xs, ()))++{- | Two seeds, each declaring its own widgets, both live. A rewrite running+after the fold sees all of them at once — which is exactly what an+@Op -> Op@ applied inside the 'Track'' could not do, since it only ever had+one directive.+-}+rewriteBatchesAcrossSeeds :: IO ()+rewriteBatchesAcrossSeeds =+    withTempDir $ \root -> do+        ran <- newIORef []+        (w, _, _) <- runServeWith [batchWidgets ran] widgetProgram root ["up a", "up b"]+        batches <- reverse <$> readIORef ran+        assertEqual+            "the second convergence batched both seeds' widgets in one node"+            [Widget "a", Widget "b"]+            (Data.List.sort (concat [ws | ("install", ws) <- batches, length ws == 2]))+        assertBool+            "every declared widget node is converged, though none of them ran itself"+            (all (\st -> st.nodeConvergence == Converged) (Map.elems w.worldNodes))++{- | Retiring one of the two seeds is the case that has no pre-fold+expression at all: one widget is on its way out while the other is staying,+so the rewrite must emit two batches rather than one, and must not sweep the+surviving widget into the removal.+-}+rewriteSplitsOnRetire :: IO ()+rewriteSplitsOnRetire =+    withTempDir $ \root -> do+        ran <- newIORef []+        (w, _, _) <- runServeWith [batchWidgets ran] widgetProgram root ["up a", "up b", "down a"]+        batches <- reverse <$> readIORef ran+        assertEqual+            "a came out on its own"+            [[Widget "a"]]+            [ws | ("remove", ws) <- batches]+        assertBool+            "and b was never in a removal batch"+            (all (\(_, ws) -> Widget "b" `notElem` ws) [b | b@("remove", _) <- batches])+        assertAllConverged TurnUp w++-------------------------------------------------------------------------------+-- supervision between commands++{- | The two cases below drive the loop over a real pipe rather than a+scripted file, because idleness is the whole point: 'Salmon.Actions.Serve'+tends its nodes only while nothing is waiting in its input, and every line of+a piped script is already queued by the time the first pass finishes. So+these write one command, wait for what the machines say, and only then write+the next.++The waiting is on the report streams, never on a clock: a case that passes+does so as soon as the machines get there.+-}+data Session = Session+    { sessionIn :: !Handle+    , sessionServe :: !(TVar [Serve.Report])+    , sessionNodes :: !(TVar [UpDown.Report Extension])+    }++-- | Run the loop on its own thread over a pipe the body writes into.+withSession :: Track' Spec -> FilePath -> (Session -> IO a) -> IO (a, World Spec Spec)+withSession prog root body = do+    serveTrace <- newTVarIO []+    nodeTrace <- newTVarIO []+    let serveReporter = ReporterM (\rep -> atomically (modifyTVar' serveTrace (rep :)))+    let nodeReporter = ReporterM (\rep -> atomically (modifyTVar' nodeTrace (rep :)))+    (readEnd, writeEnd) <- createPipe+    hSetBuffering writeEnd LineBuffering+    done <- newEmptyMVar+    _ <-+        forkIO $ do+            w <- Serve.serveWith [] Nothing True serveReporter nodeReporter (parseSpec root) (Configure pure) prog readEnd+            putMVar done w+    let session = Session writeEnd serveTrace nodeTrace+    result <- body session+    hPutStrLn writeEnd "quit"+    w <- expect "the loop to exit" (takeMVar done)+    hClose writeEnd+    pure (result, w)++-- | Block until the reports so far (oldest first) satisfy the predicate.+awaitOn :: TVar [a] -> ([a] -> Bool) -> IO ()+awaitOn trace p =+    expect "the reports to say so" $+        atomically $ do+            rs <- readTVar trace+            unless (p (reverse rs)) retry++expect :: String -> IO a -> IO a+expect what act = do+    result <- timeout 20000000 act+    maybe (fail ("timed out waiting for " <> what)) pure result++-- | Whether supervision has started over at least one node.+tending :: [Serve.Report] -> Bool+tending rs = not (null [() | Serve.Tended (Upkeep.Supervising nup _) <- rs, nup > 0])++dones :: [UpDown.Report Extension] -> Int+dones rs = length [() | UpDown.Done _ <- rs]++{- | A node whose effect something else can remove. Its @check@ is the only+thing in the model that can notice, which is exactly the case @check@ was+merged into existence for.+-}+watched :: IORef Bool -> IORef Int -> Track' Spec+watched there attempts = Track (watchedOp there attempts id)++watchedOp :: IORef Bool -> IORef Int -> (Extension -> Extension) -> Spec -> Op+watchedOp there attempts f spec =+    op "watched" nodeps $ \actions ->+        f+            actions+                { ref = mkRef "watched" spec.specNames+                , check = do+                    ok <- readIORef there+                    pure (if ok then Success else Failure "gone")+                , up = do+                    atomicModifyIORef' attempts (\k -> (k + 1, ()))+                    writeIORefTrue there+                }+  where+    writeIORefTrue v = atomicModifyIORef' v (const (True, ()))++{- | A stub node with no @check@ at all — the default 'Immaterial' verdict+almost every builtin in this repository actually has, per+"Salmon.Actions.Serve"'s own note that this is the common case a fix here+has to hold for. Unlike 'watched', nothing here can ever say "already+done"; the only way to tell whether the loop left it alone is to count how+many times @up@ itself ran.+-}+neverRuns :: IORef Int -> Track' Spec+neverRuns attempts = Track $ \spec ->+    op "never-runs" nodeps $ \actions ->+        actions+            { ref = mkRef "never-runs" spec.specNames+            , up = atomicModifyIORef' attempts (\k -> (k + 1, ()))+            }++{- | Like 'neverRuns', but two independently-countered, independently-named+variants selected by the seed's own args ("a" vs. anything else) — so a test+can tell "the node I named" apart from "some other node" by shorthand alone,+which plain 'never-runs' (one shorthand for every seed) cannot.+-}+neverRunsNamed :: IORef Int -> IORef Int -> Track' Spec+neverRunsNamed attemptsA attemptsB = Track $ \spec ->+    let isA = "a" `elem` spec.specNames+     in op (if isA then "never-runs-a" else "never-runs-b") nodeps $ \actions ->+            actions+                { ref = mkRef "never-runs" spec.specNames+                , up = atomicModifyIORef' (if isA then attemptsA else attemptsB) (\k -> (k + 1, ()))+                }++idleLoopTends :: IO ()+idleLoopTends =+    withTempDir $ \root -> do+        there <- newIORef False+        attempts <- newIORef (0 :: Int)+        (_, w) <- withSession (watched there attempts) root $ \session -> do+            hPutStrLn session.sessionIn "up a"+            awaitOn session.sessionServe tending+            assertEqual "the pass brought it up once" 1 =<< readIORef attempts+            -- something else removes the effect; nothing tells the loop+            atomicModifyIORef' there (const (False, ()))+            awaitOn session.sessionNodes (\rs -> dones rs >= 2)+            assertEqual "its own machine put it back" 2 =<< readIORef attempts+        assertEqual+            "and the world still says converged"+            [Converged]+            (fmap nodeConvergence (Map.elems w.worldNodes))++{- | The bug this pinned: 'commitEpoch' skipping its own auto-@converge@ is+not enough on its own, because the idle tending loop ('tendOf') used to+treat any not-yet-'Converged' node as work to do regardless of+@autoconverge@ — so a script that declared, then merely went idle for a+moment before its next command, got the deferred node applied anyway by the+tending loop rather than by the pass. This drives a real idle gap (a+'threadDelay', not a queued script) so the loop actually gets the chance to+tend before asserting it did not.+-}+autoConvergeOffAlsoStopsIdleTending :: IO ()+autoConvergeOffAlsoStopsIdleTending =+    withTempDir $ \root -> do+        there <- newIORef False+        attempts <- newIORef (0 :: Int)+        (_, w) <- withSession (watched there attempts) root $ \session -> do+            hPutStrLn session.sessionIn "autoconverge off"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.AutoConverged False <- rs]))+            hPutStrLn session.sessionIn "up a"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.Declared{} <- rs]))+            -- a real idle gap: enough time for the loop to have started+            -- tending and applied the node, if it were going to.+            threadDelay 300000+            hPutStrLn session.sessionIn "status"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.StatusReport _ _ _ <- rs]))+            assertEqual "the idle loop must not apply a deferred declaration" 0 =<< readIORef attempts+        assertEqual "the node is still pending, not silently converged" [Pending] (fmap nodeConvergence (Map.elems w.worldNodes))++{- | The same property as 'autoConvergeOffAlsoStopsIdleTending', pinned+directly on the node's own 'up' rather than through 'watched''s @check@+detour: 'neverRuns' has no @check@ at all (the ordinary 'Immaterial'+default, not a hand-written "gone" verdict), so there is nothing here that+can claim the effect is already in place — the only way this test could+pass wrongly is if @up@ genuinely never ran, which is the whole point.+-}+autoConvergeOffKeepsAChecklessNodeFromRunning :: IO ()+autoConvergeOffKeepsAChecklessNodeFromRunning =+    withTempDir $ \root -> do+        attempts <- newIORef (0 :: Int)+        (_, w) <- withSession (neverRuns attempts) root $ \session -> do+            hPutStrLn session.sessionIn "autoconverge off"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.AutoConverged False <- rs]))+            hPutStrLn session.sessionIn "up a"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.Declared{} <- rs]))+            -- a real idle gap: enough time for the loop to have started+            -- tending and applied the node, if it were going to.+            threadDelay 300000+            hPutStrLn session.sessionIn "status"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.StatusReport _ _ _ <- rs]))+            assertEqual "up must never have run" 0 =<< readIORef attempts+            -- the deferred work is still there, waiting for an explicit+            -- `converge` — this isn't "up never runs at all", only "not+            -- before I say so".+            hPutStrLn session.sessionIn "converge"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.ConvergeStop{} <- rs]))+            assertEqual "the explicit converge finally runs it, exactly once" 1 =<< readIORef attempts+        assertEqual "and the world now agrees it converged" [Converged] (fmap nodeConvergence (Map.elems w.worldNodes))++{- | The exemption 'tendOf' carves out for a 'managed' node: the convergence+pass ignores such a node categorically (see 'settleManaged'), so idle+tending is its /only/ path to ever start at all. If autoconverge-off also+blocked tending from acting on a not-yet-converged managed node, it could+never come up — no explicit @converge@ would help, since @converge@ never+touches it either. This is the regression a future "just block every+not-yet-converged node uniformly" simplification would introduce.+-}+managedNodeStartsDespiteAutoConvergeOff :: IO ()+managedNodeStartsDespiteAutoConvergeOff =+    withTempDir $ \root -> do+        let ticks = root </> "ticks"+        _ <- withSession (ticker ticks) root $ \session -> do+            hPutStrLn session.sessionIn "autoconverge off"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.AutoConverged False <- rs]))+            hPutStrLn session.sessionIn "up a"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.Declared{} <- rs]))+            -- no explicit `converge` is ever typed: the daemon's only route+            -- up is the idle tending loop, autoconverge notwithstanding.+            _ <- awaitTicks ticks 2+            pure ()+        pure ()++{- | @autoconverge@ is read fresh by 'tendOf' every time tending starts, not+captured at declare time — so turning it back on is enough on its own to+let the idle loop pick up whatever was left pending, with no explicit+@converge@ needed. This is what makes "stack declarations, inspect, then+flip autoconverge back on" as valid a way to resume as typing @converge@.+-}+autoConvergeBackOnLetsTendingCatchUp :: IO ()+autoConvergeBackOnLetsTendingCatchUp =+    withTempDir $ \root -> do+        attempts <- newIORef (0 :: Int)+        (_, w) <- withSession (neverRuns attempts) root $ \session -> do+            hPutStrLn session.sessionIn "autoconverge off"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.AutoConverged False <- rs]))+            hPutStrLn session.sessionIn "up a"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.Declared{} <- rs]))+            threadDelay 300000+            assertEqual "still deferred while autoconverge is off" 0 =<< readIORef attempts+            hPutStrLn session.sessionIn "autoconverge on"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.AutoConverged True <- rs]))+            -- no `converge` typed here: the next idle tick alone must do it+            awaitAttempts attempts 1+        assertEqual "and the world now agrees it converged" [Converged] (fmap nodeConvergence (Map.elems w.worldNodes))++{- | The whole point of printing paths on `status` is that they are usable:+whatever text a node's line shows must itself select that node back out+again via `--select`. Picks the shared root node's path (unique — only one+node in this fixture's graph has the shorthand `serve-spec-root`) rather than+a file's, since the two files share one shorthand and thus one identical+path (see 'ambiguousPathsAreDisambiguatedByRef' for that case).+-}+statusPathsRoundTripAsSelectors :: IO ()+statusPathsRoundTripAsSelectors =+    withTempDir $ \root -> do+        (_, reports, _) <- runServe program root ["up a b", "status"]+        let paths = last [ps | Serve.StatusReport _ _ ps <- reports]+            nodes = last [xs | Serve.StatusReport _ xs _ <- reports]+        rootRef <- case [r | (r, st) <- nodes, st.nodeShorthand == "serve-spec-root"] of+            [r] -> pure r+            rs -> assertFailure ("expected exactly one serve-spec-root node, got " <> show (length rs))+        rootPath <- case Map.lookup rootRef paths of+            Just [p] -> pure p+            other -> assertFailure ("expected exactly one path for the root node, got " <> show other)+        (w2, reports2, _) <- runServe program root ["up a b", "query --select " <> Text.unpack rootPath]+        let selected = last [sel | Serve.QueryReport _ sel _ _ <- reports2]+        assertEqual "the path selected exactly the root node it came from" (Set.singleton rootRef) selected+        assertBool "and the query touched nothing" (Map.size w2.worldNodes > 0)++{- | 'fileOp' gives every file the same shorthand ("file-contents"), so two+files declared under one seed reach the same path in 'Query.pathedRefs' —+printing paths on `status` cannot invent a distinction that was never there.+This is exactly the case @help select@ now documents: fall back to a `#`-Ref+fragment, which is unique because a 'Ref' is content-addressed.+-}+ambiguousPathsAreDisambiguatedByRef :: IO ()+ambiguousPathsAreDisambiguatedByRef =+    withTempDir $ \root -> do+        (_, reports, _) <- runServe program root ["up a b", "status"]+        let paths = last [ps | Serve.StatusReport _ _ ps <- reports]+            nodes = last [xs | Serve.StatusReport _ xs _ <- reports]+            fileRefs = [r | (r, st) <- nodes, st.nodeShorthand == "file-contents"]+        assertEqual "both files are nodes here" 2 (length fileRefs)+        let filePaths = Data.List.nub [p | r <- fileRefs, Just ps <- [Map.lookup r paths], p <- ps]+        assertEqual "and they share the exact same path" 1 (length filePaths)+        (target, other) <- case fileRefs of+            [t, o] -> pure (t, o)+            _ -> assertFailure "expected exactly two file-contents nodes"+        (_, reports2, _) <- runServe program root ["up a b", "query --select #" <> Text.unpack (unRef target)]+        let selected = last [sel | Serve.QueryReport _ sel _ _ <- reports2]+        assertEqual "the #ref pattern selected only its own node" (Set.singleton target) selected+        assertBool "not the other node sharing its path" (not (other `Set.member` selected))++{- | Queuing an instruction for a node has nowhere to deliver it at all+unless a machine exists for it — and 'tendOf' (see its own haddock)+otherwise refuses to start one for anything not-yet-converged while+autoconverge is off, which would make @force@\/@recheck@\/@pause@\/@resume@+silently useless in exactly the state they are most useful in: reviewing a+stack of deferred declarations before committing to a full @converge@. Two+independently-countered nodes here so "only the named one moved" is checked,+not just "the named one moved eventually".+-}+autoConvergeOffForceStillReachesANamedNode :: IO ()+autoConvergeOffForceStillReachesANamedNode =+    withTempDir $ \root -> do+        attemptsA <- newIORef (0 :: Int)+        attemptsB <- newIORef (0 :: Int)+        (_, w) <- withSession (neverRunsNamed attemptsA attemptsB) root $ \session -> do+            hPutStrLn session.sessionIn "autoconverge off"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.AutoConverged False <- rs]))+            hPutStrLn session.sessionIn "up a"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.Declared{} <- rs]))+            hPutStrLn session.sessionIn "up b"+            awaitOn session.sessionServe (\rs -> length [() | Serve.Declared{} <- rs] >= 2)+            -- a real idle gap: enough time for the loop to have started+            -- tending either node, if autoconverge off did not stop it.+            threadDelay 300000+            (a0, b0) <- (,) <$> readIORef attemptsA <*> readIORef attemptsB+            assertEqual "both nodes are still deferred" (0, 0) (a0, b0)+            hPutStrLn session.sessionIn "status"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.StatusReport _ _ _ <- rs]))+            reports <- readTVarIO session.sessionServe+            let nodes = last [xs | Serve.StatusReport _ xs _ <- reports]+            targetRef <- case [r | (r, st) <- nodes, st.nodeShorthand == "never-runs-a"] of+                [r] -> pure r+                rs -> assertFailure ("expected exactly one never-runs-a node, got " <> show (length rs))+            hPutStrLn session.sessionIn ("force --select #" <> Text.unpack (unRef targetRef))+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.Instructed Mailbox.Force n <- rs, n > 0]))+            awaitAttempts attemptsA 1+            -- give the untargeted node the same idle window before checking+            -- it stayed put, rather than a race against 'awaitAttempts'.+            threadDelay 300000+            assertEqual "the untargeted node was left alone" 0 =<< readIORef attemptsB+        assertEqual+            "both still wanted up in the world's own bookkeeping"+            [TurnUp, TurnUp]+            (fmap nodeDirection (Map.elems w.worldNodes))+superviseOffLeavesItAlone =+    withTempDir $ \root -> do+        there <- newIORef False+        attempts <- newIORef (0 :: Int)+        _ <- withSession (watched there attempts) root $ \session -> do+            hPutStrLn session.sessionIn "supervise off"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.Supervised False <- rs]))+            hPutStrLn session.sessionIn "up a"+            awaitOn session.sessionServe (\rs -> length [() | Serve.ConvergeStop _ _ <- rs] >= 1)+            atomicModifyIORef' there (const (False, ()))+            -- there is nothing to wait for, which is the assertion: ask the+            -- loop to do something else and check nothing happened in the+            -- meantime.+            hPutStrLn session.sessionIn "status"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.StatusReport _ _ _ <- rs]))+            assertEqual "nothing put it back" 1 =<< readIORef attempts+            assertBool "and supervision never started" . not . tending+                =<< atomically (reverse <$> readTVar session.sessionServe)+        pure ()++{- | The property the whole 'Salmon.Actions.Upkeep.Kept' machinery exists+for, and the one that cannot be seen anywhere smaller.++@serve@ stands its machines down before every command it is handed, @status@+included. A machine that holds a running process cannot be stood down the way+a one-shot machine is, or typing @status@ would restart every service on the+box — so it survives, and the next supervisor adopts it. And when the node+stops being wanted, it has to be let go /before/ the down pass starts+removing what it stood on.++Both halves are asserted the same way: whether the process is still writing.+-}+ownedProcessSurvivesCommands :: IO ()+ownedProcessSurvivesCommands =+    withTempDir $ \root -> do+        let ticks = root </> "ticks"+        (_, w) <- withSession (ticker ticks) root $ \session -> do+            hPutStrLn session.sessionIn "up a"+            awaitOn session.sessionServe (\rs -> length [() | Serve.ConvergeStop _ _ <- rs] >= 1)+            -- it is running+            n0 <- awaitTicks ticks 2+            -- a read-only command: the machines stand down, but not this one+            hPutStrLn session.sessionIn "status"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.StatusReport _ _ _ <- rs]))+            n1 <- awaitTicks ticks (n0 + 2)+            assertBool "it kept running across the command" (n1 > n0)+            -- ...and now nothing wants it+            hPutStrLn session.sessionIn "clear"+            awaitOn session.sessionServe (\rs -> length [() | Serve.ConvergeStop _ _ <- rs] >= 2)+            n2 <- countTicks ticks+            threadDelay 400000+            n3 <- countTicks ticks+            assertEqual "and stopped once nothing wanted it" n2 n3+        assertEqual+            "the world records it as having been dealt with"+            []+            [st.nodeConvergence | st <- Map.elems w.worldNodes, st.nodeConvergence /= Converged]++{- | Milestone 9 under @serve@, which is the one place its neighbourhood+refresh can be seen at all.++A machine holding a process is /adopted/ by every new supervisor rather than+restarted (see 'Salmon.Actions.Upkeep.Kept'), and every supervisor is new: the+loop stands its machines down before each command it is handed. So an adopted+machine that went on watching the maps of the supervisor that started it+would stop noticing its config change after the very first command — which is+to say, immediately and silently.++Both halves are asserted: that the command did not restart it (the spawn+count is unchanged across a @status@), and that it still followed its config+afterwards.+-}+adoptedDaemonFollowsItsConfig :: IO ()+adoptedDaemonFollowsItsConfig =+    withTempDir $ \root -> do+        there <- newIORef False+        attempts <- newIORef (0 :: Int)+        spawns <- newTVarIO (0 :: Int)+        let ticks = root </> "ticks"+        _ <- withSession (tickerOnConfig ticks there attempts spawns) root $ \session -> do+            hPutStrLn session.sessionIn "up a"+            awaitOn session.sessionServe (\rs -> length [() | Serve.ConvergeStop _ _ <- rs] >= 1)+            awaitSpawns spawns 1+            -- a read-only command, after which a different supervisor is+            -- tending the same still-running process+            hPutStrLn session.sessionIn "status"+            awaitOn session.sessionServe (\rs -> supervisings rs >= 2)+            assertEqual "the command adopted it rather than restarting it" 1 =<< readTVarIO spawns+            -- now the config underneath it is taken away+            atomicModifyIORef' there (const (False, ()))+            awaitSpawns spawns 2+            assertEqual "the config node had put its own effect back first" 2 =<< readIORef attempts+        pure ()++-- | How many times supervision has (re)started over at least one node.+supervisings :: [Serve.Report] -> Int+supervisings rs = length [() | Serve.Tended (Upkeep.Supervising _ _) <- rs]++awaitSpawns :: TVar Int -> Int -> IO ()+awaitSpawns v n =+    expect ("the process to have been started " <> show n <> " time(s)") $+        atomically (readTVar v >>= \k -> unless (k >= n) retry)++{- | A process standing on a configuration node that declares+'Salmon.Op.Supervision.RestForOne', which is the shape the whole strategy+exists for: the config is rewritten, so what reads it has to be bounced.+-}+tickerOnConfig :: FilePath -> IORef Bool -> IORef Int -> TVar Int -> Track' Spec+tickerOnConfig path there attempts spawns = Track $ \spec ->+    let cfg = watchedOp there attempts restForOne spec+     in op "ticker" (deps [cfg]) $ \actions ->+            actions+                { ref = Daemon.daemonRef (tickerDaemon path)+                , managed = Just $ \out -> do+                    atomically (modifyTVar' spawns (+ 1))+                    Daemon.runDaemon silent (tickerDaemon path) out+                , up = throwIO (userError "the ticker cannot be brought up by a one-shot pass")+                }+  where+    restForOne x = x{dynamics = [supervised defaultSupervision{supStrategy = RestForOne}]}++{- | One node, which owns a process that writes a line every 50ms.++@up@ throwing is 'Salmon.Builtin.Nodes.Daemon.daemon''s own convention and is+what makes the test meaningful: if @serve@ ever routed this node through a+convergence pass instead of to a machine, the pass would fail loudly rather+than quietly do nothing.+-}+ticker :: FilePath -> Track' Spec+ticker path = Track (const (Daemon.daemon silent (tickerDaemon path)))++tickerDaemon :: FilePath -> Daemon.Daemon+tickerDaemon path =+    Daemon.defaultDaemon+        "ticker"+        (proc "/bin/sh" ["-c", "while true; do echo tick >> " <> path <> "; sleep 0.05; done"])++countTicks :: FilePath -> IO Int+countTicks path = do+    there <- doesFileExist path+    if not there+        then pure 0+        else do+            contents <- try (readFile path) :: IO (Either IOException String)+            pure (either (const 0) (length . lines) contents)++-- | Block until the file has at least this many lines, and say how many.+awaitTicks :: FilePath -> Int -> IO Int+awaitTicks path n = expect ("the process to write " <> show n <> " line(s)") go+  where+    go = do+        k <- countTicks path+        if k >= n then pure k else threadDelay 25000 >> go++-- | Block until an attempt counter has reached at least this many — the way+-- a case confirms the /idle tending loop/, not just the declaring pass, has+-- had a go at a node.+awaitAttempts :: IORef Int -> Int -> IO ()+awaitAttempts ref n = expect ("at least " <> show n <> " attempt(s)") go+  where+    go = do+        k <- readIORef ref+        if k >= n then pure () else threadDelay 25000 >> go++{- | (R3): a node's own last word about itself is visible after its machine+stands down, not lost the moment 'Salmon.Actions.Serve.stopTending' drops+the 'Salmon.Actions.Upkeep.Supervisor' holding its+'Salmon.Op.Status.Status'. The node here never recovers, so the idle tending+loop — not the declaring pass — is what produces the failing status this+pins: @up a@ fails synchronously ('Errored'), the idle loop picks it up+because it is not yet 'Converged', and every retry settles a fresh+'Salmon.Actions.UpDown.Failure' (with its own narration already in the+output ring) into the 'Salmon.Op.Status.Status' that @status@ then reads.+-}+statusShowsAFailingNodesOutput :: IO ()+statusShowsAFailingNodesOutput =+    withTempDir $ \root -> do+        attempts <- newIORef (0 :: Int)+        _ <- withSession (flakyForever attempts) root $ \session -> do+            hPutStrLn session.sessionIn "up a"+            awaitOn session.sessionServe (\rs -> length [() | Serve.ConvergeStop _ _ <- rs] >= 1)+            -- one retry beyond the declaring pass's own attempt, so the+            -- failing status this pins is genuinely the tending machine's.+            awaitAttempts attempts 2+            hPutStrLn session.sessionIn "status"+            awaitOn session.sessionServe (\rs -> any isFailingSnapshot (flakyStates rs))+            rs <- atomically (reverse <$> readTVar session.sessionServe)+            case flakyStates rs of+                (st : _) -> case st.nodeStatus of+                    Just ms -> do+                        assertBool "remembered as a failure" (isFailure (MachineStatus.statusCheck ms))+                        assertBool+                            "and its last output was captured"+                            (not (null (MachineStatus.ringLines (MachineStatus.statusOutput ms))))+                    Nothing -> assertFailure "expected a status snapshot for the failing node"+                [] -> assertFailure "expected the flaky node in a status report"+        pure ()+  where+    flakyStates :: [Serve.Report] -> [NodeState]+    flakyStates rs =+        [st | Serve.StatusReport _ xs _ <- rs, (_, st) <- xs, st.nodeShorthand == "flaky-forever"]++    isFailingSnapshot :: NodeState -> Bool+    isFailingSnapshot st = maybe False (isFailure . MachineStatus.statusCheck) st.nodeStatus++    isFailure :: CheckResult -> Bool+    isFailure (Failure _) = True+    isFailure _ = False++{- | (R2). @force@ posts straight into a node's mailbox once its next+machine exists, and the FSM already treats that as "run @up@ regardless of+what the check says" (see @Test.UpkeepSpec@'s "Force restarts it rather than+skipping it"). What that leaves untested is the command-language plumbing+that gets an instruction there at all: parse the command, resolve the+selection against the world, queue it, and deliver it the moment tending+next starts.++The node here never goes unsatisfied (@there@ stays 'True' throughout), so a+second @up@ can only be explained by @force@ itself — not by the ordinary+"the effect went away" path 'idleLoopTends' already covers.+-}+forceOverridesASatisfiedCheck :: IO ()+forceOverridesASatisfiedCheck =+    withTempDir $ \root -> do+        there <- newIORef False+        attempts <- newIORef (0 :: Int)+        _ <- withSession (watched there attempts) root $ \session -> do+            hPutStrLn session.sessionIn "up a"+            awaitOn session.sessionServe tending+            assertEqual "the pass brought it up once" 1 =<< readIORef attempts+            hPutStrLn session.sessionIn "force"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.Instructed _ n <- rs, n > 0]))+            awaitAttempts attempts 2+            assertBool "the check never had a reason to fail" =<< readIORef there+        pure ()++{- | (R2). @pause@ stops a node's machine reacting to its effect going away;+@resume@ lets it react again. Both travel the same queue-then-deliver path+'forceOverridesASatisfiedCheck' pins, and are worth their own case because an+instruction whose whole effect is "do nothing" is otherwise invisible: this+is the one place a wrong delivery (skipped, or delivered to the wrong+machine) would show up as a spurious @up@ instead of a missing one.+-}+pauseThenResume :: IO ()+pauseThenResume =+    withTempDir $ \root -> do+        there <- newIORef False+        attempts <- newIORef (0 :: Int)+        _ <- withSession (watched there attempts) root $ \session -> do+            hPutStrLn session.sessionIn "up a"+            awaitOn session.sessionServe tending+            assertEqual "the pass brought it up once" 1 =<< readIORef attempts+            hPutStrLn session.sessionIn "pause"+            awaitOn session.sessionServe (\rs -> not (null [() | Serve.Tended (Upkeep.Paused _) <- rs]))+            atomicModifyIORef' there (const (False, ()))+            threadDelay 300000+            assertEqual "paused, so nothing put it back" 1 =<< readIORef attempts+            hPutStrLn session.sessionIn "resume"+            awaitAttempts attempts 2+        pure ()++-------------------------------------------------------------------------------+-- (I6): a maintained Ref whose content changed goes 'Serve.Stale', not+-- silently 'Serve.Converged'.++-- | Unlike 'Spec' above, content is independent of the declared name — the+-- whole point here is to redeclare the *same* path with *different*+-- content, which 'Spec'\/'program' cannot express (its content is+-- deterministic from the file name).+data GreetingSpec = GreetingSpec+    { greetingPath :: FilePath+    , greetingText :: Text+    }+    deriving (Eq, Show, Generic)++instance ToJSON GreetingSpec+instance FromJSON GreetingSpec++parseGreetingSpec :: [String] -> Either Text GreetingSpec+parseGreetingSpec [path, txt] = Right (GreetingSpec path (Text.pack txt))+parseGreetingSpec _ = Left "expected: <path> <text>"++greetingProgram :: Track' GreetingSpec+greetingProgram = Track $ \spec -> FS.filecontents (FS.FileContents spec.greetingPath spec.greetingText)++runGreetingServe :: [String] -> IO (World GreetingSpec GreetingSpec, [Serve.Report], [UpDown.Report Extension])+runGreetingServe script = do+    (serveReporter, readServeReports) <- capture+    (nodeReporter, readNodeReports) <- capture+    w <-+        withScript script $+            Serve.serveWith [] Nothing True serveReporter nodeReporter parseGreetingSpec (Configure pure) greetingProgram+    (,,) w <$> readServeReports <*> readNodeReports++assertFileContentIs :: FilePath -> String -> IO ()+assertFileContentIs path expected = do+    got <- Prelude.readFile path+    assertEqual (path <> ": content") expected got++{- | The scenario @salmon-ops-serve-fixture@'s own haddock uses to demonstrate+(I6) — re-declaring a config file with new content reports @converging (0+down, 0 up)@ and (before this) relied entirely on the tending machine's own+next look to apply it. A piped script is deliberately never supervised (see+"Salmon.Actions.Serve"'s own module haddock: idle-only tending is what keeps+@serve < script@ a deterministic sequence of passes), so this is also the+sharpest possible demonstration of the bug: under the old behaviour, this+exact test would leave the file saying "hello" forever, since nothing here+ever gives a tending machine a chance to run.++'FS.filecontents' backs onto 'Text.Text', which has a+'Salmon.Builtin.Nodes.Filesystem.EncodeFileContents' 'contentFingerprint'+(see (I6) in @specs\/per-node-state-machines-remaining.md@), so the second+declaration's 'notes' differ from the first's and 'Serve.record' marks the+'Ref' 'Serve.Stale' rather than leaving it 'Serve.Converged' — which is what+lets the second 'Serve.ConvergeStart' actually have a node to apply, instead+of the @(0, 0)@ a fully-converged, untouched graph would report.+-}+reDeclareWithChangedContentIsAppliedByThePass :: IO ()+reDeclareWithChangedContentIsAppliedByThePass =+    withTempDir $ \root -> do+        let path = root </> "daemon.conf"+        (w, reports, _) <-+            runGreetingServe ["up " <> path <> " hello", "only " <> path <> " goodbye"]+        assertFileContentIs path "goodbye"+        assertEqual+            "the first declaration converges the file and its enclosing directory; the second, only the changed file"+            [(0, 2), (0, 1)]+            (convergeStarts reports)+        assertAllConverged TurnUp w
+ test/Test/ServeTlsSpec.hs view
@@ -0,0 +1,725 @@+{-# LANGUAGE DeriveGeneric #-}++{- | Layer 1 coverage for milestone 8 of @specs\/generic-server.md@: the+HTTP surface over TCP, which is only ever TLS with a bearer token+('Salmon.Actions.Serve.Http.withHttpServerOn' with a 'Http.BindTls').++The fixture is a key and a self-signed certificate made in a temp dir by+the tree's own 'Salmon.Builtin.Nodes.Certificates' nodes — the spec's+"the @Certificates@ nodes can mint the cert; this is what they are for" —+which run as any user since they only write under the directory they are+given; @openssl@ has to be on the machine, and the group skips loudly+without it. The server binds @127.0.0.1:0@ and the test reads the port it+got. The claims: over TLS with the token, @\/status@ answers; without the+token, or with a wrong one, @401@ and nothing else; a plain-HTTP client on+the same port is refused before any route is reached; @\/events@ streams+to a client with the token; and the unix socket served by the same+'Http.Server' answers with no token at all. Plus the pure half: the option+validation the binary exits on, and the token file's own refusals.+-}+module Test.ServeTlsSpec (tests) where++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.STM (atomically, check, modifyTVar', newTVarIO, readTVar, readTVarIO)+import Control.Exception (SomeException, try)+import Control.Monad (forM_, unless, void)+import Data.Aeson (FromJSON, ToJSON, Value (..), eitherDecode)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Lazy.Char8 as LChar8+import Data.Foldable (toList)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+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.X509.CertificateStore as X509+import GHC.Generics (Generic)+import qualified Network.Connection as Connection+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Client.Internal (makeConnection)+import qualified Network.HTTP.Client.TLS as HTTPS+import qualified Network.HTTP.Types as HTTP+import qualified Network.Socket as Socket+import qualified Network.Socket.ByteString as SocketBS+import qualified Network.TLS as TLS+import System.FilePath ((</>))+import System.IO (Handle, hClose)+import System.Posix.Files (setFileMode)+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 qualified Salmon.Builtin.CommandLine as CLI+import qualified Salmon.Client.Http as Client+import Salmon.Client.Model (Event (..))+import Salmon.Builtin.Extension (Track', deps, down, help, ignoreTrack, nodeps, op, ref, up)+import qualified Salmon.Builtin.Nodes.Certificates as Certs+import Salmon.Op.Configure (Configure (..))+import Salmon.Op.Ref (mkRef)+import Salmon.Op.Track (Track (..))+import Salmon.Reporter (contramap, silent)+import qualified Salmon.Reporter.Tagged as Tagged++import Test.Harness (capture, privatePipe, requireExecutable, runUp, withTempDir)++tests :: TestTree+tests =+    testGroup+        "Salmon.Actions.Serve.Http over TCP (TLS + token)"+        [ testGroup+            "option validation (pure)"+            [ testCase "nothing given is no listener" $+                assertEqual "none" (Right Nothing) (CLI.validateTcpOptions CLI.noTcp)+            , testCase "--http-tcp alone names all three missing flags" $+                case CLI.validateTcpOptions CLI.noTcp{CLI.tcpBind = Just "127.0.0.1:8443"} of+                    Left err -> forM_ ["--tls-cert", "--tls-key", "--token-file"] $ \flag ->+                        assertBool (Text.unpack err <> " names " <> Text.unpack flag) (flag `Text.isInfixOf` err)+                    Right r -> assertFailure ("accepted: " <> show r)+            , testCase "--http-tcp with a certificate names the two still missing" $+                case CLI.validateTcpOptions CLI.noTcp{CLI.tcpBind = Just "127.0.0.1:8443", CLI.tcpCert = Just "/c.pem"} of+                    Left err -> do+                        assertBool "not the one given" (not ("--tls-cert" `Text.isInfixOf` err))+                        assertBool "the key" ("--tls-key" `Text.isInfixOf` err)+                        assertBool "the token" ("--token-file" `Text.isInfixOf` err)+                    Right r -> assertFailure ("accepted: " <> show r)+            , testCase "all four is a listener" $+                assertEqual+                    "parsed"+                    (Right (Just (CLI.TcpListen "127.0.0.1" 8443 "/c.pem" "/k.pem" "/t" Http.defaultSessionPolicy)))+                    (CLI.validateTcpOptions (allFour "127.0.0.1:8443"))+            , testCase "an IPv6 address in brackets" $+                assertEqual+                    "parsed"+                    (Right (Just (CLI.TcpListen "::1" 8443 "/c.pem" "/k.pem" "/t" Http.defaultSessionPolicy)))+                    (CLI.validateTcpOptions (allFour "[::1]:8443"))+            , testCase "a port alone is refused: the host is spelled, 0.0.0.0 included" $+                assertBool "refused" (isLeft (CLI.validateTcpOptions (allFour ":8443")))+            , testCase "a bad port is refused" $ do+                assertBool "not a number" (isLeft (CLI.validateTcpOptions (allFour "127.0.0.1:https")))+                assertBool "too big" (isLeft (CLI.validateTcpOptions (allFour "127.0.0.1:70000")))+                assertBool "no colon" (isLeft (CLI.validateTcpOptions (allFour "127.0.0.1")))+            , testCase "the three files without --http-tcp do nothing on their own, and say so" $+                case CLI.validateTcpOptions CLI.noTcp{CLI.tcpTokenFile = Just "/t"} of+                    Left err -> assertBool (Text.unpack err) ("--http-tcp" `Text.isInfixOf` err)+                    Right r -> assertFailure ("accepted: " <> show r)+            , testCase "--session-lifetime/--session-idle: defaults, 0 is off, negative refused, nothing without --http-tcp" $ do+                let policyOf o = fmap (fmap (.tcpSessionPolicy)) (CLI.validateTcpOptions o)+                    base = allFour "127.0.0.1:8443"+                assertEqual "defaults" (Right (Just Http.defaultSessionPolicy)) (policyOf base)+                assertEqual "given" (Right (Just (Http.SessionPolicy (Just 60) (Just 5)))) (policyOf base{CLI.tcpSessionLifetime = Just 60, CLI.tcpSessionIdle = Just 5})+                assertEqual "0 is off" (Right (Just (Http.SessionPolicy Nothing (Just 3600)))) (policyOf base{CLI.tcpSessionLifetime = Just 0})+                case policyOf base{CLI.tcpSessionIdle = Just (-1)} of+                    Left err -> assertBool (Text.unpack err) ("--session-idle" `Text.isInfixOf` err)+                    Right r -> assertFailure ("a negative limit was accepted: " <> show r)+                case CLI.validateTcpOptions CLI.noTcp{CLI.tcpSessionLifetime = Just 60} of+                    Left err -> assertBool (Text.unpack err) ("--session-lifetime" `Text.isInfixOf` err && "--http-tcp" `Text.isInfixOf` err)+                    Right r -> assertFailure ("accepted: " <> show r)+            ]+        , testGroup+            "sessions (a clock the test moves)"+            [ testCase "the lifetime ends a session however busy; the idle limit ends one nobody uses" sessionLimits+            , testCase "an open stream holds the idle limit off but not the lifetime, which ends the stream's wait" streamPresence+            , testCase "signing in sweeps every ended session, so the store holds what is live" signInSweeps+            ]+        , testGroup+            "the token file"+            [ testCase "trimmed, and refused when readable by others or empty" $+                withTempDir $ \dir -> do+                    let path = dir </> "token"+                    ByteString.writeFile path "  s3cret\n"+                    setFileMode path 0o644+                    assertEqual "world-readable" (Left (Http.TokenFileReadable path)) =<< Http.readTokenFile path+                    setFileMode path 0o600+                    assertEqual "trimmed" (Right "s3cret") =<< Http.readTokenFile path+                    ByteString.writeFile path "\n \n"+                    assertEqual "empty" (Left (Http.TokenFileEmpty path)) =<< Http.readTokenFile path+            , testCase "sameSecret is equality" $ do+                assertBool "equal" (Http.sameSecret "abc" "abc")+                assertBool "differ" (not (Http.sameSecret "abc" "abd"))+                assertBool "prefix" (not (Http.sameSecret "abc" "abcd"))+                assertBool "empty vs not" (not (Http.sameSecret "" "a"))+                assertBool "both empty" (Http.sameSecret "" "")+            ]+        , testGroup+            "over the wire"+            [ testCase "with the token over TLS, /status answers; without or wrong, 401; plain TCP is refused; /events streams; the unix socket needs none" $+                requireExecutable "openssl" overTheWire+            , testCase "a browser: / redirects to /auth, the token posted there is a session cookie, and the cookie is as good as the token" $+                requireExecutable "openssl" signingIn+            , testCase "Salmon.Client.Http over TLS: pinned certificate and token read, command and stream; wrong token, unpinned certificate and plain http are refused" $+                requireExecutable "openssl" typedClient+            , testCase "signing out: /auth/session says whether, logout expires the cookie, revokes the session and cuts the stream it opened" $+                requireExecutable "openssl" signingOut+            , testCase "a session's lifetime: the cookie's Max-Age, the open stream cut on time, then 401 and /auth?ended" $+                requireExecutable "openssl" sessionExpiry+            ]+        ]+  where+    allFour hostPort = CLI.TcpOptions (Just hostPort) (Just "/c.pem") (Just "/k.pem") (Just "/t") Nothing Nothing+    isLeft (Left _) = True+    isLeft _ = False++-------------------------------------------------------------------------------+-- the thing served: counters per node name++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 "tls-root" (deps (fmap nodeOp spec.specNames)) $ \actions ->+        actions{ref = mkRef "tls-root" spec.specNames, help = "the root of " <> Text.pack (unwords spec.specNames)}+  where+    nodeOp name =+        op "tls-node" nodeps $ \actions ->+            actions+                { ref = mkRef "tls-node" name+                , help = "node " <> Text.pack name+                , up = atomicModifyIORef' upsRef (\m -> (Map.insertWith (+) name 1 m, ()))+                , down = pure ()+                }++-------------------------------------------------------------------------------+-- the fixture: a key and a self-signed certificate, by the tree's own nodes++-- | The name the certificate is issued for, and the one the client asks for.+serverName :: Text+serverName = "localhost"++data Material = Material+    { materialCert :: FilePath+    , materialKey :: FilePath+    }++{- | Mint them under the directory through 'Certs.certificateAuthority' —+a self-signed certificate naming 'serverName', made the way a recipe would.+Not 'Certs.selfSign': @openssl x509 -req -signkey@ (and @-CA@, so+'Certs.caSign' too) writes an X.509 __v1__ certificate, which the+@crypton-x509-validation@ a Haskell client verifies with rejects outright+(@LeafNotV3@) however OpenSSL-based clients take it; @req -x509@ writes v3.+-}+mintMaterial :: FilePath -> IO Material+mintMaterial dir = do+    let key = Certs.Key Certs.RSA2048 dir "server.key"+        ca = Certs.CertificateAuthority key (dir </> "server.pem") (Certs.Domain serverName) 30+    ok <- runUp (Certs.certificateAuthority silent ignoreTrack ca)+    unless ok (assertFailure "the certificate nodes did not come up")+    pure (Material ca.caCertPath (Certs.keyPath key))++-------------------------------------------------------------------------------+-- a running loop with one server on two listeners++token :: ByteString.ByteString+token = "correct-horse-battery-staple"++data Running = Running+    { runningStdin :: Handle+    , runningCert :: FilePath+    , runningWorld :: MVar (World Spec Spec)+    , runningUnixPath :: FilePath+    , runningPort :: Int+    , runningTls :: HTTP.Manager+    -- ^ trusts exactly the minted certificate+    , runningUnix :: HTTP.Manager+    }++withRunning :: (Running -> IO a) -> IO a+withRunning = withRunningWith Http.defaultSessionPolicy++withRunningWith :: Http.SessionPolicy -> (Running -> IO a) -> IO a+withRunningWith policy act =+    withTempDir $ \dir -> do+        material <- mintMaterial (dir </> "tls")+        let unixPath = dir </> "serve.http"+        (stdinR, stdinW) <- privatePipe+        worldVar <- newEmptyMVar+        (own, _) <- capture+        upsRef <- newIORef Map.empty+        let binds =+                [ Http.BindUnix unixPath+                , Http.BindTls (Http.TlsBind "127.0.0.1" 0 material.materialCert material.materialKey token policy)+                ]+        Http.withHttpServerOn Events.defaultConfig binds "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+            bound <- readTVarIO (Http.serverBoundTcp server)+            port <- case bound of+                [Socket.SockAddrInet p _] -> pure (fromIntegral p)+                other -> assertFailure ("not one IPv4 address bound: " <> show other)+            tlsManager <- trustingManager material.materialCert+            unixManager <- unixSocketManager unixPath+            r <- act (Running stdinW material.materialCert worldVar unixPath port tlsManager unixManager)+            _ <- try (hClose stdinW) :: IO (Either IOError ())+            ended <- timeout (10 * 1000000) (takeMVar worldVar)+            case ended of+                Nothing -> assertFailure "the loop did not end"+                Just _ -> pure r++{- | An @http-client@ manager whose TLS trusts only the minted certificate,+verifying the chain and the name as a real client would (so a server+answering with any other certificate fails the handshake); the request+names 'serverName', which resolves to the loopback the server bound.+-}+trustingManager :: FilePath -> IO HTTP.Manager+trustingManager certFile = do+    mstore <- X509.readCertificateStore certFile+    store <- maybe (assertFailure ("no certificate read from " <> certFile)) pure mstore+    let base = TLS.defaultParamsClient (Text.unpack serverName) ""+        params = base{TLS.clientShared = base.clientShared{TLS.sharedCAStore = store}}+    HTTP.newManager (HTTPS.mkManagerSettings (Connection.TLSSettings params) Nothing)++unixSocketManager :: FilePath -> IO HTTP.Manager+unixSocketManager path =+    HTTP.newManager+        HTTP.defaultManagerSettings+            { HTTP.managerRawConnection = pure $ \_ _ _ -> do+                sock <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol+                Socket.connect sock (Socket.SockAddrUnix path)+                makeConnection (SocketBS.recv sock 4096) (SocketBS.sendAll sock) (Socket.close sock)+            }++-- | A request over TLS to the bound port, with the given @Authorization@ if any.+tlsRequest :: Running -> Maybe ByteString.ByteString -> String -> IO HTTP.Request+tlsRequest running auth route = do+    req <- HTTP.parseRequest ("https://" <> Text.unpack serverName <> ":" <> show (runningPort running) <> route)+    pure req{HTTP.requestHeaders = [(HTTP.hAuthorization, a) | Just a <- [auth]]}++bearer :: ByteString.ByteString -> Maybe ByteString.ByteString+bearer t = Just ("Bearer " <> t)++exchange :: HTTP.Manager -> HTTP.Request -> IO (Int, Value)+exchange manager req = do+    r <- timeout (10 * 1000000) (HTTP.httpLbs req manager)+    case r of+        Nothing -> assertFailure ("no answer within 10s to " <> show (HTTP.path req))+        Just resp ->+            case eitherDecode (HTTP.responseBody resp) of+                Left err -> assertFailure ("not JSON: " <> err <> ": " <> LChar8.unpack (HTTP.responseBody resp))+                Right v -> pure (HTTP.statusCode (HTTP.responseStatus resp), v)++textAt :: [Text] -> Value -> Maybe Text+textAt [] (String t) = Just t+textAt (k : ks) (Object o) = KeyMap.lookup (Key.fromText k) o >>= textAt ks+textAt _ _ = Nothing++field :: Text -> Value -> Maybe Value+field k (Object o) = KeyMap.lookup (Key.fromText k) o+field _ _ = Nothing++-------------------------------------------------------------------------------++overTheWire :: IO ()+overTheWire =+    withRunning $ \running -> do+        -- a command over TLS with the token: handled, and answered with its reports+        post <- tlsRequest running (bearer token) "/command"+        (pcode, pv) <- exchange (runningTls running) post{HTTP.method = "POST", HTTP.requestHeaders = HTTP.requestHeaders post ++ [(HTTP.hContentType, "text/plain")], HTTP.requestBody = HTTP.RequestBodyLBS "supervise off"}+        assertEqual "sync command over TLS" 200 pcode+        assertBool ("an array of reports: " <> show pv) (case pv of Array _ -> True; _ -> False)+        up <- tlsRequest running (bearer token) "/command"+        (ucode, _) <- exchange (runningTls running) up{HTTP.method = "POST", HTTP.requestHeaders = HTTP.requestHeaders up ++ [(HTTP.hContentType, "text/plain")], HTTP.requestBody = HTTP.RequestBodyLBS "up n1 n2"}+        assertEqual "up over TLS" 200 ucode++        -- a read with the token+        (code, v) <- exchange (runningTls running) =<< tlsRequest running (bearer token) "/status"+        assertEqual "/status with the token" 200 code+        assertEqual "kind" (Just "status") (textAt ["kind"] v)+        assertEqual "the declared nodes are there" 3 (length (maybe [] arrayOf (field "nodes" v)))++        -- without the token, and with a wrong one: 401 on every route+        forM_ ["/status", "/dag", "/history", "/help/seed", "/events", "/nope"] $ \route -> do+            (c0, v0) <- exchange (runningTls running) =<< tlsRequest running Nothing route+            assertEqual ("no token on " <> route) 401 c0+            assertBool ("an error object on " <> route) (field "error" v0 /= Nothing)+            (c1, _) <- exchange (runningTls running) =<< tlsRequest running (bearer "wrong") route+            assertEqual ("wrong token on " <> route) 401 c1+            (c2, _) <- exchange (runningTls running) =<< tlsRequest running (Just ("Basic " <> token)) route+            assertEqual ("not a bearer on " <> route) 401 c2+            (c3, _) <- exchange (runningTls running) =<< tlsRequest running (bearer (token <> "x")) route+            assertEqual ("a longer token on " <> route) 401 c3+        -- and a refused command is not queued: the world is unchanged+        deny <- tlsRequest running Nothing "/command"+        (dcode, _) <- exchange (runningTls running) deny{HTTP.method = "POST", HTTP.requestBody = HTTP.RequestBodyLBS "up n3"}+        assertEqual "command without the token" 401 dcode+        (_, after) <- exchange (runningTls running) =<< tlsRequest running (bearer token) "/status"+        assertEqual "n3 was never declared" 3 (length (maybe [] arrayOf (field "nodes" after)))++        -- plain TCP on the same port: refused before any route is reached+        plain <- plainRequest (runningPort running) "GET /status HTTP/1.1\r\nHost: localhost\r\nAuthorization: Bearer correct-horse-battery-staple\r\n\r\n"+        assertBool ("plain HTTP is refused, not answered: " <> show plain) (plainRefused plain)++        -- /events with the token streams: the first frame carries an event+        ev <- tlsRequest running (bearer token) "/events?since=0"+        HTTP.withResponse ev (runningTls running) $ \resp -> do+            assertEqual "/events with the token" 200 (HTTP.statusCode (HTTP.responseStatus resp))+            assertEqual "content type" (Just "text/event-stream") (lookup HTTP.hContentType (HTTP.responseHeaders resp))+            frame <- readUntilData (HTTP.responseBody resp) ByteString.empty+            assertBool ("an event replayed: " <> Char8.unpack frame) ("data: {" `ByteString.isInfixOf` frame)++        -- the unix socket served by the same server: no token, same world+        ureq <- HTTP.parseRequest "http://salmon/status"+        (ucode', uv) <- exchange (runningUnix running) ureq+        assertEqual "/status on the unix socket without a token" 200 ucode'+        assertEqual "the same nodes" 3 (length (maybe [] arrayOf (field "nodes" uv)))+        -- and one sequence of numbers across the two listeners+        (_, tv) <- exchange (runningTls running) =<< tlsRequest running (bearer token) "/status"+        assertEqual "one counter" (field "seq" uv) (field "seq" tv)+  where+    arrayOf (Array xs) = toList xs+    arrayOf _ = []++{- | The browser's path to the UI over TCP, with redirects not followed so+each hop is visible: @/@ sends a client with no credential to @/auth@, a+wrong token posted there is refused and mints nothing, the right one is a+@303@ back to @/@ with a cookie that then stands in for the bearer header on+every route — the page, the reads, a command, the event stream — while a+cookie the listener never minted is refused like no credential at all. On+the unix socket, @/auth@ has nothing to do and sends the browser to @/@.+-}+signingIn :: IO ()+signingIn =+    withRunning $ \running -> do+        let tls = runningTls running+        (rcode, rheaders, _) <- raw tls =<< tlsRequest running Nothing "/"+        assertEqual "/ without a credential" 303 rcode+        assertEqual "redirected to the form" (Just "/auth") (lookup HTTP.hLocation rheaders)++        (fcode, fheaders, fbody) <- raw tls =<< tlsRequest running Nothing "/auth"+        assertEqual "the form" 200 fcode+        assertEqual "as HTML" (Just "text/html; charset=utf-8") (lookup HTTP.hContentType fheaders)+        assertBool "a token field" ("name=\"token\"" `ByteString.isInfixOf` LChar8.toStrict fbody)++        (wcode, wheaders, wbody) <- raw tls =<< login running "not-it"+        assertEqual "a wrong token" 401 wcode+        assertEqual "mints nothing" Nothing (lookup "Set-Cookie" wheaders)+        assertBool "and says so" ("not the token" `ByteString.isInfixOf` LChar8.toStrict wbody)++        (lcode, lheaders, _) <- raw tls =<< login running token+        assertEqual "the right token" 303 lcode+        assertEqual "back to the page" (Just "/") (lookup HTTP.hLocation lheaders)+        setCookie <- maybe (assertFailure "no cookie") pure (lookup "Set-Cookie" lheaders)+        forM_ ["HttpOnly", "Secure", "SameSite=Strict", "Path=/"] $ \attr ->+            assertBool ("cookie is " <> Char8.unpack attr <> ": " <> Char8.unpack setCookie) (attr `ByteString.isInfixOf` setCookie)+        let cookie = Char8.takeWhile (/= ';') setCookie+        assertBool ("the cookie is not the token: " <> Char8.unpack cookie) (not (token `ByteString.isInfixOf` cookie))++        let withCookie c route = do+                req <- tlsRequest running Nothing route+                pure req{HTTP.requestHeaders = [(HTTP.hCookie, c)]}+        (pcode, _, pbody) <- raw tls =<< withCookie cookie "/"+        assertEqual "the page with the cookie" 200 pcode+        assertBool "is the UI" ("ui/ui.js" `ByteString.isInfixOf` LChar8.toStrict pbody)+        (scode, _) <- exchange tls =<< withCookie ("other=1; " <> cookie) "/status"+        assertEqual "a read with the cookie among others" 200 scode+        post <- withCookie cookie "/command"+        (ccode, _) <- exchange tls post{HTTP.method = "POST", HTTP.requestHeaders = HTTP.requestHeaders post ++ [(HTTP.hContentType, "text/plain")], HTTP.requestBody = HTTP.RequestBodyLBS "supervise off"}+        assertEqual "a command with the cookie" 200 ccode+        ev <- withCookie cookie "/events?since=0"+        HTTP.withResponse ev tls $ \resp ->+            assertEqual "/events with the cookie" 200 (HTTP.statusCode (HTTP.responseStatus resp))++        forM_ ["/status", "/command"] $ \route -> do+            (bcode, _, _) <- raw tls =<< withCookie "__Host-salmon-session=AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" route+            assertEqual ("a cookie never minted on " <> route) 401 bcode++        ureq <- HTTP.parseRequest "http://salmon/auth"+        (ucode, uheaders, _) <- raw (runningUnix running) ureq+        assertEqual "/auth on the unix socket" 303 ucode+        assertEqual "sends the browser to the page" (Just "/") (lookup HTTP.hLocation uheaders)+  where+    login running t = do+        req <- tlsRequest running Nothing "/auth"+        pure (HTTP.urlEncodedBody [("token", t)] req)++{- | What @salmon-tui https://...@ is made of: 'Client.newTlsClient'+pinning the minted certificate, with the token. It reads @/dag@, queues a+command, and follows @/events@ from the snapshot to the end of that command's pass+— every request carrying the header. With a wrong token every call is+'Client.Refused' 401; against the system's store the self-signed+certificate fails the handshake before any token is sent; and an+@http://@ address is refused before anything is sent at all.+-}+typedClient :: IO ()+typedClient =+    withRunning $ \running -> do+        let url = "https://" <> Text.unpack serverName <> ":" <> show (runningPort running)+        client <- Client.newTlsClient (Client.TlsTarget url token (Just (runningCert running)))+        snapshot <- Client.dag client+        since <- case field "seq" snapshot of+            Just (Number n) -> pure (Just (round n))+            other -> assertFailure ("no seq on /dag: " <> show other)+        queued <- Client.commandAsync client "up c1"+        seen <- newIORef []+        done <-+            timeout (10 * 1000000) $+                Client.events client since Client.noFilter $ \ev -> do+                    atomicModifyIORef' seen (\es -> (ev : es, ()))+                    pure (ev.eventOrigin /= Just queued.enqueuedOrigin || ev.eventKind /= "converge-stop")+        assertBool "the stream reached the end of the command's pass" (done == Just ())+        evs <- readIORef seen+        assertBool "the command's reports came over the stream" (any (\ev -> ev.eventOrigin == Just queued.enqueuedOrigin) evs)++        wrong <- Client.newTlsClient (Client.TlsTarget url "wrong" (Just (runningCert running)))+        refused <- try (Client.status wrong)+        case refused of+            Left (Client.Refused code _) -> assertEqual "a wrong token" 401 code+            other -> assertFailure ("a wrong token was not refused: " <> show (fmap (const ()) other))++        unpinned <- Client.newTlsClient (Client.TlsTarget url token Nothing)+        handshake <- try (Client.status unpinned)+        assertBool "a self-signed certificate is not trusted from the system store" (isLeftSome handshake)++        plain <- try (Client.newTlsClient (Client.TlsTarget ("http://127.0.0.1:" <> show (runningPort running)) token Nothing))+        case plain of+            Left (Client.BadTarget _) -> pure ()+            _ -> assertFailure "an http:// address was accepted"+  where+    isLeftSome :: Either SomeException a -> Bool+    isLeftSome = either (const True) (const False)++{- | The other half of 'signingIn'. @/auth/session@ is how the page knows to+offer the button: @true@ with a live cookie, @false@ without one (and on+the unix socket, where nobody signs in). @POST /auth/logout@ answers+@303@ to @/auth@ with the cookie expired, and from then on the cookie is+nothing: a read is @401@, @/@ is a redirect to the form. An @/events@+stream opened with the session before it ended does not stay open until+its next request — there is none — but ends there and then. A logout with+no cookie gets the same answer and revokes nothing, and a @GET@ of it is+refused, so a link or a prefetch cannot sign anybody out.+-}+signingOut :: IO ()+signingOut =+    withRunning $ \running -> do+        let tls = runningTls running+            withCookie c route = do+                req <- tlsRequest running Nothing route+                pure req{HTTP.requestHeaders = [(HTTP.hCookie, c) | not (ByteString.null c)]}+            sessionOf c = do+                (code, v) <- exchange tls =<< withCookie c "/auth/session"+                assertEqual "/auth/session answers" 200 code+                pure (field "session" v)+        loginReq <- tlsRequest running Nothing "/auth"+        (_, lheaders, _) <- raw tls (HTTP.urlEncodedBody [("token", token)] loginReq)+        cookie <- maybe (assertFailure "no cookie") (pure . Char8.takeWhile (/= ';')) (lookup "Set-Cookie" lheaders)+        other <- maybe (assertFailure "no cookie") (pure . Char8.takeWhile (/= ';')) . lookup "Set-Cookie" . (\(_, h, _) -> h) =<< raw tls (HTTP.urlEncodedBody [("token", token)] loginReq)++        assertEqual "signed in" (Just (Bool True)) =<< sessionOf cookie+        assertEqual "no cookie, no session" (Just (Bool False)) =<< sessionOf ""++        (gcode, _, _) <- raw tls =<< withCookie cookie "/auth/logout"+        assertEqual "a GET cannot sign out" 405 gcode+        assertEqual "and did not" (Just (Bool True)) =<< sessionOf cookie++        (acode, aheaders, _) <- raw tls . (\r -> r{HTTP.method = "POST"}) =<< tlsRequest running Nothing "/auth/logout"+        assertEqual "a logout without a cookie" 303 acode+        assertEqual "still expires one" True (maybe False ("Max-Age=0" `ByteString.isInfixOf`) (lookup "Set-Cookie" aheaders))+        assertEqual "and revokes nothing" (Just (Bool True)) =<< sessionOf cookie++        ev <- withCookie cookie "/events?since=0"+        HTTP.withResponse ev tls $ \resp -> do+            assertEqual "/events with the cookie" 200 (HTTP.statusCode (HTTP.responseStatus resp))+            _ <- readUntilData (HTTP.responseBody resp) ByteString.empty++            logout <- withCookie cookie "/auth/logout"+            (ocode, oheaders, _) <- raw tls logout{HTTP.method = "POST"}+            assertEqual "signed out" 303 ocode+            assertEqual "to the form" (Just "/auth") (lookup HTTP.hLocation oheaders)+            expired <- maybe (assertFailure "no Set-Cookie on logout") pure (lookup "Set-Cookie" oheaders)+            assertBool ("the cookie is expired: " <> Char8.unpack expired) ("__Host-salmon-session=;" `ByteString.isPrefixOf` expired && "Max-Age=0" `ByteString.isInfixOf` expired)++            ended <- timeout (5 * 1000000) (drain (HTTP.responseBody resp))+            assertEqual "the stream the session opened ends" (Just ()) ended++        assertEqual "the session is gone" (Just (Bool False)) =<< sessionOf cookie+        (scode, _, _) <- raw tls =<< withCookie cookie "/status"+        assertEqual "a read with the old cookie" 401 scode+        (rcode, rheaders, _) <- raw tls =<< withCookie cookie "/"+        assertEqual "the page with the old cookie" 303 rcode+        assertEqual "sends the browser to sign in, saying the session ended" (Just "/auth?ended") (lookup HTTP.hLocation rheaders)+        assertEqual "another browser's session is untouched" (Just (Bool True)) =<< sessionOf other++        ureq <- HTTP.parseRequest "http://salmon/auth/session"+        (ucode, uv) <- exchange (runningUnix running) ureq+        assertEqual "/auth/session on the unix socket" 200 ucode+        assertEqual "nobody signs in there" (Just (Bool False)) (field "session" uv)+  where+    drain body = do+        chunk <- HTTP.brRead body+        unless (ByteString.null chunk) (drain body)++-------------------------------------------------------------------------------+-- sessions, against a clock the test moves++-- | A clock at 0 that moves only when told, and whose waits wake when it does.+fakeClock :: IO (Http.SessionClock, Double -> IO ())+fakeClock = do+    t <- newTVarIO 0+    let clock = Http.SessionClock (readTVarIO t) (\d -> atomically (readTVar t >>= check . (>= d)))+    pure (clock, \dt -> atomically (modifyTVar' t (+ dt)))++sessionLimits :: IO ()+sessionLimits = do+    (clock, advance) <- fakeClock+    sessions <- Http.newSessionsWith (Http.SessionPolicy (Just 100) (Just 10)) clock+    busy <- Http.newSession sessions+    quiet <- Http.newSession sessions+    -- used every 5s, `busy` never idles; `quiet` is never used again+    forM_ [1 .. 3 :: Int] $ \_ -> advance 5 >> (assertBool "busy is used" =<< Http.knownSession sessions busy)+    assertBool "quiet idled out after 15s" . not =<< Http.knownSession sessions quiet+    forM_ [1 .. 16 :: Int] $ \_ -> advance 5 >> void (Http.knownSession sessions busy)+    -- 95s in: still inside its lifetime; 100s: past it, busy or not+    assertBool "busy at 95s" =<< Http.knownSession sessions busy+    advance 5+    assertBool "busy at its lifetime" . not =<< Http.knownSession sessions busy+    assertEqual "both dropped when they were looked at" 0 =<< Http.sessionCount sessions++streamPresence :: IO ()+streamPresence = do+    (clock, advance) <- fakeClock+    sessions <- Http.newSessionsWith (Http.SessionPolicy (Just 100) (Just 10)) clock+    cookie <- Http.newSession sessions+    over <- newEmptyMVar+    opened <- newEmptyMVar+    closing <- newEmptyMVar+    _ <- forkIO $ Http.withStream sessions cookie $ do+        putMVar opened ()+        Http.sessionOver sessions cookie+        putMVar over ()+        takeMVar closing+    takeMVar opened+    advance 50+    assertBool "50s of watching is not idle" =<< Http.knownSession sessions cookie+    advance 49+    r <- timeout 100000 (takeMVar over)+    assertEqual "the stream's wait is still on at 99s" Nothing r+    advance 1+    r' <- timeout (5 * 1000000) (takeMVar over)+    assertEqual "the lifetime ends the stream's wait" (Just ()) r'+    putMVar closing ()+    assertBool "and the session with it" . not =<< Http.knownSession sessions cookie+    -- the idle clock restarts when a stream closes, not before+    other <- Http.newSession sessions+    done <- newEmptyMVar+    _ <- forkIO $ Http.withStream sessions other (advance 30) >> putMVar done ()+    takeMVar done+    advance 9+    assertBool "9s after its stream closed" =<< Http.knownSession sessions other+    advance 10+    assertBool "10s after its last use" . not =<< Http.knownSession sessions other++signInSweeps :: IO ()+signInSweeps = do+    (clock, advance) <- fakeClock+    sessions <- Http.newSessionsWith (Http.SessionPolicy (Just 60) Nothing) clock+    -- a sign-in every 10s for 10 minutes, and nothing ever looked at again+    forM_ [1 .. 60 :: Int] $ \_ -> Http.newSession sessions >> advance 10+    held <- Http.sessionCount sessions+    assertBool ("at most one lifetime's worth held: " <> show held) (held <= 7)++-------------------------------------------------------------------------------++{- | The same over the wire, with a real two-second lifetime. The cookie+carries it as @Max-Age@; a stream opened with the session is cut when it+runs out, with nothing else happening; and from then on the cookie is a+@401@ on a read and, on @/@, a redirect to @/auth?ended@, whose form says+the session ended.+-}+sessionExpiry :: IO ()+sessionExpiry =+    withRunningWith (Http.SessionPolicy (Just 2) Nothing) $ \running -> do+        let tls = runningTls running+            withCookie c route = do+                req <- tlsRequest running Nothing route+                pure req{HTTP.requestHeaders = [(HTTP.hCookie, c)]}+        loginReq <- tlsRequest running Nothing "/auth"+        (_, lheaders, _) <- raw tls (HTTP.urlEncodedBody [("token", token)] loginReq)+        setCookie <- maybe (assertFailure "no cookie") pure (lookup "Set-Cookie" lheaders)+        assertBool ("Max-Age is the lifetime: " <> Char8.unpack setCookie) ("Max-Age=2" `ByteString.isInfixOf` setCookie)+        let cookie = Char8.takeWhile (/= ';') setCookie+        ev <- withCookie cookie "/events?since=0"+        ended <- timeout (10 * 1000000) $+            HTTP.withResponse ev tls $ \resp -> do+                assertEqual "/events with the cookie" 200 (HTTP.statusCode (HTTP.responseStatus resp))+                drain (HTTP.responseBody resp)+        assertEqual "the stream ends with the session" (Just ()) ended+        (scode, _, _) <- raw tls =<< withCookie cookie "/status"+        assertEqual "a read after the lifetime" 401 scode+        (rcode, rheaders, _) <- raw tls =<< withCookie cookie "/"+        assertEqual "the page after the lifetime" 303 rcode+        assertEqual "to the form, saying why" (Just "/auth?ended") (lookup HTTP.hLocation rheaders)+        (_, _, form) <- raw tls =<< tlsRequest running Nothing "/auth?ended"+        assertBool "the form says the session ended" ("session ended" `ByteString.isInfixOf` LChar8.toStrict form)+  where+    drain body = do+        chunk <- HTTP.brRead body+        unless (ByteString.null chunk) (drain body)++-- | Status, headers and body, redirects not followed.+raw :: HTTP.Manager -> HTTP.Request -> IO (Int, HTTP.ResponseHeaders, LChar8.ByteString)+raw manager req = do+    r <- timeout (10 * 1000000) (HTTP.httpLbs req{HTTP.redirectCount = 0} manager)+    case r of+        Nothing -> assertFailure ("no answer within 10s to " <> show (HTTP.path req))+        Just resp -> pure (HTTP.statusCode (HTTP.responseStatus resp), HTTP.responseHeaders resp, HTTP.responseBody resp)++-- | Read the stream until a complete @data:@ line has arrived, 10s at most.+readUntilData :: HTTP.BodyReader -> ByteString.ByteString -> IO ByteString.ByteString+readUntilData body acc+    | "\n\n" `ByteString.isInfixOf` acc && "data: " `ByteString.isInfixOf` acc = pure acc+    | otherwise = do+        chunk <- timeout (10 * 1000000) (HTTP.brRead body)+        case chunk of+            Nothing -> assertFailure ("no event within 10s; got " <> Char8.unpack acc)+            Just c | ByteString.null c -> assertFailure ("/events ended; got " <> Char8.unpack acc)+            Just c -> readUntilData body (acc <> c)++{- | Send bytes over a bare TCP connection and hand back whatever came back+before the server closed it — an exception counts as nothing.+-}+plainRequest :: Int -> ByteString.ByteString -> IO ByteString.ByteString+plainRequest port bytes = do+    r <- try $ do+        sock <- Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol+        Socket.connect sock (Socket.SockAddrInet (fromIntegral port) (Socket.tupleToHostAddress (127, 0, 0, 1)))+        SocketBS.sendAll sock bytes+        got <- timeout (10 * 1000000) (SocketBS.recv sock 4096)+        Socket.close sock+        pure (maybe ByteString.empty id got)+    pure (either (\(_ :: SomeException) -> ByteString.empty) id r)++{- | warp-tls answers a client that speaks plain HTTP on a TLS port with+@426 Upgrade Required@ and closes; a server that closed without a word+is refused too. What it must never be is an answer from a route.+-}+plainRefused :: ByteString.ByteString -> Bool+plainRefused got = ByteString.null got || "HTTP/1.1 426" `ByteString.isPrefixOf` got
+ test/Test/StatusSinkSpec.hs view
@@ -0,0 +1,489 @@+{-# LANGUAGE DeriveGeneric #-}++{- | Layer 1 coverage for milestone 5 of @specs/pull-mode.md@: the status+sink and the fleet fold.++Two @run serve@ loops, in process, follow one directory registry under+different labels and write their status documents into one directory —+which is the whole fleet shape in miniature: hosts that never talk to each+other, a registry they read, a directory they write, and a reader that+folds it. What is asserted: each document names its own host, label,+document id and mode; the document is rewritten after a convergence pass a+typed line caused and after a follow injection; an unwritable sink path is+reported once and the loop keeps serving; and the pure fold behind+@salmon-fleet status@ shows both hosts, filters by label and flags a stale+one.+-}+module Test.StatusSinkSpec (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.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)+import qualified Network.HTTP.Types as HTTP+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp+import Data.Aeson (FromJSON, ToJSON, Value (..), eitherDecode, encode, object, (.=))+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Lazy as LByteString+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)+import GHC.Generics (Generic)+import System.Directory (createDirectoryIfMissing, doesFileExist)+import System.FilePath ((</>))+import System.Timeout (timeout)+import qualified Options.Applicative as Opt+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)++import qualified Salmon.Actions.Fleet as Fleet+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 (AppliedDocument (..), Convergence (..), Direction (..), Line (..), NodeState (..), Origin (..), Producer (..), World (..))+import qualified Salmon.Actions.Serve.StatusSink as StatusSink+import qualified Salmon.Actions.UpDown as UpDown+import qualified Salmon.Builtin.CommandLine as CommandLine+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, contramap, reportBoth, silent)+import qualified Salmon.Reporter.Tagged as Tagged++import Test.Harness (capture, withTempDir)++tests :: TestTree+tests =+    testGroup+        "Salmon.Actions.Serve.StatusSink and Salmon.Actions.Fleet"+        [ testCase "two loops, one registry, one sink directory: each document names its own host, label, id and mode; rewritten after a typed convergence and after an injection; the fold shows both" twoHostsOneDirectory+        , testCase "an unwritable sink path is reported once and the loop keeps serving" unwritableSink+        , testCase "the fold: both hosts, the label filter, the stale flag, the node counts" pureFold+        , testCase "a URL sink POSTs the same document to a server, after each trigger and on the interval" postedSink+        , testCase "a URL sink that is refused is reported once, the loop keeps serving, and a later answer of 2xx resumes it" refusedPostSink+        , testCase "the address's shape chooses the writer" sinkShape+        , testCase "--status-sink-host names the document's host; without it the node name is used" sinkHostFlag+        ]++-------------------------------------------------------------------------------+-- the flag: what `run serve` parses into 'CommandLine.SinkOptions'++sinkHostFlag :: IO ()+sinkHostFlag = do+    parsed ["serve", "--status-sink", "/tmp/s.json"] >>= \o -> do+        assertEqual "path" (Just "/tmp/s.json") o.sinkPath+        assertEqual "no host given: uname -n at run time" Nothing o.sinkHost+    parsed ["serve", "--status-sink", "/tmp/s.json", "--status-sink-host", "web-3"] >>= \o ->+        assertEqual "host given" (Just "web-3") o.sinkHost+    -- the flag is accepted on its own: naming a host is not what makes a document+    parsed ["serve", "--status-sink-host", "web-3"] >>= \o -> do+        assertEqual "no path" Nothing o.sinkPath+        assertEqual "host kept" (Just "web-3") o.sinkHost+  where+    parsed args =+        case Opt.execParserPure Opt.defaultPrefs (Opt.info CommandLine.runCommandParser mempty) args of+            Opt.Success (CommandLine.RunServe _ _ _ _ _ _ _ _ _ sink _) -> pure sink+            Opt.Success other -> assertFailure ("not a serve command: " <> show other)+            Opt.Failure f -> assertFailure ("parse failed: " <> fst (Opt.renderFailure f "salmon"))+            Opt.CompletionInvoked _ -> assertFailure "completion"++-------------------------------------------------------------------------------+-- the served thing: "make these files exist", 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 "status-sink-root" (deps (fmap (fileOp spec.specDir) spec.specNames)) $ \actions ->+        actions{ref = mkRef "status-sink-root" (spec.specDir, spec.specNames)}++fileOp :: FilePath -> String -> Op+fileOp d n = FS.filecontents (FS.FileContents (d </> n) ("contents of " <> n))++-------------------------------------------------------------------------------+-- driving a loop with a sink beside it++data Driver = Driver+    { typeLine :: String -> IO ()+    , serveReports :: IO [Serve.Report]+    , followReports :: IO [Follow.Report]+    }++interval :: Int+interval = 100000++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+        }++{- | One following loop over @root@'s registry, as a host called @host@,+writing its status document to @sinkPath@. The files land in+@root/files-<host>@ so two hosts in one temp dir do not share nodes. The+composition is the one "Salmon.Builtin.CommandLine" makes: the loop's own+tagged reporter with the sink's beside it, the sink's observer handed to+'Serve.serveObserved'. -}+withHost :: FilePath -> Text -> FilePath -> [Label] -> (Driver -> IO a) -> IO (World Spec Spec, [Serve.Report], [Follow.Report], a)+withHost root host sinkPath 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 = Nothing+                , Follow.followRefuseOlder = False+                , Follow.followVerify = Follow.noVerifier+                }+        followed = Follow.followed pk modeVar appliedVar+        own = Tagged.reportTexts serveReporter nodeReporter silent followReporter+        cfg = StatusSink.Config{StatusSink.configPath = sinkPath, StatusSink.configInterval = 1000000, StatusSink.configHost = host}+        driver =+            Driver+                { typeLine = \l -> atomically (writeTChan stdinChan (Just l))+                , serveReports = readServe+                , followReports = readFollow+                }+    resultVar <- newTChanIO+    _ <- forkIO $ do+        outcome <- try (body driver)+        atomically (writeTChan stdinChan Nothing)+        atomically (writeTChan resultVar outcome)+    w <- StatusSink.withSink cfg (Just followed) own $ \sink -> do+        let tagged = reportBoth own (StatusSink.sinkReporter sink)+            producers =+                [ Follow.follower (Tagged.followStream tagged) pk modeVar appliedVar follow (putMVar gate ())+                , Follow.gated gate (chanProducer stdinChan)+                ]+        Serve.serveObserved+            (StatusSink.sinkObserver sink)+            []+            Nothing+            True+            (contramap Serve.attributed (Tagged.serveStream tagged))+            (contramap Serve.attributed (Tagged.updownStream tagged))+            (parseSpec (root </> ("host-" <> Text.unpack host)))+            (Configure pure)+            program+            (Just followed)+            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"++sinkDir :: FilePath -> FilePath+sinkDir root = root </> "sinks"++label :: Text -> Label+label t = either (error . Text.unpack) id (Follow.mkLabel t)++publish :: FilePath -> Label -> Text -> [[String]] -> IO ()+publish root lbl did seeds = do+    createDirectoryIfMissing True (registryDir root)+    LByteString.writeFile (Follow.documentPath (registryDir root) lbl) (encode (Document did (fmap SeedWords seeds) 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++hostFile :: FilePath -> Text -> String -> Bool -> IO Bool+hostFile root host n _ = doesFileExist (root </> ("host-" <> Text.unpack host) </> "files" </> n)++-- | The document at a path, if there is one and it parses.+readDoc :: FilePath -> IO (Maybe StatusSink.Document)+readDoc path = do+    present <- doesFileExist path+    if not present+        then pure Nothing+        else do+            attempt <- try (LByteString.readFile path >>= \b -> LByteString.length b `seq` pure b)+            pure $ case attempt of+                Left (_ :: SomeException) -> Nothing+                Right bytes -> either (const Nothing) Just (eitherDecode bytes)++-- | Wait until the document at the path satisfies the predicate, and return it.+waitDoc :: String -> FilePath -> (StatusSink.Document -> Bool) -> IO StatusSink.Document+waitDoc what path p = do+    waitFor what (maybe False p <$> readDoc path)+    readDoc path >>= maybe (assertFailure ("the document vanished: " <> what)) pure++labelIds :: StatusSink.Document -> [(Text, Text)]+labelIds d = [(a.appliedDocLabel, a.appliedDocId) | a <- d.docLabels]++kindOf :: Maybe Value -> Maybe Text+kindOf (Just (Object o)) | Just (String k) <- KeyMap.lookup "kind" o = Just k+kindOf _ = Nothing++allConvergedUp :: World seed directive -> Bool+allConvergedUp w = not (Map.null w.worldNodes) && all (\st -> st.nodeDirection == TurnUp && st.nodeConvergence == Converged) (Map.elems w.worldNodes)++-------------------------------------------------------------------------------++twoHostsOneDirectory :: IO ()+twoHostsOneDirectory =+    withTempDir $ \root -> do+        let web = label "web"+            db = label "db"+            alphaSink = sinkDir root </> "alpha.json"+            betaSink = sinkDir root </> "beta.json"+        publish root web "web@1" [["a"]]+        publish root db "db@1" [["b"]]+        (wAlpha, alphaReports, _, (wBeta, _, _, ())) <- withHost root "alpha" alphaSink [web] $ \alpha ->+            withHost root "beta" betaSink [db] $ \_ -> do+                -- both hosts converged on their own label and wrote about it+                dAlpha <- waitDoc "alpha's document, converged" alphaSink converged+                dBeta <- waitDoc "beta's document, converged" betaSink converged+                assertEqual "alpha names itself" "alpha" dAlpha.docHost+                assertEqual "beta names itself" "beta" dBeta.docHost+                assertEqual "alpha's label and id" [("web", "web@1")] (labelIds dAlpha)+                assertEqual "beta's label and id" [("db", "db@1")] (labelIds dBeta)+                assertEqual "alpha is following" "following" dAlpha.docMode+                assertEqual "beta is following" "following" dBeta.docMode+                assertEqual "the last converge is a converge-stop" (Just "converge-stop") (kindOf dAlpha.docLastConverge)+                assertEqual "the last follow report is the injection" (Just "injected") (kindOf dAlpha.docLastFollow)+                assertEqual "the document version" (Just (Number 1)) =<< rawField alphaSink "salmon-status"+                -- a typed line converges alpha: the document is rewritten+                -- with the new node count and a later `written`+                alpha.typeLine "up c"+                dAlpha' <- waitDoc "alpha's document after a typed up" alphaSink (\d -> d.docWritten > dAlpha.docWritten && nodes d > nodes dAlpha && converged d)+                assertEqual "the label is still web@1: nothing was fetched" [("web", "web@1")] (labelIds dAlpha')+                assertEqual "beta is untouched" (labelIds dBeta) . labelIds =<< waitDoc "beta's document" betaSink (const True)+                -- a new document for web is injected: rewritten again, now+                -- naming web@2+                publish root web "web@2" [["a"], ["d"]]+                dAlpha'' <- waitDoc "alpha's document after web@2" alphaSink (\d -> labelIds d == [("web", "web@2")] && converged d)+                assertBool "written later still" (dAlpha''.docWritten > dAlpha'.docWritten)+                assertEqual "the injection is the last follow report" (Just "injected") (kindOf dAlpha''.docLastFollow)+                -- the fold over the directory sees both, as salmon-fleet would+                (docs, rejected) <- Fleet.readStatusDir (sinkDir root)+                assertEqual "nothing rejected" [] rejected+                now <- getCurrentTime+                let rows = Fleet.fold Fleet.defaultOptions now docs+                assertEqual "both hosts, alpha first" ["alpha", "beta"] (fmap (.rowHost) rows)+                assertEqual "nothing is stale" [False, False] (fmap (.rowStale) rows)+                assertBool "every node converged on both" (all (\r -> r.rowConverged == r.rowNodes && r.rowNodes > 0) rows)+                assertEqual "the label filter" ["beta"] (fmap (.rowHost) (Fleet.fold Fleet.defaultOptions{Fleet.optLabel = Just "db"} now docs))+                -- a temp file is never left behind between writes+                assertEqual "only the two documents" 2 (length docs)+        assertBool "alpha converged" (allConvergedUp wAlpha)+        assertBool "beta converged" (allConvergedUp wBeta)+        assertEqual "no sink failure on alpha" [] [() | Serve.SinkFailed{} <- alphaReports]+  where+    nodes :: StatusSink.Document -> Int+    nodes d = let (_, _, n) = Fleet.nodeCounts d.docStatus in n+    converged :: StatusSink.Document -> Bool+    converged d = let (c, _, n) = Fleet.nodeCounts d.docStatus in n > 0 && c == n+    rawField path key = do+        bytes <- LByteString.readFile path+        pure $ case eitherDecode bytes of+            Right (Object o) -> KeyMap.lookup key o+            _ -> Nothing++{- | The sink's directory is a regular file, so neither the temp file nor+the rename can succeed. One report, then silence; the loop still answers. -}+unwritableSink :: IO ()+unwritableSink =+    withTempDir $ \root -> do+        let web = label "web"+            blocked = root </> "blocked"+        writeFile blocked "not a directory"+        publish root web "web@1" [["a"]]+        (w, reports, _, ()) <- withHost root "gamma" (blocked </> "gamma.json") [web] $ \d -> do+            waitFor "the first file" (hostFile root "gamma" "a" True)+            waitFor "the sink failure to be reported" (not . null <$> (\rs -> [() | Serve.SinkFailed{} <- rs]) <$> d.serveReports)+            -- two more triggers: a typed convergence and an injection+            d.typeLine "up b"+            waitFor "the typed file" (hostFile root "gamma" "b" True)+            publish root web "web@2" [["a"], ["c"]]+            waitFor "the injected file" (hostFile root "gamma" "c" True)+            -- and a couple of interval ticks+            threadDelay (2 * 1000000 + 200000)+            failures <- (\rs -> [path | Serve.SinkFailed path _ <- rs]) <$> d.serveReports+            assertEqual "reported once, for the path" [blocked </> "gamma.json"] failures+            -- the loop is still there+            before <- length . (\rs -> [() | Serve.StatusReport{} <- rs]) <$> d.serveReports+            d.typeLine "status"+            waitFor "a status answer" ((> before) . length . (\rs -> [() | Serve.StatusReport{} <- rs]) <$> d.serveReports)+        assertBool "the world converged regardless" (allConvergedUp w)+        assertBool "the render names the path" $+            any (Text.isInfixOf (Text.pack blocked)) (concat [Serve.renderReport rep | rep@Serve.SinkFailed{} <- reports])+        exists <- doesFileExist (blocked </> "gamma.json")+        assertBool "nothing was written" (not exists)++-- | What a local server has been posted: content type and body, newest last; and the status it answers with.+data Receiver = Receiver+    { received :: IORef [(Maybe LByteString.ByteString, LByteString.ByteString)]+    , answers :: IORef HTTP.Status+    }++withReceiver :: HTTP.Status -> (String -> Receiver -> IO a) -> IO a+withReceiver status act = do+    got <- newIORef []+    ans <- newIORef status+    let app req respond = do+            body <- Wai.strictRequestBody req+            let ctype = fmap (LByteString.fromStrict) (lookup HTTP.hContentType (Wai.requestHeaders req))+            if Wai.requestMethod req == "POST"+                then do+                    modifyIORef' got (++ [(ctype, body)])+                    st <- readIORef ans+                    respond (Wai.responseLBS st [] "")+                else respond (Wai.responseLBS HTTP.status405 [] "")+    Warp.testWithApplication (pure app) $ \port -> act ("http://127.0.0.1:" <> show port <> "/status") (Receiver got ans)++postedDocs :: Receiver -> IO [StatusSink.Document]+postedDocs r = do+    xs <- readIORef r.received+    pure [d | (_, b) <- xs, Right d <- [eitherDecode b]]++{- | The same loop as the file sink's, its documents going to a server: the+first after the first pass, more after a typed convergence and an injection,+and the interval keeps them coming. Each is the document a file would hold. -}+postedSink :: IO ()+postedSink =+    withTempDir $ \root -> withReceiver HTTP.status200 $ \url recv -> do+        let web = label "web"+        publish root web "web@1" [["a"]]+        (w, _, _, ()) <- withHost root "delta" url [web] $ \d -> do+            waitFor "the first post" ((> 0) . length <$> postedDocs recv)+            d.typeLine "up b"+            waitFor "a post naming the typed node converged" $ do+                docs <- postedDocs recv+                pure (any (\doc -> "delta" == doc.docHost && Text.isInfixOf "converged" (Text.pack (show (encode doc.docStatus)))) docs)+            publish root web "web@2" [["a"], ["c"]]+            waitFor "a post after the injection names its document" $ do+                docs <- postedDocs recv+                pure (any (\doc -> any (\l -> l.appliedDocId == "web@2") doc.docLabels) docs)+            n <- length <$> postedDocs recv+            waitFor "the interval to post again with nothing else happening" ((> n) . length <$> postedDocs recv)+        assertBool "the world converged" (allConvergedUp w)+        xs <- readIORef recv.received+        assertBool "every post is application/json" (all (\(c, _) -> fmap (LByteString.take 16) c == Just "application/json") xs)+        assertBool "every body parses as a status document" (length xs == length [() | (_, b) <- xs, Right (_ :: StatusSink.Document) <- [eitherDecode b]])++{- | A server that answers 500 is a sink that cannot be written: said once+for the URL however many triggers follow, the loop untouched, and the first+2xx afterwards is a document again. -}+refusedPostSink :: IO ()+refusedPostSink =+    withTempDir $ \root -> withReceiver HTTP.status500 $ \url recv -> do+        let web = label "web"+        publish root web "web@1" [["a"]]+        (w, reports, _, ()) <- withHost root "epsilon" url [web] $ \d -> do+            waitFor "the failure to be reported" (not . null <$> (\rs -> [() | Serve.SinkFailed{} <- rs]) <$> d.serveReports)+            d.typeLine "up b"+            waitFor "the typed file" (hostFile root "epsilon" "b" True)+            threadDelay (2 * 1000000 + 200000)+            failures <- (\rs -> [u | Serve.SinkFailed u _ <- rs]) <$> d.serveReports+            assertEqual "reported once, for the URL" [url] failures+            writeIORef recv.answers HTTP.status204+            waitFor "a document to be accepted once the server answers 2xx" ((\ds -> any (\doc -> doc.docHost == "epsilon") ds) <$> postedDocs recv)+        assertBool "the world converged regardless" (allConvergedUp w)+        let rendered = Text.unlines (concat [Serve.renderReport rep | rep@Serve.SinkFailed{} <- reports])+        assertBool "the render names the URL" (Text.isInfixOf (Text.pack url) rendered)+        assertBool "the render says what the server answered" (Text.isInfixOf "500" rendered)++sinkShape :: IO ()+sinkShape = do+    assertEqual "" [True, True, False, False, False] (fmap StatusSink.isUrl ["http://h/x", "https://h:8443/status", "/var/lib/salmon/status.json", "relative/status.json", "httpx://not"])++{- | The fold on documents built by hand: no loop, no clock but the one+given. -}+pureFold :: IO ()+pureFold = do+    let t0 = read "2026-09-24 10:00:00 UTC" :: UTCTime+        at s = addUTCTime (fromIntegral (s :: Int)) t0+        applied lbl did = AppliedDocument lbl did "32ea59311d97a7c0ffff" (at (-30))+        status convergences =+            object ["kind" .= ("status" :: Text), "mode" .= ("following" :: Text), "nodes" .= [object ["convergence" .= c] | c <- convergences :: [Text]]]+        doc host written labels convergences =+            StatusSink.Document+                { StatusSink.docHost = host+                , StatusSink.docWritten = written+                , StatusSink.docMode = "following"+                , StatusSink.docLabels = labels+                , StatusSink.docStatus = status convergences+                , StatusSink.docLastConverge = Nothing+                , StatusSink.docLastFollow = Nothing+                }+        docs =+            [ ("/sinks/web-2.json", doc "web-2" (at (-5)) [applied "web" "web@42", applied "canary" "canary@7"] ["converged", "converged", "errored"])+            , ("/sinks/web-1.json", doc "web-1" (at (-90)) [applied "web" "web@42"] ["converged", "pending"])+            , ("/sinks/db-1.json", doc "db-1" (at 2) [applied "db" "db@3"] [])+            ]+        rows = Fleet.fold Fleet.defaultOptions t0 docs+    assertEqual "hosts in name order" ["db-1", "web-1", "web-2"] (fmap (.rowHost) rows)+    assertEqual "converged / errored / total" [(0, 0, 0), (1, 0, 2), (2, 1, 3)] [(r.rowConverged, r.rowErrored, r.rowNodes) | r <- rows]+    assertEqual "the stale flag past 60s; a clock ahead of the reader's is not stale" [False, True, False] (fmap (.rowStale) rows)+    assertEqual "ages" [-2, 90, 5] (fmap (.rowAge) rows)+    assertEqual "the label filter keeps every host carrying it" ["web-1", "web-2"] (fmap (.rowHost) (Fleet.fold Fleet.defaultOptions{Fleet.optLabel = Just "web"} t0 docs))+    assertEqual "a label nobody carries" [] (Fleet.fold Fleet.defaultOptions{Fleet.optLabel = Just "nope"} t0 docs)+    assertEqual "a looser threshold" [False, False, False] (fmap (.rowStale) (Fleet.fold Fleet.defaultOptions{Fleet.optStale = 120} t0 docs))+    assertEqual+        "the line"+        "web-2\tfollowing\tweb=web@42@32ea59311d97,canary=canary@7@32ea59311d97\t2/3\t1\t5s\t"+        (Fleet.renderRow (rows !! 2))+    assertEqual+        "a stale line"+        "web-1\tfollowing\tweb=web@42@32ea59311d97\t1/2\t0\t90s\tstale"+        (Fleet.renderRow (rows !! 1))+    assertEqual "no nodes, a clock ahead" "db-1\tfollowing\tdb=db@3@32ea59311d97\t0/0\t0\t-2s\t" (Fleet.renderRow (rows !! 0))+    assertEqual "no labels renders as a dash" "-" (Text.splitOn "\t" (Fleet.renderRow (Fleet.rowOf Fleet.defaultOptions t0 "/x.json" (doc "x" t0 [] []))) !! 2)+    -- the JSON row carries the same fields+    case Fleet.rowValue (rows !! 1) of+        Object o -> do+            assertEqual "stale" (Just (Bool True)) (KeyMap.lookup "stale" o)+            assertEqual "host" (Just (String "web-1")) (KeyMap.lookup "host" o)+            assertEqual "converged" (Just (Number 1)) (KeyMap.lookup "converged" o)+        v -> assertFailure ("not an object: " <> show v)
+ test/Test/SystemdSpec.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 0 coverage for "Salmon.Builtin.Nodes.Systemd"'s @check@.++'Systemd.checkService' is a @systemctl show@ away from being untestable+without a systemd, so the decision it draws from that output is split out as+'Systemd.interpretShow' and asserted here. What is /not/ here is that+@systemctl@ prints what these cases assume — the Layer 3 tiers+(@Test.QemuSmokeSpec@, @Test.PostgresReplicationSpec@) run real units on a+real init and are what actually exercise the shelling-out.++The interesting cases are the two that are not "is it running": a unit whose+file changed since systemd loaded it, and a unit part-way through a+transition. Both were what made this node worth giving a check at all.+-}+module Test.SystemdSpec (tests) where++import Data.Text (Text)+import qualified Data.Text as Text+import System.FilePath ((</>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)+import Test.Harness (withTempDir)++import Salmon.Actions.UpDown (CheckResult (..))+import qualified Salmon.Builtin.Nodes.Systemd as Systemd++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Nodes.Systemd"+        [ testCase "a running, enabled, loaded unit is satisfied" runningIsSuccess+        , testCase "a stopped or failed unit needs bringing up" stoppedIsFailure+        , testCase "a unit whose file changed needs bringing up, running or not" staleFileIsFailure+        , testCase "a unit in transition is Unknown, not Failure" transitionIsUnknown+        , testCase "a running but disabled unit is not satisfied" disabledIsFailure+        , testCase "a unit systemd has never heard of is not satisfied" unknownUnitIsFailure+        , testCase "properties are read by name, not by position" orderIndependent+        , testGroup "watched config files" watchedTests+        ]++{- | A service's config file leaves no trace in anything systemd knows, so+'Systemd.systemdServiceWatching' folds it into the unit file, where+@NeedDaemonReload@ already notices changes. These are assertions about that+fold: same bytes, same unit; different bytes, different unit.+-}+watchedTests :: [TestTree]+watchedTests =+    [ testCase "a changed config changes the unit file" $ withTempDir $ \dir -> do+        let ini = dir </> "pgbouncer.ini"+        writeFile ini "[databases]\nx = host=a\n"+        before <- Systemd.withWatchedFingerprint [ini] unit+        writeFile ini "[databases]\nx = host=b\n"+        after <- Systemd.withWatchedFingerprint [ini] unit+        assertBool "the unit did not change with the config" (before /= after)+    , testCase "an unchanged config leaves the unit alone" $ withTempDir $ \dir -> do+        let ini = dir </> "pgbouncer.ini"+        writeFile ini "[databases]\nx = host=a\n"+        before <- Systemd.withWatchedFingerprint [ini] unit+        after <- Systemd.withWatchedFingerprint [ini] unit+        assertEqual "" before after+    , testCase "a config appearing later is a change" $ withTempDir $ \dir -> do+        let ini = dir </> "userlist.txt"+        missing <- Systemd.withWatchedFingerprint [ini] unit+        writeFile ini "\"u\" \"secret\"\n"+        present <- Systemd.withWatchedFingerprint [ini] unit+        assertBool "a file appearing went unnoticed" (missing /= present)+    , testCase "the watched files are framed, not concatenated" $ withTempDir $ \dir -> do+        let (a, b) = (dir </> "a", dir </> "b")+        writeFile a "xy" >> writeFile b "z"+        one <- Systemd.withWatchedFingerprint [a, b] unit+        writeFile a "x" >> writeFile b "yz"+        two <- Systemd.withWatchedFingerprint [a, b] unit+        assertBool "moving a byte between two files went unnoticed" (one /= two)+    , testCase "the unit text itself is kept, with the hash appended" $ withTempDir $ \dir -> do+        let ini = dir </> "conf"+        writeFile ini "anything"+        out <- Systemd.withWatchedFingerprint [ini] unit+        assertBool (Text.unpack out) (unit `Text.isPrefixOf` out)+        assertBool (Text.unpack out) ("# salmon-watches: " `Text.isInfixOf` out)+    ]+  where+    unit :: Text+    unit = "[Unit]\nDescription=a service\n\n[Service]\nExecStart=/bin/true\n"++shown :: [Text] -> CheckResult+shown = Systemd.interpretShow++isFailure :: CheckResult -> Bool+isFailure (Failure _) = True+isFailure _ = False++runningIsSuccess :: IO ()+runningIsSuccess =+    assertEqual+        "active, enabled and loaded as written"+        Success+        (shown ["ActiveState=active", "UnitFileState=enabled", "NeedDaemonReload=no"])++stoppedIsFailure :: IO ()+stoppedIsFailure = do+    assertBool "inactive" (isFailure (shown ["ActiveState=inactive", "UnitFileState=enabled", "NeedDaemonReload=no"]))+    assertBool "failed" (isFailure (shown ["ActiveState=failed", "UnitFileState=enabled", "NeedDaemonReload=no"]))++{- | The case that keeps @run up@ meaning what it used to mean. This node's+own dependency rewrites the unit file before the check ever runs, so nothing+on disk can still say the running service is stale — only systemd's own+record of it.+-}+staleFileIsFailure :: IO ()+staleFileIsFailure =+    assertBool+        "running happily, against a unit file that is no longer the one on disk"+        (isFailure (shown ["ActiveState=active", "UnitFileState=enabled", "NeedDaemonReload=yes"]))++{- | A service part-way through starting has not gone away, and treating it+as gone is how a slow starter becomes a restart loop. 'Unknown' is the+verdict that makes "Salmon.Actions.Upkeep" wait and look again.+-}+transitionIsUnknown :: IO ()+transitionIsUnknown = do+    assertEqual "activating" Unknown (shown ["ActiveState=activating", "UnitFileState=enabled", "NeedDaemonReload=no"])+    assertEqual "deactivating" Unknown (shown ["ActiveState=deactivating", "UnitFileState=enabled", "NeedDaemonReload=no"])+    assertEqual "reloading" Unknown (shown ["ActiveState=reloading", "UnitFileState=enabled", "NeedDaemonReload=no"])++-- | Still running, so nothing is obviously wrong today; gone at the next+-- reboot, which is exactly the sort of drift nobody notices by hand.+disabledIsFailure :: IO ()+disabledIsFailure =+    assertBool+        "running but disabled"+        (isFailure (shown ["ActiveState=active", "UnitFileState=disabled", "NeedDaemonReload=no"]))++unknownUnitIsFailure :: IO ()+unknownUnitIsFailure = do+    -- what `systemctl show` says about a unit it has never heard of: a state,+    -- and no install state at all.+    assertBool "never heard of it" (isFailure (shown ["ActiveState=inactive", "NeedDaemonReload=no"]))+    assertBool "said nothing whatsoever" (isFailure (shown []))++orderIndependent :: IO ()+orderIndependent =+    assertEqual+        "the same three properties, whatever order systemd emits them in"+        Success+        (shown ["NeedDaemonReload=no", "UnitFileState=enabled", "ActiveState=active"])
+ test/Test/UpTreeSpec.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 0/1 coverage for 'Salmon.Actions.UpDown.upTree''s side of the+walk: dependency ordering, one application per 'Ref' however many paths reach+it, and the failure containment that stops a node being evaluated against a+precondition that never arrived.++The mirror of "Test.DownTreeSpec", and deliberately so — since both drivers+now run the same walk over a 'Salmon.Op.Dag.Dag' in opposite directions, the+two suites are the check that the direction is the *only* difference.+-}+module Test.UpTreeSpec (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.Actions.UpDown (Report (..))+import Salmon.Builtin.Extension (deps, dynamics, help, nodeps, notes, op, ref, up)+import Salmon.Op.Actions (Act (..))+import Salmon.Op.OpGraph (inject)+import Salmon.Op.Ref (mkRef)++import Test.Harness (runUpCapturing)++tests :: TestTree+tests =+    testGroup+        "Salmon.Actions.UpDown.upTree"+        [ 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 "a blocked node blocks its own dependants in turn" blockingIsTransitive+        ]++-------------------------------------------------------------------------------++predecessorFirst :: IO ()+predecessorFirst = do+    logRef <- newIORef []+    let rec name = modifyIORef' logRef (name :)+        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"}+    _ <- runUpCapturing root+    order <- reverse <$> readIORef logRef+    assertEqual "each node applied exactly once" (sort ["root", "a", "b", "shared"]) (sort order)+    before "shared" "a" order+    before "shared" "b" order+    before "a" "root" order+    before "b" "root" order++{- | Same shape reached two ways at once ('inject' + 'deps'), which used to+produce one 'Eval' and one @Redundant@. The collapse to a+'Salmon.Op.Dag.Dag' makes it structurally one node, so there is one report+and nothing to dedupe at walk time.+-}+sharedNodeOnce :: IO ()+sharedNodeOnce = do+    logRef <- newIORef []+    let rec name = modifyIORef' logRef (name :)+        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" nodeps $ \x -> x{ref = mkRef "mid" ("right" :: Text), up = rec "right"}) `inject` apex+        root = op "root" (deps [left, right]) $ \x -> x{ref = mkRef "root" (), up = rec "root"}+    reports <- runUpCapturing root+    order <- reverse <$> readIORef logRef+    assertEqual "apex applied exactly once" 1 (length (filter (== "apex") order))+    assertEqual "apex applied first" (Just 0) (elemIndex "apex" order)+    assertEqual+        "and reported exactly once"+        1+        (length [() | Eval act <- reports, act.shorthand == "apex"])+    assertEqual "four nodes, four Evals" 4 (length [() | Eval _ <- reports])++{- | @a@'s @up@ throws, so @root@ (which depends on it) must not be evaluated+against a precondition that never arrived — but @b@, which does not depend on+@a@, is unaffected.+-}+failureBlocksDependants :: IO ()+failureBlocksDependants = do+    logRef <- newIORef []+    let rec name = modifyIORef' logRef (name :)+        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 <- runUpCapturing root+    order <- reverse <$> readIORef logRef+    assertBool "the failing node's own up still ran" ("a" `elem` order)+    assertBool "an unrelated sibling was still applied" ("b" `elem` order)+    assertBool "the blocked dependant was NOT applied" ("root" `notElem` order)+    assertEqual "and it is reported Blocked" ["root"] [act.shorthand | Blocked act <- reports]+    assertEqual "one node failed" ["a"] [act.shorthand | Failed act _ <- reports]++-- | Blocking is not one level deep: everything above a failure is contained.+blockingIsTransitive :: IO ()+blockingIsTransitive = do+    let a = op "a" nodeps $ \x -> x{ref = mkRef "mid" ("a" :: Text), up = ioError (userError "boom")}+        mid = op "mid" (deps [a]) $ \x -> x{ref = mkRef "mid" ("mid" :: Text)}+        root = op "root" (deps [mid]) $ \x -> x{ref = mkRef "root" ()}+    reports <- runUpCapturing root+    assertEqual+        "both levels above the failure are blocked"+        (sort ["mid", "root"])+        (sort [act.shorthand | Blocked act <- reports])++-------------------------------------------------------------------------------++before :: String -> String -> [String] -> IO ()+before x y order =+    assertBool+        (x <> " must come before " <> y <> " in " <> show order)+        (elemIndex x order < elemIndex y order)
+ test/Test/UpkeepSpec.hs view
@@ -0,0 +1,1429 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 0/1 coverage for "Salmon.Actions.Upkeep": the continuous driver.++The one-shot drivers can be asserted on by running them to completion and+reading the report list. Nothing here completes, so every case instead+'startUpkeep's, waits on the report stream for the state it is looking for,+pokes the world, waits again, and stops. The waiting is STM on a 'TVar' of+reports rather than @threadDelay@, so a case that passes does so as fast as+the machines run and a case that fails fails by timing out rather than by+flaking.++Four groups. First, that a node is tended at all: satisfied nodes are left+alone, unsatisfied ones are brought up, and the ordering guarantees the+one-shot drivers have still hold. Second, the part that only exists here —+the effect going away brings the node back, the restart policy decides+whether it does, and a check that cannot tell decides nothing. Third, the+control surface: instructions that only mean something to a continuous+driver, and the watchdog. Fourth, the two groups at the end, for the two+things a node can be beyond an @up@ that returns: one that owns the process+it stands for, and one whose going away takes its dependants with it.+-}+module Test.UpkeepSpec (tests) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (bracket)+import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVar, readTVarIO, retry)+import Control.Monad (unless, void)+import Data.Dynamic (toDyn)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Text (Text)+import System.Timeout (timeout)+import System.Exit (ExitCode (..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import Salmon.Actions.UpDown (CheckResult (..))+import qualified Salmon.Actions.UpDown as UpDown+import Salmon.Actions.Upkeep (DownkeepState (..), Report (..), Standing (..), Supervisor, Tend (..), UpkeepState (..))+import qualified Salmon.Actions.Upkeep as Upkeep+-- imported with their field selectors: OverloadedRecordDot only solves+-- HasField for fields whose selector is in scope, and 'Upkeep' asks for+-- several this module never mentions by name.+import Salmon.Builtin.Extension (Extension, Op, check, deps, down, dynamics, evalDeps, help, managed, nodeps, notes, op, opAct, ref, up)+import qualified Salmon.Builtin.Nodes.Filesystem as FS+import Salmon.Op.Actions (Act (..))+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Mailbox (Instruction (..))+import Salmon.Op.Ref (Ref, mkRef)+import Salmon.Op.Status (Direction (..))+import Salmon.Op.Supervision (Restart (..), Strategy (..), Supervision (..), defaultSupervision, millis, seconds, supervised)+import Salmon.Reporter (ReporterM (..))+import System.Directory (doesDirectoryExist, removeDirectory)+import System.FilePath ((</>))+import Test.Harness (withTempDir)++tests :: TestTree+tests =+    testGroup+        "Salmon.Actions.Upkeep"+        [ testCase "the adaptive delay clamps at both ends" delayClamps+        , testCase "a satisfied node is not upped, and rests" satisfiedRests+        , testCase "an unsatisfied node is upped, then rests" unsatisfiedIsUpped+        , testCase "a check that cannot tell is not evidence to act on" unknownDoesNotSpin+        , testCase "the effect going away brings the node back" vanishedComesBack+        , testCase "Restart Never leaves a fallen-over node alone" neverLeavesItAlone+        , testCase "Restart Always acts on a Completed node" alwaysActsOnCompleted+        , testCase "a dependant waits for its dependency" dependantWaits+        , testCase "a failing dependency is waited out, not Blocked" failureIsWaitedOut+        , testCase "an untended neighbour is not waited on" untendedNotWaited+        , testCase "a cycle is reported rather than hanging" cycleIsReported+        , testCase "teardown waits for every dependant" teardownOrdering+        , testCase "Pause stops tending; Resume starts again" pauseAndResume+        , testCase "a silent node past its watchdog is reported" watchdogFires+        , testCase "two supervision policies on one node are reported" policyConflict+        , testCase "stopping waits for an up in flight rather than cutting it" stopWaitsForUp+        , testCase "a node already standing is watched, not re-upped" settledIsNotReUpped+        , testCase "a node with no check parks instead of polling" immaterialParks+        , testCase "a parked node still hears a dependency go away" parkedNodeIsStillDemotable+        , testCase "a node waiting on a slow dependency is not itself wedged" watchdogSkipsWaiters+        , testGroup+            "a node that owns its effect"+            [ testCase "is Up for as long as its action runs" managedIsUpWhileRunning+            , testCase "every line its action writes is reported as Output, in order" managedOutputIsReported+            , testCase "exiting cleanly is Completed, not a restart" managedCleanExitRests+            , testCase "exiting non-zero is restarted" managedFailureRestarts+            , testCase "Restart Never respects even a crash" managedNeverStaysDown+            , testCase "Restart Always restarts a clean exit too" managedAlwaysRestarts+            , testCase "a check that says the effect is there survives a 0 exit" managedDoubleFork+            , testCase "giving up latches off until forced" managedGivesUp+            , testCase "having run a while resets the failure count" managedStableResets+            , testCase "cancelling tears the action down through its bracket" managedCancelTearsDown+            , testCase "is never told it is already standing" managedIgnoresSettled+            , testCase "Force restarts it rather than skipping it" managedForceRestarts+            ]+        , testGroup+            "a node that takes its dependants with it"+            [ testCase "a dependant already up is sent back, and comes back" restForOneDemotes+            , testCase "the default strategy leaves the dependant alone" oneForOneLeavesItAlone+            , testCase "a demoted dependant waits rather than acting" demotedWaitsForItsDependency+            , testCase "it cascades along the dependants that opted in" demotionCascades+            , testCase "a node with no dependants demotes nobody" noDependantsCostsNothing+            , testCase "a second departure in quick succession is dropped" flapIsRateLimited+            , testCase "a dependency coming up for the first time demotes nobody" settledStartIsNotDemoted+            , testCase "a dependant that owns a process is torn down and respawned" managedDependantIsRestarted+            , testCase "a torn-down process is put back whatever its own check says" managedDemotionOutranksItsOwnCheck+            , testCase "a node that lost nothing still asks its check" oneShotDemotionAsksItsCheck+            ]+        , testGroup+            "a node that reapplies instead of asking (supReapply)"+            [ testCase "it re-runs up on the loop rather than parking" reapplyRunsAgain+            , testCase "a successful reapply never re-enters Upping" reapplyStaysInUp+            , testCase "reapplying a RestForOne node does not demote its dependants" reapplyDoesNotDemoteDependants+            , testCase "a throwing reapply is a real failure, backed off and given up on" failingReapplyGivesUp+            , testCase "a node holding an action ignores supReapply and parks" managedIgnoresSupReapply+            , testCase "Filesystem.dir puts itself back, unsupervised by anybody else" dirSelfHeals+            ]+        , testGroup+            "adoption sees a changed Supervision policy (I5)"+            [ testCase "a policy-only change is not adopted, and the process restarts" changedPolicyIsNotAdopted+            , testCase "an unchanged policy is adopted, and the process is not restarted" unchangedPolicyIsAdopted+            ]+        ]++-------------------------------------------------------------------------------+-- driving a supervisor++{- | Reports, newest first, in a 'TVar' so a case can block on them in STM+rather than sleeping.+-}+type Trace = TVar [Report Extension]++-- | Fail the test rather than hanging if a machine never gets where it should.+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++{- | Block until the reports so far (oldest first) satisfy the predicate.+Combined with 'within', this is the whole of how these cases synchronise:+never "wait 200ms and hope", always "wait until the machine says so".+-}+await :: Trace -> ([Report Extension] -> Bool) -> IO ()+await trace p =+    atomically $ do+        rs <- readTVar trace+        unless (p (reverse rs)) retry++seen :: Trace -> IO [Report Extension]+seen trace = reverse <$> atomically (readTVar trace)++dagOf :: Op -> Dag.Dag Extension+dagOf = Dag.foldDag Dag.sameRepresentative . evalDeps++-- | Start a supervisor over this graph, run the body, stop it.+supervising ::+    Dag.Dag Extension ->+    (Ref -> Maybe Tend) ->+    (Supervisor Extension -> Trace -> IO a) ->+    IO a+supervising dag tend body = do+    trace <- newTVarIO []+    let r = ReporterM $ \rep -> atomically (modifyTVar' trace (rep :))+    -- a bracket, so a failing assertion does not leave machines running+    -- into the next case.+    Upkeep.withUpkeep r tend dag (\sup -> body sup trace)++{- | Everything brought up from scratch — the shape a supervisor takes when+nothing has run yet. 'Settled' is what @serve@ passes for a node a pass has+already dealt with; 'restingUp' below covers that.+-}+allUp :: Ref -> Maybe Tend+allUp = const (Just (Tend TurnUp Unsettled))++-- | Everything taken down from scratch.+allDown :: Ref -> Maybe Tend+allDown = const (Just (Tend TurnDown Unsettled))++-- | Everything already up: watched, not applied.+restingUp :: Ref -> Maybe Tend+restingUp = const (Just (Tend TurnUp Settled))++-------------------------------------------------------------------------------+-- report predicates++evals :: [Report Extension] -> [Text]+evals rs = [act.shorthand | Acted (UpDown.Eval act) <- rs]++skips :: [Report Extension] -> [Text]+skips rs = [act.shorthand | Acted (UpDown.Skip act) <- rs]++blockeds :: [Report Extension] -> [Text]+blockeds rs = [act.shorthand | Acted (UpDown.Blocked act) <- rs]++reached :: UpkeepState -> [Report Extension] -> [Text]+reached want rs = [act.shorthand | Upkeep act st <- rs, st == want]++reachedDown :: DownkeepState -> [Report Extension] -> [Text]+reachedDown want rs = [act.shorthand | Downkeep act st <- rs, st == want]++{- | How many times any machine has come round its 'Up' loop and settled+down to wait again. 'Parked' counts alongside 'NextLook' because it is the+same event said about a node with nothing to poll for: the machine finished+a turn and is waiting on its mailbox rather than on a timer. A case that+counted only 'NextLook' would hang forever on a node with no @check@, which+is most of them. 'Reapplying' counts too, for the same reason on a node+that declared 'Salmon.Op.Supervision.supReapply'.+-}+looks :: [Report Extension] -> Int+looks rs = length [() | r <- rs, waiting r]++waiting :: Report Extension -> Bool+waiting NextLook{} = True+waiting Parked{} = True+waiting Reapplying{} = True+waiting _ = False++-- | Which node was sent back to 'WaitUp', and by which dependency.+demotions :: [Report Extension] -> [(Text, Ref)]+demotions rs = [(act.shorthand, dep) | Demoted act dep <- rs]++-- | How many times this one node has said what it is waiting on next: the+-- way a case waits for one machine to have been round its loop again.+looksAt :: Text -> [Report Extension] -> Int+looksAt name rs = length (filter (== name) (waiters rs))++-- | Which node said it was settling down to wait, in order. See 'looks'.+waiters :: [Report Extension] -> [Text]+waiters rs =+    [ a.shorthand+    | r <- rs+    , a <- case r of+        NextLook a' _ _ -> [a']+        Parked a' -> [a']+        Reapplying a' _ -> [a']+        _ -> []+    ]++-- | How many times this one node ran its @up@ (or spawned its action).+evalsOf :: Text -> [Report Extension] -> Int+evalsOf name rs = length (filter (== name) (evals rs))++{- | How many times this one node's @up@ /finished/. 'evalsOf' counts the+'Salmon.Actions.UpDown.Eval' said on the way in, before the action runs, so+a case that checks the action's effect must wait on this one instead. -}+donesOf :: Text -> [Report Extension] -> Int+donesOf name rs = length [() | Acted (UpDown.Done act) <- rs, act.shorthand == name]++reachedBy :: Text -> UpkeepState -> [Report Extension] -> Int+reachedBy name want rs = length (filter (== name) (reached want rs))++-------------------------------------------------------------------------------+-- building nodes++counter :: IO (IORef Int, IO ())+counter = do+    v <- newIORef 0+    pure (v, atomicModifyIORef' v (\n -> (n + 1, ())))++node :: Text -> (Extension -> Extension) -> Op+node name f = op name nodeps (\x -> f x{ref = mkRef "upkeep" name})++nodeOn :: Text -> [Op] -> (Extension -> Extension) -> Op+nodeOn name preds f = op name (deps preds) (\x -> f x{ref = mkRef "upkeep" name})++refOf :: Text -> Ref+refOf = mkRef "upkeep"++-------------------------------------------------------------------------------++delayClamps :: IO ()+delayClamps = do+    let floored = iterate Upkeep.attentive Upkeep.initialDelay !! 10+    let capped = iterate Upkeep.relaxed Upkeep.initialDelay !! 20+    assertEqual "halving stops at the floor" Upkeep.delayFloor (Upkeep.delayMicros floored)+    assertEqual "doubling stops at the cap" Upkeep.delayCap (Upkeep.delayMicros capped)+    assertBool+        "one relaxation is a real increase"+        (Upkeep.delayMicros (Upkeep.relaxed Upkeep.initialDelay) > Upkeep.delayFloor)++-- | The common case, and the one that has to cost nothing: a node whose+-- effect is already in place is not touched, and its machine settles into+-- watching it.+satisfiedRests :: IO ()+satisfiedRests = within 10 $ do+    (ran, bump) <- counter+    let o = node "sat" $ \x -> x{check = pure Success, up = bump}+    rs <- supervising (dagOf o) allUp $ \_ trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        seen trace+    assertEqual "nothing ran" 0 =<< readIORef ran+    assertEqual "reported as skipped" ["sat"] (skips rs)+    assertEqual "and never evaluated" [] (evals rs)++unsatisfiedIsUpped :: IO ()+unsatisfiedIsUpped = within 10 $ do+    (ran, bump) <- counter+    let o = node "unsat" $ \x -> x{check = pure (Failure "not yet"), up = bump}+    rs <- supervising (dagOf o) allUp $ \_ trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        seen trace+    assertEqual "ran once" 1 =<< readIORef ran+    assertEqual "evaluated" ["unsat"] (evals rs)+    assertEqual "passed through Upping on the way" ["unsat"] (reached Upping rs)++{- | The refinement this module makes to the spec's rule: 'Unknown' is not+evidence the effect went away, so it must not restart anything. Were it+treated the way the one-shot drivers treat it — as+'Salmon.Actions.UpDown.Required' — this node would re-run @up@ at the delay+floor for as long as the process lived.++The check here answers 'Unknown' explicitly. That used to be the same thing+as having no check at all; it is not any more (see 'immaterialParks'), and+the two rules are worth pinning separately: this one is about a check that+ran and could not tell, which is a node that keeps being asked.+-}+unknownDoesNotSpin :: IO ()+unknownDoesNotSpin = within 10 $ do+    (ran, bump) <- counter+    let o = node "quiet" $ \x -> x{check = pure Unknown, up = bump}+    supervising (dagOf o) allUp $ \sup trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        assertEqual "upped once on the way in" 1 =<< readIORef ran+        -- Recheck collapses the delay and looks now, so this does not wait+        -- out a real nap to prove the second look happened.+        void (Upkeep.instruct sup (refOf "quiet") Recheck)+        await trace (\rs -> looks rs >= 2)+        assertEqual "and looking again did not re-up it" 1 =<< readIORef ran+        rs <- seen trace+        assertEqual "a node with a check is polled, not parked" 0 (length [() | Parked{} <- rs])++{- | The other half of the same story, and the one that covers most of this+repository. A node with no @check@ answers 'Immaterial' — "asking costs what+applying costs" — and there is then nothing for a timer to be for, so the+machine parks on its mailbox instead of waking to be told the same thing at+the delay cap forever.++It takes exactly one look to get there, and that is not an oversight: what+a machine knows on the way in is that its @up@ ran, not what its check would+say about it. It announces one 'NextLook', asks once, is told 'Immaterial',+and never asks again — which is the difference between one wasted check per+supervisor and one per minute forever.++Parked is not unwatched: the operator still gets through, which is what the+'Recheck' here shows. That it is answered with another 'Parked' rather than+a 'NextLook' is the point — the node looked, learned nothing again, and went+straight back to waiting.+-}+immaterialParks :: IO ()+immaterialParks = within 10 $ do+    (ran, bump) <- counter+    -- no `check` at all, so `runCheck` answers Immaterial.+    let o = node "cheap" $ \x -> x{up = bump}+    supervising (dagOf o) allUp $ \sup trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        assertEqual "upped once on the way in" 1 =<< readIORef ran+        await trace (\rs -> not (null [() | Parked{} <- rs]))+        rs0 <- seen trace+        assertEqual "one look, and then it knew" 1 (length [() | NextLook{} <- rs0])+        void (Upkeep.instruct sup (refOf "cheap") Recheck)+        await trace (\rs -> looks rs >= 3)+        rs <- seen trace+        assertEqual "and no further look was ever announced" 1 (length [() | NextLook{} <- rs])+        assertEqual "being woken did not re-up it" 1 =<< readIORef ran++{- | Parking must not cost the node the one thing supervision is for. A+'Salmon.Op.Supervision.RestForOne' dependency going away is an event, not a+timer, so a parked dependant still hears it and is brought up again on top+of whatever the dependency turns into.+-}+parkedNodeIsStillDemotable :: IO ()+parkedNodeIsStillDemotable = within 20 $ do+    (cfg, _, there) <- breakable "cfg" [] restForOne+    -- no check, so it parks the moment it is up+    (svc, svcRan) <- counted "svc" [cfg] id+    supervising (dagOf svc) allUp $ \sup trace -> do+        await trace (\rs -> reachedBy "svc" Up rs >= 1)+        await trace (\rs -> not (null [() | Parked a <- rs, a.shorthand == "svc"]))+        assertEqual "up once so far" 1 =<< readIORef svcRan+        breakIt sup there "cfg"+        await trace (\rs -> reachedBy "svc" Up rs >= 2)+        rs <- seen trace+        assertEqual "the parked node was sent back" [("svc", refOf "cfg")] (demotions rs)+        assertEqual "and brought up again on the new config" 2 =<< readIORef svcRan++{- | The point of the whole module: a node that was up and is not any more+gets put back, with nobody re-declaring anything.+-}+vanishedComesBack :: IO ()+vanishedComesBack = within 10 $ do+    there <- newIORef False+    (ran, bump) <- counter+    let o =+            node "svc" $+                \x ->+                    x+                        { check = do+                            ok <- readIORef there+                            pure (if ok then Success else Failure "gone")+                        , up = bump >> writeIORef there True+                        }+    supervising (dagOf o) allUp $ \sup trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        assertEqual "brought up once" 1 =<< readIORef ran+        -- the effect disappears behind salmon's back+        writeIORef there False+        void (Upkeep.instruct sup (refOf "svc") Recheck)+        await trace (\rs -> length (evals rs) >= 2)+        assertEqual "and was put back" 2 =<< readIORef ran++neverLeavesItAlone :: IO ()+neverLeavesItAlone = within 10 $ do+    there <- newIORef False+    (ran, bump) <- counter+    let o =+            node "once" $+                \x ->+                    x+                        { check = do+                            ok <- readIORef there+                            pure (if ok then Success else Failure "gone")+                        , up = bump >> writeIORef there True+                        , dynamics = [supervised defaultSupervision{supRestart = Never}]+                        }+    supervising (dagOf o) allUp $ \sup trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        writeIORef there False+        void (Upkeep.instruct sup (refOf "once") Recheck)+        await trace (\rs -> looks rs >= 2)+        assertEqual "the policy said don't, so it didn't" 1 =<< readIORef ran++{- | 'Completed' is a satisfied verdict — a job that ran and stopped on+purpose — so 'Always' acting on it only works if the policy is consulted+before satisfaction is, which is what this pins down.+-}+alwaysActsOnCompleted :: IO ()+alwaysActsOnCompleted = within 10 $ do+    (ran, bump) <- counter+    let o =+            node "job" $+                \x ->+                    x+                        { check = pure Completed+                        , up = bump+                        , dynamics = [supervised defaultSupervision{supRestart = Always}]+                        }+    supervising (dagOf o) allUp $ \sup trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        assertEqual "a Completed check skipped it on the way in" ["job"] . skips =<< seen trace+        void (Upkeep.instruct sup (refOf "job") Recheck)+        await trace (\rs -> not (null (evals rs)))+        assertEqual "but Always ran it anyway" 1 =<< readIORef ran++dependantWaits :: IO ()+dependantWaits = within 10 $ do+    gate <- newEmptyMVar+    (ran, bump) <- counter+    let dep = node "dep" $ \x -> x{up = takeMVar gate}+        top = nodeOn "top" [dep] $ \x -> x{up = bump}+    supervising (dagOf top) allUp $ \_ trace -> do+        await trace (\rs -> "dep" `elem` evals rs)+        assertEqual "the dependant has not run" 0 =<< readIORef ran+        putMVar gate ()+        await trace (\rs -> "top" `elem` evals rs)+        assertEqual "and now it has" 1 =<< readIORef ran++{- | The sharpest difference from the one-shot drivers. There, a node whose+dependency failed is reported 'Salmon.Actions.UpDown.Blocked' and the pass+ends. Here the dependency's own machine is still retrying, so the dependant+waits and proceeds the moment the dependency recovers — no 'Blocked', and+nobody re-declares anything.+-}+failureIsWaitedOut :: IO ()+failureIsWaitedOut = within 20 $ do+    attempts <- newIORef (0 :: Int)+    (ran, bump) <- counter+    let dep = node "flaky" $ \x ->+            x+                { up = do+                    n <- atomicModifyIORef' attempts (\k -> (k + 1, k))+                    unless (n > 0) (ioError (userError "first time always fails"))+                }+        top = nodeOn "onflaky" [dep] $ \x -> x{up = bump}+    supervising (dagOf top) allUp $ \sup trace -> do+        await trace (\rs -> length [() | Acted (UpDown.Failed _ _) <- rs] >= 1)+        assertEqual "the dependant is held off" 0 =<< readIORef ran+        rs <- seen trace+        assertEqual "and is not reported Blocked" [] (blockeds rs)+        -- skip the backoff rather than sleeping through it+        void (Upkeep.instruct sup (refOf "flaky") Recheck)+        await trace (\rs -> "onflaky" `elem` evals rs)+        assertEqual "it proceeds once the dependency recovers" 1 =<< readIORef ran++{- | A node nobody is tending will never move, so waiting for it to move+would be waiting forever. It is reported and stepped over — the same call the+one-shot drivers' gate makes when it answers 'UpDown.Skippable'.+-}+untendedNotWaited :: IO ()+untendedNotWaited = within 10 $ do+    (ran, bump) <- counter+    let dep = node "other" $ \x -> x{up = ioError (userError "must never run")}+        top = nodeOn "mine" [dep] $ \x -> x{up = bump}+    let mine = refOf "mine"+    rs <- supervising (dagOf top) (\rf -> if rf == mine then Just (Tend TurnUp Unsettled) else Nothing) $ \_ trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        seen trace+    assertEqual "the tended node ran" 1 =<< readIORef ran+    assertEqual "the other one is named as untended" ["other"] [act.shorthand | Untended act <- rs]+    assertEqual "and never ran" ["mine"] (evals rs)++cycleIsReported :: IO ()+cycleIsReported = within 10 $ do+    let leaf name = node name id+        magma =+            Map.fromList+                [ (act.extension.ref, act)+                | o <- [leaf "cyc-a", leaf "cyc-b"]+                , Just act <- [opAct o]+                ]+        looped =+            Set.fromList+                [ (refOf "cyc-a", refOf "cyc-b")+                , (refOf "cyc-b", refOf "cyc-a")+                ]+    rs <- supervising (Dag.fromMagma magma looped) allUp $ \sup trace -> do+        await trace (\rs -> not (null [() | Supervising{} <- rs]))+        assertEqual "no machine was started" 0 (Map.size (Upkeep.supervisorTending sup))+        seen trace+    assertEqual "both nodes reported Blocked" 2 (length (blockeds rs))+    assertEqual "and neither evaluated" [] (evals rs)++{- | Teardown is the same wait with the adjacency direction swapped: the+directory goes only after the file in it. 'Down' is terminal, so both+machines exit on their own.+-}+teardownOrdering :: IO ()+teardownOrdering = within 10 $ do+    logRef <- newIORef []+    let rec name = atomicModifyIORef' logRef (\xs -> (name : xs, ()))+        dir = node "dir" $ \x -> x{down = rec ("dir" :: Text)}+        file = nodeOn "file" [dir] $ \x -> x{down = rec "file"}+    rs <- supervising (dagOf file) allDown $ \_ trace -> do+        await trace (\rs -> length (reachedDown Down rs) >= 2)+        seen trace+    order <- reverse <$> readIORef logRef+    assertEqual "the dependant came down first" ["file", "dir"] order+    assertEqual "both machines finished" 2 (length (reachedDown Down rs))++{- | 'Pause' and 'Resume' are the two instructions that mean nothing to a+one-shot driver. Pausing a node still waiting on its dependency proves the+pause is real: the dependency settles while it is paused, and the node stays+put until told to carry on.+-}+pauseAndResume :: IO ()+pauseAndResume = within 10 $ do+    gate <- newEmptyMVar+    (ran, bump) <- counter+    let dep = node "gate" $ \x -> x{up = takeMVar gate}+        top = nodeOn "held" [dep] $ \x -> x{up = bump}+    supervising (dagOf top) allUp $ \sup trace -> do+        await trace (\rs -> "gate" `elem` evals rs)+        void (Upkeep.instruct sup (refOf "held") Pause)+        await trace (\rs -> not (null [() | Paused _ <- rs]))+        -- the dependency now settles; a tended node would proceed here+        putMVar gate ()+        await trace (\rs -> "gate" `elem` [act.shorthand | Acted (UpDown.Done act) <- rs])+        assertEqual "the paused node stayed put" 0 =<< readIORef ran+        void (Upkeep.instruct sup (refOf "held") Resume)+        await trace (\rs -> "held" `elem` evals rs)+        assertEqual "and moved once resumed" 1 =<< readIORef ran++{- | The watchdog is a node author saying what their node's silence would+mean. It only reports — there is nothing here that could safely kill an @up@+halfway through — but reporting is what an operator needs, and it is what+tells a slow node from a stuck one.+-}+watchdogFires :: IO ()+watchdogFires = within 10 $ do+    gate <- newEmptyMVar+    let o =+            node "wedges" $+                \x ->+                    x+                        { up = takeMVar gate+                        , dynamics = [supervised defaultSupervision{supWatchdog = Just (millis 300)}]+                        }+    supervising (dagOf o) allUp $ \_ trace -> do+        await trace (\rs -> not (null [() | Wedged{} <- rs]))+        putMVar gate ()+        await trace (\rs -> not (null [() | Unwedged{} <- rs]))+        rs <- seen trace+        assertEqual "named once while stuck" ["wedges"] [act.shorthand | Wedged act _ <- rs]+        assertEqual "and once when it moved again" ["wedges"] [act.shorthand | Unwedged act <- rs]++{- | @dynamics@ is untyped, so nothing stops an author stating two+contradictory policies. One is taken and the rest are reported, exactly as a+conflicting magma representative is.+-}+policyConflict :: IO ()+policyConflict = within 10 $ do+    let first = defaultSupervision{supRestart = Never}+        second = defaultSupervision{supRestart = Always, supWatchdog = Just (millis 500)}+    let o =+            node "twominds" $+                \x -> x{check = pure Success, dynamics = [toDyn first, toDyn second]}+    rs <- supervising (dagOf o) allUp $ \_ trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        seen trace+    assertEqual+        "the first is in force and the second is named"+        [(first, [second])]+        [(inForce, ignored) | Policy _ inForce ignored <- rs]++{- | Stopping a supervisor stops tending; it does not interrupt work in+flight. Cutting an @up@ halfway is how a half-applied effect happens, so+'stopUpkeep' waits it out.+-}+stopWaitsForUp :: IO ()+stopWaitsForUp = within 10 $ do+    finished <- newIORef False+    let o =+            node "slow" $+                \x -> x{up = threadPause >> writeIORef finished True}+    supervising (dagOf o) allUp $ \_ trace ->+        await trace (\rs -> "slow" `elem` evals rs)+    assertBool "the in-flight up ran to completion" =<< readIORef finished+  where+    -- long enough that a stop which cut the thread would win the race+    threadPause = threadDelay 400000++{- | The one thing 'Standing' exists for. Almost no node in this repository+implements @check@, so almost every node answers 'Unknown' — and a+supervisor started after a convergence pass would run every one of their+@up@s a second time if it took that answer at face value. It is told what+the pass achieved instead.++The node still gets watched: its check is consulted on the ordinary delay,+and 'vanishedComesBack' is the case that shows it acting on the answer.+-}+settledIsNotReUpped :: IO ()+settledIsNotReUpped = within 10 $ do+    (ran, bump) <- counter+    -- no check, so nothing about the node itself can confirm its effect+    let o = node "already" $ \x -> x{up = bump}+    supervising (dagOf o) restingUp $ \sup trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        assertEqual "it was not applied" 0 =<< readIORef ran+        rs <- seen trace+        assertEqual "and never evaluated" [] (evals rs)+        -- but it is genuinely being watched+        void (Upkeep.instruct sup (refOf "already") Recheck)+        await trace (\rs -> looks rs >= 2)+        assertEqual "looking still does not re-up a checkless node" 0 =<< readIORef ran++{- | The false positive the "has it said anything at all" clause in+'Salmon.Op.Status.wedged' exists to avoid. Both nodes here declare a short+watchdog and both are 'Transient' for well past it — but only one of them is+doing anything. The other is in 'WaitUp' behind it, and reporting /that/ as+wedged would point at the wrong node.+-}+watchdogSkipsWaiters :: IO ()+watchdogSkipsWaiters = within 10 $ do+    gate <- newEmptyMVar+    let policy = supervised defaultSupervision{supWatchdog = Just (millis 300)}+        dep = node "slowdep" $ \x -> x{up = takeMVar gate, dynamics = [policy]}+        top = nodeOn "waiter" [dep] $ \x -> x{dynamics = [policy]}+    supervising (dagOf top) allUp $ \_ trace -> do+        await trace (\rs -> not (null [() | Wedged{} <- rs]))+        rs <- seen trace+        assertEqual+            "only the node actually doing something is named"+            ["slowdep"]+            [act.shorthand | Wedged act _ <- rs]+        putMVar gate ()+        await trace (\rs -> "waiter" `elem` evals rs)++-------------------------------------------------------------------------------+-- nodes that own their effect++{- | These use a plain 'IO' 'ExitCode' as the "process", which is all the+machine ever sees of one — the state machine's job is the racing, the+policy and the accounting, and none of that is easier to see through a real+subprocess. @Test.DaemonSpec@ covers the part that /is/ about processes:+signals, groups, and pipes.+-}+exits :: Int -> ExitCode+exits 0 = ExitSuccess+exits n = ExitFailure n++{- | A managed node: counts its spawns and hands each one the action to run.++The count is a 'TVar' rather than an 'IORef' so a case can /wait/ for it. The+machine reports @Eval@ before it starts the action, so any assertion made off+the report stream alone races the thread that does the spawning.+-}+holder :: Text -> TVar Int -> IO ExitCode -> (Extension -> Extension) -> Op+holder name = holderOn name []++holderOn :: Text -> [Op] -> TVar Int -> IO ExitCode -> (Extension -> Extension) -> Op+holderOn name preds spawns action f =+    nodeOn name preds $ \x ->+        f+            x+                { managed = Just $ \_out -> do+                    atomically (modifyTVar' spawns (+ 1))+                    action+                }++spawnCounter :: IO (TVar Int)+spawnCounter = newTVarIO 0++-- | Block until the action has been started at least this many times.+awaitSpawns :: TVar Int -> Int -> IO ()+awaitSpawns v n = atomically (readTVar v >>= \k -> unless (k >= n) retry)++spawnsSoFar :: TVar Int -> IO Int+spawnsSoFar = readTVarIO++verdicts :: [Report Extension] -> [CheckResult]+verdicts rs = [v | NextLook _ v _ <- rs]++managedIsUpWhileRunning :: IO ()+managedIsUpWhileRunning = within 10 $ do+    gate <- newEmptyMVar+    spawns <- spawnCounter+    let o = holder "svc" spawns (takeMVar gate >> pure ExitSuccess) id+    supervising (dagOf o) allUp $ \_ trace -> do+        -- Up as soon as the action is running: for a node whose action is+        -- the effect, that is the whole of being up.+        await trace (\rs -> not (null (reached Up rs)))+        awaitSpawns spawns 1+        assertEqual "spawned once" 1 =<< spawnsSoFar spawns+        rs <- seen trace+        assertEqual "and reported Done, which is what lets serve converge it" ["svc"] [act.shorthand | Acted (UpDown.Done act) <- rs]+        putMVar gate ()++managedOutputIsReported :: IO ()+managedOutputIsReported = within 10 $ do+    gate <- newEmptyMVar+    let o =+            nodeOn "chatty" [] $ \x ->+                x+                    { managed = Just $ \out -> do+                        out "one"+                        out "two"+                        takeMVar gate >> pure ExitSuccess+                    }+    supervising (dagOf o) allUp $ \_ trace -> do+        await trace (\rs -> length [() | Output{} <- rs] >= 2)+        rs <- seen trace+        assertEqual+            "the lines, attributed to the node, in the order written"+            [("chatty", "one"), ("chatty", "two")]+            [(act.shorthand, line) | Output act line <- rs]+        putMVar gate ()++managedCleanExitRests :: IO ()+managedCleanExitRests = within 10 $ do+    spawns <- spawnCounter+    let o = holder "job" spawns (pure ExitSuccess) id+    supervising (dagOf o) allUp $ \_ trace -> do+        await trace (\rs -> Completed `elem` verdicts rs)+        assertEqual "ran once and was left alone" 1 =<< spawnsSoFar spawns++managedFailureRestarts :: IO ()+managedFailureRestarts = within 20 $ do+    spawns <- spawnCounter+    let o = holder "flapper" spawns (pure (exits 3)) id+    supervising (dagOf o) allUp $ \_ _ -> do+        awaitSpawns spawns 2+        n <- spawnsSoFar spawns+        assertBool "put back after a non-zero exit" (n >= 2)++managedNeverStaysDown :: IO ()+managedNeverStaysDown = within 10 $ do+    spawns <- spawnCounter+    let o = holder "once" spawns (pure (exits 1)) $ \x ->+            x{dynamics = [supervised defaultSupervision{supRestart = Never}]}+    supervising (dagOf o) allUp $ \sup trace -> do+        -- it has stopped and settled; nothing put it back+        await trace (\rs -> any isFailure (verdicts rs))+        assertEqual "ran once" 1 =<< spawnsSoFar spawns+        -- and a look does not change its mind either+        void (Upkeep.instruct sup (refOf "once") Recheck)+        await trace (\rs -> length (verdicts rs) >= 2)+        assertEqual "still once" 1 =<< spawnsSoFar spawns+  where+    isFailure (Failure _) = True+    isFailure _ = False++managedAlwaysRestarts :: IO ()+managedAlwaysRestarts = within 20 $ do+    spawns <- spawnCounter+    let o = holder "reloader" spawns (pure ExitSuccess) $ \x ->+            x{dynamics = [supervised defaultSupervision{supRestart = Always}]}+    supervising (dagOf o) allUp $ \_ _ -> do+        awaitSpawns spawns 2+        n <- spawnsSoFar spawns+        assertBool "a clean exit is not the end of it under Always" (n >= 2)++{- | The one shape a process handle cannot speak to: a daemon that exits 0+having forked. Consulting the check before the policy handles it for free,+and this is what pins that ordering.+-}+managedDoubleFork :: IO ()+managedDoubleFork = within 10 $ do+    forked <- newIORef False+    spawns <- spawnCounter+    let o = holder "forker" spawns (writeIORef forked True >> pure ExitSuccess) $ \x ->+            x+                { -- as a real double-forking daemon looks: nothing there+                  -- until it has run, and there afterwards even though the+                  -- process salmon spawned has exited.+                  check = do+                    up' <- readIORef forked+                    pure (if up' then Success else Failure "not yet")+                , dynamics = [supervised defaultSupervision{supRestart = Always}]+                }+    supervising (dagOf o) allUp $ \sup trace -> do+        awaitSpawns spawns 1+        await trace (\rs -> Success `elem` verdicts rs)+        -- `Always` would otherwise restart even a clean exit. The check+        -- saying the effect is there anyway is what stops it, and is the+        -- only thing that could.+        void (Upkeep.instruct sup (refOf "forker") Recheck)+        await trace (\rs -> length (verdicts rs) >= 2)+        assertEqual "the check outranks the policy" 1 =<< spawnsSoFar spawns++managedGivesUp :: IO ()+managedGivesUp = within 20 $ do+    spawns <- spawnCounter+    let o = holder "hopeless" spawns (pure (exits 1)) $ \x ->+            x{dynamics = [supervised defaultSupervision{supGiveUpAfter = Just 2}]}+    supervising (dagOf o) allUp $ \sup trace -> do+        await trace (\rs -> not (null [n | GaveUp _ n <- rs]))+        assertEqual "tried exactly as often as it was told to" 2 =<< spawnsSoFar spawns+        rs <- seen trace+        assertEqual "and says how many times" [2] [n | GaveUp _ n <- rs]+        -- parked, not gone: an operator can change their mind+        void (Upkeep.instruct sup (refOf "hopeless") Force)+        awaitSpawns spawns 3+        n <- spawnsSoFar spawns+        assertBool "forcing starts it over" (n >= 3)++{- | Without 'supStableAfter' a give-up limit latches off any long-lived node+eventually: a service that falls over once a day reaches any finite count in+that many days, having never been in a crash loop. So only /consecutive+quick/ failures count.+-}+managedStableResets :: IO ()+managedStableResets = within 30 $ do+    spawns <- spawnCounter+    let o = holder "daily" spawns (threadDelay 200000 >> pure (exits 1)) $ \x ->+            x+                { dynamics =+                    [ supervised+                        defaultSupervision+                            { supGiveUpAfter = Just 2+                            , supStableAfter = millis 100+                            }+                    ]+                }+    supervising (dagOf o) allUp $ \_ trace -> do+        awaitSpawns spawns 3+        rs <- seen trace+        assertEqual "having run past supStableAfter, it never accumulates" [] [n | GaveUp _ n <- rs]++{- | Teardown is cancelling the machine, and whatever bracket the action is+built from is what does the killing. This is the property+"Salmon.Builtin.Nodes.Daemon" relies on entirely.+-}+managedCancelTearsDown :: IO ()+managedCancelTearsDown = within 10 $ do+    torn <- newIORef False+    blocker <- newEmptyMVar+    spawns <- spawnCounter+    let o =+            holder "held" spawns+                ( bracket+                    (pure ())+                    (\() -> writeIORef torn True)+                    (\() -> takeMVar blocker >> pure ExitSuccess)+                )+                id+    -- `supervising` stops the supervisor on the way out, and a machine+    -- holding an effect is only ever taken by a cancel.+    supervising (dagOf o) allUp $ \_ _ ->+        awaitSpawns spawns 1+    assertBool "the action's own bracket ran" =<< readIORef torn++{- | A 'Settled' claim is about an effect that persists on its own. A managed+effect does not persist without the machine holding it, so a caller believing+otherwise (@serve@ does, for any node a pass marked converged) must not stop+it being spawned.+-}+managedIgnoresSettled :: IO ()+managedIgnoresSettled = within 10 $ do+    gate <- newEmptyMVar+    spawns <- spawnCounter+    let o = holder "wrongly-settled" spawns (takeMVar gate >> pure ExitSuccess) id+    supervising (dagOf o) restingUp $ \_ _ -> do+        awaitSpawns spawns 1+        assertEqual "spawned anyway" 1 =<< spawnsSoFar spawns+        putMVar gate ()++managedForceRestarts :: IO ()+managedForceRestarts = within 10 $ do+    torn <- newIORef (0 :: Int)+    spawns <- spawnCounter+    blocker <- newEmptyMVar+    let o =+            holder "restartable" spawns+                ( bracket+                    (pure ())+                    (\() -> atomicModifyIORef' torn (\n -> (n + 1, ())))+                    (\() -> takeMVar blocker >> pure ExitSuccess)+                )+                id+    supervising (dagOf o) allUp $ \sup _ -> do+        awaitSpawns spawns 1+        void (Upkeep.instruct sup (refOf "restartable") Force)+        awaitSpawns spawns 2+        assertEqual "the old one was torn down before the new one spawned" 1 =<< readIORef torn+        assertEqual "and there is a new one" 2 =<< spawnsSoFar spawns++-------------------------------------------------------------------------------+-- a node that takes its dependants with it++{- | Milestone 9's cases. All eight share one shape: a dependency is made to+leave 'Up' at a moment the case controls (its effect is removed behind+salmon's back, then it is 'Recheck'ed), and what the /dependant/ does about+it is the assertion.++Nothing here sleeps to decide anything. The two negative cases are the+exception and say so: proving something does not happen needs a bounded wait+for it, and a 'timeout' returning 'Nothing' is that wait made explicit.+-}+restForOne :: Extension -> Extension+restForOne x = x{dynamics = [supervised defaultSupervision{supStrategy = RestForOne}]}++-- | Opts a node into 'Salmon.Op.Supervision.supReapply': re-run @up@ on the+-- loop instead of parking. See the "supReapply" test group.+reapplying :: Extension -> Extension+reapplying x = x{dynamics = [supervised defaultSupervision{supReapply = True}]}++-- | Both at once: the shape a config-file-that-happens-to-be-cheap would+-- declare, and the case that pins 'supReapply' must not fire 'RestForOne'+-- on a success — only a genuine departure may.+reapplyingRestForOne :: Extension -> Extension+reapplyingRestForOne x = x{dynamics = [supervised defaultSupervision{supReapply = True, supStrategy = RestForOne}]}++-- | Like 'reapplying', but gives up after exactly one failure — deterministic+-- without needing to wait out a real backoff or a real 'supStableAfter'.+reapplyingGivesUpFast :: Extension -> Extension+reapplyingGivesUpFast x = x{dynamics = [supervised defaultSupervision{supReapply = True, supGiveUpAfter = Just 1}]}++{- | A node whose effect can be taken away behind salmon's back. Hands back+the count of its @up@s and the flag that says whether its effect is there.+-}+breakable :: Text -> [Op] -> (Extension -> Extension) -> IO (Op, IORef Int, IORef Bool)+breakable name preds f = do+    there <- newIORef False+    (ran, bump) <- counter+    let o =+            nodeOn name preds $ \x ->+                f+                    x+                        { check = do+                            ok <- readIORef there+                            pure (if ok then Success else Failure "gone")+                        , up = bump >> writeIORef there True+                        }+    pure (o, ran, there)++{- | A node that only counts. Deliberately without a @check@, so that being+sent back to 'WaitUp' really does re-run its @up@ — which is what makes a+demotion visible at all, and is the case a repository whose nodes mostly have+no check actually has.+-}+counted :: Text -> [Op] -> (Extension -> Extension) -> IO (Op, IORef Int)+counted name preds f = do+    (ran, bump) <- counter+    pure (nodeOn name preds (\x -> f x{up = bump}), ran)++-- | Take the effect away and tell the node to look now.+breakIt :: Supervisor Extension -> IORef Bool -> Text -> IO ()+breakIt sup there name = do+    writeIORef there False+    void (Upkeep.instruct sup (refOf name) Recheck)++{- | The payoff of the whole milestone: a service standing on a configuration+file that has just been rewritten is brought up again on the new one, rather+than left running against content it has never seen.+-}+restForOneDemotes :: IO ()+restForOneDemotes = within 20 $ do+    (cfg, cfgRan, there) <- breakable "cfg" [] restForOne+    (svc, svcRan) <- counted "svc" [cfg] id+    supervising (dagOf svc) allUp $ \sup trace -> do+        await trace (\rs -> reachedBy "svc" Up rs >= 1)+        assertEqual "the service came up on the original config" 1 =<< readIORef svcRan+        breakIt sup there "cfg"+        await trace (\rs -> reachedBy "svc" Up rs >= 2)+        rs <- seen trace+        assertEqual "it was sent back by its config" [("svc", refOf "cfg")] (demotions rs)+        assertEqual "and brought up again on the new one" 2 =<< readIORef svcRan+        assertEqual "which had itself been rewritten" 2 =<< readIORef cfgRan++{- | ...and the property that makes the feature safe to have landed at all:+until a node says otherwise, its dependants are not anybody's business. This+is today's behaviour, asserted so that it stays that way.+-}+oneForOneLeavesItAlone :: IO ()+oneForOneLeavesItAlone = within 20 $ do+    -- no strategy declared, so 'OneForOne'+    (cfg, _, there) <- breakable "cfg" [] id+    (svc, svcRan) <- counted "svc" [cfg] id+    supervising (dagOf svc) allUp $ \sup trace -> do+        await trace (\rs -> reachedBy "svc" Up rs >= 1)+        breakIt sup there "cfg"+        await trace (\rs -> reachedBy "cfg" Up rs >= 2)+        -- one full turn of svc's own loop after the config came back, so+        -- that "it did not react" is a statement about a machine that has+        -- since run rather than one that has not got there yet.+        void (Upkeep.instruct sup (refOf "svc") Recheck)+        await trace (\rs -> looksAt "svc" rs >= 2)+        rs <- seen trace+        assertEqual "nobody was sent back" [] (demotions rs)+        assertEqual "and the service was never touched" 1 =<< readIORef svcRan++{- | Being demoted is going back to 'WaitUp', not going back to 'Upping'.+The distinction is the whole point: a node brought up again immediately would+be brought up against the very dependency that is currently missing.+-}+demotedWaitsForItsDependency :: IO ()+demotedWaitsForItsDependency = within 20 $ do+    gate <- newEmptyMVar+    there <- newIORef False+    (cfgRan, cfgBump) <- counter+    let cfg =+            node "cfg" $ \x ->+                restForOne+                    x+                        { check = do+                            ok <- readIORef there+                            pure (if ok then Success else Failure "gone")+                        , up = do+                            n <- readIORef cfgRan+                            cfgBump+                            -- the repair is held open, so the dependency+                            -- stays visibly in flight+                            unless (n == 0) (takeMVar gate)+                            writeIORef there True+                        }+    (svc, svcRan) <- counted "svc" [cfg] id+    supervising (dagOf svc) allUp $ \sup trace -> do+        await trace (\rs -> reachedBy "svc" Up rs >= 1)+        breakIt sup there "cfg"+        await trace (\rs -> reachedBy "svc" WaitUp rs >= 2)+        assertEqual "waiting, not acting" 1 =<< readIORef svcRan+        putMVar gate ()+        await trace (\rs -> evalsOf "svc" rs >= 2)+        assertEqual "and only once the dependency was back" 2 =<< readIORef svcRan++{- | A demoted node is itself no longer up, which is all a dependant of /it/+that opted in needs to see. Nothing propagates the cascade; it falls out.+-}+demotionCascades :: IO ()+demotionCascades = within 20 $ do+    (cfg, _, there) <- breakable "cfg" [] restForOne+    (mid, midRan) <- counted "mid" [cfg] restForOne+    (leaf, leafRan) <- counted "leaf" [mid] id+    supervising (dagOf leaf) allUp $ \sup trace -> do+        await trace (\rs -> reachedBy "leaf" Up rs >= 1)+        breakIt sup there "cfg"+        await trace (\rs -> reachedBy "leaf" Up rs >= 2)+        rs <- seen trace+        assertEqual+            "each was sent back by the one in front of it, in that order"+            [("mid", refOf "cfg"), ("leaf", refOf "mid")]+            (demotions rs)+        assertEqual "mid came up again" 2 =<< readIORef midRan+        assertEqual "and so did leaf" 2 =<< readIORef leafRan++-- | The overwhelmingly common shape, and it must cost nothing.+noDependantsCostsNothing :: IO ()+noDependantsCostsNothing = within 20 $ do+    (solo, ran, there) <- breakable "solo" [] restForOne+    supervising (dagOf solo) allUp $ \sup trace -> do+        await trace (\rs -> reachedBy "solo" Up rs >= 1)+        breakIt sup there "solo"+        await trace (\rs -> reachedBy "solo" Up rs >= 2)+        rs <- seen trace+        assertEqual "it demoted nobody, itself included" [] (demotions rs)+        assertEqual "it just put its own effect back" 2 =<< readIORef ran++{- | The hazard this milestone had to be designed against: a dependency that+flaps would otherwise rebuild the whole cone behind it on every flap.++'Salmon.Op.Supervision.supDemoteEvery' bounds it to once per interval, and+the default of ten seconds is well beyond what this case takes — so the+second departure is dropped rather than delayed.+-}+flapIsRateLimited :: IO ()+flapIsRateLimited = within 30 $ do+    (cfg, _, there) <- breakable "cfg" [] restForOne+    (svc, svcRan) <- counted "svc" [cfg] id+    supervising (dagOf svc) allUp $ \sup trace -> do+        await trace (\rs -> reachedBy "svc" Up rs >= 1)+        breakIt sup there "cfg"+        await trace (\rs -> reachedBy "svc" Up rs >= 2)+        assertEqual "the first departure was acted on" 2 =<< readIORef svcRan+        breakIt sup there "cfg"+        await trace (\rs -> reachedBy "cfg" Up rs >= 3)+        -- proving a thing does not happen: wait for it, and expect not to+        -- get it. Half a second is many turns of both machines.+        again <- timeout 500000 (await trace (\rs -> evalsOf "svc" rs >= 3))+        assertEqual "the second was dropped rather than acted on" Nothing again+        rs <- seen trace+        assertEqual "one demotion, not two" 1 (length (demotions rs))+        assertEqual "and one extra bring-up, not two" 2 =<< readIORef svcRan++{- | The rule that keeps this from undoing 'Standing': a dependency that has+not been seen up yet cannot send anybody back.++Without it, @serve@ — which stands its machines up again after every command+it is handed — would re-run every @up@ in an opted-in cone each time an+operator typed anything, which is exactly the regression 'Standing' exists to+prevent.+-}+settledStartIsNotDemoted :: IO ()+settledStartIsNotDemoted = within 20 $ do+    (cfg, cfgRan, _) <- breakable "cfg" [] restForOne+    (svc, svcRan) <- counted "svc" [cfg] id+    -- the shape a supervisor starts in over a graph a pass has half done:+    -- the dependant is known to be up, the dependency is not.+    let tend aref+            | aref == refOf "svc" = Just (Tend TurnUp Settled)+            | otherwise = Just (Tend TurnUp Unsettled)+    supervising (dagOf svc) tend $ \sup trace -> do+        await trace (\rs -> reachedBy "cfg" Up rs >= 1)+        void (Upkeep.instruct sup (refOf "svc") Recheck)+        await trace (\rs -> looksAt "svc" rs >= 2)+        rs <- seen trace+        assertEqual "coming up for the first time demoted nobody" [] (demotions rs)+        assertEqual "so the standing claim held" 0 =<< readIORef svcRan+        assertEqual "while the dependency did its own work" 1 =<< readIORef cfgRan++{- | The case the feature is really for: the thing standing on the config is+a process salmon owns. Being sent back has to tear it down — through the+action's own bracket, outside the 'Control.Concurrent.Async.withAsync' —+before anything spawns again.+-}+managedDependantIsRestarted :: IO ()+managedDependantIsRestarted = within 20 $ do+    (cfg, _, there) <- breakable "cfg" [] restForOne+    spawns <- spawnCounter+    -- held by this thread, so blocking on it is a wait rather than a+    -- deadlock the runtime is entitled to notice+    gate <- newEmptyMVar+    let svc = holderOn "svc" [cfg] spawns (takeMVar gate) id+    supervising (dagOf svc) allUp $ \sup trace -> do+        await trace (\rs -> reachedBy "svc" Up rs >= 1)+        awaitSpawns spawns 1+        breakIt sup there "cfg"+        awaitSpawns spawns 2+        rs <- seen trace+        assertEqual "the process was sent back by its config" [("svc", refOf "cfg")] (demotions rs)++{- | (I1). A node that owns its process is torn down on the way out of+'Salmon.Actions.Upkeep.watch', so by the time it comes back round its effect+is certainly gone — whatever its own @check@ says.++The check here is one somebody would plausibly write and which is wrong in+the way health checks are wrong: it answers "this ran at some point", not+"it is running now". Before the fix that answer was believed, the node+reported @Skip@ and settled into 'Up' holding nothing, and the process was+gone for good.+-}+managedDemotionOutranksItsOwnCheck :: IO ()+managedDemotionOutranksItsOwnCheck = within 20 $ do+    (cfg, _, there) <- breakable "cfg" [] restForOne+    spawns <- spawnCounter+    gate <- newEmptyMVar+    ranOnce <- newIORef False+    let svc = holderOn "svc" [cfg] spawns (takeMVar gate) $ \x ->+            x+                { check = do+                    stale <- readIORef ranOnce+                    pure (if stale then Success else Failure "not started yet")+                }+    supervising (dagOf svc) allUp $ \sup trace -> do+        await trace (\rs -> reachedBy "svc" Up rs >= 1)+        awaitSpawns spawns 1+        -- from here its check lies: it says the effect is in place, and only+        -- this machine knows it has just cancelled the thing providing it.+        writeIORef ranOnce True+        breakIt sup there "cfg"+        awaitSpawns spawns 2+        rs <- seen trace+        assertEqual "it was sent back" [("svc", refOf "cfg")] (demotions rs)+        assertBool "and put back rather than talked out of it" (null (skips rs))++{- | ...and the other half of the same decision, which is what keeps it a+narrow fix rather than "a demotion always re-applies".++A node whose effect persists on its own has not lost anything by being+demoted — nothing was torn down — so its check is still the authority on+whether the demotion means any work at all. This one says yes, it is fine,+and is believed.+-}+oneShotDemotionAsksItsCheck :: IO ()+oneShotDemotionAsksItsCheck = within 20 $ do+    (cfg, _, there) <- breakable "cfg" [] restForOne+    (ran, bump) <- counter+    let svc = nodeOn "svc" [cfg] $ \x -> x{check = pure Success, up = bump}+    supervising (dagOf svc) allUp $ \sup trace -> do+        await trace (\rs -> reachedBy "svc" Up rs >= 1)+        breakIt sup there "cfg"+        await trace (\rs -> not (null (demotions rs)))+        await trace (\rs -> reachedBy "svc" Up rs >= 2)+        assertEqual "its check said there was nothing to do, and was right" 0 =<< readIORef ran+        rs <- seen trace+        assertBool "so it reported a skip rather than acting" (not (null (skips rs)))++--------------------------------------------------------------------------------+-- a node that reapplies instead of asking (supReapply)++{- | The whole point: a node with 'reapplying' and no @check@ re-runs @up@+on the adaptive delay rather than parking on its mailbox forever. 'Recheck'+collapses the delay exactly as it does for a checked node, which for this+node means "reapply now" rather than "look now".+-}+reapplyRunsAgain :: IO ()+reapplyRunsAgain = within 10 $ do+    (ran, bump) <- counter+    let o = node "cheap-dir" $ \x -> reapplying x{up = bump}+    supervising (dagOf o) allUp $ \sup trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        assertEqual "upped once on the way in" 1 =<< readIORef ran+        await trace (\rs -> not (null [() | Reapplying{} <- rs]))+        rs0 <- seen trace+        assertEqual "never parked, since it opted out of that" 0 (length [() | Parked{} <- rs0])+        void (Upkeep.instruct sup (refOf "cheap-dir") Recheck)+        await trace (\rs -> evalsOf "cheap-dir" rs >= 2)+        assertEqual "reapplied rather than merely looked at" 2 =<< readIORef ran++{- | A successful reapply is not a restart: it must not go back through+'Salmon.Actions.Upkeep.WaitUp' \/ 'Upping', or a node reapplying once a+minute would announce itself exactly like one flapping. 'Upping' is reported+only for this machine's original arrival at 'Up'.+-}+reapplyStaysInUp :: IO ()+reapplyStaysInUp = within 10 $ do+    (ran, bump) <- counter+    let o = node "steady" $ \x -> reapplying x{up = bump}+    supervising (dagOf o) allUp $ \sup trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        void (Upkeep.instruct sup (refOf "steady") Recheck)+        void (Upkeep.instruct sup (refOf "steady") Recheck)+        await trace (\rs -> evalsOf "steady" rs >= 3)+        rs <- seen trace+        assertEqual "Upping was only ever the original arrival" 1 (reachedBy "steady" Upping rs)+        assertEqual "and Up was only ever entered once" 1 (reachedBy "steady" Up rs)++{- | The interaction 'Salmon.Op.Supervision.supReapply' has to get right+with 'RestForOne': re-applying is not the dependency "going away and coming+back" from a dependant's point of view, so a dependant that opted in must+not be sent back merely because the dependency reapplied successfully —+only a genuine departure (a real 'Salmon.Actions.UpDown.Failure', or an+operator's 'Force') may do that.+-}+reapplyDoesNotDemoteDependants :: IO ()+reapplyDoesNotDemoteDependants = within 10 $ do+    (depRan, depBump) <- counter+    let dep = node "cheap-dir" $ \x -> reapplyingRestForOne x{up = depBump}+    (svc, svcRan) <- counted "svc" [dep] id+    supervising (dagOf svc) allUp $ \sup trace -> do+        await trace (\rs -> reachedBy "svc" Up rs >= 1)+        assertEqual "svc came up once" 1 =<< readIORef svcRan+        -- several successful reapplies, forced rather than waited for+        mapM_+            (const (void (Upkeep.instruct sup (refOf "cheap-dir") Recheck)))+            [1 :: Int .. 3]+        await trace (\rs -> evalsOf "cheap-dir" rs >= 4)+        rs <- seen trace+        assertEqual "reapplied several times" [] (demotions rs)+        assertEqual "svc was never sent back" 1 =<< readIORef svcRan+        assertBool "reapplying happened at all" (depRanAtLeast rs)+  where+    depRanAtLeast rs = evalsOf "cheap-dir" rs >= 4++{- | A reapply that throws is a genuine failure, not a shrug: it goes+through the same 'Salmon.Actions.Upkeep.failed' machinery a one-shot @up@+failure does, with the same backoff and the same+'Salmon.Op.Supervision.supGiveUpAfter'. A tight give-up limit makes this+deterministic — one throwing reapply is enough to exhaust it.+-}+failingReapplyGivesUp :: IO ()+failingReapplyGivesUp = within 10 $ do+    calls <- newIORef (0 :: Int)+    let o =+            node "flaky-dir" $ \x ->+                reapplyingGivesUpFast+                    x+                        { up = do+                            n <- atomicModifyIORef' calls (\k -> (k + 1, k))+                            unless (n == 0) (ioError (userError "boom"))+                        }+    supervising (dagOf o) allUp $ \sup trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        assertEqual "the first up succeeded" 1 =<< readIORef calls+        void (Upkeep.instruct sup (refOf "flaky-dir") Recheck)+        await trace (\rs -> not (null [() | GaveUp{} <- rs]))+        rs <- seen trace+        assertBool "the failing reapply was reported as a failure" (not (null [() | Acted (UpDown.Failed{}) <- rs]))++{- | 'Salmon.Op.Supervision.supReapply' is read only by a node with no+action to hold: a managed node's @up@ throws by convention+("Salmon.Builtin.Nodes.Daemon"), so re-running it on a schedule would+crash-loop a service that is otherwise fine. Declaring both must therefore+still park — never announce 'Reapplying', never spawn a second time.+-}+managedIgnoresSupReapply :: IO ()+managedIgnoresSupReapply = within 10 $ do+    gate <- newEmptyMVar+    spawns <- spawnCounter+    let o = holder "svc" spawns (takeMVar gate >> pure ExitSuccess) reapplying+    supervising (dagOf o) allUp $ \sup trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        awaitSpawns spawns 1+        void (Upkeep.instruct sup (refOf "svc") Recheck)+        await trace (\rs -> not (null [() | Parked{} <- rs]))+        rs <- seen trace+        assertEqual "never announced as reapplying" 0 (length [() | Reapplying{} <- rs])+        assertEqual "and never spawned a second time" 1 =<< spawnsSoFar spawns++{- | (R9), end to end: the real 'Salmon.Builtin.Nodes.Filesystem.dir'+builtin, not a stand-in, under a real supervisor and a real filesystem. It+declares 'Salmon.Op.Supervision.supReapply' itself (see its haddock), so+this is the payoff the whole field exists for — a directory removed behind+salmon's back comes back with nobody re-declaring anything, the same+guarantee 'vanishedComesBack' pins for a checked node.+-}+dirSelfHeals :: IO ()+dirSelfHeals = within 10 $ withTempDir $ \tmp -> do+    let path = tmp </> "managed"+        theRef = mkRef "directory" path+        o = FS.dir (FS.Directory path)+    supervising (dagOf o) allUp $ \sup trace -> do+        await trace (\rs -> not (null (reached Up rs)))+        assertBool "created on the way in" =<< doesDirectoryExist path+        removeDirectory path+        assertBool "really gone" . not =<< doesDirectoryExist path+        void (Upkeep.instruct sup theRef Recheck)+        -- 'Done', not 'Eval': the latter is said before @up@ runs, and+        -- checking the directory then is a race this case used to lose.+        await trace (\rs -> donesOf "directory" rs >= 2)+        assertBool "put back without anybody re-declaring it" =<< doesDirectoryExist path+        rs <- seen trace+        assertEqual "nothing ever demoted, since this node has no dependants" [] (demotions rs)++-------------------------------------------------------------------------------+-- (I5): adoption has to see a changed Supervision policy, not just a+-- changed Ref/shorthand/help/notes.++{- | A managed node identified only by its name — same 'Ref', shorthand,+help and notes every time — whose 'Supervision' is the caller's to vary.+Its action never returns on its own, so the only way it stops running is a+real teardown ('releaseKept' cancelling it), which is exactly what+distinguishes /adopted/ (survives) from /released/ (does not) here.+-}+policyHolder :: Strategy -> TVar Int -> Op+policyHolder s spawns =+    holder "svc" spawns (newEmptyMVar >>= takeMVar) $ \x ->+        x{dynamics = [supervised defaultSupervision{supStrategy = s}]}++{- | Before (I5): 'Salmon.Op.Dag.representative' rendered every 'Supervision'+dynamic as its bare type name, so two declarations of "svc" differing only in+'supStrategy' compared equal, and 'startUpkeep' adopted the old machine —+silently keeping its stale policy forever, since nothing else about the node+ever changes to force a fresh one. After (I5), 'Supervision' compares by+value, so this is a differing representative: the old machine is 'Released'+(its action cancelled) and a fresh one is started, which is observable here+as a second spawn of the action.+-}+changedPolicyIsNotAdopted :: IO ()+changedPolicyIsNotAdopted = within 10 $ do+    spawns <- spawnCounter+    trace <- newTVarIO []+    let r = ReporterM $ \rep -> atomically (modifyTVar' trace (rep :))+    sup1 <- Upkeep.startUpkeep r Upkeep.noKept allUp (dagOf (policyHolder OneForOne spawns))+    awaitSpawns spawns 1+    kept1 <- Upkeep.stopUpkeep sup1+    sup2 <- Upkeep.startUpkeep r kept1 allUp (dagOf (policyHolder RestForOne spawns))+    awaitSpawns spawns 2+    rs <- seen trace+    assertBool "the old machine was released, not carried over" (not (null [() | Released _ <- rs]))+    assertEqual "nothing was adopted" 0 (length [() | Adopted _ <- rs])+    kept2 <- Upkeep.stopUpkeep sup2+    void (Upkeep.releaseKept r (const False) kept2)++{- | The control case: re-declaring "svc" with the /same/ policy is still the+overwhelmingly common shape (a command that changes nothing about this node)+and must still adopt, exactly as it did before (I5) — the fix only had to+stop treating a genuine change as none, not start treating "unchanged" as+"changed".+-}+unchangedPolicyIsAdopted :: IO ()+unchangedPolicyIsAdopted = within 10 $ do+    spawns <- spawnCounter+    trace <- newTVarIO []+    let r = ReporterM $ \rep -> atomically (modifyTVar' trace (rep :))+    sup1 <- Upkeep.startUpkeep r Upkeep.noKept allUp (dagOf (policyHolder OneForOne spawns))+    awaitSpawns spawns 1+    kept1 <- Upkeep.stopUpkeep sup1+    sup2 <- Upkeep.startUpkeep r kept1 allUp (dagOf (policyHolder OneForOne spawns))+    -- nothing to await for a non-event: give the (adopted, still-running)+    -- action a moment it could have used to spawn again, then check it did not.+    threadDelay 200000+    rs <- seen trace+    assertEqual "still just the one spawn: the machine was adopted" 1 =<< spawnsSoFar spawns+    assertBool "the machine was reported adopted" (not (null [() | Adopted _ <- rs]))+    assertEqual "nothing was released" 0 (length [() | Released _ <- rs])+    kept2 <- Upkeep.stopUpkeep sup2+    void (Upkeep.releaseKept r (const False) kept2)
+ test/Test/WindowSpec.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Layer 0 coverage for "Salmon.Op.Window": membership (midnight, weekly,+-- offsets), the next opening, parsing, and the gate holding a disruptive+-- node until an injected clock passes into the window.+module Test.WindowSpec (tests) where++import Data.Functor.Identity (runIdentity)+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Text (Text)+import Data.Time (UTCTime)+import Data.Time.Format (defaultTimeLocale, parseTimeOrError)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import Salmon.Actions.UpDown (upTreeWith)+import Salmon.Builtin.Extension (Extension (..), nodeps, op)+import Salmon.Op.Ref (mkRef)+import Salmon.Op.Window++import Test.Harness (capture)++-- 2026-09-26 is a Saturday.+at :: String -> UTCTime+at = parseTimeOrError True defaultTimeLocale "%Y-%m-%d %H:%M"++win :: Text -> Window+win t = either (error . show) id (parseWindow t)++tests :: TestTree+tests =+    testGroup+        "Salmon.Op.Window"+        [ testCase "daily window: start inclusive, end exclusive" $ do+            let w = win "02:00-04:00"+            assertBool "in" (inWindow w (at "2026-09-26 02:00"))+            assertBool "in" (inWindow w (at "2026-09-26 03:59"))+            assertBool "out at end" (not (inWindow w (at "2026-09-26 04:00")))+            assertBool "out before" (not (inWindow w (at "2026-09-26 01:59")))+        , testCase "a daily window crosses midnight" $ do+            let w = win "23:00-01:00"+            assertBool "late" (inWindow w (at "2026-09-26 23:30"))+            assertBool "early" (inWindow w (at "2026-09-27 00:30"))+            assertBool "out" (not (inWindow w (at "2026-09-27 01:00")))+            assertBool "out midday" (not (inWindow w (at "2026-09-27 12:00")))+        , testCase "a weekly window applies to its day only" $ do+            let w = win "Sat:02:00-04:00"+            assertBool "Sat" (inWindow w (at "2026-09-26 03:00"))+            assertBool "Sun" (not (inWindow w (at "2026-09-27 03:00")))+        , testCase "a weekly window crossing midnight ends on the next day" $ do+            let w = win "Sat:23:00-01:00"+            assertBool "Sat night" (inWindow w (at "2026-09-26 23:30"))+            assertBool "Sun early" (inWindow w (at "2026-09-27 00:30"))+            assertBool "Sat early is not" (not (inWindow w (at "2026-09-26 00:30")))+            assertBool "Mon early is not" (not (inWindow w (at "2026-09-28 00:30")))+        , testCase "a Sunday window crossing midnight ends on Monday" $ do+            let w = win "Sun:23:00-01:00"+            assertBool "Mon early" (inWindow w (at "2026-09-28 00:30"))+        , testCase "the offset moves the window (and its weekday) against UTC" $ do+            let w = win "Sun:01:00-03:00@+02:00" -- Sat 23:00-01:00 UTC+            assertBool "in" (inWindow w (at "2026-09-26 23:30"))+            assertBool "out" (not (inWindow w (at "2026-09-27 01:00")))+            let n = win "Sat:22:00-23:00@-05:00" -- Sun 03:00-04:00 UTC+            assertBool "neg" (inWindow n (at "2026-09-27 03:30"))+        , testCase "several windows: any one suffices" $+            assertBool "second" (inAnyWindow [win "02:00-03:00", win "12:00-13:00"] (at "2026-09-26 12:30"))+        , testCase "nextOpening" $ do+            let ws = [win "Sun:02:00-04:00"]+            assertEqual "from Sat" (Just (at "2026-09-27 02:00")) (nextOpening ws (at "2026-09-26 10:00"))+            assertEqual "open now" Nothing (nextOpening ws (at "2026-09-27 03:00"))+            assertEqual "just after" (Just (at "2026-10-04 02:00")) (nextOpening ws (at "2026-09-27 04:00"))+            assertEqual "with offset" (Just (at "2026-09-27 00:00")) (nextOpening [win "Sun:02:00-04:00@+02:00"] (at "2026-09-26 10:00"))+            assertEqual "none" Nothing (nextOpening [] (at "2026-09-26 10:00"))+        , testCase "parsing refuses what it cannot mean" $ do+            mapM_+                (\t -> assertBool (show t) (either (const True) (const False) (parseWindow t)))+                ["", "02:00", "02:00-02:00", "Xyz:02:00-03:00", "25:00-03:00", "02:00-03:60", "02:00-03:00@Mars", "2:0-3:0"]+            assertEqual "roundtrip" "Sun:02:00-04:00@+02:00" (renderWindow (win "Sun:02:00-04:00@+02:00"))+        , testCase "a held node is not applied, then is once the clock enters the window" gateHolds+        ]++gateHolds :: IO ()+gateHolds = do+    applied <- newIORef (0 :: Int)+    plainApplied <- newIORef (0 :: Int)+    clock <- newIORef (at "2026-09-26 10:00")+    heldLog <- newIORef ([] :: [Maybe UTCTime])+    let restart = op "restart" nodeps $ \x ->+            disruptive x{ref = mkRef "restart" ("r" :: Text), up = modifyIORef' applied (+ 1)}+        plain = op "plain" nodeps $ \x ->+            x{ref = mkRef "plain" ("p" :: Text), up = modifyIORef' plainApplied (+ 1)}+        gate = windowGateAt (readIORef clock) [win "02:00-04:00"] (\_ next -> modifyIORef' heldLog (next :))+        pass o = do+            (r, _) <- capture+            ok <- upTreeWith gate r (pure . runIdentity) o+            assertBool "pass succeeds" ok+    pass restart+    pass plain+    assertEqual "held outside the window" 0 =<< readIORef applied+    assertEqual "a node with no opinion is untouched" 1 =<< readIORef plainApplied+    assertEqual "held, told when it opens" [Just (at "2026-09-27 02:00")] =<< readIORef heldLog+    writeIORef clock (at "2026-09-27 02:30")+    pass restart+    assertEqual "applied inside the window" 1 =<< readIORef applied
+ test/Test/WireGuardSpec.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 0 coverage for "Salmon.Builtin.Nodes.WireGuard"'s checks and+commands: what @wg show IF dump@ and @ip -o ...@ output has to say about a+declared peer or interface, and the argv of the new @wg@ commands. The dump+lines are tab separated, as @wg@ prints them (interface line: 4 fields;+peer line: 8).+-}+module Test.WireGuardSpec (tests) where++import qualified Data.Text as Text+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Nodes.Binary (Command (..))+import Salmon.Builtin.Nodes.WireGuard+import System.Process.ListLike (CreateProcess (..), CmdSpec (..))++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Nodes.WireGuard"+        [ testGroup+            "interpretWgDump"+            [ testCase "a peer as declared is satisfied" $+                assertEqual "" Success (interpretWgDump spec dump)+            , testCase "a peer that is not on the interface is missing" $+                assertEqual "" (Failure "peer not on the interface") (interpretWgDump spec{specKey = "zzz="} dump)+            , testCase "changed allowed-ips are reported" $+                assertEqual "" (Failure "allowed-ips differ") (interpretWgDump spec{specAllowedIps = "10.0.0.2/32,10.9.0.0/16"} dump)+            , testCase "allowed-ips compare as a set, a bare address is its /32" $+                assertEqual "" Success (interpretWgDump spec{specAllowedIps = "10.1.0.0/24, 10.0.0.2"} dump)+            , testCase "a different endpoint address is reported" $+                assertEqual "" (Failure "endpoint differs") (interpretWgDump spec{specEndpoint = Just "5.6.7.8:51820"} dump)+            , testCase "an endpoint given as a host name is not compared" $+                assertEqual "" Success (interpretWgDump spec{specEndpoint = Just "vpn.example:51820"} dump)+            , testCase "no declared endpoint or keepalive means not compared" $+                assertEqual "" Success (interpretWgDump spec{specEndpoint = Nothing, specKeepalive = Nothing} dump)+            , testCase "a different keepalive is reported" $+                assertEqual "" (Failure "persistent-keepalive differs") (interpretWgDump spec{specKeepalive = Just 60} dump)+            , testCase "several differences are all named" $+                assertEqual+                    ""+                    (Failure "allowed-ips differ; persistent-keepalive differs")+                    (interpretWgDump spec{specAllowedIps = "1.1.1.1/32", specKeepalive = Just 5} dump)+            , testCase "the reason never quotes the dump" $+                case interpretWgDump spec{specKey = "zzz="} dump of+                    Failure msg -> assertBool "private key leaked" (not ("PRIVATEKEY" `Text.isInfixOf` msg))+                    other -> assertBool ("expected Failure, got " <> show other) False+            ]+        , testGroup+            "interpretIface"+            [ testCase "an up link with its address is satisfied" $+                assertEqual "" Success (interpretIface "wg0" net upLink addrs)+            , testCase "a link that is down is reported" $+                assertEqual "" (Failure "link not up: wg0") (interpretIface "wg0" net downLink addrs)+            , testCase "a missing address is reported" $+                assertEqual "" (Failure "address missing on wg0: 10.0.0.1/24") (interpretIface "wg0" net upLink "")+            , testCase "another address on the link does not count" $+                assertEqual+                    ""+                    (Failure "address missing on wg0: 10.0.0.1/24")+                    (interpretIface "wg0" net upLink "5: wg0    inet 10.0.0.9/24 scope global wg0\\       valid_lft forever\n")+            ]+        , testGroup+            "commands"+            [ testCase "removing a peer removes only that peer" $+                assertEqual "" (RawCommand "wg" ["set", "wg0", "peer", "abc=", "remove"]) (cmdspec (prepare wgcommand (RemovePeer "wg0" "abc=")))+            , testCase "the dump is read from the named interface" $+                assertEqual "" (RawCommand "wg" ["show", "wg0", "dump"]) (cmdspec (prepare wgcommand (ShowDump "wg0")))+            , testCase "the address is set, not added, so a second run is a no-op" $+                assertEqual+                    ""+                    (RawCommand "ip" ["address", "replace", "dev", "wg0", "10.0.0.1/24"])+                    (cmdspec (prepare ipcommand (SetWgAddr "wg0" net)))+            ]+        ]+  where+    net = Ipv4Cidr "10.0.0.1" 24+    spec = PeerSpec "peer1=" (Just "1.2.3.4:51820") "10.0.0.2/32, 10.1.0.0/24" (Just 25)+    dump =+        "PRIVATEKEY=\tpubself=\t51820\toff\n\+        \peer1=\t(none)\t1.2.3.4:51820\t10.0.0.2/32,10.1.0.0/24\t1700000000\t100\t200\t25\n\+        \peer2=\t(none)\t(none)\t(none)\t0\t0\t0\toff\n"+    upLink = "5: wg0: <POINTOPOINT,NOARP,UP,LOWER_UP> mtu 1420 qdisc noqueue state UNKNOWN mode DEFAULT group default qlen 1000\\    link/none \n"+    downLink = "5: wg0: <POINTOPOINT,NOARP> mtu 1420 qdisc noop state DOWN mode DEFAULT group default qlen 1000\\    link/none \n"+    addrs = "5: wg0    inet 10.0.0.1/24 scope global wg0\\       valid_lft forever preferred_lft forever\n"