packages feed

salmon-ops (empty) → 0.1.0.0

raw patch · 103 files changed

+36408/−0 lines, 103 filesdep +aesondep +asyncdep +base

Dependencies added: aeson, async, base, base64-bytestring, bytestring, containers, contravariant, cryptohash-sha256, crypton, crypton-connection, crypton-x509-store, directory, file-embed, filepath, free, hashable, http-client, http-client-tls, http-types, jose, mtl, network, optparse-applicative, optparse-generic, process, process-extras, salmon-core, salmon-ops, stm, text, time, tls, unix, wai, warp, warp-tls

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for salmon-ops++## 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.
+ fixtures/DotFixture.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedRecordDot #-}++{- | A fixture graph exercising every edge-color branch of+'Salmon.Actions.Dot' (plain\/OV, red\/CL, orange\/CR+Connect, gray\/CR+Overlay),+an Actionless node (dot-render skip-through), and a dependency shared by two+parents (to exercise 'Salmon.Actions.UpDown''s dedup-by-Ref path).++This repo has no automated test suite (see CLAUDE.md) — this binary isn't+one either. It's a fixture to run and eyeball\/diff by hand, e.g. before and+after touching graph-traversal or dot-rendering code:++> salmon-ops-dot-fixture dot > before.dot   # on a known-good commit+> salmon-ops-dot-fixture dot > after.dot    # after your change+> diff before.dot after.dot                 # expect no diff++> salmon-ops-dot-fixture up                 # eyeball the Eval\/Skip\/Done report+-}+module Main (main) where++import Control.Monad (void)+import Control.Monad.Identity (runIdentity)+import qualified Data.Text as Text+import System.Environment (getArgs)+import System.Exit (die)++import Salmon.Actions.Dot (printDigraph)+import Salmon.Actions.UpDown (upTree)+import Salmon.Builtin.Extension+import Salmon.Op.Graph+import Salmon.Op.OpGraph (OpGraph (..), inject, overlaid)+import Salmon.Op.Ref (mkRef)+import Salmon.Reporter (reportPrint)++leaf :: Text.Text -> Op+leaf name =+    op name nodeps $ \x ->+        x{ref = mkRef "leaf" name, up = putStrLn ("up " <> Text.unpack name)}++-- | Depended on by both 'childV' and 'childO', to exercise upTree's+-- dedup-by-Ref path (one Eval, however many paths reach it).+commonLeaf :: Op+commonLeaf = leaf "common-leaf"++leafCL :: Op+leafCL = leaf "leaf-cl"++-- | Own predecessors are 'Vertices' (shape V): the edge into this node from+-- 'root' is tagged (CR,V) -> plain.+childV :: Op+childV =+    op "child-v" (deps [commonLeaf]) $ \x ->+        x{ref = mkRef "child" ("child-v" :: Text.Text), up = putStrLn "up child-v"}++-- | Own predecessors are 'Overlay' (shape O): the edge into this node from+-- 'root' is tagged (CR,O) -> gray. Also overlays an 'Actionless' node+-- ('realNoop'), to exercise dot's skip-through-Actionless path.+childO :: Op+childO =+    ( op "child-o" nodeps $ \x ->+        x{ref = mkRef "child" ("child-o" :: Text.Text), up = putStrLn "up child-o"}+    )+        `overlaid` commonLeaf+        `overlaid` realNoop++-- | Own predecessors are 'Connect' (shape C, via 'inject'): the edge into+-- this node from 'root' is tagged (CR,C) -> orange. Its own inject produces+-- a further CL\/red edge one level down.+childC :: Op+childC =+    ( op "child-c" nodeps $ \x ->+        x{ref = mkRef "child" ("child-c" :: Text.Text), up = putStrLn "up child-c"}+    )+        `inject` leaf "leaf-c-inner"++-- | 'root''s predecessors are hand-built as @Connect (Vertices ..) (Vertices+-- ..)@ so that 'leafCL' is reached via the Connect's left arm (CL -> red),+-- while 'childV'\/'childO'\/'childC' are reached via the right arm (CR),+-- each then getting a different edge color from its own predecessor shape.+root :: Op+root =+    (op "root" nodeps $ \x -> x{ref = mkRef "root" (), up = putStrLn "up root"})+        { predecessors = pure (Connect (Vertices [leafCL]) (Vertices [childV, childO, childC]))+        }++main :: IO ()+main = do+    args <- getArgs+    case args of+        ["dot"] -> printDigraph (pure . runIdentity) root+        ["up"] -> void $ upTree reportPrint (pure . runIdentity) root+        _ -> die "usage: salmon-ops-dot-fixture (dot|up)"
+ fixtures/PostgresReplicationFixture.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedRecordDot #-}++{- | A fixture demonstrating "Salmon.Builtin.Nodes.Postgres"'s WAL streaming+replication primitives end to end: one node running the (Debian-default,+\"main\") cluster as a primary, another cloning it and running as a+streaming standby.++This repo has no automated test suite (see CLAUDE.md) — like+'salmon-ops-dot-fixture', this binary is meant to be run and eyeballed by+hand, against two real machines (or, easiest, two podman containers on+podman's default network, which resolves containers by name via embedded+DNS). For example:++> podman run -dt --name pg-primary --hostname pg-primary debian:bookworm sleep infinity+> podman run -dt --name pg-standby --hostname pg-standby debian:bookworm sleep infinity+> podman exec pg-primary bash -c "apt-get update -qq && DEBIAN_FRONTEND=noninteractive apt-get install -y -qq sudo"+> podman exec pg-standby bash -c "apt-get update -qq && DEBIAN_FRONTEND=noninteractive apt-get install -y -qq sudo"+>+> cabal build salmon-postgres-replication-fixture+> BIN=dist-newstyle/build/*/*/salmon-ops-0.1.0.0/x/salmon-postgres-replication-fixture/build/salmon-postgres-replication-fixture/salmon-postgres-replication-fixture+> podman cp "$BIN" pg-primary:/usr/local/bin/fixture+> podman cp "$BIN" pg-standby:/usr/local/bin/fixture+>+> # allow the standby's container subnet to authenticate as the replication role+> podman exec pg-primary fixture primary 0.0.0.0/0+> podman exec pg-standby fixture standby pg-primary+>+> # eyeball it: the standby should now be streaming from the primary+> podman exec pg-standby sudo -u postgres psql -c "SELECT status FROM pg_stat_wal_receiver;"+> podman exec pg-primary sudo -u postgres psql -c "SELECT client_addr, state FROM pg_stat_replication;"++The @0.0.0.0\/0@ above is a fixture-only shortcut (no need to look up the+standby's actual container IP by hand) — a real deployment should pass the+standby's actual address\/CIDR instead, per "Postgres.primaryReplicationSetup"'s+own doc.++> salmon-postgres-replication-fixture dot primary 10.0.0.2/32   # print the primary-side graph+> salmon-postgres-replication-fixture dot standby pg-primary    # print the standby-side graph+-}+module Main (main) where++import Control.Monad (unless)+import Control.Monad.Identity (runIdentity)+import qualified Data.Text as Text+import System.Environment (getArgs)+import System.Exit (die, exitFailure)++import Salmon.Actions.Dot (printDigraph)+import Salmon.Actions.UpDown (upTree)+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (justInstall)+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 Salmon.Op.OpGraph (inject)+import Salmon.Op.Track+import Salmon.Reporter (reportPrint)++-------------------------------------------------------------------------------+-- fixture-only constants: a real deployment would generate/store these per-pair, not hardcode them++replRole :: Postgres.RoleName+replRole = "replicator"++replPassword :: Postgres.Password+replPassword = Postgres.Password "fixture-replication-password"++replSlot :: Postgres.ReplicationSlotName+replSlot = "standby_slot"++{- | Where the standby keeps the replication password; see 'standbyOp'.++@.pgpass@ format, which is what @primary_conninfo@'s @passfile=@ reads and+what 'Postgres.standby_repl_passfile' therefore expects: one file for the+clone and for the streaming that follows it.+-}+replPassfile :: FilePath+replPassfile = "/etc/postgresql/salmon-replication.pgpass"++primaryPort :: Postgres.Port+primaryPort = 5432++-------------------------------------------------------------------------------++-- | Ensures the (Debian-default) "main" cluster is installed and started, dependend on by both roles.+serverUp :: Op+serverUp = Postgres.pgLocalCluster reportPrint Debian.postgres Debian.pg_ctlcluster Postgres.localServer++serverTrack :: Track' Postgres.Server+serverTrack = Track $ const serverUp++-- | Primary role: creates the replication user, then turns "main" into a replication-capable primary.+primaryOp :: Text.Text -> Op+primaryOp standbyCidr =+    Postgres.primaryReplicationSetup+        reportPrint+        Debian.psql+        Debian.pg_ctlcluster+        primaryPort+        Postgres.mainCluster+        Postgres.defaultReplicationTuning+        replRole+        standbyCidr+        replSlot+        `inject` replUser+        `inject` serverUp+  where+    replUser = Postgres.replicationUser reportPrint serverTrack Debian.psql primaryPort (Postgres.User replRole) replPassword++{- | Standby role: installs postgres (for pg_basebackup), writes the+replication password where the clone can read it, and clones "main" off the+given primary host.++The password file is the fixture standing in for whatever a real deployment+uses to get a secret onto a machine -- that is deliberately not this node's+business (see the @salmon-ops-recipes@ convention). What matters is that+'Postgres.StandbySetup' takes a /path/: the clone is a shell script, and a+script ends up in @ps@ and in every report salmon prints.+-}+standbyOp :: Text.Text -> Op+standbyOp primaryHost =+    Postgres.standbyReplicationSetup reportPrint Debian.pg_ctlcluster standbySetup+        `inject` passfileOp+        `inject` justInstall Debian.postgres+  where+    passfileOp :: Op+    passfileOp =+        FS.ownedFile (FS.FileOwnership replPassfile (Just "postgres") (Just "postgres") 0o600)+            `inject` FS.filecontents (FS.FileContents replPassfile ("*:*:*:" <> replRole <> ":" <> replPassword.revealPassword <> "\n"))++    standbySetup =+        Postgres.StandbySetup+            { Postgres.standby_cluster = Postgres.mainCluster+            , Postgres.standby_primary_host = primaryHost+            , Postgres.standby_primary_port = primaryPort+            , Postgres.standby_repl_user = Postgres.User replRole+            , Postgres.standby_repl_passfile = replPassfile+            , Postgres.standby_slot = Just replSlot+            }++-------------------------------------------------------------------------------++-- | Runs the graph and, unlike blindly ignoring 'upTree''s result, actually+-- exits non-zero if a command failed (and everything downstream of it got+-- 'Blocked') instead of reporting false success.+runUpOrDie :: Op -> IO ()+runUpOrDie o = do+    ok <- upTree reportPrint (pure . runIdentity) o+    unless ok exitFailure++main :: IO ()+main = do+    args <- getArgs+    case args of+        ["primary", standbyCidr] -> runUpOrDie (primaryOp (Text.pack standbyCidr))+        ["standby", primaryHost] -> runUpOrDie (standbyOp (Text.pack primaryHost))+        ["dot", "primary", standbyCidr] -> printDigraph (pure . runIdentity) (primaryOp (Text.pack standbyCidr))+        ["dot", "standby", primaryHost] -> printDigraph (pure . runIdentity) (standbyOp (Text.pack primaryHost))+        _ -> die "usage: salmon-postgres-replication-fixture ((dot (primary|standby))|primary <standby-cidr>|standby <primary-host>)"
+ fixtures/QemuHostSetupFixture.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedRecordDot #-}++{- | One-time, privileged host setup for the Layer 3 qemu test tier (see+@specs/qemu-test-vms.md@\/@specs/qemu-test-vms-progress.md@): grants+"Salmon.Builtin.Nodes.Capabilities" to @capsh@\/@qemu-system-x86_64@ and+hands ownership of each rootfs's @etc\/ssh@ subtree to an unprivileged+user, so that routine test runs (@cabal test salmon-ops-recipes@,+"Test.Harness".'Test.Harness.hasVmPrivileges') no longer need to run as+root at all — only this one-off setup does. Grants @capsh@, not @ip@+itself: see "Salmon.Builtin.Nodes.LinuxBridge".'Salmon.Builtin.Nodes.LinuxBridge.ipLinkCommand's+haddock for why a direct grant on @ip@ doesn't work (iproute2+unconditionally drops its own capability set at startup and only trusts+the ambient set, which only @capsh@-mediated exec can populate).++Meant to be run once per machine, as root (or under @sudo@), and again+after any @apt upgrade@ of @libcap2-bin@\/@qemu-system-x86@ (package+upgrades replace the binary, wiping its capabilities — see+"Salmon.Builtin.Nodes.Capabilities".'Salmon.Builtin.Nodes.Capabilities.grantCapabilities'+haddock) or after debootstrapping a new rootfs:++> cabal build salmon-qemu-host-setup-fixture+> sudo dist-newstyle/build/*/*/salmon-ops-0.1.0.0/x/salmon-qemu-host-setup-fixture/build/salmon-qemu-host-setup-fixture/salmon-qemu-host-setup-fixture \+>     lucas /var/lib/salmon-test-vms/smoke/root /var/lib/salmon-test-vms/pg-primary/root /var/lib/salmon-test-vms/pg-standby/root++Idempotent (same conventions as every other node in this codebase): safe to+rerun, and every step it didn't need to redo is reported 'Skip'/no-op.+-}+module Main (main) where++import Control.Monad (unless)+import Control.Monad.Identity (runIdentity)+import Data.List (foldl')+import qualified Data.Text as Text+import System.Directory (canonicalizePath, findExecutable)+import System.Environment (getArgs)+import System.Exit (die, exitFailure)+import System.FilePath ((</>))++import Salmon.Actions.UpDown (upTree)+import Salmon.Builtin.Extension+import qualified Salmon.Builtin.Nodes.Capabilities as Capabilities+import qualified Salmon.Builtin.Nodes.Debian.OS as Debian+import qualified Salmon.Builtin.Nodes.User as User+import Salmon.Op.OpGraph (overlaid)+import Salmon.Reporter (reportPrint)++-- | The capabilities each binary needs — see 'Salmon.Builtin.Nodes.Capabilities.grantCapabilities'.+capshCapabilities, qemuCapabilities :: [Capabilities.Capability]+capshCapabilities = ["cap_net_admin"]+qemuCapabilities = ["cap_dac_override", "cap_chown", "cap_fowner"]++-- | Grants a resolved binary path its needed capabilities, or dies loudly+-- if the binary isn't found — same "fail loudly, don't hang" spirit as+-- "Test.Harness".'Test.Harness.requireExecutable'. Canonicalizes past any+-- symlink first (e.g. Debian's usrmerge makes @\/usr\/sbin\/ip@ a symlink to+-- @\/bin\/ip@) — @setcap@ refuses to operate on a symlink at all+-- ("Invalid file for capability operation"), it needs the real inode.+capabilityOp :: String -> [Capabilities.Capability] -> IO Op+capabilityOp exe caps = do+    mPath <- findExecutable exe+    case mPath of+        Nothing -> die (exe <> " not found on PATH")+        Just linkedPath -> do+            path <- canonicalizePath linkedPath+            pure (Capabilities.grantCapabilities reportPrint Debian.setcap path caps)++-- | Hands ownership of one rootfs's @etc\/ssh@ subtree to the unprivileged+-- test user — see "Test.Harness".'Test.Harness.ensureVmSshAccess', which+-- writes a fresh per-boot SSH CA there directly on the host filesystem.+sshDirOwnershipOp :: User.Owner -> FilePath -> Op+sshDirOwnershipOp owner rootfs =+    User.chown reportPrint Debian.chown True owner (rootfs </> "etc/ssh")++main :: IO ()+main = do+    args <- getArgs+    case args of+        (user : rootfsPaths) -> do+            capshOp <- capabilityOp "capsh" capshCapabilities+            qemuOp <- capabilityOp "qemu-system-x86_64" qemuCapabilities+            let owner = User.Owner (User.User (Text.pack user)) (User.Group (Text.pack user))+                sshOps = map (sshDirOwnershipOp owner) rootfsPaths+                allOps = foldl' overlaid capshOp (qemuOp : sshOps)+            ok <- upTree reportPrint (pure . runIdentity) allOps+            unless ok exitFailure+        _ -> die "usage: salmon-qemu-host-setup-fixture <unprivileged-user> <rootfs-path>..."
+ fixtures/ServeFixture.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++{- | A tiny end-to-end binary for playing with @run serve@+('Salmon.Actions.Serve') by hand, against nothing more dangerous than files+in a directory you name.++A seed is "a named bundle of files under a base directory". The 'Track''+turns it into real 'Salmon.Builtin.Nodes.Filesystem' nodes (a directory plus+one file per name, each with deterministic content), so declaring a seed up+actually creates those files and retiring it actually deletes them — you can+watch the convergence happen in another terminal with @ls@/@watch@.++Because it goes through 'CLI.execCommandOrSeed' it is a full salmon binary,+so the same seed works one-shot too:++> salmon-ops-serve-fixture config --dir /tmp/play --name web --file index.html | salmon-ops-serve-fixture run up++But the point is the loop. Try (typing, or piping in, one line per command):++> salmon-ops-serve-fixture run serve+> up --dir /tmp/play --name web --file index.html --file style.css+> up --dir /tmp/play --name api --file openapi.json+> status+> down --dir /tmp/play --name web --file index.html --file style.css+> only --dir /tmp/play --name api --file openapi.json --file CHANGELOG+> history+> quit++Notes to notice while playing:++  * the base directory itself is one node shared by every seed (they unify by+    'Salmon.Op.Ref.Ref'), so it survives until the last seed under it is gone;+  * re-declaring an unchanged seed converges to a no-op (nothing is re-run);+  * a seed is identified by the /files it asks for/, so @only@ with a+    different --file set supersedes rather than adds;+  * @status@ shows each node's wanted direction and whether it has converged.++= The @--daemon@ half++Everything above is one-shot nodes: @up@ runs, and what it leaves behind+stays put on its own. @--daemon@ adds the two things that are not that — a+node that /owns a running process/+('Salmon.Builtin.Extension.managed'), and a node whose going away+/bounces what stands on it/ ('Salmon.Op.Supervision.RestForOne') — which+otherwise exist only inside the test suite.++It adds two nodes to the bundle: a @daemon.conf@ under the bundle directory+(the only node here with a @check@ of its own, and the one declaring+@RestForOne@), and a process that reads that file __once at startup__ and+then appends a line to @\<dir\>\/\<name\>.log@ every second. The log is+deliberately outside the bundle directory: nothing declares it, so nothing+removes it, and you can read it across as many up\/down cycles as you like.++Supervision only runs while the loop is __idle__, so none of this shows up+under @serve \< script@ — every line of a piped script is already queued+before the first pass ends. Type at it, or drive it from a fifo.++> salmon-ops-serve-fixture run serve+> up --dir /tmp/play --name web --daemon --greeting hello++then, in another terminal, @tail -f \/tmp\/play\/web.log@ to watch it.++__Bouncing on drift.__ Edit @\/tmp\/play\/web\/daemon.conf@ yourself. The+config node's own machine notices (its @check@ compares the content), rewrites+it, and because it declared @RestForOne@ the process reading it is sent back:++> Signalling "web" 15+> Reaped "web"+> serve: daemon sent back to wait: ... stopped being up+> Spawned "web" (Just ...)++Note the teardown happens /before/ the node is sent back — the process is+stopped through its own bracket first, and only then does the node go looking+for its dependency again.++__Bouncing on a re-declaration.__++> only --dir /tmp/play --name web --daemon --greeting goodbye++The log's next line has both a new pid and the new greeting. Worth watching+the reports for /where/ that happens, because it is not where one would+guess: the convergence pass says @converging (0 down, 0 up)@ and does+nothing, since the node is already 'Salmon.Actions.Serve.Converged' under a+'Salmon.Op.Ref.Ref' that did not change. What applies the new content is the+config node's own machine, on its next look. A node with no @check@ — every+other node in this fixture — would simply keep the old content.++__What a node's own check is and is not allowed to say.__ Add+@--stale-check@ and the daemon node gains a plausible-looking health check:+"my log file exists". It is wrong in the way health checks are wrong — it+answers "this ran at some point", not "it is running now" — and doing either+of the above shows it being __deliberately ignored__: the node is torn down+and put straight back, because the machine that cancelled the action knows+better than any check can.++That is a fix rather than the original behaviour. Until (I1) in+@specs\/per-node-state-machines-remaining.md@ was settled, this flag lost the+process outright: the check was consulted, it said the effect was in place,+and the node settled into 'Salmon.Actions.Upkeep.Up' holding nothing at all.+The flag stays because the rule it demonstrates is worth being able to see.+-}+module Main (main) where++import Control.Exception (throwIO)+import Data.Aeson (FromJSON, ToJSON)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text.IO+import GHC.Generics (Generic)+import Options.Applicative (execParser, fullDesc, header, info, long, many, metavar, progDesc, strOption, switch, value)+import qualified Options.Applicative as Opt+import Options.Generic (ParseRecord (..))+import System.Directory (doesFileExist, removeFile)+import System.FilePath (takeDirectory, (<.>), (</>))+import System.Process (proc)++import Salmon.Actions.UpDown (CheckResult (..))+import qualified Salmon.Builtin.CommandLine as CLI+import Salmon.Builtin.Extension (Op, Track', check, deps, down, dynamics, help, managed, notes, op, ref, up)+import qualified Salmon.Builtin.Nodes.Daemon as Daemon+import qualified Salmon.Builtin.Nodes.Filesystem as FS+import Salmon.Op.Configure (Configure (..))+import Salmon.Op.Ref (mkRef)+import Salmon.Op.Supervision (Strategy (..), Supervision (..), defaultSupervision, supervised)+import Salmon.Op.Track (Track (..))+import Salmon.Reporter (reportIf, reportPrint)++-------------------------------------------------------------------------------++-- | What a human types after @config@ / @up@ / @down@ / @only@.+data Seed = Seed+    { seedDir :: FilePath+    , seedName :: Text+    , seedFiles :: [String]+    , seedDaemon :: Bool+    , seedGreeting :: Text+    , seedStaleCheck :: Bool+    }+    deriving (Generic, Show)++instance ParseRecord Seed where+    parseRecord =+        Seed+            <$> strOption+                (long "dir" <> metavar "DIR" <> value "/tmp/salmon-serve-fixture" <> Opt.help "base directory to converge files under")+            <*> fmap Text.pack (strOption (long "name" <> metavar "NAME" <> Opt.help "name of this bundle (its own subdirectory)"))+            <*> many (strOption (long "file" <> metavar "FILE" <> Opt.help "a file to keep in the bundle (repeatable)"))+            <*> switch (long "daemon" <> Opt.help "also run a process that reads this bundle's config and logs it once a second")+            <*> fmap+                Text.pack+                ( strOption+                    (long "greeting" <> metavar "TEXT" <> value "hello" <> Opt.help "what the daemon's config file says (--daemon only)")+                )+            <*> switch+                ( long "stale-check"+                    <> Opt.help "give the daemon a plausible-but-stale check (\"my log exists\"), which a bounce then ignores. See (I1)."+                )++-- | The hermetic directive: same shape as the seed here, but that's a+-- coincidence of how trivial this fixture is — the point of the type is that+-- it is 'FromJSON'\/'ToJSON', so it is what identifies a seed in the loop.+data Spec = Spec+    { specRoot :: FilePath+    , specFiles :: [FilePath]+    , specDaemon :: Maybe DaemonSpec+    }+    deriving (Eq, Show, Generic)++-- | Everything the @--daemon@ half needs, absent when it was not asked for.+data DaemonSpec = DaemonSpec+    { daemonName :: Text+    , daemonConf :: FilePath+    , daemonLog :: FilePath+    , daemonGreeting :: Text+    , daemonStaleCheck :: Bool+    }+    deriving (Eq, Show, Generic)++instance FromJSON Spec+instance ToJSON Spec+instance FromJSON DaemonSpec+instance ToJSON DaemonSpec++configure :: Configure IO Seed Spec+configure = Configure $ \seed ->+    let root = seed.seedDir </> Text.unpack seed.seedName+     in pure $+            Spec+                root+                [root </> f | f <- seed.seedFiles]+                ( if not seed.seedDaemon+                    then Nothing+                    else+                        Just $+                            DaemonSpec+                                { daemonName = seed.seedName+                                , daemonConf = root </> "daemon.conf"+                                , -- deliberately /outside/ the bundle directory, and+                                  -- so not a node: nothing declares it, nothing+                                  -- removes it, and `dir`'s non-recursive `down`+                                  -- does not trip over it on the way out.+                                  daemonLog = seed.seedDir </> Text.unpack seed.seedName <.> "log"+                                , daemonGreeting = seed.seedGreeting+                                , daemonStaleCheck = seed.seedStaleCheck+                                }+                )++program :: Track' Spec+program = Track $ \spec ->+    op "serve-fixture-bundle" (deps (fmap fileOp spec.specFiles <> foldMap (pure . daemonOp) spec.specDaemon)) $ \actions ->+        actions{ref = mkRef "serve-fixture-bundle" (spec.specRoot, spec.specFiles, fmap daemonConf spec.specDaemon)}+  where+    fileOp :: FilePath -> Op+    fileOp path =+        FS.filecontents (FS.FileContents path (Text.pack ("managed by salmon-ops-serve-fixture: " <> path <> "\n")))++-------------------------------------------------------------------------------+-- the --daemon half: a process salmon owns, and the config it stands on++{- | The daemon's configuration file.++It is written out rather than reusing+'Salmon.Builtin.Nodes.Filesystem.filecontents' for one reason now, where it+used to be two. The remaining one is the __policy__: this node declares+'RestForOne', and @filecontents@ takes no modifier through which a caller+could attach one. The reason that has gone away is the __check__ —+@filecontents@ had none when this fixture was written, so it answered+@Immaterial@ and was parked the moment it was up, which made it unable to+notice its own file changing and therefore unable to demote anything. It has+'Salmon.Builtin.Nodes.Filesystem.checkFileContents' now, and this node's+@check@ is that same function rather than a hand-rolled copy of it.++'RestForOne' is authored here, on the file, rather than on the daemon that+reads it. Only the file's author knows its content is load-bearing.+-}+configOp :: DaemonSpec -> Op+configOp d =+    op "daemon-config" (deps [FS.dir (FS.Directory (takeDirectory d.daemonConf))]) $ \actions ->+        actions+            { help = Text.pack ("keeps " <> d.daemonConf <> " saying " <> Text.unpack d.daemonGreeting)+            , notes =+                [ "checks its own contents, so a supervisor can notice it changing"+                , "declares RestForOne, so whatever reads it is bounced when it does"+                ]+            , -- keyed on the path alone, so re-declaring the bundle with a+              -- different --greeting is the /same node/ with different+              -- content rather than a second node.+              ref = mkRef "daemon-config" d.daemonConf+            , check = FS.checkFileContents (FS.FileContents d.daemonConf body)+            , up = Text.IO.writeFile d.daemonConf body+            , down = removeFile d.daemonConf+            , dynamics = [supervised defaultSupervision{supStrategy = RestForOne}]+            }+  where+    body :: Text+    body = "greeting = " <> d.daemonGreeting <> "\n"++{- | A process salmon owns, which reads the config __once at startup__ and+then logs what it read every second.++Reading once is what makes the demonstration honest: the running process+holds content that can go stale, and nothing but restarting it can make it+notice. Written out rather than going through+'Salmon.Builtin.Nodes.Daemon.daemon' because this node wants two things that+function does not offer — a dependency, and (with @--stale-check@) a @check@+of its own — which is exactly the case @runDaemon@ is exposed for.+-}+daemonOp :: DaemonSpec -> Op+daemonOp d =+    op "daemon" (deps [configOp d]) $ \actions ->+        actions+            { help = Text.pack ("keeps a process logging to " <> d.daemonLog)+            , ref = Daemon.daemonRef spawn+            , managed = Just (Daemon.runDaemon chatter spawn)+            , check =+                if not d.daemonStaleCheck+                    then -- nothing to ask: this machine holds the process,+                    -- and the process exiting is raced in the same+                    -- transaction as the mailbox. So the node parks and the+                    -- delay ladder never runs at all.+                        pure Immaterial+                    else do+                        -- A health check somebody might plausibly write, and+                        -- which is wrong in the way health checks are wrong:+                        -- it answers "something ran once", not "it is running+                        -- now". A bounce ignores it, because the machine that+                        -- cancelled the action knows better; see (I1) in+                        -- specs/per-node-state-machines-remaining.md for what+                        -- it used to do instead.+                        there <- doesFileExist d.daemonLog+                        pure (if there then Success else Failure "no log yet")+            , -- `run up` has nowhere to put an action that never returns.+              up = throwIO (Daemon.NeedsSupervisor d.daemonName)+            , -- under `serve` the process died when its machine was+              -- cancelled; under `run down` it never held one.+              down = pure ()+            }+  where+    spawn :: Daemon.Daemon+    spawn =+        Daemon.defaultDaemon+            d.daemonName+            (proc "/bin/sh" ["-c", script])++    script :: String+    script =+        mconcat+            [ "cfg=$(cat "+            , d.daemonConf+            , "); while true; do echo \"[pid $$] $cfg\" | tee -a "+            , d.daemonLog+            , "; sleep 1; done"+            ]++    -- everything the daemon does /except/ repeat its own output back: the+    -- process writes a line a second (to its log and, through @tee@, to its+    -- stdout, which is what the node's ring and a live tail follow).+    chatter = reportIf notWrote reportPrint+    notWrote Daemon.Wrote{} = False+    notWrote _ = True++-------------------------------------------------------------------------------++main :: IO ()+main = do+    let desc = fullDesc <> progDesc "play with `run serve` against files in a directory" <> header "salmon-ops-serve-fixture"+    cmd <- execParser (info parseRecord desc)+    CLI.execCommandOrSeed reportPrint configure program cmd
+ openapi/serve-api.openapi.json view
@@ -0,0 +1,3869 @@+{+  "openapi": "3.1.0",+  "info": {+    "title": "salmon run serve",+    "version": "1",+    "summary": "The HTTP surface of `run serve --http PATH` and `--http-tcp HOST:PORT`",+    "description": "Served on a unix socket (owner-only, no token) by `--http PATH`, and over TLS on a network by `--http-tcp` (every route needs `Authorization: Bearer <token>` or a session cookie from `/auth`). Both serve this same application on the same loop.\n\nReads (`/dag`, `/status`, `/history`, `/help/seed`) never enter the loop's input. Writes are `POST /command`. Motion between commands is visible only on `/events`.\n\nThe seed words in a command are binary-specific: their grammar is `GET /help/seed`, not something this document can enumerate.\n\nA client that wants to refuse a server it does not understand can read `info.version` here; the responses themselves carry no version yet."+  },+  "servers": [+    {+      "url": "http://localhost",+      "description": "unix socket (`curl --unix-socket PATH http://x/dag`)"+    },+    {+      "url": "https://{host}:{port}",+      "variables": {+        "host": {+          "default": "localhost"+        },+        "port": {+          "default": "8443"+        }+      },+      "description": "`--http-tcp`"+    }+  ],+  "security": [+    {+      "bearerAuth": []+    },+    {+      "sessionCookie": []+    }+  ],+  "paths": {+    "/dag": {+      "get": {+        "operationId": "getDag",+        "summary": "The computed DAG with each node's state",+        "description": "Bypasses the loop's input: a read never stands a machine down and answers while a node's `up` is running. At most one command old.",+        "responses": {+          "200": {+            "description": "the DAG",+            "content": {+              "application/json": {+                "schema": {+                  "$ref": "#/components/schemas/DagResponse"+                }+              }+            }+          },+          "503": {+            "description": "the loop has not started",+            "content": {+              "application/json": {+                "schema": {+                  "$ref": "#/components/schemas/Error"+                }+              }+            }+          }+        }+      }+    },+    "/status": {+      "get": {+        "operationId": "getStatus",+        "summary": "Per-node state, as `status --json`",+        "responses": {+          "200": {+            "description": "the status",+            "content": {+              "application/json": {+                "schema": {+                  "$ref": "#/components/schemas/StatusResponse"+                }+              }+            }+          },+          "503": {+            "description": "the loop has not started",+            "content": {+              "application/json": {+                "schema": {+                  "$ref": "#/components/schemas/Error"+                }+              }+            }+          }+        }+      }+    },+    "/history": {+      "get": {+        "operationId": "getHistory",+        "summary": "The seed and graph history, as `history --json`",+        "responses": {+          "200": {+            "description": "the history",+            "content": {+              "application/json": {+                "schema": {+                  "$ref": "#/components/schemas/HistoryResponse"+                }+              }+            }+          },+          "503": {+            "description": "the loop has not started",+            "content": {+              "application/json": {+                "schema": {+                  "$ref": "#/components/schemas/Error"+                }+              }+            }+          }+        }+      }+    },+    "/help/seed": {+      "get": {+        "operationId": "getHelpSeed",+        "summary": "The seed grammar and the command reference",+        "responses": {+          "200": {+            "description": "the help",+            "content": {+              "application/json": {+                "schema": {+                  "$ref": "#/components/schemas/HelpResponse"+                }+              }+            }+          }+        }+      }+    },+    "/command": {+      "post": {+        "operationId": "postCommand",+        "summary": "One line of the input language",+        "description": "The line joins the loop's inbox with an origin minted per request (`PATH#n` on the unix socket, `ADDR:PORT#n` over TCP). Synchronous by default: answers, when the loop has handled the line, with every report stamped with that origin. `?async` answers at once with the number of the `enqueued` event. A synchronous `up` holds the request for the whole pass, so a UI should use `?async` and read the outcome off `/events`.",+        "parameters": [+          {+            "name": "async",+            "in": "query",+            "required": false,+            "allowEmptyValue": true,+            "schema": {+              "type": "string"+            },+            "description": "Presence selects the asynchronous form."+          }+        ],+        "requestBody": {+          "required": true,+          "content": {+            "text/plain": {+              "schema": {+                "type": "string"+              },+              "description": "the line, one trailing newline tolerated"+            },+            "application/json": {+              "schema": {+                "$ref": "#/components/schemas/CommandBody"+              }+            }+          }+        },+        "responses": {+          "200": {+            "description": "synchronous: the reports the line produced, in order",+            "content": {+              "application/json": {+                "schema": {+                  "type": "array",+                  "items": {+                    "$ref": "#/components/schemas/Report"+                  }+                }+              }+            }+          },+          "202": {+            "description": "asynchronous: queued",+            "content": {+              "application/json": {+                "schema": {+                  "$ref": "#/components/schemas/AsyncAnswer"+                }+              }+            }+          },+          "400": {+            "description": "the body is not one line, not UTF-8, or not a command object",+            "content": {+              "application/json": {+                "schema": {+                  "$ref": "#/components/schemas/Error"+                }+              }+            }+          },+          "503": {+            "description": "the loop is not taking commands",+            "content": {+              "application/json": {+                "schema": {+                  "$ref": "#/components/schemas/Error"+                }+              }+            }+          }+        }+      }+    },+    "/events": {+      "get": {+        "operationId": "getEvents",+        "summary": "Every report, numbered and replayable, as server-sent events",+        "description": "Each event is `id: N` and `data: <EventData JSON>`. `?since=N` replays what the ring still holds above N and continues live; if N+1 has fallen off, the first event is a GapEvent with no `id`. A comment line `: keep-alive` every 15s of silence. The stream ends when the loop does. Description of the four `stream`s and of `server` is on EventData.",+        "parameters": [+          {+            "name": "since",+            "in": "query",+            "required": false,+            "schema": {+              "type": "integer"+            }+          },+          {+            "name": "stream",+            "in": "query",+            "required": false,+            "style": "form",+            "explode": true,+            "schema": {+              "type": "array",+              "items": {+                "type": "string",+                "enum": [+                  "serve",+                  "updown",+                  "upkeep",+                  "output",+                  "follow",+                  "server"+                ]+              }+            },+            "description": "repeatable or comma-separated"+          },+          {+            "name": "origin",+            "in": "query",+            "required": false,+            "style": "form",+            "explode": true,+            "schema": {+              "type": "array",+              "items": {+                "type": "string"+              }+            },+            "description": "repeatable; only events of commands typed under this origin"+          }+        ],+        "responses": {+          "200": {+            "description": "the stream",+            "content": {+              "text/event-stream": {+                "schema": {+                  "type": "string"+                }+              }+            }+          },+          "400": {+            "description": "a malformed `since`, `stream` or `origin`",+            "content": {+              "application/json": {+                "schema": {+                  "$ref": "#/components/schemas/Error"+                }+              }+            }+          }+        }+      }+    },+    "/": {+      "get": {+        "operationId": "getUi",+        "summary": "The web UI",+        "responses": {+          "200": {+            "description": "the page",+            "content": {+              "text/html": {+                "schema": {+                  "type": "string"+                }+              }+            }+          },+          "303": {+            "description": "over TCP without a credential: to /auth"+          }+        }+      }+    },+    "/ui/{file}": {+      "get": {+        "operationId": "getUiFile",+        "summary": "A file of the web UI",+        "parameters": [+          {+            "name": "file",+            "in": "path",+            "required": true,+            "schema": {+              "type": "string"+            }+          }+        ],+        "responses": {+          "200": {+            "description": "the file (`text/html`, `text/javascript` or `text/css`)"+          },+          "404": {+            "description": "not in the embedded set",+            "content": {+              "application/json": {+                "schema": {+                  "$ref": "#/components/schemas/Error"+                }+              }+            }+          }+        }+      }+    },+    "/openapi.json": {+      "get": {+        "operationId": "getOpenApi",+        "summary": "This document",+        "description": "Embedded in the binary, so it is the description of the server answering.",+        "responses": {+          "200": {+            "description": "this document",+            "content": {+              "application/json": {+                "schema": {+                  "type": "object"+                }+              }+            }+          }+        }+      }+    },+    "/auth": {+      "get": {+        "operationId": "getAuth",+        "summary": "The sign-in form (TCP listener); a redirect to / on the unix socket",+        "security": [],+        "responses": {+          "200": {+            "description": "the form",+            "content": {+              "text/html": {+                "schema": {+                  "type": "string"+                }+              }+            }+          },+          "303": {+            "description": "to /"+          }+        }+      },+      "post": {+        "operationId": "postAuth",+        "x-tcp-only": true,+        "summary": "Sign in with the token",+        "description": "TCP listener only. A form post of the token; answers 303 with a `__Host-salmon-session` cookie (HttpOnly; Secure; SameSite=Strict) that is then accepted wherever the bearer token is.",+        "security": [],+        "requestBody": {+          "content": {+            "application/x-www-form-urlencoded": {+              "schema": {+                "type": "object",+                "properties": {+                  "token": {+                    "type": "string"+                  }+                },+                "required": [+                  "token"+                ]+              }+            }+          }+        },+        "responses": {+          "303": {+            "description": "signed in (cookie set), or back to the form"+          }+        }+      }+    },+    "/auth/logout": {+      "post": {+        "operationId": "postLogout",+        "summary": "Revoke the session",+        "description": "Expires the cookie and cuts any `/events` stream opened with it.",+        "responses": {+          "303": {+            "description": "to /auth"+          }+        }+      }+    },+    "/auth/session": {+      "get": {+        "operationId": "getSession",+        "summary": "Whether this request carries a session",+        "responses": {+          "200": {+            "description": "the answer",+            "content": {+              "application/json": {+                "schema": {+                  "$ref": "#/components/schemas/SessionAnswer"+                }+              }+            }+          }+        }+      }+    }+  },+  "components": {+    "securitySchemes": {+      "bearerAuth": {+        "type": "http",+        "scheme": "bearer",+        "description": "TCP listener only; none on the unix socket."+      },+      "sessionCookie": {+        "type": "apiKey",+        "in": "cookie",+        "name": "__Host-salmon-session",+        "description": "From POST /auth; TCP listener only."+      }+    },+    "schemas": {+      "Error": {+        "type": "object",+        "properties": {+          "error": {+            "type": "string"+          }+        },+        "required": [+          "error"+        ],+        "description": "Every error status answers this: 400 (a body or query the route refuses), 401 (TCP only: no or wrong credential), 404, 405 (with an Allow header), 503 (the loop has not started)."+      },+      "Ref": {+        "type": "object",+        "properties": {+          "short": {+            "type": "string"+          },+          "full": {+            "type": "string"+          }+        },+        "required": [+          "short",+          "full"+        ],+        "description": "A node's identity: the short tag a selector can use as `#<short>`, and the full text."+      },+      "Mode": {+        "type": "string",+        "enum": [+          "interactive",+          "following",+          "replay"+        ],+        "description": "What the world is: typed at a keyboard, following a registry, or replaying the last applied document after a failed start."+      },+      "Direction": {+        "type": "string",+        "enum": [+          "up",+          "down"+        ]+      },+      "Convergence": {+        "type": "string",+        "enum": [+          "pending",+          "stale",+          "converged",+          "errored",+          "blocked"+        ]+      },+      "CheckResult": {+        "type": "object",+        "properties": {+          "verdict": {+            "type": "string",+            "enum": [+              "success",+              "skipped",+              "completed",+              "failure",+              "unknown",+              "immaterial"+            ]+          },+          "reason": {+            "type": "string"+          }+        },+        "required": [+          "verdict"+        ],+        "description": "`reason` is present for `failure` only."+      },+      "MachineStatus": {+        "type": "object",+        "properties": {+          "check": {+            "$ref": "#/components/schemas/CheckResult"+          },+          "direction": {+            "$ref": "#/components/schemas/Direction"+          },+          "stability": {+            "type": "string",+            "enum": [+              "stable",+              "transient"+            ]+          },+          "epoch": {+            "type": "integer"+          },+          "output": {+            "type": "array",+            "items": {+              "type": "string"+            }+          }+        },+        "required": [+          "check",+          "direction",+          "stability",+          "epoch",+          "output"+        ],+        "description": "The last snapshot of a node's machine (its last check, its output ring). `null` on a node no machine has looked at."+      },+      "NodeState": {+        "type": "object",+        "properties": {+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "shorthand": {+            "type": "string"+          },+          "help": {+            "type": "string"+          },+          "direction": {+            "$ref": "#/components/schemas/Direction"+          },+          "convergence": {+            "$ref": "#/components/schemas/Convergence"+          },+          "status": {+            "oneOf": [+              {+                "$ref": "#/components/schemas/MachineStatus"+              },+              {+                "type": "null"+              }+            ]+          },+          "paths": {+            "type": "array",+            "items": {+              "type": "string"+            }+          },+          "selected": {+            "type": "boolean"+          },+          "excluded": {+            "type": "boolean"+          }+        },+        "required": [+          "ref",+          "shorthand",+          "help",+          "direction",+          "convergence",+          "status",+          "paths"+        ],+        "description": "A node as `status` lists it. `selected` and `excluded` are present in a `query` report only."+      },+      "Representative": {+        "type": "object",+        "properties": {+          "shorthand": {+            "type": "string"+          },+          "help": {+            "type": "string"+          },+          "notes": {+            "type": "array",+            "items": {+              "type": "string"+            }+          },+          "dynamics": {+            "type": "array",+            "items": {+              "type": "string"+            }+          }+        },+        "required": [+          "shorthand",+          "help",+          "notes",+          "dynamics"+        ],+        "description": "The fields the loop compares to decide two declarations of one ref are the same node."+      },+      "DagNode": {+        "type": "object",+        "properties": {+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "shorthand": {+            "type": "string"+          },+          "help": {+            "type": "string"+          },+          "direction": {+            "$ref": "#/components/schemas/Direction"+          },+          "convergence": {+            "$ref": "#/components/schemas/Convergence"+          },+          "status": {+            "oneOf": [+              {+                "$ref": "#/components/schemas/MachineStatus"+              },+              {+                "type": "null"+              }+            ]+          },+          "paths": {+            "type": "array",+            "items": {+              "type": "string"+            }+          },+          "notes": {+            "type": "array",+            "items": {+              "type": "string"+            }+          },+          "dynamics": {+            "type": "array",+            "items": {+              "type": "string"+            }+          },+          "dependencies": {+            "type": "array",+            "items": {+              "$ref": "#/components/schemas/Ref"+            }+          },+          "dependants": {+            "type": "array",+            "items": {+              "$ref": "#/components/schemas/Ref"+            }+          },+          "conflict": {+            "type": "object",+            "properties": {+              "kept": {+                "$ref": "#/components/schemas/Representative"+              },+              "replaced": {+                "$ref": "#/components/schemas/Representative"+              }+            },+            "required": [+              "kept",+              "replaced"+            ]+          }+        },+        "required": [+          "ref",+          "shorthand",+          "help",+          "direction",+          "convergence",+          "status",+          "paths",+          "notes",+          "dynamics",+          "dependencies",+          "dependants"+        ],+        "description": "One node of the computed DAG. `conflict` is present while two live declarations disagree about the node."+      },+      "NodeDescription": {+        "type": "object",+        "properties": {+          "shorthand": {+            "type": "string"+          },+          "help": {+            "type": "string"+          },+          "notes": {+            "type": "array",+            "items": {+              "type": "string"+            }+          }+        },+        "required": [+          "shorthand",+          "help",+          "notes"+        ]+      },+      "Supervision": {+        "type": "object",+        "properties": {+          "restart": {+            "type": "string",+            "enum": [+              "always",+              "on-failure",+              "never"+            ]+          },+          "strategy": {+            "type": "string",+            "enum": [+              "one-for-one",+              "rest-for-one"+            ]+          },+          "reapply": {+            "type": "boolean"+          },+          "watchdog_us": {+            "oneOf": [+              {+                "type": "integer"+              },+              {+                "type": "null"+              }+            ]+          },+          "stable_after_us": {+            "type": "integer"+          },+          "demote_every_us": {+            "type": "integer"+          },+          "give_up_after": {+            "oneOf": [+              {+                "type": "integer"+              },+              {+                "type": "null"+              }+            ]+          }+        },+        "required": [+          "restart",+          "strategy",+          "reapply",+          "watchdog_us",+          "stable_after_us",+          "demote_every_us",+          "give_up_after"+        ]+      },+      "Instruction": {+        "type": "string",+        "enum": [+          "force",+          "satisfy",+          "recheck",+          "pause",+          "resume"+        ]+      },+      "Origin": {+        "oneOf": [+          {+            "type": "object",+            "properties": {+              "kind": {+                "const": "stdin"+              }+            },+            "required": [+              "kind"+            ]+          },+          {+            "type": "object",+            "properties": {+              "kind": {+                "const": "other"+              },+              "name": {+                "type": "string"+              }+            },+            "required": [+              "kind",+              "name"+            ]+          },+          {+            "type": "object",+            "properties": {+              "kind": {+                "const": "loaded"+              },+              "path": {+                "type": "string"+              }+            },+            "required": [+              "kind",+              "path"+            ]+          },+          {+            "type": "object",+            "properties": {+              "kind": {+                "const": "fetched"+              },+              "registry": {+                "type": "string"+              },+              "label": {+                "type": "string"+              },+              "document": {+                "type": "string"+              },+              "sha256": {+                "type": "string"+              }+            },+            "required": [+              "kind",+              "registry",+              "label",+              "document",+              "sha256"+            ]+          }+        ],+        "description": "Who typed a line or made a declaration."+      },+      "UpDown_skip": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "updown"+          },+          "kind": {+            "const": "skip"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node"+        ]+      },+      "UpDownUntagged_skip": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "skip"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "kind",+          "ref",+          "node"+        ]+      },+      "UpDown_eval": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "updown"+          },+          "kind": {+            "const": "eval"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node"+        ]+      },+      "UpDownUntagged_eval": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "eval"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "kind",+          "ref",+          "node"+        ]+      },+      "UpDown_done": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "updown"+          },+          "kind": {+            "const": "done"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node"+        ]+      },+      "UpDownUntagged_done": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "done"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "kind",+          "ref",+          "node"+        ]+      },+      "UpDown_blocked": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "updown"+          },+          "kind": {+            "const": "blocked"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node"+        ]+      },+      "UpDownUntagged_blocked": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "blocked"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "kind",+          "ref",+          "node"+        ]+      },+      "UpDown_failed": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "updown"+          },+          "kind": {+            "const": "failed"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "error": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node",+          "error"+        ]+      },+      "UpDownUntagged_failed": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "failed"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "error": {+            "type": "string"+          }+        },+        "required": [+          "kind",+          "ref",+          "node",+          "error"+        ]+      },+      "UpDown_conflicting": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "updown"+          },+          "kind": {+            "const": "conflicting"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "kept": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "replaced": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "kept",+          "replaced"+        ]+      },+      "UpDownUntagged_conflicting": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "conflicting"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "kept": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "replaced": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "kind",+          "ref",+          "kept",+          "replaced"+        ]+      },+      "UpDown_instructed": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "updown"+          },+          "kind": {+            "const": "instructed"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "instruction": {+            "$ref": "#/components/schemas/Instruction"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node",+          "instruction"+        ]+      },+      "UpDownUntagged_instructed": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "instructed"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "instruction": {+            "$ref": "#/components/schemas/Instruction"+          }+        },+        "required": [+          "kind",+          "ref",+          "node",+          "instruction"+        ]+      },+      "UpDown_dropped-instructions": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "updown"+          },+          "kind": {+            "const": "dropped-instructions"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "dropped": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node",+          "dropped"+        ]+      },+      "UpDownUntagged_dropped-instructions": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "dropped-instructions"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "dropped": {+            "type": "integer"+          }+        },+        "required": [+          "kind",+          "ref",+          "node",+          "dropped"+        ]+      },+      "Upkeep_acted": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "acted"+          },+          "report": {+            "$ref": "#/components/schemas/UpDownReportUntagged"+          }+        },+        "required": [+          "stream",+          "kind",+          "report"+        ]+      },+      "UpkeepUntagged_acted": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "acted"+          },+          "report": {+            "$ref": "#/components/schemas/UpDownReportUntagged"+          }+        },+        "required": [+          "kind",+          "report"+        ]+      },+      "Upkeep_upkeep": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "upkeep"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "state": {+            "type": "string",+            "enum": [+              "wait-up",+              "upping",+              "up"+            ]+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node",+          "state"+        ]+      },+      "UpkeepUntagged_upkeep": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "upkeep"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "state": {+            "type": "string",+            "enum": [+              "wait-up",+              "upping",+              "up"+            ]+          }+        },+        "required": [+          "kind",+          "ref",+          "node",+          "state"+        ]+      },+      "Upkeep_downkeep": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "downkeep"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "state": {+            "type": "string",+            "enum": [+              "wait-down",+              "downing",+              "down"+            ]+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node",+          "state"+        ]+      },+      "UpkeepUntagged_downkeep": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "downkeep"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "state": {+            "type": "string",+            "enum": [+              "wait-down",+              "downing",+              "down"+            ]+          }+        },+        "required": [+          "kind",+          "ref",+          "node",+          "state"+        ]+      },+      "Upkeep_next-look": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "next-look"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "check": {+            "$ref": "#/components/schemas/CheckResult"+          },+          "delay_us": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node",+          "check",+          "delay_us"+        ]+      },+      "UpkeepUntagged_next-look": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "next-look"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "check": {+            "$ref": "#/components/schemas/CheckResult"+          },+          "delay_us": {+            "type": "integer"+          }+        },+        "required": [+          "kind",+          "ref",+          "node",+          "check",+          "delay_us"+        ]+      },+      "Upkeep_wedged": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "wedged"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "silent_us": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node",+          "silent_us"+        ]+      },+      "UpkeepUntagged_wedged": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "wedged"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "silent_us": {+            "type": "integer"+          }+        },+        "required": [+          "kind",+          "ref",+          "node",+          "silent_us"+        ]+      },+      "Upkeep_unwedged": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "unwedged"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node"+        ]+      },+      "UpkeepUntagged_unwedged": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "unwedged"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "kind",+          "ref",+          "node"+        ]+      },+      "Upkeep_output": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "output"+          },+          "kind": {+            "const": "output"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "line": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node",+          "line"+        ],+        "description": "One line a held (`managed`) action wrote; filed on its own `output` stream so `?stream=output` is a live tail."+      },+      "UpkeepUntagged_output": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "output"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "line": {+            "type": "string"+          }+        },+        "required": [+          "kind",+          "ref",+          "node",+          "line"+        ]+      },+      "Upkeep_demoted": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "demoted"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "dependency": {+            "$ref": "#/components/schemas/Ref"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node",+          "dependency"+        ]+      },+      "UpkeepUntagged_demoted": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "demoted"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "dependency": {+            "$ref": "#/components/schemas/Ref"+          }+        },+        "required": [+          "kind",+          "ref",+          "node",+          "dependency"+        ]+      },+      "Upkeep_parked": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "parked"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node"+        ]+      },+      "UpkeepUntagged_parked": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "parked"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "kind",+          "ref",+          "node"+        ]+      },+      "Upkeep_reapplying": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "reapplying"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "delay_us": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node",+          "delay_us"+        ]+      },+      "UpkeepUntagged_reapplying": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "reapplying"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "delay_us": {+            "type": "integer"+          }+        },+        "required": [+          "kind",+          "ref",+          "node",+          "delay_us"+        ]+      },+      "Upkeep_paused": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "paused"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node"+        ]+      },+      "UpkeepUntagged_paused": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "paused"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "kind",+          "ref",+          "node"+        ]+      },+      "Upkeep_resumed": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "resumed"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node"+        ]+      },+      "UpkeepUntagged_resumed": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "resumed"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "kind",+          "ref",+          "node"+        ]+      },+      "Upkeep_gave-up": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "gave-up"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "failures": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node",+          "failures"+        ]+      },+      "UpkeepUntagged_gave-up": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "gave-up"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "failures": {+            "type": "integer"+          }+        },+        "required": [+          "kind",+          "ref",+          "node",+          "failures"+        ]+      },+      "Upkeep_adopted": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "adopted"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node"+        ]+      },+      "UpkeepUntagged_adopted": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "adopted"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "kind",+          "ref",+          "node"+        ]+      },+      "Upkeep_released": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "released"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node"+        ]+      },+      "UpkeepUntagged_released": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "released"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "kind",+          "ref",+          "node"+        ]+      },+      "Upkeep_policy": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "policy"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "supervision": {+            "$ref": "#/components/schemas/Supervision"+          },+          "ignored": {+            "type": "array",+            "items": {+              "$ref": "#/components/schemas/Supervision"+            }+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node",+          "supervision",+          "ignored"+        ]+      },+      "UpkeepUntagged_policy": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "policy"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "supervision": {+            "$ref": "#/components/schemas/Supervision"+          },+          "ignored": {+            "type": "array",+            "items": {+              "$ref": "#/components/schemas/Supervision"+            }+          }+        },+        "required": [+          "kind",+          "ref",+          "node",+          "supervision",+          "ignored"+        ]+      },+      "Upkeep_untended": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "untended"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node"+        ]+      },+      "UpkeepUntagged_untended": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "untended"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          }+        },+        "required": [+          "kind",+          "ref",+          "node"+        ]+      },+      "Upkeep_escaped": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "escaped"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "error": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "ref",+          "node",+          "error"+        ]+      },+      "UpkeepUntagged_escaped": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "escaped"+          },+          "ref": {+            "$ref": "#/components/schemas/Ref"+          },+          "node": {+            "$ref": "#/components/schemas/NodeDescription"+          },+          "error": {+            "type": "string"+          }+        },+        "required": [+          "kind",+          "ref",+          "node",+          "error"+        ]+      },+      "Upkeep_supervising": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "supervising"+          },+          "up": {+            "type": "integer"+          },+          "down": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "up",+          "down"+        ]+      },+      "UpkeepUntagged_supervising": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "supervising"+          },+          "up": {+            "type": "integer"+          },+          "down": {+            "type": "integer"+          }+        },+        "required": [+          "kind",+          "up",+          "down"+        ]+      },+      "Upkeep_retired": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "retired"+          },+          "machines": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "machines"+        ]+      },+      "UpkeepUntagged_retired": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "retired"+          },+          "machines": {+            "type": "integer"+          }+        },+        "required": [+          "kind",+          "machines"+        ]+      },+      "Upkeep_holding": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "upkeep"+          },+          "kind": {+            "const": "holding"+          },+          "machines": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "machines"+        ]+      },+      "UpkeepUntagged_holding": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "holding"+          },+          "machines": {+            "type": "integer"+          }+        },+        "required": [+          "kind",+          "machines"+        ]+      },+      "Serve_started": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "started"+          }+        },+        "required": [+          "stream",+          "kind"+        ]+      },+      "Serve_stopped": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "stopped"+          }+        },+        "required": [+          "stream",+          "kind"+        ]+      },+      "Serve_hung-up": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "hung-up"+          },+          "from": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "from"+        ]+      },+      "Serve_bad-command": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "bad-command"+          },+          "error": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "error"+        ]+      },+      "Serve_bad-seed": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "bad-seed"+          },+          "error": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "error"+        ]+      },+      "Serve_bad-directive": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "bad-directive"+          },+          "error": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "error"+        ]+      },+      "Serve_bad-load": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "bad-load"+          },+          "error": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "error"+        ]+      },+      "Serve_loading": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "loading"+          },+          "path": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "path"+        ]+      },+      "Serve_load-done": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "load-done"+          },+          "path": {+            "type": "string"+          },+          "lines": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "path",+          "lines"+        ]+      },+      "Serve_declared": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "declared"+          },+          "epoch": {+            "type": "integer"+          },+          "direction": {+            "$ref": "#/components/schemas/Direction"+          },+          "nodes": {+            "type": "integer"+          },+          "active_seeds": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "epoch",+          "direction",+          "nodes",+          "active_seeds"+        ]+      },+      "Serve_cleared": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "cleared"+          },+          "retired": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "retired"+        ]+      },+      "Serve_supervised": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "supervised"+          },+          "on": {+            "type": "boolean"+          }+        },+        "required": [+          "stream",+          "kind",+          "on"+        ]+      },+      "Serve_auto-converged": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "auto-converged"+          },+          "on": {+            "type": "boolean"+          }+        },+        "required": [+          "stream",+          "kind",+          "on"+        ]+      },+      "Serve_instructed": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "instructed"+          },+          "instruction": {+            "$ref": "#/components/schemas/Instruction"+          },+          "nodes": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "instruction",+          "nodes"+        ]+      },+      "Serve_fetch-requested": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "fetch-requested"+          },+          "following": {+            "type": "boolean"+          }+        },+        "required": [+          "stream",+          "kind",+          "following"+        ]+      },+      "Serve_tended": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "tended"+          },+          "report": {+            "$ref": "#/components/schemas/UpkeepReportUntagged"+          }+        },+        "required": [+          "stream",+          "kind",+          "report"+        ]+      },+      "Serve_converge-start": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "converge-start"+          },+          "down": {+            "type": "integer"+          },+          "up": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "down",+          "up"+        ]+      },+      "Serve_converge-stop": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "converge-stop"+          },+          "ok": {+            "type": "boolean"+          },+          "remaining": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "ok",+          "remaining"+        ]+      },+      "Serve_status": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "status"+          },+          "mode": {+            "$ref": "#/components/schemas/Mode"+          },+          "nodes": {+            "type": "array",+            "items": {+              "$ref": "#/components/schemas/NodeState"+            }+          }+        },+        "required": [+          "stream",+          "kind",+          "mode",+          "nodes"+        ]+      },+      "Serve_history": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "history"+          },+          "seeds": {+            "type": "array",+            "items": {+              "$ref": "#/components/schemas/HistoryEntry"+            }+          }+        },+        "required": [+          "stream",+          "kind",+          "seeds"+        ]+      },+      "Serve_history-elided": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "history-elided"+          },+          "elided": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "elided"+        ]+      },+      "Serve_query": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "query"+          },+          "nodes": {+            "type": "array",+            "items": {+              "$ref": "#/components/schemas/NodeState"+            }+          }+        },+        "required": [+          "stream",+          "kind",+          "nodes"+        ]+      },+      "Serve_help": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "help"+          },+          "topic": {+            "oneOf": [+              {+                "type": "string"+              },+              {+                "type": "null"+              }+            ]+          },+          "lines": {+            "type": "array",+            "items": {+              "type": "string"+            }+          }+        },+        "required": [+          "stream",+          "kind",+          "topic",+          "lines"+        ]+      },+      "Serve_sink-failed": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "sink-failed"+          },+          "path": {+            "type": "string"+          },+          "error": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "path",+          "error"+        ]+      },+      "Follow_following": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "following"+          },+          "registry": {+            "type": "string"+          },+          "labels": {+            "type": "array",+            "items": {+              "type": "string"+            }+          },+          "schedule": {+            "type": "object",+            "properties": {+              "base_us": {+                "type": "integer"+              },+              "factor": {+                "type": "number"+              },+              "cap_us": {+                "type": "integer"+              },+              "jitter": {+                "type": "number"+              },+              "debounce_us": {+                "type": "integer"+              },+              "max_wait_us": {+                "type": "integer"+              }+            },+            "required": [+              "base_us",+              "factor",+              "cap_us",+              "jitter",+              "debounce_us",+              "max_wait_us"+            ]+          }+        },+        "required": [+          "stream",+          "kind",+          "registry",+          "labels",+          "schedule"+        ]+      },+      "Follow_injected": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "injected"+          },+          "label": {+            "type": "string"+          },+          "document": {+            "type": "string"+          },+          "sha256": {+            "type": "string"+          },+          "up": {+            "type": "integer"+          },+          "down": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "label",+          "document",+          "sha256",+          "up",+          "down"+        ]+      },+      "Follow_no-diff": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "no-diff"+          },+          "label": {+            "type": "string"+          },+          "document": {+            "type": "string"+          },+          "sha256": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "label",+          "document",+          "sha256"+        ]+      },+      "Follow_deferred": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "deferred"+          },+          "label": {+            "type": "string"+          },+          "document": {+            "type": "string"+          },+          "sha256": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "label",+          "document",+          "sha256"+        ]+      },+      "Follow_replayed": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "replayed"+          },+          "label": {+            "type": "string"+          },+          "document": {+            "type": "string"+          },+          "sha256": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "label",+          "document",+          "sha256"+        ]+      },+      "Follow_backoff": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "backoff"+          },+          "failures": {+            "type": "integer"+          },+          "next_us": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "failures",+          "next_us"+        ]+      },+      "Follow_missing": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "missing"+          },+          "label": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "label"+        ]+      },+      "Follow_vanished": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "vanished"+          },+          "label": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "label"+        ]+      },+      "Follow_malformed": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "malformed"+          },+          "label": {+            "type": "string"+          },+          "sha256": {+            "type": "string"+          },+          "error": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "label",+          "sha256",+          "error"+        ]+      },+      "Follow_fetch-failed": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "fetch-failed"+          },+          "label": {+            "type": "string"+          },+          "error": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "label",+          "error"+        ]+      },+      "Follow_stale": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "stale"+          },+          "label": {+            "type": "string"+          },+          "document": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "label",+          "document"+        ]+      },+      "Follow_bad-cache": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "bad-cache"+          },+          "label": {+            "type": "string"+          },+          "error": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "label",+          "error"+        ]+      },+      "Follow_rejected": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "rejected"+          },+          "label": {+            "type": "string"+          },+          "sha256": {+            "type": "string"+          },+          "reason": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "label",+          "sha256",+          "reason"+        ]+      },+      "Follow_cache-failed": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "follow"+          },+          "kind": {+            "const": "cache-failed"+          },+          "label": {+            "type": "string"+          },+          "error": {+            "type": "string"+          }+        },+        "required": [+          "stream",+          "kind",+          "label",+          "error"+        ]+      },+      "UpDownReport": {+        "oneOf": [+          {+            "$ref": "#/components/schemas/UpDown_skip"+          },+          {+            "$ref": "#/components/schemas/UpDown_eval"+          },+          {+            "$ref": "#/components/schemas/UpDown_done"+          },+          {+            "$ref": "#/components/schemas/UpDown_blocked"+          },+          {+            "$ref": "#/components/schemas/UpDown_failed"+          },+          {+            "$ref": "#/components/schemas/UpDown_conflicting"+          },+          {+            "$ref": "#/components/schemas/UpDown_instructed"+          },+          {+            "$ref": "#/components/schemas/UpDown_dropped-instructions"+          }+        ],+        "description": "`stream` is added when the report travels tagged; nested inside `acted` it is absent."+      },+      "UpkeepReport": {+        "oneOf": [+          {+            "$ref": "#/components/schemas/Upkeep_acted"+          },+          {+            "$ref": "#/components/schemas/Upkeep_upkeep"+          },+          {+            "$ref": "#/components/schemas/Upkeep_downkeep"+          },+          {+            "$ref": "#/components/schemas/Upkeep_next-look"+          },+          {+            "$ref": "#/components/schemas/Upkeep_wedged"+          },+          {+            "$ref": "#/components/schemas/Upkeep_unwedged"+          },+          {+            "$ref": "#/components/schemas/Upkeep_output"+          },+          {+            "$ref": "#/components/schemas/Upkeep_demoted"+          },+          {+            "$ref": "#/components/schemas/Upkeep_parked"+          },+          {+            "$ref": "#/components/schemas/Upkeep_reapplying"+          },+          {+            "$ref": "#/components/schemas/Upkeep_paused"+          },+          {+            "$ref": "#/components/schemas/Upkeep_resumed"+          },+          {+            "$ref": "#/components/schemas/Upkeep_gave-up"+          },+          {+            "$ref": "#/components/schemas/Upkeep_adopted"+          },+          {+            "$ref": "#/components/schemas/Upkeep_released"+          },+          {+            "$ref": "#/components/schemas/Upkeep_policy"+          },+          {+            "$ref": "#/components/schemas/Upkeep_untended"+          },+          {+            "$ref": "#/components/schemas/Upkeep_escaped"+          },+          {+            "$ref": "#/components/schemas/Upkeep_supervising"+          },+          {+            "$ref": "#/components/schemas/Upkeep_retired"+          },+          {+            "$ref": "#/components/schemas/Upkeep_holding"+          }+        ],+        "description": ""+      },+      "UpDownReportUntagged": {+        "oneOf": [+          {+            "$ref": "#/components/schemas/UpDownUntagged_skip"+          },+          {+            "$ref": "#/components/schemas/UpDownUntagged_eval"+          },+          {+            "$ref": "#/components/schemas/UpDownUntagged_done"+          },+          {+            "$ref": "#/components/schemas/UpDownUntagged_blocked"+          },+          {+            "$ref": "#/components/schemas/UpDownUntagged_failed"+          },+          {+            "$ref": "#/components/schemas/UpDownUntagged_conflicting"+          },+          {+            "$ref": "#/components/schemas/UpDownUntagged_instructed"+          },+          {+            "$ref": "#/components/schemas/UpDownUntagged_dropped-instructions"+          }+        ],+        "description": "An UpDown report nested inside another (no `stream`: only the outermost object is tagged)."+      },+      "UpkeepReportUntagged": {+        "oneOf": [+          {+            "$ref": "#/components/schemas/UpkeepUntagged_acted"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_upkeep"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_downkeep"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_next-look"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_wedged"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_unwedged"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_output"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_demoted"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_parked"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_reapplying"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_paused"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_resumed"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_gave-up"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_adopted"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_released"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_policy"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_untended"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_escaped"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_supervising"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_retired"+          },+          {+            "$ref": "#/components/schemas/UpkeepUntagged_holding"+          }+        ],+        "description": "An Upkeep report nested inside `tended` (no `stream`)."+      },+      "ServeReport": {+        "oneOf": [+          {+            "$ref": "#/components/schemas/Serve_started"+          },+          {+            "$ref": "#/components/schemas/Serve_stopped"+          },+          {+            "$ref": "#/components/schemas/Serve_hung-up"+          },+          {+            "$ref": "#/components/schemas/Serve_bad-command"+          },+          {+            "$ref": "#/components/schemas/Serve_bad-seed"+          },+          {+            "$ref": "#/components/schemas/Serve_bad-directive"+          },+          {+            "$ref": "#/components/schemas/Serve_bad-load"+          },+          {+            "$ref": "#/components/schemas/Serve_loading"+          },+          {+            "$ref": "#/components/schemas/Serve_load-done"+          },+          {+            "$ref": "#/components/schemas/Serve_declared"+          },+          {+            "$ref": "#/components/schemas/Serve_cleared"+          },+          {+            "$ref": "#/components/schemas/Serve_supervised"+          },+          {+            "$ref": "#/components/schemas/Serve_auto-converged"+          },+          {+            "$ref": "#/components/schemas/Serve_instructed"+          },+          {+            "$ref": "#/components/schemas/Serve_fetch-requested"+          },+          {+            "$ref": "#/components/schemas/Serve_tended"+          },+          {+            "$ref": "#/components/schemas/Serve_converge-start"+          },+          {+            "$ref": "#/components/schemas/Serve_converge-stop"+          },+          {+            "$ref": "#/components/schemas/Serve_status"+          },+          {+            "$ref": "#/components/schemas/Serve_history"+          },+          {+            "$ref": "#/components/schemas/Serve_history-elided"+          },+          {+            "$ref": "#/components/schemas/Serve_query"+          },+          {+            "$ref": "#/components/schemas/Serve_help"+          },+          {+            "$ref": "#/components/schemas/Serve_sink-failed"+          }+        ],+        "description": ""+      },+      "FollowReport": {+        "oneOf": [+          {+            "$ref": "#/components/schemas/Follow_following"+          },+          {+            "$ref": "#/components/schemas/Follow_injected"+          },+          {+            "$ref": "#/components/schemas/Follow_no-diff"+          },+          {+            "$ref": "#/components/schemas/Follow_deferred"+          },+          {+            "$ref": "#/components/schemas/Follow_replayed"+          },+          {+            "$ref": "#/components/schemas/Follow_backoff"+          },+          {+            "$ref": "#/components/schemas/Follow_missing"+          },+          {+            "$ref": "#/components/schemas/Follow_vanished"+          },+          {+            "$ref": "#/components/schemas/Follow_malformed"+          },+          {+            "$ref": "#/components/schemas/Follow_fetch-failed"+          },+          {+            "$ref": "#/components/schemas/Follow_stale"+          },+          {+            "$ref": "#/components/schemas/Follow_bad-cache"+          },+          {+            "$ref": "#/components/schemas/Follow_rejected"+          },+          {+            "$ref": "#/components/schemas/Follow_cache-failed"+          }+        ],+        "description": ""+      },+      "Report": {+        "oneOf": [+          {+            "$ref": "#/components/schemas/ServeReport"+          },+          {+            "$ref": "#/components/schemas/UpDownReport"+          },+          {+            "$ref": "#/components/schemas/UpkeepReport"+          },+          {+            "$ref": "#/components/schemas/FollowReport"+          }+        ],+        "description": "One report, tagged by `stream` (who reported: `serve` the loop, `updown` a convergence pass, `upkeep` a tending machine, `follow` the pull-mode fetcher) and `kind` (the constructor, kebab-cased). Exactly what `--json` prints, one object per line. Report text is public and carried verbatim.",+        "discriminator": {+          "propertyName": "stream"+        }+      },+      "HistoryEntry": {+        "type": "object",+        "properties": {+          "epoch": {+            "type": "integer"+          },+          "declaration": {+            "type": "string",+            "enum": [+              "up",+              "only",+              "down"+            ]+          },+          "active": {+            "type": "boolean"+          },+          "origin": {+            "$ref": "#/components/schemas/Origin"+          },+          "args": {+            "type": "array",+            "items": {+              "type": "string"+            }+          }+        },+        "required": [+          "epoch",+          "declaration",+          "active",+          "origin",+          "args"+        ]+      },+      "DagResponse": {+        "type": "object",+        "properties": {+          "mode": {+            "$ref": "#/components/schemas/Mode"+          },+          "nodes": {+            "type": "array",+            "items": {+              "$ref": "#/components/schemas/DagNode"+            }+          },+          "seq": {+            "type": "integer"+          }+        },+        "required": [+          "mode",+          "nodes",+          "seq"+        ],+        "description": "The computed DAG (the structure a pass walks, before any registered rewrite): one object per ref, dependencies first. `seq` is the last event number handed out, read before the world, so `GET /events?since=<seq>` replays anything that landed in between."+      },+      "StatusResponse": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "status"+          },+          "mode": {+            "$ref": "#/components/schemas/Mode"+          },+          "nodes": {+            "type": "array",+            "items": {+              "$ref": "#/components/schemas/NodeState"+            }+          },+          "seq": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "mode",+          "nodes",+          "seq"+        ],+        "description": "What `status --json` prints, plus `seq` (see DagResponse)."+      },+      "HistoryResponse": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "serve"+          },+          "kind": {+            "const": "history"+          },+          "seeds": {+            "type": "array",+            "items": {+              "$ref": "#/components/schemas/HistoryEntry"+            }+          },+          "elided": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "seeds",+          "elided"+        ],+        "description": "What `history --json` prints, with the elided count folded in as a field."+      },+      "HelpResponse": {+        "type": "object",+        "properties": {+          "seed": {+            "type": "string"+          },+          "commands": {+            "type": "array",+            "items": {+              "type": "string"+            }+          }+        },+        "required": [+          "seed",+          "commands"+        ],+        "description": "`seed` is the seed parser's own `--help` text: the grammar of the words after `up`/`only`/`down`, which is binary-specific. `commands` is the input language's reference."+      },+      "CommandBody": {+        "oneOf": [+          {+            "type": "object",+            "properties": {+              "line": {+                "type": "string"+              }+            },+            "required": [+              "line"+            ]+          },+          {+            "type": "object",+            "properties": {+              "verb": {+                "type": "string"+              },+              "seed": {+                "type": "array",+                "items": {+                  "type": "string"+                }+              }+            },+            "required": [+              "verb"+            ]+          }+        ],+        "description": "One line of the input language, or a verb and its seed words rendered to the very line the first form would have carried. A newline anywhere is refused: one command per request."+      },+      "AsyncAnswer": {+        "type": "object",+        "properties": {+          "seq": {+            "type": "integer"+          },+          "origin": {+            "type": "string"+          }+        },+        "required": [+          "seq",+          "origin"+        ],+        "description": "`seq` is the number of the `enqueued` event for the command; its reports are the events numbered above it whose `origin.name` is `origin`."+      },+      "EnqueuedEvent": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "server"+          },+          "kind": {+            "const": "enqueued"+          },+          "line": {+            "type": "string"+          },+          "seq": {+            "type": "integer"+          },+          "origin": {+            "$ref": "#/components/schemas/Origin"+          }+        },+        "required": [+          "stream",+          "kind",+          "line",+          "seq",+          "origin"+        ]+      },+      "GapEvent": {+        "type": "object",+        "properties": {+          "stream": {+            "const": "server"+          },+          "kind": {+            "const": "gap"+          },+          "from": {+            "type": "integer"+          }+        },+        "required": [+          "stream",+          "kind",+          "from"+        ],+        "description": "Sent first, with no `id:`, to a client whose `?since` fell off the ring: `from` is the oldest number the replay starts at."+      },+      "EventData": {+        "type": "object",+        "properties": {+          "stream": {+            "type": "string",+            "enum": [+              "serve",+              "updown",+              "upkeep",+              "output",+              "follow",+              "server"+            ]+          },+          "kind": {+            "type": "string"+          },+          "seq": {+            "type": "integer"+          },+          "origin": {+            "$ref": "#/components/schemas/Origin"+          }+        },+        "required": [+          "stream",+          "kind",+          "seq"+        ],+        "description": "The `data:` of one server-sent event: the Report object of that stream and kind (or EnqueuedEvent) with `seq` added, and `origin` when the event belongs to a command. `seq` is also the SSE `id:`. See Report, EnqueuedEvent and GapEvent for the fields by kind.",+        "additionalProperties": true+      },+      "SessionAnswer": {+        "type": "object",+        "properties": {+          "session": {+            "type": "boolean"+          }+        },+        "required": [+          "session"+        ]+      },+      "StatusObject": {+        "type": "object",+        "properties": {+          "kind": {+            "const": "status"+          },+          "mode": {+            "$ref": "#/components/schemas/Mode"+          },+          "nodes": {+            "type": "array",+            "items": {+              "$ref": "#/components/schemas/NodeState"+            }+          }+        },+        "required": [+          "kind",+          "mode",+          "nodes"+        ],+        "description": "`status --json` as the sink embeds it: the same object without the `stream` tag."+      },+      "StatusDocument": {+        "type": "object",+        "properties": {+          "salmon-status": {+            "const": 1+          },+          "host": {+            "type": "string"+          },+          "written": {+            "type": "string",+            "format": "date-time"+          },+          "mode": {+            "$ref": "#/components/schemas/Mode"+          },+          "labels": {+            "type": "array",+            "items": {+              "type": "object",+              "properties": {+                "label": {+                  "type": "string"+                },+                "id": {+                  "type": "string"+                },+                "sha256": {+                  "type": "string"+                },+                "applied": {+                  "type": "string",+                  "format": "date-time"+                }+              },+              "required": [+                "label",+                "id",+                "sha256",+                "applied"+              ]+            }+          },+          "status": {+            "$ref": "#/components/schemas/StatusObject"+          },+          "last": {+            "type": "object",+            "properties": {+              "converge": {+                "oneOf": [+                  {+                    "$ref": "#/components/schemas/Report"+                  },+                  {+                    "type": "null"+                  }+                ]+              },+              "follow": {+                "oneOf": [+                  {+                    "$ref": "#/components/schemas/Report"+                  },+                  {+                    "type": "null"+                  }+                ]+              }+            },+            "required": [+              "converge",+              "follow"+            ]+          }+        },+        "required": [+          "salmon-status",+          "host",+          "written",+          "mode",+          "labels",+          "status",+          "last"+        ],+        "description": "The document `run serve --status-sink` writes (to a file, or POSTed to a URL). Not served over HTTP by the loop; described here because it embeds `status` and two Reports and is read by other tools (`salmon-fleet status`)."+      }+    }+  }+}
+ salmon-ops.cabal view
@@ -0,0 +1,235 @@+cabal-version:      2.4+name:               salmon-ops+version:            0.1.0.0+synopsis:           IO builtins and command line plumbing for Salmon operations.+description:        Builtin operations (files, systemd, debian packages, podman, postgres, wireguard, certificates, ssh, ...) built on salmon-core, plus the shared command line, the long-running serve loop with its HTTP API and web UI.+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+extra-source-files:+                    ui/index.html+                    ui/ui.js+                    ui/ui.css+                    ui/auth.html+                    openapi/serve-api.openapi.json++source-repository head+    type:     git+    location: https://github.com/lucasdicioccio/salmon+    subdir:   salmon-ops++library+    exposed-modules: Salmon.Actions.Concurrent+                   , Salmon.Actions.Follow+                   , Salmon.Actions.Follow.Registry+                   , Salmon.Actions.Follow.Registry.Dns+                   , Salmon.Actions.Follow.Registry.Git+                   , Salmon.Actions.Follow.Registry.Http+                   , Salmon.Actions.Follow.Scheduler+                   , Salmon.Actions.Follow.Signature+                   , Salmon.Actions.Help+                   , Salmon.Actions.Serve+                   , Salmon.Actions.Serve.Events+                   , Salmon.Actions.Serve.Http+                   , Salmon.Actions.Serve.Socket+                   , Salmon.Actions.Serve.StatusSink+                   , Salmon.Actions.Fleet+                   , Salmon.Actions.UpDown+                   , Salmon.Actions.Upkeep+                   , Salmon.Actions.Dot+                   , Salmon.Actions.Query+                   , Salmon.Client.Http+                   , Salmon.Client.Model+                   , Salmon.Builtin.Extension+                   , Salmon.Builtin.CommandLine+                   , Salmon.Builtin.Helpers+                   , Salmon.Builtin.Migrations+                   , Salmon.Builtin.Nodes.Bash+                   , Salmon.Builtin.Nodes.Binary+                   , Salmon.Builtin.Nodes.Cabal+                   , Salmon.Builtin.Nodes.Daemon+                   , Salmon.Builtin.Nodes.Capabilities+                   , Salmon.Builtin.Nodes.Certificates+                   , Salmon.Builtin.Nodes.Continuation+                   , Salmon.Builtin.Nodes.CronTask+                   , Salmon.Builtin.Nodes.Debian.Debootstrap+                   , Salmon.Builtin.Nodes.Debian.AptRepository+                   , Salmon.Builtin.Nodes.Debian.Package+                   , Salmon.Builtin.Nodes.Debian.OS+                   , Salmon.Builtin.Nodes.Demo+                   , Salmon.Builtin.Nodes.Gcp.ArtifactRegistry+                   , Salmon.Builtin.Nodes.Gcp.Billing+                   , Salmon.Builtin.Nodes.Gcp.CloudRun+                   , Salmon.Builtin.Nodes.Gcp.Compute+                   , Salmon.Builtin.Nodes.Gcp.Core+                   , Salmon.Builtin.Nodes.Gcp.Iam+                   , Salmon.Builtin.Nodes.Gcp.LoadBalancing+                   , Salmon.Builtin.Nodes.Gcp.Monitoring+                   , Salmon.Builtin.Nodes.Gcp.ResourceManager+                   , Salmon.Builtin.Nodes.Gcp.SecretManager+                   , Salmon.Builtin.Nodes.Gcp.ServiceUsage+                   , Salmon.Builtin.Nodes.Gcp.SshAccess+                   , Salmon.Builtin.Nodes.Gcp.Storage+                   , Salmon.Builtin.Nodes.Filesystem+                   , Salmon.Builtin.Nodes.Git+                   , Salmon.Builtin.Nodes.User+                   , Salmon.Builtin.Nodes.Keys+                   , Salmon.Builtin.Nodes.LinuxBridge+                   , Salmon.Builtin.Nodes.Netfilter+                   , Salmon.Builtin.Nodes.Nginx+                   , Salmon.Builtin.Nodes.Npm+                   , Salmon.Builtin.Nodes.PgBouncer+                   , Salmon.Builtin.Nodes.Etcd+                   , Salmon.Builtin.Nodes.Postgres+                   , Salmon.Builtin.Nodes.LlamaServer+                   , Salmon.Builtin.Nodes.PgVector+                   , Salmon.Builtin.Nodes.Plakar+                   , Salmon.Builtin.Nodes.Podman+                   , Salmon.Builtin.Nodes.Qemu+                   , Salmon.Builtin.Nodes.Rsync+                   , Salmon.Builtin.Nodes.Routes+                   , Salmon.Builtin.Nodes.Self+                   , Salmon.Builtin.Nodes.Secrets+                   , Salmon.Builtin.Nodes.Spago+                   , Salmon.Builtin.Nodes.Ssh+                   , Salmon.Builtin.Nodes.Sysctl+                   , Salmon.Builtin.Nodes.Systemd+                   , Salmon.Builtin.Nodes.Tar+                   , Salmon.Builtin.Nodes.Upx+                   , Salmon.Builtin.Nodes.Web+                   , Salmon.Builtin.Nodes.WireGuard+                   , Salmon.Op.Concurrency+                   , Salmon.Op.Dag+                   , Salmon.Op.Ledger+                   , Salmon.Op.Mailbox+                   , Salmon.Op.Rewrite+                   , Salmon.Op.Status+                   , Salmon.Op.Supervision+                   , Salmon.Op.Window+                   , Salmon.Op.Configure+                   , Salmon.Op.Ref+                   , Salmon.Reporter+                   , Salmon.Reporter.Tagged+    build-depends:    base >=4.16.3.0 && <4.22+                    , async+                    , aeson+                    , base64-bytestring+                    , bytestring+                    , containers+                    , contravariant+                    , crypton+                    , crypton-connection+                    , crypton-x509-store+                    , cryptohash-sha256+                    , directory+                    , file-embed+                    , filepath+                    , free+                    , hashable+                    , http-client+                    , http-client-tls+                    , http-types+                    , jose+                    , mtl+                    , network+                    , optparse-applicative+                    , optparse-generic+                    , process+                    , process-extras+                    , salmon-core ^>=0.1.0.0+                    , stm+                    , text+                    , time+                    , unix+                    , wai+                    , warp+                    , tls+                    , warp-tls+    hs-source-dirs:   src+    default-language: Haskell2010+    default-extensions: KindSignatures+                      , DataKinds+                      , OverloadedStrings+                      , DeriveFunctor+                      , OverloadedRecordDot+                      , TypeApplications+                      , ScopedTypeVariables++executable salmon-ops-dot-fixture+    main-is:          DotFixture.hs+    hs-source-dirs:   fixtures+    build-depends:    base >=4.16.3.0 && <4.22+                    , mtl+                    , salmon-core ^>=0.1.0.0+                    , salmon-ops ^>=0.1.0.0+                    , text+    -- every salmon binary can end up running the concurrent driver (`run+    -- serve` does), and a node's own thread must not block the whole runtime.+    ghc-options:      -threaded+    default-language: Haskell2010+    default-extensions: OverloadedStrings+                      , OverloadedRecordDot+                      , ScopedTypeVariables++executable salmon-postgres-replication-fixture+    main-is:          PostgresReplicationFixture.hs+    hs-source-dirs:   fixtures+    build-depends:    base >=4.16.3.0 && <4.22+                    , mtl+                    , salmon-core ^>=0.1.0.0+                    , salmon-ops ^>=0.1.0.0+                    , text+    -- every salmon binary can end up running the concurrent driver (`run+    -- serve` does), and a node's own thread must not block the whole runtime.+    ghc-options:      -threaded+    default-language: Haskell2010+    default-extensions: OverloadedStrings+                      , OverloadedRecordDot+                      , ScopedTypeVariables++executable salmon-qemu-host-setup-fixture+    main-is:          QemuHostSetupFixture.hs+    hs-source-dirs:   fixtures+    build-depends:    base >=4.16.3.0 && <4.22+                    , directory+                    , mtl+                    , filepath+                    , salmon-core ^>=0.1.0.0+                    , salmon-ops ^>=0.1.0.0+                    , text+    -- every salmon binary can end up running the concurrent driver (`run+    -- serve` does), and a node's own thread must not block the whole runtime.+    ghc-options:      -threaded+    default-language: Haskell2010+    default-extensions: OverloadedStrings+                      , OverloadedRecordDot+                      , ScopedTypeVariables++executable salmon-ops-serve-fixture+    main-is:          ServeFixture.hs+    hs-source-dirs:   fixtures+    build-depends:    base >=4.16.3.0 && <4.22+                    , aeson+                    , directory+                    , filepath+                    , optparse-applicative+                    , optparse-generic+                    , process+                    , salmon-core ^>=0.1.0.0+                    , salmon-ops ^>=0.1.0.0+                    , text+    -- every salmon binary can end up running the concurrent driver (`run+    -- serve` does), and a node's own thread must not block the whole runtime.+    ghc-options:      -threaded+    default-language: Haskell2010+    default-extensions: OverloadedStrings+                      , OverloadedRecordDot+                      , ScopedTypeVariables
+ src/Salmon/Actions/Concurrent.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | The concurrent driver: one thread per node, ordering by STM rather than+by counters on a traversal's stack.++Same contract as "Salmon.Actions.UpDown"'s synchronous drivers — same+'UpDown.Report' stream, same @'IO' 'Bool'@, same failure containment — and+the same one pass, one attempt per node. What differs is that independent+subtrees no longer wait for each other, and that each node has state of its+own while it runs, which is what everything after this is built on.++= How ordering works here++Each node gets a @'TVar' 'Status'@ and a thread. The thread blocks on+'waitStability' over its neighbours in the direction it waits — dependencies+going up, dependants coming down — and 'retry' does the scheduling. No+counters, no ready-queue, no wakeup channel: a node wakes exactly when a+neighbour's state changes and not otherwise. The teardown ordering that+'UpDown.walk' spends a countdown map on is the same code with the two+adjacency directions swapped.++= Failure is still a property of the pass++'waitStability' reads direction and stability only, so a node that settled+having failed looks exactly like one that settled having succeeded. That is+deliberate — whether to proceed past a failure is the /driver's/ policy, not+the neighbour's property — and this driver answers it the way the synchronous+one does: a node whose neighbour did not succeed reports 'UpDown.Blocked',+settles, and contains the failure to that sub-DAG. A supervisor would answer+it differently (wait, because the neighbour may yet be repaired), which is+why it is not baked into 'Status'.++= Two things concurrency forces that the sequential drivers never had to face++* __Reports are serialised.__ Every 'runReporter' call goes through one+  'MVar', so a multi-line report cannot interleave with another node's. The+  reporter belongs to the caller and cannot be assumed thread-safe.+* __A cycle has to be found before the walk, not after.__ The sequential+  drivers discover unreachable nodes by finishing and noticing what they+  never touched. A thread waiting on a node in a cycle simply never wakes, so+  'Dag.stuck' is consulted up front and those nodes are reported 'Blocked'+  without being spawned.++= Instructions++A node consults its mailbox once, immediately before deciding what to do —+which is all a single-pass driver can honour. 'Force' makes it act regardless+of what 'check' or the 'UpDown.Gate' says; 'Satisfy' makes it treat the node+as already done. The last of those two in the mailbox wins, since a later+instruction supersedes an earlier statement of intent. 'Recheck', 'Pause' and+'Resume' are meaningful only to a driver that tends a node continuously; here+they are read, reported and otherwise ignored.++= Bounding width++Ordering is unbounded by design (an edge or a collection is the only thing+that ever serialises two nodes here — see "Salmon.Op.Concurrency"'s header+for why that is deliberate and what it does not cover). Both drivers below+take an optional 'ConcurrencyLimit' that bounds something orthogonal to+ordering: how many nodes may be inside their own 'check'\/'up'\/'down' at+once, across the whole pass. 'Nothing' reproduces this module's behaviour+before the limit existed.+-}+module Salmon.Actions.Concurrent (+    upDagConcurrent,+    downDagConcurrent,+    noMailboxes,+) where++import Control.Concurrent.Async (forConcurrently_)+import Control.Concurrent.MVar (newMVar, withMVar)+import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVar, readTVarIO)+import Control.Exception (SomeException, try)+import Control.Monad (forM_, unless)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as Text+import GHC.Records (HasField)++import Salmon.Actions.UpDown (CheckResult (..), Gate, Report (..), Requirement (..), requirement, runCheck)+import Salmon.Op.Actions (Act (..))+import Salmon.Op.Concurrency (ConcurrencyLimit, withConcurrencyLimit)+import Salmon.Op.Dag (Dag)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Mailbox (Instruction (..), Mailbox)+import qualified Salmon.Op.Mailbox as Mailbox+import Salmon.Op.Ref (Ref)+import Salmon.Op.Status (Direction (..), Stability (..), Status (..), newStatus, note, waitStability)+import Salmon.Reporter++-- | No node can be instructed: what a driver with no control plane in front+-- of it passes.+noMailboxes :: Map Ref Mailbox+noMailboxes = Map.empty++{- | 'Salmon.Actions.UpDown.upDag', concurrently. Every node runs as soon as+the nodes it depends on have settled, rather than as soon as the traversal+gets to it.+-}+upDagConcurrent ::+    forall ext.+    ( HasField "up" ext (IO ())+    , HasField "check" ext (IO CheckResult)+    , HasField "ref" ext Ref+    ) =>+    Gate ext ->+    Reporter (Report ext) ->+    Map Ref Mailbox ->+    -- | caps how many nodes are inside 'check'\/'up' at once across this+    -- pass; 'Nothing' is unbounded. See "Salmon.Op.Concurrency".+    Maybe ConcurrencyLimit ->+    Dag ext ->+    IO Bool+upDagConcurrent gate r boxes limit dag =+    walkConcurrent TurnUp r boxes limit dag Dag.dependenciesOf apply+  where+    apply :: Say ext -> TVar Status -> Act ext -> [Instruction] -> IO CheckResult+    apply say status act instructions = do+        wanted <- decide+        case wanted of+            Skippable -> do+                say (Skip act)+                pure Skipped+            Required -> do+                say (Eval act)+                note status "eval"+                result <- try @SomeException act.extension.up+                case result of+                    Left e -> do+                        say (Failed act e)+                        note status (Text.pack (show e))+                        pure (Failure (Text.pack (show e)))+                    Right () -> do+                        say (Done act)+                        note status "done"+                        pure Success+      where+        decide =+            case override instructions of+                Just Force -> pure Required+                Just Satisfy -> pure Skippable+                _ -> do+                    asked <- gate act+                    case asked of+                        Skippable -> pure Skippable+                        Required -> requirement <$> runCheck act++{- | 'Salmon.Actions.UpDown.downDag', concurrently. A node comes down as soon+as everything standing on it has, which is the same STM wait with the two+adjacency directions swapped.++A node's own 'Salmon.Builtin.Extension.check' is not consulted, as in the+sequential teardown: it answers "does my effect still need creating", which+is not the question. 'Force' and 'Satisfy' still apply, since they are+statements about whether to act at all.+-}+downDagConcurrent ::+    forall ext.+    ( HasField "down" ext (IO ())+    , HasField "ref" ext Ref+    ) =>+    Gate ext ->+    Reporter (Report ext) ->+    Map Ref Mailbox ->+    -- | caps how many nodes are inside 'down' at once across this pass;+    -- 'Nothing' is unbounded. See "Salmon.Op.Concurrency".+    Maybe ConcurrencyLimit ->+    Dag ext ->+    IO Bool+downDagConcurrent gate r boxes limit dag =+    walkConcurrent TurnDown r boxes limit dag Dag.dependantsOf apply+  where+    apply :: Say ext -> TVar Status -> Act ext -> [Instruction] -> IO CheckResult+    apply say status act instructions = do+        wanted <- decide+        case wanted of+            Skippable -> do+                say (Skip act)+                pure Skipped+            Required -> do+                say (Eval act)+                note status "eval"+                result <- try @SomeException act.extension.down+                case result of+                    Left e -> do+                        say (Failed act e)+                        note status (Text.pack (show e))+                        pure (Failure (Text.pack (show e)))+                    Right () -> do+                        say (Done act)+                        note status "done"+                        pure Success+      where+        decide =+            case override instructions of+                Just Force -> pure Required+                Just Satisfy -> pure Skippable+                _ -> gate act++-------------------------------------------------------------------------------++-- | A serialised 'runReporter': see the module header on why.+type Say ext = Report ext -> IO ()++-- | The last 'Force' or 'Satisfy' in the mailbox, if either is there. Later+-- supersedes earlier: these are statements of current intent.+override :: [Instruction] -> Maybe Instruction+override = go Nothing+  where+    go acc [] = acc+    go acc (i : is)+        | i `elem` [Force, Satisfy] = go (Just i) is+        | otherwise = go acc is++{- | The ordering, containment and completeness machinery both concurrent+drivers share, parameterised by which adjacency direction a node waits on.++@apply@ returns what the node has to say about itself afterwards, in the+vocabulary of the direction it is going: 'Success' means the node reached the+state this pass wanted (the effect is up, or the effect is gone), 'Failure'+that it did not, 'Skipped' that nobody asked it to try.+-}+walkConcurrent ::+    forall ext.+    (HasField "ref" ext Ref) =>+    Direction ->+    Reporter (Report ext) ->+    Map Ref Mailbox ->+    Maybe ConcurrencyLimit ->+    Dag ext ->+    (Dag ext -> Ref -> [Ref]) ->+    (Say ext -> TVar Status -> Act ext -> [Instruction] -> IO CheckResult) ->+    IO Bool+walkConcurrent dir r boxes limit dag waitsOn apply = do+    let order = Dag.dagOrder dag+    let stuckRefs = Dag.stuck waitsOn dag++    statuses <- Map.fromList <$> traverse (\aref -> (,) aref <$> newStatus dir) order+    -- nodes that did not reach what this pass wanted. Read by a node's+    -- neighbours once they have settled, which is why it is a TVar and not+    -- an IORef.+    failedVar <- newTVarIO (Set.empty :: Set Ref)++    reportLock <- newMVar ()+    let say :: Say ext+        say rep = withMVar reportLock (\() -> runReporter r rep)++    -- A node on a cycle never becomes ready, so it is never spawned; nothing+    -- live waits on it, since everything that does is on or behind the same+    -- cycle and therefore also here.+    forM_ [aref | aref <- order, Set.member aref stuckRefs] $ \aref -> do+        forM_ (Dag.representativeOf dag aref) $ \act -> say (Blocked act)+        atomically (modifyTVar' failedVar (Set.insert aref))++    forConcurrently_ [aref | aref <- order, Set.notMember aref stuckRefs] $ \aref ->+        forM_ (Dag.representativeOf dag aref) $ \act -> do+            let status = statuses Map.! aref+            let neighbours = waitsOn dag aref+            atomically (waitStability dir Stable [statuses Map.! n | n <- neighbours])+            blocked <- anyFailed failedVar neighbours+            outcome <-+                if blocked+                    then do+                        say (Blocked act)+                        note status "blocked"+                        pure (Failure "a neighbour did not settle as wanted")+                    else do+                        instructions <- takeInstructions say act aref+                        -- a node's own thread throwing would leave its+                        -- neighbours waiting forever, so nothing is allowed+                        -- to escape here even though `apply` catches already.+                        -- the slot is held only around this call: every+                        -- neighbour this node waited on above has already+                        -- released its own by the time `waitStability`+                        -- returns, so this can never wait on a slot held by+                        -- something in turn waiting on this node.+                        escaped <- try @SomeException (withConcurrencyLimit limit (apply say status act instructions))+                        case escaped of+                            Right result -> pure result+                            Left e -> do+                                say (Failed act e)+                                pure (Failure (Text.pack (show e)))+            -- recording the outcome and settling has to be one transaction:+            -- a neighbour that saw `Stable` before the failure was recorded+            -- would proceed against a node that had in fact failed.+            atomically $ do+                unless (succeeded outcome) $ modifyTVar' failedVar (Set.insert aref)+                modifyTVar' status $ \st ->+                    st{statusStability = Stable, statusCheck = outcome}++    failed <- readTVarIO failedVar+    pure (Set.null failed)+  where+    succeeded :: CheckResult -> Bool+    succeeded (Failure _) = False+    succeeded Unknown = False+    succeeded _ = True++    anyFailed :: TVar (Set Ref) -> [Ref] -> IO Bool+    anyFailed var neighbours = atomically $ do+        f <- readTVar var+        pure (any (`Set.member` f) neighbours)++    takeInstructions :: Say ext -> Act ext -> Ref -> IO [Instruction]+    takeInstructions say act aref =+        case Map.lookup aref boxes of+            Nothing -> pure []+            Just box -> do+                before <- Mailbox.dropped box+                instructions <- atomically (Mailbox.takeAll box)+                unless (before == 0) $ say (DroppedInstructions act before)+                forM_ instructions $ \i -> say (Instructed act i)+                pure instructions
+ src/Salmon/Actions/Dot.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Salmon.Actions.Dot (+    printDigraph,+    printCograph,+    printDagCograph,+    PlaceHolder (..),+    OpaqueNode (..),+    DotGraphExt,+) where++import Control.Comonad.Cofree (Cofree (..))+import Data.Foldable (toList, traverse_)+import GHC.Records++import Data.Dynamic (Dynamic, fromDynamic)+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import qualified Data.Maybe as Maybe+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text++import Salmon.FoldBranch+import Salmon.Op.Actions+import Salmon.Op.Dag (Dag)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Eval+import Salmon.Op.Graph+import Salmon.Op.GraphFold (Branch (..), Shape (..), foldWithContext)+import Salmon.Op.OpGraph+import Salmon.Op.Ref++type Node ext = Maybe (Ref, ShortHand, ext)++type RawEdge = (Ref, Ref)++data Edge = Edge {connection :: ConnectType, rawEdge :: RawEdge}+data PrevConnectType = CL | CR | OV+data CurConnectType = V | O | C+type ConnectType = (PrevConnectType, CurConnectType)++-- | Slightly over-constrained constraint for graph extentions we want to represent.+type DotGraphExt ext = (HasField "dynamics" ext [Dynamic], HasField "ref" ext Ref)++data PlaceHolder = PlaceHolder Text++data OpaqueNode = OpaqueNode Text++hasPlaceholder ::+    (DotGraphExt ext) =>+    ext ->+    Bool+hasPlaceholder e =+    not $ null $ Maybe.catMaybes $ map (fromDynamic @PlaceHolder) e.dynamics++hasOpaqueNode ::+    (DotGraphExt ext) =>+    ext ->+    Bool+hasOpaqueNode e =+    not $ null $ Maybe.catMaybes $ map (fromDynamic @OpaqueNode) e.dynamics++dotNode :: (DotGraphExt ext) => Node ext -> Text+dotNode Nothing = ""+dotNode (Just (ref, name, ext))+    | hasOpaqueNode ext = mconcat [unRef ref, "[color=darkgreen;shape=egg;label=\"", dotEscape name, "\"];"]+    | hasPlaceholder ext = mconcat [unRef ref, "[color=grey;label=\"", dotEscape name, "\"];"]+    | otherwise = mconcat [unRef ref, "[label=\"", dotEscape name, "\"];"]++dotEdge :: Edge -> Text+dotEdge e =+    let (ref1, ref2) = e.rawEdge+     in case e.connection of+            (OV, _) -> mconcat [unRef ref1, "->", unRef ref2]+            (CL, _) -> mconcat [unRef ref1, "->", unRef ref2, "[color=red]"]+            (CR, C) -> mconcat [unRef ref1, "->", unRef ref2, "[color=orange]"]+            (CR, O) -> mconcat [unRef ref1, "->", unRef ref2, "[color=gray]"]+            (CR, V) -> mconcat [unRef ref1, "->", unRef ref2]++dotEscape :: Text -> Text+dotEscape = id++sameNode :: Node a -> Node a -> Bool+sameNode n1 n2 = Maybe.fromMaybe False $ do+    (l, _, _) <- n1+    (r, _, _) <- n2+    pure $ l == r++sameEdge :: Edge -> Edge -> Bool+sameEdge e1 e2 = e1.rawEdge == e2.rawEdge++-------------------------------------------------------------------------------++evalEdges ::+    forall m ext.+    (DotGraphExt ext) =>+    Cofree Graph (OpGraph m (Actions ext)) ->+    [Edge]+evalEdges = foldWithContext Nothing onNode nextCtx . fmap node+  where+    onNode :: Maybe (PrevConnectType, ext) -> Shape -> Actions ext -> [Edge]+    onNode prev shape a =+        [Edge (ct, curOf shape) (l.ref, r.ref) | r <- toList a, (ct, l) <- toList prev]++    curOf :: Shape -> CurConnectType+    curOf SVertices = V+    curOf SOverlay = O+    curOf SConnect = C++    nextCtx :: Maybe (PrevConnectType, ext) -> Branch -> Actions ext -> Maybe (PrevConnectType, ext)+    nextCtx prev branch a = case a of+        Actionless -> prev+        Actions (Act _ ext) -> Just (branchToPrevCT branch, ext)++    branchToPrevCT :: Branch -> PrevConnectType+    branchToPrevCT FromVertices = OV+    branchToPrevCT FromOverlayL = OV+    branchToPrevCT FromOverlayR = OV+    branchToPrevCT FromConnectL = CL+    branchToPrevCT FromConnectR = CR++-------------------------------------------------------------------------------++evalNodes ::+    (DotGraphExt ext) =>+    Cofree Graph (OpGraph m (Actions ext)) ->+    Cofree Graph (Node ext)+evalNodes = fmap (\x -> mkNode x.node)++mkNode ::+    (DotGraphExt ext) =>+    Actions ext ->+    Node ext+mkNode x =+    case x of+        Actionless ->+            Nothing+        (Actions act) ->+            Just (act.extension.ref, act.shorthand, act.extension)++-------------------------------------------------------------------------------++printDigraph ::+    forall m ext.+    ( Monad m+    , DotGraphExt ext+    ) =>+    (forall a. m a -> IO a) ->+    OpGraph m (Actions ext) ->+    IO ()+printDigraph nat graph = do+    printCograph =<< nat (expand graph)++printCograph ::+    forall m ext.+    ( Monad m+    , DotGraphExt ext+    ) =>+    Cofree Graph (OpGraph m (Actions ext)) ->+    IO ()+printCograph gr1 = do+    let nodes = fmap dotNode $ List.nubBy sameNode $ toList $ evalNodes gr1+    let edges = fmap dotEdge $ List.nubBy sameEdge $ evalEdges gr1+    putStrLn "digraph {"+    putStrLn "rankdir=LR;"+    traverse_ Text.putStrLn $ nodes+    traverse_ Text.putStrLn $ edges+    putStrLn "}"++{- | (R4) 'printCograph' for a folded, and possibly rewritten, 'Dag' rather+than the declared @Cofree Graph@ — what @run dag@ prints once any+"Salmon.Op.Rewrite" phases are registered, so a batch is one node in the+picture rather than however many nodes it replaced.++A 'Dag' has already collapsed 'Connect'\/'Overlay' into plain dependency+edges, so the red\/orange\/gray distinction 'printCograph' draws from+'Salmon.Op.GraphFold.Shape' has nothing left to key off — every edge here is+"depends on", drawn the same way 'OV' edges always were.+-}+printDagCograph ::+    forall ext.+    (DotGraphExt ext) =>+    Dag ext ->+    IO ()+printDagCograph dag = do+    let nodes = fmap dotNode [mkDagNode aref act | (aref, act) <- Map.toList (Dag.dagNodes dag)]+    let edges =+            [ dotEdge (Edge (OV, V) (dref, aref))+            | aref <- Dag.dagOrder dag+            , dref <- Dag.dependenciesOf dag aref+            ]+    putStrLn "digraph {"+    putStrLn "rankdir=LR;"+    traverse_ Text.putStrLn $ nodes+    traverse_ Text.putStrLn $ edges+    putStrLn "}"+  where+    mkDagNode :: Ref -> Act ext -> Node ext+    mkDagNode aref act = Just (aref, act.shorthand, act.extension)
+ src/Salmon/Actions/Fleet.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | The fleet fold (milestone 5 of @specs/pull-mode.md@): what+@salmon-fleet status DIR@ computes over a directory of status sink+documents ("Salmon.Actions.Serve.StatusSink"), one per host.++Fleet status is a fold over the documents the hosts wrote, computed by+whoever reads the directory — this module, a script, a web page — and not+by a running service: the directory is the only shared thing, and it is a+dumb one. The fold is pure ('fold') over what 'readStatusDir' found, so+that it is testable without a host, and the binary in @salmon-apps@ is a+thin command line over the two.++What a row says about a host: its name and mode, the document each of its+labels last applied (id and digest), how many of its nodes have converged+and how many are errored out of how many, and how long ago it wrote —+flagged 'rowStale' past a threshold. A stale host is a /visible fact/, not+a decision: nothing here decides a host is dead (see the spec's "what this+does not solve"), it only says nobody has heard from it lately.+-}+module Salmon.Actions.Fleet (+    -- * Reading a directory+    readStatusDir,++    -- * The fold+    Options (..),+    defaultOptions,+    Row (..),+    fold,+    rowOf,+    nodeCounts,++    -- * Rendering+    renderRow,+    renderHeader,+    rowValue,+) where++import Control.Exception (SomeException, try)+import Data.Aeson (ToJSON (..), Value (..), eitherDecode, object, (.=))+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Lazy as LByteString+import Data.List (isSuffixOf, sortOn)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)+import System.Directory (listDirectory)+import System.FilePath ((</>))++import Salmon.Actions.Serve (AppliedDocument (..))+import Salmon.Actions.Serve.StatusSink (Document (..))++-------------------------------------------------------------------------------++{- | Every @*.json@ in the directory, read and parsed: the documents that+are status sink documents, and, by file, why the others are not. A file+that cannot be read at all is in the second list too; nothing is ever+written. -}+readStatusDir :: FilePath -> IO ([(FilePath, Document)], [(FilePath, String)])+readStatusDir dir = do+    names <- filter (".json" `isSuffixOf`) <$> listDirectory dir+    outcomes <- mapM readOne (sortOn id names)+    pure ([(f, d) | (f, Right d) <- outcomes], [(f, e) | (f, Left e) <- outcomes])+  where+    readOne name = do+        let path = dir </> name+        attempt <- try (LByteString.readFile path >>= \b -> LByteString.length b `seq` pure b)+        pure . (,) path $ case attempt of+            Left (ex :: SomeException) -> Left (show ex)+            Right bytes -> eitherDecode bytes++-------------------------------------------------------------------------------++data Options = Options+    { optLabel :: Maybe Text+    -- ^ only hosts carrying this label+    , optStale :: NominalDiffTime+    -- ^ a document written longer ago than this flags its host+    }+    deriving (Show, Eq)++-- | No label filter; stale after a minute.+defaultOptions :: Options+defaultOptions = Options Nothing 60++-- | One host, as the fold reports it.+data Row = Row+    { rowHost :: !Text+    , rowMode :: !Text+    , rowLabels :: [AppliedDocument]+    , rowConverged :: !Int+    , rowErrored :: !Int+    , rowNodes :: !Int+    , rowWritten :: !UTCTime+    , rowAge :: !NominalDiffTime+    -- ^ how long before @now@ the document was written; negative for a+    -- clock ahead of the reader's+    , rowStale :: !Bool+    , rowFile :: !FilePath+    }+    deriving (Show, Eq)++{- | The fold: one row per document, hosts in name order, filtered to the+label asked for, each flagged stale against @now@. Two documents naming+one host (two files, one machine) are two rows: the fold reports what is+there and does not pick. -}+fold :: Options -> UTCTime -> [(FilePath, Document)] -> [Row]+fold opts now docs =+    sortOn (\r -> (r.rowHost, r.rowFile))+        [ row+        | (path, doc) <- docs+        , maybe True (\l -> l `elem` fmap (.appliedDocLabel) doc.docLabels) opts.optLabel+        , let row = rowOf opts now path doc+        ]++rowOf :: Options -> UTCTime -> FilePath -> Document -> Row+rowOf opts now path doc =+    Row+        { rowHost = doc.docHost+        , rowMode = doc.docMode+        , rowLabels = doc.docLabels+        , rowConverged = converged+        , rowErrored = errored+        , rowNodes = total+        , rowWritten = doc.docWritten+        , rowAge = age+        , rowStale = age > opts.optStale+        , rowFile = path+        }+  where+    age = now `diffUTCTime` doc.docWritten+    (converged, errored, total) = nodeCounts doc.docStatus++{- | Converged, errored, total, read off the @status@ object's @nodes@ —+the same objects @status --json@ prints. Anything that is not that shape+counts as no nodes. -}+nodeCounts :: Value -> (Int, Int, Int)+nodeCounts status =+    case status of+        Object o | Just (Array nodes) <- KeyMap.lookup "nodes" o ->+            let convergences = [c | Object n <- foldr (:) [] nodes, Just (String c) <- [KeyMap.lookup "convergence" n]]+             in ( length (filter (== "converged") convergences)+                , length (filter (== "errored") convergences)+                , length convergences+                )+        _ -> (0, 0, 0)++-------------------------------------------------------------------------------++-- | The column names, for the line above 'renderRow's.+renderHeader :: Text+renderHeader = "host\tmode\tlabels\tconverged\terrored\tage\tflags"++{- | One line per host, tab-separated: host, mode, @label=id@sha256[:12]@+per label (comma-separated, @-@ for none), @converged/total@, errored,+the document's age in seconds, and @stale@ or nothing. -}+renderRow :: Row -> Text+renderRow r =+    Text.intercalate+        "\t"+        [ r.rowHost+        , r.rowMode+        , if null r.rowLabels then "-" else Text.intercalate "," (fmap labelText r.rowLabels)+        , Text.pack (show r.rowConverged) <> "/" <> Text.pack (show r.rowNodes)+        , Text.pack (show r.rowErrored)+        , Text.pack (show (round r.rowAge :: Integer)) <> "s"+        , if r.rowStale then "stale" else ""+        ]+  where+    labelText :: AppliedDocument -> Text+    labelText a = a.appliedDocLabel <> "=" <> a.appliedDocId <> "@" <> Text.take 12 a.appliedDocDigest++-- | The row as @--json@ prints it.+rowValue :: Row -> Value+rowValue r =+    object+        [ "host" .= r.rowHost+        , "mode" .= r.rowMode+        , "labels" .= r.rowLabels+        , "converged" .= r.rowConverged+        , "errored" .= r.rowErrored+        , "nodes" .= r.rowNodes+        , "written" .= r.rowWritten+        , "age_s" .= (realToFrac r.rowAge :: Double)+        , "stale" .= r.rowStale+        , "file" .= r.rowFile+        ]++instance ToJSON Row where+    toJSON = rowValue
+ src/Salmon/Actions/Follow.hs view
@@ -0,0 +1,870 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | Pull mode for @run serve@: a 'Producer' that fetches the loop's+declarations from a registry instead of waiting to be typed at.++The unit fetched is a 'Document' — the /desired set/ of seeds for one+'Label', not a log of commands — and a host follows a list of labels, its+desired set being the union of their documents. A 'Registry' is anything that+answers "the latest document for this label"; 'directoryRegistry' is the+first one (and the test harness: write a file, watch the world change).++Three rules are load-bearing, and each is what a naive poller gets wrong.++__Change is detected before anything is injected.__ Every line that reaches+the loop's inbox stands the supervisor's machines down ("Salmon.Actions.Serve"+calls @stopTending@ before any command, by design). A poller that injected on+every round would therefore starve supervision: at a five-second interval no+machine would ever reach its check ceiling and a 'Salmon.Builtin.Extension.managed'+node's watch would be cut every tick. So a round first asks the registry+whether the document /might/ have changed (its 'Stamp': an mtime and size for+a file, an ETag or a commit id later), then compares the bytes' 'Digest'+against the one last applied, and only a document whose digest differs+produces anything at all. An unchanged round is invisible to the loop.++__What is injected is a diff, as one batch.__ Against the document last+applied for that label, not against the world: one @up@ per seed newly+present, one @down@ per seed no longer present /and not in any other+followed label's document/ — the union across labels is computed here,+because the ledger identifies a declaration by its directive and could not+tell one label's copy of a seed from another's. The batch is a single+'Serve.Batch' inbox entry: the loop runs it with @autoconverge@ held off,+restores whatever the operator had set, and converges once. Seeds an+operator typed interactively are never in a document's diff and so are left+alone — unless the operator typed the very same seed a document then drops,+which the ledger cannot tell apart (see the spec's "two operators").++__The fetcher is a named actor in @history@.__ Every declaration it makes+carries a 'Serve.Fetched' origin — registry, label, document id, digest — so+that an operator can tell "I typed this" from "the document said so", which+is the only way to find out why a host did something surprising.++__When__ a round runs, and when what it found is injected, is the+scheduler's ("Salmon.Actions.Follow.Scheduler"): a ladder with jitter toward+the registry (a failed round backs off, a successful one — changed or not —+polls at the base), and a quiet window toward the loop (a change waits for+the registry to stop changing, or for @max_wait@, and three documents seen+inside one window are one diff and one convergence pass). The first round+at startup is the exception: synchronous, injected at once, so that the+first convergence is as deterministic as a piped script's. The loop's+@fetch@ command pokes the scheduler through a 'Scheduler.Poke': a round now,+the ladder forgotten, whatever is pending injected the moment the round is+over.++__The last applied document survives a restart__ (milestone 4 of+@specs/pull-mode.md@), if a 'followCache' directory is given: after every+injection the document each label just applied is written there, bytes,+digest and id, atomically (a temp file and a rename, so a crash mid-write+leaves the previous one). At startup, a label whose registry cannot be+reached — the fetch threw, or the bytes it returned do not parse — is+applied from its cached document instead, reported 'Replayed', and the loop+is in 'Serve.Replay' mode: the world is the last thing this host knew, not+necessarily what the registry says now. The mode turns to+'Serve.Following' at the first later round in which every label answers,+changed or not. The cached document is compared by digest exactly as a+previously applied one is, so a registry that comes back with the same+document injects nothing — the starvation rule holds across restarts.+'Serve.Replay' is only ever /entered/ at startup, and the reason is what the+cache stands in for: a world, not a round. Before the first round there is+no world at all, and coming up empty would tear nothing down, look converged+and be wrong; the cache is the better answer to that. After a successful+round the world already is what the registry last said, and a round failing+later changes nothing about it — the last good document stays in force+(the spec's rule for a document that fails verification, applied here too),+and the scheduler's 'Backoff' is what says the registry is unreachable. A+cache that cannot be read is reported ('BadCache') and ignored, one that+cannot be written likewise ('CacheFailed'): the cache never takes the loop+down. Without a cache directory nothing is cached and a host that starts+against an unreachable registry declares nothing, as it did before.++__Ordered ids__, the spec's open question, are settled the way it leaned: a+document may carry a @published@ RFC 3339 timestamp at its top level, and+with 'followRefuseOlder' a fetched document published /before/ the one this+label already applied (or has pending) is reported 'Stale' and not injected+— what a registry serving from a lagging replica would otherwise do to a+host. Off by default, and without a @published@ on both sides the latest+document is whatever the registry says.++__A document is verified before it is parsed__, by 'followVerify': a+function of the raw bytes and their digest, run on everything that would+otherwise reach the loop — a fetched document from any registry, and a+cached one on replay, since a cache file is as writable as a registry file.+A 'Left' is reported 'Rejected' with its reason, is a failed round, and the+bytes are neither injected nor cached; the last good document stays in+force. A 'Right' is /the bytes to parse/: 'noVerifier', the default and+what runs without a @--follow-key@, hands back what it was given, and+"Salmon.Actions.Follow.Signature"'s @signedVerifier@ hands back the document+it unwrapped from a signed envelope. The digest kept everywhere here — the+one compared for change, reported, recorded in @history@ and written beside+the cache entry — is that of the bytes /as fetched/, envelope included: the+cache keeps those same bytes so that a replay goes through the verifier+exactly as a fetch did.++The status sink ("Salmon.Actions.Serve.StatusSink") reads this module's+reports and the per-label 'Applied' cell ('appliedDocuments') and writes+nothing here. The registries beyond the directory are in+"Salmon.Actions.Follow.Registry", the signature scheme in+"Salmon.Actions.Follow.Signature".+-}+module Salmon.Actions.Follow (+    -- * Documents+    Document (..),+    Entry (..),+    formatVersion,+    entryCommand,++    -- * Labels and registries+    Label,+    mkLabel,+    labelText,+    Stamp (..),+    Digest (..),+    Fetch (..),+    Registry (..),+    directoryRegistry,+    documentPath,+    digestOf,++    -- * The cache+    Cached (..),+    cachePath,+    readCache,+    readCacheEntry,+    writeCache,++    -- * Following+    Follow (..),+    Verifier,+    noVerifier,+    follower,+    followerWith,+    gated,+    newMode,+    newApplied,+    followed,+    appliedDocuments,+    Applied (..),+    diffBatch,++    -- * Reporting+    Report (..),+    reportText,+    renderReport,+) where++import Control.Concurrent.MVar (MVar, readMVar)+import Control.Concurrent.STM (TChan, atomically, writeTChan)+import Control.Exception (SomeException, try)+import Control.Monad (forM, forM_, unless, when)+import Data.Aeson (FromJSON (..), ToJSON (..), Value, eitherDecode, encode, object, withObject, (.:), (.:?), (.=))+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as LByteString+import Data.Char (isAlphaNum)+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, maybeToList)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.IO as Text+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (getPOSIXTime)+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getFileSize, getModificationTime, renameFile)+import System.FilePath ((<.>), (</>))+import System.IO (hFlush, stdout)++import qualified Salmon.Actions.Follow.Scheduler as Scheduler+import qualified Salmon.Actions.Query as Query+import qualified Salmon.Actions.Serve as Serve+import Salmon.Actions.Serve (Declaration (..), Line (..), Origin (..), Producer (..), Provenance (..), ServeCommand (..))+import Salmon.Reporter++-------------------------------------------------------------------------------+-- documents++{- | One seed of a document: either the words that would follow @config@ on+the command line (what @up@ takes), or a directive's JSON (what+@up-directive@ takes from a file). Two entries are the same seed iff they are+equal here, spelling included — the ledger's finer notion (equal directives)+is applied once the loop configures them.+-}+data Entry+    = -- | @{"seed": ["app", "--version", "42"]}@+      SeedWords [String]+    | -- | @{"directive": {...}}@+      SeedDirective Value+    deriving (Show, Eq)++instance FromJSON Entry where+    parseJSON = withObject "seed entry" $ \o -> do+        ws <- o .:? "seed"+        dv <- o .:? "directive"+        case (ws, dv) of+            (Just w, Nothing) -> pure (SeedWords w)+            (Nothing, Just d) -> pure (SeedDirective d)+            (Nothing, Nothing) -> fail "a seed entry needs a `seed` (words) or a `directive` (JSON)"+            (Just _, Just _) -> fail "a seed entry has either a `seed` or a `directive`, not both"++instance ToJSON Entry where+    toJSON (SeedWords ws) = object ["seed" .= ws]+    toJSON (SeedDirective d) = object ["directive" .= d]++{- | The fetched thing. @salmon@ is 'formatVersion' and must be exactly that;+@id@ is opaque, the publisher's own name for this revision, and is what+@history@ records; @published@ is optional, an RFC 3339 timestamp, and is+only ever compared under 'followRefuseOlder'; anything else at the top level+is ignored so a publisher can annotate.+-}+data Document = Document+    { docId :: Text+    , docSeeds :: [Entry]+    , docPublished :: Maybe UTCTime+    }+    deriving (Show, Eq)++-- | The one value of @salmon@ this reader understands.+formatVersion :: Int+formatVersion = 1++instance FromJSON Document where+    parseJSON = withObject "salmon document" $ \o -> do+        v <- o .: "salmon"+        unless (v == formatVersion) $+            fail ("unsupported document format: salmon=" <> show v <> " (this reader understands " <> show formatVersion <> ")")+        Document <$> o .: "id" <*> o .: "seeds" <*> o .:? "published"++instance ToJSON Document where+    toJSON d =+        object $+            ["salmon" .= formatVersion, "id" .= d.docId, "seeds" .= d.docSeeds]+                ++ ["published" .= p | p <- maybeToList d.docPublished]++-- | The loop command that declares an entry in the given direction.+entryCommand :: Declaration -> Label -> Entry -> ServeCommand+entryCommand decl _ (SeedWords ws) = Declare decl ws+entryCommand decl lbl (SeedDirective v) = DeclareInline decl (labelText lbl) v++-------------------------------------------------------------------------------+-- labels and registries++{- | An address into a registry: "the latest document for @web-api@". A+label is spliced into a path, a URL or a DNS name by the registry backend, so+its alphabet is restricted to what every backend can carry safely — letters,+digits, @.@, @_@, @-@, @\@@ — and it may not start with a dot, which for the+directory backend is what keeps @..@ from escaping the directory.+-}+newtype Label = Label Text+    deriving (Show, Eq, Ord)++mkLabel :: Text -> Either Text Label+mkLabel t+    | Text.null t = Left "a label cannot be empty"+    | Text.isPrefixOf "." t = Left ("a label cannot start with a dot: " <> t)+    | Text.all allowed t = Right (Label t)+    | otherwise = Left ("a label may only contain letters, digits, `.`, `_`, `-` and `@`: " <> t)+  where+    allowed c = isAlphaNum c || c `elem` ("._-@" :: String)++labelText :: Label -> Text+labelText (Label t) = t++{- | The registry's own cheap "has it moved?" token for a document: an+mtime and size for a file, later an ETag, a commit id or an object+generation. Opaque to the fetcher, which only ever hands the last one back+and compares digests when the registry says it may have changed. A stamp is+a shortcut, not the decision: two writes inside one timestamp tick are why+the digest is compared as well.+-}+newtype Stamp = Stamp Text+    deriving (Show, Eq)++-- | Hex-encoded SHA-256 of a document's bytes, exactly as fetched.+newtype Digest = Digest {unDigest :: Text}+    deriving (Show, Eq)++digestOf :: ByteString -> Digest+digestOf = Digest . Query.digestBytes++-- | What a registry answers when asked for a label, given the stamp of what+-- the fetcher last saw for it.+data Fetch+    = -- | no document for this label+      Absent+    | -- | the stamp still matches: nothing read, nothing to compare+      Unchanged+    | -- | the bytes, their digest, and the stamp to hand back next time+      Found !Stamp !Digest !ByteString+    deriving (Show, Eq)++{- | Anything that answers "latest document for @label@". The backend owns+the template that turns a label into an address, and the meaning of its+'Stamp'.+-}+data Registry = Registry+    { registryName :: Text+    -- ^ how @history@ and reports name it: a directory path, a URL, a repo+    , registryFetch :: Label -> Maybe Stamp -> IO Fetch+    -- ^ may throw; the fetcher contains that and reports it+    }++-- | Where 'directoryRegistry' looks for a label: @\<dir\>/\<label\>.json@.+documentPath :: FilePath -> Label -> FilePath+documentPath dir (Label t) = dir </> Text.unpack t <.> "json"++{- | A directory with one file per label, named by 'documentPath'. Its stamp+is the file's modification time and size; a file whose stamp matches the one+handed back is not even read. The directory itself missing is the registry+being unreachable — a throw, the same as a host a URL points at not+answering — and not a label with no document: the difference is what+decides whether a cached document is replayed at startup.+-}+directoryRegistry :: FilePath -> Registry+directoryRegistry dir = Registry (Text.pack dir) fetch+  where+    fetch lbl previous = do+        there <- doesDirectoryExist dir+        unless there $+            ioError (userError ("registry directory does not exist: " <> dir))+        let path = documentPath dir lbl+        present <- doesFileExist path+        if not present+            then pure Absent+            else do+                mtime <- getModificationTime path+                size <- getFileSize path+                let stamp = Stamp (Text.pack (show mtime <> " " <> show size))+                if Just stamp == previous+                    then pure Unchanged+                    else do+                        bytes <- LByteString.readFile path+                        -- forced now: a lazy read holds the handle open, and a+                        -- rewrite under it is precisely the case this is for.+                        let digest = digestOf bytes+                        LByteString.length bytes `seq` pure (Found stamp digest bytes)++-------------------------------------------------------------------------------+-- the cache++{- | What the cache keeps per label: the applied document's bytes exactly as+fetched (so that the digest, kept beside them, is the one a later fetch is+compared against), and its id for the report that replays it. On disk as+@{"salmon-cache": 1, "id": ..., "sha256": ..., "document": ...}@, the bytes+as one JSON string.+-}+data Cached = Cached+    { cachedId :: !Text+    , cachedDigest :: !Digest+    , cachedBytes :: !ByteString+    }+    deriving (Show, Eq)++cacheFormatVersion :: Int+cacheFormatVersion = 1++instance FromJSON Cached where+    parseJSON = withObject "salmon cache entry" $ \o -> do+        v <- o .: "salmon-cache"+        unless (v == cacheFormatVersion) $+            fail ("unsupported cache format: salmon-cache=" <> show v)+        Cached+            <$> o .: "id"+            <*> (Digest <$> o .: "sha256")+            <*> (LByteString.fromStrict . Text.encodeUtf8 <$> o .: "document")++instance ToJSON Cached where+    toJSON c =+        object+            [ "salmon-cache" .= cacheFormatVersion+            , "id" .= c.cachedId+            , "sha256" .= c.cachedDigest.unDigest+            , "document" .= Text.decodeUtf8Lenient (LByteString.toStrict c.cachedBytes)+            ]++{- | The cache's file for a label: @\<dir\>/\<label\>.applied.json@. Not+'documentPath''s name, so that a cache directory pointed at a registry+directory by mistake overwrites nothing the registry serves.+-}+cachePath :: FilePath -> Label -> FilePath+cachePath dir (Label t) = dir </> Text.unpack t <.> "applied" <.> "json"++{- | The cached entry for a label, its digest checked against the bytes:+'Nothing' when there is none, a reason when there is one that cannot be+used. The bytes are as fetched, so what they parse as depends on the+verifier — see 'readCache' for the unsigned reading. Never throws.+-}+readCacheEntry :: FilePath -> Label -> IO (Either Text (Maybe Cached))+readCacheEntry dir lbl = do+    let path = cachePath dir lbl+    present <- doesFileExist path+    if not present+        then pure (Right Nothing)+        else do+            attempt <- try (LByteString.readFile path >>= \b -> LByteString.length b `seq` pure b)+            pure $ case attempt of+                Left (ex :: SomeException) -> Left (Text.pack (show ex))+                Right bytes -> case eitherDecode bytes of+                    Left err -> Left (Text.pack err)+                    Right c+                        | digestOf c.cachedBytes /= c.cachedDigest -> Left "the cached bytes do not hash to the digest kept beside them"+                        | otherwise -> Right (Just c)++{- | 'readCacheEntry', with the bytes parsed as the 'Document' they hold+directly — the reading for a cache written under 'noVerifier'. A cache+written under a verifier that unwraps (a signed envelope) parses only+through that verifier, which is how 'follower' reads it.+-}+readCache :: FilePath -> Label -> IO (Either Text (Maybe (Cached, Document)))+readCache dir lbl = do+    entry <- readCacheEntry dir lbl+    pure $ case entry of+        Left err -> Left err+        Right Nothing -> Right Nothing+        Right (Just c) -> case eitherDecode c.cachedBytes of+            Left err -> Left ("the cached document does not parse: " <> Text.pack err)+            Right doc -> Right (Just (c, doc))++{- | Write a label's cache entry: to a temporary file beside it, then+renamed over it, so that a crash mid-write leaves the previous entry rather+than half of this one. May throw; the caller reports and moves on.+-}+writeCache :: FilePath -> Label -> Cached -> IO ()+writeCache dir lbl c = do+    createDirectoryIfMissing True dir+    let path = cachePath dir lbl+        tmp = path <.> "tmp"+    LByteString.writeFile tmp (encode c)+    renameFile tmp path++-------------------------------------------------------------------------------+-- following++data Follow = Follow+    { followRegistry :: Registry+    , followLabels :: [Label]+    , followSchedule :: Scheduler.Config+    -- ^ the ladder toward the registry and the window toward the loop+    , followCache :: Maybe FilePath+    -- ^ where each label's last applied document is kept across restarts;+    -- 'Nothing' keeps none+    , followRefuseOlder :: Bool+    -- ^ refuse a document whose @published@ is older than the one already+    -- applied or pending for its label+    , followVerify :: Verifier+    -- ^ run on the raw bytes of every document before it is parsed, cache+    -- replay included; 'noVerifier' accepts everything+    }++{- | The verify-before-inject hook: the label the bytes were fetched *for*,+the digest and the bytes exactly as fetched; a reason to refuse them, or the+bytes the loop is to parse as the 'Document' — the same ones for a verifier+that only checks, the unwrapped document for one that strips a signed+envelope. It may throw, which is a refusal with the exception's text.++The label is an argument because a document is only worth applying at the+address it was signed for: a verifier that is not told which label it is+looking at cannot tell a @canary@ document that is validly signed from the+same bytes served at @prod@'s address. -}+type Verifier = Label -> Digest -> ByteString -> IO (Either Text ByteString)++-- | Accepts everything as it is: the default, and unsigned mode.+noVerifier :: Verifier+noVerifier _ _ bytes = pure (Right bytes)++-- | 'followVerify' with a throw contained as a refusal.+verify :: Follow -> Label -> Digest -> ByteString -> IO (Either Text ByteString)+verify follow lbl digest bytes = do+    outcome <- try (follow.followVerify lbl digest bytes)+    pure $ case outcome of+        Left (ex :: SomeException) -> Left (Text.pack (show ex))+        Right verdict -> verdict++{- | The document last applied for a label: what the next diff is against.+The stamp is 'Nothing' for a document replayed from the cache — a stamp+belongs to the registry, and the cache is not it — so the registry reads+the file once and hands the stamp back from then on. -}+data Applied = Applied+    { appliedStamp :: !(Maybe Stamp)+    , appliedDigest :: !Digest+    , appliedId :: !Text+    , appliedSeeds :: [Entry]+    , appliedPublished :: !(Maybe UTCTime)+    , appliedAt :: !UTCTime+    -- ^ when it was injected (the wall clock), for the status sink+    }+    deriving (Show, Eq)++data Report+    = -- | registry, labels, schedule+      Following !Text ![Label] !Scheduler.Config+    | -- | a changed document was injected: label, id, digest, seeds up, seeds down+      Injected !Label !Text !Digest !Int !Int+    | -- | a changed document whose seed set is the one already applied+      -- (its id or an annotation changed); recorded, nothing injected+      NoDiff !Label !Text !Digest+    | -- | a changed document, seen after startup: it waits for the quiet+      -- window (label, id, digest); what it turns into is the 'Injected'+      -- or 'NoDiff' that follows+      Deferred !Label !Text !Digest+    | -- | a round failed: consecutive failures, microseconds until the next round+      Backoff !Int !Int+    | -- | no document for this label+      Missing !Label+    | -- | the document was applied once and is now gone; what it declared+      -- stays in force+      Vanished !Label+    | -- | the bytes did not parse as a document: label, digest, why+      Malformed !Label !Digest !Text+    | -- | asking the registry threw+      FetchFailed !Label !Text+    | -- | the registry could not be read at startup and the cached+      -- document was applied instead: label, id, digest. The 'Injected'+      -- that follows is its declarations.+      Replayed !Label !Text !Digest+    | -- | under 'followRefuseOlder', a document published before the one+      -- already applied or pending for its label: label, id. Not injected.+      Stale !Label !Text+    | -- | a cache entry that cannot be used: label, why. Ignored.+      BadCache !Label !Text+    | -- | writing a label's cache entry threw: label, why. The document+      -- was injected all the same; only the next restart is affected.+      CacheFailed !Label !Text+    | -- | 'followVerify' refused the bytes: label, digest, why. Not+      -- injected, not cached; a failed round. For a cached document at+      -- startup, not replayed.+      Rejected !Label !Digest !Text+    deriving (Show, Eq)++-- | One write per report, for the same reason as 'Serve.reportText': the+-- loop's own reporter writes to this handle from another thread.+reportText :: Reporter Report+reportText = ReporterM $ \rep -> do+    Text.putStr (Text.unlines (renderReport rep))+    hFlush stdout++renderReport :: Report -> [Text]+renderReport rep =+    case rep of+        Following reg lbls cfg ->+            [ "follow: "+                <> reg+                <> " for "+                <> Text.intercalate ", " (fmap labelText lbls)+                <> " "+                <> Scheduler.renderConfig cfg+            ]+        Injected lbl did dg nup ndown ->+            [ "follow: "+                <> labelText lbl+                <> " id="+                <> did+                <> " sha256="+                <> Text.take 12 dg.unDigest+                <> ": "+                <> Text.pack (show nup)+                <> " seed(s) up, "+                <> Text.pack (show ndown)+                <> " down"+            ]+        NoDiff lbl did dg ->+            ["follow: " <> labelText lbl <> " id=" <> did <> " sha256=" <> Text.take 12 dg.unDigest <> ": same seeds as before, nothing to declare"]+        Deferred lbl did dg ->+            ["follow: " <> labelText lbl <> " id=" <> did <> " sha256=" <> Text.take 12 dg.unDigest <> ": changed, waiting for the registry to go quiet"]+        Backoff n us ->+            ["follow: " <> Text.pack (show n) <> " failed round(s) in a row; next in " <> Text.pack (show (us `div` 1000000)) <> "s"]+        Missing lbl -> ["follow: no document for " <> labelText lbl]+        Vanished lbl -> ["follow: document for " <> labelText lbl <> " is gone; its last declarations stay in force"]+        Malformed lbl dg err -> ("follow: cannot read document for " <> labelText lbl <> " (sha256=" <> Text.take 12 dg.unDigest <> "):") : Text.lines err+        FetchFailed lbl err -> ["follow: fetching " <> labelText lbl <> " failed: " <> err]+        Replayed lbl did dg ->+            ["follow: " <> labelText lbl <> ": registry unreachable; replaying the cached document id=" <> did <> " sha256=" <> Text.take 12 dg.unDigest]+        Stale lbl did ->+            ["follow: " <> labelText lbl <> " id=" <> did <> ": published before the document already applied; refused (--follow-refuse-older)"]+        BadCache lbl err -> ("follow: ignoring the cached document for " <> labelText lbl <> ":") : Text.lines err+        CacheFailed lbl err -> ("follow: could not cache the document for " <> labelText lbl <> ":") : Text.lines err+        Rejected lbl dg err -> ("follow: refusing the document for " <> labelText lbl <> " (sha256=" <> Text.take 12 dg.unDigest <> "):") : Text.lines err++{- | The diff-batch for a label whose document changed: what to declare up+(in the new document, not in the old one) and down (in the old one, not in+the new one, and not in any other label's document either — the union+across labels, taken over what the other labels are /about to/ say when+several are injected together). The old document is 'Nothing' for a label+seen for the first time.+-}+diffBatch :: Label -> Maybe Applied -> [Entry] -> Map Label Applied -> ([Entry], [Entry])+diffBatch lbl previous new others =+    (ups, downs)+  where+    old = maybe [] appliedSeeds previous+    elsewhere = concat [a.appliedSeeds | (l, a) <- Map.toList others, l /= lbl]+    ups = [e | e <- new, e `notElem` old]+    downs = [e | e <- old, e `notElem` new, e `notElem` elsewhere]++{- | The cell the fetcher keeps its 'Serve.Mode' in, made by the caller so+that the loop can be handed a reader of it ('followed') before the producer+runs. Starts 'Serve.Following'; only the startup round can turn it to+'Serve.Replay'. -}+newMode :: IO (IORef Serve.Mode)+newMode = newIORef Serve.Following++{- | The cell the fetcher keeps the document last applied per label in,+made by the caller for the same reason as 'newMode': the status sink reads+it ('appliedDocuments') and the sink is composed before the producer runs.+Starts empty. -}+newApplied :: IO (IORef (Map Label Applied))+newApplied = newIORef Map.empty++-- | The loop's side: what @fetch@ pokes, what @status@ reads, and what+-- the status sink lists per label.+followed :: Scheduler.Poke -> IORef Serve.Mode -> IORef (Map Label Applied) -> Serve.Followed+followed pk mode applied =+    Serve.Followed+        { Serve.followedFetch = Scheduler.poke pk+        , Serve.followedMode = readIORef mode+        , Serve.followedApplied = appliedDocuments applied+        }++-- | The document last applied per label, in label order, as the status+-- sink publishes it.+appliedDocuments :: IORef (Map Label Applied) -> IO [Serve.AppliedDocument]+appliedDocuments applied = do+    m <- readIORef applied+    pure [Serve.AppliedDocument (labelText lbl) a.appliedId a.appliedDigest.unDigest a.appliedAt | (lbl, a) <- Map.toList m]++-- | The producer, on the system clock and seeded from the wall clock (so+-- that two hosts started together draw different jitter). See 'followerWith'.+follower :: Reporter Report -> Scheduler.Poke -> IORef Serve.Mode -> IORef (Map Label Applied) -> Follow -> IO () -> Producer+follower r pk mode applied follow primed = Producer $ \inbox -> do+    seed <- fromIntegral . (`div` 1000) . fromEnum <$> getPOSIXTime+    produceInto (followerWith r (Scheduler.systemClock pk) (Scheduler.mkRng seed) mode applied follow primed) inbox++{- | The producer. One round runs synchronously before the given action+(meant to release the standard-input producer, see 'gated'), and whatever it+found is injected at once — no window: there is nothing to coalesce yet, and+the first convergence is meant to be as deterministic as a piped script's.+A label that round could not read is replayed from the cache, if there is+one for it (see the module's summary for why only this round is). Rounds+then run on the schedule ("Salmon.Actions.Follow.Scheduler"), on the clock+given: the system's, or a test's. The thread never sends an 'Eof': a+registry that goes quiet is not the loop ending.+-}+followerWith :: Reporter Report -> Scheduler.Clock -> Scheduler.Rng -> IORef Serve.Mode -> IORef (Map Label Applied) -> Follow -> IO () -> Producer+followerWith r clock rng mode applied follow primed = Producer $ \inbox -> do+    runReporter r (Following (registryName follow.followRegistry) follow.followLabels follow.followSchedule)+    st <- Fetcher applied <$> newIORef Map.empty <*> newIORef Set.empty <*> newIORef Map.empty+    cached <- loadCache+    replayed <- forM follow.followLabels $ \lbl -> do+        outcome <- fetchOne r follow st lbl+        case (outcome, Map.lookup lbl cached) of+            (Scheduler.Failed, Just (c, doc)) -> do+                modifyIORef' st.fetcherSeen (Map.insert lbl (Seen Nothing c.cachedDigest doc.docId doc.docSeeds doc.docPublished c.cachedBytes))+                runReporter r (Replayed lbl doc.docId c.cachedDigest)+                pure True+            _ -> pure False+    when (or replayed) $ writeIORef mode Serve.Replay+    injectPending r follow st inbox+    primed+    now <- Scheduler.clockNow clock+    Scheduler.run+        follow.followSchedule+        clock+        Scheduler.Hooks+            { Scheduler.hookFetch = round_ st >>= \o -> deferred st o >> answered o >> pure o+            , Scheduler.hookInject = injectPending r follow st inbox+            , Scheduler.hookBackoff = \n us -> runReporter r (Backoff n us)+            }+        (Scheduler.start follow.followSchedule rng now)+  where+    round_ st = mconcat <$> forM follow.followLabels (fetchOne r follow st)+    -- the changes a scheduled round found are going to wait: say so once+    -- per label, at the round that saw them+    deferred :: Fetcher -> Scheduler.Outcome -> IO ()+    deferred st o =+        when (o == Scheduler.Changed) $ do+            fresh <- atomicModifyIORef' st.fetcherFresh (\s -> (Set.empty, s))+            seen <- readIORef st.fetcherSeen+            forM_ (Set.toList fresh) $ \lbl ->+                forM_ (Map.lookup lbl seen) $ \s -> runReporter r (Deferred lbl s.seenId s.seenDigest)+    -- a round in which every label answered ends a replay: from here on+    -- the world is what the registry says+    answered :: Scheduler.Outcome -> IO ()+    answered o = unless (o == Scheduler.Failed) $ writeIORef mode Serve.Following+    -- every label's cache entry, read once; a bad one is reported and left out+    loadCache :: IO (Map Label (Cached, Document))+    loadCache = case follow.followCache of+        Nothing -> pure Map.empty+        Just dir ->+            fmap (Map.fromList . catMaybes) $+                forM follow.followLabels $ \lbl -> do+                    entry <- readCacheEntry dir lbl+                    case entry of+                        Left err -> runReporter r (BadCache lbl err) >> pure Nothing+                        Right Nothing -> pure Nothing+                        -- verified as a fetched one is, and parsed from+                        -- what the verifier hands back: the cache is as+                        -- writable as the registry+                        Right (Just c) -> do+                            verdict <- verify follow lbl c.cachedDigest c.cachedBytes+                            case verdict of+                                Left why -> runReporter r (Rejected lbl c.cachedDigest why) >> pure Nothing+                                Right inner -> case eitherDecode inner of+                                    Left err -> runReporter r (BadCache lbl ("the cached document does not parse: " <> Text.pack err)) >> pure Nothing+                                    Right doc -> pure (Just (lbl, (c, doc)))++{- | A producer that does not start until the 'MVar' is filled — what puts+standard input behind the fetcher's first round. -}+gated :: MVar () -> Producer -> Producer+gated gate p = Producer $ \inbox -> do+    readMVar gate+    produceInto p inbox++-- | A document seen and not yet applied: the latest for its label. The+-- stamp is 'Nothing' for one replayed from the cache, and the bytes are+-- kept so the cache can be written once it is applied.+data Seen = Seen+    { seenStamp :: !(Maybe Stamp)+    , seenDigest :: !Digest+    , seenId :: !Text+    , seenSeeds :: [Entry]+    , seenPublished :: !(Maybe UTCTime)+    , seenBytes :: !ByteString+    }++-- | What a fetcher carries between rounds.+data Fetcher = Fetcher+    { fetcherApplied :: IORef (Map Label Applied)+    -- ^ per label, the document the loop last heard about+    , fetcherSeen :: IORef (Map Label Seen)+    -- ^ per label, a newer document waiting for its window+    , fetcherFresh :: IORef (Set Label)+    -- ^ labels whose 'Seen' changed since last reported+    , fetcherNoise :: IORef (Map Label Report)+    -- ^ the last complaint per label, so an unchanged one is not repeated+    }++-- | The outcome of a round is the worst of its labels'.+instance Semigroup Scheduler.Outcome where+    Scheduler.Failed <> _ = Scheduler.Failed+    _ <> Scheduler.Failed = Scheduler.Failed+    Scheduler.Changed <> _ = Scheduler.Changed+    _ <> Scheduler.Changed = Scheduler.Changed+    Scheduler.Unchanged <> Scheduler.Unchanged = Scheduler.Unchanged++instance Monoid Scheduler.Outcome where+    mempty = Scheduler.Unchanged++{- | One label's share of a round. Nothing here writes to the inbox: a+document whose digest differs from the last one seen is parsed and set+aside as this label's 'Seen', to be diffed and injected by 'injectPending'+when the scheduler says so. Every other outcome is a report at most — and a+repeated one (a label still missing, a file still malformed) is not even+that, since a report per round about a condition that has not changed is+noise. A registry that throws, bytes the verifier refuses, or bytes that do+not parse, is a 'Failed' round; a label with no document is not (the+registry answered), and neither is a document refused for being 'Stale'.+The verifier runs before the parser and after the digest comparison, so it+sees every document that could reach the loop and nothing that could not. -}+fetchOne :: Reporter Report -> Follow -> Fetcher -> Label -> IO Scheduler.Outcome+fetchOne r follow st lbl = do+    applied <- Map.lookup lbl <$> readIORef st.fetcherApplied+    seen <- Map.lookup lbl <$> readIORef st.fetcherSeen+    -- what was last read, applied or not: the stamp to hand back, the+    -- digest a re-read is compared against, and the publication time a+    -- refused document is older than+    let (lastStamp, lastDigest, lastPublished) = case seen of+            Just s -> (s.seenStamp, Just s.seenDigest, s.seenPublished)+            Nothing -> (appliedStamp =<< applied, appliedDigest <$> applied, appliedPublished =<< applied)+    outcome <- try (registryFetch registry lbl lastStamp) :: IO (Either SomeException Fetch)+    case outcome of+        Left ex -> complain (FetchFailed lbl (Text.pack (show ex))) >> pure Scheduler.Failed+        Right Absent -> complain (maybe (Missing lbl) (const (Vanished lbl)) applied) >> pure Scheduler.Unchanged+        Right Unchanged -> pure Scheduler.Unchanged+        Right (Found stamp digest bytes)+            -- the mtime moved but the bytes did not: the starvation rule.+            -- Remember the new stamp so the file is not re-read every round.+            | Just digest == lastDigest -> do+                case seen of+                    Just s -> modifyIORef' st.fetcherSeen (Map.insert lbl s{seenStamp = Just stamp})+                    Nothing -> modifyIORef' st.fetcherApplied (Map.adjust (\a -> a{appliedStamp = Just stamp}) lbl)+                pure Scheduler.Unchanged+            | otherwise -> do+                -- verified before it is parsed, on the bytes as fetched+                verdict <- verify follow lbl digest bytes+                case verdict of+                    Left why -> complain (Rejected lbl digest why) >> pure Scheduler.Failed+                    Right inner -> case eitherDecode inner :: Either String Document of+                        Left err -> complain (Malformed lbl digest (Text.pack err)) >> pure Scheduler.Failed+                        Right doc+                            | follow.followRefuseOlder+                            , Just newer <- lastPublished+                            , Just published <- doc.docPublished+                            , published < newer ->+                                complain (Stale lbl doc.docId) >> pure Scheduler.Unchanged+                            | otherwise -> do+                                quiet+                                modifyIORef' st.fetcherSeen (Map.insert lbl (Seen (Just stamp) digest doc.docId doc.docSeeds doc.docPublished bytes))+                                modifyIORef' st.fetcherFresh (Set.insert lbl)+                                pure Scheduler.Changed+  where+    registry = follow.followRegistry+    -- report a complaint once per change of complaint, not once per round+    complain rep = do+        last_ <- readIORef st.fetcherNoise+        unless (Map.lookup lbl last_ == Just rep) $ do+            writeIORef st.fetcherNoise (Map.insert lbl rep last_)+            runReporter r rep+    quiet = modifyIORef' st.fetcherNoise (Map.delete lbl)++{- | Inject everything 'Seen' as one batch: per label, the diff against the+document last applied — so three documents seen inside one window amount to+one diff, from the one the loop knows to the latest — and one 'Serve.Batch'+for all of them, each command carrying its own label's provenance. A label+whose latest document turns out to say what was already applied (written+and written back inside the window) is reported 'NoDiff' and adopted+without a declaration. Nothing to inject writes nothing. Each label's+document is then written to the cache, if there is one — after the batch+is in the inbox, since a cache that cannot be written must not hold the+injection back. -}+injectPending :: Reporter Report -> Follow -> Fetcher -> TChan Line -> IO ()+injectPending r follow st inbox = do+    seen <- atomicModifyIORef' st.fetcherSeen (\s -> (Map.empty, s))+    writeIORef st.fetcherFresh Set.empty+    unless (Map.null seen) $ do+        applied <- readIORef st.fetcherApplied+        now <- getCurrentTime+        let adopt :: Seen -> Applied+            adopt s = Applied s.seenStamp s.seenDigest s.seenId s.seenSeeds s.seenPublished now+            -- what every label is about to say: the union the diff is against+            upcoming = Map.union (fmap adopt seen) applied+        let perLabel :: (Label, Seen) -> (Report, [(Origin, ServeCommand)])+            perLabel (lbl, s) =+                let previous = Map.lookup lbl applied+                    (ups, downs) = diffBatch lbl previous s.seenSeeds upcoming+                    origin =+                        Fetched+                            Provenance+                                { provRegistry = registryName follow.followRegistry+                                , provLabel = labelText lbl+                                , provDocument = s.seenId+                                , provDigest = s.seenDigest.unDigest+                                }+                 in if null ups && null downs+                        then (NoDiff lbl s.seenId s.seenDigest, [])+                        else+                            ( Injected lbl s.seenId s.seenDigest (length ups) (length downs)+                            , [(origin, cmd) | cmd <- fmap (entryCommand Add lbl) ups ++ fmap (entryCommand Remove lbl) downs]+                            )+            (reports, cmds) = fmap concat (unzip (fmap perLabel (Map.toList seen)))+        writeIORef st.fetcherApplied upcoming+        unless (null cmds) $+            atomically (writeTChan inbox (Batch cmds))+        forM_ reports (runReporter r)+        forM_ follow.followCache $ \dir ->+            forM_ (Map.toList seen) $ \(lbl, s) -> do+                written <- try (writeCache dir lbl (Cached s.seenId s.seenDigest s.seenBytes))+                case written of+                    Left (ex :: SomeException) -> runReporter r (CacheFailed lbl (Text.pack (show ex)))+                    Right () -> pure ()
+ src/Salmon/Actions/Follow/Registry.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Which registry @--follow@ names, from the shape of its argument+(milestone 6 of @specs/pull-mode.md@). Every backend is a+'Salmon.Actions.Follow.Registry' value owning the template that turns a+label into an address; the fetcher and the scheduler see none of this.++> --follow /srv/reg                          a directory: /srv/reg/<label>.json+> --follow git+https://host/repo#main:hosts  a git branch: hosts/<label>.json at origin/main+> --follow https://host/seed/latest/{label}  HTTP: GET that URL, or <base>/<label>.json without {label}+> --follow dns:fleet.example                 a TXT index at <label>.fleet.example, fetched over HTTP+> --follow s3://bucket/prefix                a bucket, over its plain HTTPS object URLs+> --follow gs://bucket/prefix                likewise, Google's++The bucket backends are the HTTP one under a URL template:+@https://\<bucket\>.s3.amazonaws.com/\<prefix\>/\<label\>.json@,+@https://storage.googleapis.com/\<bucket\>/\<prefix\>/\<label\>.json@, or+path-style under an S3-compatible endpoint given with+@--follow-bucket-endpoint@. That covers a public bucket, or one fronted by+something that signs — no SDK, and __no authenticated access__: a private+bucket answers @403@, which is a failed round and says so.+-}+module Salmon.Actions.Follow.Registry (+    Address (..),+    parseAddress,+    Bucket (..),+    Store (..),+    bucketTemplate,+    Options (..),+    defaultOptions,+    open,+    defaultWorkdir,+) where++import Data.Text (Text)+import qualified Data.Text as Text+import System.Directory (getTemporaryDirectory)+import System.FilePath ((</>))++import Salmon.Actions.Follow (Registry (..), digestOf, directoryRegistry, unDigest)+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 Data.ByteString.Lazy.Char8 as LChar8++-- | What @--follow@ can name.+data Address+    = Directory FilePath+    | Git Git.Source+    | Http Text+    | Dns Text+    | InBucket Bucket+    deriving (Show, Eq)++data Store = S3 | Gcs+    deriving (Show, Eq)++-- | @s3://bucket/prefix@ or @gs://bucket/prefix@; the prefix may be empty.+data Bucket = Bucket+    { bucketStore :: Store+    , bucketName :: Text+    , bucketPrefix :: Text+    }+    deriving (Show, Eq)++-- | By shape; anything with no recognised scheme is a directory path.+parseAddress :: Text -> Either Text Address+parseAddress t+    | Just rest <- Text.stripPrefix "git+" t = Git <$> Git.parseSource rest+    | Text.isPrefixOf "http://" t || Text.isPrefixOf "https://" t = Right (Http t)+    | Just zone <- Text.stripPrefix "dns:" t =+        if Text.null zone then Left "dns: needs a zone" else Right (Dns zone)+    | Just rest <- Text.stripPrefix "s3://" t = InBucket <$> bucket S3 rest+    | Just rest <- Text.stripPrefix "gs://" t = InBucket <$> bucket Gcs rest+    | Text.null t = Left "--follow needs a registry"+    | otherwise = Right (Directory (Text.unpack t))+  where+    bucket store rest =+        let (name, prefix) = Text.breakOn "/" rest+         in if Text.null name+                then Left ("a bucket address needs a bucket name: " <> t)+                else Right (Bucket store name (Text.dropWhileEnd (== '/') (Text.drop 1 prefix)))++{- | The bucket's HTTPS base URL, which "Salmon.Actions.Follow.Registry.Http"+then appends @/\<label\>.json@ to. Virtual-hosted for S3 proper, path-style+under an endpoint (what MinIO and friends expect) and for GCS. -}+bucketTemplate :: Maybe Text -> Bucket -> Text+bucketTemplate endpoint b =+    Text.dropWhileEnd (== '/') base <> (if Text.null b.bucketPrefix then "" else "/" <> b.bucketPrefix)+  where+    base = case (endpoint, b.bucketStore) of+        (Just e, _) -> Text.dropWhileEnd (== '/') e <> "/" <> b.bucketName+        (Nothing, S3) -> "https://" <> b.bucketName <> ".s3.amazonaws.com"+        (Nothing, Gcs) -> "https://storage.googleapis.com/" <> b.bucketName++-- | What the backends need beyond their address.+data Options = Options+    { optHttp :: Http.Options+    , optWorkdir :: Maybe FilePath+    -- ^ the git checkout; 'defaultWorkdir' when 'Nothing'+    , optCacheDir :: Maybe FilePath+    -- ^ @--follow-cache@, which the default checkout lives under+    , optBucketEndpoint :: Maybe Text+    -- ^ an S3-compatible endpoint, path-style+    , optResolver :: Dns.Resolver+    }++defaultOptions :: Options+defaultOptions = Options Http.defaultOptions Nothing Nothing Nothing Dns.digResolver++{- | Where a git registry is checked out when nobody said: @checkout@ under+the cache directory (the one place a follower already keeps state across+restarts), else a directory under the system's temporary one named by the+repository, so that two followers of different repositories on one machine+do not share a checkout. -}+defaultWorkdir :: Maybe FilePath -> Git.Source -> IO FilePath+defaultWorkdir (Just cache) _ = pure (cache </> "checkout")+defaultWorkdir Nothing source = do+    tmp <- getTemporaryDirectory+    pure (tmp </> ("salmon-follow-" <> Text.unpack (Text.take 12 (unDigest (digestOf (LChar8.pack (Text.unpack (Git.renderSource source))))))))++-- | The registry for an address.+open :: Options -> Address -> IO Registry+open o addr = case addr of+    Directory dir -> pure (directoryRegistry dir)+    Git source -> do+        workdir <- maybe (defaultWorkdir o.optCacheDir source) pure o.optWorkdir+        Git.gitRegistry workdir source+    Http template -> do+        mgr <- Http.newManager o.optHttp+        pure (Http.httpRegistry mgr template)+    Dns zone -> do+        mgr <- Http.newManager o.optHttp+        pure (Dns.dnsRegistry o.optResolver mgr zone)+    InBucket b -> do+        mgr <- Http.newManager o.optHttp+        let reg = Http.httpRegistry mgr (bucketTemplate o.optBucketEndpoint b)+        pure reg{registryName = renderBucket b}++-- | The address back, as given: what @history@ and reports name.+renderBucket :: Bucket -> Text+renderBucket b = (case b.bucketStore of S3 -> "s3://"; Gcs -> "gs://") <> b.bucketName <> (if Text.null b.bucketPrefix then "" else "/" <> b.bucketPrefix)
+ src/Salmon/Actions/Follow/Registry/Dns.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE OverloadedStrings #-}++{- | The DNS-index registry for "Salmon.Actions.Follow": DNS is the+registry's /index/, HTTP its /storage/ (the spec's recommended shape).++@--follow dns:\<zone\>@ names it. The document for label @L@ is announced by+one @TXT@ record at @\<L\>.\<zone\>@ reading++> v=salmon1 url=<https url> sha256=<hex digest of the document's bytes>++and that record's digest is the stamp: a round is one DNS lookup, and the+URL is fetched only when the digest the record carries is not the one last+seen — one UDP round-trip, cached by the record's TTL, and no connection to+the store at all while nothing changes. The body that comes back is hashed+and compared with the record; a mismatch throws 'IndexMismatch' and is a+failed round with that reason, never applied, because a store serving+something other than what the index announces is either mid-publish or+somebody else's, and neither is a document. No record is 'Absent'; the+lookup failing (no resolver reachable, a @SERVFAIL@) throws.++The resolver is a 'Resolver' — a name and one function — so that a test can+answer lookups itself. The one shipped, 'digResolver', shells out to+@dig +short@ through "Salmon.Builtin.Nodes.Binary" like every other binary+this tree drives: nothing in the tree resolves DNS today, and one @TXT@+lookup was not worth a resolver library's dependency footprint.+-}+module Salmon.Actions.Follow.Registry.Dns (+    Resolver (..),+    digResolver,+    parseDigTxt,+    IndexRecord (..),+    parseIndexRecord,+    recordName,+    dnsRegistry,+    IndexMismatch (..),+) where++import Control.Exception (Exception, throwIO)+import Data.Either (partitionEithers)+import qualified Data.Text as Text+import Data.Text (Text)+import qualified Data.Text.Encoding as Text+import Network.HTTP.Client (Manager)+import System.Process.ListLike (proc)++import Salmon.Actions.Follow (Digest (..), Fetch (..), Label, Registry (..), Stamp (..), labelText)+import Salmon.Actions.Follow.Registry.Http (fetchUrl)+import Salmon.Builtin.Nodes.Binary (Command (..))+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Reporter (silent)++-- | Who answers a @TXT@ lookup: every record's strings already joined,+-- one 'Text' per record; @[]@ for a name with none. May throw.+data Resolver = Resolver+    { resolverName :: Text+    , resolveTxt :: Text -> IO [Text]+    }++-- | @dig +short TXT \<name\>@; a non-zero exit (no server reachable) throws.+digResolver :: Resolver+digResolver =+    Resolver+        { resolverName = "dig"+        , resolveTxt = \name -> do+            out <- Binary.untrackedExecOutput dig ["+short", "TXT", Text.unpack name] "" silent+            pure (parseDigTxt (Text.decodeUtf8Lenient out))+        }+  where+    dig = Command (\args -> proc "dig" args)++{- | @dig +short@ prints one record per line as its quoted strings —+@"v=salmon1 url=..." "sha256=..."@ for a record longer than one string —+and the odd @;;@ comment on the way to a non-zero exit. Each line's strings+are unescaped and joined, as the @TXT@ RFC says a reader should.+-}+parseDigTxt :: Text -> [Text]+parseDigTxt = map (Text.concat . strings . Text.unpack) . filter (not . Text.isPrefixOf ";") . filter (not . Text.null) . Text.lines+  where+    strings :: String -> [Text]+    strings s = case dropWhile (/= '"') s of+        [] -> []+        (_ : rest) -> let (str, more) = quoted rest in Text.pack str : strings more+    quoted :: String -> (String, String)+    quoted ('\\' : c : rest) = let (s, more) = quoted rest in (c : s, more)+    quoted ('"' : rest) = ([], rest)+    quoted (c : rest) = let (s, more) = quoted rest in (c : s, more)+    quoted [] = ([], [])++-- | What a @v=salmon1@ record announces.+data IndexRecord = IndexRecord+    { indexUrl :: Text+    , indexDigest :: Digest+    }+    deriving (Show, Eq)++-- | @v=salmon1 url=... sha256=...@, whitespace-separated, in any order after+-- the version; a record for some other version, or one missing either+-- field, is a 'Left' naming what is missing.+parseIndexRecord :: Text -> Either Text IndexRecord+parseIndexRecord txt =+    case Text.words txt of+        ("v=salmon1" : fields) ->+            let pairs = [(k, Text.drop 1 v) | f <- fields, let (k, v) = Text.breakOn "=" f]+             in case (lookup "url" pairs, lookup "sha256" pairs) of+                    (Just url, Just hex)+                        | Text.length hex == 64 && Text.all isHex hex -> Right (IndexRecord url (Digest (Text.toLower hex)))+                        | otherwise -> Left ("sha256= is not a hex sha256 digest: " <> hex)+                    (Nothing, _) -> Left "no url= in the record"+                    (_, Nothing) -> Left "no sha256= in the record"+        _ -> Left ("not a v=salmon1 record: " <> txt)+  where+    isHex c = c `elem` ("0123456789abcdefABCDEF" :: String)++-- | The name looked up for a label: @\<label\>.\<zone\>@.+recordName :: Text -> Label -> Text+recordName zone lbl = labelText lbl <> "." <> Text.dropWhileEnd (== '.') zone++-- | The index said one thing and the store served another.+data IndexMismatch = IndexMismatch+    { mismatchName :: Text+    , mismatchUrl :: Text+    , mismatchAnnounced :: Digest+    , mismatchServed :: Digest+    }++instance Show IndexMismatch where+    show m =+        Text.unpack $+            "the document at "+                <> m.mismatchUrl+                <> " does not hash to what the index record "+                <> m.mismatchName+                <> " announces (record: sha256="+                <> Text.take 12 m.mismatchAnnounced.unDigest+                <> ", served: sha256="+                <> Text.take 12 m.mismatchServed.unDigest+                <> ")"++instance Exception IndexMismatch++-- | A registry over a zone, named @dns:\<zone\>@.+dnsRegistry :: Resolver -> Manager -> Text -> Registry+dnsRegistry resolver mgr zone =+    Registry+        { registryName = "dns:" <> zone+        , registryFetch = \lbl previous -> do+            let name = recordName zone lbl+            txts <- resolveTxt resolver name+            if null txts+                then pure Absent+                else case partitionEithers (map parseIndexRecord txts) of+                    (errs, []) -> ioError (userError (Text.unpack (name <> " has " <> Text.pack (show (length txts)) <> " TXT record(s) and none is a salmon index: " <> Text.intercalate "; " errs)))+                    (_, record : _) -> do+                        let stamp = Stamp ("sha256:" <> record.indexDigest.unDigest)+                        if Just stamp == previous+                            then pure Unchanged+                            else do+                                -- unconditional: the record already said it moved+                                fetched <- fetchUrl mgr record.indexUrl Nothing+                                case fetched of+                                    Found _ digest bytes+                                        | digest == record.indexDigest -> pure (Found stamp digest bytes)+                                        | otherwise -> throwIO (IndexMismatch name record.indexUrl record.indexDigest digest)+                                    Absent -> ioError (userError (Text.unpack (name <> " points at " <> record.indexUrl <> ", which has no document")))+                                    Unchanged -> ioError (userError (Text.unpack (record.indexUrl <> " answered 304 to an unconditional request")))+        }
+ src/Salmon/Actions/Follow/Registry/Git.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}++{- | The git registry for "Salmon.Actions.Follow": the desired state is a+repository, and the document for a label is a file in it.++@--follow git+\<url\>[#\<branch\>[:\<subdir\>]]@ names it. The repository is+cloned once into a working directory the caller chooses (see+"Salmon.Actions.Follow.Registry" for the default), and every round is a+@git fetch@ followed by a @git reset --hard@ onto what the remote branch+now points at — never a merge, since the checkout is nobody's to edit. The+document for label @L@ is @\<subdir\>/\<L\>.json@ in that checkout, and the+stamp is the commit the branch resolved to: a round that finds the same+commit reads nothing, which is the directory registry's "ask before+reading" with a hash instead of an mtime. A file missing from the commit is+'Absent'; the fetch failing — no network, no such branch, a credential+prompt refused (@GIT_TERMINAL_PROMPT@ is off, so a private repository fails+rather than hangs) — throws and is a failed round.++Everything goes through the @git@ binary as "Salmon.Builtin.Nodes.Git"+does, with 'Binary.untrackedExec' so that a non-zero exit is a throw+carrying git's own stderr, and not a Haskell git library.++The subdirectory has to come after the branch (@#main:hosts@, or @#:hosts@+for the remote's default branch), because a URL has colons of its own —+@ssh://host:22/repo@, @git\@host:repo.git@ — and the spec's+@[#\<branch\>][:\<subdir\>]@ leaves which one is the subdirectory's to+guess.+-}+module Salmon.Actions.Follow.Registry.Git (+    Source (..),+    parseSource,+    renderSource,+    gitRegistry,+    documentPathIn,+) where++import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy as LByteString+import Data.Text (Text)+import qualified Data.Text as Text+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)+import System.Environment (getEnvironment)+import System.FilePath ((<.>), (</>))+import System.Process.ListLike (CreateProcess (..), proc)++import Salmon.Actions.Follow (Fetch (..), Label, Registry (..), Stamp (..), digestOf, labelText)+import Salmon.Builtin.Nodes.Binary (Command (..))+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Reporter (silent)++-- | A repository, a branch (the remote's default when 'Nothing') and the+-- subdirectory the documents are under (the root when 'Nothing').+data Source = Source+    { sourceUrl :: Text+    , sourceBranch :: Maybe Text+    , sourceSubdir :: Maybe FilePath+    }+    deriving (Show, Eq)++-- | What follows @git+@: @\<url\>[#\<branch\>[:\<subdir\>]]@.+parseSource :: Text -> Either Text Source+parseSource spec+    | Text.null url = Left ("a git registry needs a URL: git+" <> spec)+    | otherwise = case Text.stripPrefix "#" fragment of+        Nothing -> Right (Source url Nothing Nothing)+        Just rest ->+            let (branch, subdir) = Text.breakOn ":" rest+             in Right+                    ( Source+                        url+                        (if Text.null branch then Nothing else Just branch)+                        (case Text.unpack (Text.drop 1 subdir) of "" -> Nothing; d -> Just d)+                    )+  where+    (url, fragment) = Text.breakOn "#" spec++-- | The address back, as @git+...@: what @history@ and reports name.+renderSource :: Source -> Text+renderSource s =+    "git+"+        <> s.sourceUrl+        <> case (s.sourceBranch, s.sourceSubdir) of+            (Nothing, Nothing) -> ""+            (b, d) -> "#" <> maybe "" id b <> maybe "" (\d' -> ":" <> Text.pack d') d++-- | Where a label's document is in a checkout: @\<subdir\>/\<label\>.json@.+documentPathIn :: FilePath -> Source -> Label -> FilePath+documentPathIn workdir s lbl = maybe workdir (workdir </>) s.sourceSubdir </> Text.unpack (labelText lbl) <.> "json"++{- | A registry over a checkout at @workdir@, made once per process (the+environment is read here, once, to turn off git's credential prompts). -}+gitRegistry :: FilePath -> Source -> IO Registry+gitRegistry workdir source = do+    env <- getEnvironment+    let git = Command (\args -> (proc "git" args){env = Just (("GIT_TERMINAL_PROMPT", "0") : filter ((/= "GIT_TERMINAL_PROMPT") . fst) env)})+        run :: [String] -> IO ()+        run args = Binary.untrackedExec git args "" silent+        -- what the branch resolves to after a fetch, as a full hash+        resolve :: IO Text+        resolve = do+            out <- Binary.untrackedExecOutput git ["-C", workdir, "rev-parse", "--verify", remoteRef] "" silent+            let hash = Text.strip (Text.pack (C8.unpack out))+            if Text.null hash then ioError (userError ("git rev-parse " <> remoteRef <> " answered nothing")) else pure hash+    pure+        Registry+            { registryName = renderSource source+            , registryFetch = \lbl previous -> do+                cloned <- doesDirectoryExist (workdir </> ".git")+                if cloned+                    then run ["-C", workdir, "fetch", "--quiet", "origin"]+                    else do+                        createDirectoryIfMissing True workdir+                        run (["clone", "--quiet"] ++ maybe [] (\b -> ["--branch", Text.unpack b, "--single-branch"]) source.sourceBranch ++ [Text.unpack source.sourceUrl, workdir])+                commit <- resolve+                let stamp = Stamp commit+                if Just stamp == previous+                    then pure Unchanged+                    else do+                        run ["-C", workdir, "reset", "--hard", "--quiet", Text.unpack commit]+                        let path = documentPathIn workdir source lbl+                        present <- doesFileExist path+                        if not present+                            then pure Absent+                            else do+                                bytes <- LByteString.readFile path+                                LByteString.length bytes `seq` pure (Found stamp (digestOf bytes) bytes)+            }+  where+    remoteRef = maybe "origin/HEAD" (\b -> "origin/" <> Text.unpack b) source.sourceBranch
+ src/Salmon/Actions/Follow/Registry/Http.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE OverloadedStrings #-}++{- | The HTTP registry for "Salmon.Actions.Follow": the document for a label+is one @GET@, and the server does the change detection.++The template is the operator's: @--follow https://host/path@ fetches+@\<path\>/\<label\>.json@, and a @{label}@ anywhere in the URL places the+label there instead (@https://host/seed/latest/{label}@, the spec's example).+The stamp is the response's @ETag@, or its @Last-Modified@ when there is no+@ETag@, handed back as @If-None-Match@ / @If-Modified-Since@ so that an+unchanged document is a @304@ and no body crosses the wire — the same "ask+before reading" the directory registry does with an mtime, done by the+server. A server that sends neither is read in full every round and the+digest does the work, as ever.++What is what: @200@ is a document, @304@ is 'Unchanged', @404@ is 'Absent'+(the registry answered; not a failed round), and everything else — a @5xx@,+a @403@, a connection refused, a timeout — throws and is a failed round on+the scheduler's ladder. Redirects are followed by @http-client@'s default.+Bytes that do not parse are the fetcher's 'Salmon.Actions.Follow.Malformed',+not this module's concern.+-}+module Salmon.Actions.Follow.Registry.Http (+    Options (..),+    defaultOptions,+    newManager,+    httpRegistry,+    addressFor,+    fetchUrl,+    HttpFailed (..),+) where++import Control.Exception (Exception, throwIO)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Network.HTTP.Client (Manager, httpLbs, parseRequest, requestHeaders, responseBody, responseHeaders, responseStatus, responseTimeoutMicro)+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Client.TLS (newTlsManagerWith, tlsManagerSettings)+import Network.HTTP.Types (statusCode)++import Salmon.Actions.Follow (Digest (..), Fetch (..), Label, Registry (..), Stamp (..), digestOf, labelText)++-- | What every HTTP-backed registry shares.+newtype Options = Options+    { optTimeout :: Int+    -- ^ microseconds a whole response may take, connection included+    }+    deriving (Show, Eq)++-- | Thirty seconds: a registry is a small document, and a round that hangs+-- holds every other label's fetch behind it.+defaultOptions :: Options+defaultOptions = Options{optTimeout = 30 * 1000000}++-- | One manager per process — TLS or plain, decided per request by its scheme.+newManager :: Options -> IO Manager+newManager o = newTlsManagerWith tlsManagerSettings{HTTP.managerResponseTimeout = responseTimeoutMicro o.optTimeout}++{- | Where a label's document is: the template with @{label}@ replaced, or+@\<base\>/\<label\>.json@ when the template has no placeholder (a trailing+slash on the base is not doubled).+-}+addressFor :: Text -> Label -> Text+addressFor template lbl+    | placeholder `Text.isInfixOf` template = Text.replace placeholder (labelText lbl) template+    | otherwise = Text.dropWhileEnd (== '/') template <> "/" <> labelText lbl <> ".json"+  where+    placeholder = "{label}"++-- | A registry over a URL template; its name is the template as given.+httpRegistry :: Manager -> Text -> Registry+httpRegistry mgr template =+    Registry+        { registryName = template+        , registryFetch = \lbl previous -> fetchUrl mgr (addressFor template lbl) previous+        }++-- | A status this module has no answer for.+data HttpFailed = HttpFailed+    { httpFailedUrl :: Text+    , httpFailedStatus :: Int+    }++instance Show HttpFailed where+    show e = "GET " <> Text.unpack e.httpFailedUrl <> " answered " <> show e.httpFailedStatus++instance Exception HttpFailed++{- | @GET@ a URL conditionally on the stamp from the last time, which is+@etag:...@ or @last-modified:...@ so that the header it goes back in is+known. Throws for anything but @200@, @304@ and @404@; a URL that does not+parse throws too.+-}+fetchUrl :: Manager -> Text -> Maybe Stamp -> IO Fetch+fetchUrl mgr url previous = do+    req0 <- parseRequest (Text.unpack url)+    let conditional = case previous of+            Just (Stamp s)+                | Just etag <- Text.stripPrefix etagPrefix s -> [("If-None-Match", Text.encodeUtf8 etag)]+                | Just lm <- Text.stripPrefix lastModifiedPrefix s -> [("If-Modified-Since", Text.encodeUtf8 lm)]+            _ -> []+        req = req0{requestHeaders = ("Accept", "application/json") : conditional ++ requestHeaders req0}+    resp <- httpLbs req mgr+    case statusCode (responseStatus resp) of+        200 -> do+            let bytes = responseBody resp+            pure (Found (stampOf (responseHeaders resp)) (digestOf bytes) bytes)+        304 -> pure Unchanged+        404 -> pure Absent+        code -> throwIO (HttpFailed url code)+  where+    etagPrefix = "etag:"+    lastModifiedPrefix = "last-modified:"+    stampOf headers =+        case (lookup "ETag" headers, lookup "Last-Modified" headers) of+            (Just etag, _) -> Stamp (etagPrefix <> Text.decodeUtf8Lenient etag)+            (Nothing, Just lm) -> Stamp (lastModifiedPrefix <> Text.decodeUtf8Lenient lm)+            -- nothing to ask conditionally with: read every round, and let+            -- the digest say whether anything changed+            (Nothing, Nothing) -> Stamp "none"
+ src/Salmon/Actions/Follow/Scheduler.hs view
@@ -0,0 +1,373 @@+{-# LANGUAGE OverloadedStrings #-}++{- | The scheduler behind "Salmon.Actions.Follow": /when/ the fetcher asks the+registry, and /when/ what it found reaches the loop. Two jobs that point in+opposite directions, per @specs/pull-mode.md@.++__Toward the registry: a ladder.__ A round that succeeds — changed or not —+schedules the next one at 'schedBase'; a round that fails (the registry+threw, or answered with bytes that do not parse) schedules it at+@min cap (base · factor^(n-1))@ after @n@ consecutive failures, so the first+retry comes no later than a success's next round and every one after it is+slower, up to 'schedCap'. Every delay is jittered by up to 'schedJitter' of+itself, either way, so a fleet that rebooted together does not poll+together. There is no reason to slow down while quiet: an unchanged round is+a success.++__Toward the loop: a quiet window.__ A change is not injected at once. It+opens a window of 'schedDebounce'; a further change inside the window+restarts it (the pending batch is whatever the /latest/ document says,+diffed against the last one /applied/); the batch is injected once the+registry has been quiet for that long, or once 'schedMaxWait' has elapsed+since the first pending change, whichever comes first. This is what turns a+publisher writing three times in a row into one convergence pass, and what+keeps a half-published state from being applied — and it is the starvation+rule of "Salmon.Actions.Follow" restated as a rate: every injection stands+the supervisor's machines down, so how often that can happen is bounded by+the window, not by the poll.++__The @fetch@ command__ is the one place inbound events touch this: 'poked'+schedules a round now, forgets the failure count, and marks whatever is+pending (before or after that round) to be injected as soon as the round is+over — an operator who just published does not want to wait out either+ladder.++The whole thing is a pure step function over a small 'Sched' ('observed',+'poked', 'injected', and 'next' to ask what is due), which is what the+tests table-test, plus one 'IO' loop ('run') around it that takes its clock+from the caller, so that a test moves time rather than waiting for it.+Its randomness is a seeded 'Rng' for the same reason.++"Salmon.Actions.Upkeep" has a ladder of the same shape (double to a cap,+halve to a floor), but that one is a per-node question about /checks/; this+one is per-registry about /fetches/, and the two share nothing on purpose.+-}+module Salmon.Actions.Follow.Scheduler (+    -- * Configuration+    Micros,+    Config (..),+    defaultConfig,+    renderConfig,++    -- * The pure step+    Sched,+    schedFailures,+    schedNextFetch,+    schedPending,+    Pending (..),+    Outcome (..),+    Action (..),+    Due (..),+    start,+    observed,+    poked,+    injected,+    next,+    ladder,++    -- * Jitter+    Rng,+    mkRng,+    jittered,++    -- * The loop+    Clock (..),+    Wake (..),+    Poke,+    newPoke,+    poke,+    systemClock,+    Hooks (..),+    run,+) where++import Control.Concurrent.STM (TVar, atomically, check, newTVarIO, orElse, readTVar, registerDelay, writeTVar)+import Data.Bits (shiftR, xor)+import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Word (Word64)+import GHC.Clock (getMonotonicTimeNSec)++-------------------------------------------------------------------------------+-- configuration++-- | Microseconds, the unit 'Control.Concurrent.threadDelay' takes.+type Micros = Int++data Config = Config+    { schedBase :: !Micros+    -- ^ the delay after a successful round, and the ladder's first rung+    , schedFactor :: !Double+    -- ^ how much slower each consecutive failure makes the next round+    , schedCap :: !Micros+    -- ^ the ladder's ceiling+    , schedJitter :: !Double+    -- ^ every delay is scaled by a uniform draw from @[1 - j, 1 + j]@+    , schedDebounce :: !Micros+    -- ^ how long the registry must be quiet after a change before it is injected+    , schedMaxWait :: !Micros+    -- ^ the longest a change waits, quiet or not+    }+    deriving (Show, Eq)++{- | The spec's defaults: tens of seconds toward the registry, a few seconds+toward the loop. -}+defaultConfig :: Config+defaultConfig =+    Config+        { schedBase = 30 * second+        , schedFactor = 2+        , schedCap = 10 * 60 * second+        , schedJitter = 0.2+        , schedDebounce = 5 * second+        , schedMaxWait = 60 * second+        }+  where+    second = 1000000++-- | One line, for a report.+renderConfig :: Config -> Text+renderConfig cfg =+    Text.concat+        [ "every "+        , secs cfg.schedBase+        , " (on failure x"+        , Text.pack (show cfg.schedFactor)+        , " up to "+        , secs cfg.schedCap+        , ", jitter "+        , Text.pack (show (round (cfg.schedJitter * 100) :: Int))+        , "%; a change waits "+        , secs cfg.schedDebounce+        , " of quiet, at most "+        , secs cfg.schedMaxWait+        , ")"+        ]+  where+    secs us = Text.pack (show (us `div` 1000000)) <> "s"++-------------------------------------------------------------------------------+-- jitter++{- | A splitmix64 generator, written out rather than pulled in as a+dependency: two lines of arithmetic are all a jitter needs, and a test that+wants the same draws twice seeds it with 'mkRng'. -}+newtype Rng = Rng Word64+    deriving (Show, Eq)++mkRng :: Word64 -> Rng+mkRng = Rng++nextWord :: Rng -> (Word64, Rng)+nextWord (Rng s) =+    let s' = s + 0x9e3779b97f4a7c15+        z1 = (s' `xor` (s' `shiftR` 30)) * 0xbf58476d1ce4e5b9+        z2 = (z1 `xor` (z1 `shiftR` 27)) * 0x94d049bb133111eb+     in (z2 `xor` (z2 `shiftR` 31), Rng s')++-- | A uniform draw from @[0, 1)@.+unit :: Rng -> (Double, Rng)+unit g =+    let (w, g') = nextWord g+     in (fromIntegral (w `shiftR` 11) / 9007199254740992, g')++-- | Scale a delay by a uniform draw from @[1 - j, 1 + j]@; the identity at @j = 0@.+jittered :: Config -> Rng -> Micros -> (Micros, Rng)+jittered cfg g us+    | cfg.schedJitter <= 0 = (us, g)+    | otherwise =+        let (u, g') = unit g+            scale = 1 - cfg.schedJitter + 2 * cfg.schedJitter * u+         in (max 0 (round (fromIntegral us * scale)), g')++-------------------------------------------------------------------------------+-- the pure step++-- | What one round of fetching every label amounted to.+data Outcome+    = -- | every label answered and none moved+      Unchanged+    | -- | every label answered and at least one moved: something is pending+      Changed+    | -- | at least one label could not be read+      Failed+    deriving (Show, Eq)++-- | A change waiting for its window: when it was first seen, and when last.+data Pending = Pending+    { pendingSince :: !Micros+    , pendingLast :: !Micros+    }+    deriving (Show, Eq)++data Sched = Sched+    { schedFailures :: !Int+    -- ^ consecutive failed rounds+    , schedNextFetch :: !Micros+    -- ^ when the next round is due+    , schedPending :: !(Maybe Pending)+    , schedFlush :: !(Maybe Micros)+    -- ^ a @fetch@ came in at this time: inject what is pending without+    -- waiting out the window (kept until an injection, or until a round+    -- ends with nothing pending)+    , schedLastInjection :: !(Maybe Micros)+    , schedRng :: !Rng+    }+    deriving (Show)++-- | What to do next, and when.+data Action = Fetch | Inject+    deriving (Show, Eq)++data Due = Due+    { dueAt :: !Micros+    , dueAction :: !Action+    }+    deriving (Show, Eq)++{- | A scheduler whose first round has just succeeded at @now@ — the+synchronous one "Salmon.Actions.Follow" runs at startup, whose result is+injected without any window (there is nothing to coalesce yet, and the first+convergence is meant to be deterministic). The next round is one base delay+away. -}+start :: Config -> Rng -> Micros -> Sched+start cfg g now =+    observed+        cfg+        now+        Unchanged+        Sched+            { schedFailures = 0+            , schedNextFetch = now+            , schedPending = Nothing+            , schedFlush = Nothing+            , schedLastInjection = Nothing+            , schedRng = g+            }++-- | The ladder's rung after this many consecutive failures, before jitter.+ladder :: Config -> Int -> Micros+ladder cfg n+    | n <= 1 = cfg.schedBase+    | otherwise =+        let raw = fromIntegral cfg.schedBase * cfg.schedFactor ^^ (n - 1) :: Double+         in if raw >= fromIntegral cfg.schedCap then cfg.schedCap else round raw++-- | A round just ended, at @now@, with this outcome.+observed :: Config -> Micros -> Outcome -> Sched -> Sched+observed cfg now outcome st =+    st+        { schedFailures = failures+        , schedNextFetch = now + delay+        , schedPending = pending+        , -- a flush with nothing behind it has nothing left to do+          schedFlush = if isJust pending then st.schedFlush else Nothing+        , schedRng = g'+        }+  where+    failures = case outcome of+        Failed -> st.schedFailures + 1+        _ -> 0+    pending = case outcome of+        Changed -> Just (maybe (Pending now now) (\p -> p{pendingLast = now}) st.schedPending)+        _ -> st.schedPending+    (delay, g') = jittered cfg st.schedRng (ladder cfg failures)++{- | A @fetch@ came in at @now@: the next round is due now, the ladder is+forgotten, and whatever is pending once that round is over goes in at once. -}+poked :: Micros -> Sched -> Sched+poked now st = st{schedFailures = 0, schedNextFetch = now, schedFlush = Just now}++-- | The pending batch was injected at @now@.+injected :: Micros -> Sched -> Sched+injected now st = st{schedPending = Nothing, schedFlush = Nothing, schedLastInjection = Just now}++{- | What is due next. A round and an injection due at the same instant go+round first: a @fetch@ makes both due now, and the point of it is to inject+what that round finds, not what was found before it. -}+next :: Config -> Sched -> Due+next cfg st =+    case injectionDue of+        Just at | at < st.schedNextFetch -> Due at Inject+        _ -> Due st.schedNextFetch Fetch+  where+    injectionDue = do+        p <- st.schedPending+        pure $ case st.schedFlush of+            Just at -> at+            Nothing -> min (p.pendingLast + cfg.schedDebounce) (p.pendingSince + cfg.schedMaxWait)++-------------------------------------------------------------------------------+-- the loop++-- | Why a wait ended.+data Wake = Elapsed | Poked+    deriving (Show, Eq)++{- | Where the loop gets its time. 'systemClock' is the real one; a test+supplies one whose 'clockWaitUntil' blocks until the test moves the clock. -}+data Clock = Clock+    { clockNow :: IO Micros+    , clockWaitUntil :: Micros -> IO Wake+    -- ^ return at the given time, or earlier if poked+    }++-- | The control channel a @fetch@ command pulls: one flag, set by 'poke'+-- and consumed by the next wait.+newtype Poke = Poke (TVar Bool)++newPoke :: IO Poke+newPoke = Poke <$> newTVarIO False++poke :: Poke -> IO ()+poke (Poke v) = atomically (writeTVar v True)++-- | The monotonic clock, sleeping in STM so a 'poke' can cut the sleep short.+systemClock :: Poke -> Clock+systemClock (Poke pokeVar) = Clock now waitUntil+  where+    now = fmap (\ns -> fromIntegral (ns `div` 1000)) getMonotonicTimeNSec+    waitUntil at = do+        t <- now+        if at <= t+            then pure Elapsed+            else do+                elapsedVar <- registerDelay (at - t)+                atomically $+                    (readTVar elapsedVar >>= check >> pure Elapsed)+                        `orElse` (readTVar pokeVar >>= check >> writeTVar pokeVar False >> pure Poked)++-- | What the loop does when something is due.+data Hooks = Hooks+    { hookFetch :: IO Outcome+    -- ^ one round: ask the registry for every label+    , hookInject :: IO ()+    -- ^ inject whatever is pending+    , hookBackoff :: Int -> Micros -> IO ()+    -- ^ a round failed: consecutive failures, and how long until the next one+    }++-- | Never returns; the caller kills the thread.+run :: Config -> Clock -> Hooks -> Sched -> IO ()+run cfg clock hooks = go+  where+    go st = do+        let due = next cfg st+        wake <- clockWaitUntil clock due.dueAt+        now <- clockNow clock+        st' <- case wake of+            Poked -> pure (poked now st)+            Elapsed -> case due.dueAction of+                Inject -> do+                    hookInject hooks+                    pure (injected now st)+                Fetch -> do+                    outcome <- hookFetch hooks+                    after <- clockNow clock+                    let st1 = observed cfg after outcome st+                    case outcome of+                        Failed -> hookBackoff hooks st1.schedFailures (st1.schedNextFetch - after)+                        _ -> pure ()+                    pure st1+        go st'
+ src/Salmon/Actions/Follow/Signature.hs view
@@ -0,0 +1,425 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | Signed documents for pull mode: the verifier that fills in+'Salmon.Actions.Follow.followVerify', and the signer a controller runs+(@salmon-fleet sign@).++Pulling inverts trust — a host following a registry trusts whatever the+registry serves — so a document can be wrapped in a /signed envelope/:++@+{ "salmon-signed": 1+, "document": { "salmon": 1, "id": "web\@2026-09-24", "seeds": [...] }+, "signatures": [ { "key": "\<key id\>", "alg": "EdDSA", "sig": "\<base64\>" } ]+}+@++The document rides inside it as fetched, an object, not a string; the+signature is over its /canonical bytes/ — 'canonicalBytes', which is+"Data.Aeson"'s 'encode' of the parsed 'Value'. That encoder writes an+object's keys in sorted order (aeson 2's 'Data.Aeson.KeyMap' is a+@Data.Map@ under its default @ordered-keymap@ flag; the plan pins aeson+2.2.5.1, and the ordering has held since 2.0) and one spelling per string+and number, so a registry, a proxy or a pretty-printer that re-serialises+the envelope — reorders keys, changes whitespace — does not break the+signature; only a change to the document's /content/ does. Both the signer+and the verifier parse first and encode with the same function, which is+the whole of the canonicalisation story: no separate canonical-JSON+library, and nothing to keep in step with one.++__What the verifier hands the loop is the inner document__, canonical+bytes, so that what is parsed as a 'Salmon.Actions.Follow.Document' is+exactly what was signed. The digest the fetcher keeps — in @history@, in+'Salmon.Actions.Follow.Rejected', and beside the cached bytes — stays the+digest of the bytes /as fetched/, i.e. of the envelope: change detection+compares fetched bytes, the DNS index's @sha256=@ names them, and a cache+entry is verified from those same bytes on replay, so the envelope is what+the cache keeps and the digest is what identifies it.++__The key is a JWK__ ("Crypto.JOSE.JWK", the @jose@ package+"Salmon.Builtin.Nodes.Keys" already generates JWK files with): the one key+format this tree already has, kept rather than adding a PEM story beside+it. @salmon-fleet keygen@ writes an Ed25519 pair as two JWK files; the+algorithm is EdDSA over Ed25519 — @jose@ carries it on @crypton@, which+was already a dependency — with the RSA and EC algorithms @jose@ also+signs with accepted for a key that is one of those (the signer picks+'JWK.bestJWSAlg'). @none@ and the HMAC algorithms are refused outright: a+public key can verify neither. The key id is the RFC 7638 thumbprint, the+SHA-256 of the public key's canonical JSON, in hex.++Verification is per 'signedVerifier': every signature is tried against+every key it names, any one that verifies accepts. What is refused, and+with what reason: a plain unsigned document (there is a key, so it is+required), an envelope that does not parse, one with no signatures, and+one whose signatures all fail — the reason names which.++__A signature is worth something only at the address it was signed for.__ A+registry that can be written to but not signed for could otherwise copy a+validly signed @canary@ document to @prod@'s address, and every host following+@prod@ would apply it (the cache, read back through the same verifier, is+exposed the same way). So the verifier is told the label it is looking at+('Salmon.Actions.Follow.Verifier') and holds two rules:++* the __document names its label__: a top-level @label@ member of the+  document, so the signature (which is over the document's canonical bytes)+  covers it, where a label kept beside the signatures would not be signed at+  all. A document whose @label@ is not the one it was fetched for is refused,+  the reason naming both. @salmon-fleet sign --label L@ writes it.+* a __key may speak for some labels only__ ('TrustedKey'): a key given as+  @--follow-key LABEL=FILE@ verifies documents for that label and no other;+  a bare @--follow-key FILE@ keeps meaning any label.++A signed document with no @label@ (signed before this) is refused unless the+'AcceptUnlabelled' migration policy is on, which is @--follow-accept-unlabelled@.+-}+module Salmon.Actions.Follow.Signature (+    -- * Keys+    PrivateKey,+    PublicKey,+    generateKeyPair,+    publicKey,+    keyId,+    readPrivateKeyFile,+    readPublicKeyFile,+    writeKeyPair,++    -- * The envelope+    envelopeVersion,+    canonicalBytes,+    signDocument,+    Envelope (..),+    Signature (..),++    signDocumentFor,++    -- * The verifier+    TrustedKey (..),+    trustsAnyLabel,+    trustsOnly,+    Legacy (..),+    parseKeySpec,+    signedVerifier,+    verifyEnvelope,+    verifyEnvelopeFor,+) where++import Control.Exception (SomeException, try)+import Control.Monad (unless)+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), eitherDecode, encode, object, withObject, (.:), (.=))+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Base64 as Base64+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as LByteString+import Data.Either (lefts, rights)+import Data.Functor.Const (Const (..))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import System.Posix.Files (setFileMode)++import qualified Crypto.JOSE.Error as JOSE+import qualified Crypto.JOSE.JWA.JWS as JWS+import Crypto.JOSE.JWK (JWK)+import qualified Crypto.JOSE.JWK as JWK++import Salmon.Actions.Follow (Label, Verifier, labelText, mkLabel)++-------------------------------------------------------------------------------+-- keys++-- | A key with private material: what signs.+newtype PrivateKey = PrivateKey JWK+    deriving (Show, Eq)++-- | A key without private material: what a host verifies against.+newtype PublicKey = PublicKey JWK+    deriving (Show, Eq)++-- | Read a getter or lens without a @lens@ dependency: 'Const' is both+-- the functor a lens needs and the contravariant one a getter needs.+view :: ((a -> Const a a) -> s -> Const a s) -> s -> a+view l = getConst . l Const++-- | A fresh Ed25519 pair, as one JWK holding both halves.+generateKeyPair :: IO PrivateKey+generateKeyPair = PrivateKey <$> JWK.genJWK (JWK.OKPGenParam JWK.Ed25519)++-- | The public half of a key. Every key material @jose@ generates has one.+publicKey :: PrivateKey -> PublicKey+publicKey (PrivateKey k) =+    PublicKey (maybe k id (view JWK.asPublicKey k))++-- | The RFC 7638 thumbprint of the public key, SHA-256, hex: what an+-- envelope's @key@ member names.+keyId :: PublicKey -> Text+keyId (PublicKey k) = Text.pack (show (view JWK.thumbprint k :: JWK.Digest JWK.SHA256))++-- | A JWK file holding private material: the reason it cannot be used, or+-- the key. Never throws.+readPrivateKeyFile :: FilePath -> IO (Either Text PrivateKey)+readPrivateKeyFile path = do+    parsed <- readKeyFile path+    pure $ case parsed of+        Left err -> Left err+        Right k+            | view JWK.asPublicKey k == Just k -> Left (Text.pack path <> ": holds no private material")+            | otherwise -> Right (PrivateKey k)++-- | A JWK file holding a public key — or a private one, whose public half+-- is taken. Never throws.+readPublicKeyFile :: FilePath -> IO (Either Text PublicKey)+readPublicKeyFile path = do+    parsed <- readKeyFile path+    pure $ case parsed of+        Left err -> Left err+        Right k -> case view JWK.asPublicKey k of+            Nothing -> Left (Text.pack path <> ": not a key with a public half")+            Just pk -> Right (PublicKey pk)++readKeyFile :: FilePath -> IO (Either Text JWK)+readKeyFile path = do+    attempt <- try (LByteString.readFile path >>= \b -> LByteString.length b `seq` pure b)+    pure $ case attempt of+        Left (ex :: SomeException) -> Left (Text.pack path <> ": " <> Text.pack (show ex))+        Right bytes -> case eitherDecode bytes of+            Left err -> Left (Text.pack path <> ": not a JWK: " <> Text.pack err)+            Right k -> Right k++{- | Write a pair as two JWK files: the private key at @path@, mode 0600,+and its public half at @path.pub@. May throw. -}+writeKeyPair :: FilePath -> PrivateKey -> IO ()+writeKeyPair path key@(PrivateKey k) = do+    LByteString.writeFile path (encode k <> "\n")+    setFileMode path 0o600+    let PublicKey pk = publicKey key+    LByteString.writeFile (path <> ".pub") (encode pk <> "\n")++-------------------------------------------------------------------------------+-- the envelope++-- | The one value of @salmon-signed@ this reader understands.+envelopeVersion :: Int+envelopeVersion = 1++-- | The bytes a signature is over: 'encode' of the parsed value. See the+-- module comment for why that is canonical enough.+canonicalBytes :: Value -> ByteString+canonicalBytes = encode++data Signature = Signature+    { sigKey :: !Text+    -- ^ the signing key's 'keyId'+    , sigAlg :: !JWS.Alg+    , sigBytes :: !ByteString.ByteString+    -- ^ raw; base64 on the wire+    }+    deriving (Show, Eq)++instance FromJSON Signature where+    parseJSON = withObject "salmon signature" $ \o -> do+        k <- o .: "key"+        alg <- o .: "alg"+        b64 <- o .: "sig"+        case Base64.decode (Text.encodeUtf8 b64) of+            Left err -> fail ("sig is not base64: " <> err)+            Right raw -> pure (Signature k alg raw)++instance ToJSON Signature where+    toJSON s =+        object+            [ "key" .= s.sigKey+            , "alg" .= s.sigAlg+            , "sig" .= Text.decodeUtf8 (Base64.encode s.sigBytes)+            ]++-- | The wire shape: the document as a 'Value', signatures beside it.+data Envelope = Envelope+    { envDocument :: !Value+    , envSignatures :: ![Signature]+    }+    deriving (Show, Eq)++instance FromJSON Envelope where+    parseJSON = withObject "salmon signed envelope" $ \o -> do+        v <- o .: "salmon-signed"+        unless (v == envelopeVersion) $+            fail ("unsupported envelope format: salmon-signed=" <> show v <> " (this reader understands " <> show envelopeVersion <> ")")+        Envelope <$> o .: "document" <*> o .: "signatures"++instance ToJSON Envelope where+    toJSON e =+        object+            [ "salmon-signed" .= envelopeVersion+            , "document" .= e.envDocument+            , "signatures" .= e.envSignatures+            ]++{- | Wrap a document's bytes in a signed envelope: the reason they cannot be+signed (not JSON, not an object, a key that signs nothing), or the+envelope's bytes. The document is kept as parsed, so a publisher's+annotations survive; what is signed is its canonical form. -}+signDocument :: PrivateKey -> ByteString -> IO (Either Text ByteString)+signDocument key = signDocumentFor key Nothing++{- | 'signDocument' for a document that names the label it is for: the+@label@ member is put into the document before it is signed, so the+signature covers it. A document that already names a different label is not+signed (a mistake worth stopping on); one that names the same is left as it+is. -}+signDocumentFor :: PrivateKey -> Maybe Label -> ByteString -> IO (Either Text ByteString)+signDocumentFor key@(PrivateKey k) mlabel bytes =+    case eitherDecode bytes of+        Left err -> pure (Left ("the document is not JSON: " <> Text.pack err))+        Right (Object o0) | Just lbl <- mlabel, Just existing <- KeyMap.lookup "label" o0, existing /= String (labelText lbl) ->+            pure (Left ("the document already names " <> Text.pack (show existing) <> " as its label, not " <> labelText lbl))+        Right (Object o0) -> signObject (Object (maybe o0 (\lbl -> KeyMap.insert "label" (String (labelText lbl)) o0) mlabel))+        Right _ -> pure (Left "the document is not a JSON object")+  where+    signObject doc = do+            outcome <- JOSE.runJOSE $ do+                alg <- JWK.bestJWSAlg k+                sig <- JWK.sign alg (view JWK.jwkMaterial k) (LByteString.toStrict (canonicalBytes doc))+                pure (alg, sig)+            pure $ case outcome of+                Left (err :: JOSE.Error) -> Left ("cannot sign with this key: " <> Text.pack (show err))+                Right (alg, sig) ->+                    Right (encode (Envelope doc [Signature (keyId (publicKey key)) alg sig]) <> "\n")++-------------------------------------------------------------------------------+-- the verifier++{- | Refuse everything but an envelope one of these keys signed, and hand+the loop the document inside it. 'Right' is the inner document's canonical+bytes; the digest handed in is only for the reasons' sake. -}+signedVerifier :: Legacy -> [TrustedKey] -> Verifier+signedVerifier legacy keys lbl _ bytes = pure (verifyEnvelopeFor legacy keys lbl bytes)++{- | A @--follow-key@ argument: @FILE@, or @LABEL=FILE@ for a key that speaks+for that label only. Something is a label only if what precedes the first+@=@ has no @/@ and is a valid label, so a path that happens to contain an+@=@ stays a path. -}+parseKeySpec :: Text -> Either Text (Maybe Label, FilePath)+parseKeySpec spec = case Text.breakOn "=" spec of+    (l, r)+        | not (Text.null r), not (Text.null l), not (Text.any (== '/') l) -> do+            lbl <- mkLabel l+            pure (Just lbl, Text.unpack (Text.drop 1 r))+    _ -> Right (Nothing, Text.unpack spec)++-- | A public key, and the labels it may speak for.+data TrustedKey = TrustedKey+    { trustedKey :: !PublicKey+    , trustedLabels :: !(Maybe [Label])+    -- ^ 'Nothing': any label. 'Just': these labels and no others.+    }+    deriving (Show, Eq)++-- | A key that verifies documents for every label.+trustsAnyLabel :: PublicKey -> TrustedKey+trustsAnyLabel k = TrustedKey k Nothing++-- | A key that verifies documents for one label only.+trustsOnly :: Label -> PublicKey -> TrustedKey+trustsOnly l k = TrustedKey k (Just [l])++speaksFor :: Label -> TrustedKey -> Bool+speaksFor l t = maybe True (l `elem`) t.trustedLabels++-- | What to do with a signed document that names no label: one signed before+-- documents named theirs.+data Legacy+    = -- | refuse it (the default)+      RefuseUnlabelled+    | -- | accept it, the migration flag+      AcceptUnlabelled+    deriving (Show, Eq)++{- | 'signedVerifier', pure: the signature is checked against the keys that+may speak for this label, then the document's own @label@ against the label+it was fetched for. -}+verifyEnvelopeFor :: Legacy -> [TrustedKey] -> Label -> ByteString -> Either Text ByteString+verifyEnvelopeFor legacy keys lbl bytes = do+    let here = [trustedKey t | t <- keys, speaksFor lbl t]+        elsewhere = [trustedKey t | t <- keys, not (speaksFor lbl t)]+    doc <- case verifiedDocument here bytes of+        Right d -> Right d+        Left why -> Left (why <> notTrustedHere elsewhere)+    case doc of+        Object o -> case KeyMap.lookup "label" o of+            Just (String t)+                | t == labelText lbl -> Right (canonicalBytes doc)+                | otherwise ->+                    Left ("the document is signed for label " <> t <> " but was fetched for label " <> labelText lbl <> ": refusing to apply one label's document at another's address")+            Just other -> Left ("the document's label is not a string: " <> Text.pack (show other))+            Nothing -> case legacy of+                AcceptUnlabelled -> Right (canonicalBytes doc)+                RefuseUnlabelled ->+                    Left ("the signed document names no label, so it could have been signed for any address (this one is " <> labelText lbl <> "); sign it again with `salmon-fleet sign --label " <> labelText lbl <> "`, or accept unlabelled documents while migrating with --follow-accept-unlabelled")+        _ -> Left "the signed document is not a JSON object"+  where+    -- a signature by a key that exists but may not speak here says so,+    -- rather than the vaguer "names no configured key"+    notTrustedHere elsewhere = case [keyId k | k <- elsewhere, signedBy k] of+        [] -> ""+        ids -> " (signed by " <> Text.intercalate ", " (fmap short ids) <> ", which may not speak for label " <> labelText lbl <> ")"+    signedBy k = case eitherDecode bytes :: Either String Envelope of+        Right env -> keyId k `elem` fmap sigKey env.envSignatures+        Left _ -> False+    short = Text.take 12++-- | 'signedVerifier' for keys that each speak for every label, and a+-- document that need not name one. The check that is only about the+-- signature: what 'verifyEnvelopeFor' builds on.+verifyEnvelope :: [PublicKey] -> ByteString -> Either Text ByteString+verifyEnvelope keys bytes = canonicalBytes <$> verifiedDocument keys bytes++-- | The document inside an envelope one of these keys signed.+verifiedDocument :: [PublicKey] -> ByteString -> Either Text Value+verifiedDocument keys bytes =+    case eitherDecode bytes :: Either String Value of+        Left err -> Left ("not a signed envelope, not even JSON: " <> Text.pack err)+        Right (Object o)+            | not (KeyMap.member "salmon-signed" o) ->+                Left "unsigned document: a signing key is configured (--follow-key) and this document carries no signed envelope"+        Right v -> case eitherDecode (encode v) :: Either String Envelope of+            Left err -> Left ("the signed envelope does not parse: " <> Text.pack err)+            Right env+                | null env.envSignatures -> Left "the signed envelope carries no signatures"+                | null keys -> Left "no signing key to verify against"+                | otherwise ->+                    let signed = LByteString.toStrict (canonicalBytes env.envDocument)+                        verdicts = [check signed key sig | sig <- env.envSignatures, key <- keys]+                     in if or (rights verdicts)+                            then Right env.envDocument+                            else+                                Left $+                                    "no signature verifies against any of the "+                                        <> Text.pack (show (length keys))+                                        <> " configured key(s): "+                                        <> Text.intercalate "; " (dedupe (lefts verdicts))+  where+    -- one signature against one key: a mismatched key id is not tried (its+    -- reason says so), an algorithm a public key cannot verify with is+    -- refused rather than handed to jose, and a signature that does not+    -- verify says which key it was tried against.+    check :: ByteString.ByteString -> PublicKey -> Signature -> Either Text Bool+    check signed pk@(PublicKey k) sig+        | sig.sigKey /= keyId pk = Left ("signature by " <> short sig.sigKey <> " names no configured key")+        | not (publicAlg sig.sigAlg) = Left ("signature by " <> short sig.sigKey <> " uses " <> Text.pack (show sig.sigAlg) <> ", which no public key can verify")+        | otherwise = case JWK.verify sig.sigAlg (view JWK.jwkMaterial k) signed sig.sigBytes of+            Left (err :: JOSE.Error) -> Left ("signature by " <> short sig.sigKey <> ": " <> Text.pack (show err))+            Right True -> Right True+            Right False -> Left ("signature by " <> short sig.sigKey <> " does not verify: the document was altered after signing, or signed by another key")+    short = Text.take 12+    dedupe = foldr (\x acc -> if x `elem` acc then acc else x : acc) []++-- | The algorithms a /public/ key verifies: not @none@, not an HMAC.+publicAlg :: JWS.Alg -> Bool+publicAlg alg = case alg of+    JWS.None -> False+    JWS.HS256 -> False+    JWS.HS384 -> False+    JWS.HS512 -> False+    _ -> True
+ src/Salmon/Actions/Help.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Salmon.Actions.Help where++import Control.Comonad.Cofree (Cofree)+import Data.Foldable (toList, traverse_)+import qualified Data.Maybe as Maybe+import GHC.Records++import Salmon.FoldBranch+import Salmon.Op.Actions+import Salmon.Op.Dag (Dag)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Eval+import Salmon.Op.Graph+import Salmon.Op.OpGraph+import Salmon.Op.Ref (unRef)++import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text++{- | Per-node path, as the segments (one 'shorthand' per non-'Actionless'+ancestor, root-to-node) that 'query' renders joined by @\/@ ((R4): @run+tree@\/@run dag@ moved to the computed 'Salmon.Op.Dag.Dag' and print+'printDagTree'\/'Salmon.Actions.Dot.printDagCograph' instead — this is+declared-graph-only now). Shared by 'printCograph', "Salmon.Actions.Dot", and+"Salmon.Actions.Query" so there is exactly one definition of "what a node's+path is" across all of them.+-}+nodeSegments ::+    (Functor t) =>+    Cofree t (Actions ext) ->+    Cofree t [Text]+nodeSegments = foldBranch step []+  where+    step pfx x =+        case x of+            Actionless -> pfx+            Actions y -> pfx <> [shorthand y]++pathText :: [Text] -> Text+pathText = ("" <>) . Text.concat . map ("/" <>)++printTree :: (Monad m) => (forall a. m a -> IO a) -> OpGraph m (Actions ext) -> IO ()+printTree nat graph = do+    printCograph =<< nat (expand graph)++printCograph ::+    (Monad m) =>+    Cofree Graph (OpGraph m (Actions ext)) ->+    IO ()+printCograph gr1 = do+    traverse_ Text.putStrLn $ dirtree gr1+  where+    dirtree = fmap pathText . nodeSegments . fmap node++printHelpTree ::+    ( Monad m+    , HasField "help" ext Text+    ) =>+    (forall a. m a -> IO a) ->+    OpGraph m (Actions ext) ->+    IO ()+printHelpTree nat graph = do+    printHelpCograph =<< nat (expand graph)++printHelpCograph ::+    ( Monad m+    , HasField "help" ext Text+    ) =>+    Cofree Graph (OpGraph m (Actions ext)) ->+    IO ()+printHelpCograph gr1 = do+    let as = toList $ dirtree gr1+    let bs = toList $ helptree gr1+    traverse_ Text.putStrLn $ zipWith (\a b -> a <> " " <> b) as bs+  where+    dirtree = fmap pathText . nodeSegments . fmap node+    helptree = fmap (helpnode . node)+    helpnode x =+        case x of+            Actionless -> ""+            (Actions act) -> (extension act).help++{- | (R4) 'printHelpCograph' for a folded, and possibly rewritten, 'Dag'+rather than the declared @Cofree Graph@ — what @run tree@ prints once any+"Salmon.Op.Rewrite" phases are registered, so a batched node is shown once,+under the shorthand\/help the rewrite gave it, rather than as however many+per-package nodes it replaced.++There is no path to print: a 'Dag' is 'Ref'-keyed, not tree-shaped, so a+node reached from several declarations no longer has several positions to+list it at — it is one line, same as it is one node in the traversal that+actually runs. Each line is followed by its dependencies, indented, so the+ordering a rewrite's edges impose (e.g. removals before installs) is still+visible without a hierarchy to draw it in.+-}+printDagTree ::+    (HasField "help" ext Text) =>+    Dag ext ->+    IO ()+printDagTree dag = traverse_ Text.putStrLn (dagLines dag)++dagLines :: (HasField "help" ext Text) => Dag ext -> [Text]+dagLines dag =+    [ line+    | aref <- Dag.dagOrder dag+    , Just act <- [Dag.representativeOf dag aref]+    , line <- nodeLine aref act : depLines aref+    ]+  where+    nodeLine aref act =+        act.shorthand <> " (" <> unRef aref <> ") " <> (extension act).help+    depLines aref =+        [ "  <- " <> Maybe.maybe (unRef dref) (.shorthand) (Dag.representativeOf dag dref)+        | dref <- Dag.dependenciesOf dag aref+        ]
+ src/Salmon/Actions/Query.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Targeting 'Salmon.Actions.UpDown.upTree' (and 'run tree'/'run dag') at a+subset of an already-expanded graph, per @specs/advance-querying.md@.++A node is addressed by its tree /position/ (the same @\/initialize\/chown@+paths 'Salmon.Actions.Help.printHelpCograph' already prints), not by+identity: the same 'Ref' can occur at several paths (a shared predecessor,+e.g. a directory two files sit in). Resolving a selector is therefore always+"match paths, then take the 'Ref' at each match" — see 'resolveSelectors'.+-}+module Salmon.Actions.Query (+    -- * Patterns+    PatternSegment (..),+    parsePattern,+    matchPattern,++    -- * Resolving selectors against an expanded graph+    pathedRefs,+    pathedNodes,+    resolveSelectors,+    resolveRewrittenSelectors,++    -- * Applying an exclusion set+    forceSkip,++    -- * Human-readable output+    shortRef, -- re-exported from "Salmon.Op.Ref", where it lives+    renderAnnotated,+    printAnnotated,++    -- * Plans+    Plan (..),+    digestBytes,+) where++import Control.Comonad.Cofree (Cofree (..))+import Data.Aeson (FromJSON, ToJSON)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LByteString+import qualified Crypto.Hash.SHA256 as SHA256+import Data.Foldable (toList, traverse_)+import qualified Data.List as List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import GHC.Generics (Generic)+import Numeric (showHex)++import Salmon.Actions.Help (pathText)+import Salmon.Builtin.Extension (Extension (..), Op)+import Salmon.Op.Actions+import Salmon.Op.Graph (Graph)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.OpGraph+import Salmon.Op.Ref (Ref, shortRef, unRef)+import Salmon.Op.Rewrite (Rewritten)+import qualified Salmon.Op.Rewrite as Rewrite+import Salmon.Actions.UpDown (CheckResult (Skipped))++-------------------------------------------------------------------------------++-- | One segment of a parsed selector pattern.+data PatternSegment+    = Lit Text+    | -- | @*@: exactly one segment.+      Star+    | -- | @**@: zero or more segments (any depth, including none).+      DoubleStar+    deriving (Show, Eq)++-- | Parses a @\/a\/b\/*\/**@-style pattern into 'PatternSegment's.+parsePattern :: Text -> [PatternSegment]+parsePattern raw =+    map toSegment $ filter (not . Text.null) $ Text.splitOn "/" raw+  where+    toSegment "*" = Star+    toSegment "**" = DoubleStar+    toSegment s = Lit s++-- | Does this parsed pattern match this node path (both as segment lists)?+matchPattern :: [PatternSegment] -> [Text] -> Bool+matchPattern [] [] = True+matchPattern [] (_ : _) = False+matchPattern (DoubleStar : ps) path =+    matchPattern ps path || case path of+        [] -> False+        (_ : rest) -> matchPattern (DoubleStar : ps) rest+matchPattern (_ : _) [] = False+matchPattern (Star : ps) (_ : rest) = matchPattern ps rest+matchPattern (Lit l : ps) (seg : rest) = l == seg && matchPattern ps rest++-------------------------------------------------------------------------------++-- | Every node's path (as segments, root-to-node) paired with the 'Ref' found there.+pathedRefs :: Cofree Graph Op -> [([Text], Ref)]+pathedRefs = map (\(path, ref, _help) -> (path, ref)) . pathedNodes++-- | Like 'pathedRefs', but also carries each node's 'Salmon.Builtin.Extension.help' text.+pathedNodes :: Cofree Graph Op -> [([Text], Ref, Text)]+pathedNodes = go []+  where+    go :: [Text] -> Cofree Graph Op -> [([Text], Ref, Text)]+    go pfx (x :< g) =+        case x.node of+            Actionless -> concatMap (go pfx) (toList g)+            Actions act ->+                let path = pfx <> [shorthand act]+                 in (path, act.extension.ref, act.extension.help) : concatMap (go path) (toList g)++-------------------------------------------------------------------------------++-- | @resolveSelectors cograph selectPatterns excludePatterns@: @(selected, excluded)@.+resolveSelectors ::+    Cofree Graph Op ->+    [Text] ->+    [Text] ->+    (Set Ref, Set Ref)+resolveSelectors cograph selectPatterns excludePatterns =+    (selected, excluded)+  where+    entries = pathedRefs cograph+    matches pats = Set.fromList [ref | (path, ref) <- entries, pat <- map parsePattern pats, matchPattern pat path]+    allRefs = Set.fromList (map snd entries)+    selectedBase = if null selectPatterns then allRefs else matches selectPatterns+    excluded = matches excludePatterns+    selected = selectedBase `Set.difference` excluded++{- | Like 'resolveSelectors', but rewrite-aware (see @specs\/advance-querying.md@+and (R4) in @specs\/per-node-state-machines-remaining.md@): a pattern is+resolved as a path glob against the /declared/ @cograph@ exactly as before,+__except__ one beginning with @#@, which instead matches by 'Ref' — either a+declared node's own, or (via 'Salmon.Op.Rewrite.membersOf') a+rewrite-introduced node's, expanded back to the declared nodes it stands in+for.++That fallback exists because a path glob fundamentally cannot address a+rewrite-introduced node (a package-install batch, say): such a node was+never declared, so it has no position in @cograph@ for a pattern to match —+it only exists in 'computed', produced after the fold. Its 'Ref' is the one+thing about it a pattern /can/ name, and it is exactly the text+'shortRef'\/'renderAnnotated' already print (the @#@ prefix mirrors+'renderAnnotated's own @" #" <> shortRef ref@ disambiguation suffix, so what+a render prints can be pasted straight back in as a selector). A fragment+matches as a prefix of either the short or the full 'Ref' text, so an+operator can paste the short form from a tree\/dag render or a longer,+disambiguating chunk of a full ref if a short one turns out ambiguous.++Every result is still a __declared__ 'Ref' set — this does not change what+'query plan'\/'query show' consume, since 'run up'/'run down''s+@phaseIgnored@ and 'Salmon.Op.Rewrite.collectDynamic' are both keyed on+declared refs. Addressing a batch by its own ref is therefore equivalent to+addressing every declared node it was built from — excluding \"the batch\"+/is/ excluding all 20 packages that went into it, which is the only+coherent meaning a plan (a set of declared exclusions consulted /before/ any+rewrite runs) can give it.+-}+resolveRewrittenSelectors ::+    Cofree Graph Op ->+    Rewritten Extension ->+    [Text] ->+    [Text] ->+    (Set Ref, Set Ref)+resolveRewrittenSelectors cograph computed selectPatterns excludePatterns =+    (selected, excluded)+  where+    entries = pathedRefs cograph+    allRefs = Set.fromList (map snd entries)++    (selRefPats, selPathPats) = List.partition isRefPattern selectPatterns+    (excRefPats, excPathPats) = List.partition isRefPattern excludePatterns++    matchesOf :: [Text] -> [Text] -> Set Ref+    matchesOf pathPats refPats =+        Set.fromList [ref | (path, ref) <- entries, pat <- map parsePattern pathPats, matchPattern pat path]+            `Set.union` Set.unions (map matchRefPattern refPats)++    -- an empty select list still means "everything", exactly as+    -- 'resolveSelectors' — checked against the *combined* pattern list, not+    -- just its path half, or a select made of nothing but '#'-patterns+    -- would silently widen to "everything" instead of narrowing to what was+    -- actually asked for.+    selectedBase = if null selectPatterns then allRefs else matchesOf selPathPats selRefPats+    excluded = matchesOf excPathPats excRefPats+    selected = selectedBase `Set.difference` excluded++    isRefPattern :: Text -> Bool+    isRefPattern = Text.isPrefixOf "#"++    -- every declared 'Ref' a '#'-pattern resolves to: its direct matches+    -- among declared nodes, plus every declared member of a matching+    -- computed (rewrite-introduced) node.+    matchRefPattern :: Text -> Set Ref+    matchRefPattern pat = declaredHits `Set.union` viaComputed+      where+        fragment = Text.drop 1 pat+        declaredHits = Set.fromList [ref | (_, ref) <- entries, matchesRefFragment fragment ref]+        computedHits = [cref | cref <- Map.keys (Dag.dagNodes computed.computedDag), matchesRefFragment fragment cref]+        viaComputed = Set.unions (map (Rewrite.membersOf computed) computedHits)++    matchesRefFragment :: Text -> Ref -> Bool+    matchesRefFragment fragment ref = fragment `Text.isPrefixOf` shortRef ref || fragment `Text.isPrefixOf` unRef ref++-------------------------------------------------------------------------------++{- | Rewrites every node whose 'Salmon.Op.Ref.Ref' is in the given set so its+'Salmon.Builtin.Extension.check' unconditionally reports 'Skipped',+leaving 'up'/'down'/'ref'/'dynamics' and the graph topology untouched.+This is the one producer of 'Skipped': it is a statement about a decision+made over the node, not about the node's effect.+Relies on 'OpGraph's derived 'Functor' recursing through the effectful+'predecessors' field (works because 'Op's @meval@ is 'Data.Functor.Identity',+itself a 'Functor') and on 'Actions'' own 'Functor' instance over its+extension type.+-}+forceSkip :: Set Ref -> Op -> Op+forceSkip refs = fmap (fmap rewrite)+  where+    rewrite :: Extension -> Extension+    rewrite ext+        | ext.ref `Set.member` refs = ext{check = pure Skipped}+        | otherwise = ext++-------------------------------------------------------------------------------++{- | Mirrors 'Salmon.Actions.Help.printHelpCograph', annotating matched paths.++@dedupe@: the same 'Ref' can occur at several paths (a shared predecessor); when+'True', only its first-encountered occurrence is printed instead of one line per+path. @showDescriptions@: when 'True', a node's 'Salmon.Builtin.Extension.help'+text (if non-empty) is printed on its own indented line right below the node's+path, prefixed with @"  # "@.++Path text alone doesn't always identify a node: sibling nodes built with the+same 'Salmon.Builtin.Extension.ShortHand' (e.g. several migration files each+going through the same @pg-script@ builder) render the exact same path text+while carrying distinct 'Ref's. Every occurrence of such a colliding path+(post-dedupe) is suffixed with @" #" <> 'shortRef' ref@ — stable across runs+and independent of traversal order, unlike an incrementing counter — so the+repeats are visibly distinguished instead of looking like accidental+duplicates.+-}+printAnnotated :: Cofree Graph Op -> Set Ref -> Set Ref -> Bool -> Bool -> IO ()+printAnnotated cograph selected excluded dedupe showDescriptions =+    traverse_ Text.putStrLn (renderAnnotated cograph selected excluded dedupe showDescriptions)++-- | Pure line-rendering behind 'printAnnotated' (kept separate so it's testable without IO capture).+renderAnnotated :: Cofree Graph Op -> Set Ref -> Set Ref -> Bool -> Bool -> [Text]+renderAnnotated cograph selected excluded dedupe showDescriptions =+    concatMap render entries+  where+    entries+        | dedupe = dedupeBy (\(_, ref, _) -> ref) (pathedNodes cograph)+        | otherwise = pathedNodes cograph++    -- how many (post-dedupe) entries render to this exact path text; >1 means it needs disambiguating.+    pathCounts :: Map Text Int+    pathCounts = Map.fromListWith (+) [(pathText path, 1 :: Int) | (path, _, _) <- entries]++    render :: ([Text], Ref, Text) -> [Text]+    render (path, ref, help) = line : descLine+      where+        key = pathText path+        collides = Map.findWithDefault 0 key pathCounts > 1+        line = key <> (if collides then " #" <> shortRef ref else "") <> annotation ref+        descLine = ["  # " <> help | showDescriptions && not (Text.null help)]++    annotation ref+        | ref `Set.member` excluded = " [excluded]"+        | ref `Set.member` selected = " [selected]"+        | otherwise = ""++dedupeBy :: (Ord b) => (a -> b) -> [a] -> [a]+dedupeBy f = go Set.empty+  where+    go _ [] = []+    go seen (x : xs)+        | f x `Set.member` seen = go seen xs+        | otherwise = x : go (Set.insert (f x) seen) xs++-------------------------------------------------------------------------------++{- | An exclusion plan resolved against one specific directive.++'planDirective' is populated only when @query plan@ is run with+@--embed-directive@ — by default a plan is a small companion file that+travels alongside its directive (checked via 'planDirectiveDigest'), not a+copy of it. Embedding is for the case where you want the plan itself to be a+standalone, replayable artifact (e.g. archived for an audit trail); recover+the embedded bytes with @query extract-directive@ rather than reading this+field directly, so a caller never has to care whether a given plan carries+one.+-}+data Plan = Plan+    { planDirectiveDigest :: Text+    , planExcludedRefs :: [Ref]+    , planExcludedPatterns :: [Text]+    , planDirective :: Maybe Text+    }+    deriving (Show, Eq, Generic)++instance ToJSON Plan+instance FromJSON Plan++{- | sha256 of raw bytes, hex-encoded. Callers must hash the exact bytes read+off stdin, never a re-'Data.Aeson.encode'd value (aeson gives no+cross-invocation guarantee that decode-then-re-encode round-trips byte for+byte).+-}+digestBytes :: LByteString.ByteString -> Text+digestBytes = Text.concat . map hex . ByteString.unpack . SHA256.hashlazy+  where+    hex w =+        let s = showHex w ""+         in Text.pack (if length s == 1 then '0' : s else s)
+ src/Salmon/Actions/Serve.hs view
@@ -0,0 +1,2811 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | A long-running convergence loop, fed a stream of seeds.++Where @run up@ is a one-shot "expand this one directive and walk it once",+'serve' keeps a 'World' around: a set of seeds that have been declared, the+graphs those seeds evaluated to, and — unified across all of them by 'Ref' —+a per-node 'NodeState' saying which 'Direction' that node is wanted in and+whether it has 'Converged' there yet.++The unit of input is a /declaration/: a seed, plus what to do with it (see+'ServeCommand'). Declaring a seed evaluates it and folds the result into two+structures: 'worldMagma', one representative per node keyed by 'Ref' (what+each node /is/), and 'worldLedger', a "Salmon.Op.Ledger" entry per+declaration saying which nodes and which precedence edges that declaration+asks for. A @down@ retracts its entry rather than deleting it, because a+retracted declaration's /edges/ are exactly what says what order to take its+nodes down in. From the ledger everything else is derived:++  * a node some live declaration asks for is wanted 'TurnUp';+  * a node this world still tracks and no live declaration still asks for is+    wanted 'TurnDown';+  * flipping a node's direction resets it to 'Pending', so it gets applied+    again in the new direction.++An 'Epoch' — the seed, the directive, and the graph it evaluated to — is+kept only while its declaration is live, because the only thing still needing+a graph is the up pass. The teardown works off the magma and the ledger, so+storage is bounded by node count and by how many declarations are live or+retiring, not by the shape of what has been declared.++Convergence then runs — after every declaration, and on demand via+@converge@ — as one teardown pass followed by one bring-up pass, each of+which is just "Salmon.Actions.UpDown".'UpDown.downTreeWith' /+'UpDown.upTreeWith' over the relevant graphs with a 'UpDown.Gate' that+filters down to the nodes wanted in that pass and not yet converged. The+dependency ordering, the dedup-by-'Ref', and the "a failed node blocks+whatever depended on it" containment therefore behave exactly as they do for+@run up@ / @run down@; the only thing this module adds on top is the memory+of what has already been done. Nodes that end a pass 'Errored' or 'Blocked'+stay non-converged and are retried by the next pass.++That memory is bounded, which matters for a process meant to stay up: a+node leaves when it has settled down, a contribution leaves once none of its+nodes is still on its way down, and an epoch leaves as soon as its+declaration is retired or superseded. 'resettle' collects after every+declaration and every convergence; see 'prune' for the rules. What survives collection is+'worldLog', one small line per declaration ever made, which is what+@history@ prints — so the record of /what was declared/ outlives the graphs+that were declared.++== Between passes, the nodes are tended++A convergence pass is one attempt at whatever is outstanding, and then it is+over. That leaves a gap this loop used to have no answer for: an effect that+goes away on its own — a service that dies, a file something else deletes —+is not noticed until somebody types @converge@.++So while this loop is idle, every node it knows has a machine of its own+("Salmon.Actions.Upkeep"), running in whatever direction the node is wanted.+A node wanted up rechecks its own effect on an adaptive delay and runs @up@+again if it has gone; a node wanted down retries its @down@ until it works,+then stops.++/Idle/ is exactly the condition, and it is 'loop' that enforces it: the+machines start when nothing is waiting in the input and stand down before any+command is handled (stopping /waits for/ an @up@ or @down@ in flight rather+than interrupting one, since a half-applied effect is worse than a slow+command). Two things fall out, and the second is the reason:++  * a piped script has every line, end-of-input included, queued before the+    first pass finishes, so it is never supervised at all — @serve \< script@+    stays a deterministic sequence of passes;+  * there is nothing to race. Starting machines and then stopping them+    because a command had been sitting in the queue all along would make+    "was this node acted on?" depend on thread timing.++@supervise off@ stops them for good and leaves every effect exactly as it is:+@off@ is not a teardown. Note also that a restricted @converge --select@+scopes the /pass/, not the standing watch — a node the pass skipped is still+tended once the loop goes idle.++== Where the lines come from++The loop reads one inbox. What fills it is a list of 'Producer's, each on a+thread of its own, each pushing 'Line's tagged with the 'Origin' that typed+them; 'serveWith' is the one-producer case, standard input, and behaves+exactly as it did when the loop read a 'Handle' directly. The inbox is still+the loop's whole notion of idle — machines are tended while it is empty and+stand down before any command, whoever typed it — and a piped script is+still every line queued before the first pass ends. Two producers+interleave at line granularity and nothing more: a command is handled whole+before the next is read, and the order in which two producers' lines land+in the inbox is the order they are handled.++One decision is new with the list. /Only standard input's end of input ends+the loop./ Any other producer's 'Eof' is not a command — nothing is about to+act, so the machines are not stood down for it — and the loop reads on; a+socket client hanging up or a fetcher going quiet must not take the server+with it. A loop with no 'Stdin' producer at all therefore ends only on+@quit@. Such a producer hanging up is reported, as 'HungUp', at the moment+the loop reads its 'Eof' — which, the inbox being one queue, is after every+line it typed has been handled. Whoever holds a connection for that origin+can close it on that report and know nothing typed on it is still pending.++== Whose report is it++A report emitted while a command is handled belongs to whoever typed the+command; one emitted between commands (the tending machines' own) belongs+to nobody in particular. 'serveAttributed' says which, by stamping every+report with the 'Origin' of the line being handled — 'Nothing' outside a+command — through 'Attributed'. That is what lets a second client be+answered on its own connection rather than on the loop's standard output+("Salmon.Actions.Serve.Socket"); 'serveProducers' is the same loop with the+stamp thrown away.++This is what replaced @serveWakingWith@, an "these nodes want attention" hook+nothing in the repo ever drove. It was there because a node had no state of+its own to block on; now one does, so the hook is not a smaller version of+this — it is unnecessary. Restart policy and watchdogs are per-node and live+in "Salmon.Op.Supervision".+-}+module Salmon.Actions.Serve (+    -- * Running+    serve,+    serveWith,+    serveProducers,+    serveAttributed,+    serveFollowing,+    serveObserved,+    Followed (..),+    AppliedDocument (..),+    Mode (..),+    renderMode,++    -- * Input producers+    Producer (..),+    Line (..),+    Origin (..),+    Provenance (..),+    renderOrigin,+    originName,+    handleProducer,+    stdinProducer,++    -- * Attributing reports+    Attributed (..),++    -- * Input language+    ServeCommand (..),+    Declaration (..),+    Selection (..),+    noSelection,+    Topic,+    parseServeCommand,+    parseSelection,+    tokenize,++    -- * World state+    World (..),+    Collision (..),+    emptyWorld,+    Epoch (..),+    EpochId (..),+    LogEntry (..),+    worldLogLimit,+    NodeState (..),+    Direction (..),+    Convergence (..),++    -- * Reading a world+    worldDag,+    worldPaths,+    historyLinesMatching,++    -- * Reporting+    Report (..),+    reportText,+    renderReport,+) where++import Control.Comonad.Cofree (Cofree)+import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.STM (TChan, TVar, atomically, isEmptyTChan, newTChanIO, readTChan, writeTChan)+import Control.Exception (IOException, SomeException, finally, try)+import Control.Monad (forM_, unless, when)+import Data.Aeson (FromJSON (..), ToJSON (..), Value, eitherDecode, encode, object, withObject, (.:), (.=))+import Data.Aeson.Types (parseEither)+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as LByteString+import Data.Char (isSpace)+import Data.Foldable (traverse_)+import Data.Maybe (isJust)+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)+import Data.List (nub, sortOn)+import qualified Data.List as List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.Time.Clock (UTCTime)+import System.IO (Handle, hFlush, hGetLine, hIsEOF, stdout)++import qualified Salmon.Actions.Query as Query+import qualified Salmon.Actions.Concurrent as Concurrent+import qualified Salmon.Actions.UpDown as UpDown+import Salmon.Actions.UpDown (Requirement (..))+-- imported with their field selectors: OverloadedRecordDot only solves+-- HasField for fields that are in scope.+import Salmon.Builtin.Extension (Extension (..), Op, Track', evalDeps)+import Salmon.Op.Actions (Act (..), ShortHand)+import Salmon.Op.Concurrency (ConcurrencyLimit)+import Salmon.Op.Configure (Configure, gen)+import Salmon.Op.Graph (Graph)+import Salmon.Op.Dag (Dag)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Ledger (Ledger)+import qualified Salmon.Op.Ledger as Ledger+import qualified Salmon.Op.Mailbox as Mailbox+import Salmon.Op.Ref (Ref, unRef)+import Salmon.Op.Rewrite (Phase (..), Rewrite, Rewritten)+import qualified Salmon.Op.Rewrite as Rewrite+-- 'Direction' used to be declared here, identically. It belongs with the+-- per-node state now that a node has state of its own, and is re-exported+-- from this module so nothing that named 'Serve.TurnUp' had to change.+import Salmon.Op.Status (Direction (..))+import qualified Salmon.Op.Status as MachineStatus+import Salmon.Op.Supervision (Micros (..))+import Salmon.Op.Track (run)+import Salmon.Reporter+import qualified Salmon.Actions.Upkeep as Upkeep++-------------------------------------------------------------------------------++-- | How far a node is from its wanted 'Direction'.+data Convergence+    = -- | never applied in the current direction (new node, or the+      -- direction just flipped under it)+      Pending+    | -- | (I6): was 'Converged', but a later declaration replaced this+      -- 'Ref''s representative with one 'Dag.sameRepresentative' calls+      -- different — so what it means to be converged may have changed too.+      -- Treated exactly like 'Pending' by 'gateFor' (anything but+      -- 'Converged' is worth a pass's attention): the node is handed to+      -- 'UpDown.upDag' again, which asks its own @check@ before doing+      -- anything, same as ever. A node with a content-comparing @check@+      -- (e.g. 'Salmon.Builtin.Nodes.Filesystem.filecontents') settles+      -- straight back to 'Converged' at the cost of one @check@ if the new+      -- declaration didn't actually change what it writes; a node with no+      -- @check@ gets exactly what it already gets under a bare 'Pending' —+      -- an unconditional @up@, which the idempotency convention every node+      -- author is already asked to follow makes safe. Kept as its own+      -- constructor rather than folded into 'Pending' so @status@ can tell+      -- "never touched" from "was up, now re-verifying".+      Stale+    | -- | applied in the current direction, or found to already be there+      Converged+    | -- | the last attempt threw; will be retried+      Errored+    | -- | the last attempt never ran because a neighbour failed; will be retried+      Blocked+    deriving (Show, Eq, Ord)++{- | What 'serve' remembers about one node of the unified graph. Keyed by+'Ref', so the same node reached through several seeds' graphs is one entry.+-}+data NodeState = NodeState+    { nodeShorthand :: !ShortHand+    , nodeHelp :: !Text+    , nodeDirection :: !Direction+    , nodeConvergence :: !Convergence+    , nodeStatus :: !(Maybe MachineStatus.Status)+    -- ^ (R3). What this node's machine last had to say for itself: its own+    -- 'Salmon.Actions.UpDown.CheckResult', how long ago it last did+    -- anything observable, and its ring of output — the same 'Status' a+    -- machine's neighbours block on while tending is running, snapshotted+    -- by 'stopTending' at the one moment it is readable from outside: after+    -- the machine has stood down (or been detached into+    -- 'Salmon.Actions.Upkeep.Kept') but before the 'Upkeep.Supervisor'+    -- holding its 'TVar' is dropped. 'Nothing' for a node that has never+    -- been tended — declared while supervision is off, or not yet reached+    -- by a first idle pass.+    --+    -- Freshness rides the existing rhythm rather than adding one: every+    -- command runs 'stopTending' first (see 'loop'), so a node that /was/+    -- tended has a snapshot from mere moments before whatever just read it.+    -- A holding machine is adopted back into the next 'Upkeep.Supervisor'+    -- the next time tending starts, which is what keeps its snapshot+    -- refreshing across commands too, rather than freezing at whenever it+    -- first started holding.+    }+    deriving (Show)++newtype EpochId = EpochId {unEpochId :: Int}+    deriving (Show, Eq, Ord)++{- | One declaration, and everything derived from it at the time it was made.++An epoch is kept only while its declaration is /live/, because the only thing+it is still needed for is @--select@ resolution, which is about active seeds+and needs the graph's paths rather than the magma's nodes. What a retired declaration leaves+behind is its 'Ledger.Contribution' — two flat sets — plus its nodes in+'worldMagma', which is all a teardown needs and is bounded by node count+rather than by graph shape. Re-declaring the same seed appends a new epoch+and 'prune' drops the superseded one; 'worldLog' remembers that it happened.+-}+data Epoch seed directive = Epoch+    { epochId :: !EpochId+    , epochDeclaration :: !Declaration+    , epochDirection :: !Direction+    , -- | who made this declaration: typed, loaded from a file, or fetched+      -- from a registry. Kept for @history@.+      epochOrigin :: !Origin+    , -- | the argv this seed was declared with, kept for @history@; a+      -- directive-file declaration (@up-directive@ and friends) gets a+      -- synthetic @["<directive-file>", path]@ here instead.+      epochTokens :: [String]+    , -- | 'Nothing' when this epoch was declared straight from a directive+      -- file, which has no seed to keep.+      epochSeed :: Maybe seed+    , epochDirective :: directive+    , -- | identity of the seed for the active set: its encoded directive, so+      -- that two spellings of the same desired state are one active seed+      epochKey :: !ByteString+    , -- | the graph as evaluated when the seed was declared. The one thing+      -- left that needs a graph rather than the magma: @--select@ resolves+      -- path patterns, and a 'Dag' has 'Ref's and edges but no paths.+      epochGraph :: Cofree Graph Op+    }++{- | What @history@ prints, and all that is kept of an 'Epoch' once 'prune'+has collected it. Deliberately small — no graph, no seed, no directive —+which is what makes it affordable to keep long after the epoch itself is+gone. 'logRefs' is the one non-trivial field: the node set the declaration+contributed, kept so @history --select@ still answers for a collected epoch.+-}+data LogEntry = LogEntry+    { logEpoch :: !EpochId+    , logDeclaration :: !Declaration+    , logOrigin :: !Origin+    , logTokens :: [String]+    , logRefs :: !(Set Ref)+    }+    deriving (Show)++-- | How many declarations 'worldLog' remembers.+worldLogLimit :: Int+worldLogLimit = 1000++data World seed directive = World+    { worldNextId :: !Int+    , -- | the epochs whose graphs a future pass could still walk — the+      -- active ones, plus retired ones that still describe a node to turn+      -- down. Newest first; collected by 'prune'.+      worldEpochs :: [Epoch seed directive]+    , -- | one line per declaration ever made, newest first, outliving the+      -- epoch's graph. Capped at 'worldLogLimit'.+      worldLog :: [LogEntry]+    , -- | declarations that have fallen off the end of 'worldLog'+      worldLogDropped :: !Int+    , -- | which declarations still want which nodes and edges — live ones+      -- (what should be up) and retiring ones (whose edges are still the+      -- only description of what order to take their nodes down in). Keyed+      -- by 'epochKey', so two spellings of one desired state are one entry.+      -- This is what replaced keeping a retired seed's whole graph.+      worldLedger :: !(Ledger ByteString)+    , -- | one representative per node, merged across every declaration that+      -- has mentioned it (last writer wins, see "Salmon.Op.Dag"). Holds what+      -- a node /is/ — its @up@\/@check@\/@down@ — where 'worldNodes' holds+      -- where it has got to. Never an 'Op': that would retain the whole+      -- expanded closure and bound nothing.+      worldMagma :: !(Map Ref (Act Extension))+    , -- | the nodes whose current representative won a collision that is+      -- still standing: what @\/dag@ shows beside such a node so a client+      -- that did not catch the pass's 'UpDown.Conflicting' can still show+      -- the pair. See 'Collision' for when an entry appears and goes.+      worldConflicts :: !(Map Ref Collision)+    , -- | every node still being managed or still to be torn down, unified+      -- by 'Ref'. A node that has converged 'TurnDown' is finished and is+      -- dropped, so a fully retired world settles empty.+      worldNodes :: Map Ref NodeState+    }++{- | The machines currently tending this world's nodes, and whether they are+wanted at all.++Deliberately not part of 'World': a 'World' is a pure value this module hands+back to its caller, and a running 'Upkeep.Supervisor' is neither pure nor+meaningful once 'serve' has returned.+-}+data Tending = Tending+    { tendingSup :: !(IORef (Maybe (Upkeep.Supervisor Extension)))+    , tendingKept :: !(IORef (Upkeep.Kept Extension))+    -- ^ machines still holding a 'Salmon.Builtin.Extension.managed' effect+    -- up, between one supervisor and the next. These outlive a command+    -- precisely because stopping a supervisor means "stop tending", and a+    -- @status@ that killed every service would be a poor reading of that.+    -- See 'Salmon.Actions.Upkeep.Kept'.+    , tendingOn :: !(IORef Bool)+    -- ^ @supervise off@ clears this; nothing is tended between passes, and+    -- @serve@ behaves as it did before per-node machines existed.+    , tendingAutoConverge :: !(IORef Bool)+    -- ^ @autoconverge off@ clears this: a declaring command+    -- (@up@\/@only@\/@down@\/@clear@\/the @-directive@ forms) still records+    -- the epoch and updates 'worldNodes'/'worldLedger' as usual, but the+    -- convergence pass that would otherwise follow it immediately is+    -- skipped, leaving whatever @status@\/@query@ already show unchanged+    -- until an explicit @converge@. On by default, matching every existing+    -- caller's behaviour.+    , tendingPending :: !(IORef (Map Ref [Mailbox.Instruction]))+    -- ^ (R2). instructions an operator posted while no supervisor was+    -- running to hand them to. A one-shot machine does not survive a+    -- command the way a holding one does (see 'tendingKept'), so+    -- @force@\/@recheck@\/@pause@\/@resume@ cannot post straight into a+    -- mailbox that is about to be discarded — 'startTending' delivers these+    -- the moment the /next/ supervisor's machines exist (both freshly+    -- started and adopted), then clears the queue. "Force this node next+    -- time you look at it" rather than keeping every one-shot machine alive+    -- just so it has a mailbox to post into.+    }++{- | A representative that lost to the magma's current one, kept for as+long as somebody still wants the loser's version.++Two kinds of collision land here, through 'record'. One is inside a single+declaration: the graph reaches one 'Ref' from two differently-described+nodes, which is 'Dag.dagConflicts' and has always been reported+'UpDown.Conflicting' at declare time. The other is /across/ declarations:+this declaration describes a 'Ref' differently from what the magma holds,+and another live declaration still wants that 'Ref' — two seeds colliding+on one node, which last-writer-wins resolves silently otherwise (the same+key re-declared with a change is not a collision but (I6)'s 'Stale').++'collisionHolders' is who was standing on the losing side — the other live+declarations for the cross kind, the declaration itself for the inside kind+— and is what keeps the entry honest without keeping every declaration's+representative around: a re-declaration that leaves the magma's+representative as it is keeps the entry while a holder is still live, a+re-declaration that changes it recomputes, and 'prune' drops an entry whose+holders have all retired or whose node has left the magma.+-}+data Collision = Collision+    { collisionConflict :: !(Dag.Conflict Extension)+    -- ^ 'Dag.conflictKept' is the magma's representative at the time of+    -- the write, 'Dag.conflictReplaced' the one it beat+    , collisionHolders :: !(Set ByteString)+    -- ^ 'epochKey's of the declarations on the losing side+    }++emptyWorld :: World seed directive+emptyWorld = World 0 [] [] 0 Ledger.emptyLedger Map.empty Map.empty Map.empty++-------------------------------------------------------------------------------++-- | What declaring a seed does to the active set.+data Declaration+    = -- | @up@: add this seed to the active set+      Add+    | -- | @only@: make this seed the whole active set, retiring the others+      Replace+    | -- | @down@: retire this seed+      Remove+    deriving (Show, Eq, Ord)++{- | A pair of select\/exclude path-patterns, understood the same way as+"Salmon.Actions.Query" ('Query.parsePattern'\/'Query.matchPattern'). An empty+'selSelect' means "everything" (mirrors 'Query.resolveSelectors'); an empty+'selExclude' subtracts nothing. 'noSelection' is both empty, and is what a+bare @status@\/@history@\/@converge@\/@query@ (no @--select@\/@--exclude@ at+all) parses to.+-}+data Selection = Selection+    { selSelect :: ![Text]+    , selExclude :: ![Text]+    }+    deriving (Show, Eq)++noSelection :: Selection+noSelection = Selection [] []++data ServeCommand+    = Declare !Declaration ![String]+    | -- | @up-directive@\/@only-directive@\/@down-directive@: declare a seed+      -- straight from a directive JSON file, skipping seed-arg parsing.+      DeclareDirective !Declaration !FilePath+    | -- | the same declaration with the directive's JSON already in hand+      -- rather than in a file. Not spelled by any line of the input language+      -- ('parseServeCommand' never produces it); it exists for a producer+      -- that holds a document with a directive in it ("Salmon.Actions.Follow")+      -- and would otherwise have to write that directive to a file to name+      -- it. The 'Text' is what @history@ prints in place of an argv.+      DeclareInline !Declaration !Text !Value+    | -- | @load@: run a file of serve-command lines, in order, as if typed.+      Load !FilePath+    | -- | @clear@: retire every seed (everything known goes down)+      Clear+    | -- | @converge@: re-attempt whatever has not converged; a non-empty+      -- 'Selection' restricts this one pass to matching nodes only.+      Converge !Selection+    | Status !Selection+    | History !Selection+    | -- | @query@: annotate the world's nodes with a 'Selection', without+      -- acting on anything.+      QueryCmd !Selection+    | -- | @supervise on@\/@supervise off@: whether to keep tending nodes+      -- between convergence passes. On by default.+      Supervise !Bool+    | -- | @autoconverge on@\/@autoconverge off@: whether a declaring+      -- command (@up@\/@only@\/@down@\/@clear@\/the @-directive@ forms)+      -- triggers a convergence pass on its own. On by default; @off@ lets+      -- several declarations (or an inspection via @status@\/@query@) sit+      -- between the declaration and an explicit @converge@.+      AutoConverge !Bool+    | -- | @force@\/@recheck@\/@pause@\/@resume@ [--select P]... [--exclude+      -- P]...: queue a 'Mailbox.Instruction' for the matching nodes, to be+      -- delivered the next time this world's nodes are tended (R2). An+      -- empty selection means every node, same as @status@\/@query@.+      Instruct !Mailbox.Instruction !Selection+    | -- | @fetch@: ask the fetcher ("Salmon.Actions.Follow") for a round+      -- now — its ladder forgotten, whatever it has pending injected as soon+      -- as the round is over — rather than at its next scheduled one. The+      -- loop cannot call into a producer, so it pulls a hook 'serveFollowing'+      -- was given; without one, nothing is being followed and it says so.+      Fetch+    | -- | @help@\/@help TOPIC@: print the command reference, or (when+      -- 'Just' a recognised 'Topic') a lengthier explanation of just that+      -- one command. 'Nothing', or a topic 'lookupTopic' doesn't recognise,+      -- both fall back to the same full reference.+      Help !(Maybe Topic)+    | Quit+    | -- | blank line or comment+      Noop+    deriving (Show, Eq)++-- | A @help@ argument, matched case-insensitively against 'helpTopics'.+type Topic = Text++declarationDirection :: Declaration -> Direction+declarationDirection Add = TurnUp+declarationDirection Replace = TurnUp+declarationDirection Remove = TurnDown++{- | Parse one line of 'serve' input: a command word followed, for the+declaring commands, by the seed's own command-line arguments.+-}+parseServeCommand :: String -> Either Text ServeCommand+parseServeCommand line =+    case dropWhile isSpace line of+        [] -> Right Noop+        ('#' : _) -> Right Noop+        _ -> dispatch =<< tokenize line+  where+    dispatch toks =+        case toks of+            [] -> Right Noop+            (w : args) ->+                case w of+                    "up" -> Right (Declare Add args)+                    "only" -> Right (Declare Replace args)+                    "down" -> Right (Declare Remove args)+                    "up-directive" -> onlyFile w args (DeclareDirective Add)+                    "only-directive" -> onlyFile w args (DeclareDirective Replace)+                    "down-directive" -> onlyFile w args (DeclareDirective Remove)+                    "load" -> onlyFile w args Load+                    "clear" -> nullary w args Clear+                    "converge" -> Converge <$> parseSelection args+                    "status" -> Status <$> parseSelection args+                    "history" -> History <$> parseSelection args+                    "query" -> QueryCmd <$> parseSelection args+                    "supervise" -> onOff w args Supervise+                    "autoconverge" -> onOff w args AutoConverge+                    "force" -> Instruct Mailbox.Force <$> parseSelection args+                    "recheck" -> Instruct Mailbox.Recheck <$> parseSelection args+                    "pause" -> Instruct Mailbox.Pause <$> parseSelection args+                    "resume" -> Instruct Mailbox.Resume <$> parseSelection args+                    "fetch" -> nullary w args Fetch+                    "help" -> Help <$> helpTopic w args+                    "?" -> Help <$> helpTopic w args+                    "quit" -> nullary w args Quit+                    "exit" -> nullary w args Quit+                    _ -> Left ("unknown command: " <> Text.pack w)++    nullary w args cmd+        | null args = Right cmd+        | otherwise = Left (Text.pack w <> " takes no argument")++    helpTopic w args =+        case args of+            [] -> Right Nothing+            [t] -> Right (Just (Text.pack t))+            _ -> Left (Text.pack w <> " takes at most one topic argument")++    onlyFile w args mk =+        case args of+            [path] -> Right (mk path)+            _ -> Left (Text.pack w <> " takes exactly one file argument")++    onOff w args mk =+        case args of+            ["on"] -> Right (mk True)+            ["off"] -> Right (mk False)+            _ -> Left (Text.pack w <> " takes exactly one of `on` or `off`")++{- | Scans a token list for repeated @--select PATTERN@\/@--exclude+PATTERN@ pairs, shared by @query@\/@status@\/@history@\/@converge@.+-}+parseSelection :: [String] -> Either Text Selection+parseSelection = go [] []+  where+    go sel exc [] = Right (Selection (reverse sel) (reverse exc))+    go sel exc ("--select" : p : rest) = go (Text.pack p : sel) exc rest+    go sel exc ("--exclude" : p : rest) = go sel (Text.pack p : exc) rest+    go _ _ ["--select"] = Left "--select needs a PATTERN argument"+    go _ _ ["--exclude"] = Left "--exclude needs a PATTERN argument"+    go _ _ (w : _) = Left ("unrecognized argument: " <> Text.pack w)++{- | Split a line into argv-style tokens, honouring single quotes, double+quotes and backslash escapes, so a seed can carry values with spaces in them.+-}+tokenize :: String -> Either Text [String]+tokenize = outside []+  where+    outside toks s =+        case s of+            [] -> Right (reverse toks)+            (c : cs)+                | isSpace c -> outside toks cs+                | otherwise -> word toks "" (c : cs)++    word toks cur s =+        case s of+            [] -> Right (reverse (reverse cur : toks))+            (c : cs)+                | isSpace c -> outside (reverse cur : toks) cs+                | c == '\\' -> escape (word toks) cur cs+                | c == '\'' -> quoted '\'' toks cur cs+                | c == '"' -> quoted '"' toks cur cs+                | otherwise -> word toks (c : cur) cs++    quoted q toks cur s =+        case s of+            [] -> Left "unterminated quote"+            (c : cs)+                | c == q -> word toks cur cs+                | c == '\\' && q == '"' -> escape (quoted q toks) cur cs+                | otherwise -> quoted q toks (c : cur) cs++    escape k cur s =+        case s of+            (d : ds) -> k (d : cur) ds+            [] -> Left "trailing backslash"++-------------------------------------------------------------------------------++data Report+    = Started+    | -- | input closed+      Stopped+    | -- | a producer other than standard input has no more lines, and every+      -- line it did have has been handled. Never for 'Stdin', whose end of+      -- input is 'Stopped'.+      HungUp !Origin+    | BadCommand !Text+    | BadSeed !Text+    | BadDirective !Text+    | -- | reading a @load@ file failed, or its nesting was too deep+      BadLoad !Text+    | Loading !FilePath+    | -- | lines run from a @load@ file+      LoadDone !FilePath !Int+    | -- | epoch, direction, nodes in its graph, live declarations afterwards+      Declared !EpochId !Direction !Int !Int+    | -- | number of seeds retired+      Cleared !Int+    | -- | @supervise on@\/@supervise off@+      Supervised !Bool+    | -- | @autoconverge on@\/@autoconverge off@+      AutoConverged !Bool+    | -- | (R2). a @force@\/@recheck@\/@pause@\/@resume@ was queued for this+      -- many nodes; takes effect once tending next starts, not immediately+      Instructed !Mailbox.Instruction !Int+    | -- | @fetch@: whether anything is being followed (a round was asked+      -- for), or not (nothing to ask)+      FetchRequested !Bool+    | -- | something a node's own machine had to say between convergence+      -- passes. See 'Salmon.Actions.Upkeep.Report'; the chatty half of that+      -- stream is filtered out before it reaches here.+      Tended !(Upkeep.Report Extension)+    | -- | nodes to turn down, nodes to turn up+      ConvergeStart !Int !Int+    | -- | everything applied cleanly, nodes still not converged+      ConvergeStop !Bool !Int+    | -- | the loop's 'Mode', then nodes, plus every live declaration's+      -- path(s) to each one (see 'worldPaths') — the thing a+      -- @--select@\/@--exclude@ pattern is actually built from.+      StatusReport !Mode ![(Ref, NodeState)] !(Map Ref [Text])+    | -- | epoch, declaration, still active, who declared it, argv+      HistoryReport ![(EpochId, Declaration, Bool, Origin, [String])]+    | -- | declarations too old to still be in 'worldLog'; emitted after a+      -- 'HistoryReport' so @history@ never silently claims to be complete+      HistoryElided !Int+    | -- | world nodes annotated against a resolved selection: selected, excluded, paths+      QueryReport ![(Ref, NodeState)] !(Set Ref) !(Set Ref) !(Map Ref [Text])+    | -- | @help@: the full reference ('Nothing', or a 'Topic' 'lookupTopic'+      -- didn't recognise), or a lengthier explanation of just that one+      -- recognised 'Topic'.+      HelpText !(Maybe Topic)+    | -- | the status sink ("Salmon.Actions.Serve.StatusSink") could not+      -- write its document: path, why. Emitted from the sink's own thread,+      -- once per run of failures rather than once per attempt, and never+      -- attributed to a typist; the loop keeps serving.+      SinkFailed !FilePath !Text+    deriving (Show)++-- | Prints 'Report's in a human-readable, one-event-per-block form.+reportText :: Reporter Report+reportText = ReporterM $ \rep -> do+    -- one write per report rather than one per line: another producer's+    -- reporter ("Salmon.Actions.Follow") shares this handle from its own+    -- thread, and two half-lines interleaved are not two reports.+    Text.putStr (Text.unlines (renderReport rep))+    hFlush stdout++renderReport :: Report -> [Text]+renderReport rep =+    case rep of+        Started ->+            [ "serve: ready"+            , "serve: type `help` for the command reference"+            ]+        Stopped -> ["serve: input closed"]+        HungUp origin -> ["serve: " <> originName origin <> " hung up"]+        BadCommand err -> ["serve: " <> err]+        BadSeed err -> ("serve: cannot configure seed:") : Text.lines err+        BadDirective err -> ("serve: cannot decode directive:") : Text.lines err+        BadLoad err -> ["serve: " <> err]+        Loading path -> ["serve: loading " <> Text.pack path]+        LoadDone path n -> ["serve: loaded " <> Text.pack path <> " (" <> tshow n <> " line(s))"]+        Declared eid dir nnodes nactive ->+            [ Text.unwords+                [ "serve: epoch"+                , renderEpochId eid+                , renderDirection dir+                , "(" <> tshow nnodes <> " nodes,"+                , tshow nactive <> " active seed(s))"+                ]+            ]+        Cleared n -> ["serve: retired " <> tshow n <> " seed(s)"]+        Supervised True -> ["serve: supervising (nodes are tended between passes)"]+        Supervised False -> ["serve: not supervising (nodes are left alone between passes)"]+        AutoConverged True -> ["serve: auto-converging (each declaration converges immediately)"]+        AutoConverged False -> ["serve: not auto-converging (declarations wait for an explicit `converge`)"]+        FetchRequested True -> ["serve: fetching now"]+        FetchRequested False -> ["serve: nothing is being followed (start with --follow to fetch declarations)"]+        Instructed instr n ->+            [ Text.unwords+                [ "serve: queued"+                , Text.toLower (tshow instr)+                , "for"+                , tshow n+                , "node(s), to take effect once tending next starts"+                ]+            ]+        Tended t -> renderTended t+        ConvergeStart ndown nup ->+            ["serve: converging (" <> tshow ndown <> " down, " <> tshow nup <> " up)"]+        ConvergeStop ok remaining ->+            [ Text.unwords+                [ "serve:"+                , -- 'remaining' rather than 'ok' decides the headline: a+                  -- restricted pass can leave nodes pending (skipped, not+                  -- attempted) while still reporting 'ok' — nothing it+                  -- actually attempted failed.+                  if remaining == 0 then "converged" else "converge incomplete"+                , "(" <> tshow remaining <> " node(s) left"+                , if ok then ")" else ", including a failure)"+                ]+            ]+        StatusReport mode [] _ -> ["serve: mode: " <> renderMode mode, "serve: no nodes"]+        StatusReport mode xs paths -> ("serve: mode: " <> renderMode mode) : "serve: nodes:" : concatMap (renderNode paths) (sortOn statusOrder xs)+        HistoryReport [] -> ["serve: no seed declared yet"]+        HistoryReport xs -> "serve: seeds:" : fmap renderEpochLine xs+        HistoryElided n -> ["serve: " <> tshow n <> " earlier declaration(s) elided"]+        QueryReport [] _ _ _ -> ["serve: no nodes"]+        QueryReport xs sel exc paths -> "serve: nodes:" : concatMap (renderQueryNode paths sel exc) (sortOn statusOrder xs)+        HelpText mtopic ->+            case mtopic >>= lookupTopic of+                Just detailed -> detailed+                Nothing -> commandReference+        SinkFailed path err -> ("serve: status sink " <> Text.pack path <> " could not be written:") : Text.lines err+  where+    statusOrder :: (Ref, NodeState) -> (Direction, Convergence, ShortHand, Text)+    statusOrder (r, st) = (st.nodeDirection, st.nodeConvergence, st.nodeShorthand, unRef r)++    {- | One summary line, plus (R3) a trailing detail block for a node whose+    last known check was 'Salmon.Actions.UpDown.Failure' — its own ring of+    output, tail-capped so one wedged node cannot bury the rest of the+    listing. A node this has never tended (never supervised, or not yet+    reached by an idle pass) says so rather than showing stale silence as if+    it meant something. -}+    renderNode :: Map Ref [Text] -> (Ref, NodeState) -> [Text]+    renderNode paths (r, st) = summary : pathLines ++ detail+      where+        summary =+            Text.unwords+                [ " "+                , renderDirection st.nodeDirection+                , Text.justifyLeft 9 ' ' (tshow st.nodeConvergence)+                , Text.justifyLeft 10 ' ' (unRef r)+                , st.nodeShorthand+                , renderVerdict st.nodeStatus+                ]+        pathLines = case Map.findWithDefault [] r paths of+            [] -> ["     path: (none — not reached by any live declaration's graph)"]+            [p] -> ["     path: " <> p]+            ps -> "     paths:" : [ "       " <> p | p <- ps ]+        detail = case st.nodeStatus of+            Just ms | UpDown.Failure _ <- ms.statusCheck -> renderRingTail ms.statusOutput+            _ -> []++    renderVerdict :: Maybe MachineStatus.Status -> Text+    renderVerdict Nothing = "[not yet tended]"+    renderVerdict (Just ms) = "[" <> tshow ms.statusCheck <> "]"++    -- | The last few lines of a node's output ring, oldest of the shown+    -- ones first — enough to see what a failing node was last saying+    -- without dumping the whole (up to 256-line) ring into a status listing.+    renderRingTail :: MachineStatus.Ring -> [Text]+    renderRingTail ring =+        case MachineStatus.ringLines ring of+            [] -> []+            ls ->+                let shown = drop (max 0 (length ls - ringTailLines)) ls+                    omitted = length ls - length shown+                    header+                        | omitted > 0 = "     last output (" <> tshow omitted <> " earlier line(s) omitted):"+                        | otherwise = "     last output:"+                 in header : fmap ("       " <>) shown++    ringTailLines :: Int+    ringTailLines = 10++    renderQueryNode :: Map Ref [Text] -> Set Ref -> Set Ref -> (Ref, NodeState) -> [Text]+    renderQueryNode paths sel exc entry@(r, _) = case renderNode paths entry of+        [] -> []+        (summary : rest) -> (summary <> annotation) : rest+      where+        annotation+            | r `Set.member` exc = " [excluded]"+            | r `Set.member` sel = " [selected]"+            | otherwise = ""++    -- a typed line renders exactly as it did before origins existed; any+    -- other origin is a trailing annotation, so the argv stays where an+    -- operator's eye already looks for it.+    renderEpochLine :: (EpochId, Declaration, Bool, Origin, [String]) -> Text+    renderEpochLine (eid, decl, active, origin, toks) =+        Text.unwords $+            [ " "+            , renderEpochId eid+            , Text.justifyLeft 8 ' ' (renderDeclaration decl)+            , if active then "[active]" else "[retired]"+            , Text.pack (unwords toks)+            ]+                ++ [ann | Just ann <- [renderOrigin origin]]++{- | How @history@ names where a declaration came from: 'Nothing' for a typed+line (the common case, and the one every existing transcript shows), a+bracketed annotation otherwise. A fetched declaration names its registry,+label, document id and digest, which is the whole point of recording it —+see "Salmon.Actions.Follow".+-}+renderOrigin :: Origin -> Maybe Text+renderOrigin origin =+    case origin of+        Stdin -> Nothing+        Origin name -> Just ("[via " <> name <> "]")+        Loaded path -> Just ("[loaded " <> Text.pack path <> "]")+        Fetched prov ->+            Just $+                Text.concat+                    [ "[fetched "+                    , prov.provRegistry+                    , " label="+                    , prov.provLabel+                    , " id="+                    , prov.provDocument+                    , " sha256="+                    , Text.take 12 prov.provDigest+                    , "]"+                    ]++{- | The supervision events worth an operator's attention, one line each.++Everything a machine says about its own progress — state transitions, the+next check's delay — is dropped upstream in 'serve''s own reporter rather+than rendered small here: a per-node line on every nap is a trace, not a+report.+-}+renderTended :: Upkeep.Report Extension -> [Text]+renderTended t =+    case t of+        Upkeep.Supervising nup ndown ->+            ["serve: tending " <> tshow nup <> " node(s) up, " <> tshow ndown <> " down"]+        -- not rendered: the machines stand down before every command,+        -- including a `help`, and a line saying so each time is noise. That+        -- they came back is what the next 'Upkeep.Supervising' says.+        Upkeep.Retired _ -> []+        Upkeep.Wedged act (Micros us) ->+            [ "serve: "+                <> act.shorthand+                <> " has been silent for "+                <> tshow (us `div` 1000)+                <> "ms, past its watchdog"+            ]+        Upkeep.Holding n -> ["serve: " <> tshow n <> " node(s) still holding an effect up"]+        Upkeep.Unwedged act -> ["serve: " <> act.shorthand <> " is moving again"]+        -- not rendered: a live tail is for a client of `/events`; on a+        -- terminal it would interleave every daemon's stdout with the reports.+        Upkeep.Output _ _ -> []+        Upkeep.GaveUp act n ->+            [ "serve: "+                <> act.shorthand+                <> " gave up after "+                <> tshow n+                <> " consecutive failures; force or recheck it to try again"+            ]+        -- a machine taken over from the previous supervisor: worth a line,+        -- because the alternative (a restart) would have been visible and an+        -- operator should be able to tell which happened.+        Upkeep.Adopted act -> ["serve: " <> act.shorthand <> " kept running"]+        Upkeep.Released act -> ["serve: " <> act.shorthand <> " let go"]+        -- worth a line even though it is a normal consequence of a+        -- declared policy: it is the one thing in the supervisor that+        -- touches a node nobody asked about, so an operator seeing work+        -- happen on a node they did not expect should be able to find out+        -- why from the same stream.+        Upkeep.Demoted act dep ->+            [ "serve: "+                <> act.shorthand+                <> " sent back to wait: "+                <> unRef dep+                <> " stopped being up"+            ]+        Upkeep.Paused act -> ["serve: " <> act.shorthand <> " paused (its effect is untouched)"]+        Upkeep.Resumed act -> ["serve: " <> act.shorthand <> " resumed"]+        Upkeep.Policy act _ ignored ->+            [ "serve: "+                <> act.shorthand+                <> " declares "+                <> tshow (1 + length ignored)+                <> " supervision policies; the first is in force"+            ]+        Upkeep.Escaped act e ->+            ("serve: " <> act.shorthand <> "'s own machine threw:") : Text.lines (tshow e)+        -- filtered out before they get here; listed so a new constructor is+        -- a compile error rather than a silent omission.+        Upkeep.Acted _ -> []+        Upkeep.Upkeep{} -> []+        Upkeep.Downkeep{} -> []+        Upkeep.NextLook{} -> []+        -- the same kind of thing as 'NextLook', and filtered for the same+        -- reason: it is a machine saying what it is waiting on, which is+        -- most nodes most of the time. `status` is where to see it.+        Upkeep.Parked{} -> []+        -- also filtered, and for the same reason as 'Parked' — it is+        -- announced on every sleep of a node that declared+        -- `Op.Supervision.supReapply`, which for a busy directory tree could+        -- be every few seconds. `status` is where to see whether a node is+        -- being reapplied rather than polled.+        Upkeep.Reapplying{} -> []+        Upkeep.Untended{} -> []++renderDirection :: Direction -> Text+renderDirection TurnUp = "up"+renderDirection TurnDown = "down"++renderDeclaration :: Declaration -> Text+renderDeclaration Add = "up"+renderDeclaration Replace = "only"+renderDeclaration Remove = "down"++renderEpochId :: EpochId -> Text+renderEpochId eid = "#" <> tshow eid.unEpochId++tshow :: (Show a) => a -> Text+tshow = Text.pack . show++-- | The full command reference, printed by @help@\/@?@ with no topic, or+-- with a topic 'lookupTopic' doesn't recognise.+commandReference :: [Text]+commandReference =+    [ "serve: commands:"+    , "  up <seed args...>              add this seed to the active set"+    , "  only <seed args...>            make this seed the whole active set, retiring the others"+    , "  down <seed args...>            retire this seed"+    , "  up-directive <file>            like `up`, but from a directive JSON file (no seed parsing)"+    , "  only-directive <file>          like `only`, but from a directive JSON file"+    , "  down-directive <file>          like `down`, but from a directive JSON file"+    , "  load <file>                    run a file of these command lines, in order, as if typed"+    , "  clear                          retire every seed (everything known goes down)"+    , "  converge [--select P]... [--exclude P]..."+    , "                                 re-attempt whatever has not converged;"+    , "                                 with --select/--exclude, restrict this one pass to matching nodes"+    , "  status [--select P]... [--exclude P]..."+    , "                                 list nodes and their direction/convergence"+    , "  history [--select P]... [--exclude P]..."+    , "                                 list past declarations"+    , "  query [--select P]... [--exclude P]..."+    , "                                 annotate nodes [selected]/[excluded], without acting on anything"+    , "  supervise on|off               whether to keep tending nodes between passes (default on)"+    , "  autoconverge on|off            whether a declaration converges immediately (default on)"+    , "  force   [--select P]... [--exclude P]..."+    , "                                 run `up` on matching nodes even though their check says not to"+    , "  recheck [--select P]... [--exclude P]..."+    , "                                 look at matching nodes now, rather than at their next delay"+    , "  pause   [--select P]... [--exclude P]..."+    , "                                 stop tending matching nodes, without touching their effect"+    , "  resume  [--select P]... [--exclude P]..."+    , "                                 start tending matching nodes again"+    , "  fetch                          (--follow) fetch the followed documents now, not at the next round"+    , "  help, ? [TOPIC]                print this reference, or (given a topic) more about just it"+    , "  quit, exit                     leave the loop, changing nothing on the way out"+    , "serve: --select/--exclude patterns are /-separated node-path globs (* one segment, ** any depth);"+    , "       may repeat; omitting --select entirely means everything."+    , "serve: `help TOPIC` for more, where TOPIC is one of:"+    , "       up, directive, load, clear, converge, status, history, query, select, supervise,"+    , "       autoconverge, force, fetch"+    ]++{- | @help TOPIC@'s lookup table, matched case-insensitively (several names+may share one block of text, e.g. @up@\/@only@\/@down@ all point at+'declareHelp'). A topic not listed here falls back to 'commandReference'+(see 'lookupTopic').+-}+helpTopics :: [(Topic, [Text])]+helpTopics =+    [ ("up", declareHelp)+    , ("only", declareHelp)+    , ("down", declareHelp)+    , ("directive", directiveHelp)+    , ("up-directive", directiveHelp)+    , ("only-directive", directiveHelp)+    , ("down-directive", directiveHelp)+    , ("load", loadHelp)+    , ("clear", clearHelp)+    , ("converge", convergeHelp)+    , ("status", statusHelp)+    , ("history", historyHelp)+    , ("query", queryHelp)+    , ("supervise", superviseHelp)+    , ("watchdog", superviseHelp)+    , ("autoconverge", autoConvergeHelp)+    , ("force", instructHelp)+    , ("recheck", instructHelp)+    , ("pause", instructHelp)+    , ("resume", instructHelp)+    , ("fetch", fetchHelp)+    , ("select", selectHelp)+    , ("exclude", selectHelp)+    , ("pattern", selectHelp)+    ]++lookupTopic :: Topic -> Maybe [Text]+lookupTopic t = lookup (Text.toLower t) helpTopics++declareHelp :: [Text]+declareHelp =+    [ "serve: up / only / down <seed args...>"+    , ""+    , "  up <seed args...>    parses <seed args...> with the seed's own command-line parser (the"+    , "                       same words that would follow `config` on the command line),"+    , "                       configures it into a directive, and adds the resulting epoch to the"+    , "                       active set."+    , "  only <seed args...>  like `up`, but also retires every other currently active seed. A"+    , "                       node shared with a retiring seed (e.g. an enclosing directory) is"+    , "                       left alone if the new seed still wants it too."+    , "  down <seed args...>  retires this seed. Its nodes go down unless another active seed"+    , "                       still wants them."+    , ""+    , "  A seed is identified by its encoded directive, not by its argv spelling: re-declaring an"+    , "  already-active, unchanged seed is a no-op (nothing pending, nothing re-run)."+    , ""+    , "  Every declaration converges automatically right after being recorded (as if `converge`"+    , "  had been typed next); it is never itself scoped by --select/--exclude. `autoconverge off`"+    , "  turns this off, so several declarations can be recorded and inspected (`status`/`query`)"+    , "  before an explicit `converge` acts on any of them — see `help autoconverge`."+    , ""+    , "  See also: `help directive` (declaring from a pre-generated directive file instead of"+    , "  seed args), `help load` (batch-declaring several seeds from a script file)."+    ]++directiveHelp :: [Text]+directiveHelp =+    [ "serve: up-directive / only-directive / down-directive <file>"+    , ""+    , "  Exactly like `up`/`only`/`down`, but the seed's own command-line parser is skipped"+    , "  entirely: <file> is read and JSON-decoded straight into the directive, e.g. the output"+    , "  of `my-salmon config <seed-args> > configs/foo.json` saved ahead of time."+    , ""+    , "  Useful when a directive was already generated once (or came from somewhere other than"+    , "  this binary's own seed parser) and there is no seed value to reconstruct here — `status`"+    , "  still shows these nodes normally, and `history` records the file path in place of argv."+    , ""+    , "  A malformed or unreadable file reports an error and declares nothing."+    ]++loadHelp :: [Text]+loadHelp =+    [ "serve: load <file>"+    , ""+    , "  Reads <file> and runs each of its lines through this exact same command language, in"+    , "  order, as if they had been typed (or piped) at the prompt one at a time — including"+    , "  further `load` lines, blank lines, and `#`-comments."+    , ""+    , "  A `quit`/`exit` inside a loaded file ends the whole serve session, not just the load."+    , ""+    , "  Nested loads are capped at a small depth to catch a file that (directly or indirectly)"+    , "  loads itself; exceeding it reports an error rather than looping forever."+    , ""+    , "  This is the way to turn a directory of saved scripts (each a sequence of `up`/`only`/"+    , "  `down`/`up-directive`/... lines) into one `load configs/whatever.txt` declaration."+    ]++clearHelp :: [Text]+clearHelp =+    [ "serve: clear"+    , ""+    , "  Retires every currently active seed in one step (equivalent to a `down` for each). Every"+    , "  node no seed wants any more goes down on the convergence pass that follows automatically."+    , "  Takes no arguments."+    ]++convergeHelp :: [Text]+convergeHelp =+    [ "serve: converge [--select PATTERN]... [--exclude PATTERN]..."+    , ""+    , "  Re-attempts whatever has not yet converged: one teardown pass over nodes wanted down,"+    , "  then one bring-up pass over nodes wanted up. This runs automatically after every"+    , "  declaration; a bare `converge` is for retrying after fixing whatever made a node error"+    , "  out, or after a wait for some external condition."+    , ""+    , "  With --select/--exclude, this one pass is additionally restricted to nodes matching the"+    , "  resolved selection (see `help select`) — anything outside it is left exactly as it was,"+    , "  neither attempted nor marked converged, so a later unrestricted `converge` still picks it"+    , "  up. Omitting both flags converges everything pending, as before."+    , ""+    , "  Note the restriction scopes the *pass*, not the world: with supervision on (the"+    , "  default), a node this pass skipped is still tended once the loop goes idle, and may be"+    , "  acted on then. `supervise off` first if you want a pass to be the only thing that"+    , "  touches anything."+    , ""+    , "  The report's headline (`converged` vs. `converge incomplete`) reflects how many nodes are"+    , "  still left afterwards, not just whether anything attempted this pass failed — a"+    , "  restricted pass can report no failure while still leaving excluded nodes pending."+    ]++statusHelp :: [Text]+statusHelp =+    [ "serve: status [--select PATTERN]... [--exclude PATTERN]..."+    , ""+    , "  First says which mode the loop is in — `interactive` (nothing followed: every declaration"+    , "  was typed or loaded), `following` (the world is what the registry last said), or `replay`"+    , "  (the registry could not be reached at startup and the world is a cached document: the"+    , "  last one applied before the restart, until a round in which every label answers)."+    , "  Then lists every node this world is still concerned with, unified by Ref across every seed"+    , "  that shares it, with its wanted direction (up/down) and convergence (Pending/Stale/"+    , "  Converged/Errored/Blocked). A node that has finished going down is dropped, so a world whose seeds"+    , "  have all been retired and converged lists nothing at all — `history` still shows they"+    , "  were declared."+    , ""+    , "  With no flags at all, lists everything, exactly as before --select/--exclude existed"+    , "  (including nodes still on their way down). With --select/--exclude given, narrows the"+    , "  listing to the resolved selection (see `help select`) — this can, unlike the unfiltered"+    , "  form, only show nodes belonging to a currently active seed."+    , ""+    , "  Each line also carries what the node's own machine last had to say for itself (its"+    , "  check, in brackets) once it has been tended at least once; `[not yet tended]` means"+    , "  supervision has not reached it yet. A node whose last word was a failure additionally"+    , "  shows the tail of its own output ring underneath — what it was doing right before it"+    , "  failed, which is otherwise nowhere to see."+    , ""+    , "  Underneath each summary line is the path (or paths, if more than one live seed's graph"+    , "  reaches the same node) a --select/--exclude PATTERN would match to name it — the same"+    , "  slash-separated form `run tree`/`query` print, pasteable straight back in. This is the"+    , "  only place those paths are discoverable at all; a node with none listed belongs to no"+    , "  currently active seed (it is on its way down after being retired)."+    ]++historyHelp :: [Text]+historyHelp =+    [ "serve: history [--select PATTERN]... [--exclude PATTERN]..."+    , ""+    , "  Lists the declarations made, newest last, each tagged [active]/[retired] and showing the"+    , "  original argv (or, for a directive-file declaration, the file path). This is a log of"+    , "  what was asked for, kept long after the graph a declaration built has been collected —"+    , "  so a [retired] line here does not mean that graph is still held in memory."+    , ""+    , "  A line typed at this loop shows nothing more. One run from a `load`ed file ends in"+    , "  [loaded <file>]; one made by the fetcher (`run serve --follow`) ends in"+    , "  [fetched <registry> label=<label> id=<document id> sha256=<digest prefix>], which is"+    , "  how to tell what you typed from what a document said."+    , ""+    , "  The log is capped; if older declarations have fallen off the end, a line after the"+    , "  listing says how many."+    , ""+    , "  With --select/--exclude, only declarations that named at least one node in the resolved"+    , "  selection (see `help select`) are shown."+    ]++queryHelp :: [Text]+queryHelp =+    [ "serve: query [--select PATTERN]... [--exclude PATTERN]..."+    , ""+    , "  Lists every node (like a plain `status`), annotating each one [selected] or [excluded]"+    , "  against the resolved selection (see `help select`), without acting on anything — no"+    , "  convergence pass runs. Useful for checking what a `converge --select/--exclude` would"+    , "  touch before actually running it."+    ]++superviseHelp :: [Text]+superviseHelp =+    [ "serve: supervise on|off"+    , ""+    , "  Whether nodes are *tended* between convergence passes, rather than only applied by"+    , "  them. On by default."+    , ""+    , "  While supervising, every node this world knows has a small state machine of its own,"+    , "  running in whatever direction the node is wanted. A node wanted up rechecks its own"+    , "  effect on an adaptive delay — doubling to a minute while the effect is there, halving"+    , "  to half a second when it is not — and runs `up` again if the effect has gone. A node"+    , "  wanted down retries its `down` on the same schedule until it succeeds, then stops."+    , ""+    , "  The machines run only while this loop is idle. They start when there is nothing"+    , "  waiting in the input and stand down before any command is handled (stopping waits for"+    , "  any `up`/`down` in flight rather than cutting it), so a piped script — every line of"+    , "  which is queued before the first pass ends — is never supervised at all, and behaves"+    , "  exactly as it did before any of this existed."+    , ""+    , "  Turning supervision off stops the machines and leaves every effect exactly as it is:"+    , "  `off` is not a teardown, it is `serve` behaving as it did before nodes had machines."+    , ""+    , "  What a node does about its effect going away is the node author's choice, stated as a"+    , "  supervision policy on the node itself (see Salmon.Op.Supervision):"+    , ""+    , "    OnFailure  put it back when the check says the effect is gone. The default."+    , "    Never      report it and leave it; an operator decides."+    , "    Always     also rerun a node whose check says it ran to completion and stopped."+    , ""+    , "  A check that cannot tell (`Unknown`) never triggers a restart: nothing here re-runs"+    , "  `up` on a node that looked and could not say. A node with no check of its own — most"+    , "  of them — answers `Immaterial` instead (\"asking would cost what applying costs\"), is"+    , "  brought up once, and is then parked rather than polled: still reachable by `force`,"+    , "  `recheck` and by a dependency that takes its dependants with it, but no longer woken"+    , "  on a timer to be told the same thing. A node whose effect can go away behind salmon's"+    , "  back wants a real check; that is what makes it noticeable at all."+    , ""+    , "  A node may instead opt into `supReapply`: rather than being parked, it re-runs `up`"+    , "  on the same adaptive delay, in place of asking. Only sound for an `up` that is both"+    , "  cheap and genuinely idempotent — a directory is the case it exists for, a build or a"+    , "  clone is not — and ignored for a node that owns a running process, whose `up` is not"+    , "  meant to be re-run at all."+    , ""+    , "  A node may also declare a watchdog: how long it may go without doing anything"+    , "  observable before that silence should be reported. Nodes that declare none are never"+    , "  called wedged, which is the right default — silence is evidence only once somebody has"+    , "  said what silence would mean."+    ]++autoConvergeHelp :: [Text]+autoConvergeHelp =+    [ "serve: autoconverge on|off"+    , ""+    , "  Whether a declaring command (`up`/`only`/`down`/`clear`, and the `-directive` forms)"+    , "  triggers a convergence pass immediately after recording its epoch. On by default, which"+    , "  is what makes `up <seed>` on its own bring the seed's nodes up: the declaration and the"+    , "  pass that acts on it happen as one step."+    , ""+    , "  `autoconverge off` splits that in two. A declaration still updates the active set and"+    , "  `worldLedger`/`worldNodes` right away — `status`/`query`/`history` see it immediately —"+    , "  but nothing is applied until an explicit `converge` (optionally restricted with"+    , "  --select/--exclude). This is the way to record several declarations (e.g. `up a`, then"+    , "  `down b`, then `up c`) and inspect the combined result with `query`/`status` before"+    , "  anything actually runs, or to review a directive-driven declaration for a mistake before"+    , "  committing to it."+    , ""+    , "  Supervision (`help supervise`) is unaffected either way: a node already up and already"+    , "  supervised keeps being tended regardless of this setting, which only governs whether a"+    , "  *new* declaration's own pass fires on its own. `converge` (with no autoconverge caveat)"+    , "  always still runs a pass, whichever way this is set."+    ]++instructHelp :: [Text]+instructHelp =+    [ "serve: force | recheck | pause | resume [--select PATTERN]... [--exclude PATTERN]..."+    , ""+    , "  Tell the matching nodes' own machines something a check cannot: (see `help supervise`"+    , "  for what those machines are). Omitting --select entirely means every node, same as"+    , "  `status`/`query`."+    , ""+    , "    force    run `up` even though the check says not to — the operator knows something"+    , "             it does not. For a node that owns a process, this is how to restart one"+    , "             that is healthy, which is otherwise not sayable at all."+    , "    recheck  look now instead of waiting out the current delay."+    , "    pause    stop tending, without touching the effect. For a node that owns a process,"+    , "             this leaves it running, unwatched — the operational verb for \"stop caring"+    , "             about this without stopping it\"."+    , "    resume   start tending again."+    , ""+    , "  These act on a node's machine, and a node only has one while supervision is tending it"+    , "  (see `help supervise`) — a piped script, or `supervise off`, means there is nothing to"+    , "  instruct. A one-shot machine (most nodes) does not survive the command that named it"+    , "  either: `serve` stands every one-shot machine down before handling any command, `status`"+    , "  included, so there is no live mailbox to post into at the moment this is typed. So the"+    , "  instruction is queued instead and delivered the moment tending next starts — the next"+    , "  time this loop goes idle, immediately after the command that queued it. A node a"+    , "  selection matched that never gets a machine (excluded, retired, or simply never tended)"+    , "  is not an error: the count this command reports is how many nodes matched, not how many"+    , "  machines heard it."+    ]++fetchHelp :: [Text]+fetchHelp =+    [ "serve: fetch"+    , ""+    , "  Only meaningful under --follow. The fetcher polls its registry on a schedule: at a base"+    , "  interval while rounds succeed, backing off (times --follow-factor, up to --follow-cap)"+    , "  while they fail; and a changed document is not applied at once but held until the"+    , "  registry has been quiet for --follow-debounce (or --follow-max-wait has elapsed since the"+    , "  first pending change), so a publisher writing several times in a row is one pass."+    , ""+    , "  `fetch` cuts both short: a round runs now, the backoff is forgotten, and whatever is"+    , "  pending afterwards is applied without waiting out the quiet window — for an operator"+    , "  who just published and does not want to wait. Without --follow it only says so."+    ]++selectHelp :: [Text]+selectHelp =+    [ "serve: --select PATTERN / --exclude PATTERN"+    , ""+    , "  Shared by `converge`/`status`/`history`/`query`. A PATTERN is a /-separated glob over a"+    , "  node's tree position (the same path `run tree`/`run dag` print): a plain segment must"+    , "  match literally, `*` matches exactly one segment, `**` matches any number of segments"+    , "  (including zero), so `**` alone matches everything."+    , ""+    , "  Both flags may repeat; each is unioned with itself first. The selected set is every node"+    , "  matching some --select pattern (or, if --select is omitted entirely, every node), minus"+    , "  every node matching some --exclude pattern."+    , ""+    , "  The same node (a shared predecessor, e.g. a directory two files sit in) can occur at"+    , "  several paths; matching any one of them is enough to select or exclude it."+    , ""+    , "  `status`/`query` are where these paths actually come from — each node's listing there"+    , "  shows every path it currently has, pasteable straight back in as a PATTERN. A path built"+    , "  from op kinds alone (`directory`, `file-contents`, ...) can be the same for two different"+    , "  nodes when a recipe reuses the same shorthand at each position; when that happens, prefix"+    , "  the node's own Ref (also printed on its `status` line) with `#` instead — `#fragment`"+    , "  matches any node whose Ref starts with that text, which is always unique."+    ]++-------------------------------------------------------------------------------++{- | Read declarations from a handle until EOF (or @quit@), converging after+each one, and hand back the 'World' as it stands when the loop ends. Never+tears anything down on its way out: exiting the loop leaves the machine as+the last convergence left it. The handle is the loop's standard input+('stdinProducer'); see 'serveProducers' for feeding it from more than one+place.+-}+serve ::+    forall seed directive.+    (ToJSON directive, FromJSON directive) =>+    -- | loop-level events+    Reporter Report ->+    -- | per-node events, same reporter @run up@ uses+    Reporter (UpDown.Report Extension) ->+    -- | parses a seed out of one declaration's arguments+    ([String] -> Either Text seed) ->+    Configure IO seed directive ->+    Track' directive ->+    Handle ->+    IO (World seed directive)+serve = serveWith [] Nothing True++{- | 'serve', with "Salmon.Op.Rewrite" phases registered. They run after every+fold, so a convergence walks the /computed/ graph — the one where a+collection node has replaced the nodes it batches — while the ledger and+'worldNodes' keep speaking in terms of what was declared. See+'Salmon.Op.Rewrite' for why that split is the only place cross-declaration+knowledge can live.++The 'Maybe' 'ConcurrencyLimit' bounds each convergence pass's two concurrent+walks (see "Salmon.Actions.Concurrent"): 'Nothing' is unbounded, matching+'serve's behaviour before the limit existed. One limit covers both the+teardown and the bring-up half of every pass, not one each, since the two+never run at the same time (teardown is awaited before bring-up starts) and+so never contend with each other for it.++The 'Bool' is the starting value of @autoconverge@ (see 'AutoConverge'):+'True' matches every version of 'serve' before the setting existed (each+declaration converges immediately), 'False' starts the loop the way an+in-session @autoconverge off@ would, for a caller (e.g. a CLI flag) that+wants declarations held back from the very first line rather than needing+the operator to type it first.+-}+serveWith ::+    forall seed directive.+    (ToJSON directive, FromJSON directive) =>+    [Rewrite Extension] ->+    Maybe ConcurrencyLimit ->+    Bool ->+    Reporter Report ->+    Reporter (UpDown.Report Extension) ->+    ([String] -> Either Text seed) ->+    Configure IO seed directive ->+    Track' directive ->+    Handle ->+    IO (World seed directive)+serveWith rewrites limit autoConverge0 r nodeReporter parseSeed configure program h =+    serveProducers rewrites limit autoConverge0 r nodeReporter parseSeed configure program [stdinProducer h]++-------------------------------------------------------------------------------+-- input producers++{- | Who typed a line. Standard input is singled out because its end of input+is the one that ends the loop (see 'serveProducers'); every other source is+named, so that a report or a history entry can one day say where a+declaration came from.+-}+data Origin+    = -- | the process's own standard input+      Stdin+    | -- | any other source: a socket connection, a test+      Origin !Text+    | -- | a line run from a @load@ed file (never pushed by a producer: the+      -- loop itself tags the file's lines as it runs them)+      Loaded !FilePath+    | -- | a declaration "Salmon.Actions.Follow" made from a fetched+      -- document; see 'Provenance' for what @history@ says about it+      Fetched !Provenance+    deriving (Show, Eq, Ord)++{- | Where a fetched declaration came from, in enough detail that an operator+reading @history@ can tell "I typed this" from "the document said so", and+/which/ document: the registry, the label addressed in it, the document's+own @id@ and the digest of its bytes.+-}+data Provenance = Provenance+    { provRegistry :: !Text+    , provLabel :: !Text+    , provDocument :: !Text+    , provDigest :: !Text+    }+    deriving (Show, Eq, Ord)++{- | An 'Origin' as a report names it in a sentence ("stdin hung up"), as+opposed to 'renderOrigin', the bracketed annotation @history@ appends.+-}+originName :: Origin -> Text+originName Stdin = "stdin"+originName (Origin t) = t+originName (Loaded path) = "loaded " <> Text.pack path+originName (Fetched prov) = "fetched " <> prov.provRegistry <> " label=" <> prov.provLabel++{- | A report, and the 'Origin' of the command it was emitted for: 'Nothing'+for one emitted between commands (the tending loop's), or before the first+and after the last. See 'serveAttributed'.+-}+data Attributed a = Attributed+    { attributedTo :: !(Maybe Origin)+    , attributed :: !a+    }+    deriving (Show, Functor)++{- | What a 'Producer' pushes into the loop's inbox.++A 'Batch' is the unit a fetched document is injected as: its commands run+back to back with @autoconverge@ held off, so the declarations record without+each one converging on its own, then the setting is put back to whatever it+was — an operator's @autoconverge off@ is not silently re-enabled — and one+@converge@ runs. The batch carries its own commands rather than text lines+so a seed's words survive without a quoting round trip, and it is one inbox+entry rather than several so nothing another producer types can land in the+middle of it. Each command carries its own 'Origin', because one batch can+carry several documents' worth of declarations (several labels changed+inside one quiet window) and @history@ must still say which document each+came from.+-}+data Line+    = -- | one line of the input language, as the producer read it+      Line !Origin !String+    | -- | several commands, handled as one: see above+      Batch ![(Origin, ServeCommand)]+    | -- | this producer has nothing more to say and its thread is about to end+      Eof !Origin+    deriving (Show, Eq)++{- | A source of 'Line's. 'serveProducers' runs 'produceInto' on a thread of+its own, hands it the loop's one inbox, and kills the thread when the loop+ends; a producer is expected to push an 'Eof' as its last word and return.+-}+newtype Producer = Producer {produceInto :: TChan Line -> IO ()}++-- | Read a handle line by line until end of file, then 'Eof'.+handleProducer :: Origin -> Handle -> Producer+handleProducer origin h = Producer go+  where+    go inbox = do+        eof <- hIsEOF h+        if eof+            then atomically (writeTChan inbox (Eof origin))+            else do+                line <- hGetLine h+                atomically (writeTChan inbox (Line origin line))+                go inbox++{- | The producer 'serveWith' runs: 'handleProducer' with the 'Stdin' origin,+which is what makes its end of input the loop's. The handle need not be the+process's actual standard input — a test's pipe or script file is the same+thing to the loop.+-}+stdinProducer :: Handle -> Producer+stdinProducer = handleProducer Stdin++{- | 'serveWith', fed by any number of 'Producer's rather than one handle.+Each runs on its own thread so that the loop is never itself blocked in a+read: the supervisor's machines run while it waits, and stopping them has to+be able to interleave with a command arriving.++The loop ends on @quit@, or on 'Eof' from the 'Stdin' origin; an 'Eof' from+any other origin is read past. With no 'Stdin' producer in the list, only+@quit@ ends it.+-}+serveProducers ::+    forall seed directive.+    (ToJSON directive, FromJSON directive) =>+    [Rewrite Extension] ->+    Maybe ConcurrencyLimit ->+    Bool ->+    Reporter Report ->+    Reporter (UpDown.Report Extension) ->+    ([String] -> Either Text seed) ->+    Configure IO seed directive ->+    Track' directive ->+    [Producer] ->+    IO (World seed directive)+serveProducers rewrites limit autoConverge0 r nodeReporter parseSeed configure program =+    serveFollowing rewrites limit autoConverge0 r nodeReporter parseSeed configure program Nothing++{- | What the loop knows of a fetcher producer ("Salmon.Actions.Follow"):+how to wake it (what @fetch@ pulls) and which 'Mode' it is in (what @status@+prints). It is a pair of hooks rather than a producer's methods because the+loop reads lines and does not know which producer it has; these two are the+only things it needs of the fetcher, and both are read-only from its side.+-}+data Followed = Followed+    { followedFetch :: IO ()+    -- ^ a round now; see 'Salmon.Actions.Follow.Scheduler.poke'+    , followedMode :: IO Mode+    -- ^ never 'Interactive'+    , followedApplied :: IO [AppliedDocument]+    -- ^ the document last applied per label, for the status sink+    -- ("Salmon.Actions.Serve.StatusSink"); read-only, a plain read of the+    -- fetcher's own cell+    }++{- | What the fetcher last applied for one label, as the status sink+publishes it: the label, the document's @id@, its sha256 and when it was+injected. Defined here rather than in "Salmon.Actions.Follow" because the+loop's 'Followed' names it and the fetcher imports the loop, not the other+way round. -}+data AppliedDocument = AppliedDocument+    { appliedDocLabel :: !Text+    , appliedDocId :: !Text+    , appliedDocDigest :: !Text+    , appliedDocAt :: !UTCTime+    }+    deriving (Show, Eq)++instance ToJSON AppliedDocument where+    toJSON a = object ["label" .= a.appliedDocLabel, "id" .= a.appliedDocId, "sha256" .= a.appliedDocDigest, "applied" .= a.appliedDocAt]++instance FromJSON AppliedDocument where+    parseJSON = withObject "applied document" $ \o ->+        AppliedDocument <$> o .: "label" <*> o .: "id" <*> o .: "sha256" <*> o .: "applied"++{- | Which guarantees apply to the world right now, for @status@ (see+@specs/pull-mode.md@, "what this does not solve"). 'Interactive' when nothing+is followed: every declaration was typed, loaded or batched by a client.+'Following' when a fetcher is running and the world is what the registry+last said. 'Replay' when the registry could not be reached at startup and+the fetcher applied its cached document instead — the world is the last+thing this host knew, not necessarily what the registry says now — until a+later round in which every followed label answers. -}+data Mode = Interactive | Replay | Following+    deriving (Show, Eq, Ord)++renderMode :: Mode -> Text+renderMode Interactive = "interactive"+renderMode Replay = "replay"+renderMode Following = "following"++{- | 'serveProducers', with a 'Followed' for what @fetch@ and @status@ ask+of a fetcher producer. 'Nothing' when nothing is being followed: @fetch@+then only says so, and @status@ reports 'Interactive'. -}+serveFollowing ::+    forall seed directive.+    (ToJSON directive, FromJSON directive) =>+    [Rewrite Extension] ->+    Maybe ConcurrencyLimit ->+    Bool ->+    Reporter Report ->+    Reporter (UpDown.Report Extension) ->+    ([String] -> Either Text seed) ->+    Configure IO seed directive ->+    Track' directive ->+    Maybe Followed ->+    [Producer] ->+    IO (World seed directive)+serveFollowing rewrites limit autoConverge0 r nodeReporter =+    serveAttributed rewrites limit autoConverge0 (contramap attributed r) (contramap attributed nodeReporter)++{- | 'serveProducers', reporting through reporters that are told whose+report each one is.++The loop keeps one private "line being handled" cell, written when a line+is taken off the inbox and cleared when its command is done, and every+report — the loop's own and the per-node ones a pass emits — is stamped+with it on the way out ('Salmon.Reporter.pulls'). Nothing else about the+loop changes: a command is handled whole before the next is read, so the+cell is stable for as long as a command's reports are being emitted, and+the concurrent walks a pass runs all report inside that window. What+arrives outside it — a machine tending a node between commands — is stamped+'Nothing'.++The cell is written /after/ 'stopTending', not before: the machines standing+down are not something the operator who typed the command asked for, so+whatever they say on their way out is nobody's.+-}+serveAttributed ::+    forall seed directive.+    (ToJSON directive, FromJSON directive) =>+    [Rewrite Extension] ->+    Maybe ConcurrencyLimit ->+    Bool ->+    Reporter (Attributed Report) ->+    Reporter (Attributed (UpDown.Report Extension)) ->+    ([String] -> Either Text seed) ->+    Configure IO seed directive ->+    Track' directive ->+    Maybe Followed ->+    [Producer] ->+    IO (World seed directive)+serveAttributed = serveObserved (const (pure ()))++{- | 'serveAttributed', handing an observer a way to read the 'World' before+the first line is read.++The accessor is a plain read of the loop's own cell — never a copy, never a+lock — so what it returns is whatever the loop has committed so far: a+declaration's nodes the moment it is recorded (a pass has not necessarily+run), and the tending snapshot 'stopTending' last filed on each node. It is+what a server answering reads ("Salmon.Actions.Serve.Http") holds instead of+a seat in the inbox, which is the whole of how a read stays a read: it never+stands the machines down and never waits behind a command, including one+whose @up@ is taking a while.++The observer is called once, synchronously, before any producer starts; a+server that wants to run for the loop's lifetime forks from it. The loop+does not kill anything the observer started — a server's own bracket owns+that — but it does return, so an observer holding the accessor after that+reads the final 'World', the same value this returns. It is the first+argument, ahead of everything 'serveAttributed' takes, so that the two+signatures read as one prefixed by the other.+-}+serveObserved ::+    forall seed directive.+    (ToJSON directive, FromJSON directive) =>+    (IO (World seed directive) -> IO ()) ->+    [Rewrite Extension] ->+    Maybe ConcurrencyLimit ->+    Bool ->+    Reporter (Attributed Report) ->+    Reporter (Attributed (UpDown.Report Extension)) ->+    ([String] -> Either Text seed) ->+    Configure IO seed directive ->+    Track' directive ->+    Maybe Followed ->+    [Producer] ->+    IO (World seed directive)+serveObserved observe rewrites limit autoConverge0 rAttributed nodeReporterAttributed parseSeed configure program onFetch producers = do+    handling <- newIORef Nothing+    serveLoop observe rewrites limit autoConverge0 handling (stamp handling rAttributed) (stamp handling nodeReporterAttributed) parseSeed configure program onFetch producers+  where+    stamp :: IORef (Maybe Origin) -> Reporter (Attributed a) -> Reporter a+    stamp handling = pulls (\rep -> (`Attributed` rep) <$> readIORef handling)++-- | The loop itself: 'serveAttributed' with the stamping already applied+-- and the cell it reads from in hand.+serveLoop ::+    forall seed directive.+    (ToJSON directive, FromJSON directive) =>+    (IO (World seed directive) -> IO ()) ->+    [Rewrite Extension] ->+    Maybe ConcurrencyLimit ->+    Bool ->+    IORef (Maybe Origin) ->+    Reporter Report ->+    Reporter (UpDown.Report Extension) ->+    ([String] -> Either Text seed) ->+    Configure IO seed directive ->+    Track' directive ->+    Maybe Followed ->+    [Producer] ->+    IO (World seed directive)+serveLoop observe rewrites limit autoConverge0 handling r nodeReporter parseSeed configure program onFetch producers = do+    world <- newIORef emptyWorld+    observe (readIORef world)+    tending <- Tending <$> newIORef Nothing <*> newIORef Upkeep.noKept <*> newIORef True <*> newIORef autoConverge0 <*> newIORef Map.empty+    inbox <- newTChanIO+    readers <- traverse (\p -> forkIO (produceInto p inbox)) producers+    runReporter r Started+    loop tending world inbox `finally` (stopTending tending world >> traverse_ killThread readers)+    readIORef world+  where+    -- | Deepest chain of nested @load@s allowed, to bound a self-referential+    -- (or mutually-referential) load file rather than looping forever.+    maxLoadDepth :: Int+    maxLoadDepth = 8++    loop :: Tending -> IORef (World seed directive) -> TChan Line -> IO ()+    loop tending world inbox = do+        {- Tend the nodes only while there is genuinely nothing to do.++        The reader thread queues input as fast as it arrives, so an empty+        inbox means the loop is idle and a non-empty one means the next+        command is already waiting. Starting machines only when idle is worth+        more than the two lines it costs:++          * a piped script behaves exactly as it did before any of this+            existed. Every line, end-of-input included, is already queued by+            the time the first pass finishes, so nothing is ever tended and+            @serve < script@ stays a deterministic sequence of passes;+          * there is nothing to race. Starting machines and then stopping+            them because a command had been sitting in the queue all along+            would mean whether a node got acted on depended on thread+            timing.++        Which leaves supervision doing exactly what it is for: minding the+        nodes while whoever is driving this loop is not saying anything. -}+        idle <- atomically (isEmptyTChan inbox)+        when idle (startTending tending world)+        line <- atomically (readTChan inbox)+        case line of+            -- another producer hanging up is not a command: nothing is about+            -- to act, so the machines are not stood down, and the loop goes+            -- back to waiting (they are left running if they were). It is+            -- said, though: every line that origin typed has been handled+            -- by now, which is what whoever holds its connection waits for.+            Eof origin | origin /= Stdin -> do+                runReporter r (HungUp origin)+                loop tending world inbox+            _ -> do+                -- a command is about to act on these nodes, so the machines+                -- stand down. Waits for anything in flight rather than+                -- cutting it.+                stopTending tending world+                case line of+                    Eof _ -> runReporter r Stopped+                    Line origin l -> do+                        writeIORef handling (Just origin)+                        keepGoing <- step tending 0 world origin l+                        writeIORef handling Nothing+                        when keepGoing (loop tending world inbox)+                    Batch cmds -> do+                        keepGoing <- batch tending world cmds+                        when keepGoing (loop tending world inbox)++    {- | Run a 'Batch': every command with @autoconverge@ held off, the+    setting put back afterwards (a @finally@, so a command that stops the+    loop still leaves it as the operator had it), then one full convergence+    pass — the sequence the fetcher would otherwise have to spell as+    @autoconverge off@ … @autoconverge on@ … @converge@ on the inbox, except+    that only the loop knows what to put the setting back /to/. An empty+    batch converges nothing: there is no declaration to act on. -}+    batch :: Tending -> IORef (World seed directive) -> [(Origin, ServeCommand)] -> IO Bool+    batch tending world cmds = do+        was <- readIORef (tendingAutoConverge tending)+        writeIORef (tendingAutoConverge tending) False+        keepGoing <-+            runAll cmds `finally` writeIORef (tendingAutoConverge tending) was+        when (keepGoing && not (null cmds)) (converge tending world Nothing)+        pure keepGoing+      where+        runAll [] = pure True+        runAll ((origin, cmd) : rest) = do+            go <- stepCommand tending 0 world origin cmd+            if go then runAll rest else pure False++    -------------------------------------------------------------------------+    -- supervision++    {- | Start tending every node this world knows, in whatever direction it+    is wanted. Called by 'loop' when it has nothing to do, and stopped again+    the moment it has. -}+    startTending :: Tending -> IORef (World seed directive) -> IO ()+    startTending tending world = do+        already <- readIORef (tendingSup tending)+        case already of+            -- a read-only command does not stand the machines down, so by+            -- the time the loop is idle again they are still running and+            -- there is nothing to do. Restarting them would re-check every+            -- node for no reason, and would drop the mailboxes an operator+            -- may have posted into.+            Just _ -> pure ()+            Nothing -> do+                on <- readIORef (tendingOn tending)+                auto <- readIORef (tendingAutoConverge tending)+                w <- readIORef world+                unless (not on || Map.null w.worldNodes) $ do+                    -- the same computed dag a pass walks: a rewrite's+                    -- collection node is what actually gets tended, and+                    -- 'membersOf' is what keeps the bookkeeping in declared+                    -- terms.+                    let computed = Rewrite.rewrite rewrites (phaseOf w Nothing) (worldDag w)+                    kept <- readIORef (tendingKept tending)+                    forced <- Map.keysSet <$> readIORef (tendingPending tending)+                    sup <-+                        Upkeep.startUpkeep+                            (tendReporter world computed)+                            kept+                            (tendOf auto forced w computed)+                            (Rewrite.computedDag computed)+                    -- the supervisor owns them now: it adopted what it could+                    -- and released the rest.+                    writeIORef (tendingKept tending) Upkeep.noKept+                    writeIORef (tendingSup tending) (Just sup)+                    deliverPending tending sup++    {- | (R2). Hand every queued instruction to the machine it was meant for,+    now that one exists, and forget it. Delivered in the order they were+    posted, which matters for e.g. a @pause@ followed by a @resume@.++    A node an instruction named that this supervisor is not tending at all+    (excluded by the selection at declare time, retired, or simply never+    matched a live node) silently drops it here exactly as 'Upkeep.instruct'+    always has — there was nothing to queue it *for* once its target never+    showed up, and the operator already saw how many nodes matched when the+    command was typed ('Instructed'). -}+    deliverPending :: Tending -> Upkeep.Supervisor Extension -> IO ()+    deliverPending tending sup = do+        pending <- readIORef (tendingPending tending)+        unless (Map.null pending) $ do+            forM_ (Map.toList pending) $ \(aref, instrs) ->+                forM_ instrs (Upkeep.instruct sup aref)+            writeIORef (tendingPending tending) Map.empty++    -- | (R2). Queue an instruction for every named node, oldest first per+    -- node, for 'deliverPending' to hand to the next supervisor.+    queueInstruction :: Tending -> Set Ref -> Mailbox.Instruction -> IO ()+    queueInstruction tending refs instr =+        modifyIORef' (tendingPending tending) $ \pending ->+            Set.foldr (\aref -> Map.insertWith (flip (<>)) aref [instr]) pending refs++    {- | Stop tending, without tearing anything down.++    Two different things happen to the two kinds of machine, and the+    difference is the whole of why 'Upkeep.Kept' exists. A machine tending an+    effect that persists on its own is wound down, waiting for any @up@ or+    @down@ in flight rather than interrupting it. A machine /holding/ an+    effect up keeps running: this is called before every command, @status@+    included, and a supervisor that took its processes with it would restart+    every service every time anybody typed anything.++    (R3). Before the supervisor's 'TVar's go out of reach, every machine's+    'Status' is read and stored on its node — the only place this is ever+    readable from, since a running machine's own 'TVar' is not part of+    'World' and a discarded 'Upkeep.Supervisor' offers no way back in. Read+    from @sup@ itself rather than from 'Upkeep.stopUpkeep''s result, so a+    holding machine's status is captured here too and not only a one-shot+    one's — 'Upkeep.supervisorStatuses' covers every machine this supervisor+    had, before 'Upkeep.stopUpkeep' partitions them into stopped and kept. -}+    stopTending :: Tending -> IORef (World seed directive) -> IO ()+    stopTending tending world = do+        current <- readIORef (tendingSup tending)+        forM_ current $ \sup -> do+            snapshotStatuses world (Upkeep.supervisorStatuses sup)+            kept <- Upkeep.stopUpkeep sup+            writeIORef (tendingKept tending) kept+        writeIORef (tendingSup tending) Nothing++    -- | Read every machine's live 'Status' and file it on its node. See+    -- 'stopTending'.+    snapshotStatuses :: IORef (World seed directive) -> Map Ref (TVar MachineStatus.Status) -> IO ()+    snapshotStatuses world statuses = do+        snapshot <- traverse MachineStatus.readStatus statuses+        modifyIORef' world $ \w ->+            w{worldNodes = Map.foldrWithKey record w.worldNodes snapshot}+      where+        record aref st = Map.adjust (\ns -> ns{nodeStatus = Just st}) aref++    {- | Tear down the machines still holding effects for nodes this world no+    longer wants up, and record those nodes as down.++    This runs __before__ a convergence pass rather than as part of it, and+    the ordering is the point: a daemon's dependencies — its config file, its+    working directory — must not be removed while it is still running, and+    the down pass is what removes them. 'Upkeep.releaseKept' cancels and+    waits, so by the time the pass starts the processes really are gone.++    Recording them down here is exact rather than optimistic: for a node+    whose effect only exists while something holds it, "nothing holds it" is+    what being down /is/. Which is also why a managed node is invisible to+    both passes ('gateFor'): there is nothing for a one-shot @down@ to do+    that this has not already done, and nothing a one-shot @up@ could do at+    all. -}+    settleManaged :: Tending -> IORef (World seed directive) -> IO ()+    settleManaged tending world = do+        w <- readIORef world+        kept <- readIORef (tendingKept tending)+        kept' <- Upkeep.releaseKept releaseReporter (wantedUp w) kept+        writeIORef (tendingKept tending) kept'+        let goners =+                [ rf+                | (rf, a) <- Map.toList w.worldMagma+                , isJust a.extension.managed+                , Just st <- [Map.lookup rf w.worldNodes]+                , st.nodeDirection == TurnDown+                ]+        unless (null goners) $+            modifyIORef' world $ \w0 ->+                foldr (\rf acc -> setConvergence TurnDown rf Converged acc) w0 goners++    wantedUp :: World seed directive -> Ref -> Bool+    wantedUp w rf =+        case Map.lookup rf w.worldNodes of+            Just st -> st.nodeDirection == TurnUp+            Nothing -> False++    -- | Just enough of 'tendReporter' for 'Upkeep.releaseKept', which is+    -- called outside any particular pass and so has no 'Rewritten' to+    -- translate through.+    releaseReporter :: Reporter (Upkeep.Report Extension)+    releaseReporter = ReporterM $ \rep ->+        case rep of+            Upkeep.Acted inner -> runReporter nodeReporter inner+            _ -> runReporter r (Tended rep)++    {- | Which nodes the supervisor tends, and how.++    'gateFor' is the convergence version of this and differs in one place: it+    demands the node has /not/ converged yet, because a pass is one attempt+    at whatever is outstanding. Tending is the opposite — a converged node is+    precisely the one worth keeping an eye on — so convergence becomes+    'Upkeep.Standing' rather than a filter: a converged node starts already+    where it wants to be and is only watched, and a 'Pending'\/'Errored'\/+    'Blocked' one is acted on.++    That distinction is load-bearing rather than an optimisation. Almost no+    node in this repository has a @check@, so almost every node answers+    'UpDown.Unknown'; without it, starting a supervisor after a pass would+    re-run every @up@ in the graph.++    The first 'Bool' is @autoconverge@'s current value, and it narrows+    "acted on" for a plain (non-'managed') node: with autoconverge off, a+    not-yet-'Converged' one-shot node is left untended (returns 'Nothing')+    rather than 'Unsettled', because applying it is exactly the convergence+    work an operator just asked to defer to an explicit @converge@ — without+    this, a node the idle loop reached before that @converge@ would get 'up'+    run on it anyway, since almost every node's @check@ answers+    'UpDown.Immaterial'\/'UpDown.Unknown' and 'Unsettled' treats either as+    "go ahead". A 'managed' node is exempt: it has no other path to ever+    start (the convergence pass ignores it categorically, see+    'settleManaged'), so autoconverge being off must not also mean "never".+    Already-'Converged' nodes are unaffected either way — self-healing an+    effect already brought up is not the convergence work being deferred.++    The 'Set' 'Ref' is every node with an instruction still queued in+    'tendingPending' — a @force@\/@recheck@\/@pause@\/@resume@ typed while+    autoconverge is off. Deferring convergence must not also swallow an+    operator naming a node explicitly: that instruction has nowhere to be+    delivered at all (no machine exists to post it to, see+    'deliverPending') unless a machine starts for it here, autoconverge or+    not. This is the same exemption 'managed' gets and for the same reason+    — an explicit, targeted ask is not the batched convergence work+    @autoconverge off@ defers — it just reaches that ask through a+    different field than @managed@ does.+    -}+    tendOf :: Bool -> Set Ref -> World seed directive -> Rewritten Extension -> Ref -> Maybe Upkeep.Tend+    tendOf autoConverge forced w computed aref =+        case [st | rf <- Set.toList (Rewrite.membersOf computed aref), Just st <- [Map.lookup rf w.worldNodes]] of+            [] -> Nothing+            sts ->+                -- a collection node standing in for members that disagree+                -- goes up: the conservative direction, the same call+                -- 'Salmon.Op.Rewrite' asks its phases to make. And it counts+                -- as standing only if /every/ member it speaks for does,+                -- which is the same all-or-nothing attribution a batch makes+                -- everywhere else.+                let ups = [st | st <- sts, st.nodeDirection == TurnUp]+                    mine = if null ups then sts else ups+                    converged = all (\st -> st.nodeConvergence == Converged) mine+                    managed = maybe False (isJust . (.extension.managed)) (Map.lookup aref (Dag.dagNodes (Rewrite.computedDag computed)))+                    instructed = not (Set.null (Set.intersection forced (Rewrite.membersOf computed aref)))+                 in if not converged && not autoConverge && not managed && not instructed+                        then Nothing+                        else+                            Just+                                Upkeep.Tend+                                    { Upkeep.tendDirection = if null ups then TurnDown else TurnUp+                                    , Upkeep.tendStanding =+                                        if converged+                                            then Upkeep.Settled+                                            else Upkeep.Unsettled+                                    }++    {- | Where a machine's reports go.++    Node-level events ('Upkeep.Acted') are the one-shot drivers' own+    vocabulary, so they go where a pass's do: into the convergence+    bookkeeping, and on to the caller's node reporter. Two filters, both+    about volume rather than meaning:++    * a 'UpDown.Skip' is recorded but not printed. The supervisor re-checks+      every node when it starts, and saying "nothing to do" once per node+      per convergence on top of what the pass already said is noise;+    * 'Upkeep.NextLook' and the state transitions are dropped entirely. Every+      node emits one on every nap, forever, which is a trace rather than a+      report. What survives is what an operator would want woken for: a+      wedged node, a paused one, a contradictory policy, a machine that+      escaped. -}+    tendReporter :: IORef (World seed directive) -> Rewritten Extension -> Reporter (Upkeep.Report Extension)+    tendReporter world computed = ReporterM $ \rep ->+        case rep of+            Upkeep.Acted inner -> do+                runReporter (tendWriter world computed) inner+                case inner of+                    UpDown.Skip _ -> pure ()+                    _ -> runReporter nodeReporter inner+            Upkeep.Upkeep{} -> pure ()+            Upkeep.Downkeep{} -> pure ()+            Upkeep.NextLook{} -> pure ()+            Upkeep.Untended{} -> pure ()+            _ -> runReporter r (Tended rep)++    {- | 'stateWriter', for a driver that tends both directions at once.++    The convergence version is told which direction its pass is for; a+    supervisor is not, so each node's own currently-wanted direction is what+    its outcome is recorded against. There is no @restriction@ either: a+    supervisor is never scoped by a @--select@, because the operator restricts+    a /pass/, not what is kept running. -}+    tendWriter :: IORef (World seed directive) -> Rewritten Extension -> Reporter (UpDown.Report Extension)+    tendWriter world computed = ReporterM $ \rep ->+        case rep of+            UpDown.Eval _ -> pure ()+            UpDown.Done act -> mark act Converged+            UpDown.Skip act -> mark act Converged+            UpDown.Failed act _ -> mark act Errored+            UpDown.Blocked act -> mark act Blocked+            UpDown.Conflicting{} -> pure ()+            UpDown.Instructed{} -> pure ()+            UpDown.DroppedInstructions{} -> pure ()+      where+        mark :: Act Extension -> Convergence -> IO ()+        mark act c =+            forM_ (Set.toList (Rewrite.membersOf computed act.extension.ref)) $ \rf ->+                atomicModifyIORef' world (\w -> (setConvergenceHere rf c w, ()))++    step :: Tending -> Int -> IORef (World seed directive) -> Origin -> String -> IO Bool+    step tending depth world origin line =+        case parseServeCommand line of+            Left err -> do+                runReporter r (BadCommand err)+                pure True+            Right cmd -> stepCommand tending depth world origin cmd++    stepCommand :: Tending -> Int -> IORef (World seed directive) -> Origin -> ServeCommand -> IO Bool+    stepCommand tending depth world origin cmd =+                case cmd of+                    Noop -> pure True+                    Quit -> pure False+                    Help mtopic -> do+                        runReporter r (HelpText mtopic)+                        pure True+                    Status sel -> do+                        w <- readIORef world+                        mode <- maybe (pure Interactive) followedMode onFetch+                        runReporter r (StatusReport mode (filterNodes w sel) (worldPaths w))+                        pure True+                    History sel -> do+                        w <- readIORef world+                        let (selr, excr) = resolveWorldSelectors w sel+                        let allowed = selr `Set.difference` excr+                        let matches :: LogEntry -> Bool+                            matches e = sel == noSelection || not (Set.null (Set.intersection e.logRefs allowed))+                        runReporter r (HistoryReport (historyLinesMatching matches w))+                        when (w.worldLogDropped > 0) $+                            runReporter r (HistoryElided w.worldLogDropped)+                        pure True+                    QueryCmd sel -> do+                        w <- readIORef world+                        let (selr, excr) = resolveWorldSelectors w sel+                        runReporter r (QueryReport (Map.toList w.worldNodes) selr excr (worldPaths w))+                        pure True+                    Converge sel -> do+                        restriction <-+                            if sel == noSelection+                                then pure Nothing+                                else do+                                    w <- readIORef world+                                    let (selr, excr) = resolveWorldSelectors w sel+                                    pure (Just (selr `Set.difference` excr))+                        converge tending world restriction+                        pure True+                    Clear -> do+                        w <- readIORef world+                        writeIORef world (resettle w{worldLedger = Ledger.retractAll w.worldLedger})+                        runReporter r (Cleared (Ledger.liveCount w.worldLedger))+                        convergeIfAuto tending world+                        pure True+                    Declare decl args -> do+                        declare tending world origin decl args+                        pure True+                    DeclareDirective decl path -> do+                        declareDirective tending world origin decl path+                        pure True+                    DeclareInline decl name value -> do+                        declareDecoded tending world origin decl ["<directive>", Text.unpack name] (parseEither parseJSON value)+                        pure True+                    Load path -> loadFile tending world (depth + 1) path+                    Supervise on -> do+                        writeIORef (tendingOn tending) on+                        -- turning it off has to take effect now; turning it+                        -- on happens the moment this loop is next idle,+                        -- which is immediately after this command.+                        unless on (stopTending tending world)+                        runReporter r (Supervised on)+                        pure True+                    AutoConverge on -> do+                        writeIORef (tendingAutoConverge tending) on+                        runReporter r (AutoConverged on)+                        pure True+                    Instruct instr sel -> do+                        w <- readIORef world+                        let (selr, excr) = resolveWorldSelectors w sel+                            allowed = selr `Set.difference` excr+                        queueInstruction tending allowed instr+                        runReporter r (Instructed instr (Set.size allowed))+                        pure True+                    Fetch -> do+                        traverse_ followedFetch onFetch+                        runReporter r (FetchRequested (isJust onFetch))+                        pure True++    -- | Filters 'worldNodes' by a 'Selection', preserving today's exact+    -- unfiltered listing (including nodes wanted 'TurnDown') when no+    -- @--select@\/@--exclude@ was given at all.+    filterNodes :: World seed directive -> Selection -> [(Ref, NodeState)]+    filterNodes w sel+        | sel == noSelection = Map.toList w.worldNodes+        | otherwise =+            let (selr, excr) = resolveWorldSelectors w sel+                allowed = selr `Set.difference` excr+             in [(rf, st) | (rf, st) <- Map.toList w.worldNodes, rf `Set.member` allowed]++    loadFile :: Tending -> IORef (World seed directive) -> Int -> FilePath -> IO Bool+    loadFile tending world depth path+        | depth > maxLoadDepth = do+            runReporter r (BadLoad ("refusing to load " <> Text.pack path <> ": nesting too deep (possible cycle)"))+            pure True+        | otherwise = do+            runReporter r (Loading path)+            result <- try (readFile path) :: IO (Either IOException String)+            case result of+                Left ex -> do+                    runReporter r (BadLoad ("cannot read " <> Text.pack path <> ": " <> Text.pack (show ex)))+                    pure True+                Right contents -> go 0 (lines contents)+      where+        go n [] = do+            runReporter r (LoadDone path n)+            pure True+        go n (ln : rest) = do+            keepGoing <- step tending depth world (Loaded path) ln+            if keepGoing then go (n + 1) rest else pure False++    -- | A 'Configure' that throws is reported as a bad seed and the loop+    -- reads on, same as a seed that fails to parse. It used to take the whole+    -- loop down, which for a typed line was a nuisance and for a fetched+    -- document (whose author is not at this keyboard) would be a host+    -- losing its supervisor to somebody else's typo.+    declare :: Tending -> IORef (World seed directive) -> Origin -> Declaration -> [String] -> IO ()+    declare tending world origin decl args =+        case parseSeed args of+            Left err -> runReporter r (BadSeed err)+            Right seed -> do+                configured <- try (gen configure seed) :: IO (Either SomeException directive)+                case configured of+                    Left ex -> runReporter r (BadSeed (Text.pack (unwords args) <> ": configure threw: " <> Text.pack (show ex)))+                    Right directive -> declareConfigured tending world origin decl args seed directive++    declareConfigured :: Tending -> IORef (World seed directive) -> Origin -> Declaration -> [String] -> seed -> directive -> IO ()+    declareConfigured tending world origin decl args seed directive = do+                w0 <- readIORef world+                let o = run program directive+                let gr = evalDeps o+                let ep =+                        Epoch+                            { epochId = EpochId w0.worldNextId+                            , epochDeclaration = decl+                            , epochDirection = declarationDirection decl+                            , epochOrigin = origin+                            , epochTokens = args+                            , epochSeed = Just seed+                            , epochDirective = directive+                            , epochKey = encode directive+                            , epochGraph = gr+                            }+                commitEpoch tending world w0 decl ep++    declareDirective :: Tending -> IORef (World seed directive) -> Origin -> Declaration -> FilePath -> IO ()+    declareDirective tending world origin decl path = do+        result <- try (LByteString.readFile path) :: IO (Either IOException ByteString)+        case result of+            Left ex -> runReporter r (BadDirective ("cannot read " <> Text.pack path <> ": " <> Text.pack (show ex)))+            Right bytes -> declareDecoded tending world origin decl ["<directive-file>", path] (eitherDecode bytes)++    -- | The tail of a directive declaration once its JSON has been read from+    -- wherever it was: a decode failure is reported and nothing is declared.+    declareDecoded :: Tending -> IORef (World seed directive) -> Origin -> Declaration -> [String] -> Either String directive -> IO ()+    declareDecoded tending world origin decl tokens decoded =+                case decoded of+                    Left err -> runReporter r (BadDirective (Text.pack err))+                    Right directive -> do+                        w0 <- readIORef world+                        let o = run program directive+                        let gr = evalDeps o+                        let ep =+                                Epoch+                                    { epochId = EpochId w0.worldNextId+                                    , epochDeclaration = decl+                                    , epochDirection = declarationDirection decl+                                    , epochOrigin = origin+                                    , epochTokens = tokens+                                    , epochSeed = Nothing+                                    , epochDirective = directive+                                    , epochKey = encode directive+                                    , epochGraph = gr+                                    }+                        commitEpoch tending world w0 decl ep++    -- | Appends and records a freshly-built epoch, then converges (fully:+    -- a declaration is never itself scoped by a 'Selection') — unless+    -- @autoconverge off@ has asked declarations to just record and wait.+    commitEpoch :: Tending -> IORef (World seed directive) -> World seed directive -> Declaration -> Epoch seed directive -> IO ()+    commitEpoch tending world w0 decl ep = do+        let dag = Dag.foldDag Dag.sameRepresentative ep.epochGraph+        -- the fold is where a Ref collision inside one declaration is+        -- visible; the down pass no longer folds anything, so this is the+        -- only place left that can say so.+        forM_ (reverse (Dag.dagConflicts dag)) $ \c ->+            runReporter nodeReporter (UpDown.Conflicting c.conflictRef c.conflictKept c.conflictReplaced)+        let (recorded, crossed) = recordWith decl ep dag w0+        -- ... and a collision with another live declaration is only+        -- visible once the ledger says who else wants the node.+        forM_ crossed $ \c ->+            runReporter nodeReporter (UpDown.Conflicting c.conflictRef c.conflictKept c.conflictReplaced)+        let w1 = resettle recorded+        writeIORef world w1+        runReporter r $+            Declared+                ep.epochId+                ep.epochDirection+                (Map.size (Dag.dagNodes dag))+                (length w1.worldEpochs)+        convergeIfAuto tending world++    -- | 'converge's the whole world, unless @autoconverge off@ is in+    -- effect, in which case a declaring command's own report is the only+    -- thing the operator sees until an explicit @converge@.+    convergeIfAuto :: Tending -> IORef (World seed directive) -> IO ()+    convergeIfAuto tending world = do+        auto <- readIORef (tendingAutoConverge tending)+        when auto (converge tending world Nothing)++    -- | Runs one down-then-up convergence pass. @restriction@, when+    -- present, additionally 'Skippable'-gates any node whose 'Ref' isn't in+    -- it — used only by an explicit @converge --select\/--exclude@; the+    -- auto-converge that follows every declaration always passes 'Nothing'.+    converge :: Tending -> IORef (World seed directive) -> Maybe (Set Ref) -> IO ()+    converge tending world restriction = do+        -- 'loop' has already stood the one-shot machines down. What it did+        -- not do is let go of the effects something is still /holding/,+        -- because at that point this world had not yet been told what the+        -- command changed. Now it has, so: anything no longer wanted up goes+        -- first, before the down pass starts removing what it stood on.+        settleManaged tending world+        w <- readIORef world+        -- the rewrites run per pass rather than per declaration, because+        -- what they partition on ('Ledger.desired') is a property of the+        -- whole ledger at this moment, not of any one declaration.+        let computed = Rewrite.rewrite rewrites (phaseOf w restriction) (worldDag w)+        let dag = Rewrite.computedDag computed+        let (nup, ndown) = pendingCounts w+        runReporter r (ConvergeStart ndown nup)+        -- teardown first: a node being replaced by an incompatible one+        -- (different content, hence a different 'Ref') has to go before its+        -- successor is brought up.+        okDown <-+            if ndown == 0+                then pure True+                else+                    Concurrent.downDagConcurrent+                        (gateFor world computed TurnDown restriction)+                        (recorder world computed TurnDown restriction)+                        Concurrent.noMailboxes+                        limit+                        dag+        okUp <-+            if nup == 0+                then pure True+                else+                    Concurrent.upDagConcurrent+                        (gateFor world computed TurnUp restriction)+                        (recorder world computed TurnUp restriction)+                        Concurrent.noMailboxes+                        limit+                        dag+        -- this pass is what turns nodes converged-'TurnDown', so it is also+        -- where the graphs that described them stop being needed.+        modifyIORef' world resettle+        w' <- readIORef world+        let (rup, rdown) = pendingCounts w'+        runReporter r (ConvergeStop (okDown && okUp) (rup + rdown))++    {- | Only touch what this pass is for: a node wanted the other way (it+    belongs to some other seed), already converged, or excluded by this+    pass's own 'restriction' (an explicit @converge --select\/--exclude@) is+    left alone. -}+    gateFor :: IORef (World seed directive) -> Rewritten Extension -> Direction -> Maybe (Set Ref) -> UpDown.Gate Extension+    gateFor world computed dir restriction = \act -> do+        w <- readIORef world+        -- a node a rewrite introduced has no 'NodeState' of its own; it is+        -- worth touching iff any of the declared nodes it stands in for is.+        -- For every other node 'membersOf' is the singleton of itself, so+        -- this is the same predicate it always was.+        pure $+            -- a node whose effect only exists while something holds it is+            -- not this pass's business in either direction: bringing it up+            -- needs a driver that can hold it (so its @up@ throws, on+            -- purpose — see "Salmon.Builtin.Nodes.Daemon"), and taking it+            -- down is 'settleManaged', which has already run.+            if isJust act.extension.managed+                then Skippable+                else+                    if any (wants w) (Set.toList (Rewrite.membersOf computed act.extension.ref))+                        then Required+                        else Skippable+      where+        wants :: World seed directive -> Ref -> Bool+        wants w rf =+            case Map.lookup rf w.worldNodes of+                Nothing -> False+                Just st ->+                    st.nodeDirection == dir+                        && st.nodeConvergence /= Converged+                        && maybe True (Set.member rf) restriction++    recorder :: IORef (World seed directive) -> Rewritten Extension -> Direction -> Maybe (Set Ref) -> Reporter (UpDown.Report Extension)+    recorder world computed dir restriction = reportBoth (stateWriter world computed dir restriction) nodeReporter++    {- 'upTree'/'downTree' report an 'Eval' before running a node and, once+    it returns, exactly one of 'Done' (succeeded) or 'Failed' (threw) — so+    recording convergence off 'Done'/'Failed' rather than 'Eval' is exact. A+    'Skip' is either this pass's own gate (already converged, not ours — both+    fine to record as converged, the direction check below drops the latter+    — or restricted out by an explicit @converge --select\/--exclude@, which+    must leave the node's actual convergence untouched so a later+    unrestricted @converge@ still retries it) or, on the way up, the node's+    own 'check' saying its effect is already in place, which is convergence+    too. -}+    stateWriter :: IORef (World seed directive) -> Rewritten Extension -> Direction -> Maybe (Set Ref) -> Reporter (UpDown.Report Extension)+    stateWriter world computed dir restriction = ReporterM $ \rep ->+        case rep of+            UpDown.Eval _ -> pure ()+            UpDown.Done act -> mark act Converged+            UpDown.Skip act+                | maybe False (Set.notMember act.extension.ref) restriction -> pure ()+                -- 'gateFor' skips every managed node, and that skip says+                -- nothing about whether the node is up: only the machine+                -- holding it can say that, and it does so through+                -- 'tendWriter'.+                | isJust act.extension.managed -> pure ()+                | otherwise -> mark act Converged+            UpDown.Failed act _ -> mark act Errored+            UpDown.Blocked act -> mark act Blocked+            -- not a node outcome: it says two declarations describe one+            -- node differently, which the operator wants to see but which+            -- leaves no node any more or less converged than it was.+            UpDown.Conflicting{} -> pure ()+            -- likewise not node outcomes: an instruction being applied, or+            -- an older one being evicted, says what was asked for rather+            -- than what happened.+            UpDown.Instructed{} -> pure ()+            UpDown.DroppedInstructions{} -> pure ()+      where+        -- what happened to a collection node happened to every declared node+        -- it stands in for — that is the whole of what makes a batch's+        -- outcome legible in per-package terms, and it is why a batch+        -- reports failure for all of its members.+        -- 'atomicModifyIORef'', not 'modifyIORef'': the concurrent driver+        -- runs several nodes at once and they all report into this same+        -- world, so a read-modify-write that is not atomic silently loses+        -- convergence records.+        mark :: Act Extension -> Convergence -> IO ()+        mark act c =+            forM_ (Set.toList (Rewrite.membersOf computed act.extension.ref)) $ \rf ->+                atomicModifyIORef' world (\w -> (setConvergence dir rf c w, ()))++-------------------------------------------------------------------------------++{- | Folds one declaration in: its nodes into 'worldMagma', its nodes and+edges into 'worldLedger', its graph into 'worldEpochs', and a line into+'worldLog'. 'worldNextId' only ever grows, so an id in the log stays+meaningful after 'prune' has collected the epoch it names.++Every declaration is 'Ledger.declare'd before the retraction is applied,+@down@ included. That is not a detour: a @down@ re-evaluates its seed, and+folding that evaluation in first is what makes the teardown use the /current/+description of those nodes rather than whatever was declared last time. It is+also why the ledger entry is replaced rather than accumulated — the same key+declared twice is one declaration, so one @down@ retracts it.+-}+record :: Declaration -> Epoch seed directive -> Dag Extension -> World seed directive -> World seed directive+record decl ep dag w = fst (recordWith decl ep dag w)++{- | 'record', also handing back the collisions this declaration has with+/other/ live declarations (one per 'Ref', kept-and-replaced), which the loop+reports 'UpDown.Conflicting' beside the ones the fold found inside the+declaration itself. See 'Collision' for the rule.+-}+recordWith :: Declaration -> Epoch seed directive -> Dag Extension -> World seed directive -> (World seed directive, [Dag.Conflict Extension])+recordWith decl ep dag w =+    ( w+        { worldNextId = w.worldNextId + 1+        , worldEpochs = ep : w.worldEpochs+        , worldLog = kept+        , worldLogDropped = w.worldLogDropped + length dropped+        , -- left-biased: this declaration's representatives win, which is+          -- 'Salmon.Op.Dag''s last-writer-wins across declarations.+          worldMagma = Map.union (Dag.dagNodes dag) w.worldMagma+        , worldLedger = ledger'+        , worldConflicts = Map.union collisions (Map.withoutKeys w.worldConflicts described)+        , -- (I6): a 'Ref' this declaration redescribes goes 'Stale' rather+          -- than staying silently 'Converged' under a representative it was+          -- never actually applied against.+          worldNodes = foldr demoteIfChanged w.worldNodes (Set.toList changed)+        }+    , crossed+    )+  where+    contrib = Ledger.contribution dag+    described = Map.keysSet (Dag.dagNodes dag)++    retraction = case decl of+        Add -> id+        Replace -> Ledger.retractOthers ep.epochKey+        Remove -> Ledger.retract ep.epochKey++    ledger' = retraction (Ledger.declare ep.epochKey contrib w.worldLedger)++    -- the other live declarations still wanting a node — read off the+    -- ledger /after/ the retraction, so an @only@ does not collide with the+    -- very seeds it is retiring+    othersHolding :: Ref -> Set ByteString+    othersHolding rf =+        Map.keysSet (Map.filterWithKey (\k c -> k /= ep.epochKey && c.contribLive && Set.member rf c.contribRefs) ledger')++    -- the fold's own collisions, oldest first so the newest wins the map+    inside :: Map Ref (Dag.Conflict Extension)+    inside = Map.fromList [(c.conflictRef, c) | c <- reverse (Dag.dagConflicts dag)]++    -- the collisions this declaration is the last writer of: a node it+    -- describes differently from the magma while another live declaration+    -- still wants it. Reported, as the fold's own are.+    crossed :: [Dag.Conflict Extension]+    crossed =+        [ Dag.Conflict rf newAct oldAct+        | (rf, newAct) <- Map.toList (Dag.dagNodes dag)+        , Set.member rf changed+        , Just oldAct <- [Map.lookup rf w.worldMagma]+        , not (Set.null (othersHolding rf))+        ]++    crossedByRef :: Map Ref (Dag.Conflict Extension)+    crossedByRef = Map.fromList [(c.conflictRef, c) | c <- crossed]++    -- one entry per 'Ref' this declaration describes, or none+    collisions :: Map Ref Collision+    collisions = Map.mapMaybe id (Map.mapWithKey collisionOf (Dag.dagNodes dag))++    collisionOf :: Ref -> Act Extension -> Maybe Collision+    collisionOf rf _+        | Just c <- Map.lookup rf crossedByRef =+            Just (Collision c (othersHolding rf))+        | Just c <- Map.lookup rf inside =+            Just (Collision c (Set.singleton ep.epochKey))+        | not (Set.member rf changed)+        , Just standing <- Map.lookup rf w.worldConflicts+        , any (`Ledger.isLive` ledger') (Set.toList standing.collisionHolders) =+            Just standing+        | otherwise = Nothing+      where+        others = othersHolding rf++    {- | Every 'Ref' this declaration describes differently than whatever is+    already in the magma — the same 'Dag.sameRepresentative' comparison+    'Dag.foldDag' itself uses to decide a re-declaration is a genuine+    conflict rather than the overwhelmingly common "one node, reached+    again" case. A brand-new 'Ref' (absent from 'worldMagma') is not+    "changed": it has nothing to differ from, and 'retune' already gives it+    a fresh 'Pending' on its own.+    -}+    changed :: Set Ref+    changed =+        Set.fromList+            [ rf+            | (rf, newAct) <- Map.toList (Dag.dagNodes dag)+            , Just oldAct <- [Map.lookup rf w.worldMagma]+            , not (Dag.sameRepresentative oldAct newAct)+            ]++    -- only a node currently believed 'Converged' has anything to lose by+    -- this: one already 'Pending'\/'Stale'\/'Errored'\/'Blocked' is getting+    -- a fresh look regardless, and relabelling it would only blur why.+    demoteIfChanged :: Ref -> Map Ref NodeState -> Map Ref NodeState+    demoteIfChanged rf =+        Map.adjust (\st -> if st.nodeConvergence == Converged then st{nodeConvergence = Stale} else st) rf++    entry =+        LogEntry+            { logEpoch = ep.epochId+            , logDeclaration = ep.epochDeclaration+            , logOrigin = ep.epochOrigin+            , logTokens = ep.epochTokens+            , logRefs = Ledger.contribRefs contrib+            }+    (kept, dropped) = splitAt worldLogLimit (entry : w.worldLog)++{- | Re-derives the world after anything that could have changed it: first+'retune' (every node's wanted 'Direction', from the active seeds), then+'prune' (drop what is finished).++The order is load-bearing and is the one way to get this wrong. 'prune' asks+which nodes are still on their way down, and immediately after a @down@+declaration is 'record'ed those nodes still look 'TurnUp' and 'Converged' —+so pruning first would collect the very contribution the teardown is about to+be run from. 'retune' is what flips them to 'TurnDown'\/'Pending', after+which 'prune' keeps their contribution. (@Test.ServeSpec@'s "a retired+declaration survives a failed down" case pins this.)+-}+resettle :: World seed directive -> World seed directive+resettle = prune . retune++{- | Re-derives every node's wanted 'Direction' from the active seeds. A node+whose direction is unchanged keeps its 'Convergence'; one that just flipped+goes back to 'Pending', because whatever was done to it was done the other way.+-}+retune :: World seed directive -> World seed directive+retune w =+    w{worldNodes = Map.mapWithKey adjust known}+  where+    desired :: Set Ref+    desired = Ledger.desired w.worldLedger++    -- every node any retained contribution still mentions, with its metadata+    -- taken from the magma — i.e. from the last declaration to describe it.+    known :: Map Ref (ShortHand, Text)+    known =+        Map.fromList+            [ (r, (act.shorthand, act.extension.help))+            | r <- Set.toList (Ledger.knownRefs w.worldLedger)+            , Just act <- [Map.lookup r w.worldMagma]+            ]++    adjust r (sh, hlp) =+        let dir = if Set.member r desired then TurnUp else TurnDown+         in case Map.lookup r w.worldNodes of+                Just st+                    | st.nodeDirection == dir ->+                        st{nodeShorthand = sh, nodeHelp = hlp}+                _ -> NodeState sh hlp dir Pending Nothing++{- | Drops what is finished, which is what keeps a long-lived @serve@+bounded. Three rules that have to agree with each other:++  * a node converged 'TurnDown' is done — it is off the machine and nothing+    will be done to it again — so it leaves 'worldNodes' and 'worldMagma';+  * a /retired/ contribution is kept only while one of its nodes is still to+    be turned down, since its edges are the only remaining statement of what+    order to do that in. A live one is never dropped: it is what holds its+    nodes up;+  * an epoch is kept only while its declaration is live, and then only the+    newest for that key. Nothing else needs a graph any more — this is where+    the storage saving is, and it is the rule that used to also have to keep+    a retired seed's graph for the teardown to walk.++The two 'Map.restrictKeys' are implied by the rules rather than adding to+them: they make "every node in 'worldNodes' is described by some retained+contribution, and every one has a representative" hold structurally instead+of by argument.++Note this is why re-declaring an unchanged seed is cheap forever: the+superseded epoch is no longer newest for its key while its nodes stay+'TurnUp' under the new one, so its graph goes.+-}+prune :: forall seed directive. World seed directive -> World seed directive+prune w =+    w+        { worldEpochs = keptEpochs+        , worldLedger = ledger+        , worldMagma = Map.restrictKeys w.worldMagma (Map.keysSet retained)+        , worldConflicts = Map.filter standing (Map.restrictKeys w.worldConflicts (Map.keysSet retained))+        , worldNodes = retained+        }+  where+    nodes = Map.filter (not . finished) w.worldNodes++    -- a collision stands while somebody on its losing side is still live+    standing :: Collision -> Bool+    standing c = any (`Ledger.isLive` ledger) (Set.toList c.collisionHolders)+    retained = Map.restrictKeys nodes (Ledger.knownRefs ledger)++    -- these locals are annotated because a record-dot binding without a+    -- signature generalizes over 'HasField' and would need FlexibleContexts.+    finished :: NodeState -> Bool+    finished st = st.nodeDirection == TurnDown && st.nodeConvergence == Converged++    ledger = Ledger.collect stillToTurnDown w.worldLedger++    stillToTurnDown :: Ref -> Bool+    stillToTurnDown r =+        case Map.lookup r nodes of+            Just st -> st.nodeDirection == TurnDown+            Nothing -> False++    -- newest-first, so the first epoch seen for a key is the current one.+    keptEpochs :: [Epoch seed directive]+    keptEpochs = go Set.empty w.worldEpochs+      where+        go :: Set ByteString -> [Epoch seed directive] -> [Epoch seed directive]+        go _ [] = []+        go seen (ep : eps)+            | Set.member ep.epochKey seen = go seen eps+            | Ledger.isLive ep.epochKey ledger = ep : go (Set.insert ep.epochKey seen) eps+            | otherwise = go (Set.insert ep.epochKey seen) eps++setConvergence :: Direction -> Ref -> Convergence -> World seed directive -> World seed directive+setConvergence dir r c w =+    w{worldNodes = Map.adjust upd r w.worldNodes}+  where+    upd st+        | st.nodeDirection == dir = st{nodeConvergence = c}+        | otherwise = st++{- | 'setConvergence' against whichever direction the node is currently+wanted in, rather than against a stated one.++The convergence passes know their own direction and use it as a filter — a+node wanted the other way belongs to another pass and must not be recorded.+A supervisor tends both directions at once and has no such filter to apply,+so the node's own state is the answer.+-}+setConvergenceHere :: Ref -> Convergence -> World seed directive -> World seed directive+setConvergenceHere r c w =+    case Map.lookup r w.worldNodes of+        Nothing -> w+        Just st -> setConvergence st.nodeDirection r c w++-- | (nodes wanted up, nodes wanted down) that have not converged yet.+pendingCounts :: World seed directive -> (Int, Int)+pendingCounts w =+    (count TurnUp, count TurnDown)+  where+    count dir = length [() | st <- Map.elems w.worldNodes, st.nodeDirection == dir, st.nodeConvergence /= Converged]++{- | What the "Salmon.Op.Rewrite" phases are told about the pass about to+run: which nodes some live declaration still wants (so a rewrite can tell an+install from a removal), and which ones an explicit @converge+--select@\/@--exclude@ has put out of scope (so a rewrite does not quietly+batch up work the operator asked to skip).+-}+phaseOf :: World seed directive -> Maybe (Set Ref) -> Phase+phaseOf w restriction =+    Phase+        { phaseDesired = Ledger.desired w.worldLedger+        , phaseIgnored = maybe Set.empty (Map.keysSet w.worldNodes `Set.difference`) restriction+        }++{- | What both convergence passes walk: the magma, wired back up with the+precedence the ledger holds. No graph is involved, which is the point — a+retired declaration's graph is long gone, and its two flat sets are enough.++One structure for both directions, rather than a union of graphs per pass.+Nodes this pass is not for are in it too, exactly as they used to be in the+epoch graphs the old @upOps@\/@downOps@ handed over; the pass's+'UpDown.Gate' is what leaves them alone, and a 'UpDown.Skip'ped node releases+its neighbours just like an applied one.+-}+worldDag :: World seed directive -> Dag Extension+worldDag w = Dag.fromMagma w.worldMagma (Ledger.precedenceOf w.worldLedger)++{- | Read off 'worldLog', not 'worldEpochs' — a declaration is still worth+printing long after 'prune' has collected the graph it made. The+@[active]@\/@[retired]@ flag stays exact regardless: a collected epoch is+never in 'worldActive'. The only caller is 'HistoryReport', with a predicate+of @const True@ for a plain @history@; there is no unfiltered version left+to call directly, since there was never a caller for one.+-}+historyLinesMatching ::+    (LogEntry -> Bool) ->+    World seed directive ->+    [(EpochId, Declaration, Bool, Origin, [String])]+historyLinesMatching p w =+    [ (e.logEpoch, e.logDeclaration, Set.member e.logEpoch activeIds, e.logOrigin, e.logTokens)+    | e <- reverse w.worldLog+    , p e+    ]+  where+    activeIds = activeEpochIds w++{- | Resolves a 'Selection' against every currently-/active/ epoch's graph,+unioning the per-epoch matches — there is no single unified cograph for the+whole 'World', only the unified 'worldNodes' map. An empty 'selSelect' still+resolves to "everything" per epoch, so the union over active epochs is+exactly every active node, mirroring 'retune''s own @desired@ computation.++A pattern beginning with @#@ is, exactly as 'Query.resolveRewrittenSelectors'+already does for @run up@\/@run down@, matched by 'Ref' instead of by path: a+fragment of the text 'status'\/'query' now print on every node's line (either+the short, disambiguating tag or the full 'Ref'). This is what makes a node+addressable at all when two of them share every path — a recipe that reuses+the same shorthand (\"directory\", \"file-contents\", ...) at each position+gives 'Query.pathedRefs' no way to tell them apart by path, and printing the+paths in 'worldPaths' cannot invent a distinction that was never there.+-}+resolveWorldSelectors :: World seed directive -> Selection -> (Set Ref, Set Ref)+resolveWorldSelectors w sel =+    (selectedBase `Set.difference` excluded, excluded)+  where+    (selRefPats, selPathPats) = List.partition isRefFragment sel.selSelect+    (excRefPats, excPathPats) = List.partition isRefFragment sel.selExclude++    allRefs = Set.unions [Set.fromList (map snd (Query.pathedRefs ep.epochGraph)) | ep <- w.worldEpochs]++    pathMatches :: [Text] -> Set Ref+    pathMatches [] = Set.empty+    pathMatches pats = Set.unions [fst (Query.resolveSelectors ep.epochGraph pats []) | ep <- w.worldEpochs]++    refMatches :: [Text] -> Set Ref+    refMatches pats = Set.fromList [rf | rf <- Set.toList allRefs, pat <- pats, matchesRefFragment pat rf]++    matchesRefFragment :: Text -> Ref -> Bool+    matchesRefFragment pat rf =+        let fragment = Text.drop 1 pat+         in fragment `Text.isPrefixOf` Query.shortRef rf || fragment `Text.isPrefixOf` unRef rf++    isRefFragment :: Text -> Bool+    isRefFragment = Text.isPrefixOf "#"++    matchesOf :: [Text] -> [Text] -> Set Ref+    matchesOf pathPats refPats = pathMatches pathPats `Set.union` refMatches refPats++    selectedBase = if null sel.selSelect then allRefs else matchesOf selPathPats selRefPats+    excluded = matchesOf excPathPats excRefPats++{- | The epochs 'prune' retained are exactly the live declarations' newest+ones, so this needs no separate active-seed index — the ledger's liveness is+the only source of truth for what is declared up.+-}+activeEpochIds :: World seed directive -> Set EpochId+activeEpochIds w = Set.fromList (fmap epochId w.worldEpochs)++{- | Every path (rendered @\/@-separated, root-to-node, exactly the shape+@--select@\/@--exclude@ patterns match against) at which a live declaration's+graph reaches each 'Ref' — the thing @status@\/@query@ never showed despite+being the only practical way to /build/ a selector pattern in the first+place: without this, a node was nameable only by its 'Ref' (opaque) or by+guessing the path back from its 'nodeShorthand' and hoping there is exactly+one node with that shorthand. A node reached by more than one seed, or twice+within one seed's graph, can have more than one path; all of them are shown,+since any one is a valid selector. Sourced from 'worldEpochs' only, same as+'resolveWorldSelectors' — a retired seed's graph is gone, and a node with no+entry here (nothing in it, or absent from the map) is one no /live/+declaration's graph currently reaches by path at all, addressable only by its+'Ref' (the @#@-prefixed form 'Query.resolveRewrittenSelectors' understands).+-}+worldPaths :: World seed directive -> Map Ref [Text]+worldPaths w =+    Map.map (nub . sortOn Text.length) $+        Map.fromListWith+            (++)+            [ (ref, [Text.intercalate "/" path])+            | ep <- w.worldEpochs+            , (path, ref) <- Query.pathedRefs ep.epochGraph+            ]
+ src/Salmon/Actions/Serve/Events.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | The event stream behind @GET \/events@: one numbered, replayable record+of everything the loop and its machines report.++Milestone 4 of @specs\/generic-server.md@. "Salmon.Actions.Serve.Http"+mounts it; this module is the part with no HTTP in it — the counter, the+ring, the broadcast, and the reporter that feeds them — so that it can be+reasoned about (and tested) without a socket.++= One counter, one order++Every event carries a sequence number drawn from one counter per loop, and+so does every command @POST \/command@ queues (an @?async@ answer is that+number). The counter is taken, the ring appended and the broadcast written+in __one STM transaction__ ('publish'), which is what makes the number an+order rather than a label: the ring holds events in sequence order with no+holes, a client resuming from @?since=n@ gets exactly the events numbered+above @n@, and an @?async@ client waiting for "the reports of my command"+waits for events numbered above the one it was handed, stamped with its+origin.++The spec's open question asks that the number be taken under the same+'Control.Concurrent.MVar.MVar' the concurrent driver serialises+'runReporter' through, because 'Salmon.Actions.Upkeep' reports come from+machine threads while 'Salmon.Actions.Serve' and 'Salmon.Actions.UpDown'+reports come from the loop. That lock cannot be shared, as it turns out:+there is not one of it. "Salmon.Actions.Concurrent" makes a fresh+@reportLock@ inside every walk (two per convergence pass) and+"Salmon.Actions.Upkeep" makes its own in every supervisor, each local to+the function that made it. What each of them does hold while it calls+'runReporter' is /its/ lock, so a numbering reporter whose whole effect is+one transaction composes __under__ every one of them: within a driver,+report order and sequence order agree because the driver's lock serialises+its calls and each call's transaction is indivisible; across drivers and+threads, the transaction alone gives one total order. That is the answer+taken here — the numbering reporter is its own critical section (an STM+transaction, the moral equivalent of an 'Control.Concurrent.MVar.MVar' with+nothing else in it), and the drivers' locks compose over it.++= What is on the stream, and what is only here++Every 'Serve.Report' and 'UpDown.Report' the loop's reporters see, stamped+with the 'Origin' of the command being handled when there is one; and the+tending machines' 'Upkeep.Report's, which the loop hands its reporter+wrapped as 'Serve.Tended' between commands and which are unwrapped here to+the @upkeep@ stream they came from. __This stream is the only place a+client can see the machines at work__: a synchronous @POST \/command@ answers+with the reports stamped for that command, and tending happens exactly when+no command is being handled, so its reports have no origin and no request+to be answered to. A @\/dag@ or @\/status@ read is a snapshot that is at most+one command old (see "Salmon.Actions.Serve.Http"); the motion between+commands is here or nowhere.++Two events are the server's own rather than a report, under+@stream: "server"@: an @enqueued@ event for every command the HTTP surface+queues (which is what keeps the numbering dense — the number an @?async@+answer carries is an event in the ring like any other), and a @gap@ event,+sent first to a client whose @?since@ has fallen off the ring, so a+resumption never skips silently.++= The ring++A bounded 'Seq' of the newest events, oldest dropped first. It bounds+memory rather than promising history: a client that stays connected misses+nothing, a client that reconnects promptly misses nothing, and a client+that comes back after more events than the ring holds is told so. The size+is @run serve --events-ring N@.+-}+module Salmon.Actions.Serve.Events (+    -- * The record+    Events,+    eventsConfig,+    Config (..),+    defaultConfig,+    newEvents,+    Event (..),+    Body (..),++    -- * Feeding it+    publish,+    enqueued,+    eventsReporter,+    lastSequence,++    -- * Reading it+    Subscription (..),+    withSubscription,+    subscribers,+    Filter (..),+    noFilter,+    matches,+    streamOf,++    -- * The wire+    eventValue,+    gapValue,+    renderEvent,+    renderGap,+    keepAlive,+) where++import Control.Concurrent.STM (STM, TChan, TVar, atomically, dupTChan, modifyTVar', newBroadcastTChanIO, newTVarIO, readTChan, readTVar, readTVarIO, writeTChan, writeTVar)+import Control.Exception (bracket_)+import Control.Monad (void)+import Data.Aeson (Value (..), encode, object, toJSON, (.=))+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Builder as Builder+import Data.Foldable (toList)+import Data.Sequence (Seq, (|>))+import qualified Data.Sequence as Seq+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import Data.Word (Word64)++import qualified Salmon.Actions.Upkeep as Upkeep+import qualified Salmon.Actions.Serve as Serve+import Salmon.Actions.Serve (Attributed (..), Origin)+import Salmon.Reporter+import Salmon.Reporter.Tagged (Tagged (..), originValue)++-------------------------------------------------------------------------------++data Config = Config+    { configRing :: !Int+    -- ^ how many events the ring keeps; at least one+    , configKeepAlive :: !Int+    -- ^ microseconds of silence before a subscriber is sent a comment+    -- line, so that proxies and clients with a read timeout do not drop+    -- an idle stream+    }+    deriving (Show, Eq)++-- | A ring in the low thousands, a keep-alive every fifteen seconds.+defaultConfig :: Config+defaultConfig = Config{configRing = 2048, configKeepAlive = 15 * 1000000}++-- | What an event is about.+data Body+    = -- | a report from one of the three streams+      Reported !Tagged+    | -- | a command the HTTP surface queued: the line, as typed+      Enqueued !String+    deriving (Show)++data Event = Event+    { eventSeq :: !Word64+    , eventOrigin :: !(Maybe Origin)+    -- ^ the command this belongs to: the origin of the line being handled+    -- when it was reported, or the origin a command was queued under+    , eventBody :: !Body+    }+    deriving (Show)++-- | The record: counter, ring and broadcast, all written in one transaction.+data Events = Events+    { eventsConfig :: !Config+    , eventsLast :: !(TVar Word64)+    -- ^ the last number handed out; 0 before the first+    , eventsRing :: !(TVar (Seq Event))+    -- ^ the newest 'configRing' events, oldest first, contiguous+    , eventsChan :: !(TChan Event)+    -- ^ broadcast; a subscriber reads a 'dupTChan' of it+    , eventsSubscribers :: !(TVar Int)+    }++newEvents :: Config -> IO Events+newEvents cfg =+    Events cfg{configRing = max 1 cfg.configRing}+        <$> newTVarIO 0+        <*> newTVarIO Seq.empty+        <*> newBroadcastTChanIO+        <*> newTVarIO 0++-------------------------------------------------------------------------------+-- feeding++{- | Number a body, keep it, broadcast it: one transaction, see the module+header. Returns the number.+-}+publish :: Events -> Maybe Origin -> Body -> IO Word64+publish ev origin body = atomically $ do+    n <- (+ 1) <$> readTVar ev.eventsLast+    writeTVar ev.eventsLast n+    let e = Event n origin body+    modifyTVar' ev.eventsRing $ \ring ->+        let ring' = ring |> e+         in if Seq.length ring' > ev.eventsConfig.configRing then Seq.drop 1 ring' else ring'+    writeTChan ev.eventsChan e+    pure n++-- | The event for a command queued under an origin; returns its number.+enqueued :: Events -> Origin -> String -> IO Word64+enqueued ev origin line = publish ev (Just origin) (Enqueued line)++{- | The reporter to compose beside the loop's own. A 'Serve.Tended' report+is published as the 'Upkeep.Report' inside it: the wrapper exists so that+the loop can forward the machines' stream through its one reporter, and the+stream tag says the same thing on the wire.+-}+eventsReporter :: Events -> Reporter (Attributed Tagged)+eventsReporter ev = ReporterM $ \(Attributed origin tagged) ->+    void (publish ev origin (Reported (unwrap tagged)))+  where+    unwrap (FromServe (Serve.Tended inner)) = FromUpkeep inner+    unwrap t = t++{- | The last number handed out, for a snapshot to carry: everything that+happens after a read of this is numbered above it. A read that pairs this+with a snapshot takes this __first__, so that an event landing between the+two is replayed rather than skipped — a client applies it twice, which is+the safe direction for a state event, instead of never.+-}+lastSequence :: Events -> IO Word64+lastSequence ev = readTVarIO ev.eventsLast++-------------------------------------------------------------------------------+-- reading++-- | A replay and a live feed, taken in one transaction so nothing is+-- between them.+data Subscription = Subscription+    { subscriptionGap :: !(Maybe Word64)+    -- ^ 'Just' the oldest number still in the ring, when the events just+    -- after @since@ are no longer there+    , subscriptionReplay :: ![Event]+    -- ^ the events numbered above @since@ that the ring still has+    , subscriptionLive :: !(STM Event)+    -- ^ the next event after those; blocks+    }++{- | Subscribe from a point: 'Nothing' for live only, @'Just' n@ for+everything after @n@ (@0@ is the whole ring). The subscriber count is+kept for as long as the action runs, however it ends — a client+disconnecting is an exception out of its stream, and that is the cleanup.+-}+withSubscription :: Events -> Maybe Word64 -> (Subscription -> IO a) -> IO a+withSubscription ev since act =+    bracket_+        (atomically (modifyTVar' ev.eventsSubscribers (+ 1)))+        (atomically (modifyTVar' ev.eventsSubscribers (subtract 1)))+        (atomically subscribe >>= act)+  where+    subscribe :: STM Subscription+    subscribe = do+        chan <- dupTChan ev.eventsChan+        ring <- readTVar ev.eventsRing+        let (gap, replay) = case since of+                Nothing -> (Nothing, [])+                Just n ->+                    let after = toList (Seq.dropWhileL (\e -> e.eventSeq <= n) ring)+                     in case Seq.lookup 0 ring of+                            -- the ring is contiguous, so the first event+                            -- after `n` is missing iff the oldest one kept+                            -- is already past it+                            Just oldest | oldest.eventSeq > n + 1 -> (Just oldest.eventSeq, after)+                            _ -> (Nothing, after)+        pure+            Subscription+                { subscriptionGap = gap+                , subscriptionReplay = replay+                , subscriptionLive = readTChan chan+                }++-- | How many subscriptions are open right now.+subscribers :: Events -> IO Int+subscribers ev = readTVarIO ev.eventsSubscribers++{- | What a client asked to see: 'Nothing' is everything. Server-side, since+the spec's "clients filter" is right about who decides and wrong about who+pays — a terminal client over a slow link wants less on the wire.+-}+data Filter = Filter+    { filterStreams :: !(Maybe (Set Text))+    -- ^ @serve@, @updown@, @upkeep@, @server@+    , filterOrigins :: !(Maybe (Set Text))+    -- ^ by 'Serve.originName'+    }+    deriving (Show, Eq)++noFilter :: Filter+noFilter = Filter Nothing Nothing++matches :: Filter -> Event -> Bool+matches f e =+    maybe True (Set.member (streamOf e.eventBody)) f.filterStreams+        && maybe True (\os -> maybe False (\o -> Set.member (Serve.originName o) os) e.eventOrigin) f.filterOrigins++-- | The @stream@ an event is filed under: the 'Tagged' one, or @server@.+streamOf :: Body -> Text+streamOf body = case body of+    Reported (FromServe _) -> "serve"+    Reported (FromUpDown _) -> "updown"+    Reported (FromUpkeep (Upkeep.Output _ _)) -> "output"+    Reported (FromUpkeep _) -> "upkeep"+    Reported (FromFollow _) -> "follow"+    Enqueued _ -> "server"++-------------------------------------------------------------------------------+-- the wire++{- | The 'Tagged' object with @seq@ added, and @origin@ (the object+@history@ entries use) when the event belongs to a command; an @enqueued@+event is @{"stream":"server","kind":"enqueued","line":...}@ with the same+two.+-}+eventValue :: Event -> Value+eventValue e = withSeq (withOrigin base)+  where+    base = case e.eventBody of+        Reported tagged -> toJSON tagged+        Enqueued line -> object ["stream" .= streamOf e.eventBody, "kind" .= ("enqueued" :: Text), "line" .= line]+    withSeq = insert "seq" (toJSON e.eventSeq)+    withOrigin v = maybe v (\o -> insert "origin" (originValue o) v) e.eventOrigin+    insert k v (Object o) = Object (KeyMap.insert k v o)+    insert k v other = object [k .= v, "report" .= other]++-- | The synthetic event a resumption that fell off the ring is sent first:+-- @from@ is the oldest number the replay then starts at.+gapValue :: Word64 -> Value+gapValue oldest = object ["kind" .= ("gap" :: Text), "from" .= oldest, "stream" .= ("server" :: Text)]++-- | One SSE event: its number as @id@, its object as @data@.+renderEvent :: Event -> Builder.Builder+renderEvent e =+    "id: " <> Builder.word64Dec e.eventSeq <> "\ndata: " <> Builder.lazyByteString (encode (eventValue e)) <> "\n\n"++-- | The gap event, with no @id@: a client resumes from the last real one.+renderGap :: Word64 -> Builder.Builder+renderGap oldest = "data: " <> Builder.lazyByteString (encode (gapValue oldest)) <> "\n\n"++-- | An SSE comment line, which a client ignores and a proxy sees as traffic.+keepAlive :: Builder.Builder+keepAlive = Builder.byteString ": keep-alive\n\n"
+ src/Salmon/Actions/Serve/Http.hs view
@@ -0,0 +1,1204 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++{- | The read surfaces and the command surface as HTTP over a unix socket:+@run serve --http PATH@.++Milestone 3 of @specs\/generic-server.md@. Four reads and one write:++  * @GET \/dag@ — the computed 'Dag' ('Serve.worldDag': the magma wired up+    with the ledger's precedence, the structure a convergence pass walks),+    one object per 'Ref' in 'Dag.dagOrder' with its edges in both directions+    and the loop's state for it. It exists from the first declaration on: a+    pass need not have run, and every node then simply reads @pending@. A+    node a retired declaration still describes is in it too, with+    @direction: down@, until its teardown is done and 'Serve.prune' drops+    it.+  * @GET \/status@, @GET \/history@ — the same objects @--json@ prints for+    the @status@ and @history@ commands ("Salmon.Reporter.Tagged"'s+    encoding, reused rather than re-described).+  * @GET \/help\/seed@ — this binary's own seed parser's @--help@ text, and+    the loop's command reference.+  * @POST \/command@ — one line of the input language, typed into the inbox+    exactly as a socket client's would be. Synchronous by default: the+    response is the JSON array of every report that line produced, which+    is what @curl@ and a CI step want. With @?async@ the line is queued and+    the response is the sequence number it was queued at, for a client+    that reads the event stream from there instead.+  * @GET \/events@ — the event stream, milestone 4, as server-sent events:+    every report the loop's reporters see, numbered, with @?since=N@ to+    replay what the ring still holds after @N@ and go on live, and+    @?stream=@\/@?origin=@ to narrow it. "Salmon.Actions.Serve.Events" is+    the record behind it; this module only writes it to a connection.+  * @GET \/@ and @GET \/ui\/*@ — the web UI (milestone 7), a handful of+    static files under @salmon-ops\/ui\/@ compiled into the binary with+    "Data.FileEmbed", so a binary is one file whatever it serves. The+    page is a client of the surfaces above and nothing more: it draws+    @\/dag@ and follows @\/events@ from that snapshot's @seq@. Nothing+    here is dynamic — a path outside the embedded set is the same @404@+    as any other unknown route, and there is no template.++= Reads never touch the inbox++Every command the loop handles first stands the tending machines down+('Serve.stopTending'), because a command is about to act. A read is not,+so it does not queue: it reads the loop's own 'Serve.World' cell through+the accessor 'Serve.serveObserved' hands over, and the tending snapshot that+cell already carries. That is what makes @\/status@ answer at once while a+node's @up@ is taking a minute in the loop, and it is the property the+loop's (R3) snapshot design was built for. The price is exactly what the+spec says: a read is at most one command old, and motion between commands+is the event stream's business, not this module's.++= One inbox, one attribution++A command is one more 'Serve.Producer' into the loop's inbox+('serverProducer'), pushed under an 'Origin' minted per request, followed+in the same transaction by that origin's 'Serve.Eof' so nothing another+producer types lands between the two. Which reports belong to the request+is the loop's knowledge — 'Serve.serveAttributed' stamps each with the+origin of the line being handled — and 'serverReporters' only collects the+ones stamped for a request still waiting, then lets the request go on the+loop's 'Serve.HungUp' for its origin, which the loop reports once every+line the origin typed has been handled. The same closing rule as+"Salmon.Actions.Serve.Socket", for the same reason.++= Its own socket, not the line protocol's++@--http@ takes a path of its own rather than sharing @--listen@'s and+telling the two apart by their first bytes. Detection itself is easy (an+HTTP request line is unmistakable); what it costs is elsewhere: the line+protocol reads its connection through a 'System.IO.Handle', which buffers+past the bytes peeked and cannot give them back, so both protocols would+have to be rewritten over raw sockets, and warp would need a+@Connection@ shim from its @Internal@ module to replay the peeked bytes.+Two paths cost one flag. The socket is bound through+'Socket.withUnixListener' all the same, so it is owner-only and refuses a+path something else is listening on — permissions are the whole access+story on that path (see the spec's security section).++= Over the network: TLS and a token, or nothing++Milestone 8. @run serve --http-tcp HOST:PORT --tls-cert FILE --tls-key+FILE --token-file FILE@ runs the same 'application' on a TCP listener+('withHttpServerOn', a 'BindTls' beside the unix 'BindUnix'), and the three+files are not optional: 'Bind' has no plaintext TCP constructor, and the+command line refuses @--http-tcp@ without all three, naming the missing+ones. A salmon server is root on the box one @up@ away, so it never listens+on a network without both. warp-tls answers a plain-HTTP client on that+port with @426 Upgrade Required@ and never reaches the application.++The token is 'requireToken', a middleware on the TCP listener only:+@Authorization: Bearer \<token\>@ on every route — the reads, the command,+the event stream, anything a later milestone adds to the application —+compared in constant time ('sameSecret') against the file's trimmed+content, or a session cookie a browser got by posting that token to+@\/auth@ (a browser cannot put a header on a navigation or an+@EventSource@), @401@ with a JSON error otherwise — @GET \/@ excepted,+which redirects to @\/auth@. @POST \/auth\/logout@ revokes the session,+cutting any event stream it had open. It is a middleware rather than+a check inside 'application' because the unix socket must stay token-free+(its permissions are its access story, and every client of it today is a+local one), and so that a route added to 'application' is covered without+its author knowing the token exists. Checking a token queues nothing: a+read is still a read. The file itself is 'readTokenFile': refused when+readable by others, or empty.++One 'Server' value serves both listeners — one event ring, one request+counter, one inbox — so sequence numbers are one sequence across them, and+an origin is 'originFor': @PATH#n@ on the unix socket, @ADDR:PORT#n@ (the+client's) over TCP, so @history@ says who typed a line from the network.+Not here: a client certificate instead of a token, a read-only token, a+plaintext option behind any flag, sessions that expire on their own.++= Sequence numbers++One counter, on 'Events'. A command @POST \/command@ queues is an+@enqueued@ event numbered from it (an @?async@ answer is that number), and+every report is numbered from it as it is published, in one transaction+with the ring and the broadcast — see "Salmon.Actions.Serve.Events" for+why that transaction, rather than the concurrent driver's reporter lock,+is the critical section. A client has one cursor: everything that happened+after its command was queued is everything numbered after the number it+was handed, and @\/dag@ and @\/status@ carry @seq@, the last number handed+out when the snapshot was read, so that @\/events?since=@ that number+resumes without a gap. The number is read __before__ the world, so an+event landing between the two reads is replayed rather than skipped.++= The stream on the wire++@\/events@ is a @text\/event-stream@ response that does not end until the+client goes or the loop does: one @id: N@ \/ @data: {...}@ per event (the+'Events.eventValue' object), a @gap@ event first when the ring no longer+reaches @?since@, and a comment line after every 'Events.configKeepAlive'+of silence, so a proxy between here and the client, or a client with a+read timeout, keeps the connection. A client hanging up is an exception+out of the write, which ends the stream and drops its subscription; the+loop ending sets 'serverStopped', on which every open stream returns, so+warp's shutdown does not wait behind a subscriber.+-}+module Salmon.Actions.Serve.Http (+    -- * Serving+    Server,+    serverName,+    serverEvents,+    serverBoundTcp,+    withHttpServer,+    withHttpServerWith,++    -- * Over the network+    Bind (..),+    TlsBind (..),+    withHttpServerOn,+    BadCredentials (..),+    requireToken,+    SessionPolicy (..),+    defaultSessionPolicy,+    SessionClock (..),+    systemSessionClock,+    Sessions,+    newSessions,+    newSessionsWith,+    newSession,+    knownSession,+    endSession,+    sessionCount,+    withStream,+    sessionOver,+    sameSecret,+    TokenError (..),+    readTokenFile,++    -- * Plugging into the loop+    serverObserver,+    serverProducer,+    serverReporters,+    serverFollowReporter,++    -- * The command body+    renderStructured,++    -- * The machine-readable description of this API+    openApiDocument,++    -- * The read model+    WorldView (..),+    viewWorld,+    dagValue,+    application,+) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (race, withAsync)+import qualified Control.Concurrent.STM as STM+import Control.Concurrent.STM (TChan, TVar, atomically, modifyTVar', newTVarIO, orElse, readTVar, readTVarIO, registerDelay, retry, writeTChan, writeTVar)+import Control.Exception (Exception, bracket, bracket_, finally, fromException, throwIO)+import Control.Monad (forM_, join, unless, void, when)+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.Random as Random+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), encode, object, withObject, (.:), (.:?), (.=))+import Data.FileEmbed (embedDir, embedFile, makeRelativeToProject)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Bits (xor, (.&.), (.|.))+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Base64.URL as Base64+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Lazy as LByteString+import Data.Char (isSpace, toLower)+import Data.Maybe (fromMaybe, isNothing)+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.List (foldl')+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 qualified Data.Text.Encoding as Text+import qualified Data.Text.Read as Text+import Data.Word (Word64, Word8)+import GHC.Clock (getMonotonicTimeNSec)+import System.FilePath (takeExtension)+import qualified Network.HTTP.Types as HTTP+import qualified Network.Socket as Socket+import qualified Network.TLS as TLS+import Network.Wai (Application, Request, Response)+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Handler.WarpTLS as WarpTLS+import System.Posix.Files (fileMode, getFileStatus)++import qualified Salmon.Actions.Serve as Serve+import Salmon.Actions.Serve (Attributed (..), Declaration, EpochId, Line (..), NodeState (..), Origin (..), Producer (..), World (..))+import qualified Salmon.Actions.Serve.Events as Events+import Salmon.Actions.Serve.Events (Events)+import qualified Salmon.Actions.Serve.Socket as Socket+import qualified Salmon.Actions.UpDown as UpDown+import Salmon.Builtin.Extension (Extension (..))+import Salmon.Op.Actions (Act (..))+import Salmon.Op.Dag (Dag)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Ref (Ref)+import Salmon.Op.Status (Direction (..))+import qualified Salmon.Actions.Follow as Follow+import Salmon.Reporter+import Salmon.Reporter.Tagged (Tagged (..), nodeStatePairs, refValue, representativeValue)++-------------------------------------------------------------------------------++-- | One or more listeners with warp accepting on them, and the requests in flight.+data Server = Server+    { serverName :: String+    -- ^ what a request's origin is named after: the unix socket's path when+    -- there is one, else @HOST:PORT@ (see 'originFor')+    , serverBoundTcp :: TVar [Socket.SockAddr]+    -- ^ the TCP addresses actually bound, port @0@ resolved, in 'Bind' order+    , serverSeedHelp :: Text+    -- ^ the binary's own @config --help@, for @\/help\/seed@+    , serverInbox :: TVar (Maybe (TChan Line))+    -- ^ the loop's inbox, once the loop has started this server's producer+    , serverView :: TVar (Maybe (IO WorldView))+    -- ^ the read accessor, once the loop has handed it over+    , serverPending :: TVar (Map Origin Collector)+    -- ^ synchronous commands still waiting for their reports+    , serverCounter :: IORef Int+    -- ^ next request number; an origin is never reused within a run+    , serverEvents :: Events+    -- ^ the counter, the ring and the broadcast behind @\/events@+    , serverMode :: IO Serve.Mode+    -- ^ what @status@ says first: interactive, following, or replaying a+    -- cached document ("Salmon.Actions.Follow"); the loop's own accessor+    , serverStopped :: TVar Bool+    -- ^ set on the way out, so a request waiting on a loop that has ended+    -- answers with what it has rather than never+    }++-- | The reports a synchronous command has been answered with so far.+data Collector = Collector+    { collectorReports :: TVar [Tagged]+    -- ^ newest first+    , collectorDone :: TVar Bool+    }++{- | Where a server listens. A unix socket needs nothing but its path; TCP+needs everything in 'TlsBind', and there is deliberately no constructor for+TCP without it.+-}+data Bind+    = BindUnix FilePath+    | BindTls TlsBind+    deriving (Show)++{- | A TCP listener: the address to bind, the certificate and key warp-tls+serves, and the token every request on it must present. The token is the+file's content already read and trimmed ('readTokenFile'), so that a+server is refused before it binds rather than after.+-}+data TlsBind = TlsBind+    { tlsHost :: String+    -- ^ an address to bind, never a wildcard by omission: the caller spells it+    , tlsPort :: Int+    -- ^ @0@ for any free port; 'serverBoundTcp' says which+    , tlsCertFile :: FilePath+    , tlsKeyFile :: FilePath+    , tlsToken :: ByteString.ByteString+    , tlsSessions :: SessionPolicy+    -- ^ how long a browser's sign-in lasts ('defaultSessionPolicy' unless told)+    }+    deriving (Show)++{- | Bind the socket at the path (owner-only, see 'Socket.withUnixListener'),+serve HTTP on it for as long as the action runs, and take it down after.++The action normally runs the loop, with this server's producer, observer+and reporters plugged in; the server outlives the loop only for as long as+it takes the action to return, and a request still waiting at that point+is answered with the reports it collected.+-}+withHttpServer :: FilePath -> Text -> IO Serve.Mode -> (Server -> IO a) -> IO a+withHttpServer = withHttpServerWith Events.defaultConfig++-- | 'withHttpServer' with the event stream's ring size and keep-alive chosen.+withHttpServerWith :: Events.Config -> FilePath -> Text -> IO Serve.Mode -> (Server -> IO a) -> IO a+withHttpServerWith cfg path = withHttpServerOn cfg [BindUnix path]++{- | One server on every listener in the list: one 'Server' value — one+event ring, one request counter, one inbox — and the same 'application'+accepting on each, so a command typed over TCP and a read over the unix+socket see one world and one sequence of numbers. A unix bind is+'withHttpServerWith' exactly; a TCP bind is warp-tls over a socket bound+here (so port @0@ works and 'serverBoundTcp' reports what it became), with+'requireToken' in front of the application — the unix socket never asks for+a token, since its permissions are its access story, and the TCP listener+never answers without one. The certificate and key are loaded before+anything is bound, so a file that does not parse is an exception out of+this call rather than a listener thread dying quietly behind a running loop.++Binds are taken in order and released in reverse; the action runs once+every one of them is listening.+-}+withHttpServerOn :: forall a. Events.Config -> [Bind] -> Text -> IO Serve.Mode -> (Server -> IO a) -> IO a+withHttpServerOn cfg binds seedHelp mode act = do+    server <-+        Server name+            <$> newTVarIO []+            <*> pure seedHelp+            <*> newTVarIO Nothing+            <*> newTVarIO Nothing+            <*> newTVarIO Map.empty+            <*> newIORef 0+            <*> Events.newEvents cfg+            <*> pure mode+            <*> newTVarIO False+    listenOn server binds+  where+    name :: String+    name =+        case [p | BindUnix p <- binds] ++ [t.tlsHost <> ":" <> show t.tlsPort | BindTls t <- binds] of+            (n : _) -> n+            [] -> "http"++    settings = Warp.setServerName "salmon" Warp.defaultSettings++    listenOn :: Server -> [Bind] -> IO a+    listenOn server [] =+        act server `finally` atomically (writeTVar (serverStopped server) True)+    listenOn server (BindUnix path : more) =+        Socket.withUnixListener path $ \listener ->+            withAsync (Warp.runSettingsSocket settings (Socket.listenerSocket listener) (application server)) $ \_ ->+                listenOn server more+    listenOn server (BindTls tls : more) = do+        -- warp-tls loads these on its own thread, where a bad file is an+        -- error nobody waits on; load them here first so it is ours.+        _ <- either (throwIO . BadCredentials tls.tlsCertFile tls.tlsKeyFile) pure =<< TLS.credentialLoadX509 tls.tlsCertFile tls.tlsKeyFile+        withTcpListener tls.tlsHost tls.tlsPort $ \sock addr -> do+            atomically (modifyTVar' (serverBoundTcp server) (++ [addr]))+            let tlsSettings = WarpTLS.tlsSettings tls.tlsCertFile tls.tlsKeyFile+                -- warp prints what its hook is handed, and two families of+                -- exception on a TLS listener are the listener working as+                -- intended rather than anything to trace: a plain-HTTP+                -- client answered 426 and refused (warp-tls throws after),+                -- and a TLS-level error on one connection — a client that+                -- closed without a close-notify (`PostHandshake Error_EOF`,+                -- which curl does on every request) or whose handshake+                -- failed, neither of which reached the application. The+                -- startup line is meant to be the only thing on stderr.+                quietly = Warp.setOnException $ \mreq e ->+                    case (fromException e, fromException e) of+                        (Just WarpTLS.InsecureConnectionDenied, _) -> pure ()+                        (_, Just (_ :: TLS.TLSException)) -> pure ()+                        _ -> Warp.defaultOnException mreq e+            sessions <- newSessions tls.tlsSessions+            withAsync (WarpTLS.runTLSSocket tlsSettings (quietly settings) sock (requireToken tls.tlsToken sessions (application server))) $ \_ ->+                listenOn server more++-- | The certificate or key given for a TCP listener did not load.+data BadCredentials = BadCredentials FilePath FilePath String+    deriving (Show)++instance Exception BadCredentials++{- | A bound, listening TCP socket at the address, and the address it got+(the port resolved when @0@ was asked for); closed on the way out.+-}+withTcpListener :: String -> Int -> (Socket.Socket -> Socket.SockAddr -> IO a) -> IO a+withTcpListener host port act = do+    let hints = Socket.defaultHints{Socket.addrFlags = [Socket.AI_PASSIVE, Socket.AI_NUMERICSERV], Socket.addrSocketType = Socket.Stream}+    addrs <- Socket.getAddrInfo (Just hints) (Just host) (Just (show port))+    addr <- case addrs of+        (a : _) -> pure a+        [] -> throwIO (userError ("no address to bind for " <> host <> ":" <> show port))+    bracket (Socket.openSocket addr) Socket.close $ \sock -> do+        Socket.setSocketOption sock Socket.ReuseAddr 1+        Socket.bind sock (Socket.addrAddress addr)+        Socket.listen sock 16+        bound <- Socket.getSocketName sock+        act sock bound++-------------------------------------------------------------------------------+-- the token++{- | Refuse every request on this listener that is not authenticated, with+@401@ and a JSON error. Authenticated is either of two things: an+@Authorization: Bearer <token>@ header for exactly this token — what a+script or @curl@ sends — or a session cookie the listener handed out at+@\/auth@, which is what a browser sends, since nothing lets a page put a+header on a navigation or on an @EventSource@. Every route, the event+stream included: a read of the output ring is as sensitive as a command+(the spec's decision), so there is no route a network client gets for free.++Four routes are this middleware's own and are answered before the check.+@GET \/auth@ is a form asking for the token, and @POST \/auth@ with the+token as the form's @token@ field answers @303@ to @\/@ with a+@__Host-salmon-session@ cookie (@HttpOnly@, @Secure@, @SameSite=Strict@,+@Path=\/@), or @401@ and the form again. And @GET \/@ without either+credential is a @303@ to @\/auth@ rather than a @401@, since whoever asks+for the page is a browser that can do something about it.+@POST \/auth\/logout@ revokes the session the request carries, if any,+and answers @303@ to @\/auth@ with the cookie expired — the same answer+whoever asks, so it says nothing about whether the cookie was good — and+an @\/events@ stream opened with that session ends at once rather than+at its next request ('untilEnded'). @GET \/auth\/session@ answers+@{"session": true}@ when the request's cookie is a live session, which is+how the page knows to offer the button; on the unix socket, where nothing+is signed in, the application answers @false@.++The cookie is not the token: it is 32 random bytes minted per login and+known only to this listener ('Sessions'), so the token a script uses is+never stored in a browser, and a restart logs every browser out.+@SameSite=Strict@ is what keeps another site's page from posting a+command with it. The token comparison is constant-time ('sameSecret'), the+scheme name is matched without regard to case, the token itself exactly;+a session is looked up by its SHA-256, so the lookup's timing says nothing+about the cookie either.+-}+requireToken :: ByteString.ByteString -> Sessions -> Wai.Middleware+requireToken token sessions app req respond =+    case (Wai.requestMethod req, Wai.pathInfo req) of+        ("GET", ["auth"])+            | "ended" `elem` map fst (Wai.queryString req) -> respond (loginPage HTTP.status200 SessionEnded)+            | otherwise -> respond (loginPage HTTP.status200 NoNote)+        ("POST", ["auth"]) -> do+            body <- boundedBody 4096 req+            let presented = join . lookup "token" . HTTP.parseQuery =<< body+            case presented of+                Just p | sameSecret p token -> do+                    cookie <- newSession sessions+                    respond $+                        Wai.responseLBS+                            HTTP.status303+                            [ (HTTP.hLocation, "/")+                            , ("Set-Cookie", sessionCookie <> "=" <> cookie <> "; Path=/; Secure; HttpOnly; SameSite=Strict" <> maxAge)+                            , (HTTP.hCacheControl, "no-store")+                            ]+                            ""+                _ -> respond (loginPage HTTP.status401 WrongToken)+        (_, ["auth"]) -> respond (methodNotAllowed ["GET", "POST"])+        ("POST", ["auth", "logout"]) -> do+            -- whoever asks, the answer is the same: the cookie expired and+            -- the form; a session is revoked only if the request carried it+            forM_ (cookieOf req) (endSession sessions)+            respond $+                Wai.responseLBS+                    HTTP.status303+                    [ (HTTP.hLocation, "/auth")+                    , ("Set-Cookie", sessionCookie <> "=; Path=/; Secure; HttpOnly; SameSite=Strict; Max-Age=0")+                    , (HTTP.hCacheControl, "no-store")+                    ]+                    ""+        (_, ["auth", "logout"]) -> respond (methodNotAllowed ["POST"])+        ("GET", ["auth", "session"]) -> do+            signedIn <- maybe (pure False) (knownSession sessions) (cookieOf req)+            respond (json HTTP.status200 (object ["session" .= signedIn]))+        (_, ["auth", "session"]) -> respond (methodNotAllowed ["GET"])+        _ -> do+            credential <-+                case bearerOf =<< lookup HTTP.hAuthorization (Wai.requestHeaders req) of+                    Just presented -> pure (if sameSecret presented token then ByToken else NoCredential)+                    Nothing -> case cookieOf req of+                        Nothing -> pure NoCredential+                        Just cookie -> do+                            known <- knownSession sessions cookie+                            pure (if known then BySession cookie else NoCredential)+            case (credential, Wai.requestMethod req, Wai.pathInfo req) of+                (ByToken, _, _) -> app req respond+                -- a stream outlives the check that let it in, so one opened+                -- with a session ends when the session does+                (BySession cookie, _, ["events"]) -> app req (respond . untilEnded sessions cookie)+                (BySession _, _, _) -> app req respond+                -- a cookie that is no longer a session was one: say so on the form+                (NoCredential, "GET", []) ->+                    respond (Wai.responseLBS HTTP.status303 [(HTTP.hLocation, maybe "/auth" (const "/auth?ended") (cookieOf req))] "")+                _ ->+                    respond $+                        Wai.responseLBS+                            HTTP.status401+                            [(HTTP.hContentType, "application/json"), ("WWW-Authenticate", "Bearer")]+                            (encode (object ["error" .= ("a bearer token is required" :: Text)]))+  where+    -- the browser forgets the cookie when the server does, when there is a when+    maxAge :: ByteString.ByteString+    maxAge = maybe "" (\l -> "; Max-Age=" <> Char8.pack (show (ceiling l :: Int))) sessions.sessionsPolicy.sessionLifetime++    bearerOf :: ByteString.ByteString -> Maybe ByteString.ByteString+    bearerOf h =+        let (scheme, rest) = Char8.break (== ' ') h+         in if Char8.map toLower scheme == "bearer"+                then Just (Char8.dropWhileEnd isSpace (Char8.dropWhile (== ' ') rest))+                else Nothing++-- | What a request presented that let it in.+data Credential = ByToken | BySession ByteString.ByteString | NoCredential++{- | The response with its body cut short the moment the session is over+(signed out, or past its lifetime; 'sessionOver'), and held as one of the+session's open streams while it runs ('withStream'): 'Wai.responseToStream' is every response as a streaming one, and+the body races a wait on the session's membership. For an @\/events@+stream that is the difference between signing out and signing out except+in the tab still watching.+-}+untilEnded :: Sessions -> ByteString.ByteString -> Response -> Response+untilEnded sessions cookie resp =+    let (status, headers, withBody) = Wai.responseToStream resp+     in Wai.responseStream status headers $ \write flush ->+            withBody $ \body ->+                withStream sessions cookie (void (race (body write flush) (sessionOver sessions cookie)))++-- | The session cookie's name; @__Host-@ makes a browser refuse it unless @Secure@, @Path=\/@ and no @Domain@.+sessionCookie :: ByteString.ByteString+sessionCookie = "__Host-salmon-session"++-- | The value of 'sessionCookie' among the request's cookies, from every @Cookie@ header (HTTP\/2 may split them).+cookieOf :: Request -> Maybe ByteString.ByteString+cookieOf req =+    lookup sessionCookie+        [ (name, ByteString.drop 1 value)+        | (h, v) <- Wai.requestHeaders req+        , h == HTTP.hCookie+        , pair <- Char8.split ';' v+        , let (name, value) = Char8.break (== '=') (Char8.dropWhile isSpace pair)+        ]++{- | The body, if it is no longer than the limit: a login form is a few+dozen bytes, and nothing unauthenticated gets to make the server hold more.+-}+boundedBody :: Int -> Request -> IO (Maybe ByteString.ByteString)+boundedBody limit req = go 0 []+  where+    go n acc = do+        chunk <- Wai.getRequestBodyChunk req+        let n' = n + ByteString.length chunk+        if ByteString.null chunk+            then pure (Just (ByteString.concat (reverse acc)))+            else if n' > limit then pure Nothing else go n' (chunk : acc)++-- | What the form says above the button, if anything.+data FormNote = NoNote | WrongToken | SessionEnded++-- | @ui\/auth.html@, with the note in its place.+loginPage :: HTTP.Status -> FormNote -> Response+loginPage status note =+    Wai.responseLBS+        status+        [(HTTP.hContentType, "text/html; charset=utf-8"), (HTTP.hCacheControl, "no-store")]+        (LByteString.fromStrict (before <> line <> after))+  where+    page = maybe "" id (lookup "auth.html" uiFiles)+    (before, after) = ByteString.breakSubstring "<!--refused-->" page+    line = case note of+        NoNote -> ""+        WrongToken -> "<p class=\"refused\">That is not the token.</p>"+        SessionEnded -> "<p class=\"ended\">Your session ended; sign in again.</p>"++{- | How long a session lasts. Two limits, each 'Nothing' for none, because+they guard against different things. The __lifetime__ counts from sign-in+and ends a session however busy it is — it bounds how long a stolen+cookie or a tab left open over a weekend stays good, and it cuts an event+stream the session has open. The __idle__ limit counts from the session's+last use, and an open @\/events@ stream is use: the page makes almost no+requests while it is being watched, and a dashboard left open should not+expire for being looked at. So "idle" means nobody is looking, and the+lifetime is what ends a session somebody is.++What bounds the listener's memory is that an ended session is dropped at+every sign-in ('newSession'), and at the next request that presents it —+at most the sessions signed in within one lifetime are held. With both+limits off nothing ends a session but signing out or a restart.+-}+data SessionPolicy = SessionPolicy+    { sessionLifetime :: Maybe Double+    -- ^ seconds from sign-in+    , sessionIdle :: Maybe Double+    -- ^ seconds since last use, not counting while a stream is open+    }+    deriving (Show, Eq)++-- | Twelve hours from sign-in, one hour of nobody looking.+defaultSessionPolicy :: SessionPolicy+defaultSessionPolicy = SessionPolicy (Just (12 * 3600)) (Just 3600)++{- | Where sessions get their time: now, and a wait for a moment to come,+both in seconds on one monotonic scale. 'systemSessionClock' is the real+one; a test's moves when it says so.+-}+data SessionClock = SessionClock+    { clockNow :: IO Double+    , clockSleepUntil :: Double -> IO ()+    }++systemSessionClock :: SessionClock+systemSessionClock = SessionClock now sleepUntil+  where+    now = (/ 1e9) . fromIntegral <$> getMonotonicTimeNSec+    sleepUntil t = do+        n <- now+        when (n < t) $ do+            -- in slices, so a far deadline is not one huge threadDelay+            threadDelay (ceiling (min 60 (t - n) * 1e6))+            sleepUntil t++-- | One session: when it was signed in, when it was last used, how many streams it holds open.+data Session = Session+    { sessionCreated :: !Double+    , sessionLastSeen :: !Double+    , sessionStreams :: !Int+    }++{- | The sessions a TCP listener has handed out at @\/auth@, by the SHA-256+of their cookie. One lives until it is signed out ('endSession'), until+the 'SessionPolicy' ends it, or until the process ends.+-}+data Sessions = Sessions+    { sessionsPolicy :: SessionPolicy+    , sessionsClock :: SessionClock+    , sessionsVar :: TVar (Map ByteString.ByteString Session)+    }++newSessions :: SessionPolicy -> IO Sessions+newSessions policy = newSessionsWith policy systemSessionClock++newSessionsWith :: SessionPolicy -> SessionClock -> IO Sessions+newSessionsWith policy clock = Sessions policy clock <$> newTVarIO Map.empty++-- | Whether the policy still lets a session stand at this moment.+live :: SessionPolicy -> Double -> Session -> Bool+live policy now sess =+    maybe True (\l -> now - sess.sessionCreated < l) policy.sessionLifetime+        && (sess.sessionStreams > 0 || maybe True (\i -> now - sess.sessionLastSeen < i) policy.sessionIdle)++{- | Mint a session and hand back its cookie value, dropping every session+the policy has ended on the way: signing in is the one moment the set+grows, so it is the moment it is swept.+-}+newSession :: Sessions -> IO ByteString.ByteString+newSession sessions = do+    raw <- Random.getRandomBytes 32+    now <- sessions.sessionsClock.clockNow+    let cookie = Base64.encodeUnpadded raw+    atomically $+        modifyTVar' sessions.sessionsVar $+            Map.insert (SHA256.hash cookie) (Session now now 0) . Map.filter (live sessions.sessionsPolicy now)+    pure cookie++{- | Whether the cookie is a session that still stands, counting this as a+use of it. One the policy has ended is dropped here, so it is gone for+every request after this one too.+-}+knownSession :: Sessions -> ByteString.ByteString -> IO Bool+knownSession sessions cookie = do+    now <- sessions.sessionsClock.clockNow+    let key = SHA256.hash cookie+    atomically $ do+        m <- readTVar sessions.sessionsVar+        case Map.lookup key m of+            Nothing -> pure False+            Just sess+                | live sessions.sessionsPolicy now sess -> do+                    writeTVar sessions.sessionsVar (Map.insert key sess{sessionLastSeen = now} m)+                    pure True+                | otherwise -> do+                    writeTVar sessions.sessionsVar (Map.delete key m)+                    pure False++-- | Revoke a session; a cookie that was never one is nothing to revoke.+endSession :: Sessions -> ByteString.ByteString -> IO ()+endSession sessions cookie = atomically (modifyTVar' sessions.sessionsVar (Map.delete (SHA256.hash cookie)))++-- | How many sessions are held, ended or not: what a sweep is for.+sessionCount :: Sessions -> IO Int+sessionCount sessions = Map.size <$> readTVarIO sessions.sessionsVar++{- | Run the action as a stream the session holds open: the idle clock+stops while it runs, and restarts from the moment it ends.+-}+withStream :: Sessions -> ByteString.ByteString -> IO a -> IO a+withStream sessions cookie = bracket_ (adjust 1) (adjust (-1))+  where+    key = SHA256.hash cookie+    adjust n = do+        now <- sessions.sessionsClock.clockNow+        atomically $ modifyTVar' sessions.sessionsVar $ Map.adjust (\sess -> sess{sessionStreams = sess.sessionStreams + n, sessionLastSeen = now}) key++{- | Blocks until the session is over: signed out, or past its lifetime —+in which case it is dropped here, so the requests after it see as much.+The idle limit does not end a session with a stream open, so a stream+has only these two to wait for.+-}+sessionOver :: Sessions -> ByteString.ByteString -> IO ()+sessionOver sessions cookie = do+    created <- fmap (.sessionCreated) . Map.lookup key <$> readTVarIO sessions.sessionsVar+    case (created, sessions.sessionsPolicy.sessionLifetime) of+        (Nothing, _) -> pure ()+        (Just c, Just lifetime) -> do+            r <- race (atomically removed) (sessions.sessionsClock.clockSleepUntil (c + lifetime))+            either pure (const (endSession sessions cookie)) r+        (Just _, Nothing) -> atomically removed+  where+    key = SHA256.hash cookie+    removed = readTVar sessions.sessionsVar >>= STM.check . not . Map.member key++{- | Equal, in time that depends on the lengths and not on where the first+differing byte is: every byte is folded whether or not an earlier one+already differed, and the length comparison is folded in the same way+rather than short-circuiting.+-}+sameSecret :: ByteString.ByteString -> ByteString.ByteString -> Bool+sameSecret a b = (lengthBit .|. foldl' (.|.) 0 (ByteString.zipWith xor a b)) == 0+  where+    lengthBit :: Word8+    lengthBit = if ByteString.length a == ByteString.length b then 0 else 1++-- | Why a token file was not accepted.+data TokenError+    = -- | others can read it, so it is not a secret: the file's mode+      TokenFileReadable FilePath+    | -- | nothing but whitespace in it+      TokenFileEmpty FilePath+    deriving (Show, Eq)++instance Exception TokenError++{- | The token in a file: its content with surrounding whitespace removed+(so a trailing newline from @echo@ is not part of it). Refused when the+file is readable by others — a token anyone on the box can read is not one —+and when it is empty, which would make every request with an empty+@Bearer@ valid. A file that cannot be read at all throws as any read does.+-}+readTokenFile :: FilePath -> IO (Either TokenError ByteString.ByteString)+readTokenFile path = do+    st <- getFileStatus path+    if fileMode st .&. 0o004 /= 0+        then pure (Left (TokenFileReadable path))+        else do+            raw <- ByteString.readFile path+            let token = Char8.dropWhileEnd isSpace (Char8.dropWhile isSpace raw)+            pure (if ByteString.null token then Left (TokenFileEmpty path) else Right token)++{- | What to hand 'Serve.serveObserved': installs the read accessor. Reads+answer @503@ until it has been.+-}+serverObserver :: Server -> IO (World seed directive) -> IO ()+serverObserver server readWorld =+    atomically (writeTVar (serverView server) (Just (viewWorld <$> readWorld)))++{- | The producer to run beside the loop's others. It types nothing of its+own: it publishes the inbox for requests to push into and then waits to be+killed with the loop, at which point the inbox is withdrawn and a command+arriving afterwards answers @503@.+-}+serverProducer :: Server -> Producer+serverProducer server = Producer $ \inbox -> do+    atomically (writeTVar (serverInbox server) (Just inbox))+    atomically retry `finally` atomically (writeTVar (serverInbox server) Nothing)++{- | Wrap the loop's reporters: every report goes on unchanged, then onto+the event stream ('Events.eventsReporter', numbered there), and one stamped+with a waiting request's origin is collected for that request's response.+The loop's 'Serve.HungUp' for such an origin releases the request — it is+the loop saying every line typed under that origin has been handled, so the+response is complete.+-}+serverReporters ::+    Server ->+    (Reporter (Attributed Serve.Report), Reporter (Attributed (UpDown.Report Extension))) ->+    (Reporter (Attributed Serve.Report), Reporter (Attributed (UpDown.Report Extension)))+serverReporters server (serveR, updownR) = (serveR', updownR')+  where+    serveR' :: Reporter (Attributed Serve.Report)+    serveR' = ReporterM $ \a@(Attributed origin rep) -> do+        runReporter serveR a+        runReporter events (FromServe <$> a)+        forM_ origin (collect (FromServe rep))+        case rep of+            Serve.HungUp gone -> release gone+            _ -> pure ()++    updownR' :: Reporter (Attributed (UpDown.Report Extension))+    updownR' = ReporterM $ \a@(Attributed origin rep) -> do+        runReporter updownR a+        runReporter events (FromUpDown <$> a)+        forM_ origin (collect (FromUpDown rep))++    events :: Reporter (Attributed Tagged)+    events = Events.eventsReporter (serverEvents server)++    collect :: Tagged -> Origin -> IO ()+    collect tagged origin = atomically $ do+        pending <- readTVar (serverPending server)+        forM_ (Map.lookup origin pending) $ \c ->+            modifyTVar' (collectorReports c) (tagged :)++    release :: Origin -> IO ()+    release origin = atomically $ do+        pending <- readTVar (serverPending server)+        forM_ (Map.lookup origin pending) $ \c -> do+            writeTVar (collectorDone c) True+            writeTVar (serverPending server) (Map.delete origin pending)++{- | The pull-mode fetcher's reports on @\/events@, as the @follow@ stream.++Its own function rather than a third member of 'serverReporters''s pair,+since the fetcher is a producer with a reporter of its own+('Follow.follower') and nothing about it is stamped for a request: it is+nobody's command, so its events carry no @origin@ and no synchronous+@POST /command@ collects them. Compose it beside the reporter the fetcher+already has.+-}+serverFollowReporter :: Server -> Reporter Follow.Report+serverFollowReporter server =+    ReporterM $ \rep ->+        runReporter (Events.eventsReporter (serverEvents server)) (Attributed Nothing (FromFollow rep))++-------------------------------------------------------------------------------+-- the read model++{- | What the reads are answered from: the parts of a 'World' they need,+computed at the moment of the read from the loop's own cell.+-}+data WorldView = WorldView+    { viewDag :: Dag Extension+    , viewConflicts :: Map Ref Serve.Collision+    , viewNodes :: Map Ref NodeState+    , viewPaths :: Map Ref [Text]+    , viewHistory :: [(EpochId, Declaration, Bool, Origin, [String])]+    , viewElided :: Int+    }++viewWorld :: World seed directive -> WorldView+viewWorld w =+    WorldView+        { viewDag = Serve.worldDag w+        , viewConflicts = w.worldConflicts+        , viewNodes = w.worldNodes+        , viewPaths = Serve.worldPaths w+        , viewHistory = Serve.historyLinesMatching (const True) w+        , viewElided = w.worldLogDropped+        }++{- | @\/dag@: the nodes in 'Dag.dagOrder', each the 'Act' projection — the+fields 'Dag.sameRepresentative' compares (shorthand, help, notes, the+rendering of dynamics) and the loop's state for the node, as @status@+lists it — plus its dependencies and dependants as refs, and, for a node+whose representative won a collision that is still standing+('Serve.Collision'), a @conflict@ with the @kept@ and @replaced@+representatives, so a client can show the pair without having caught the+pass's @conflicting@ event. Structurally what+'Salmon.Actions.Help.printDagTree' prints for the same 'Dag', with the+state added. The envelope carries the loop's 'Serve.Mode' at the moment of+the read, the same value @\/status@ opens with, so a client knows which+guarantees the nodes it is looking at are under.+-}+dagValue :: Serve.Mode -> WorldView -> Value+dagValue mode v =+    object+        [ "mode" .= mode+        , "nodes"+            .= [ nodeObject r act+               | r <- Dag.dagOrder dag+               , Just act <- [Dag.representativeOf dag r]+               ]+        ]+  where+    dag = viewDag v++    nodeObject :: Ref -> Act Extension -> Value+    nodeObject r act =+        object $+            nodeStatePairs (viewPaths v) Nothing (r, stateOf r act)+                ++ [ "notes" .= rep.repNotes+                   , "dynamics" .= rep.repDynamics+                   , "dependencies" .= fmap refValue (Dag.dependenciesOf dag r)+                   , "dependants" .= fmap refValue (Dag.dependantsOf dag r)+                   ]+                ++ [ "conflict" .= object ["kept" .= representativeValue c.conflictKept, "replaced" .= representativeValue c.conflictReplaced]+                   | Just col <- [Map.lookup r (viewConflicts v)]+                   , let c = col.collisionConflict+                   ]+      where+        rep = Dag.representative act++    -- 'Serve.prune' keeps 'worldNodes' and 'worldMagma' on the same key+    -- set, so this is always a hit; a miss would be a node the ledger+    -- describes and nothing wants, which is what the fallback says.+    stateOf :: Ref -> Act Extension -> NodeState+    stateOf r act =+        Map.findWithDefault+            (NodeState act.shorthand act.extension.help TurnDown Serve.Pending Nothing)+            r+            (viewNodes v)++-------------------------------------------------------------------------------+-- the application++{- | The body of @POST \/command@ when it is JSON: either @{"line": "up a b"}@+or the structured @{"verb": "up", "seed": ["a", "b"]}@ (@seed@ optional, for+@clear@, @converge@ and the rest), which is rendered to the very line the first+form would have carried — so the two are one command on the loop, not two.+-}+data CommandBody = CommandBody String++instance FromJSON CommandBody where+    parseJSON = withObject "command" $ \o -> do+        line <- o .:? "line"+        verb <- o .:? "verb"+        seed <- o .:? "seed"+        case (line, verb) of+            (Just l, Nothing)+                | isNothing (seed :: Maybe [String]) -> pure (CommandBody l)+                | otherwise -> fail "\"seed\" goes with \"verb\", not \"line\""+            (Nothing, Just v) -> pure (CommandBody (renderStructured v (fromMaybe [] seed)))+            (Just _, Just _) -> fail "give either \"line\" or \"verb\", not both"+            (Nothing, Nothing) -> fail "expected {\"line\": ...} or {\"verb\": ..., \"seed\": [...]}"++{- | A verb and its seed words as one input line. A word is quoted only when+'Salmon.Actions.Serve.tokenize' would otherwise split or reinterpret it+(whitespace, quotes, a backslash, or being empty), so the common case is the+line a person would have typed. A newline cannot be carried by a line at all;+'commandLine' refuses it afterwards like any multi-line body.+-}+renderStructured :: String -> [String] -> String+renderStructured verb seed = unwords (verb : fmap word seed)+  where+    word w+        | not (null w) && all plain w = w+        | otherwise = "\"" <> concatMap escape w <> "\""+    plain c = not (isSpace c) && c `notElem` ("\\'\"" :: String)+    escape c+        | c `elem` ("\\\"" :: String) = ['\\', c]+        | otherwise = [c]++application :: Server -> Application+application server req respond =+    case (Wai.requestMethod req, Wai.pathInfo req) of+        ("GET", ["dag"]) -> withView $ \seqNo v -> do+            mode <- serverMode server+            respond (json HTTP.status200 (withSeq seqNo (dagValue mode v)))+        ("GET", ["status"]) -> withView $ \seqNo v -> do+            mode <- serverMode server+            respond (json HTTP.status200 (withSeq seqNo (toJSON (FromServe (Serve.StatusReport mode (Map.toList (viewNodes v)) (viewPaths v))))))+        ("GET", ["history"]) -> withView $ \_ v ->+            respond (json HTTP.status200 (withElided (viewElided v) (toJSON (FromServe (Serve.HistoryReport (viewHistory v))))))+        ("GET", ["help", "seed"]) ->+            respond $+                json+                    HTTP.status200+                    ( object+                        [ "seed" .= serverSeedHelp server+                        , "commands" .= Serve.renderReport (Serve.HelpText Nothing)+                        ]+                    )+        ("POST", ["command"]) -> command >>= respond+        ("GET", ["events"]) -> events+        ("GET", []) -> respond (static "index.html")+        ("GET", ["openapi.json"]) -> respond (Wai.responseLBS HTTP.status200 [(HTTP.hContentType, "application/json")] (LByteString.fromStrict openApiDocument))+        -- over TCP 'requireToken' answers this; anywhere else there is nothing to log into+        ("GET", ["auth"]) -> respond (Wai.responseLBS HTTP.status303 [(HTTP.hLocation, "/")] "")+        ("POST", ["auth", "logout"]) -> respond (Wai.responseLBS HTTP.status303 [(HTTP.hLocation, "/")] "")+        ("GET", ["auth", "session"]) -> respond (json HTTP.status200 (object ["session" .= False]))+        ("GET", ("ui" : rest)) -> respond (static (Text.unpack (Text.intercalate "/" rest)))+        (_, ["events"]) -> respond (methodNotAllowed ["GET"])+        (_, ["openapi.json"]) -> respond (methodNotAllowed ["GET"])+        (_, ["dag"]) -> respond (methodNotAllowed ["GET"])+        (_, ["status"]) -> respond (methodNotAllowed ["GET"])+        (_, ["history"]) -> respond (methodNotAllowed ["GET"])+        (_, ["help", "seed"]) -> respond (methodNotAllowed ["GET"])+        (_, ["command"]) -> respond (methodNotAllowed ["POST"])+        (_, []) -> respond (methodNotAllowed ["GET"])+        (_, "ui" : _) -> respond (methodNotAllowed ["GET"])+        _ -> respond (failure HTTP.status404 "no such resource")+  where+    -- the snapshot and the last sequence number at the time it was taken:+    -- the number first, so what lands in between is replayed, never+    -- skipped (see "Sequence numbers" above).+    withView :: (Word64 -> WorldView -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+    withView k = do+        mread <- readTVarIO (serverView server)+        case mread of+            Nothing -> respond (failure HTTP.status503 "the loop has not started")+            Just readView -> do+                seqNo <- Events.lastSequence (serverEvents server)+                readView >>= k seqNo++    withSeq :: Word64 -> Value -> Value+    withSeq n (Object o) = Object (KeyMap.insert "seq" (toJSON n) o)+    withSeq n v = object ["report" .= v, "seq" .= n]++    -- the history object as `--json` prints it, with the count `history`+    -- would print as a second object folded in as a field.+    withElided :: Int -> Value -> Value+    withElided n (Object o) = Object (KeyMap.insert "elided" (toJSON n) o)+    withElided n v = object ["report" .= v, "elided" .= n]++    command :: IO Response+    command = do+        body <- Wai.strictRequestBody req+        case commandLine req body of+            Left err -> pure (failure HTTP.status400 err)+            Right line -> do+                minbox <- readTVarIO (serverInbox server)+                case minbox of+                    Nothing -> pure (failure HTTP.status503 "the loop is not taking commands")+                    Just inbox -> do+                        n <- atomicModifyIORef' (serverCounter server) (\k -> (k + 1, k))+                        let origin = originFor server req n+                        -- numbered before it is queued, so every report+                        -- the line produces is numbered after it+                        seqNo <- Events.enqueued (serverEvents server) origin line+                        if asynchronous+                            then do+                                atomically (enqueue inbox origin line)+                                pure (json HTTP.status202 (object ["seq" .= seqNo, "origin" .= Serve.originName origin]))+                            else do+                                c <- Collector <$> newTVarIO [] <*> newTVarIO False+                                atomically $ do+                                    modifyTVar' (serverPending server) (Map.insert origin c)+                                    enqueue inbox origin line+                                reports <- atomically $ do+                                    done <- readTVar (collectorDone c)+                                    stopped <- readTVar (serverStopped server)+                                    unless (done || stopped) retry+                                    modifyTVar' (serverPending server) (Map.delete origin)+                                    reverse <$> readTVar (collectorReports c)+                                pure (json HTTP.status200 (toJSON reports))++    -- the line and its end of input in one transaction, so nothing another+    -- producer types can land between the two.+    enqueue inbox origin line = do+        writeTChan inbox (Line origin line)+        writeTChan inbox (Eof origin)++    asynchronous :: Bool+    asynchronous = any ((== "async") . fst) (Wai.queryString req)++    -- @\/events@: replay from @?since@ (a gap first if the ring no longer+    -- reaches it), then live until the client or the loop goes.+    events :: IO Wai.ResponseReceived+    events =+        case eventsQuery req of+            Left err -> respond (failure HTTP.status400 err)+            Right (since, filt) ->+                respond $ Wai.responseStream HTTP.status200 sseHeaders $ \write flush ->+                    Events.withSubscription (serverEvents server) since $ \sub -> do+                        forM_ (Events.subscriptionGap sub) (write . Events.renderGap)+                        forM_ (filter (Events.matches filt) (Events.subscriptionReplay sub)) (write . Events.renderEvent)+                        flush+                        let keepAlive = Events.configKeepAlive (Events.eventsConfig (serverEvents server))+                            live = do+                                expired <- registerDelay keepAlive+                                next <-+                                    atomically $+                                        (Just . Just <$> Events.subscriptionLive sub)+                                            `orElse` (Nothing <$ (readTVar (serverStopped server) >>= STM.check))+                                            `orElse` (Just Nothing <$ (readTVar expired >>= STM.check))+                                case next of+                                    Nothing -> pure ()+                                    Just Nothing -> write Events.keepAlive >> flush >> live+                                    Just (Just e) -> do+                                        when (Events.matches filt e) (write (Events.renderEvent e) >> flush)+                                        live+                        live++    sseHeaders :: [HTTP.Header]+    sseHeaders =+        [ (HTTP.hContentType, "text/event-stream")+        , (HTTP.hCacheControl, "no-cache")+        , ("X-Accel-Buffering", "no")+        ]++{- | The origin a request's command is typed under: @NAME#n@, where @NAME@+is the server's ('serverName', the unix socket's path) for a request on the+unix socket and the client's own address for one over TCP — @history@ then+says which network client typed a line, which "the socket" does not.+-}+originFor :: Server -> Request -> Int -> Origin+originFor server req n = Origin (Text.pack (name <> "#" <> show n))+  where+    name = case Wai.remoteHost req of+        Socket.SockAddrUnix _ -> serverName server+        addr -> show addr++-- | @?since=N@, @?stream=a,b@ (repeatable), @?origin=NAME@ (repeatable).+eventsQuery :: Request -> Either Text (Maybe Word64, Events.Filter)+eventsQuery req = do+    since <- case lookup "since" query of+        Nothing -> Right Nothing+        Just Nothing -> Left "since needs a number"+        Just (Just raw) -> case Text.decimal (Text.decodeUtf8 raw) of+            Right (n, rest) | Text.null rest -> Right (Just n)+            _ -> Left "since is not a number"+    let listed key = [Text.strip v | (k, Just raw) <- query, k == key, v <- Text.splitOn "," (Text.decodeUtf8 raw), not (Text.null (Text.strip v))]+        setOf key = case listed key of+            [] -> Nothing+            vs -> Just (Set.fromList vs)+    pure (since, Events.Filter{Events.filterStreams = setOf "stream", Events.filterOrigins = setOf "origin"})+  where+    query = Wai.queryString req++-- | One line, from a JSON @{"line": ...}@ or @{"verb": ..., "seed": [...]}@ body or a text one.+commandLine :: Request -> LByteString.ByteString -> Either Text String+commandLine req body+    | isJson = case Aeson.eitherDecode body of+        Left err -> Left ("body is not a {\"line\": ...} or {\"verb\": ..., \"seed\": [...]} object: " <> Text.pack err)+        Right (CommandBody line) -> oneLine line+    | otherwise = case Text.decodeUtf8' (LByteString.toStrict body) of+        Left _ -> Left "body is not UTF-8"+        Right t -> oneLine (Text.unpack (Text.dropWhileEnd (== '\n') t))+  where+    isJson =+        case lookup HTTP.hContentType (Wai.requestHeaders req) of+            Just ct -> "application/json" `ByteString.isPrefixOf` ct+            Nothing -> False+    oneLine line+        | '\n' `elem` line = Left "one command per request"+        | otherwise = Right line++json :: HTTP.Status -> Value -> Response+json status v = Wai.responseLBS status [(HTTP.hContentType, "application/json")] (encode v)++-------------------------------------------------------------------------------+-- the web UI++{- | The files under @salmon-ops\/ui\/@, read at compile time. Relative+paths as the page references them (@ui.js@, @ui.css@), with @index.html@+the page itself.+-}+uiFiles :: [(FilePath, ByteString.ByteString)]+uiFiles = $(makeRelativeToProject "ui" >>= embedDir)++{- | @openapi\/serve-api.openapi.json@, read at compile time: the machine-readable+description of this module's routes, answered at @GET \/openapi.json@. Embedded+so that what a server says about itself is the file its own build was checked+against ("Test.ServeApiSpec").+-}+openApiDocument :: ByteString.ByteString+openApiDocument = $(makeRelativeToProject "openapi/serve-api.openapi.json" >>= embedFile)++{- | One embedded file, or the same @404@ an unknown route gets — the set is+closed at compile time, so there is nothing to look up on disk.+-}+static :: FilePath -> Response+static path =+    case lookup path uiFiles of+        Nothing -> failure HTTP.status404 "no such resource"+        Just body -> Wai.responseLBS HTTP.status200 [(HTTP.hContentType, contentType path)] (LByteString.fromStrict body)++-- | By extension; the embedded set only holds these three kinds.+contentType :: FilePath -> ByteString.ByteString+contentType path =+    case takeExtension path of+        ".html" -> "text/html; charset=utf-8"+        ".js" -> "text/javascript; charset=utf-8"+        ".css" -> "text/css; charset=utf-8"+        ".svg" -> "image/svg+xml"+        _ -> "application/octet-stream"++failure :: HTTP.Status -> Text -> Response+failure status err = json status (object ["error" .= err])++methodNotAllowed :: [ByteString.ByteString] -> Response+methodNotAllowed allowed =+    Wai.responseLBS+        HTTP.status405+        [(HTTP.hContentType, "application/json"), ("Allow", Char8.intercalate ", " allowed)]+        (encode (object ["error" .= ("method not allowed" :: Text)]))
+ src/Salmon/Actions/Serve/Socket.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | The line protocol over a unix socket: @run serve --listen PATH@.++Milestone 2 of @specs\/generic-server.md@. A 'Listener' is a bound unix+socket plus the connections currently open on it. It plugs into+"Salmon.Actions.Serve" at the two places that module leaves open: as one+more 'Serve.Producer' into the loop's inbox ('listenerProducer', one+'Serve.Origin' per connection, standard input untouched beside it), and as+the reporters the loop is handed ('listenerReporters'), which write every+report /typed on a connection/ back to that connection as JSON lines —+"Salmon.Reporter.Tagged"'s encoding, the same objects @--json@ prints — and+hand every report, whoever typed it, on to the loop's own reporter+unchanged. A client therefore sees exactly the reports for its own lines;+what the tending machines say between commands, and what other clients+typed, goes to the loop's own reporter only.++Which report belongs to whom is the loop's knowledge, not this module's:+'Serve.serveAttributed' stamps each report with the 'Serve.Origin' of the+line being handled, and this module only looks the origin up. The one+ordering fact this leans on: a connection is closed when the loop reports+'Serve.HungUp' for it, which the loop does after every line typed on it has+been handled — so a client that sends a line and shuts its writing side+still gets its reports.++The protocol is the input language as typed on standard input, one command+per line; @quit@ from any client ends the loop exactly as it does from+standard input. There is no per-connection @text@ mode and no+authentication: a unix socket inherits the filesystem's permissions, which+is why the socket file is created owner-only (mode 0600) and why TCP is not+here (see the spec's security section). A stale socket file at the path is+replaced only if nothing answers on it; something answering means another+@serve@ is listening there, and this one refuses to start rather than take+its path.+-}+module Salmon.Actions.Serve.Socket (+    -- * Listening+    Listener,+    listenerPath,+    listenerSocket,+    withUnixListener,+    ListenError (..),+    unixPathMax,++    -- * Plugging into the loop+    listenerProducer,+    listenerReporters,+) where++import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVar, readTVarIO, swapTVar, writeTChan, writeTVar)+import Control.Exception (Exception, IOException, bracket, finally, throwIO, try)+import Control.Monad (forM_, forever, void, when)+import Data.Foldable (traverse_)+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Network.Socket as Socket+import Network.Socket (Socket)+import System.Directory (removeFile)+import System.IO (BufferMode (..), Handle, IOMode (..), hClose, hGetLine, hIsEOF, hSetBuffering)+import System.Posix.Files (fileExist, getFileStatus, isSocket, setFileMode)++import qualified Salmon.Actions.Serve as Serve+import Salmon.Actions.Serve (Attributed (..), Line (..), Origin (..), Producer (..))+import qualified Salmon.Actions.UpDown as UpDown+import Salmon.Builtin.Extension (Extension)+import Salmon.Reporter+import Salmon.Reporter.Tagged (Tagged (..), reportJSONLines)++-------------------------------------------------------------------------------++-- | A bound, listening unix socket and the connections open on it.+data Listener = Listener+    { listenerPath :: FilePath+    , listenerSocket :: Socket+    , listenerClients :: TVar (Map Origin Handle)+    -- ^ every connection still open, by the origin its lines carry+    , listenerCounter :: IORef Int+    -- ^ next connection number; an origin is never reused within a run+    }++-- | Why a 'Listener' could not be made.+data ListenError+    = -- | something answered a connection attempt at the path: another+      -- @serve@ is listening there+      AlreadyListening FilePath+    | -- | the path exists and is not a socket, so it is not ours to remove+      NotASocket FilePath+    | -- | the path is longer than a unix socket address holds: its length,+      -- and the most 'unixPathMax' allows+      PathTooLong FilePath Int Int+    deriving (Show, Eq)++{- | The size of @sockaddr_un@'s @sun_path@ on Linux, which the path and its+terminating NUL must fit in. @network@ checks the same bound, but with+'error' from inside 'Socket.bind' — a crash naming @pokeSockAddr@ — and+does not export its constant, so it is spelled here and checked first.+-}+unixPathMax :: Int+unixPathMax = 108++instance Exception ListenError++{- | Bind a unix socket at the path, owner-only, and hand it over; on the+way out close every connection still open, close the socket, and remove+the file.++Refuses with 'AlreadyListening' if a connection to the path succeeds — the+path is somebody's — with 'NotASocket' if a non-socket sits there, and with+'PathTooLong' before touching anything if the path cannot be a socket+address at all (a deep temp directory reaches the limit sooner than one+would think). A+socket file nothing answers on is stale (its @serve@ died without removing+it) and is removed first.++The mode is set between the bind and the listen. That order is what makes+it race-free without touching the process's file creation mask (which is+process-global, and a test suite running this beside anything that creates+files would notice): a socket that is bound but not yet listening refuses+every connection, so nobody can get in during the moment it exists with+the default mode.+-}+withUnixListener :: FilePath -> (Listener -> IO a) -> IO a+withUnixListener path = bracket acquire release+  where+    acquire :: IO Listener+    acquire = do+        -- the same count network makes: one byte per character+        when (length path >= unixPathMax) (throwIO (PathTooLong path (length path) (unixPathMax - 1)))+        clearStale+        sock <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol+        Socket.bind sock (Socket.SockAddrUnix path) `onFailure` Socket.close sock+        (setFileMode path 0o600 >> Socket.listen sock 16) `onFailure` (Socket.close sock >> removeFile path)+        Listener path sock <$> newTVarIO Map.empty <*> newIORef 0++    release :: Listener -> IO ()+    release l = do+        clients <- readTVarIO (listenerClients l)+        traverse_ (void . tryIO . hClose) (Map.elems clients)+        Socket.close (listenerSocket l)+        void (tryIO (removeFile path))++    onFailure :: IO a -> IO () -> IO a+    onFailure act cleanup = do+        r <- tryIO act+        case r of+            Right a -> pure a+            Left e -> cleanup >> throwIO e++    clearStale :: IO ()+    clearStale = do+        there <- fileExist path+        if not there+            then pure ()+            else do+                st <- getFileStatus path+                if not (isSocket st)+                    then throwIO (NotASocket path)+                    else do+                        answered <- answers+                        if answered+                            then throwIO (AlreadyListening path)+                            else removeFile path++    -- connect first: a listener on the path accepts, a stale file refuses+    answers :: IO Bool+    answers =+        bracket+            (Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol)+            Socket.close+            ( \probe -> do+                r <- tryIO (Socket.connect probe (Socket.SockAddrUnix path))+                pure (either (const False) (const True) r)+            )++tryIO :: IO a -> IO (Either IOException a)+tryIO = try++-------------------------------------------------------------------------------++{- | Accept connections for as long as the loop runs, each one a reader+thread pushing the lines it types into the inbox under an 'Origin' of its+own, then an 'Eof' when it hangs up.++The connection is /not/ closed when its reader sees end of input: the loop+may still be handling — or not yet have reached — a line this client typed,+and the client is owed those reports. 'listenerReporters' closes it on the+loop's 'Serve.HungUp' for this origin instead. Only when the loop ends and+this producer's thread is killed with it are the connections still open+closed outright — here, so that a client still attached reads end of file+the moment the loop is gone rather than whenever the listener is released;+which is what @quit@ promises: nothing changes on the way out, and whoever+is still connected is simply hung up on.+-}+listenerProducer :: Listener -> Producer+listenerProducer l = Producer $ \inbox -> do+    readers <- newIORef []+    let accepting = forever $ do+            (conn, _) <- Socket.accept (listenerSocket l)+            n <- atomicModifyIORef' (listenerCounter l) (\k -> (k + 1, k))+            h <- Socket.socketToHandle conn ReadWriteMode+            hSetBuffering h LineBuffering+            let origin = Origin (Text.pack (listenerPath l <> "#" <> show n))+            atomically (modifyTVar' (listenerClients l) (Map.insert origin h))+            tid <- forkIO (readLines origin h inbox `finally` atomically (writeTChan inbox (Eof origin)))+            atomicModifyIORef' readers (\ts -> (tid : ts, ()))+    accepting `finally` hangUp readers+  where+    hangUp readers = do+        atomicModifyIORef' readers (\ts -> ([], ts)) >>= traverse_ killThread+        clients <- atomically (swapTVar (listenerClients l) Map.empty)+        traverse_ (void . tryIO . hClose) (Map.elems clients)++    -- a client whose socket errors out mid-read is the same to the loop+    -- as one that finished: its 'Eof' follows from the finally either way.+    readLines origin h inbox = do+        r <- tryIO $ do+            eof <- hIsEOF h+            if eof+                then pure False+                else do+                    line <- hGetLine h+                    atomically (writeTChan inbox (Line origin line))+                    pure True+        case r of+            Right True -> readLines origin h inbox+            _ -> pure ()++{- | The two reporters the loop takes, built over the loop's own.++Every report goes to @own@ exactly as it would without a listener. A report+stamped with one of this listener's origins is also encoded as one JSON+line ('reportJSONLines') on that connection. A write that fails — the+client went away while its command was being handled — drops the+connection; the loop's 'Serve.HungUp' for it, which follows, then finds+nothing to close. The 'Serve.HungUp' itself is the one report that is also+an instruction here: the connection it names is closed, since every line it+typed has been handled by the time the loop says so.+-}+listenerReporters ::+    Listener ->+    Reporter Tagged ->+    (Reporter (Attributed Serve.Report), Reporter (Attributed (UpDown.Report Extension)))+listenerReporters l own = (serveR, updownR)+  where+    serveR :: Reporter (Attributed Serve.Report)+    serveR = ReporterM $ \(Attributed origin rep) -> do+        runReporter own (FromServe rep)+        forM_ origin (echo (FromServe rep))+        case rep of+            Serve.HungUp gone -> disconnect gone+            _ -> pure ()++    updownR :: Reporter (Attributed (UpDown.Report Extension))+    updownR = ReporterM $ \(Attributed origin rep) -> do+        runReporter own (FromUpDown rep)+        forM_ origin (echo (FromUpDown rep))++    echo :: Tagged -> Origin -> IO ()+    echo tagged origin = do+        clients <- readTVarIO (listenerClients l)+        forM_ (Map.lookup origin clients) $ \h -> do+            r <- tryIO (runReporter (reportJSONLines h) tagged)+            case r of+                Right () -> pure ()+                Left _ -> disconnect origin++    disconnect :: Origin -> IO ()+    disconnect origin = do+        mh <- atomically $ do+            clients <- readTVar (listenerClients l)+            let (mh, clients') = Map.updateLookupWithKey (\_ _ -> Nothing) origin clients+            writeTVar (listenerClients l) clients'+            pure mh+        forM_ mh (void . tryIO . hClose)
+ src/Salmon/Actions/Serve/StatusSink.hs view
@@ -0,0 +1,335 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | The status sink of @run serve@ (milestone 5 of @specs/pull-mode.md@): a+JSON document about this host, written to a file, for a fleet fold to read.++A host in pull mode fetches its declarations and converges on them with no+controller watching; the sink is how anything learns what came of it. It is+a file first — @--status-sink PATH@ — because a file is the dumbest store+there is and everything else (a bucket object keyed by host, an HTTP @POST@)+is the same document handed to a different writer. Whoever reads the+directory the files land in folds them ("Salmon.Actions.Fleet",+@salmon-fleet status@); no running service keeps fleet state.++Three things about how it is driven are deliberate.++__It is a reporter and a timer, not a producer.__ The sink learns that a+convergence pass ended, or that the fetcher injected a document, from the+loop's own report stream — 'sinkReporter' is composed beside the loop's+reporter with 'reportBoth' and watches for 'Serve.ConvergeStop' and+'Follow.Injected' — and it reads the world through the accessor+'Serve.serveObserved' hands its observer ('sinkObserver'): a plain read of+the loop's cell, never a seat in the inbox. So writing status never stands+the tending machines down, never waits behind a command, and never runs+@stopTending@; every arrival on the inbox still does exactly what it did.+Between triggers a tick every 'configInterval' rewrites the document with+whatever the world looks like now, which is what makes a host that has gone+quiet visible as one whose @written@ is old rather than one whose file+says everything is fine.++__Where it goes is chosen by the address's shape__, as the pull side's+registries are: @http://…@ or @https://…@ is @POST@ed as @application/json@+(any non-2xx answer, a refused connection or a timeout is a failed write,+reported like any other), anything else is a file path. It is the same+document either way, written by a different writer; the reporter, the timer+and the once-per-run failure report do not know which. There is no+authentication beyond what the URL itself carries.++__Every file write is atomic__: the document goes to a temporary file beside the+path and is renamed over it, so a fold that reads the directory mid-write+sees the previous document whole, never half of this one.++__A sink that cannot be written never takes the loop down.__ The failure is+reported ('Serve.SinkFailed'), once per run of failures rather than once per+attempt, and the loop keeps serving; the next write that succeeds re-arms+the report. The spec sketched the sink as an op in the host's own graph so a+failing sink would show as a @Failed@ node; it is a thread instead, because+a node is applied by a pass and the sink must write /after/ the pass, which+a node in that pass cannot do — the report is the same information, on the+same stream.++The document, @salmon-status: 1@:++> { "salmon-status": 1,+>   "host": "web-3", "written": "2026-09-24T10:41:07.12Z", "mode": "following",+>   "labels": [{"label": "web", "id": "web@42", "sha256": "…", "applied": "…"}],+>   "status": { ...the object `status --json` prints... },+>   "last": { "converge": { ...the last converge-stop object... },+>             "follow":   { ...the last follow report object... } } }++@status@ is the same object the loop's own @status@ emits under @--json@+and the HTTP @/status@ answers; @last.converge@ and @last.follow@ are the+tagged report objects exactly as @--json@ prints them (@stream@ included),+@null@ until there has been one.+-}+module Salmon.Actions.Serve.StatusSink (+    -- * Configuration+    Config (..),+    defaultInterval,+    hostName,++    -- * Running one+    Sink,+    withSink,+    sinkReporter,+    sinkObserver,+    writeNow,++    -- * The document+    Document (..),+    formatVersion,+    writeAtomically,+    isUrl,+    postDocument,+) where++import Control.Concurrent.Async (withAsync)+import Control.Concurrent.STM (atomically, newTVarIO, readTVar, registerDelay, retry, writeTVar)+import Control.Concurrent.STM.TVar (TVar)+import Control.Exception (SomeException, try)+import Control.Monad (forever, unless, when)+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), encode, object, withObject, (.:), (.:?), (.=))+import qualified Data.ByteString.Lazy as LByteString+import Data.List (isPrefixOf)+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 Data.Time.Clock (UTCTime, getCurrentTime)+import Network.HTTP.Client (Manager, RequestBody (..), httpLbs, method, parseRequest, requestBody, requestHeaders, responseStatus, responseTimeoutMicro)+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Client.TLS (newTlsManagerWith, tlsManagerSettings)+import Network.HTTP.Types (hContentType, statusCode)+import System.Directory (createDirectoryIfMissing, renameFile)+import System.FilePath (takeDirectory, (<.>))+import System.Posix.Unistd (getSystemID, nodeName)++import qualified Salmon.Actions.Follow as Follow+import qualified Salmon.Actions.Serve as Serve+import Salmon.Actions.Serve (AppliedDocument (..), Followed (..), World (..))+import Salmon.Reporter+import Salmon.Reporter.Tagged (Tagged (..))++-------------------------------------------------------------------------------++data Config = Config+    { configPath :: FilePath+    -- ^ where the document is written: a file (its directory is created if+    -- missing) or, when it has the shape of one ('isUrl'), a URL it is+    -- @POST@ed to+    , configInterval :: Int+    -- ^ microseconds between two writes with no trigger in between+    , configHost :: Text+    -- ^ what @host@ says; 'hostName' for the machine's own+    }+    deriving (Show, Eq)++-- | Ten seconds, in microseconds.+defaultInterval :: Int+defaultInterval = 10 * 1000000++-- | The machine's node name (@uname -n@).+hostName :: IO Text+hostName = Text.pack . nodeName <$> getSystemID++-------------------------------------------------------------------------------++-- | The document version this writer produces and "Salmon.Actions.Fleet" reads.+formatVersion :: Int+formatVersion = 1++data Document = Document+    { docHost :: !Text+    , docWritten :: !UTCTime+    , docMode :: !Text+    -- ^ 'Serve.renderMode' of the loop's 'Serve.Mode'+    , docLabels :: [AppliedDocument]+    , docStatus :: !Value+    -- ^ the @status@ object, as @--json@ prints it+    , docLastConverge :: !(Maybe Value)+    -- ^ the last @converge-stop@ object, as @--json@ prints it+    , docLastFollow :: !(Maybe Value)+    -- ^ the last follow-stream object, as @--json@ prints it+    }+    deriving (Show, Eq)++instance ToJSON Document where+    toJSON d =+        object+            [ "salmon-status" .= formatVersion+            , "host" .= d.docHost+            , "written" .= d.docWritten+            , "mode" .= d.docMode+            , "labels" .= d.docLabels+            , "status" .= d.docStatus+            , "last" .= object ["converge" .= d.docLastConverge, "follow" .= d.docLastFollow]+            ]++instance FromJSON Document where+    parseJSON = withObject "salmon status document" $ \o -> do+        v <- o .: "salmon-status"+        unless (v == formatVersion) $+            fail ("unsupported status format: salmon-status=" <> show v <> " (this reader understands " <> show formatVersion <> ")")+        lastO <- o .:? "last"+        (lc, lf) <- case lastO of+            Nothing -> pure (Nothing, Nothing)+            Just lo -> (,) <$> lo .:? "converge" <*> lo .:? "follow"+        Document+            <$> o .: "host"+            <*> o .: "written"+            <*> o .: "mode"+            <*> o .: "labels"+            <*> o .: "status"+            <*> pure lc+            <*> pure lf++-------------------------------------------------------------------------------++-- | A running sink: what to compose beside the loop.+data Sink = Sink+    { sinkConfig :: Config+    , sinkFollowed :: Maybe Followed+    , sinkOwn :: Reporter Tagged+    -- ^ where a failure to write is reported: the loop's own reporter,+    -- not the composition that includes this sink+    , sinkStatusOf :: IORef (Maybe (IO Value))+    -- ^ installed by 'sinkObserver'; nothing is written before it is+    , sinkLast :: IORef (Maybe Value, Maybe Value)+    -- ^ last converge-stop, last follow report+    , sinkWake :: TVar Bool+    -- ^ a trigger happened: write as soon as possible+    , sinkComplained :: IORef Bool+    -- ^ the current run of failures has been reported+    , sinkManager :: Maybe Manager+    -- ^ for a URL target; 'Nothing' for a file+    }++{- | Run a sink for the body's lifetime. The writer thread is cancelled+when the body returns, mid-write or not — the temporary file is the only+casualty, never the document.+-}+withSink :: Config -> Maybe Followed -> Reporter Tagged -> (Sink -> IO a) -> IO a+withSink cfg followed own body = do+    manager <-+        if isUrl cfg.configPath+            then Just <$> newTlsManagerWith tlsManagerSettings{HTTP.managerResponseTimeout = responseTimeoutMicro postTimeout}+            else pure Nothing+    sink <-+        Sink cfg followed own+            <$> newIORef Nothing+            <*> newIORef (Nothing, Nothing)+            <*> newTVarIO False+            <*> newIORef False+            <*> pure manager+    withAsync (writer sink) $ \_ -> body sink+  where+    writer sink = forever $ do+        timer <- registerDelay cfg.configInterval+        atomically $ do+            woken <- readTVar sink.sinkWake+            due <- readTVar timer+            unless (woken || due) retry+            writeTVar sink.sinkWake False+        writeNow sink++{- | What to hand 'Serve.serveObserved': installs the world accessor the+status object is read through. Combine with another observer (the HTTP+server's) by sequencing them; each is a write of one cell.+-}+sinkObserver :: Sink -> IO (World seed directive) -> IO ()+sinkObserver sink readWorld =+    writeIORef sink.sinkStatusOf $+        Just $ do+            w <- readWorld+            mode <- maybe (pure Serve.Interactive) followedMode sink.sinkFollowed+            pure (toJSON (Serve.StatusReport mode (Map.toList w.worldNodes) (Serve.worldPaths w)))++{- | The reporter to compose beside the loop's own. It keeps the last+converge-stop and the last follow report, and wakes the writer on a pass+ending or a document being injected; everything else passes through+unobserved. The objects kept are the tagged ones — @stream@ included — so+what the sink carries is byte-for-byte what @--json@ printed.+-}+sinkReporter :: Sink -> Reporter Tagged+sinkReporter sink = ReporterM $ \tagged ->+    case tagged of+        FromServe Serve.ConvergeStop{} -> do+            modifyIORef' sink.sinkLast (\(_, f) -> (Just (toJSON tagged), f))+            wake+        FromFollow rep -> do+            modifyIORef' sink.sinkLast (\(c, _) -> (c, Just (toJSON tagged)))+            when (injected rep) wake+        _ -> pure ()+  where+    wake = atomically (writeTVar sink.sinkWake True)+    injected Follow.Injected{} = True+    injected _ = False++{- | Write the document once, now. Nothing before the observer has+installed the world accessor; a failure is reported once per run of them.+-}+writeNow :: Sink -> IO ()+writeNow sink = do+    accessor <- readIORef sink.sinkStatusOf+    case accessor of+        Nothing -> pure ()+        Just readStatus -> do+            attempt <- try $ do+                now <- getCurrentTime+                status <- readStatus+                mode <- maybe (pure Serve.Interactive) followedMode sink.sinkFollowed+                labels <- maybe (pure []) followedApplied sink.sinkFollowed+                (lastConverge, lastFollow) <- readIORef sink.sinkLast+                let doc =+                        Document+                            { docHost = sink.sinkConfig.configHost+                            , docWritten = now+                            , docMode = Serve.renderMode mode+                            , docLabels = labels+                            , docStatus = status+                            , docLastConverge = lastConverge+                            , docLastFollow = lastFollow+                            }+                case sink.sinkManager of+                    Just manager -> postDocument manager sink.sinkConfig.configPath (encode doc)+                    Nothing -> writeAtomically sink.sinkConfig.configPath (encode doc)+            case attempt of+                Right () -> writeIORef sink.sinkComplained False+                Left (ex :: SomeException) -> do+                    complained <- readIORef sink.sinkComplained+                    unless complained $ do+                        writeIORef sink.sinkComplained True+                        runReporter sink.sinkOwn (FromServe (Serve.SinkFailed sink.sinkConfig.configPath (Text.pack (show ex))))++{- | Write bytes to a path through a temporary file beside it and a rename,+creating the directory if missing. May throw; the caller decides what a+failure means.+-}+writeAtomically :: FilePath -> LByteString.ByteString -> IO ()+writeAtomically path bytes = do+    createDirectoryIfMissing True (takeDirectory path)+    let tmp = path <.> "tmp"+    LByteString.writeFile tmp bytes+    renameFile tmp path++-- | Does this address have the shape of a URL to post to, rather than a path?+isUrl :: String -> Bool+isUrl target = any (`isPrefixOf` target) ["http://", "https://"]++-- | Ten seconds, in microseconds: how long a post may take before it is a failed write.+postTimeout :: Int+postTimeout = 10000000++{- | @POST@ the document as @application/json@. Anything but a 2xx answer+throws, with the status in the message; so does a connection that cannot be+made or a post that outlasts 'postTimeout'.+-}+postDocument :: Manager -> String -> LByteString.ByteString -> IO ()+postDocument manager url bytes = do+    req0 <- parseRequest url+    let req = req0{method = "POST", requestHeaders = [(hContentType, "application/json")], requestBody = RequestBodyLBS bytes}+    resp <- httpLbs req manager+    let code = statusCode (responseStatus resp)+    unless (code >= 200 && code < 300) $+        ioError (userError ("the sink answered " <> show code))
+ src/Salmon/Actions/UpDown.hs view
@@ -0,0 +1,529 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Salmon.Actions.UpDown where++import Control.Exception (SomeException, try)+import Control.Monad (forM_, when)+import Data.Dynamic (Dynamic)+import Data.IORef (atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Records+import System.Directory (doesDirectoryExist, doesFileExist)++import Salmon.FoldBranch+import Salmon.Op.Actions+import Salmon.Op.Dag (Dag)+import Salmon.Op.Mailbox (Instruction)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Eval+import Salmon.Op.OpGraph+import Salmon.Op.Ref+import Salmon.Reporter++-------------------------------------------------------------------------------++{- | 'Failed' and 'Blocked' are new relative to the early history of this+module: 'upTree' used to run every node's 'up' unconditionally and never+looked at whether it actually succeeded (a failing subprocess only ever+showed up, if at all, buried in a 'Salmon.Builtin.Nodes.Binary.Report').+Now a thrown exception from 'up' — which "Salmon.Builtin.Nodes.Binary".'Salmon.Builtin.Nodes.Binary.untrackedExec'+raises on a non-zero exit, so this isn't opt-in per node — is caught,+reported as 'Failed', and every node that (transitively) depends on it gets+'Blocked' instead of being evaluated against an unmet precondition. Nodes+outside that failed subtree are untouched: one broken branch doesn't halt+the whole traversal.+-}+data Report ext+    = Skip !(Act ext)+    | Eval !(Act ext)+    | Done !(Act ext)+    | Failed !(Act ext) !SomeException+    | Blocked !(Act ext)+    | -- | Two nodes in this graph share one 'Ref' — the same effect site,+      -- reached from two declarations that describe it differently. The+      -- second 'Act' is the representative that lost to last-writer-wins and+      -- was /not/ run; the first is the one that replaced it. See+      -- "Salmon.Op.Dag" for why the comparison is a heuristic, and why+      -- last-wins.+      --+      Conflicting !Ref !(Act ext) !(Act ext)+    | -- | an operator's 'Instruction' overrode what this node would otherwise+      -- have done. Only the concurrent driver can emit these: a one-shot+      -- 'upTree' has no mailboxes to read.+      Instructed !(Act ext) !Instruction+    | -- | this node's mailbox was full and evicted this many older+      -- instructions. Reported because forcing a node has to be either+      -- reliable or visibly unreliable.+      DroppedInstructions !(Act ext) !Int+    deriving (Show)++-------------------------------------------------------------------------------++{- | What a node's own 'Salmon.Builtin.Extension.check' answers about the+effect that node is responsible for.++This is the merge of what used to be two fields: @prelim :: IO Requirement@,+implemented by 22 nodes and consulted by 'upTreeWith', and @check :: IO ()@,+implemented by none and consulted only by a module with no callers. See+@specs/per-node-state-machines.md@ — the per-node state machines that spec+describes are driven by exactly this answer, so it has to say more than+"should I act".++Four of the six constructors describe the /effect/. The other two describe a+decision somebody made /about/ the node: 'Skipped' is an operator's ("treat+this as satisfied", from 'Salmon.Actions.Query.forceSkip') and 'Immaterial'+is the node author's ("there is nothing here worth asking about").+-}+data CheckResult+    = -- | the effect is in place+      Success+    | -- | treat as satisfied without looking; see 'Salmon.Actions.Query.forceSkip'+      Skipped+    | -- | the effect ran to completion and stopped on purpose — a job rather+      -- than a service. Converged, but not running.+      Completed+    | -- | the effect is not in place, with a reason. Note this is the+      -- ordinary answer on a first run and not an error report: "the file+      -- isn't there yet" and "the file is there but wrong" are the same+      -- answer to the only question 'upTreeWith' asks, which is whether to+      -- run 'up'.+      Failure !Text+    | -- | the check looked and could not tell. Acts like 'Failure' when+      -- deciding whether to run 'up', and is kept distinct so that a+      -- supervisor can tell "I looked and it is gone" from "I could not+      -- look" — see "Salmon.Builtin.Nodes.Systemd", where a unit part-way+      -- through starting is exactly this and calling it gone is how a slow+      -- starter becomes a restart loop.+      Unknown+    | -- | there is nothing here worth asking about: applying the effect+      -- costs about what finding out would, so the node's author declined+      -- to write a check and said so. @mkdir -p@ against+      -- 'System.Directory.doesDirectoryExist' is the shape of it, and so is+      -- @ip route replace@ — the whole family of nodes whose idempotency+      -- comes from the underlying tool having a "set" verb.+      --+      -- __This is the default__ for a node that supplies no 'check', which+      -- 'Unknown' used to be. The one-shot drivers cannot tell the two+      -- apart, both being 'Required': running an idempotent @up@ once is+      -- precisely the cheap thing being claimed. The difference is under+      -- "Salmon.Actions.Upkeep", where a node that answers this /parks/+      -- rather than waking on a timer to be told the same thing again. It+      -- also leaves 'Unknown' meaning only what it says, which it could not+      -- while it doubled as "nobody wrote a check".+      Immaterial+    deriving (Show, Eq)++{- | Least-satisfied wins, mirroring 'Requirement''s "'Required' wins": if+either half of a merged node still needs doing, the merged node does. Only+reachable through @instance Semigroup Salmon.Builtin.Extension.Extension@,+which nothing on the execution path uses.+-}+instance Semigroup CheckResult where+    Failure a <> Failure b = Failure (a <> "; " <> b)+    Failure a <> _ = Failure a+    _ <> Failure b = Failure b+    Unknown <> _ = Unknown+    _ <> Unknown = Unknown+    Immaterial <> _ = Immaterial+    _ <> Immaterial = Immaterial+    Completed <> _ = Completed+    _ <> Completed = Completed+    Skipped <> b = b+    Success <> b = b++data Requirement+    = Required+    | Skippable+    deriving (Show, Ord, Eq)++instance Semigroup Requirement where+    Skippable <> Skippable = Skippable+    _ <> _ = Required++{- | What 'upTreeWith' does with a 'CheckResult'.++'Failure', 'Unknown' and 'Immaterial' all mean 'Required'. Erring that way+is safe because 'Salmon.Builtin.Extension.up' is required to be idempotent+regardless (see CLAUDE.md), and it is the direction that keeps a node with a+broken check converging rather than stalling. It is also why a one-shot+@run up@ behaves exactly as it did before 'Immaterial' existed.+-}+requirement :: CheckResult -> Requirement+requirement Success = Skippable+requirement Skipped = Skippable+requirement Completed = Skippable+requirement (Failure _) = Required+requirement Unknown = Required+requirement Immaterial = Required++skipIfDirectoryIsMissing :: FilePath -> IO CheckResult+skipIfDirectoryIsMissing path = do+    exists <- doesDirectoryExist path+    if not exists+        then pure Success+        else pure (Failure $ "still present: " <> Text.pack path)++skipIfFileExists :: FilePath -> IO CheckResult+skipIfFileExists path = do+    exists <- doesFileExist path+    if exists+        then pure Success+        else pure (Failure $ "missing: " <> Text.pack path)++{- | An extra, caller-supplied precondition, consulted per node /before/ the+node's own opinion about itself is asked for.++Where a node's own 'Salmon.Builtin.Extension.check' answers "is my effect+already in place on this machine", a 'Gate' answers the orthogonal question+"does this traversal want to touch this node at all" — which only the caller+knows. It exists for+"Salmon.Actions.Serve".'Salmon.Actions.Serve.serve', which walks a graph+that is the union of several seeds' graphs and must leave alone the nodes+that belong to some /other/ seed, or that it has already converged.++A 'Gate' returning 'Skippable' short-circuits: for 'upTreeWith' the node's+own 'check' is not even consulted, and either way the node is reported+'Skip'ped. Returning 'Required' means "this traversal does want this node",+and the usual per-node logic proceeds unchanged.+-}+type Gate ext = Act ext -> IO Requirement++-- | The 'Gate' that wants every node: what plain 'upTree'/'downTree' use.+alwaysRequired :: Gate ext+alwaysRequired = const (pure Required)++{- | Returns 'True' iff every node actually ran (or was legitimately+'Skip'ped via 'check') — i.e. 'False' means at least one node threw and+something downstream of it was 'Blocked'. Callers that only care about+side effects (the historical behaviour) can ignore the result; callers that+want a process exit code to reflect reality (e.g. a CLI) now can.+-}+upTree ::+    forall a m ext.+    ( Monad m+    , HasField "up" ext (IO ())+    , HasField "check" ext (IO CheckResult)+    , HasField "ref" ext Ref+    , -- the fields 'Salmon.Op.Dag.sameRepresentative' compares two colliding+      -- representatives on; see 'Conflicting'.+      HasField "help" ext Text+    , HasField "notes" ext [Text]+    , HasField "dynamics" ext [Dynamic]+    ) =>+    Reporter (Report ext) ->+    (forall a. m a -> IO a) ->+    OpGraph m (Actions ext) ->+    IO Bool+upTree = upTreeWith alwaysRequired++-- | 'upTree', but only touching the nodes a caller-supplied 'Gate' asks for.+upTreeWith ::+    forall a m ext.+    ( Monad m+    , HasField "up" ext (IO ())+    , HasField "check" ext (IO CheckResult)+    , HasField "ref" ext Ref+    , -- the fields 'Salmon.Op.Dag.sameRepresentative' compares two colliding+      -- representatives on; see 'Conflicting'.+      HasField "help" ext Text+    , HasField "notes" ext [Text]+    , HasField "dynamics" ext [Dynamic]+    ) =>+    Gate ext ->+    Reporter (Report ext) ->+    (forall a. m a -> IO a) ->+    OpGraph m (Actions ext) ->+    IO Bool+upTreeWith gate r nat graph = upDag gate r =<< expandDag r nat graph++{- | 'upTreeWith' once the graph has already been collapsed: one pass over a+'Dag.Dag' in dependency order, one attempt per node, 'Salmon.Builtin.Extension.check'+then 'Salmon.Builtin.Extension.up'.++The exact mirror of 'downDag', which is the point — the two drivers now share+the collapse, the ordering machinery and the failure containment, and differ+only in which adjacency direction they follow and which action they run. A+long-running driver that keeps a magma and a "Salmon.Op.Ledger" rather than+graphs gets here through 'Dag.fromMagma'.++Termination is structural in the finite 'Dag.Dag' this walks: one attempt per+node, no retries, no waiting. That is what keeps @run up@ a command that+returns rather than a supervisor.+-}+upDag ::+    forall ext.+    ( HasField "up" ext (IO ())+    , HasField "check" ext (IO CheckResult)+    , HasField "ref" ext Ref+    ) =>+    Gate ext ->+    Reporter (Report ext) ->+    Dag ext ->+    IO Bool+upDag gate r dag =+    walk r dag Dag.dependenciesOf Dag.dependantsOf (Dag.leaves dag) apply+  where+    -- returns True iff this node failed, so its dependants must not be run+    -- against an unmet precondition.+    apply :: Act ext -> IO Bool+    apply act = do+        wanted <- gate act+        st <- case wanted of+            Skippable -> pure Skippable+            Required -> requirement <$> runCheck act+        case st of+            Skippable -> do+                runReporter r (Skip act)+                pure False+            Required -> do+                runReporter r (Eval act)+                result <- try @SomeException act.extension.up+                case result of+                    Left e -> do+                        runReporter r (Failed act e)+                        pure True+                    Right () -> do+                        runReporter r (Done act)+                        pure False++{- | The ordering, containment and completeness machinery both drivers share,+parameterised by which way round they read the 'Dag.Dag'.++@ready@ is the direction a node waits on (dependencies for a bring-up,+dependants for a teardown) and @release@ its opposite; @start@ is the nodes+waiting on nothing. A node is applied once everything it waits on is done;+if @apply@ (or a prior 'Blocked') says it is not safe to proceed past this+node, everything it would have released is 'Blocked' instead — one failure+contains a whole sub-DAG rather than a single branch, in whichever direction+that sub-DAG lies.++The final sweep is what a walk over a 'Dag.Dag' needs and a walk over a+'Cofree' did not: an edge set can describe a cycle, and a node on one never+reaches a count of zero. Reporting those 'Blocked' turns "silently did+nothing and claimed success" into a visible failure.+-}+walk ::+    forall ext.+    (HasField "ref" ext Ref) =>+    Reporter (Report ext) ->+    Dag ext ->+    (Dag ext -> Ref -> [Ref]) ->+    (Dag ext -> Ref -> [Ref]) ->+    [Ref] ->+    (Act ext -> IO Bool) ->+    IO Bool+walk r dag ready release start apply = do+    let order = Dag.dagOrder dag+    countRef <- newIORef (Map.fromList [(aref, length (ready dag aref)) | aref <- order])+    blockedRef <- newIORef (Set.empty :: Set Ref)+    doneRef <- newIORef (Set.empty :: Set Ref)+    failRef <- newIORef False+    let+        processNode :: Act ext -> IO Bool+        processNode act = do+            blocked <- Set.member act.extension.ref <$> readIORef blockedRef+            if blocked+                then do+                    runReporter r (Blocked act)+                    writeIORef failRef True+                    pure True+                else apply act >>= \stop -> do+                    when stop (writeIORef failRef True)+                    pure stop++        processReady :: Ref -> IO ()+        processReady aref = do+            modifyIORef' doneRef (Set.insert aref)+            stop <- maybe (pure False) processNode (Dag.representativeOf dag aref)+            forM_ (release dag aref) $ \d -> do+                when stop $ modifyIORef' blockedRef (Set.insert d)+                n <- atomicModifyIORef' countRef $ \m ->+                    let k = Map.findWithDefault 0 d m - 1 in (Map.insert d k m, k)+                when (n == 0) $ processReady d++    mapM_ processReady start++    -- anything a cycle kept from ever becoming ready.+    reached <- readIORef doneRef+    forM_ [aref | aref <- order, Set.notMember aref reached] $ \aref -> do+        forM_ (Dag.representativeOf dag aref) $ \act -> runReporter r (Blocked act)+        writeIORef failRef True++    not <$> readIORef failRef++{- | Everything both drivers do before either of them walks anything: expand+the effectful @predecessors@ recipes, collapse the result to a 'Dag.Dag', and+report any 'Ref' collision the collapse had to resolve.++Exposed rather than inlined because this is the seam a+"Salmon.Op.Rewrite" phase goes in: a caller that has rewrites registered folds+here, rewrites, and hands 'upDag'\/'downDag' the computed graph instead of+the declared one.+-}+expandDag ::+    forall a m ext.+    ( Monad m+    , HasField "ref" ext Ref+    , HasField "help" ext Text+    , HasField "notes" ext [Text]+    , HasField "dynamics" ext [Dynamic]+    ) =>+    Reporter (Report ext) ->+    (forall a. m a -> IO a) ->+    OpGraph m (Actions ext) ->+    IO (Dag ext)+expandDag r nat graph = do+    cofree <- nat (expand graph)+    let dag = Dag.foldDag Dag.sameRepresentative cofree+    reportConflicts r dag+    pure dag++-- | Emit one 'Conflicting' per representative that lost to last-writer-wins,+-- oldest first. Both drivers do this before touching anything.+reportConflicts :: Reporter (Report ext) -> Dag ext -> IO ()+reportConflicts r dag =+    forM_ (reverse (Dag.dagConflicts dag)) $ \c ->+        runReporter r (Conflicting c.conflictRef c.conflictKept c.conflictReplaced)++{- | Runs a node's own 'Salmon.Builtin.Extension.check', containing a thrower+as a 'Failure' rather than letting it escape.++This is the one behaviour change in merging @prelim@ into @check@: @prelim@+was evaluated outside the 'try' that wraps 'Salmon.Builtin.Extension.up', so+a @prelim@ that threw took the whole traversal down with it instead of+failing the one node. A check that throws now just means the node's effect+could not be confirmed, and 'requirement' turns that into "run 'up'".+-}+runCheck ::+    (HasField "check" ext (IO CheckResult)) =>+    Act ext ->+    IO CheckResult+runCheck act = do+    result <- try @SomeException act.extension.check+    pure $ case result of+        Left e -> Failure (Text.pack (show e))+        Right x -> x++{- | Tears a graph down in reverse-dependency (topological) order: a node is+torn down only after /every/ node that depends on it already has been. This+matters precisely for a predecessor shared by several dependents — e.g. a+directory two files sit in: the naive "walk the tree top-down, dedupe by+'Ref'" would tear that directory down at the /first/ dependent it was reached+through, while the other dependents were still standing on top of it (a+directory-not-empty failure, in the filesystem case). So this does not walk+the 'Cofree' structurally; it first collapses it with+"Salmon.Op.Dag".'Salmon.Op.Dag.foldDag' into a 'Ref'-level DAG that knows+each node's /dependants/ as well as its dependencies, and then tears nodes+down as they become free — a node is processed once all its dependants are+done, and only then are its own predecessors released. A 'Ref' collision+inside the graph is reported 'Conflicting' before anything runs.++Failure is contained the mirror image of 'upTree's: a node whose 'down' threw+is reported 'Failed', and because it is therefore /still standing/, every one+of its predecessors is 'Blocked' — it would be unsafe to pull a dependency+out from under a node that is still up. A predecessor is likewise blocked if+/any/ of its dependents was blocked, so one failure contains a whole+still-standing sub-DAG rather than a single tree branch. A 'Gate' 'Skip'+(caller says "leave this node alone") is /not/ a failure and does not block+predecessors. Returns 'True' iff everything wanted was actually torn down (no+'Failed'/'Blocked'). Unlike the old structural walk, a shared node is visited+exactly once, so 'downTree' never emits 'Redundant'.+-}+downTree ::+    forall a m ext.+    ( Monad m+    , HasField "down" ext (IO ())+    , HasField "ref" ext Ref+    , -- the fields 'Salmon.Op.Dag.sameRepresentative' compares two colliding+      -- representatives on; see 'Conflicting'.+      HasField "help" ext Text+    , HasField "notes" ext [Text]+    , HasField "dynamics" ext [Dynamic]+    ) =>+    Reporter (Report ext) ->+    (forall a. m a -> IO a) ->+    OpGraph m (Actions ext) ->+    IO Bool+downTree = downTreeWith alwaysRequired++{- | 'downTree', but only tearing down the nodes a caller-supplied 'Gate'+asks for. Note that, unlike 'upTreeWith', this is the /only/ way a node gets+'Skip'ped on the way down: a node's own 'Salmon.Builtin.Extension.check' is+never consulted for teardown (it is written to answer "does my effect still+need creating", which is not the question a teardown needs answered).++The @help@\/@notes@\/@dynamics@ constraints are+'Salmon.Op.Dag.sameRepresentative''s, not this function's. GHC only solves a+'HasField' constraint when the field selector is in scope, so a caller that+imports 'Salmon.Builtin.Extension' selectively has to name those three+fields even though it never mentions them.+-}+downTreeWith ::+    forall a m ext.+    ( Monad m+    , HasField "down" ext (IO ())+    , HasField "ref" ext Ref+    , -- the fields 'Salmon.Op.Dag.sameRepresentative' compares two colliding+      -- representatives on; see 'Conflicting'.+      HasField "help" ext Text+    , HasField "notes" ext [Text]+    , HasField "dynamics" ext [Dynamic]+    ) =>+    Gate ext ->+    Reporter (Report ext) ->+    (forall a. m a -> IO a) ->+    OpGraph m (Actions ext) ->+    IO Bool+downTreeWith gate r nat graph = downDag gate r =<< expandDag r nat graph++{- | 'downTreeWith' once the graph has already been collapsed — the exact+mirror of 'upDag': the same 'walk', read the other way round, running+'Salmon.Builtin.Extension.down' instead of+'Salmon.Builtin.Extension.up'.++A node's own 'Salmon.Builtin.Extension.check' is never consulted here (it+answers "does my effect still need creating", which is not the question a+teardown asks), so a 'Gate' is the only thing that skips a node on the way+down.++Split out from 'downTreeWith' because a long-running driver does not keep+graphs: it keeps a magma and a "Salmon.Op.Ledger" of who still wants what,+and rebuilds something walkable with 'Dag.fromMagma'. Expanding a 'Cofree' is+one way to get here, not the only one.+-}+downDag ::+    forall ext.+    ( HasField "down" ext (IO ())+    , HasField "ref" ext Ref+    ) =>+    Gate ext ->+    Reporter (Report ext) ->+    Dag ext ->+    IO Bool+downDag gate r dag =+    walk r dag Dag.dependantsOf Dag.dependenciesOf (Dag.roots dag) apply+  where+    -- returns True iff the node is still standing, so its predecessors must+    -- not be pulled out from under it.+    apply :: Act ext -> IO Bool+    apply act = do+        wanted <- gate act+        case wanted of+            Skippable -> do+                runReporter r (Skip act)+                pure False+            Required -> do+                runReporter r (Eval act)+                result <- try @SomeException act.extension.down+                case result of+                    Left e -> do+                        runReporter r (Failed act e)+                        pure True+                    Right () -> do+                        runReporter r (Done act)+                        pure False
+ src/Salmon/Actions/Upkeep.hs view
@@ -0,0 +1,2063 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | The continuous driver: a node is not applied once, it is /tended/.++"Salmon.Actions.UpDown" and "Salmon.Actions.Concurrent" both make one pass —+one attempt per node, then the walk returns @IO Bool@ and everything it+started is over. This one does not return. Each node runs a small state+machine that keeps asking whether its effect is still in place and puts it+back when it is not, which is the whole of "keep this running" and the reason+@Salmon.Builtin.Nodes.Supervised@ was deleted rather than ported: supervision+is not a kind of node, it is what every node gets.++= Two machines, three states each++@+'UpkeepState'   = 'WaitUp'   | 'Upping'  | 'Up'+'DownkeepState' = 'WaitDown' | 'Downing' | 'Down'+@++A node wanted up runs the first, a node wanted down runs the second, and+which neighbours it waits on is the only difference in their ordering:+dependencies going up, dependants coming down, exactly as in the one-shot+drivers. 'Salmon.Op.Status.waitStability' does the blocking, so there is+still no scheduler and no ready-queue.++The asymmetry between them is not an oversight: __'Down' is terminal and+'Up' is not.__ A node's 'Salmon.Builtin.Extension.check' answers "does my+effect need creating", which is a question about being up; nothing in the+model answers "is it still gone". So a downkeep machine reaching 'Down' has+finished and exits, while an upkeep machine reaching 'Up' has only started.++= The steady state is a check on an adaptive delay++@+'Up': wait 'Delay'; then 'Salmon.Actions.UpDown.runCheck':+    the effect is there   -> stay 'Up', 'relaxed'   (double, capped at 60s)+    the effect is gone    -> go 'Upping', 'attentive' (halve, floored at 500ms)+@++Backing off while healthy and tightening while not is what makes this cost+nothing in the common case and react quickly in the uncommon one. It is also+why a check is allowed to be expensive: the adaptive value is a delay+/between/ checks rather than a period, so a slow check reduces its own+frequency and the load is self-limiting.++Three refinements this module makes to that rule, all places where the+one-shot reading does not survive contact with a loop:++* __'Salmon.Actions.UpDown.Unknown' does not restart anything.__+  'Salmon.Actions.UpDown.requirement' maps it to+  'Salmon.Actions.UpDown.Required', which is right for one pass over an+  idempotent action and wrong here: "I looked and could not tell" is not+  evidence the effect went away, and acting on it would spin the node at the+  delay floor for as long as @serve@ is up. Such a node keeps being asked,+  and keeps being left alone.+* __'Salmon.Actions.UpDown.Immaterial' is not polled at all.__ It is the+  answer from a node whose author declined to write a check because asking+  costs what applying costs — which, being the default, is most of the nodes+  in this tree. There is then no cheaper question to put on a timer, so such+  a node /parks/: it blocks on its mailbox, its demoting dependencies and+  (if it holds one) its own action, with no delay ladder at all. See 'Rest'.+  It takes one look to learn this, because what a machine knows on the way in+  is that its @up@ ran, not what a check would say.+* __A failing @up@ backs off rather than tightening.__ The spec's rule+  adapts the delay on what the /check/ said; it says nothing about how often+  to retry an @up@ that keeps throwing. Tightening there would hammer+  @apt-get@ every 500ms, so 'Upping' 'relaxed's on each failure and the+  retry cadence decays to the cap.++= Instructions finally mean something++'Salmon.Op.Mailbox.Recheck', 'Salmon.Op.Mailbox.Pause' and+'Salmon.Op.Mailbox.Resume' are read and ignored by the one-shot concurrent+driver, because there is nothing continuous for them to modify. Here+'Salmon.Op.Mailbox.Recheck' collapses the delay to its floor and looks now,+'Salmon.Op.Mailbox.Pause' stops tending the node without touching its effect,+and 'Salmon.Op.Mailbox.Resume' starts again. 'Salmon.Op.Mailbox.Force' and+'Salmon.Op.Mailbox.Satisfy' keep their meanings. Every wait in the machine —+the neighbour wait and the delay both — is a choice against the mailbox, so+an instruction is never queued behind a 60s nap.++= Failure is waited out, not contained++This is the sharpest difference from the one-shot drivers and the reason+'Salmon.Op.Status.waitStability' deliberately cannot see whether a neighbour+succeeded. A one-shot pass reports 'Salmon.Actions.UpDown.Blocked' for a node+whose dependency failed, because the pass is about to end and the node will+not get another chance. Here it gets nothing but chances: the dependency's+own machine is still retrying, so the dependant simply keeps waiting and+proceeds the moment the dependency recovers, with nobody re-declaring+anything. That is the same fact — "do not act against an unmet+precondition" — with the driver's own answer to what to do about it.++A cycle is the one case with no answer, and it is found before the walk for+the same reason "Salmon.Actions.Concurrent" finds it there: a thread waiting+on a node in a cycle never wakes.++= A node leaving 'Up' can take its dependants with it++By default it does not: putting a node back is a statement about that node,+and the nodes standing on it that have already reached 'Up' are not+disturbed. A node whose author says+'Salmon.Op.Supervision.RestForOne' is the exception — its dependants go back+to 'WaitUp' and are brought up again on top of whatever it turns into, which+is Erlang's strategy of the same name read along dependency edges, and the+only thing in this design that changes what a /correct/ graph does.++Three things keep that affordable:++* __it is opt-in on the node that goes away__, so a graph naming no strategy+  behaves exactly as it did before, and a machine with no such dependency+  subscribes to no statuses at all — the cost is zero rather than small;+* __a dependency that has not been ready yet cannot demote anybody.__+  Otherwise a supervisor starting over a graph a pass has just converged+  would send every opted-in node back to 'WaitUp' before its dependencies'+  machines had settled, undoing 'Standing' wholesale;+* __a node is demoted at most once per its own+  'Salmon.Op.Supervision.supStableAfter'__, so a flapping dependency cannot+  rebuild the cone behind it on every flap. A rate limit rather than a+  settling delay, deliberately: a settling delay would swallow the case the+  feature is for, since a rewritten config file is back within milliseconds.++= A machine that throws is restarted, not lost++'Salmon.Actions.UpDown.Blocked' has no equivalent here for a node's own+/machine/ throwing — as opposed to its @up@\/@down@\/@check@ throwing, which+is caught inside 'upkeep'\/'downkeep' and handled entirely in-band. A machine+escaping those is this module's own bug, not the node's, and it used to mean+the node was simply gone until the next 'startUpkeep' rebuilt every machine+from scratch — tolerable while a supervisor's lifetime was one convergence+pass, and not once one is left running across commands ('Kept', and the+mailbox queue 'startTending' drains into it — see @specs/per-node-state-machines-remaining.md@'s+R2/R5).++'restarting' is the layer that closes that gap: it is what 'startUpkeep' now+runs instead of 'machine' directly, and it restarts the node's machine in+place — reporting 'Escaped' on every attempt, since a restart that happened+silently would defeat the point of calling this a bug. The restart re-enters+as 'Unsettled' rather than wherever the dead machine's closure remembered:+nothing survived the crash, not even the assumption that the effect is still+there, and 'Unsettled' is what makes the very next step a fresh 'Consult'+rather than a blind @up@. A short, fixed pause ('delayFloor') separates one+attempt from the next, only so a bug that fires on every entry cannot spin a+core; it is not the adaptive ladder; 'Salmon.Op.Supervision' has no opinion+about it, being a policy about the /node/, not about this module's own bugs.++The one thing 'restarting' must not catch is an /asynchronous/ exception —+'Control.Concurrent.Async.AsyncCancelled' above all, since 'releaseKept'+tears a holding machine down by throwing exactly that into it and then+waiting for the async to finish. Swallowing it as though it were a crash+would restart the machine 'releaseKept' is trying to stop, and its caller's+wait would never return. Anything matching 'SomeAsyncException' is re-thrown+untouched instead of restarted.++= The watchdog++'Salmon.Op.Supervision.supWatchdog' is a node author saying how long their+node may go without doing anything observable. A single scanning thread+compares 'Salmon.Op.Status.statusLastActive' against it and reports+'Wedged' — once per episode, with 'Unwedged' when the node moves again. It+only ever /reports/: killing a wedged @up@ would need a bracket around it+that an @up :: IO ()@ does not have, which is exactly what a node owning its+process ('Salmon.Builtin.Extension.managed') supplies and no other node can.+If no node in the dag declares a watchdog the thread is never started.+-}+module Salmon.Actions.Upkeep (+    -- * The machines+    UpkeepState (..),+    DownkeepState (..),++    -- * The adaptive delay+    Delay,+    initialDelay,+    delayFloor,+    delayCap,+    delayMicros,+    attentive,+    relaxed,++    -- * What a node is tended as+    Tend (..),+    Standing (..),++    -- * Running+    Supervisor,+    startUpkeep,+    stopUpkeep,+    withUpkeep,+    supervisorStatuses,+    supervisorMailboxes,+    supervisorTending,+    instruct,++    -- * Machines that outlive a supervisor+    Kept,+    noKept,+    keptHeld,+    releaseKept,++    -- * Reporting+    Report (..),+) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (Async, async, cancel, poll, waitCatch, waitCatchSTM, withAsync)+import Control.Concurrent.MVar (newMVar, withMVar)+import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar', newTVarIO, orElse, readTVar, readTVarIO, registerDelay, retry, writeTVar)+import Control.Exception (SomeAsyncException, SomeException, bracket, fromException, throwIO, try)+import Control.Monad (forM, forM_, unless)+import Data.Dynamic (Dynamic)+import Data.Foldable (traverse_)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, isJust, mapMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Word (Word64)+import GHC.Clock (getMonotonicTimeNSec)+import GHC.Records (HasField, getField)+import System.Exit (ExitCode (..))++import Salmon.Actions.UpDown (CheckResult (..), runCheck)+import qualified Salmon.Actions.UpDown as UpDown+import Salmon.Op.Actions (Act (..))+import Salmon.Op.Dag (Dag)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Mailbox (Instruction (..), Mailbox)+import qualified Salmon.Op.Mailbox as Mailbox+import Salmon.Op.Ref (Ref, unRef)+import Salmon.Op.Status (Direction (..), Stability (..), Status (..), newStatus, note, settle, touch, unsettle, waitStability, wedged)+import Salmon.Op.Supervision (Micros (..), Restart (..), Strategy (..), Supervision (..), millis, seconds, supervisionOf, toNanos)+import Salmon.Reporter++-------------------------------------------------------------------------------++-- | Where a node wanted up currently is.+data UpkeepState+    = -- | a dependency is not up yet, or is failing+      WaitUp+    | -- | running @up@+      Upping+    | -- | the effect is in place; checking on it periodically+      Up+    deriving (Show, Eq, Ord)++{- | Where a node wanted down currently is. 'Down' is terminal — see the+module header on why there is no polling counterpart to 'Up'.+-}+data DownkeepState+    = -- | something still standing on this node has not come down+      WaitDown+    | -- | running @down@+      Downing+    | Down+    deriving (Show, Eq, Ord)++{- | What a node is to be tended as: which way, and whether it is already+there.++@+'Tend' 'TurnUp' 'Unsettled'  -- bring it up, then keep it up+'Tend' 'TurnUp' 'Settled'    -- it is up; just keep it that way+@+-}+data Tend = Tend+    { tendDirection :: !Direction+    , tendStanding :: !Standing+    }+    deriving (Show, Eq)++{- | Whether the caller already knows the node to be where it wants to be.++This exists because a supervisor is usually started /after/ something else+has just done the work — a convergence pass, or an earlier supervisor — and+a node whose check cannot confirm its own effect would otherwise have that+work done again immediately. Most nodes in this repository have no @check@+at all and answer 'Salmon.Actions.UpDown.Unknown', so 'Consult'ing them on+the way in means re-running every @up@ in the graph after every pass. The+caller knows better and says so.++'Settled' is a claim about the past, not a promise about the future: the+node's machine still looks, on the ordinary adaptive delay, and still puts+the node back if the effect has gone. What 'Settled' skips is the first+@up@, not the watching.+-}+data Standing+    = -- | not known to be there: wait for the neighbours, then act+      Unsettled+    | -- | already there; start in 'Up' (or 'Down') and only look+      Settled+    deriving (Show, Eq, Ord)++-------------------------------------------------------------------------------++{- | How long to wait before looking again. Doubles while things are fine and+halves while they are not, between a floor and a cap.+-}+newtype Delay = Delay Micros+    deriving (Show, Eq, Ord)++-- | Half a second: as often as this ever looks.+delayFloor :: Micros+delayFloor = millis 500++-- | A minute: as rarely as this ever looks.+delayCap :: Micros+delayCap = seconds 60++{- | Where a machine starts. At the floor, because a node that has just been+brought up is the one most likely to fall straight back over.+-}+initialDelay :: Delay+initialDelay = Delay delayFloor++delayMicros :: Delay -> Micros+delayMicros (Delay m) = m++-- | Look sooner: halve, no lower than 'delayFloor'.+attentive :: Delay -> Delay+attentive (Delay (Micros m)) = Delay (Micros (max (unMicros delayFloor) (m `div` 2)))++-- | Look later: double, no higher than 'delayCap'.+relaxed :: Delay -> Delay+relaxed (Delay (Micros m)) = Delay (Micros (min (unMicros delayCap) (m * 2)))++-------------------------------------------------------------------------------++{- | Everything this driver has to say. 'Acted' carries the one-shot drivers'+own vocabulary unchanged, so a caller already listening to+'Salmon.Actions.UpDown.Report' — @serve@'s convergence bookkeeping, for+instance — keeps working by looking at nothing else.+-}+data Report ext+    = -- | what the node did, in the one-shot drivers' words+      Acted !(UpDown.Report ext)+    | -- | a node wanted up changed state+      Upkeep !(Act ext) !UpkeepState+    | -- | a node wanted down changed state+      Downkeep !(Act ext) !DownkeepState+    | -- | resting in 'Up': this is what the check said, and this is how long+      -- until the next one+      NextLook !(Act ext) !CheckResult !Micros+    | -- | silent for longer than its author said it ever should be+      Wedged !(Act ext) !Micros+    | -- | ...and moving again+      Unwedged !(Act ext)+    | -- | one line a node's held action produced, as it went into the node's+      -- output ring: what a live tail follows. Only lines from an action a+      -- machine holds; the ring's own narration (@up@, @spawn@, ...) is not+      -- output.+      Output !(Act ext) !Text+    | -- | a dependency that declared 'Salmon.Op.Supervision.RestForOne' left+      -- 'Up', so this node went back to 'WaitUp' to be brought up again on+      -- top of whatever that dependency becomes+      Demoted !(Act ext) !Ref+    | -- | resting in 'Up' with nothing to poll for: this node's check+      -- answered 'Salmon.Actions.UpDown.Immaterial', so the machine is+      -- blocked on its mailbox and its demoting dependencies instead of on+      -- a timer. Takes the place 'NextLook' has for a node that does have+      -- something to ask.+      Parked !(Act ext)+    | -- | resting in 'Up' and about to sleep before re-running @up@ again,+      -- because this node declared 'Salmon.Op.Supervision.supReapply'+      -- rather than being asked. Takes the place 'NextLook' has for a node+      -- with a real check, and is kept distinct from it precisely so a scan+      -- of the log can tell "checked and found fine" from "never asked,+      -- just applied again" at a glance.+      Reapplying !(Act ext) !Micros+    | -- | told to stop tending this node; its effect is left exactly as it is+      Paused !(Act ext)+    | Resumed !(Act ext)+    | -- | this many consecutive failures was the author's limit+      -- ('Salmon.Op.Supervision.supGiveUpAfter'), so the node is parked+      -- until an operator forces or rechecks it+      GaveUp !(Act ext) !Int+    | -- | a machine left running by a previous supervisor was taken over+      -- rather than restarted, so the effect it holds never stopped+      Adopted !(Act ext)+    | -- | ...and one that was not taken over: cancelled, which tears the+      -- effect it held down through the action's own bracket+      Released !(Act ext)+    | -- | this node declared more than one 'Supervision'; the first is in+      -- force and the rest are not. See "Salmon.Op.Supervision".+      Policy !(Act ext) !Supervision ![Supervision]+    | -- | in the dag, but not this supervisor's business: settled out of the+      -- way so that its neighbours are not held up+      Untended !(Act ext)+    | -- | a node's own machine threw, which is a bug in this module rather+      -- than a failure of the node+      Escaped !(Act ext) !SomeException+    | -- | machines started: wanted up, wanted down+      Supervising !Int !Int+    | -- | machines stopped+      Retired !Int+    | -- | ...and machines left running, holding effects up, for the next+      -- supervisor to adopt. See 'Kept'.+      Holding !Int+    deriving (Show)+++-------------------------------------------------------------------------------++-- | One node's machine, its observable state, and the way to talk to it.+data Machine ext = Machine+    { machineAct :: !(Act ext)+    , machineDirection :: !Direction+    , machineStatus :: !(TVar Status)+    , machineMailbox :: !Mailbox+    , machineWatchdog :: !(Maybe Micros)+    , machineHolds :: !Bool+    -- ^ whether this machine holds a running+    -- 'Salmon.Builtin.Extension.managed' action, and so is 'Kept' rather+    -- than wound down when its supervisor stops.+    , machineUnder :: !(TVar Under)+    -- ^ the supervisor this machine is running under. Held here, and not+    -- only inside the machine's own closure, so that a supervisor adopting+    -- the machine can hand it its own. See 'Under'.+    , machineThread :: !(Async ())+    }++{- | Everything about a machine that belongs to its /supervisor/ rather than+to its node: who it waits on, which of those can send it back to 'WaitUp',+where the failures everyone reads are recorded, and when to stop.++Behind a 'TVar' for one case, and it is the case 'Kept' created. A machine+holding a 'Salmon.Builtin.Extension.managed' action outlives the supervisor+that started it, and an adopted machine still looking at that supervisor's+state would be looking at things nobody maintains any more: it could never+see a dependency leave 'Up', its own failures would be recorded where no+dependant reads them, and — the one that bites hardest — the halt flag it+watches is permanently set, so the moment such a machine took a path that+heeds it (which, before 'Salmon.Op.Supervision.RestForOne', it never did) it+would quietly exit and orphan the process it holds. So 'startUpkeep' writes+its own state into every machine it adopts, and every wait reads that afresh+rather than closing over it.+-}+data Under = Under+    { underStatuses :: !(Map Ref (TVar Status))+    -- ^ every node this supervisor is tending. A neighbour that is not in+    -- here is not waited on at all: nothing is going to move it, so waiting+    -- for it to move would be waiting forever.+    , underFailed :: !(TVar (Set Ref))+    -- ^ which nodes are currently failing. Not in 'Status' for the reason+    -- 'Salmon.Op.Status.waitStability' gives: the two drivers answer+    -- "proceed past a failure?" differently.+    , underHalt :: !(TVar Bool)+    -- ^ set when this supervisor is stopping. See 'Heed' for who is allowed+    -- to hear it, and why a machine holding an effect is not.+    , underDependencies :: ![Ref]+    -- ^ waited on by a node going up.+    , underDependants :: ![Ref]+    -- ^ waited on by a node coming down.+    , underDemoters :: ![Ref]+    -- ^ the dependencies that declared 'Salmon.Op.Supervision.RestForOne':+    -- the ones whose leaving 'Up' sends this node back to 'WaitUp'. Empty+    -- for every node until somebody opts one in, and that emptiness is the+    -- whole of why the feature costs nothing.+    }++{- | Where a node in 'Up' last saw each of its demoting dependencies: which+machine it was watching, and the 'Salmon.Op.Status.statusEpoch' that machine+was settled at.++A dependency that is /absent/ is disarmed — it has not been seen settled up+since this node started watching, and so cannot send it anywhere. That is+what a dependency starts out as when it has not come up yet, and what one+becomes again when a departure of its is deliberately not acted on.++The 'TVar' is remembered alongside the number because the two are only+comparable together. An adopted machine's dependency is a /different+machine/ for the same node (a fresh 'Salmon.Op.Status.Status', counting from+zero), and comparing this node's memory of the old one against the new one's+epoch would read as a departure on every command @serve@ is handed —+restarting every service, which is the thing 'Kept' exists to prevent. A+dependency whose machine has been replaced is therefore re-armed, not acted+on. See 'crossing'.+-}+type Armed = Map Ref (TVar Status, Word64)++{- | A running set of node machines.++Only /tended/ nodes are in here. A node in the dag that this supervisor was+not asked to tend has no machine and no 'Status', and is not waited on by+anybody: nothing is going to move it, so waiting for it to move would be+waiting forever. That is the same call the one-shot drivers' 'UpDown.Gate'+makes when it answers 'UpDown.Skippable'.+-}+data Supervisor ext = Supervisor+    { supMachines :: !(Map Ref (Machine ext))+    , supHalt :: !(TVar Bool)+    , supWatch :: !(Maybe (Async ()))+    , supSay :: !(Report ext -> IO ())+    }++{- | Machines a stopped supervisor left running, for the next one to take+over.++A machine that holds a running process cannot be treated the way a one-shot+machine is. Stopping a supervisor stops /tending/ — and since @serve@ stands+its machines down before every command it is handed, a supervisor that wound+its processes down with it would kill every service on every @status@. So a+holding machine survives its supervisor, and the next 'startUpkeep' either+__adopts__ it (the effect it holds never stopped) or __releases__ it+(cancelled, which tears that effect down through the action's own bracket).++The choice between the two is what @specs\/per-node-state-machines.md@'s+§"@Ref@ is location-addressed" calls the one case where swapping a machine is+right: a node is adopted only if it is still wanted 'TurnUp' /and/ its+representative has not changed. A @managed@ node whose command line changed+but whose ref key did not is the same node with a different action, and the+process running is the old one's.+-}+newtype Kept ext = Kept (Map Ref (Machine ext))++-- | Nothing running: what a first supervisor is given.+noKept :: Kept ext+noKept = Kept Map.empty++-- | What each kept machine is holding up, for a caller deciding what to+-- release.+keptHeld :: Kept ext -> Map Ref (Act ext)+keptHeld (Kept ms) = fmap machineAct ms++{- | Cancel every kept machine whose 'Ref' the predicate rejects, and return+what is left.++Cancelling is the teardown: the machine's thread is inside a 'withAsync' over+the node's action, so the async exception unwinds through whatever bracket+that action is built from — for "Salmon.Builtin.Nodes.Daemon" that is+@SIGTERM@ to the process group, a grace period, then @SIGKILL@. 'cancel'+waits, so when this returns the effects really are down.++That waiting is the point of exposing this at all: a caller tearing a node+down has to be able to do it __before__ anything else in the graph moves. A+daemon's dependencies — its config file, its working directory — must not be+removed while it is still running, and nothing but ordering prevents that.+-}+releaseKept ::+    Reporter (Report ext) ->+    (Ref -> Bool) ->+    Kept ext ->+    IO (Kept ext)+releaseKept report keep (Kept ms) = do+    let (kept, going) = Map.partitionWithKey (\aref _ -> keep aref) ms+    forM_ (Map.elems going) $ \m -> do+        cancel (machineThread m)+        runReporter report (Released (machineAct m))+    pure (Kept kept)++-- | The live state of every node being tended.+supervisorStatuses :: Supervisor ext -> Map Ref (TVar Status)+supervisorStatuses = fmap machineStatus . supMachines++-- | The mailbox of every node being tended.+supervisorMailboxes :: Supervisor ext -> Map Ref Mailbox+supervisorMailboxes = fmap machineMailbox . supMachines++-- | Which nodes are being tended, and which way each.+supervisorTending :: Supervisor ext -> Map Ref Direction+supervisorTending = fmap machineDirection . supMachines++{- | Tell one node something. 'False' if the node has no machine here, or if+its mailbox was full and an older instruction had to be evicted to make room+(which the node reports when it reads it).+-}+instruct :: Supervisor ext -> Ref -> Instruction -> IO Bool+instruct sup aref instruction =+    case Map.lookup aref (supMachines sup) of+        Nothing -> pure False+        Just m -> Mailbox.post (machineMailbox m) instruction++-------------------------------------------------------------------------------++{- | Start tending every node the second argument names a direction for.++A node it returns 'Nothing' for is reported 'Untended' and left entirely+alone — no machine, no status, and nothing waits on it. A node on a cycle is+reported 'Salmon.Actions.UpDown.Blocked' and likewise never started, because+here it would wait forever rather than be noticed at the end of a pass.++Returns as soon as the machines are running. They run until 'stopUpkeep'.+-}+startUpkeep ::+    forall ext.+    ( HasField "up" ext (IO ())+    , HasField "down" ext (IO ())+    , HasField "managed" ext (Maybe ((Text -> IO ()) -> IO ExitCode))+    , HasField "check" ext (IO CheckResult)+    , HasField "ref" ext Ref+    , HasField "help" ext Text+    , HasField "notes" ext [Text]+    , HasField "dynamics" ext [Dynamic]+    ) =>+    Reporter (Report ext) ->+    -- | machines a previous supervisor left running; 'noKept' for a first one+    Kept ext ->+    -- | which nodes to tend, how+    (Ref -> Maybe Tend) ->+    Dag ext ->+    IO (Supervisor ext)+startUpkeep report (Kept prior) tend dag = do+    -- reports are serialised for the same reason the concurrent one-shot+    -- driver serialises them: the caller's reporter is not assumed+    -- thread-safe, and interleaved multi-line reports are unreadable.+    lock <- newMVar ()+    let say rep = withMVar lock (\() -> runReporter report rep)++    halt <- newTVarIO False+    failed <- newTVarIO (Set.empty :: Set Ref)++    forM_ untended $ \act -> say (Untended act)+    forM_ blocked $ \act -> say (Acted (UpDown.Blocked act))++    -- machines left running by the previous supervisor that this one is+    -- taking over rather than restarting. Everything else it left is+    -- released below, which tears down what it was holding.+    adopted <- fmap (Map.fromList . concat) $ forM tended $ \(aref, act, t) ->+        case Map.lookup aref prior of+            Just m+                | t.tendDirection == TurnUp+                , Dag.sameRepresentative (machineAct m) act -> do+                    alive <- poll (machineThread m)+                    case alive of+                        -- its thread finished while nobody was watching, so+                        -- there is nothing to take over.+                        Just _ -> pure []+                        Nothing -> do+                            say (Adopted act)+                            pure [(aref, m)]+            _ -> pure []+    -- everything not adopted is cancelled here, which tears down what it was+    -- holding. What comes back is therefore exactly the adopted set; anything+    -- else would be a machine stranded by a future change to 'releaseKept',+    -- and is reported rather than dropped on the floor.+    Kept leftovers <- releaseKept report (`Map.member` adopted) (Kept prior)+    forM_ (Map.toList leftovers) $ \(aref, m) ->+        unless (Map.member aref adopted) (say (Released (machineAct m)))++    let starting = [entry | entry@(aref, _, _) <- tended, not (Map.member aref adopted)]++    fresh <-+        Map.fromList+            <$> forM starting (\(aref, _, t) -> (,) aref <$> newStatus t.tendDirection)+    let statuses = fmap machineStatus adopted <> fresh++    let under aref =+            let ds = Dag.dependenciesOf dag aref+             in Under+                    { underStatuses = statuses+                    , underFailed = failed+                    , underHalt = halt+                    , underDependencies = ds+                    , underDependants = Dag.dependantsOf dag aref+                    , -- authored on the dependency, read by the dependant:+                      -- only the node that goes away knows whether its going+                      -- away matters to whatever is standing on it.+                      underDemoters =+                        [ d+                        | d <- ds+                        , Map.member d statuses+                        , Map.lookup d strategies == Just RestForOne+                        ]+                    }++    -- an adopted machine came from a supervisor whose maps are now nobody's:+    -- hand it this one's, or it would watch 'TVar's that never change again+    -- and record its failures where no dependant reads them.+    forM_ (Map.toList adopted) $ \(aref, m) ->+        atomically (writeTVar (machineUnder m) (under aref))++    machines <- forM starting $ \(aref, act, t) -> do+        let (policy, ignored) = supervisionOf act.extension+        unless (null ignored) $ say (Policy act policy ignored)+        box <- Mailbox.newMailbox Mailbox.defaultCapacity+        drops <- newTVarIO 0+        under' <- newTVarIO (under aref)+        let status = statuses Map.! aref+        let holds = isJust (getField @"managed" act.extension)+        let ctx =+                Ctx+                    { ctxSay = say+                    , ctxUnder = under'+                    , ctxRef = aref+                    , ctxAct = act+                    , ctxStatus = status+                    , ctxBox = box+                    , ctxDrops = drops+                    , ctxPolicy = policy+                    }+        -- A 'Settled' claim is about an effect that persists on its own, and+        -- a managed effect does not persist without a machine holding it. So+        -- a managed node that was not adopted starts from scratch whatever+        -- the caller believes about it: there is no process, so it is not up.+        let t' = if holds then t{tendStanding = Unsettled} else t+        thread <- async (restarting ctx t')+        pure+            ( aref+            , Machine+                { machineAct = act+                , machineDirection = t.tendDirection+                , machineStatus = status+                , machineMailbox = box+                , machineWatchdog = supWatchdog policy+                , machineHolds = holds+                , machineUnder = under'+                , machineThread = thread+                }+            )++    let table = adopted <> Map.fromList machines+    let ups = length [() | m <- Map.elems table, machineDirection m == TurnUp]+    say (Supervising ups (Map.size table - ups))++    watch <- startWatchdog say halt table++    pure+        Supervisor+            { supMachines = table+            , supHalt = halt+            , supWatch = watch+            , supSay = say+            }+  where+    -- a node on a cycle never becomes ready. One relation is enough to find+    -- one: the dependants relation is the dependencies relation reversed, so+    -- a cycle in either is a cycle in both.+    stuckRefs :: Set Ref+    stuckRefs = Dag.stuck Dag.dependenciesOf dag++    classified :: [(Ref, Act ext, Maybe Tend, Bool)]+    classified =+        [ (aref, act, tend aref, Set.member aref stuckRefs)+        | aref <- Dag.dagOrder dag+        , Just act <- [Dag.representativeOf dag aref]+        ]++    tended :: [(Ref, Act ext, Tend)]+    tended = [(aref, act, t) | (aref, act, Just t, False) <- classified]++    blocked :: [Act ext]+    blocked = [act | (_, act, Just _, True) <- classified]++    untended :: [Act ext]+    untended = [act | (_, act, Nothing, _) <- classified]++    -- what each tended node's own author said about the nodes standing on+    -- it; every dependant reads its dependencies' entries out of here.+    strategies :: Map Ref Strategy+    strategies =+        Map.fromList+            [ (aref, supStrategy (fst (supervisionOf act.extension)))+            | (aref, act, _) <- tended+            ]++{- | Ask every machine to stop, wait for it, and report how many stopped.++__Nothing is torn down.__ Stopping a supervisor stops /tending/ these nodes;+it does not run anybody's @down@. A node whose @up@ is in flight is waited+for rather than interrupted, because interrupting an @up@ halfway is how a+half-applied effect happens; a node that is merely napping stops at once.+-}+stopUpkeep :: Supervisor ext -> IO (Kept ext)+stopUpkeep sup = do+    atomically (writeTVar (supHalt sup) True)+    traverse_ waitCatch (supWatch sup)+    let (holding, oneShots) = Map.partition machineHolds (supMachines sup)+    forM_ (Map.elems oneShots) $ \m -> do+        outcome <- waitCatch (machineThread m)+        case outcome of+            Right () -> pure ()+            -- 'restarting' already restarts and reports a crashing machine+            -- in place, so this only fires for an asynchronous exception+            -- that reached the thread some other way than 'releaseKept'+            -- (which 'restarting' lets through rather than restarting) —+            -- reported here as a last resort rather than dropped silently.+            Left e -> supSay sup (Escaped (machineAct m) e)+    -- a holding machine ignores the halt flag by construction, so these are+    -- all still running — except one whose node never got past 'WaitUp' (it+    -- was holding nothing yet, so it heeded the halt like any other) or+    -- whose action gave up on its own. Those have nothing to hand over.+    kept <- flip Map.traverseMaybeWithKey holding $ \_ m -> do+        alive <- poll (machineThread m)+        pure (if isJust alive then Nothing else Just m)+    supSay sup (Retired (Map.size oneShots))+    unless (Map.null kept) $ supSay sup (Holding (Map.size kept))+    pure (Kept kept)++-- | 'startUpkeep' and 'stopUpkeep' as a bracket.+withUpkeep ::+    ( HasField "up" ext (IO ())+    , HasField "down" ext (IO ())+    , HasField "managed" ext (Maybe ((Text -> IO ()) -> IO ExitCode))+    , HasField "check" ext (IO CheckResult)+    , HasField "ref" ext Ref+    , HasField "help" ext Text+    , HasField "notes" ext [Text]+    , HasField "dynamics" ext [Dynamic]+    ) =>+    Reporter (Report ext) ->+    (Ref -> Maybe Tend) ->+    Dag ext ->+    (Supervisor ext -> IO a) ->+    IO a+withUpkeep report tend dag body =+    bracket (startUpkeep report noKept tend dag) release body+  where+    -- a bracket owns everything it started, holding machines included: the+    -- caller has nowhere to put a 'Kept'.+    release sup = do+        kept <- stopUpkeep sup+        _ <- releaseKept report (const False) kept+        pure ()++-------------------------------------------------------------------------------++-- | What one machine needs to do its job.+data Ctx ext = Ctx+    { ctxSay :: !(Report ext -> IO ())+    , ctxUnder :: !(TVar Under)+    -- ^ everything about this machine's surroundings, re-read on every wait+    -- rather than captured: an adopted machine's surroundings change under+    -- it. See 'Under'.+    , ctxRef :: !Ref+    , ctxAct :: !(Act ext)+    , ctxStatus :: !(TVar Status)+    , ctxBox :: !Mailbox+    , ctxDrops :: !(TVar Int)+    -- ^ evictions already reported, so a repeated read reports the+    -- difference rather than the running total.+    , ctxPolicy :: !Supervision+    }++{- | What 'upping' is to do about the node's own check before acting.++Two entries into 'Upping' and they want opposite things. Arriving from+'WaitUp' the check has not been asked yet and is the whole point: it is what+makes a re-declared graph cost nothing. Arriving from 'Up' — or from a+'Salmon.Op.Mailbox.Force' — it has just been asked and the answer is the+/reason/ we are here, so asking again would be both wasteful and wrong: a+'Salmon.Actions.UpDown.Completed' node that 'Salmon.Op.Supervision.Always'+says to run again would be talked out of it by its own check.+-}+data Intent+    = -- | ask the check; skip if it says the effect is already there+      Consult+    | -- | act, and this is why+      Regardless !CheckResult+    deriving (Show)++-- | Why a wait ended.+data Wake+    = -- | the delay expired, or the neighbours are ready+      Elapsed+    | -- | somebody said something; oldest first, never empty+      Told ![Instruction]+    | -- | the held action stopped, with its exit status (or the exception it+      -- threw instead of exiting). Only a machine holding a+      -- 'Salmon.Builtin.Extension.managed' action can see this.+      Ended !(Either SomeException ExitCode)+    | -- | a dependency that declared 'Salmon.Op.Supervision.RestForOne' has+      -- stopped being up. Only a machine in 'Up' with such a dependency can+      -- see this.+      Demote !Ref+    | -- | ...and one that had, is settled up again — this is its machine and+      -- the 'Salmon.Op.Status.statusEpoch' it is settled at, and it may+      -- demote this node next time it moves. See 'crossing' on why the two+      -- are a pair.+      Rearm !Ref !(TVar Status) !Word64+    | -- | the supervisor is stopping+      Halt++{- | Whether a wait is allowed to end because the supervisor is stopping.++A machine holding a running effect answers 'IgnoreHalt': stopping a+supervisor stops /tending/, and a machine that let go of its own process+every time a command was typed would kill every service on every @status@.+Such a machine is kept (see 'Kept') and is only ever taken by an outright+'cancel', which is also what tears its effect down.+-}+data Heed+    = HeedHalt+    | IgnoreHalt+    deriving (Show, Eq)++-------------------------------------------------------------------------------++{- | What the restart policy has to remember between attempts.++Two fields, and neither is derivable from the node's 'Status': that carries+what the node is doing now, while this carries how it has been getting on.+-}+data Tally = Tally+    { tallyFailures :: !Int+    -- ^ /consecutive/ failures, which is the only count a give-up limit can+    -- sensibly read.+    , tallyUpSince :: !(Maybe Word64)+    -- ^ monotonic nanoseconds at the moment the node last reached 'Up'.+    , tallyDemotedAt :: !(Maybe Word64)+    -- ^ monotonic nanoseconds at the moment a dependency last sent this node+    -- back to 'WaitUp'. What rate-limits 'Salmon.Op.Supervision.RestForOne'+    -- against 'Salmon.Op.Supervision.supDemoteEvery'; see 'tooSoon'.+    }++freshTally :: Tally+freshTally = Tally 0 Nothing Nothing++{- | Count a failure — first forgetting the ones before it, if the node had+been up long enough to count as working.++'Salmon.Op.Supervision.supStableAfter' is what makes a give-up limit usable+at all: without it, a service that falls over once a day reaches any finite+limit eventually and latches off, having never actually been in a crash+loop.+-}+countFailure :: Supervision -> Word64 -> Tally -> Tally+countFailure sup now t =+    case t.tallyUpSince of+        Just since+            | now >= since+            , now - since >= toNanos sup.supStableAfter ->+                t{tallyFailures = 1, tallyUpSince = Nothing}+        _ -> t{tallyFailures = t.tallyFailures + 1, tallyUpSince = Nothing}++-- | Has this node used up the author's patience?+exhausted :: Supervision -> Tally -> Bool+exhausted sup t = maybe False (\n -> t.tallyFailures >= n) sup.supGiveUpAfter++{- | Was this node sent back by a dependency so recently that doing it again+would be following a flap rather than a change?++Never having been demoted is never too soon: an isolated departure is+honoured whenever it comes. That is what keeps this a __rate limit rather+than a settling delay__ — a settling delay would swallow the very case+'Salmon.Op.Supervision.RestForOne' exists for, since the config file a+service stands on is rewritten in milliseconds and is back long before any+window could expire. What is dropped is the /second/ demotion inside the+node's own 'Salmon.Op.Supervision.supDemoteEvery', which is what a flap looks+like and a change does not.+-}+tooSoon :: Supervision -> Word64 -> Tally -> Bool+tooSoon sup now t =+    case t.tallyDemotedAt of+        Just at | now >= at -> now - at < toNanos sup.supDemoteEvery+        _ -> False++{- | How long to wait before the n-th consecutive retry: the floor doubled+@n-1@ times, capped.++Derived from the failure count rather than carried alongside it, so it resets+exactly when 'countFailure' resets the count, and cannot drift out of step+with it.+-}+backoff :: Int -> Delay+backoff n = iterate relaxed initialDelay !! min 24 (max 0 (n - 1))++{- | What a restart policy makes of an exit status.++The systemd reading, and the reason owning a process is worth the trouble:+'Salmon.Op.Supervision.OnFailure' is only expressible if something can tell+@exit 0@ from @exit 137@, which no @check@ can.+-}+restartsOnExit :: Restart -> ExitCode -> Bool+restartsOnExit Never _ = False+restartsOnExit OnFailure ExitSuccess = False+restartsOnExit OnFailure (ExitFailure _) = True+restartsOnExit Always _ = True++machine ::+    ( HasField "up" ext (IO ())+    , HasField "down" ext (IO ())+    , HasField "managed" ext (Maybe ((Text -> IO ()) -> IO ExitCode))+    , HasField "check" ext (IO CheckResult)+    , HasField "ref" ext Ref+    ) =>+    Tend ->+    Ctx ext ->+    IO ()+machine (Tend TurnUp standing) ctx = upkeep standing ctx+machine (Tend TurnDown standing) ctx = downkeep standing ctx++{- | What 'startUpkeep' actually runs: 'machine', restarted in place if it+throws. See the module header's "A machine that throws is restarted, not+lost" for why, and why 'SomeAsyncException' is the one thing this must let+through rather than treat as a crash.+-}+restarting ::+    ( HasField "up" ext (IO ())+    , HasField "down" ext (IO ())+    , HasField "managed" ext (Maybe ((Text -> IO ()) -> IO ExitCode))+    , HasField "check" ext (IO CheckResult)+    , HasField "ref" ext Ref+    ) =>+    Ctx ext ->+    Tend ->+    IO ()+restarting ctx t = do+    outcome <- try @SomeException (machine t ctx)+    case outcome of+        Right () -> pure ()+        Left e+            | Just (_ :: SomeAsyncException) <- fromException e -> throwIO e+            | otherwise -> do+                ctxSay ctx (Escaped (ctxAct ctx) e)+                u <- readTVarIO (ctxUnder ctx)+                halted <- readTVarIO (underHalt u)+                unless halted $ do+                    -- a fixed floor, not the adaptive ladder: this is a+                    -- bug in this module, not a node's own retry cadence,+                    -- and all it needs is enough of a pause that a bug+                    -- firing on every entry does not spin a core.+                    threadDelay (fromIntegral (unMicros delayFloor))+                    restarting ctx t{tendStanding = Unsettled}++-------------------------------------------------------------------------------++{- | The lifecycle of a node wanted up: @WaitUp -> Upping -> Up@, and back to+'Upping' whenever the node stops being up and its policy says to put it back.++Two shapes of node run through here and the difference is confined to one+step. A node with only @up@ /does/ something and returns, and 'Up' is a+periodic check on what it left behind. A node with a+'Salmon.Builtin.Extension.managed' action /is/ its effect for as long as the+action runs, so 'Up' additionally races the action itself: the exit it+eventually yields is the reason the node stopped being up, and is what the+restart policy reads instead of a 'CheckResult'.+-}+upkeep ::+    forall ext.+    ( HasField "up" ext (IO ())+    , HasField "managed" ext (Maybe ((Text -> IO ()) -> IO ExitCode))+    , HasField "check" ext (IO CheckResult)+    , HasField "ref" ext Ref+    ) =>+    Standing ->+    Ctx ext ->+    IO ()+upkeep standing ctx =+    case standing of+        Unsettled -> waitUp freshTally Consult []+        -- Already up: settle so dependants may go, and start watching. The+        -- verdict is 'Skipped' because that is exactly what it is — nobody+        -- looked, somebody said — and the first 'look' replaces it.+        --+        -- 'startUpkeep' never hands 'Settled' to a node with a managed+        -- action, because a 'Settled' claim is about an effect that persists+        -- on its own and a managed effect does not persist without the+        -- machine holding it.+        Settled -> do+            markOk ctx+            settle status Skipped+            say (Upkeep act Up)+            entering Skipped (relaxed initialDelay) freshTally+  where+    act = ctxAct ctx+    say = ctxSay ctx+    status = ctxStatus ctx+    policy = ctxPolicy ctx++    -- | The action, if this node owns one.+    holding :: Maybe ((Text -> IO ()) -> IO ExitCode)+    holding = getField @"managed" act.extension++    {- | Nothing to do until the dependencies are up. Instructions that arrive+    meanwhile are held rather than lost: a 'Force' typed at a node whose+    dependency is still coming up means "when you get there, act", not "act+    now against an unmet precondition".++    Carries the 'Tally' rather than starting a fresh one, because this is+    where a demoted node comes back to and the moment it was demoted is what+    stops a flapping dependency demoting it again immediately, and an+    'Intent' because what a node does when its dependencies arrive is not the+    same question as whether they have. -}+    waitUp :: Tally -> Intent -> [Instruction] -> IO ()+    waitUp tally intent pending = do+        say (Upkeep act WaitUp)+        loop pending+      where+        loop held = do+            w <- standby ctx TurnUp+            told <- announce ctx w+            case w of+                Halt -> pure ()+                Ended _ -> pure () -- nothing is running yet; unreachable+                -- 'standby' does not watch for these; a node that is not up+                -- has nothing to be demoted from.+                Demote _ -> loop held+                Rearm{} -> loop held+                Told _ -> paused ctx told (loop (held <> told)) (loop (held <> told))+                Elapsed -> attempt (held <> told) intent tally++    -- | Decide whether to act, then act in whichever way this node acts.+    attempt :: [Instruction] -> Intent -> Tally -> IO ()+    attempt told intent tally+        | Just Satisfy <- override told = satisfy+        | otherwise = do+            say (Upkeep act Upping)+            unsettle status TurnUp+            decided <- case (intent, told `has` Force) of+                (_, True) -> pure (Right (Failure "forced"))+                (Regardless why, _) -> pure (Right why)+                (Consult, _) -> do+                    verdict <- runCheck act+                    pure (if satisfiedBy verdict then Left verdict else Right verdict)+            case decided of+                Left verdict -> do+                    say (Acted (UpDown.Skip act))+                    reached verdict tally+                Right _ -> case holding of+                    Nothing -> oneShot tally+                    Just action -> hold action tally++    -- | An @up@ that returns, leaving something behind that persists.+    oneShot :: Tally -> IO ()+    oneShot tally = do+        say (Acted (UpDown.Eval act))+        note status "up"+        outcome <- try @SomeException act.extension.up+        case outcome of+            Right () -> do+                say (Acted (UpDown.Done act))+                reached Success tally+            Left e -> do+                say (Acted (UpDown.Failed act e))+                note status (Text.pack (show e))+                failed (Failure (Text.pack (show e))) tally++    {- | An action that /is/ the effect. 'withAsync' rather than 'async' is+    the whole of the teardown story: cancelling this machine's thread+    cancels the action, and whatever bracket the action is built from does+    the killing — see "Salmon.Builtin.Nodes.Daemon". The scope of the+    'withAsync' is one run of the effect; a restart leaves it and comes+    back through 'attempt'. -}+    hold :: ((Text -> IO ()) -> IO ExitCode) -> Tally -> IO ()+    hold action tally = do+        say (Acted (UpDown.Eval act))+        note status "spawn"+        -- 'watch' hands back what to do /once the action is no longer held/,+        -- and that continuation is run outside the 'withAsync' on purpose:+        -- leaving the block is what cancels the action, so a restart is+        -- guaranteed to have torn the old effect down before the new+        -- attempt spawns.+        next <- withAsync (action (\line -> note status line >> say (Output act line))) $ \running -> do+            -- Up as soon as it is running: for a node whose action is the+            -- effect, "the action is running" is the whole of being up. The+            -- report is 'Done' for the same reason, which is what lets+            -- @serve@ record such a node as converged at all.+            now <- getMonotonicTimeNSec+            markOk ctx+            settle status Success+            say (Acted (UpDown.Done act))+            say (Upkeep act Up)+            armed <- arming ctx+            watch running Success (relaxed initialDelay) tally{tallyUpSince = Just now} armed+        next++    {- | 'Up' with an action in hand: the nap, the mailbox, the action's own+    exit and any demoting dependency, raced. The check still runs on the+    adaptive delay, so a managed node that also supplies a @check@ gets both+    the health probe and the exit. One that does not answers 'Immaterial' and+    parks, which for /this/ machine costs nothing at all: the exit of the+    thing it holds is raced in the same transaction, so the timer was never+    the thing telling it anything. -}+    watch :: Async ExitCode -> CheckResult -> Delay -> Tally -> Armed -> IO (IO ())+    watch running verdict d tally armed = do+        -- 'supReapply' is read only by 'resting': a node holding a running+        -- action has an @up@ that throws by convention (see+        -- "Salmon.Builtin.Nodes.Daemon"), so re-running it on a schedule+        -- would crash-loop a service that is working fine. 'Reapply' and+        -- 'Park' therefore mean the same thing here.+        w <- case restOf policy verdict of+            Poll -> do+                say (NextLook act verdict (delayMicros d))+                naptimeHolding ctx running armed (delayMicros d)+            _ -> do+                say (Parked act)+                parkHolding ctx running armed+        told <- announce ctx w+        case w of+            -- 'naptimeHolding' answers 'IgnoreHalt', so this cannot happen:+            -- a machine holding a running effect is kept rather than wound+            -- down, and only a 'cancel' takes it.+            Halt -> watch running verdict d tally armed+            Ended outcome -> pure (afterExit outcome tally)+            Elapsed -> peek (relaxed d)+            Rearm dep var e -> watch running verdict d tally (Map.insert dep (var, e) armed)+            {- 'Regardless', and this is not a preference. Leaving this block+            cancels the action, so by the time the node comes back round its+            effect is /certainly/ gone — and a check that says otherwise is+            stale by construction, answering about a pidfile, a port+            something else is holding, or a log file that exists because the+            node ran earlier. 'Consult'ing it would settle the node into 'Up'+            holding nothing at all, which is the one outcome worse than not+            bouncing it.++            Note the discriminator is /this machine is holding the effect+            right now/, not "this node has a managed action": a node whose+            action forked and exited is watched from 'resting' as an unowned+            effect, and re-applying that one would start a second copy of+            something already running. -}+            Demote dep -> do+                sending <- demote dep (Regardless (Failure ("sent back by " <> unRef dep))) tally+                case sending of+                    -- handed back rather than run, like a restart and for+                    -- the same reason: it runs outside the 'withAsync', so+                    -- the process this node holds is torn down before it+                    -- goes back to waiting.+                    Just go -> pure go+                    Nothing -> watch running verdict d tally (Map.delete dep armed)+            Told _+                -- pausing a node that owns a process must not kill the+                -- process: that is the whole difference between 'Pause' and+                -- a teardown. So this parks while still holding.+                | Just Pause <- tending told -> do+                    say (Paused act)+                    heldPause+                    say (Resumed act)+                    watch running verdict d tally armed+                -- forcing a node that is already running its own effect+                -- means restart it: hand back the next attempt, which runs+                -- after the 'withAsync' has cancelled this one.+                | Just Force <- override told -> pure (attempt told (Regardless (Failure "forced")) tally)+                | Just Satisfy <- override told -> pure satisfy+                | otherwise -> peek (soonIf told d)+      where+        {- | Look while still holding. A check that says the effect is gone+        even though the action is still running is a health probe failing —+        the process is up and not working — and restarting is what the+        policy is for. -}+        peek :: Delay -> IO (IO ())+        peek d' = do+            v <- runCheck act+            touch status+            if restarts policy v+                then pure (attempt [] (Regardless v) tally)+                else watch running v d' tally armed++        -- | Block for a 'Resume'. Ignores the halt flag for the same reason+        -- the nap does.+        heldPause :: IO ()+        heldPause = do+            told <- listenHolding ctx+            _ <- announce ctx (Told told)+            case tending told of+                Just Resume -> pure ()+                _ -> heldPause++    {- | The action stopped. Consult the check /before/ the policy: a process+    that exits 0 because it daemonised is still up, and the check is the only+    thing that can say so. That one ordering handles the double-fork case for+    free — the one shape a process handle cannot speak to at all, since a+    handle to a process that has exited says nothing about the daemon it left+    behind. -}+    afterExit :: Either SomeException ExitCode -> Tally -> IO ()+    afterExit outcome tally = do+        case outcome of+            Left e -> do+                say (Acted (UpDown.Failed act e))+                note status (Text.pack (show e))+            Right code -> note status ("exited " <> Text.pack (show code))+        verdict <- runCheck act+        if satisfiedBy verdict+            then do+                -- it forked, or something else is holding the effect up. The+                -- node is now an unowned effect and is polled like one.+                settle status verdict+                entering verdict (relaxed initialDelay) tally+            else+                if wantsBack+                    then failed (why verdict) tally+                    else do+                        -- it stopped and the policy says leave it. Settled,+                        -- and 'statusCheck' says which kind of stopped.+                        let final = case outcome of+                                Right ExitSuccess -> Completed+                                _ -> why verdict+                        case final of+                            Completed -> markOk ctx+                            _ -> markFailed ctx+                        settle status final+                        say (NextLook act final (delayMicros (relaxed initialDelay)))+                        entering final (relaxed initialDelay) tally+      where+        wantsBack = case outcome of+            -- the action threw rather than exiting, so there is no code for+            -- the policy to read; anything but 'Never' tries again.+            Left _ -> policy.supRestart /= Never+            Right code -> restartsOnExit policy.supRestart code+        why verdict = case outcome of+            Left e -> Failure (Text.pack (show e))+            Right ExitSuccess -> case verdict of+                Failure _ -> verdict+                _ -> Failure "exited"+            Right code -> Failure (Text.pack ("exited " <> show code))++    -- | The effect is in place. Keep an eye on it.+    reached :: CheckResult -> Tally -> IO ()+    reached verdict tally = do+        now <- getMonotonicTimeNSec+        markOk ctx+        settle status verdict+        say (Upkeep act Up)+        entering verdict (relaxed initialDelay) tally{tallyUpSince = Just now}++    {- | Enter 'Up'.++    The demote watch starts /disarmed/ for every dependency that is not ready+    at this instant, and each arms itself the first time it is seen ready.+    Without that, a supervisor starting over a graph a pass has just+    converged would demote every opted-in node before its dependencies'+    machines had settled — undoing 'Standing' wholesale and re-running every+    @up@ in the cone, which under @serve@ is once per command typed. -}+    entering :: CheckResult -> Delay -> Tally -> IO ()+    entering verdict d tally = do+        armed <- arming ctx+        resting verdict d tally armed++    {- | 'Up' without an action to hold: sleep, look, and adapt — back off+    while the effect is there, tighten and go back to 'Upping' when it is+    not.++    A 'Reapply' node sleeps on the same ladder but wakes into 'reapply'+    rather than 'look' — see 'Salmon.Op.Supervision.supReapply'. -}+    resting :: CheckResult -> Delay -> Tally -> Armed -> IO ()+    resting verdict d tally armed = do+        let rest = restOf policy verdict+        w <- case rest of+            Poll -> do+                say (NextLook act verdict (delayMicros d))+                napWatching ctx armed (delayMicros d)+            Park -> do+                say (Parked act)+                parkWatching ctx armed+            Reapply -> do+                say (Reapplying act (delayMicros d))+                napWatching ctx armed (delayMicros d)+        told <- announce ctx w+        let onElapsed = case rest of+                Reapply -> reapply+                _ -> look+        case w of+            Halt -> pure ()+            Ended _ -> pure ()+            Rearm dep var e -> resting verdict d tally (Map.insert dep (var, e) armed)+            -- 'Consult': whatever this node's effect is, it is still there+            -- as far as this machine knows, so its own check is the+            -- authority on whether the demotion means any work. A demotion+            -- that turns out to be unnecessary then costs one check rather+            -- than one @up@.+            Demote dep -> do+                sending <- demote dep Consult tally+                case sending of+                    Just go -> go+                    Nothing -> resting verdict d tally (Map.delete dep armed)+            -- 'Pause' is read before 'Force'/'Satisfy', so a flush holding+            -- both contradictory things does the lesser: stop tending, and+            -- let the operator say what they meant.+            Told _ ->+                paused ctx told (resting verdict d tally armed) $+                    case override told of+                        Just Force -> attempt told (Regardless (Failure "forced")) tally+                        Just Satisfy -> satisfy+                        -- 'Recheck' on a 'Reapply' node means the same thing+                        -- it always meant — "do the thing you'd do sooner" —+                        -- which for this node is re-applying, not asking.+                        _ -> onElapsed (soonIf told d) tally armed+            Elapsed -> onElapsed d tally armed++    {- | 'resting' for a 'Reapply' node: re-run @up@ instead of asking, and+    fold the outcome back into the ordinary machinery rather than inventing+    a parallel one.++    On success this is exactly 'look' with the check hard-coded to+    'Immaterial' \/ satisfied — same ladder, same 'markOk', same return to+    'resting'. On failure it hands off to 'failed' precisely as 'oneShot'+    does, which is what gives a flaky @up@ the normal backoff and+    'Salmon.Op.Supervision.supGiveUpAfter' rather than a re-apply loop with+    its own opinion about retrying.++    Deliberately does __not__ go through 'unsettle' \/ 'entering': this node+    never stopped being up, from a dependant's point of view, so+    'Salmon.Op.Status.statusEpoch' must not move and a 'RestForOne' watcher+    must see nothing at all — see 'Salmon.Op.Supervision.supReapply'. A+    failing re-apply still reaches every dependant that needs to know,+    through 'markFailed' \/ the failed-set 'crossing' already reads, without+    needing the epoch to move.+    -}+    reapply :: Delay -> Tally -> Armed -> IO ()+    reapply d tally armed = do+        say (Acted (UpDown.Eval act))+        note status "reapply"+        outcome <- try @SomeException act.extension.up+        case outcome of+            Right () -> do+                markOk ctx+                say (Acted (UpDown.Done act))+                resting Immaterial (relaxed d) tally armed+            Left e -> do+                say (Acted (UpDown.Failed act e))+                note status (Text.pack (show e))+                failed (Failure (Text.pack (show e))) tally++    {- | A demoting dependency has moved. Either this node is going back to+    'WaitUp', or it was sent back too recently for a second departure to be a+    change rather than a flap.++    A departure that is not acted on leaves the dependency /disarmed/ rather+    than armed where it was — so that this node is not woken by the same+    departure again, and so that what it eventually re-arms at is where the+    dependency ended up rather than where it was before it moved. Both+    callers do that; only whether they run the result or hand it back+    differs. -}+    demote :: Ref -> Intent -> Tally -> IO (Maybe (IO ()))+    demote dep intent tally = do+        now <- getMonotonicTimeNSec+        pure $+            if tooSoon policy now tally+                then Nothing+                else Just (demoting dep now intent tally)++    {- | Going back to 'WaitUp', to be brought up again on top of whatever the+    dependency that sent this node back becomes.++    No 'markFailed': being demoted is not failing, and 'Transient' is already+    enough to hold this node's own dependants. That is also what carries the+    cascade — a dependant of /this/ node that opted in sees exactly what this+    node just saw. -}+    demoting :: Ref -> Word64 -> Intent -> Tally -> IO ()+    demoting dep now intent tally = do+        say (Demoted act dep)+        unsettle status TurnUp+        waitUp tally{tallyDemotedAt = Just now} intent []++    {- | Look, and either carry on resting or go back to 'Upping'. The policy+    is consulted before 'satisfiedBy' rather than after, which is the only+    way 'Salmon.Op.Supervision.Always' can act on a 'Completed' node — that+    verdict /is/ satisfied, and the whole of what @Always@ means is "run it+    again anyway". -}+    look :: Delay -> Tally -> Armed -> IO ()+    look d tally armed = do+        verdict <- runCheck act+        touch status+        if restarts policy verdict+            then attempt [] (Regardless verdict) tally+            else do+                -- either still up, or stopped being up with a policy that+                -- says leave it: settled either way, but 'statusCheck'+                -- carries which, and so does the report.+                --+                -- A node that has actually stopped being up counts as+                -- failing, so a dependant still in 'WaitUp' holds off rather+                -- than being brought up on top of it. Only an outright+                -- 'Failure' qualifies: marking 'Unknown' would strand the+                -- dependants of every node that has no check at all.+                case verdict of+                    Failure _ -> markFailed ctx+                    _ -> markOk ctx+                settle status verdict+                resting verdict (relaxed d) tally armed++    {- | The node did not get up, or stopped being up and is wanted back.+    Counts the failure, and either backs off and tries again or latches off. -}+    failed :: CheckResult -> Tally -> IO ()+    failed why tally = do+        now <- getMonotonicTimeNSec+        let tally' = countFailure policy now tally+        markFailed ctx+        settle status why+        if exhausted policy tally'+            then gaveUp why tally'+            else retryUp why (backoff tally'.tallyFailures) tally'++    -- | Wait out the backoff, then have another go.+    retryUp :: CheckResult -> Delay -> Tally -> IO ()+    retryUp why d tally = do+        say (NextLook act why (delayMicros d))+        w <- naptime ctx (delayMicros d)+        told <- announce ctx w+        case w of+            Halt -> pure ()+            Ended _ -> pure ()+            Demote _ -> retryUp why d tally+            Rearm{} -> retryUp why d tally+            Told _ ->+                paused ctx told (retryUp why d tally) $+                    case override told of+                        Just Satisfy -> satisfy+                        _ -> attempt told Consult tally+            Elapsed -> attempt told Consult tally++    {- | This many consecutive failures was the node author's limit, so stop+    trying and stay out of the way.++    Parked rather than exited, for two reasons: the node's dependants have to+    keep seeing it settled-and-failing, and an operator has to be able to+    change their mind. 'Force' or 'Recheck' starts it over with a clean+    tally. -}+    gaveUp :: CheckResult -> Tally -> IO ()+    gaveUp why tally = do+        say (GaveUp act tally.tallyFailures)+        loop+      where+        loop = do+            w <- atomically (halting HeedHalt ctx (listen ctx retry))+            told <- announce ctx w+            case w of+                Halt -> pure ()+                Ended _ -> pure ()+                Demote _ -> loop+                Rearm{} -> loop+                Elapsed -> loop+                Told _+                    | told `has` Force -> attempt told (Regardless why) freshTally+                    | told `has` Recheck -> attempt told Consult freshTally+                    | Just Satisfy <- override told -> satisfy+                    | otherwise -> loop++    {- | An operator said "treat this as done". Settled without acting, and+    still tended: the instruction satisfies this attempt, it does not stop+    the node being looked after. 'Salmon.Op.Mailbox.Pause' is the one that+    does that. -}+    satisfy :: IO ()+    satisfy = do+        say (Acted (UpDown.Skip act))+        markOk ctx+        settle status Skipped+        say (Upkeep act Up)+        entering Skipped (Delay delayCap) freshTally++{- | @WaitDown -> Downing -> Down@. 'Down' is terminal: nothing in the model+answers "is it still gone", so there is nothing to poll for.+-}+downkeep ::+    forall ext.+    ( HasField "down" ext (IO ())+    , HasField "ref" ext Ref+    ) =>+    Standing ->+    Ctx ext ->+    IO ()+downkeep standing ctx =+    case standing of+        Unsettled -> waitDown+        -- already down. 'Down' is terminal, so this machine is done before+        -- it starts; it settles only so that its dependencies may go too.+        Settled -> finished Skipped+  where+    act = ctxAct ctx+    say = ctxSay ctx+    status = ctxStatus ctx++    waitDown :: IO ()+    waitDown = do+        say (Downkeep act WaitDown)+        loop+      where+        loop = do+            w <- standby ctx TurnDown+            told <- announce ctx w+            case w of+                Halt -> pure ()+                Ended _ -> pure ()+                -- a node coming down is not up, so nothing can demote it.+                Demote _ -> loop+                Rearm{} -> loop+                Told _ ->+                    paused ctx told loop $+                        case override told of+                            Just Satisfy -> finished Skipped+                            _ -> loop+                Elapsed -> downing initialDelay++    downing :: Delay -> IO ()+    downing d = do+        say (Downkeep act Downing)+        unsettle status TurnDown+        say (Acted (UpDown.Eval act))+        note status "down"+        outcome <- try @SomeException act.extension.down+        case outcome of+            Right () -> do+                say (Acted (UpDown.Done act))+                finished Success+            Left e -> do+                let why = Failure (Text.pack (show e))+                say (Acted (UpDown.Failed act e))+                note status (Text.pack (show e))+                markFailed ctx+                settle status why+                retryDown why (relaxed d)++    retryDown :: CheckResult -> Delay -> IO ()+    retryDown why d = do+        say (NextLook act why (delayMicros d))+        w <- naptime ctx (delayMicros d)+        told <- announce ctx w+        case w of+            Halt -> pure ()+            Ended _ -> pure ()+            Demote _ -> retryDown why d+            Rearm{} -> retryDown why d+            Told _ ->+                paused ctx told (retryDown why d) $+                    case override told of+                        Just Satisfy -> finished Skipped+                        _ -> downing (soonIf told d)+            Elapsed -> downing d++    -- | Off the machine. The node's dependencies may now go down too.+    finished :: CheckResult -> IO ()+    finished verdict = do+        markOk ctx+        settle status verdict+        say (Downkeep act Down)++-------------------------------------------------------------------------------++{- | Block until the neighbours in the given direction have settled /and/+none of them is currently failing — or until an instruction arrives, or the+supervisor stops.++Waiting out a neighbour's failure rather than reporting+'Salmon.Actions.UpDown.Blocked' is the sharpest difference between this+driver and the one-shot ones; see the module header. Under nobody is+tending are not waited on at all.+-}+standby :: Ctx ext -> Direction -> IO Wake+standby ctx dir =+    atomically $+        halting HeedHalt ctx $+            listen ctx $ do+                u <- readTVar (ctxUnder ctx)+                let neighbours = case dir of+                        TurnUp -> underDependencies u+                        TurnDown -> underDependants u+                let watched = [n | n <- neighbours, Map.member n (underStatuses u)]+                waitStability dir Stable (mapMaybe (`Map.lookup` underStatuses u) watched)+                broken <- readTVar (underFailed u)+                if any (`Set.member` broken) watched then retry else pure Elapsed++{- | Sleep, unless an instruction arrives or the supervisor stops — so an+instruction is never queued behind a 60s nap.+-}+naptime :: Ctx ext -> Micros -> IO Wake+naptime ctx d = do+    timer <- registerDelay (unMicros d)+    atomically $+        halting HeedHalt ctx $+            listen ctx $ do+                over <- readTVar timer+                if over then pure Elapsed else retry++{- | 'naptime' for a node in 'Up': the nap and the mailbox as before, plus+any dependency that opted into demoting this node.+-}+napWatching :: Ctx ext -> Armed -> Micros -> IO Wake+napWatching ctx armed d = do+    timer <- registerDelay (unMicros d)+    atomically $+        halting HeedHalt ctx $+            crossing ctx armed $+                listen ctx $ do+                    over <- readTVar timer+                    if over then pure Elapsed else retry++{- | 'napWatching' with no timer at all, for a node whose check answered+'Salmon.Actions.UpDown.Immaterial' — see 'Rest'. Everything else it waits on+is unchanged, so the node still hears an instruction, a demoting dependency+and the supervisor standing down; there is simply no 'Elapsed' to be had.+-}+parkWatching :: Ctx ext -> Armed -> IO Wake+parkWatching ctx armed =+    atomically $+        halting HeedHalt ctx $+            crossing ctx armed $+                listen ctx retry++{- | 'napWatching' for a machine holding a running action: plus the action's+own exit, and no 'Halt'.++Five things raced in one transaction, which is the shape §"Ordering is STM"+promised and the reason nothing here needs a scheduler: the exit wins as soon+as it happens, rather than being noticed at the end of a delay that may be a+minute long.+-}+naptimeHolding :: Ctx ext -> Async ExitCode -> Armed -> Micros -> IO Wake+naptimeHolding ctx running armed d = do+    timer <- registerDelay (unMicros d)+    atomically $+        halting IgnoreHalt ctx $+            crossing ctx armed $+                ended running $+                    listen ctx $ do+                        over <- readTVar timer+                        if over then pure Elapsed else retry++{- | 'parkWatching' for a machine holding a running action. The one place+parking costs nothing at all to reason about: the exit of the thing this+node holds is raced in the same transaction, so dropping the timer removes+the only wake-up that was never going to tell anybody anything.+-}+parkHolding :: Ctx ext -> Async ExitCode -> Armed -> IO Wake+parkHolding ctx running armed =+    atomically $+        halting IgnoreHalt ctx $+            crossing ctx armed $+                ended running $+                    listen ctx retry++-- | Block until somebody says something. For a holding machine, which has no+-- other reason to stop waiting.+listenHolding :: Ctx ext -> IO [Instruction]+listenHolding ctx = do+    w <- atomically (listen ctx retry)+    case w of+        Told told -> pure told+        _ -> listenHolding ctx++{- | 'Halt' wins over everything, for a machine that is allowed to hear it: a+stopping supervisor is not negotiable. A machine holding a running effect is+not allowed to hear it — see 'Heed'.+-}+halting :: Heed -> Ctx ext -> STM Wake -> STM Wake+halting IgnoreHalt _ k = k+halting HeedHalt ctx k = do+    u <- readTVar (ctxUnder ctx)+    stop <- readTVar (underHalt u)+    if stop then pure Halt else k++-- | The held action stopping pre-empts the nap, though not an instruction+-- already waiting.+ended :: Async ExitCode -> STM Wake -> STM Wake+ended running k = k `orElse` (Ended <$> waitCatchSTM running)++{- | Wake when a dependency that declared 'Salmon.Op.Supervision.RestForOne'+crosses the line between ready and not.++__Skipped entirely for a node with no such dependency__, which is every node+until somebody opts one in. That is not an optimisation but the reason this+feature is affordable at all: the alternative — every node in a supervised+graph holding a live subscription to all of its dependencies' statuses — is+the thundering herd @specs\/per-node-state-machines.md@ warned about, and+here it simply does not exist.++The @quiet@ set is what turns level-triggered STM into edge detection. A+dependency that has already been handed over is not looked at again until it+is ready, at which point it comes back as 'Rearm'; without that, a node that+declined a demotion would be re-woken by the same unready dependency+immediately, forever. It is also how a node that has just entered 'Up' avoids+demoting itself over a dependency that has not come up yet — see 'disarmed'.+-}+crossing :: Ctx ext -> Armed -> STM Wake -> STM Wake+crossing ctx armed k = do+    u <- readTVar (ctxUnder ctx)+    case underDemoters u of+        [] -> k+        demoters -> k `orElse` edge u demoters+  where+    edge u demoters = do+        broken <- readTVar (underFailed u)+        crossings <- traverse (look u broken) demoters+        case catMaybes crossings of+            [] -> retry+            (w : _) -> pure w++    look u broken dep =+        -- a neighbour nobody is tending is never going to move, so it is+        -- never going to leave 'Up' either.+        case Map.lookup dep (underStatuses u) of+            Nothing -> pure Nothing+            Just var -> do+                now <- readyNow var broken dep+                pure $ case Map.lookup dep armed of+                    -- armed against a different machine: this node's+                    -- supervisor was replaced under it, so there is nothing+                    -- to compare and it re-arms rather than reacting.+                    Just (v, _) | v /= var -> Rearm dep var <$> now+                    -- armed, and exactly where it was left: nothing happened.+                    Just (_, was) | now == Just was -> Nothing+                    -- armed, and either moved since or currently failing.+                    Just _ -> Just (Demote dep)+                    -- not armed, and settled up: arm it where it is now.+                    Nothing -> Rearm dep var <$> now++{- | Where a neighbour is, if it is settled up and not currently failing —+the condition 'standby' blocks on, asked about one node, and answered with+the 'Salmon.Op.Status.statusEpoch' that says /which/ time it is settled.++That number rather than a 'Bool' is what makes a departure impossible to+miss. A dependency that fell over and recovered between two of this node's+waits is 'Stable' at both of them, and STM keeps no queue of what happened in+between — the epoch is the only thing left that remembers.+-}+readyNow :: TVar Status -> Set Ref -> Ref -> STM (Maybe Word64)+readyNow var broken dep = do+    st <- readTVar var+    pure $+        if st.statusStability == Stable+            && st.statusDirection == TurnUp+            && not (Set.member dep broken)+            then Just st.statusEpoch+            else Nothing++{- | Which of this node's demoting dependencies are ready at this instant,+and where each of them is — the ones that are not are left out, and so cannot+demote this node until they have been seen up at least once.++Taken afresh on every entry into 'Up' rather than remembered, because the two+places that matter are exactly the ones where this machine has not been+watching: a supervisor that has just started, and a node that has just been+put back.+-}+arming :: Ctx ext -> IO Armed+arming ctx =+    atomically $ do+        u <- readTVar (ctxUnder ctx)+        case underDemoters u of+            [] -> pure Map.empty+            demoters -> do+                broken <- readTVar (underFailed u)+                entries <- traverse (entry u broken) demoters+                pure (Map.fromList (catMaybes entries))+  where+    entry u broken dep =+        case Map.lookup dep (underStatuses u) of+            Nothing -> pure Nothing+            Just var -> fmap (\e -> (dep, (var, e))) <$> readyNow var broken dep++-- | Anything pending in the mailbox pre-empts whatever else this wait was for.+listen :: Ctx ext -> STM Wake -> STM Wake+listen ctx k = do+    told <- Mailbox.takeAll (ctxBox ctx)+    if null told then k else pure (Told told)++{- | Report what was said (and what was dropped to make room for it), and+hand it back. @[]@ for any wake that was not an instruction.+-}+announce :: Ctx ext -> Wake -> IO [Instruction]+announce _ Halt = pure []+announce _ Elapsed = pure []+announce _ (Ended _) = pure []+announce _ (Demote _) = pure []+announce _ (Rearm _ _ _) = pure []+announce ctx (Told told) = do+    total <- Mailbox.dropped (ctxBox ctx)+    fresh <- atomically $ do+        seen <- readTVar (ctxDrops ctx)+        writeTVar (ctxDrops ctx) total+        pure (total - seen)+    unless (fresh == 0) $ ctxSay ctx (Acted (UpDown.DroppedInstructions (ctxAct ctx) fresh))+    forM_ told $ \i -> ctxSay ctx (Acted (UpDown.Instructed (ctxAct ctx) i))+    pure told++{- | If the last thing said was 'Pause', stop tending until a 'Resume'+arrives (or until the supervisor stops) and then take @onResume@; otherwise+take @onwards@ immediately.++Pausing leaves the node's effect and its 'Status' exactly as they are: a+paused node still looks settled to its neighbours, which is the point —+pausing is about whether /we/ keep tending it, not about whether it is up.+Everything else in the mailbox still applies; only 'Pause' and 'Resume' are+read here.+-}+paused :: Ctx ext -> [Instruction] -> IO () -> IO () -> IO ()+paused ctx told onResume onwards =+    case tending told of+        Just Pause -> do+            ctxSay ctx (Paused (ctxAct ctx))+            hold+        _ -> onwards+  where+    hold = do+        w <- atomically (halting HeedHalt ctx (listen ctx retry))+        case w of+            Halt -> pure ()+            Ended _ -> pure ()+            Demote _ -> hold+            Rearm{} -> hold+            Elapsed -> hold+            Told ts -> do+                _ <- announce ctx (Told ts)+                case tending ts of+                    Just Resume -> do+                        ctxSay ctx (Resumed (ctxAct ctx))+                        onResume+                    _ -> hold++-- | The last 'Pause'/'Resume' said, if either was.+tending :: [Instruction] -> Maybe Instruction+tending told = case [t | t <- told, t == Pause || t == Resume] of+    [] -> Nothing+    xs -> Just (last xs)++-- | The last 'Force' or 'Satisfy' said, if either was: later supersedes+-- earlier, these being statements of current intent.+override :: [Instruction] -> Maybe Instruction+override told = case [t | t <- told, t == Force || t == Satisfy] of+    [] -> Nothing+    xs -> Just (last xs)++has :: [Instruction] -> Instruction -> Bool+has told i = i `elem` told++-- | 'Recheck' means "look now": the delay collapses to its floor.+soonIf :: [Instruction] -> Delay -> Delay+soonIf told d = if told `has` Recheck then initialDelay else d++{- | What a node in 'Up' does between looks: wake on a timer, or not at all.++'Salmon.Actions.UpDown.Immaterial' is a node author saying that asking what+state their effect is in costs about what putting it back would, so they did+not write a check. There is then no cheaper question to put on a timer, and+a machine that keeps waking to ask it learns nothing each time — which, since+that verdict is the /default/, is what the delay ladder was doing for the+great majority of the nodes in this tree.++A parked node is not an unwatched one. It still comes back for everything+that is an actual event: an operator's 'Salmon.Op.Mailbox.Instruction', a+'Salmon.Op.Supervision.RestForOne' dependency going away, its own action+exiting, the supervisor standing down. It has only stopped asking a question+nobody wrote an answer to.++Two consequences worth knowing. A parked node is __never reported+'Wedged'__, and that needs no code: 'Salmon.Op.Status.wedged' asks about a+node that has not settled, and a parked one has. And it is __never+restarted by its own check__, because there is no check — which is the same+statement as "this node has no way to notice its effect going away", true+of it before and after, and the reason a node whose effect can vanish+should write one.++A node may say otherwise: 'Salmon.Op.Supervision.supReapply' opts a node+whose check answers 'Immaterial' out of parking and into __re-applying on+the loop instead of asking__. The ladder's meaning inverts for such a node —+it is now a rate limit on how often @up@ is re-run rather than on how often+a check is consulted — but it is the same ladder, doubling toward the cap+while nothing throws. See 'Salmon.Op.Supervision.supReapply' for why this+is opt-in and narrow (safe only for an @up@ that is genuinely cheap /and/+genuinely idempotent) and ignored for a node that holds a running action+(see 'watch' above, which reads only whether this is 'Poll' or not).+-}+data Rest+    = Poll+    | Park+    | Reapply+    deriving (Show, Eq)++restOf :: Supervision -> CheckResult -> Rest+restOf sup Immaterial = if supReapply sup then Reapply else Park+restOf _ _ = Poll++-- | 'Success', 'Skipped' and 'Completed' all mean "the effect is in place";+-- see 'Salmon.Op.Supervision.Restart' on why 'Unknown' is in neither camp.+satisfiedBy :: CheckResult -> Bool+satisfiedBy Success = True+satisfiedBy Skipped = True+satisfiedBy Completed = True+satisfiedBy (Failure _) = False+satisfiedBy Unknown = False+-- an author who declined to write a check has said nothing about whether+-- the effect is there, so this is 'up''s business, not a claim it is done.+satisfiedBy Immaterial = False++-- | Does this policy put the node back, given what the check said?+restarts :: Supervision -> CheckResult -> Bool+restarts sup verdict =+    case (supRestart sup, verdict) of+        (Never, _) -> False+        (_, Failure _) -> True+        (Always, Completed) -> True+        _ -> False++markFailed :: Ctx ext -> IO ()+markFailed ctx = onFailures ctx (Set.insert (ctxRef ctx))++markOk :: Ctx ext -> IO ()+markOk ctx = onFailures ctx (Set.delete (ctxRef ctx))++-- | Through 'ctxUnder' rather than a captured 'TVar', so that an adopted+-- machine records what it is doing where its /current/ supervisor's+-- dependants read it.+onFailures :: Ctx ext -> (Set Ref -> Set Ref) -> IO ()+onFailures ctx f =+    atomically $ do+        u <- readTVar (ctxUnder ctx)+        modifyTVar' (underFailed u) f++-------------------------------------------------------------------------------++{- | One thread watching every node that declared a watchdog. Not started at+all when none did, which is the common case.++It scans rather than being woken, because "nothing has happened for N+seconds" is exactly the event no node can report about itself. A node is+reported 'Wedged' once per episode and 'Unwedged' when it moves again.++Reporting is all it does. Killing a wedged @up@ needs the+teardown-through-a-bracket that owning the process buys, which is the next+milestone; until then the operator is the one who decides.+-}+startWatchdog ::+    (Report ext -> IO ()) ->+    TVar Bool ->+    Map Ref (Machine ext) ->+    IO (Maybe (Async ()))+startWatchdog say halt machines+    | null watched = pure Nothing+    | otherwise = Just <$> async (loop Set.empty)+  where+    watched =+        [ (aref, m, w)+        | (aref, m) <- Map.toList machines+        , Just w <- [machineWatchdog m]+        ]++    -- often enough to notice promptly, rarely enough to cost nothing: half+    -- the shortest declared watchdog, clamped to [250ms, 5s].+    tick :: Micros+    tick =+        Micros+            . max (unMicros (millis 250))+            . min (unMicros (seconds 5))+            . (`div` 2)+            . minimum+            $ [unMicros w | (_, _, w) <- watched]++    loop :: Set Ref -> IO ()+    loop reported = do+        timer <- registerDelay (unMicros tick)+        stop <- atomically $ do+            halted <- readTVar halt+            if halted+                then pure True+                else do+                    over <- readTVar timer+                    if over then pure False else retry+        unless stop $ do+            now <- getMonotonicTimeNSec+            loop =<< sweep now reported++    sweep :: Word64 -> Set Ref -> IO (Set Ref)+    sweep now = go watched+      where+        go [] acc = pure acc+        go ((aref, m, w) : rest) acc = do+            st <- readTVarIO (machineStatus m)+            let bad = wedged now (Just (toNanos w)) st+            let was = Set.member aref acc+            acc' <- case (bad, was) of+                (True, False) -> do+                    say (Wedged (machineAct m) (silentFor now st))+                    pure (Set.insert aref acc)+                (False, True) -> do+                    say (Unwedged (machineAct m))+                    pure (Set.delete aref acc)+                _ -> pure acc+            go rest acc'++    silentFor :: Word64 -> Status -> Micros+    silentFor now st = Micros (fromIntegral ((now - statusLastActive st) `div` 1000))
+ src/Salmon/Builtin/CommandLine.hs view
@@ -0,0 +1,1134 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}++module Salmon.Builtin.CommandLine where++import Control.Concurrent.MVar (newEmptyMVar, putMVar)+import Control.Applicative ((<|>))+import Control.Monad (forM, forM_, void, when)+import Data.Foldable (traverse_)+import Control.Monad.Identity+import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode)+import qualified Data.ByteString.Lazy as LBysteString+import Data.Maybe (fromJust, fromMaybe, isJust)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Either (rights)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Options.Applicative+import qualified Options.Applicative+import Options.Generic+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr, stdin, stdout)++import Salmon.Op.Actions (Act (..))+import qualified Salmon.Op.Concurrency as Concurrency+import Salmon.Op.Configure+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Ref (Ref)+import Salmon.Op.Rewrite (Phase (..), Rewrite, Rewritten)+import qualified Salmon.Op.Rewrite as Rewrite+import Salmon.Op.Eval+import Salmon.Op.OpGraph+import Salmon.Op.Track++import Salmon.Actions.Dot as Dot+import qualified Salmon.Actions.Follow as Follow+import qualified Salmon.Actions.Follow.Registry as Registry+import qualified Salmon.Actions.Follow.Registry.Http as Registry.Http+import qualified Salmon.Actions.Follow.Scheduler as Scheduler+import qualified Salmon.Actions.Follow.Signature as Signature+import Salmon.Actions.Help as Help+import qualified Salmon.Actions.Query as Query+import qualified Salmon.Actions.Serve as Serve+import qualified Salmon.Actions.Serve.Events as Events+import qualified Salmon.Actions.Serve.Http as Http+import qualified Salmon.Actions.Serve.Socket as Socket+import qualified Salmon.Actions.Serve.StatusSink as StatusSink+-- 'CheckResult' constructors are hidden: 'Success'/'Failure' collide with+-- optparse-applicative's 'ParserResult' ones, which this module pattern+-- matches on. Nothing here needs a 'CheckResult'.+import Salmon.Actions.UpDown as UpDown hiding (Failure, Success)+import Salmon.Builtin.Extension+import qualified Salmon.Op.Window as Window+import Salmon.Reporter+import qualified Salmon.Reporter.Tagged as Tagged++data Command seed+    = Config seed+    | Query QueryCommand+    | Run RunCommand+    deriving (Eq, Ord, Generic, Show)++-- | Kept for the JSON/remote-call contract in "Salmon.Builtin.Nodes.Self"+-- ('CLI.RemoteCall'/'argForBaseCommand') — a self-call is always a plain+-- 'Up' today, never plan-aware, so this never needs a plan file field.+data BaseCommand+    = Up+    | Down+    | Tree+    | DAG+    | Serve+    deriving (Eq, Ord, Generic, Show, Read)++argForBaseCommand :: BaseCommand -> Text+argForBaseCommand = \case+    Up -> "up"+    Down -> "down"+    Tree -> "tree"+    DAG -> "dag"+    Serve -> "serve"++-- | The @run@ subcommand's own subcommands. Parsed by hand (rather than via+-- 'Options.Generic''s derived 'ParseRecord', which 'BaseCommand' still uses+-- for its own, unrelated JSON contract) so that @up@ can carry an optional+-- @--plan@/@--force-stale-plan@ pair.+data RunCommand+    = -- | @run up@, optionally honoring a @query plan@-emitted 'Query.Plan' file.+      -- The windows (@--maintenance-window@) outside which 'Window.disruptive'+      -- nodes are held, and whether to ignore them (@--override-window@).+      RunUp !(Maybe FilePath) !Bool !ReportFormat ![Text] !Bool+    | RunDown !ReportFormat+    | RunTree+    | RunDAG+    | -- | @run serve@, optionally capping how many nodes converge at once+      -- per pass (R6 in @specs/per-node-state-machines-remaining.md@;+      -- 'Nothing' is unbounded, matching every version of @serve@ before+      -- this flag existed), and optionally starting with @autoconverge@ off+      -- (@--no-autoconverge@; 'False' is the default, matching every+      -- version of @serve@ before the setting existed). Then pull mode+      -- ("Salmon.Actions.Follow"): a registry to follow (@--follow+      -- REGISTRY@, a directory, @git+URL@, an HTTP URL, @dns:ZONE@ or a+      -- bucket — see "Salmon.Actions.Follow.Registry"), the labels to+      -- fetch from it (@--label L@,+      -- repeatable; both or neither), and the fetcher's schedule+      -- ('FollowOptions'). Last, optionally listening for the same+      -- line protocol on a unix socket (@--listen PATH@, milestone 2 of+      -- @specs/generic-server.md@; see "Salmon.Actions.Serve.Socket"),+      -- stdin still read beside it, and for HTTP on a second unix socket+      -- (@--http PATH@, milestone 3; see "Salmon.Actions.Serve.Http").+      -- Last, the status sink ('SinkOptions', milestone 5 of+      -- @specs/pull-mode.md@; see "Salmon.Actions.Serve.StatusSink").+      -- The HTTP server's event stream keeps @--events-ring N@ events for a+      -- client to resume from (milestone 4; see "Salmon.Actions.Serve.Events").+      -- Last of all, the same HTTP over the network ('TcpOptions', milestone+      -- 8): @--http-tcp HOST:PORT@ with @--tls-cert@, @--tls-key@ and+      -- @--token-file@, all three or nothing.+      RunServe !(Maybe Int) !Bool !ReportFormat !(Maybe FilePath) ![Text] !FollowOptions !(Maybe FilePath) !(Maybe FilePath) !Int !SinkOptions !TcpOptions+    deriving (Eq, Ord, Generic, Show)++{- | The four flags that put the HTTP surface on a network, as typed. What+they mean together is 'validateTcpOptions': there is no way to spell a+plaintext listener, and the only accepted shapes are none of them or all of+them.+-}+data TcpOptions = TcpOptions+    { tcpBind :: !(Maybe String)+    -- ^ @--http-tcp HOST:PORT@+    , tcpCert :: !(Maybe FilePath)+    -- ^ @--tls-cert FILE@+    , tcpKey :: !(Maybe FilePath)+    -- ^ @--tls-key FILE@+    , tcpTokenFile :: !(Maybe FilePath)+    -- ^ @--token-file FILE@+    , tcpSessionLifetime :: !(Maybe Double)+    -- ^ @--session-lifetime SECONDS@, @0@ for none+    , tcpSessionIdle :: !(Maybe Double)+    -- ^ @--session-idle SECONDS@, @0@ for none+    }+    deriving (Eq, Ord, Generic, Show)++instance FromJSON TcpOptions+instance ToJSON TcpOptions++-- | No network listener at all: the default.+noTcp :: TcpOptions+noTcp = TcpOptions Nothing Nothing Nothing Nothing Nothing Nothing++-- | A validated 'TcpOptions': where to listen and the three files, all present.+data TcpListen = TcpListen+    { tcpHost :: !String+    , tcpPort :: !Int+    , tcpCertFile :: !FilePath+    , tcpKeyFile :: !FilePath+    , tcpTokenPath :: !FilePath+    , tcpSessionPolicy :: !Http.SessionPolicy+    -- ^ 'Http.defaultSessionPolicy' with whatever @--session-*@ said+    }+    deriving (Eq, Show)++{- | The loud default, as a pure function so it can be tested without a+process: 'Nothing' when none of the four is given; a 'TcpListen' when all+four are and the address parses; otherwise the message the binary exits+with, naming every flag that is missing — so an operator who typed+@--http-tcp@ alone is told about all three at once rather than one per+attempt — or, for @--tls-cert@\/@--tls-key@\/@--token-file@ without+@--http-tcp@, that they do nothing on their own. @HOST@ is never implied:+@:8443@ is refused, since listening on every address is exactly the thing+that should have to be spelled out (@0.0.0.0:8443@ does it). An IPv6 address+is written in brackets, @[::1]:8443@. @--session-lifetime@\/@--session-idle@+are the browser sign-in's limits ('Http.SessionPolicy'), @0@ turning one+off, a negative one refused, and like the files they do nothing without+@--http-tcp@.+-}+validateTcpOptions :: TcpOptions -> Either Text (Maybe TcpListen)+validateTcpOptions opts =+    case opts.tcpBind of+        Nothing+            | null given -> Right Nothing+            | otherwise -> Left (Text.intercalate ", " given <> " need --http-tcp HOST:PORT to apply to; there is no network listener without it")+        Just hostPort ->+            case missing of+                [] -> do+                    (host, port) <- parseHostPort hostPort+                    lifetime <- limit "--session-lifetime" opts.tcpSessionLifetime Http.defaultSessionPolicy.sessionLifetime+                    idle <- limit "--session-idle" opts.tcpSessionIdle Http.defaultSessionPolicy.sessionIdle+                    Right (Just (TcpListen host port (fromJust opts.tcpCert) (fromJust opts.tcpKey) (fromJust opts.tcpTokenFile) (Http.SessionPolicy lifetime idle)))+                _ ->+                    Left+                        ( "--http-tcp needs "+                            <> Text.intercalate ", " missing+                            <> ": a salmon server never listens on a network without TLS and a token"+                        )+  where+    named =+        [ ("--tls-cert", opts.tcpCert)+        , ("--tls-key", opts.tcpKey)+        , ("--token-file", opts.tcpTokenFile)+        ]+    given =+        [flag | (flag, Just _) <- named]+            ++ [flag | (flag, True) <- [("--session-lifetime", isJust opts.tcpSessionLifetime), ("--session-idle", isJust opts.tcpSessionIdle)]]+    missing = [flag | (flag, Nothing) <- named]+    limit :: Text -> Maybe Double -> Maybe Double -> Either Text (Maybe Double)+    limit flag typed dflt =+        case typed of+            Nothing -> Right dflt+            Just 0 -> Right Nothing+            Just n+                | n > 0 -> Right (Just n)+                | otherwise -> Left (flag <> ": not a number of seconds: " <> Text.pack (show n) <> " (0 turns it off)")++-- | @HOST:PORT@, with @[v6]:PORT@ for an IPv6 address; the port is 0..65535.+parseHostPort :: String -> Either Text (String, Int)+parseHostPort s =+    case break (== ':') (reverse s) of+        (portRev, ':' : hostRev) -> do+            let host = unbracket (reverse hostRev)+                portText = reverse portRev+            port <- case reads portText of+                [(n, "")] | n >= 0 && n <= 65535 -> Right n+                _ -> Left ("--http-tcp: not a port: " <> Text.pack (show portText))+            when (null host) (Left ("--http-tcp: no host in " <> Text.pack (show s) <> "; spell the address, 0.0.0.0 included"))+            Right (host, port)+        _ -> Left ("--http-tcp: expected HOST:PORT, got " <> Text.pack (show s))+  where+    unbracket h+        | Just inner <- stripBrackets h = inner+        | otherwise = h+    stripBrackets ('[' : rest) | not (null rest) && last rest == ']' = Just (init rest)+    stripBrackets _ = Nothing++{- | @--status-sink PATH|URL@, @--status-sink-interval SECONDS@ (default+'StatusSink.defaultInterval') and @--status-sink-host NAME@: where this+host's status document is written, how often between the writes a+convergence pass or a follow injection triggers on their own, and what the+document's @host@ says — 'StatusSink.hostName' (@uname -n@) when not given.+Naming it is for two loops on one machine (a fold shows two rows naming one+host otherwise) and for a container whose node name means nothing to the+reader. 'Nothing' for the path writes none.+-}+data SinkOptions = SinkOptions+    { sinkPath :: !(Maybe FilePath)+    , sinkInterval :: !Int+    , sinkHost :: !(Maybe Text)+    }+    deriving (Eq, Ord, Generic, Show)++instance FromJSON SinkOptions+instance ToJSON SinkOptions++instance FromJSON RunCommand+instance ToJSON RunCommand++{- | The @--follow-*@ flags: the scheduler's numbers+("Salmon.Actions.Follow.Scheduler"), in seconds where they are durations,+then the cache directory (@--follow-cache DIR@; none by default, in which+case nothing survives a restart) and @--follow-refuse-older@ (see+'Follow.followRefuseOlder'). @--follow-interval@ is milestone 2's name for+the base delay, kept as a synonym of @--follow-base@; either may be given,+the base's own flag wins. Then the backends' own knobs (milestone 6):+@--follow-timeout@ for the HTTP-backed ones, @--follow-workdir@ for the git+checkout, @--follow-bucket-endpoint@ for an S3-compatible store. Last,+@--follow-key FILE@ (repeatable): the public keys a document must be signed+by ("Salmon.Actions.Follow.Signature"); with none given, documents are+taken as they come — __unsigned mode is the default__.+-}+data FollowOptions = FollowOptions+    { followBase :: !(Maybe Int)+    , followInterval :: !(Maybe Int)+    , followFactor :: !Double+    , followCap :: !Int+    , followJitter :: !Double+    , followDebounce :: !Int+    , followMaxWait :: !Int+    , followCacheDir :: !(Maybe FilePath)+    , followRefuseOlder :: !Bool+    , followTimeout :: !Int+    , followWorkdir :: !(Maybe FilePath)+    , followBucketEndpoint :: !(Maybe Text)+    , followKeys :: ![FilePath]+    -- ^ each @FILE@ (a key that speaks for any label) or @LABEL=FILE@ (one that+    -- speaks for that label only)+    , followAcceptUnlabelled :: !Bool+    -- ^ the migration flag: accept a signed document that names no label+    }+    deriving (Eq, Ord, Generic, Show)++instance FromJSON FollowOptions+instance ToJSON FollowOptions++followSchedule :: FollowOptions -> Scheduler.Config+followSchedule o =+    Scheduler.Config+        { Scheduler.schedBase = seconds (fromMaybe defaultBase (o.followBase <|> o.followInterval))+        , Scheduler.schedFactor = max 1 o.followFactor+        , Scheduler.schedCap = seconds o.followCap+        , Scheduler.schedJitter = max 0 (min 1 o.followJitter)+        , Scheduler.schedDebounce = seconds o.followDebounce+        , Scheduler.schedMaxWait = seconds o.followMaxWait+        }+  where+    defaultBase = Scheduler.defaultConfig.schedBase `div` 1000000++-- | A flag in seconds, as the microseconds the schedule and the backends take.+seconds :: Int -> Int+seconds n = max 0 n * 1000000++{- | How the commands that execute something (@run up@, @run down@, @run+serve@) report. @--json@ selects 'ReportJson': one JSON object per line on+stdout, in the encoding "Salmon.Reporter.Tagged" defines, in place of the+binary's own text reporters — so @run up --json | jq@ works, and a client+of the server @specs\/generic-server.md@ sketches reads the same objects.+Absent, 'ReportText' hands every report to the reporters the binary+passed in, untouched.+-}+data ReportFormat+    = ReportText+    | ReportJson+    deriving (Eq, Ord, Generic, Show)++instance FromJSON ReportFormat+instance ToJSON ReportFormat++data QueryCommand+    = -- | @query show@: annotate the directive's tree with [selected]/[excluded].+      -- The 'Bool's are dedupe (print each 'Salmon.Op.Ref.Ref' only once, at+      -- its first-encountered path; on by default, @--no-dedupe@ turns it+      -- off) and descriptions (@--descriptions@: print each node's help text+      -- on an indented line below its path).+      QueryShow !QuerySelection !Bool !Bool+    | -- | @query plan@: emit a 'Query.Plan' (JSON) for @run up --plan@.+      QueryPlan !QuerySelection !Bool+    | -- | @query extract-directive@: recover an embedded directive from a+      -- 'Query.Plan' file made with @query plan --embed-directive@.+      QueryExtractDirective !FilePath+    deriving (Eq, Ord, Generic, Show)++instance FromJSON QueryCommand+instance ToJSON QueryCommand++data QuerySelection = QuerySelection+    { querySelect :: [Text]+    , queryExclude :: [Text]+    }+    deriving (Eq, Ord, Generic, Show)++instance FromJSON QuerySelection+instance ToJSON QuerySelection++instance (ParseRecord seed) => ParseRecord (Command seed) where+    parseRecord =+        combo <**> helper+      where+        combo =+            hsubparser $+                mconcat+                    [ command "config" (info (Config <$> parseRecord) cfg)+                    , command "query" (info (Query <$> queryCommandParser) qry)+                    , command "run" (info (Run <$> runCommandParser) run)+                    , commandGroup "Salmon Commands."+                    ]+        cfg = progDesc "Prints a config."+        qry = progDesc "Inspects, or plans an exclusion against, a directive on stdin."+        run = progDesc "Runs a config."++runCommandParser :: Parser RunCommand+runCommandParser =+    hsubparser $+        mconcat+            [ command "up" (info upP (progDesc "Runs (up) the directive on stdin."))+            , command "down" (info (RunDown <$> reportFormatP) (progDesc "Tears down (down) the directive on stdin."))+            , command "tree" (info (pure RunTree) (progDesc "Prints a human-readable dependency tree."))+            , command "dag" (info (pure RunDAG) (progDesc "Prints Graphviz dot output."))+            , command "serve" (info serveP (progDesc "Reads a stream of seed declarations on stdin and converges."))+            ]+  where+    serveP =+        RunServe+            <$> optional+                ( Options.Applicative.option+                    Options.Applicative.auto+                    ( long "max-concurrency"+                        <> Options.Applicative.metavar "N"+                        <> Options.Applicative.help "Cap how many nodes converge (check/up/down) at once per pass. Omitted = unbounded."+                    )+                )+            <*> switch+                ( long "no-autoconverge"+                    <> Options.Applicative.help+                        "Start with `autoconverge off`: declarations are recorded but not converged until an explicit `converge`."+                )+            <*> reportFormatP+            <*> optional+                ( strOption+                    ( long "follow"+                        <> Options.Applicative.metavar "REGISTRY"+                        <> Options.Applicative.help "Pull mode: fetch declarations (one document per --label) from a registry: a directory (DIR/<label>.json), git+URL[#BRANCH[:SUBDIR]] (SUBDIR/<label>.json in the checkout), an http(s):// URL (<base>/<label>.json, or {label} placed in it), dns:ZONE (a TXT index at <label>.ZONE naming an https URL and a sha256), or s3://BUCKET/PREFIX / gs://BUCKET/PREFIX (public or presigned object URLs; no SDK, no credentials)."+                    )+                )+            <*> many+                ( strOption+                    ( long "label"+                        <> Options.Applicative.metavar "LABEL"+                        <> Options.Applicative.help "A label to follow in the --follow registry; repeatable, the desired set is the union."+                    )+                )+            <*> followOptionsP+            <*> optional+                ( strOption+                    ( long "listen"+                        <> Options.Applicative.metavar "PATH"+                        <> Options.Applicative.help+                            "Also accept the line protocol on a unix socket at PATH (created owner-only); each client is answered on its own connection, as JSON lines. Stdin keeps working alongside."+                    )+                )+            <*> optional+                ( strOption+                    ( long "http"+                        <> Options.Applicative.metavar "PATH"+                        <> Options.Applicative.help+                            "Also serve HTTP on a unix socket at PATH (created owner-only): GET /dag, /status, /history, /help/seed and POST /command[?async]. Stdin keeps working alongside."+                    )+                )+            <*> Options.Applicative.option+                Options.Applicative.auto+                ( long "events-ring"+                    <> Options.Applicative.metavar "N"+                    <> Options.Applicative.value (Events.configRing Events.defaultConfig)+                    <> Options.Applicative.showDefault+                    <> Options.Applicative.help "How many events --http's /events keeps for a client to resume from with ?since=; a client further behind is sent a gap event."+                )+            <*> sinkOptionsP+            <*> tcpOptionsP+    tcpOptionsP =+        TcpOptions+            <$> optional+                ( strOption+                    ( long "http-tcp"+                        <> Options.Applicative.metavar "HOST:PORT"+                        <> Options.Applicative.help+                            "Also serve the same HTTP over TCP at HOST:PORT, with TLS and a bearer token on every request. Requires --tls-cert, --tls-key and --token-file; there is no plaintext option. Spell the host ([::1]:8443 for IPv6)."+                    )+                )+            <*> optional+                ( strOption+                    ( long "tls-cert"+                        <> Options.Applicative.metavar "FILE"+                        <> Options.Applicative.help "The PEM certificate (with its chain, if any) --http-tcp serves."+                    )+                )+            <*> optional+                ( strOption+                    ( long "tls-key"+                        <> Options.Applicative.metavar "FILE"+                        <> Options.Applicative.help "The PEM private key for --tls-cert."+                    )+                )+            <*> optional+                ( strOption+                    ( long "token-file"+                        <> Options.Applicative.metavar "FILE"+                        <> Options.Applicative.help "A file holding the bearer token every --http-tcp request must present (surrounding whitespace ignored). Refused if readable by others."+                    )+                )+            <*> optional+                ( Options.Applicative.option+                    Options.Applicative.auto+                    ( long "session-lifetime"+                        <> Options.Applicative.metavar "SECONDS"+                        <> Options.Applicative.help "How long a browser's sign-in at /auth on --http-tcp lasts, however busy; an event stream it holds is cut at the end (default 43200, 12h; 0 for no limit)."+                    )+                )+            <*> optional+                ( Options.Applicative.option+                    Options.Applicative.auto+                    ( long "session-idle"+                        <> Options.Applicative.metavar "SECONDS"+                        <> Options.Applicative.help "How long a browser's sign-in on --http-tcp lasts with nothing using it; an open event stream counts as use (default 3600, 1h; 0 for no limit)."+                    )+                )+    sinkOptionsP =+        SinkOptions+            <$> optional+                ( strOption+                    ( long "status-sink"+                        <> Options.Applicative.metavar "PATH|URL"+                        <> Options.Applicative.help "Write this host's status document (JSON: host, mode, applied documents per label, the `status` object, the last converge and follow reports) to PATH, atomically, or POST it to an http(s):// URL, after every convergence pass and follow injection and on a timer; `salmon-fleet status DIR` folds a directory of the files."+                    )+                )+            <*> Options.Applicative.option+                Options.Applicative.auto+                ( long "status-sink-interval"+                    <> Options.Applicative.metavar "SECONDS"+                    <> Options.Applicative.value (StatusSink.defaultInterval `div` 1000000)+                    <> showDefault+                    <> Options.Applicative.help "Seconds between two status sink writes when nothing triggers one."+                )+            <*> optional+                ( strOption+                    ( long "status-sink-host"+                        <> Options.Applicative.metavar "NAME"+                        <> Options.Applicative.help "What the status document's `host` field says (default: this machine's node name, `uname -n`); give one when two loops on one machine write documents, or the node name means nothing to whoever folds them."+                    )+                )+    followOptionsP =+        FollowOptions+            <$> optional+                ( Options.Applicative.option+                    Options.Applicative.auto+                    ( long "follow-base"+                        <> Options.Applicative.metavar "SECONDS"+                        <> Options.Applicative.help ("Seconds between two rounds of fetching the followed labels while rounds succeed (default " <> show (defaultSecs (.schedBase)) <> ").")+                    )+                )+            <*> optional+                ( Options.Applicative.option+                    Options.Applicative.auto+                    ( long "follow-interval"+                        <> Options.Applicative.metavar "SECONDS"+                        <> Options.Applicative.help "Same as --follow-base (the older name)."+                    )+                )+            <*> Options.Applicative.option+                Options.Applicative.auto+                ( long "follow-factor"+                    <> Options.Applicative.metavar "FACTOR"+                    <> Options.Applicative.value Scheduler.defaultConfig.schedFactor+                    <> showDefault+                    <> Options.Applicative.help "How much slower each consecutive failed round makes the next one."+                )+            <*> Options.Applicative.option+                Options.Applicative.auto+                ( long "follow-cap"+                    <> Options.Applicative.metavar "SECONDS"+                    <> Options.Applicative.value (defaultSecs (.schedCap))+                    <> showDefault+                    <> Options.Applicative.help "The longest a failing registry is left alone between rounds."+                )+            <*> Options.Applicative.option+                Options.Applicative.auto+                ( long "follow-jitter"+                    <> Options.Applicative.metavar "FRACTION"+                    <> Options.Applicative.value Scheduler.defaultConfig.schedJitter+                    <> showDefault+                    <> Options.Applicative.help "Every delay is scaled by a uniform draw from [1-j, 1+j], so a fleet does not poll in step."+                )+            <*> Options.Applicative.option+                Options.Applicative.auto+                ( long "follow-debounce"+                    <> Options.Applicative.metavar "SECONDS"+                    <> Options.Applicative.value (defaultSecs (.schedDebounce))+                    <> showDefault+                    <> Options.Applicative.help "How long the registry must be quiet after a change before the change is applied; 0 applies at once."+                )+            <*> Options.Applicative.option+                Options.Applicative.auto+                ( long "follow-max-wait"+                    <> Options.Applicative.metavar "SECONDS"+                    <> Options.Applicative.value (defaultSecs (.schedMaxWait))+                    <> showDefault+                    <> Options.Applicative.help "The longest a change waits to be applied while the registry keeps changing."+                )+            <*> optional+                ( strOption+                    ( long "follow-cache"+                        <> Options.Applicative.metavar "DIR"+                        <> Options.Applicative.help "Keep each label's last applied document in DIR, and replay it at startup when the registry cannot be reached (status then says `mode: replay`). Without it a restart against an unreachable registry declares nothing."+                    )+                )+            <*> switch+                ( long "follow-refuse-older"+                    <> Options.Applicative.help "Refuse a fetched document whose `published` timestamp is older than the one already applied for its label (reported as stale, not injected). Documents without `published` are never refused."+                )+            <*> Options.Applicative.option+                Options.Applicative.auto+                ( long "follow-timeout"+                    <> Options.Applicative.metavar "SECONDS"+                    <> Options.Applicative.value (Registry.Http.defaultOptions.optTimeout `div` 1000000)+                    <> showDefault+                    <> Options.Applicative.help "The longest one HTTP fetch may take, for the http(s)://, dns: and bucket registries; longer is a failed round."+                )+            <*> optional+                ( strOption+                    ( long "follow-workdir"+                        <> Options.Applicative.metavar "DIR"+                        <> Options.Applicative.help "Where a git+ registry is checked out (cloned once, then fetched and reset every round). Default: `checkout` under --follow-cache, else a directory under the system temporary directory named by the repository."+                    )+                )+            <*> optional+                ( strOption+                    ( long "follow-bucket-endpoint"+                        <> Options.Applicative.metavar "URL"+                        <> Options.Applicative.help "For an s3:// registry, an S3-compatible endpoint (MinIO, Ceph RGW...) to address the bucket under, path-style: URL/BUCKET/PREFIX/<label>.json. Without it, https://BUCKET.s3.amazonaws.com."+                    )+                )+            <*> many+                ( strOption+                    ( long "follow-key"+                        <> Options.Applicative.metavar "[LABEL=]FILE"+                        <> Options.Applicative.help "A public key (JWK, as `salmon-fleet keygen` writes FILE.pub) every fetched or replayed document must carry a signature by; repeatable, any one suffices. LABEL=FILE makes the key speak for that label only (repeat the flag for more labels); a bare FILE speaks for any label. A signed document must also name the label it was fetched for (`salmon-fleet sign --label`). Without --follow-key documents are not required to be signed (the default). With it, an unsigned document is refused and never applied."+                    )+                )+            <*> switch+                ( long "follow-accept-unlabelled"+                    <> Options.Applicative.help "The migration flag: accept a signed document that names no label (signed before documents named theirs). Off by default; it lets a validly signed document be served at another label's address, so turn it off once documents are re-signed with --label."+                )+    defaultSecs :: (Scheduler.Config -> Int) -> Int+    defaultSecs f = f Scheduler.defaultConfig `div` 1000000+    upP =+        RunUp+            <$> optional+                ( strOption+                    ( long "plan"+                        <> Options.Applicative.metavar "FILE"+                        <> Options.Applicative.help "A `query plan`-emitted Plan: force-skip its excluded nodes."+                    )+                )+            <*> switch+                ( long "force-stale-plan"+                    <> Options.Applicative.help "Proceed even if the plan's directive digest doesn't match stdin."+                )+            <*> reportFormatP+            <*> many+                ( option+                    (eitherReader (\t -> either (Left . Text.unpack) (const (Right (Text.pack t))) (Window.parseWindow (Text.pack t))))+                    ( long "maintenance-window"+                        <> Options.Applicative.metavar "[DAY:]HH:MM-HH:MM[@UTC|@+HH:MM]"+                        <> Options.Applicative.help "Nodes marked disruptive run only inside these windows (repeatable); outside them they are skipped and reported on stderr. DAY is Mon..Sun; a start later than the end crosses midnight; the zone is a fixed offset, UTC by default."+                    )+                )+            <*> switch+                ( long "override-window"+                    <> Options.Applicative.help "Run disruptive nodes whatever the maintenance windows say."+                )+    reportFormatP =+        Options.Applicative.flag+            ReportText+            ReportJson+            ( long "json"+                <> Options.Applicative.help "Report as one JSON object per line on stdout (see Salmon.Reporter.Tagged) instead of text."+            )++queryCommandParser :: Parser QueryCommand+queryCommandParser =+    hsubparser $+        mconcat+            [ command "show" (info showP (progDesc "Prints the directive's tree, annotating [selected]/[excluded] nodes."))+            , command "plan" (info planP (progDesc "Emits a Plan (JSON) excluding --exclude matches."))+            , command "extract-directive" (info extractP (progDesc "Prints a plan file's embedded directive (see `query plan --embed-directive`)."))+            ]+  where+    selectionP =+        QuerySelection+            <$> many (Text.pack <$> strOption (long "select" <> Options.Applicative.metavar "PATTERN" <> Options.Applicative.help "May repeat; union. Omitted entirely = everything."))+            <*> many (Text.pack <$> strOption (long "exclude" <> Options.Applicative.metavar "PATTERN" <> Options.Applicative.help "May repeat; union, then subtracted from the selection."))+    showP =+        QueryShow+            <$> selectionP+            <*> (not <$> switch+                    ( long "no-dedupe"+                        <> Options.Applicative.help "Print every path a node is reachable from, instead of only its first-encountered one (dedupe is on by default)."+                    ))+            <*> switch+                ( long "descriptions"+                    <> Options.Applicative.help "Print each node's help text on an indented line (\"  # ...\") below its path."+                )+    planP =+        QueryPlan+            <$> selectionP+            <*> switch+                ( long "embed-directive"+                    <> Options.Applicative.help "Embed the directive itself in the plan, so `query extract-directive` can recover it later without the original directive on hand."+                )+    extractP =+        QueryExtractDirective+            <$> Options.Applicative.strArgument (Options.Applicative.metavar "PLAN-FILE")++instance (FromJSON seed) => FromJSON (Command seed)+instance (ToJSON seed) => ToJSON (Command seed)++instance FromJSON BaseCommand+instance ToJSON BaseCommand++{- | Function to combine a configuration system (based on a seed).+todo: consider adding some non-det when the graph depends not just on a seed but also on reading a variable in the directive+- either at the configure step: then the seed must contain enough to build the ops+- either in the expand phase from the directive+-}+execCommandOrSeed ::+    forall directive seed.+    (ToJSON directive, FromJSON directive, ParseRecord seed) =>+    Reporter (UpDown.Report Extension) ->+    Configure IO seed directive ->+    Track' directive ->+    Command seed ->+    IO ()+execCommandOrSeed = execCommandOrSeedWith Serve.reportText++{- | 'execCommandOrSeed' with a say in how @run serve@ reports its own+loop-level events (as opposed to the per-node events, which go to the same+reporter every other command uses).+-}+execCommandOrSeedWith ::+    forall directive seed.+    (ToJSON directive, FromJSON directive, ParseRecord seed) =>+    Reporter Serve.Report ->+    Reporter (UpDown.Report Extension) ->+    Configure IO seed directive ->+    Track' directive ->+    Command seed ->+    IO ()+execCommandOrSeedWith serveR r = execCommandOrSeedWithRewrites serveR r []++{- | 'execCommandOrSeedWith' with "Salmon.Op.Rewrite" phases registered.++This is how an application asks for something like+'Salmon.Builtin.Nodes.Debian.Package.batchPackages' — a collection of many+small nodes into one bulk invocation — instead of applying an @Op -> Op@ pass+by hand inside its own 'Track''. The difference is not stylistic: a phase runs+after the fold, so it sees every declaration and which way each node is+wanted, neither of which a @directive -> Op@ can see. See "Salmon.Op.Rewrite".++The phases apply to @run up@, @run down@, @run serve@ — the commands that+execute something — and, as of (R4), @run tree@\/@run dag@: both now print+the /computed/ 'Salmon.Op.Dag.Dag' through 'Salmon.Actions.Help.printDagTree'+\/'Salmon.Actions.Dot.printDagCograph' rather than the declared @Cofree+Graph@, so a batched node shows up once, the way it will actually run.+@query@ is the one holdout still printing the /declared/ graph: it resolves+@--select@\/@--exclude@ as path globs (see 'Salmon.Actions.Query.resolveSelectors'),+and a rewritten 'Salmon.Op.Dag.Dag' has refs and edges but no paths for a+pattern to match against — fixing that needs either a path-free renderer with+its own selection language, or resolving a pattern against the declared graph+and translating the result through 'Salmon.Op.Rewrite.membersOf', neither of+which is worth doing speculatively.+-}+execCommandOrSeedWithRewrites ::+    forall directive seed.+    (ToJSON directive, FromJSON directive, ParseRecord seed) =>+    Reporter Serve.Report ->+    Reporter (UpDown.Report Extension) ->+    [Rewrite Extension] ->+    Configure IO seed directive ->+    Track' directive ->+    Command seed ->+    IO ()+execCommandOrSeedWithRewrites serveR r rewrites genBase traceBase cmd = do+    case cmd of+        (Run (RunUp Nothing _ fmt wins override)) -> do+            result <- withGraph (runUp (updownFor fmt) (windowsFor wins override) Set.empty)+            when (result == Just False) exitFailure+        (Run (RunUp (Just planPath) forceStale fmt wins override)) -> do+            result <- withGraphAndBytes $ \dirBytes op -> do+                planBytes <- LBysteString.readFile planPath+                case eitherDecode planBytes of+                    Left err -> do+                        putStrLn ("failed to json-parse plan " <> planPath <> ": " <> err)+                        exitFailure+                    Right plan -> do+                        let actual = Query.digestBytes dirBytes+                        let expected = Query.planDirectiveDigest plan+                        if actual == expected+                            then runUp (updownFor fmt) (windowsFor wins override) (Set.fromList (Query.planExcludedRefs plan)) op+                            else+                                if forceStale+                                    then do+                                        putStrLn $+                                            "warning: plan digest mismatch (plan expects "+                                                <> Text.unpack expected+                                                <> ", this directive hashes to "+                                                <> Text.unpack actual+                                                <> "); proceeding due to --force-stale-plan"+                                        runUp (updownFor fmt) (windowsFor wins override) (Set.fromList (Query.planExcludedRefs plan)) op+                                    else do+                                        putStrLn $+                                            "refusing to run stale plan: plan expects digest "+                                                <> Text.unpack expected+                                                <> ", but this directive hashes to "+                                                <> Text.unpack actual+                                        exitFailure+            when (result == Just False) exitFailure+        (Run (RunDown fmt)) -> do+            result <- withGraph (runDown (updownFor fmt))+            when (result == Just False) exitFailure+        (Run RunTree) -> do+            -- (R4): the computed 'Dag' is what @run up@ would actually walk+            -- once any "Salmon.Op.Rewrite" phases are registered; with none+            -- registered `computed` is the declared graph, still collapsed+            -- to one line per 'Ref' rather than one per path.+            void $ withGraph (\op -> computedTreeDag op >>= Help.printDagTree)+        (Run RunDAG) -> do+            void $ withGraph (\op -> computedTreeDag (injectRemoteSubgraphs 0 op) >>= Dot.printDagCograph)+        (Run (RunServe maxConcurrency noAutoConverge fmt followDir labels followOptions listen http eventsRing sinkOptions tcpOptions)) -> do+            limit <- traverse Concurrency.newConcurrencyLimit maxConcurrency+            let own = taggedFor fmt+            -- the network listener is refused before anything is bound or+            -- read: the flags as a whole, then the token file itself+            tcp <- case validateTcpOptions tcpOptions of+                Left err -> do+                    hPutStrLn stderr (Text.unpack err)+                    exitFailure+                Right t -> pure t+            -- and so is a socket path no unix address can hold, which+            -- would otherwise surface as network's own crash from bind+            forM_ [(flag, path) | (flag, Just path) <- [("--listen", listen), ("--http", http)]] $ \(flag, path) ->+                when (length path >= Socket.unixPathMax) $ do+                    hPutStrLn stderr (flag <> " " <> path <> " is " <> show (length path) <> " characters; a unix socket path holds at most " <> show (Socket.unixPathMax - 1) <> " (pick a shorter one, e.g. under /run or /tmp)")+                    exitFailure+            tlsBinds <- forM (maybe [] pure tcp) $ \t -> do+                token <- Http.readTokenFile t.tcpTokenPath+                case token of+                    Left (Http.TokenFileReadable path) -> do+                        hPutStrLn stderr ("--token-file " <> path <> " is readable by others; a token anyone on the box can read is not one (chmod 600 it)")+                        exitFailure+                    Left (Http.TokenFileEmpty path) -> do+                        hPutStrLn stderr ("--token-file " <> path <> " is empty")+                        exitFailure+                    Right tok -> pure (Http.BindTls (Http.TlsBind t.tcpHost t.tcpPort t.tcpCertFile t.tcpKeyFile tok t.tcpSessionPolicy))+            let binds = [Http.BindUnix path | Just path <- [http]] ++ tlsBinds+            follow <- case (followDir, traverse Follow.mkLabel labels) of+                (Nothing, _) | not (null followOptions.followKeys) -> do+                    hPutStrLn stderr "--follow-key needs a --follow REGISTRY whose documents it verifies"+                    exitFailure+                (Nothing, Right []) -> pure Nothing+                (Nothing, _) -> do+                    hPutStrLn stderr "--label needs a --follow REGISTRY to fetch from"+                    exitFailure+                (Just _, Right []) -> do+                    hPutStrLn stderr "--follow needs at least one --label to fetch"+                    exitFailure+                (Just _, Left err) -> do+                    hPutStrLn stderr (Text.unpack err)+                    exitFailure+                (Just addr, Right lbls) -> do+                    -- the backend is chosen by the shape of the address; see+                    -- "Salmon.Actions.Follow.Registry"+                    address <- case Registry.parseAddress (Text.pack addr) of+                        Left err -> hPutStrLn stderr (Text.unpack err) >> exitFailure+                        Right a -> pure a+                    -- a key that cannot be loaded must not start a loop that+                    -- would then refuse everything, or accept everything+                    keys <- forM followOptions.followKeys $ \spec -> do+                        (scope, path) <- case Signature.parseKeySpec (Text.pack spec) of+                            Left err -> hPutStrLn stderr ("--follow-key " <> spec <> ": " <> Text.unpack err) >> exitFailure+                            Right parsed -> pure parsed+                        loaded <- Signature.readPublicKeyFile path+                        case loaded of+                            Left err -> hPutStrLn stderr ("--follow-key " <> path <> ": " <> Text.unpack err) >> exitFailure+                            Right k -> pure (maybe (Signature.trustsAnyLabel k) (\l -> Signature.trustsOnly l k) scope)+                    let legacy = if followOptions.followAcceptUnlabelled then Signature.AcceptUnlabelled else Signature.RefuseUnlabelled+                        verifier = if null keys then Follow.noVerifier else Signature.signedVerifier legacy keys+                    registry <-+                        Registry.open+                            Registry.defaultOptions+                                { Registry.optHttp = Registry.Http.Options{Registry.Http.optTimeout = seconds followOptions.followTimeout}+                                , Registry.optWorkdir = followOptions.followWorkdir+                                , Registry.optCacheDir = followOptions.followCacheDir+                                , Registry.optBucketEndpoint = followOptions.followBucketEndpoint+                                }+                            address+                    pure $+                        Just+                            Follow.Follow+                                { Follow.followRegistry = registry+                                , Follow.followLabels = lbls+                                , Follow.followSchedule = followSchedule followOptions+                                , Follow.followCache = followOptions.followCacheDir+                                , Follow.followRefuseOlder = followOptions.followRefuseOlder+                                , Follow.followVerify = verifier+                                }+            -- the fetcher's first round is in the inbox before standard+            -- input is even read, so the first convergence is what the+            -- registry says, deterministically; after that both interleave+            -- at line granularity.+            gate <- newEmptyMVar+            -- what `fetch` pokes: the fetcher's clock wakes on it; and+            -- what `status` reads: the fetcher's mode+            pk <- Scheduler.newPoke+            modeVar <- Follow.newMode+            appliedVar <- Follow.newApplied+            host <- maybe StatusSink.hostName pure sinkOptions.sinkHost+            let onFetch = Follow.followed pk modeVar appliedVar <$ follow+                sinkConfig path =+                    StatusSink.Config+                        { StatusSink.configPath = path+                        , StatusSink.configInterval = max 1 sinkOptions.sinkInterval * 1000000+                        , StatusSink.configHost = host+                        }+            -- the status sink watches the loop's stream for its triggers,+            -- so what everything below reports through is the loop's own+            -- reporter with the sink beside it; the sink's own complaints+            -- go to the loop's own alone.+            withMaybe sinkOptions.sinkPath (\path -> StatusSink.withSink (sinkConfig path) onFetch own) $ \msink -> do+              let tagged = maybe own (reportBoth own . StatusSink.sinkReporter) msink+                  -- with a socket to talk to, the process must outlive+                  -- whatever started it (`< /dev/null &` is the ordinary way+                  -- to run it), so standard input is read as a named source+                  -- rather than as the loop's 'Serve.Stdin': its end of input+                  -- is a hang-up like any client's and only `quit` — from+                  -- stdin or from a client — ends the loop.+                  stdinP = case (listen, binds) of+                      (Nothing, []) -> Serve.stdinProducer stdin+                      _ -> Serve.handleProducer (Serve.Origin "stdin") stdin+                  producersWith followR more =+                      case follow of+                          Nothing -> stdinP : more+                          Just f -> Follow.follower followR pk modeVar appliedVar f (putMVar gate ()) : Follow.gated gate stdinP : more+              -- the listener's reporters answer each socket client on its own+              -- connection, the HTTP server's answer each request with its+              -- own reports, and both hand everything on to the loop's own,+              -- which stays exactly as `fmt` says.+              withMaybe listen Socket.withUnixListener $ \mlistener ->+                withMaybe (nonEmptyList binds) (\bs -> Http.withHttpServerOn Events.defaultConfig{Events.configRing = eventsRing} bs (seedHelpText (parseRecord :: Parser seed)) (maybe (pure Serve.Interactive) Serve.followedMode onFetch)) $ \mserver -> do+                    -- exactly one line, once the listener is up, saying what+                    -- is now reachable from the network and on what terms+                    forM_ tcp $ \t ->+                        hPutStrLn stderr ("serve: exposing HTTP on " <> t.tcpHost <> ":" <> show t.tcpPort <> " with TLS, token from " <> t.tcpTokenPath)+                    let (serveR0, r0) = reportersOver tagged+                        base = case mlistener of+                            Nothing -> (contramap Serve.attributed serveR0, contramap Serve.attributed r0)+                            Just listener -> Socket.listenerReporters listener tagged+                        (serveR', r') = maybe base (`Http.serverReporters` base) mserver+                        observe acc = do+                            traverse_ (`Http.serverObserver` acc) mserver+                            traverse_ (`StatusSink.sinkObserver` acc) msink+                        more = foldMap (pure . Socket.listenerProducer) mlistener <> foldMap (pure . Http.serverProducer) mserver+                    void $+                        Serve.serveObserved+                            observe+                            rewrites+                            limit+                            (not noAutoConverge)+                            serveR'+                            r'+                            parseSeedArgs+                            genBase+                            traceBase+                            onFetch+                            -- the fetcher's reports also go to /events, as its own stream+                            (producersWith (maybe id (\srv r -> reportBoth r (Http.serverFollowReporter srv)) mserver (Tagged.followStream tagged)) more)+        (Query (QueryShow (QuerySelection sel exc) dedupe showDescriptions)) -> do+            void $ withGraph $ \op -> do+                let cograph = runIdentity (expand op)+                computed <- computedRewritten op+                let (selected, excluded) = Query.resolveRewrittenSelectors cograph computed sel exc+                Query.printAnnotated cograph selected excluded dedupe showDescriptions+        (Query (QueryPlan (QuerySelection sel exc) embedDirective)) -> do+            void $ withGraphAndBytes $ \dirBytes op -> do+                let cograph = runIdentity (expand op)+                computed <- computedRewritten op+                let (_, excluded) = Query.resolveRewrittenSelectors cograph computed sel exc+                let embedded = if embedDirective then Just (Text.decodeUtf8 (LBysteString.toStrict dirBytes)) else Nothing+                let plan = Query.Plan (Query.digestBytes dirBytes) (Set.toList excluded) exc embedded+                LBysteString.putStr (encode plan)+        (Query (QueryExtractDirective planPath)) -> do+            planBytes <- LBysteString.readFile planPath+            case eitherDecode planBytes of+                Left err -> do+                    putStrLn ("failed to json-parse plan " <> planPath <> ": " <> err)+                    exitFailure+                Right plan ->+                    case Query.planDirective plan of+                        Nothing -> do+                            putStrLn ("plan " <> planPath <> " has no embedded directive (was it created with `query plan --embed-directive`?)")+                            exitFailure+                        Just dirText ->+                            LBysteString.putStr (LBysteString.fromStrict (Text.encodeUtf8 dirText))+        Config seed -> do+            dir <- gen genBase seed+            LBysteString.putStr $ encode dir+  where+    nat = pure . runIdentity++    {- | The one 'Tagged.Tagged' reporter a @run up@\/@run down@\/@run+    serve@ speaks through, by 'ReportFormat': for 'ReportText' it dispatches+    back to the reporters the binary passed in (so nothing about the text+    output changes), for 'ReportJson' it is "Salmon.Reporter.Tagged"'s line+    writer on stdout in their place. The tending loop's own stream never+    reaches here on its own — @serve@ forwards what it keeps of it as+    'Serve.Tended', which the encoding nests — so its slot is 'silent'. The+    fetcher's stream ("Salmon.Actions.Follow") goes through here too, so+    that @--json@ covers it and a status sink can watch it. -}+    taggedFor :: ReportFormat -> Reporter Tagged.Tagged+    taggedFor fmt = case fmt of+        ReportText -> Tagged.reportTexts serveR r silent Follow.reportText+        ReportJson -> Tagged.reportJSONLines stdout++    -- | The tagged reporter split contravariantly into the two the drivers take.+    reportersOver :: Reporter Tagged.Tagged -> (Reporter Serve.Report, Reporter (UpDown.Report Extension))+    reportersOver tagged = (Tagged.serveStream tagged, Tagged.updownStream tagged)++    updownFor :: ReportFormat -> Reporter (UpDown.Report Extension)+    updownFor = snd . reportersOver . taggedFor++    {- | @run up@: everything in this one directive's graph is wanted up, so+    that is the rewrites' 'phaseDesired'. @excluded@ (a plan's skipped+    refs) is what they must not collect: batching a node the operator asked+    to skip would run it anyway, under another node's name.++    Exclusion is a 'UpDown.Gate' rather than 'Query.forceSkip' precisely so it+    composes with collections — a batch is worth running iff some member of+    it is, which is the same 'Rewrite.membersOf' translation @serve@'s gate+    does. The report stream is identical either way: both produce a 'Skip'. -}+    runUp :: Reporter (UpDown.Report Extension) -> UpDown.Gate Extension -> Set Ref -> Op -> IO Bool+    runUp r' windowGate excluded op = do+        dag <- UpDown.expandDag r' nat op+        let computed = Rewrite.rewrite rewrites (Phase (Set.fromList (Dag.dagOrder dag)) excluded) dag+        UpDown.upDag (bothGates windowGate (excluding computed excluded)) r' (Rewrite.computedDag computed)++    {- | @run down@: nothing is wanted up, which is what makes a+    direction-aware rewrite emit a teardown batch here and an install batch+    under @run up@, from the same registered phase. -}+    runDown :: Reporter (UpDown.Report Extension) -> Op -> IO Bool+    runDown r' op = do+        dag <- UpDown.expandDag r' nat op+        let computed = Rewrite.rewrite rewrites (Phase Set.empty Set.empty) dag+        UpDown.downDag UpDown.alwaysRequired r' (Rewrite.computedDag computed)++    {- | (R4): the whole-graph 'Rewritten' `run tree`\/`run dag`\/`query`+    all read from — everything in the declared graph is "desired" and+    nothing is "ignored", the same 'Phase' 'Rewrite.wholeGraph' builds for a+    bare @run down@'s rewrite pass, since none of the three is about one+    direction of travel. Kept as the full 'Rewritten' (not just+    'Rewrite.computedDag') because `query` also needs 'Rewrite.membersOf' —+    see 'Query.resolveRewrittenSelectors'.+    -}+    computedRewritten :: Op -> IO (Rewritten Extension)+    computedRewritten op = do+        dag <- UpDown.expandDag r nat op+        pure (Rewrite.rewrite rewrites (Rewrite.wholeGraph dag) dag)++    computedTreeDag :: Op -> IO (Dag.Dag Extension)+    computedTreeDag op = Rewrite.computedDag <$> computedRewritten op++    -- | Held by the maintenance windows (reported on stderr) or excluded: skipped.+    windowsFor :: [Text] -> Bool -> UpDown.Gate Extension+    windowsFor wins override+        | override = UpDown.alwaysRequired+        | otherwise = Window.windowGate (rights (map Window.parseWindow wins)) $ \act next ->+            hPutStrLn stderr $+                "held by maintenance window until "+                    <> maybe "(never)" show next+                    <> ": "+                    <> show act.shorthand++    bothGates :: UpDown.Gate Extension -> UpDown.Gate Extension -> UpDown.Gate Extension+    bothGates g1 g2 act = do+        a <- g1 act+        case a of+            UpDown.Skippable -> pure UpDown.Skippable+            _ -> g2 act++    excluding :: Rewritten Extension -> Set Ref -> UpDown.Gate Extension+    excluding computed excluded+        | Set.null excluded = UpDown.alwaysRequired+        | otherwise = \act ->+            pure $+                if any (`Set.notMember` excluded) (Set.toList (Rewrite.membersOf computed act.extension.ref))+                    then UpDown.Required+                    else UpDown.Skippable++    -- | 'Nothing' iff the incoming JSON graph failed to parse (in which case @cont@ never ran).+    withGraph :: (Op -> IO a) -> IO (Maybe a)+    withGraph cont = withGraphAndBytes (const cont)++    -- | Like 'withGraph', but also hands the continuation the exact raw+    -- bytes read off stdin — needed to digest the directive itself (see+    -- 'Query.digestBytes'), since re-'encode'ing the decoded value gives no+    -- guarantee of hashing to the same bytes.+    withGraphAndBytes :: (LBysteString.ByteString -> Op -> IO a) -> IO (Maybe a)+    withGraphAndBytes cont = do+        jsonbody <- LBysteString.getContents+        case eitherDecode jsonbody of+            Left err -> do+                putStrLn ("failed to json-parse graph: " <> err)+                pure Nothing+            Right a -> do+                Just <$> cont jsonbody (run traceBase a)++-- | Bracket over an optional resource: the continuation gets 'Nothing'+-- when there was nothing to acquire.+withMaybe :: Maybe x -> (x -> (y -> IO r) -> IO r) -> (Maybe y -> IO r) -> IO r+withMaybe Nothing _ k = k Nothing+withMaybe (Just x) with k = with x (k . Just)++-- | 'Nothing' for an empty list, for 'withMaybe' over a list of resources.+nonEmptyList :: [x] -> Maybe [x]+nonEmptyList [] = Nothing+nonEmptyList xs = Just xs++{- | A seed parser's own @--help@ text, as @config --help@ prints it: what+@GET \/help\/seed@ answers, the one non-generic surface the server has.+-}+seedHelpText :: Parser seed -> Text+seedHelpText p =+    case execParserPure defaultPrefs (info (p <**> helper) briefDesc) ["--help"] of+        Failure failure -> Text.pack (fst (renderFailure failure "config"))+        Success _ -> ""+        CompletionInvoked _ -> ""++{- | Runs a seed's own command-line parser over the arguments of one @run+serve@ declaration — i.e. the same words that would follow @config@ on an+actual command line.+-}+parseSeedArgs :: forall seed. (ParseRecord seed) => [String] -> Either Text seed+parseSeedArgs args =+    case execParserPure defaultPrefs (info parseRecord briefDesc) args of+        Success seed -> Right seed+        Failure failure -> Left (Text.pack $ fst $ renderFailure failure "config")+        CompletionInvoked _ -> Left "unexpected shell-completion request"++updownOnReport ::+    Reporter (UpDown.Report Extension) ->+    Reporter Op+updownOnReport r =+    ReporterM $ \op -> void $ UpDown.upTree r nat op+  where+    nat = pure . runIdentity++injectRemoteSubgraphs :: Int -> Op -> Op+injectRemoteSubgraphs lvl orig =+    orig `overlaid` flattenAllRemoteCalls orig++-- | A record for dynamic remote-op.+data RemoteOp = RemoteOp {unRemote :: Op}++flattenAllRemoteCalls :: Op -> Op+flattenAllRemoteCalls root =+    op "remote-call-details" (deps remoteCalls) id+  where+    remoteCalls = concatMap adapt $ collectDynamics root+    adapt :: (Op, [RemoteOp]) -> [Op]+    adapt (orig, remotes) = [unRemote r | r <- remotes]
+ src/Salmon/Builtin/Extension.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Salmon.Builtin.Extension where++import Control.Applicative ((<|>))+import Control.Comonad.Cofree+import Control.Monad.Identity+import Data.Dynamic (Dynamic, Typeable, fromDynamic, toDyn)+import Data.Foldable (toList)+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text as Text+import System.Exit (ExitCode)++import Salmon.Actions.Dot (PlaceHolder (..))+import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Op.Actions+import Salmon.Op.Configure+import Salmon.Op.Eval+import Salmon.Op.Graph+import Salmon.Op.OpGraph+import Salmon.Op.Ref (Ref, mkRef, unRef)+import Salmon.Op.Track++-- | Instanciate actions.+type Actions' = Actions Extension++-- | A short (one-liner) helper string.+type Help = Text++-- | An longer helper string.+type Note = Text++{- | Where a 'managed' action puts a line of its own output: the node's own+bounded ring (@Salmon.Op.Status.statusOutput@), which is also what tells a+watchdog the node is still making progress.+-}+type Output = Text -> IO ()++-- | Our demo extension.+data Extension = Extension+    { help :: Help+    , notes :: [Note]+    , ref :: Ref+    , up :: IO ()+    , -- | The long-running counterpart to 'up', for the one thing @up@+      -- cannot express: an effect that only exists for as long as something+      -- holds it. It blocks while the node is up and returns the reason it+      -- stopped, so the handle never has to escape — the node's own thread+      -- is in scope for the effect's entire lifetime, which is what a+      -- traversal (where @up :: IO ()@ ran and returned into nothing) could+      -- not offer. Teardown is cancelling that thread, so whatever bracket+      -- the action is built from is what does the killing; see+      -- "Salmon.Builtin.Nodes.Process".+      --+      -- 'Nothing' for every node whose effect persists on its own, which is+      -- almost all of them. Two fields rather than a+      -- @OneShot ... | Managed ...@ sum deliberately: the sum is the better+      -- type and would rewrite all 106 @up =@ sites in the tree for a+      -- feature a handful of nodes use. If a third lifecycle ever turns up,+      -- that is the moment to pay for it.+      --+      -- __Only a driver that can hold a running action honours this__ —+      -- "Salmon.Actions.Upkeep", i.e. @run serve@. The one-shot drivers call+      -- 'up', so a node that has no meaningful 'up' should say so by+      -- throwing from it rather than by no-oping.+      managed :: Maybe (Output -> IO ExitCode)+    , -- | "is my effect already in place": the merge of what used to be+      -- @prelim@ and a separate, unimplemented @check@. See 'CheckResult'.+      check :: IO CheckResult+    , down :: IO ()+    , dynamics :: [Dynamic]+    }++instance Show Extension where+    show ext =+        Text.unpack $+            Text.unwords+                [ "["+                , unRef ext.ref+                , ":"+                , ext.help+                , "]"+                ]++instance Semigroup Extension where+    a <> b =+        Extension+            (help a <> "|" <> help b)+            (notes a <> notes b)+            (ref a <> ref b)+            (up a <> up b)+            -- there is no combining two long-running actions: each is the+            -- effect's whole lifetime, and running both would mean one node+            -- owning two processes with one status. First one wins, which+            -- matches the magma's own last-writer-wins in spirit — take one,+            -- do not invent a third thing. Nothing on the execution path+            -- uses this instance.+            (managed a <|> managed b)+            (check a <> check b)+            (down b <> down a)+            (dynamics a <> dynamics b)++type Op = OpGraph Identity Actions'++type Track' a = Track Identity Actions' a++type Tracked' a = Tracked Identity Actions' a++evalDeps :: Op -> Cofree Graph Op+evalDeps = runIdentity . expand++nodeps :: Identity (Graph Op)+nodeps = pure $ Vertices []++deps :: [Op] -> Identity (Graph Op)+deps xs = pure $ Vertices xs++realNoop :: Op+realNoop =+    OpGraph nodeps Actionless++ignoreTrack :: Track' a+ignoreTrack = Track (const realNoop)++noop :: ShortHand -> Op+noop short =+    OpGraph+        nodeps+        ( Actions+            $ Act+                short+            $ Extension+                noHelp+                noNotes+                ref+                skip+                -- nothing to hold: the default node's effect, whatever it+                -- turns out to be, persists without anybody watching it.+                Nothing+                -- a node that says nothing about its own effect is taken+                -- to be saying that asking would cost what applying costs,+                -- which 'requirement' reads as "run up" — the same+                -- behaviour the old @pure Required@ default had, and the+                -- reason the one-shot drivers cannot tell the difference.+                -- Under "Salmon.Actions.Upkeep" they part company: such a+                -- node parks instead of being polled forever for an answer+                -- it has already given.+                (pure Immaterial)+                skip+                noDynamics+        )+  where+    noHelp :: Help+    noHelp = ""++    noDynamics :: [Dynamic]+    noDynamics = []++    noNotes :: [Note]+    noNotes = []++    ref :: Ref+    ref = mkRef "noop" short++    skip :: IO ()+    skip = pure ()++op :: ShortHand -> Identity (Graph Op) -> (Extension -> Extension) -> Op+op short pred f =+    -- complicated implementation to say that we apply the modifier on Extension on top of a noop+    let baseOp = (noop short){predecessors = pred}+        baseNode = node baseOp+     in baseOp{node = fmap f baseNode}++placeholder :: ShortHand -> Text -> Op+placeholder short t = op short nodeps $ \actions ->+    actions+        { dynamics = [toDyn $ PlaceHolder t]+        , ref = mkRef short t+        }++-- | Function to retrieve the dynamic objects of a given type.+getDynamics :: (Typeable a) => Op -> [a]+getDynamics o = catMaybes $ fmap fromDynamic $ concatMap dynamics exts+  where+    exts :: [Extension]+    exts = toList o.node -- uses the foldable instance of 'Actions' which is like a Maybe++-- | Collect all ops with a given dynamic type. This can be used to perform analyses on whole graphs.+collectDynamics :: (Typeable a) => Op -> [(Op, [a])]+collectDynamics root =+    let ops = toList (evalDeps root)+     in [(op, getDynamics op) | op <- ops]++-- Utility to partially apply type in opaque continuation setup in conjuction+-- with UpDown.upTree in defining a `up`.+newtype TrackedIO a = TrackedIO {unwrapTIO :: Tracked' (IO a)}++type Act' = Act Extension++opAct :: Op -> Maybe (Act Extension)+opAct x =+    case x.node of+        Actionless -> Nothing+        Actions a -> Just a
+ src/Salmon/Builtin/Helpers.hs view
@@ -0,0 +1,39 @@+module Salmon.Builtin.Helpers where++import Control.Comonad.Cofree+import Data.Text (Text)+import qualified Data.Text as Text++import Salmon.Builtin.Extension+import Salmon.Op.Actions+import Salmon.Op.Graph+import Salmon.Op.OpGraph+import Salmon.Op.Ref++-- | A helper to turn a migration graph into an Op.+collapse ::+    forall a.+    Text ->+    (a -> Op) ->+    Cofree Graph a ->+    Op+collapse opName toOp (m :< x) =+    current `inject` pred+  where+    current, pred :: Op+    current = toOp m+    pred = evalPred [] x+    currentref = case current.node of Actionless -> mkRef "actionless" (); (Actions (Act _ x)) -> x.ref+    gorec = collapse opName toOp+    setref lineage actions =+        actions{ref = mkRef opName (unRef currentref, lineage)}++    -- the string in eval pred accumulates left/right branches choices to disambiguate noop nodes by ref+    evalPred :: [Text] -> Graph (Cofree Graph a) -> Op+    evalPred l (Vertices []) = realNoop+    evalPred l (Vertices zs) =+        op opName (deps $ fmap gorec zs) (setref l)+    evalPred l (Overlay g1 g2) =+        op opName (deps [evalPred ("l" : l) g1, evalPred ("r" : l) g2]) (setref l)+    evalPred l (Connect g1 g2) =+        op opName (deps [evalPred ("l" : l) g2 `inject` evalPred ("r" : l) g1]) (setref l)
+ src/Salmon/Builtin/Migrations.hs view
@@ -0,0 +1,79 @@+{- | Object to help reading migration files and turning a series of files into+a Migration.++The idea is that+-}+module Salmon.Builtin.Migrations where++import Control.Comonad.Cofree (Cofree (..))+import Data.ByteString as ByteString+import System.FilePath ((</>))++import Salmon.Op.Eval+import Salmon.Op.Graph+import Salmon.Op.OpGraph++{- | Migrations are sequenced operations that are stored in separate files.++Hence, evaluating the Migration steps requires opening multiple files and is non-deterministic.+-}+type Migration a = OpGraph IO a++{- | Collections of functions to read Migration steps.++The idea of these functions is that they should be independent.+Indeed, normalizePath could be contramapped on register or mapped on+parsePredecessors. However the idea is to build a MigrationReader piecewise.+Further, we expect that the loadMigrations step is done once in a Seeding+stage. Thus, we expect that Migrations out of the reader are JSON-ifiable+data items. Which are then turned into some operation-bearing in an+Run stage.+Hence, some hints are provided about expectations.+-}+data MigrationReader a+    = MigrationReader+    { register :: FilePath -> IO a+    -- ^ function to turn a filepath in the migration+    -- We expect that most-often this function will be pure, merely recording the+    -- file path. IO is provided as a convenience.+    , parsePredecessors :: ByteString -> [FilePath]+    -- ^ locate predecessor files in the contents of the file+    -- We expect that this parsing is superficial, for instance reading only+    -- inside comments of SQL scripts rather than parsing a whole SQL AST.+    , normalizePath :: FilePath -> FilePath+    -- ^ function to turn a filepath found in the migration into a file the+    -- reader can actually open.+    }++{- | Add a prefix like a source-directory where migrations refer to each-other+using local-paths that may differ from the rundir where Salmon binaries run.+-}+addFilePrefix :: FilePath -> MigrationReader a -> MigrationReader a+addFilePrefix pfx reader =+    reader{normalizePath = \p -> pfx </> reader.normalizePath p}++-- TODO: ioref to avoid double reading+-- TODO: detect cycles+readMigrationFile ::+    forall a.+    MigrationReader a ->+    FilePath ->+    IO (Migration a)+readMigrationFile reader src =+    OpGraph readPredecessors <$> (reader.register path)+  where+    path :: FilePath+    path = reader.normalizePath src++    readPredecessors :: IO (Graph (Migration a))+    readPredecessors = do+        contents <- ByteString.readFile (reader.normalizePath src)+        Vertices+            <$> traverse (readMigrationFile reader) (reader.parsePredecessors contents)++-- | Load migrations steps for a given starting file.+loadMigrations ::+    MigrationReader a ->+    FilePath ->+    IO (Cofree Graph (Migration a))+loadMigrations r path = expand =<< readMigrationFile r path
+ src/Salmon/Builtin/Nodes/Bash.hs view
@@ -0,0 +1,47 @@+module Salmon.Builtin.Nodes.Bash where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.Ref+import Salmon.Reporter++import Control.Monad (void)+import Data.Text (Text)+import qualified Data.Text as Text++import System.FilePath ((</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess, proc)++-------------------------------------------------------------------------------++data Report+    = RunBash !BashCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------+run :: Reporter Report -> Track' (Binary "bash") -> File "script" -> Op+run r bash script =+    withFile script $ \filepath ->+        let cmd = BashCommand filepath+         in withBinary bash bashrun cmd $ \up ->+                op "bash-run" nodeps $ \actions ->+                    actions+                        { help = "runs a bash command"+                        , ref = mkRef "bash-run" filepath+                        , up = up (r' cmd)+                        }+  where+    r' cmd = contramap (RunBash cmd) r++data BashCommand = BashCommand FilePath+    deriving (Show)++bashrun :: Command "bash" BashCommand+bashrun = Command $ \(BashCommand path) ->+    proc+        "bash"+        [ path+        ]
+ src/Salmon/Builtin/Nodes/Binary.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE PatternSynonyms #-}++module Salmon.Builtin.Nodes.Binary (+    Binary,+    justInstall,+    Command (..),+    withBinary,+    withBinaryStdin,+    untrackedExec,+    untrackedExecOutput,+    CommandIO (..),+    withBinaryIO,+    untrackedExecIO,+    Report (..),+    pattern CommandSuccess,+    isCommandSuccessful,+    CommandFailed (..),+    CommandFailedSimple (..),+    checkExitCode,+) where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.OpGraph+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Control.Exception (Exception, throwIO)+import Control.Monad (void)+import qualified Data.ByteString.Char8 as C8+import Data.ByteString (ByteString)+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.IO.Exception (ExitCode (..))+import GHC.TypeLits (Symbol)++import GHC.IO.Handle (Handle)+import System.Process (ProcessHandle, createProcess)+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess (..), proc)++-------------------------------------------------------------------------------++data Report+    = CommandStart !CreateProcess+    | CommandStopped !CreateProcess !ExitCode !ByteString !ByteString+    | Requested !(Maybe Act') !Report+    deriving (Show)++pattern CommandSuccess out err <-+    CommandStopped _ ExitSuccess out err++isCommandSuccessful :: Report -> Bool+isCommandSuccessful r = case r of+    (CommandStart _) -> False+    (CommandStopped _ ExitSuccess _ _) -> True+    (CommandStopped _ _ _ _) -> False+    (Requested _ child) -> isCommandSuccessful child++-------------------------------------------------------------------------------++{- | A proxy type to pass binaries around.++This proxy cannot be constructed directly.+-}+data Binary (wellKnownName :: Symbol) = Binary++justInstall :: Track' (Binary sym) -> Op+justInstall t = run t Binary++-- | A command declares using a command.+data Command (wellKnownName :: Symbol) arg+    = Command+    { prepare :: arg -> CreateProcess+    }++{- | Captures the property that, to use a binary one needs to inherit the+dependencies from the binary provider.+-}+withBinary :: Track' (Binary x) -> Command x arg -> arg -> ((Reporter Report -> IO ()) -> Op) -> Op+withBinary t cmd arg consumeIO =+    withBinaryStdin t cmd arg "" consumeIO++withBinaryStdin :: Track' (Binary x) -> Command x arg -> arg -> ByteString -> ((Reporter Report -> IO ()) -> Op) -> Op+withBinaryStdin t cmd arg stdin consumeIO =+    -- we use laziness here so that the Ref we add as Referral is the Ref from the enclosed Op (which has a circular dep itself)+    let mk a = (untrackedExec cmd a stdin, Binary)+        -- wrap consumer by capturing the reporter being passed around+        fconsume :: (Reporter Report -> IO ()) -> Op+        fconsume f =+            let+                g :: Reporter Report -> IO ()+                g r = f (contramap (Requested (opAct ret)) r)+             in+                consumeIO g+        ret = tracking t mk arg fconsume+     in ret++{- | Runs the command and, unlike a naive shell-out, does not swallow a+non-zero exit: after reporting 'CommandStopped' (so the failure is still+visible in the 'Report' stream either way), it throws 'CommandFailed'. This+is what lets "Salmon.Actions.UpDown".'Salmon.Actions.UpDown.upTree' actually+notice a failing command instead of blindly running every dependent as if it+had succeeded.+-}+untrackedExec :: Command x a -> a -> ByteString -> (Reporter Report -> IO ())+untrackedExec binary arg dat = \r -> do+    let p = prepare binary arg+    runReporter r (CommandStart p)+    (code, out, err) <- readCreateProcessWithExitCode p dat+    runReporter r (CommandStopped p code out err)+    case code of+        ExitSuccess -> pure ()+        ExitFailure n -> throwIO (CommandFailed p n out err)++{- | 'untrackedExec' for a caller that wants the command's standard output+back — a @git rev-parse@, a @dig +short@ — under the same rule about exit+codes: non-zero throws 'CommandFailed', so what is handed back is always+the output of a command that succeeded.+-}+untrackedExecOutput :: Command x a -> a -> ByteString -> Reporter Report -> IO ByteString+untrackedExecOutput binary arg dat r = do+    let p = prepare binary arg+    runReporter r (CommandStart p)+    (code, out, err) <- readCreateProcessWithExitCode p dat+    runReporter r (CommandStopped p code out err)+    case code of+        ExitSuccess -> pure out+        ExitFailure n -> throwIO (CommandFailed p n out err)++-- | Thrown by 'untrackedExec' (and so, transitively, by every node built on 'withBinary') on a non-zero exit.+data CommandFailed+    = CommandFailed+    { commandFailed_process :: CreateProcess+    , commandFailed_exitCode :: Int+    , commandFailed_stdout :: ByteString+    , commandFailed_stderr :: ByteString+    }++instance Show CommandFailed where+    show e =+        mconcat+            [ "command failed (exit "+            , show e.commandFailed_exitCode+            , "): "+            , show (cmdspec e.commandFailed_process)+            , "\nstdout:\n"+            , C8.unpack e.commandFailed_stdout+            , "\nstderr:\n"+            , C8.unpack e.commandFailed_stderr+            ]++instance Exception CommandFailed++{- | A minimal variant of 'CommandFailed' for call sites that only have a+human-readable label for what ran, not the full 'CreateProcess' (e.g. those+built on 'withBinaryIO', which hands back a raw 'ProcessHandle' rather than+a checked result — see "Salmon.Builtin.Nodes.WireGuard" for an example).+-}+data CommandFailedSimple = CommandFailedSimple String Int++instance Show CommandFailedSimple where+    show (CommandFailedSimple label n) = mconcat ["command failed (exit ", show n, "): ", label]++instance Exception CommandFailedSimple++checkExitCode :: String -> ExitCode -> IO ()+checkExitCode _ ExitSuccess = pure ()+checkExitCode label (ExitFailure n) = throwIO (CommandFailedSimple label n)++type RunningCommand = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)++{- | A more general Command where more side-effects are allowed to generate the command and more information is returned.+we recommend using Command until this is no longer practical+intended use case is to redirect inputs/outputs but the mechanism could be abused to significantly alter the command being run based on runtime info (i.e., best avoided)+arg and ioarg allow to split a deterministic arg, which can be directly tracked, and an ioarg that will exist only when executing up/down effects+-}+data CommandIO (wellKnownName :: Symbol) arg ioarg+    = CommandIO+    { prepareIO :: arg -> ioarg -> IO CreateProcess+    }++withBinaryIO :: Track' (Binary x) -> CommandIO x arg ioarg -> arg -> ((ioarg -> IO RunningCommand) -> Op) -> Op+withBinaryIO t cmd arg consumeIO =+    let mk a = (untrackedExecIO cmd a, Binary)+     in tracking t mk arg consumeIO++untrackedExecIO :: CommandIO x a ioarg -> a -> (ioarg -> IO RunningCommand)+untrackedExecIO binary arg = \ioarg -> do+    p <- prepareIO binary arg ioarg+    createProcess p
+ src/Salmon/Builtin/Nodes/Cabal.hs view
@@ -0,0 +1,170 @@+-- todo:+-- --cabal-file configuration+-- --optimization and profile modes+module Salmon.Builtin.Nodes.Cabal where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Data.Text (Text)+import qualified Data.Text as Text+import GHC.TypeLits (Symbol)++import System.FilePath (takeDirectory, (</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess, cwd, proc)++-------------------------------------------------------------------------------+data Report+    = CabalBuild !Cabal !Binary.Report+    | CabalInstall !Cabal !Binary.Report+    | CabalTest !Cabal !Binary.Report+    | CabalSDist !Cabal !Binary.Report+    | CabalUpload !CandidateStatus !FilePath !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------+data Cabal = Cabal {cabalDir :: FilePath, cabalTarget :: Text}+    deriving (Eq, Ord, Show)++type CabalFlags = [Flag]++data Flag+    = AllowNewer++data CabalRun+    = Build CabalFlags Cabal+    | Test Cabal+    | Install CabalFlags Cabal FilePath+    | SDist Cabal FilePath+    | Upload CandidateStatus FilePath++data CandidateStatus+    = Candidate+    | Public+    deriving (Show, Ord, Eq)++build :: Reporter Report -> Track' (Binary "cabal") -> CabalFlags -> Cabal -> Op+build r cabal flags c =+    withBinary cabal cabalRun (Build flags c) $ \up ->+        op "cabal-build" nodeps $ \actions ->+            actions+                { help = "cabal builds a target"+                , ref = mkRef "cabal-build" (show c)+                , up = up r'+                }+  where+    r' = contramap (CabalBuild c) r++install :: Reporter Report -> Track' (Binary "cabal") -> CabalFlags -> Cabal -> FilePath -> Op+install r cabal flags c installdir =+    withBinary cabal cabalRun (Install flags c installdir) $ \up ->+        op "cabal-install" previous $ \actions ->+            actions+                { help = "cabal builds a target"+                , ref = mkRef "cabal-install" (show c)+                , up = up r'+                }+  where+    r' = contramap (CabalInstall c) r+    previous = deps [dir (Directory installdir)]++test :: Reporter Report -> Track' (Binary "cabal") -> CabalFlags -> Cabal -> FilePath -> Op+test r cabal flags c installdir =+    withBinary cabal cabalRun (Test c) $ \up ->+        op "cabal-test" previous $ \actions ->+            actions+                { help = "cabal tests a target"+                , ref = mkRef "cabal-test" (show c)+                , up = up r'+                }+  where+    r' = contramap (CabalTest c) r+    previous = deps [dir (Directory installdir)]++sdist :: Reporter Report -> Track' (Binary "cabal") -> Cabal -> FilePath -> Op+sdist r cabal c dirpath =+    withBinary cabal cabalRun (SDist c dirpath) $ \up ->+        op "cabal-sdist" (deps [enclosingdir]) $ \actions ->+            actions+                { help = "cabal sdist a package"+                , ref = mkRef "cabal-sdist" (dirpath, c.cabalTarget)+                , up = up r'+                }+  where+    r' = contramap (CabalSDist c) r+    enclosingdir :: Op+    enclosingdir = dir (Directory dirpath)++upload :: Reporter Report -> Track' (Binary "cabal") -> Track' FilePath -> FilePath -> Op+upload r cabal mkTarfile path =+    withBinary cabal cabalRun (Upload Candidate path) $ \up ->+        op "cabal-upload" (deps [run mkTarfile path]) $ \actions ->+            actions+                { help = "cabal uploads a package"+                , ref = mkRef "cabal-upload" path+                , up = up r'+                }+  where+    r' = contramap (CabalUpload Candidate path) r++publish :: Reporter Report -> Track' (Binary "cabal") -> Track' FilePath -> FilePath -> Op+publish r cabal mkTarfile path =+    withBinary cabal cabalRun (Upload Public path) $ \up ->+        op "cabal-publishes" (deps [run mkTarfile path]) $ \actions ->+            actions+                { help = "cabal publishes a package"+                , ref = mkRef "cabal-publish" path+                , up = up r'+                }+  where+    r' = contramap (CabalUpload Public path) r++cabalRun :: Command "cabal" CabalRun+cabalRun = Command $ go+  where+    go (Build flags c) = (proc "cabal" (["build", Text.unpack c.cabalTarget] <> (extraArgs flags))){cwd = Just c.cabalDir}+    go (Test c) = (proc "cabal" ["test", Text.unpack c.cabalTarget]){cwd = Just c.cabalDir}+    go (Install flags c dir) = (proc "cabal" (["install", "--install-method=copy", "--overwrite-policy=always", "--installdir=" <> dir, Text.unpack c.cabalTarget] <> (extraArgs flags))){cwd = Just c.cabalDir}+    go (SDist c path) = (proc "cabal" ["sdist", "--output-directory=" <> path, Text.unpack c.cabalTarget]){cwd = Just c.cabalDir}+    go (Upload Candidate path) = (proc "cabal" ["upload", path])+    go (Upload Public path) = (proc "cabal" ["upload", "--publish", path])++    extraArgs :: CabalFlags -> [String]+    extraArgs xs = fmap extraArg xs++    extraArg :: Flag -> String+    extraArg AllowNewer = "--allow-newer"++data Instructions (s :: Symbol)+    = Instructions+    { installed_name :: Text+    , instructions_binary :: Track' (Binary "cabal")+    , instructions_cabal :: Cabal+    , instructions_cabal_flags :: CabalFlags+    , instructions_installdir :: FilePath+    }++data Installed (s :: Symbol)+    = Installed+    { installation_path :: FilePath+    }++installed :: Reporter Report -> Instructions a -> Tracked' (Installed a)+installed r instr =+    Tracked (Track $ const op) obj+  where+    op =+        install+            r+            instr.instructions_binary+            instr.instructions_cabal_flags+            instr.instructions_cabal+            instr.instructions_installdir+    installPath = instr.instructions_installdir </> Text.unpack instr.installed_name+    obj = Installed installPath
+ src/Salmon/Builtin/Nodes/Capabilities.hs view
@@ -0,0 +1,85 @@+{- | Linux file-capability primitives (@setcap@\/@getcap@) — for granting a+binary just enough privilege (e.g. @CAP_NET_ADMIN@ to create bridge/tap+devices, or @CAP_DAC_OVERRIDE@ for a 9p passthrough export to act on behalf+of any guest uid) to run some operation unprivileged, instead of requiring+the whole calling process to be root.+-}+module Salmon.Builtin.Nodes.Capabilities where++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Data.List (isInfixOf)+import Data.Text (Text)+import qualified Data.Text as Text++import GHC.IO.Exception (ExitCode (..))+import System.Process (readProcessWithExitCode)+import System.Process.ListLike (proc)++-------------------------------------------------------------------------------+data Report+    = RunSetcap !SetcapCommand !Binary.Report+    deriving (Show)++-- | A Linux capability name, e.g. @"cap_net_admin"@ (see @capabilities(7)@).+type Capability = Text++{- | Grants a binary a set of capabilities (@setcap \<caps\>+eip \<path\>@), so+it can perform privileged operations without the whole calling process+running as root. @setcap@ is a set rather than an add — reapplying the same+capability set is already idempotent — but *running* @setcap@ at all needs+@CAP_SETFCAP@ (in practice: root), so this still guards with 'check' to+avoid needing that privilege on every re-run once the capabilities are+already in place: the same "does the effect already exist" shape as+"Salmon.Builtin.Nodes.Netfilter".'Salmon.Builtin.Nodes.Netfilter.rule',+just guarding "needs privilege at all" instead of "isn't idempotent".++Capabilities set this way are stored as an extended attribute on the file —+they survive a reboot, but not a package upgrade that reinstalls the+binary (@apt upgrade@ replaces the underlying inode), which is exactly what+'check' re-detects and 'up' re-grants the next time this 'Op' runs.+-}+grantCapabilities :: Reporter Report -> Track' (Binary "setcap") -> FilePath -> [Capability] -> Op+grantCapabilities r setcapBin path caps =+    withBinary setcapBin runSetcap (SetCap path capText) $ \apply ->+        op "grant-capabilities" nodeps $ \actions ->+            actions+                { help = Text.pack $ "grants " <> Text.unpack capText <> " to " <> path+                , ref = mkRef "grant-capabilities" (path, capText)+                , check = skipIfCapabilitiesGranted path caps+                , up = apply r'+                , down = Binary.untrackedExec runSetcap (RemoveCap path) "" r'+                }+  where+    capText = Text.intercalate "," caps+    r' = contramap (RunSetcap (SetCap path capText)) r++{- | @getcap \<path\>@'s output lists every capability currently granted —+'Salmon.Actions.UpDown.Success' iff all of @caps@ already show up in it.+-}+skipIfCapabilitiesGranted :: FilePath -> [Capability] -> IO CheckResult+skipIfCapabilitiesGranted path caps = do+    (code, out, _err) <- readProcessWithExitCode "getcap" [path] ""+    pure $ case code of+        ExitSuccess | all (\c -> Text.unpack c `isInfixOf` out) caps -> Success+        _ -> Failure ("capabilities not granted on " <> Text.pack path)++-------------------------------------------------------------------------------+data SetcapCommand+    = SetCap FilePath Text+    | RemoveCap FilePath+    deriving (Show)++runSetcap :: Command "setcap" SetcapCommand+runSetcap = Command go+  where+    go (SetCap path capText) =+        proc "setcap" [Text.unpack capText <> "+eip", path]+    go (RemoveCap path) =+        proc "setcap" ["-r", path]
+ src/Salmon/Builtin/Nodes/Certificates.hs view
@@ -0,0 +1,372 @@+module Salmon.Builtin.Nodes.Certificates where++import Salmon.Actions.UpDown (CheckResult (..), skipIfFileExists)+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Control.Monad (void)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Encoding.Error as Text++import System.Directory (doesFileExist)+import System.Exit (ExitCode (..))+import System.FilePath (takeDirectory, (</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess, proc)++-------------------------------------------------------------------------------+data Report+    = RunOpenSSLCommand !OpenSSLCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++newtype Domain = Domain {getDomain :: Text}+    deriving (Show, Ord, Eq)++data KeyType+    = RSA2048+    | RSA4096+    deriving (Show, Ord, Eq)++data Key+    = Key+    { keyType :: KeyType+    , keyDir :: FilePath+    , keyName :: Text+    }+    deriving (Show, Ord, Eq)++data SigningRequest+    = SigningRequest+    { certDomain :: Domain+    , certKey :: Key+    , certCSRDir :: FilePath+    , certCSRName :: Text+    }+    deriving (Show, Ord, Eq)++csrPath :: SigningRequest -> FilePath+csrPath req = req.certCSRDir </> Text.unpack req.certCSRName++derPath :: SigningRequest -> FilePath+derPath req = csrPath req <> ".der"++data SelfSigned+    = SelfSigned+    { selfSignedPEMPath :: FilePath+    , selfSignedRequest :: SigningRequest+    }+    deriving (Show, Ord, Eq)++{- | A certificate authority salmon owns: a key, and a self-signed certificate+naming it.++This exists for the case where the /verifier/ and the /issuer/ are both+configured by the same graph, which public CAs (see+"Salmon.Builtin.Nodes.Acme") are no help with at all. The motivating one is+Postgres client-certificate authentication: the server is told to trust this+CA and nothing else, and each client gets a certificate from it whose+@CN@ /is/ the database role it logs in as.++Two things follow from it being a long-lived root. Its key lives in a+'retainedDir' like every other key here, so a teardown archives rather than+deletes it -- losing it invalidates nothing, but it does mean no certificate+can ever be issued again to the fleet that trusts it. And its validity is+explicit ('caValidityDays'), because a CA that outlives its leaves by less+than their own lifetime quietly breaks every renewal.+-}+data CertificateAuthority+    = CertificateAuthority+    { caKey :: Key+    , caCertPath :: FilePath+    , caCommonName :: Domain+    , caValidityDays :: Int+    }+    deriving (Show, Ord, Eq)++-- | A certificate signed by a 'CertificateAuthority' rather than by itself.+data CaSigned+    = CaSigned+    { caSignedPEMPath :: FilePath+    , caSignedRequest :: SigningRequest+    , caSignedAuthority :: CertificateAuthority+    , caSignedValidityDays :: Int+    }+    deriving (Show, Ord, Eq)++tlsKey :: Reporter Report -> Track' (Binary "openssl") -> Key -> Op+tlsKey r bin key =+    withBinary bin openssl cmd $ \up -> do+        op "certificate-key" (deps [enclosingdir]) $ \actions ->+            actions+                { help = "generate a certificate-key"+                , notes =+                    [ "does not delete keys on down"+                    ]+                , ref = mkRef "openssl" path+                , check = skipIfFileExists path+                , up = up r'+                }+  where+    cmd = GenTLSKey key.keyType path+    r' = contramap (RunOpenSSLCommand cmd) r+    path :: FilePath+    path = keyPath key++    -- retained rather than plain 'dir': tearing down a cert down the line+    -- should leave old key/cert material lying around under a timestamped+    -- name rather than deleting it.+    enclosingdir :: Op+    enclosingdir = retainedDir (Directory key.keyDir)++keyPath :: Key -> FilePath+keyPath key = key.keyDir </> Text.unpack key.keyName++signingRequest :: Reporter Report -> Track' (Binary "openssl") -> SigningRequest -> Op+signingRequest r bin req =+    withCommand (GenCSR kpath csrpath dom) $ \makeCSR ->+        withCommand (ConvertCSR2DER csrpath derpath) $ \convert ->+            op "certificate-csr" (deps [enclosingdir, tlsKey r bin req.certKey]) $ \actions ->+                actions+                    { help = "generate a certificate signing request"+                    , ref = mkRef "openssl-csr" csrpath+                    , up = void $ makeCSR >> convert+                    }+  where+    r' cmd = contramap (RunOpenSSLCommand cmd) r+    withCommand cmd f =+        let+            g :: (Reporter Binary.Report -> IO ()) -> Op+            g callbin = f (callbin (r' cmd))+         in+            withBinary bin openssl cmd g++    kpath :: FilePath+    kpath = keyPath req.certKey++    csrpath :: FilePath+    csrpath = csrPath req++    derpath :: FilePath+    derpath = derPath req++    enclosingdir :: Op+    enclosingdir = retainedDir (Directory csrdir)++    csrdir :: FilePath+    csrdir = req.certCSRDir++    dom :: Domain+    dom = req.certDomain++selfSign :: Reporter Report -> Track' (Binary "openssl") -> SelfSigned -> Op+selfSign r bin selfsigned =+    withBinary bin openssl cmd $ \up ->+        op "certificate-self-sign" (deps [signingRequest r bin selfsigned.selfSignedRequest]) $ \actions ->+            actions+                { help = "self sign a certificate"+                , ref = mkRef "openssl-selfsign" pempath+                , check = checkCertNotExpiringSoon pempath+                , up = up r'+                }+  where+    cmd = SignCSR csr key pempath+    r' = contramap (RunOpenSSLCommand cmd) r+    key :: FilePath+    key = keyPath selfsigned.selfSignedRequest.certKey++    csr :: FilePath+    csr = csrPath selfsigned.selfSignedRequest++    pempath :: FilePath+    pempath = selfsigned.selfSignedPEMPath++{- | Generates the CA's own self-signed certificate (its key comes from+'tlsKey', as a dependency).++Unlike 'selfSign' this goes through @openssl req -x509@ rather than+@openssl x509 -req@, which is what marks the result as a CA+(@basicConstraints=critical,CA:TRUE@ is added by @req -x509@) -- a+certificate signed the other way is not accepted as an issuer, however much+it looks like one.+-}+certificateAuthority :: Reporter Report -> Track' (Binary "openssl") -> CertificateAuthority -> Op+certificateAuthority r bin ca =+    withBinary bin openssl cmd $ \up ->+        op "certificate-authority" (deps [enclosingdir, tlsKey r bin ca.caKey]) $ \actions ->+            actions+                { help = "self-signs the CA certificate " <> getDomain ca.caCommonName+                , notes = ["losing this key means nothing can ever be issued to the fleet that trusts it"]+                , ref = mkRef "openssl-ca" ca.caCertPath+                , check = checkCertNotExpiringSoon ca.caCertPath+                , up = up r'+                }+  where+    cmd = GenSelfSignedCa (keyPath ca.caKey) ca.caCertPath ca.caCommonName ca.caValidityDays+    r' = contramap (RunOpenSSLCommand cmd) r++    enclosingdir :: Op+    enclosingdir = retainedDir (Directory (takeDirectory ca.caCertPath))++{- | Signs a 'SigningRequest' with a 'CertificateAuthority'.++The @CN@ that ends up in the certificate is the request's+'certDomain' -- which, for a Postgres client certificate, is not a domain at+all but the database role the holder will be authenticated as. 'Domain' is+just the @CN@ under an older name; nothing here parses it.++The authority arrives as a 'Track'' rather than being built here, because+the two cases a caller has are genuinely different graphs: a CA this graph+also creates (pass @Track (certificateAuthority r bin)@) and one that was+provisioned out of band and is simply present (pass 'ignoreTrack'). Baking+in the first would make the second declare a node that tries to overwrite+somebody else's root.+-}+caSign :: Reporter Report -> Track' (Binary "openssl") -> Track' CertificateAuthority -> CaSigned -> Op+caSign r bin caTrack signed =+    withBinary bin openssl cmd $ \up ->+        op "certificate-ca-sign" (deps [signingRequest r bin signed.caSignedRequest, run caTrack ca]) $ \actions ->+            actions+                { help = "signs " <> getDomain signed.caSignedRequest.certDomain <> " with CA " <> getDomain ca.caCommonName+                , ref = mkRef "openssl-ca-sign" signed.caSignedPEMPath+                , check = checkCertNotExpiringSoon signed.caSignedPEMPath+                , up = up r'+                }+  where+    ca = signed.caSignedAuthority+    cmd =+        SignCSRWithCa+            (csrPath signed.caSignedRequest)+            ca.caCertPath+            (keyPath ca.caKey)+            signed.caSignedPEMPath+            signed.caSignedValidityDays+    r' = contramap (RunOpenSSLCommand cmd) r++{- | 'Failure' if @path@ is missing, or if the certificate there is already+expired or will expire within a day (@openssl x509 -checkend 86400@) —+'Success' otherwise. Used in place of a plain 'skipIfFileExists' wherever a+node's effect is a certificate rather than an arbitrary file, so an+out-of-date self-signed or ACME-signed certificate is noticed and+regenerated rather than being treated as satisfied forever after the first+run. See "Salmon.Builtin.Nodes.Acme".@acmeChallenge_dns01@ for the ACME+side.+-}+checkCertNotExpiringSoon :: FilePath -> IO CheckResult+checkCertNotExpiringSoon path = do+    exists <- doesFileExist path+    if not exists+        then pure (Failure $ "missing: " <> Text.pack path)+        else do+            (code, _out, err) <-+                readCreateProcessWithExitCode+                    (proc "openssl" ["x509", "-checkend", "86400", "-noout", "-in", path])+                    ""+            pure $ case code of+                ExitSuccess -> Success+                ExitFailure _ ->+                    Failure $+                        "expired or expiring within a day: "+                            <> Text.pack path+                            <> ": "+                            <> Text.decodeUtf8With Text.lenientDecode err++data OpenSSLCommand+    = GenCSR FilePath FilePath Domain+    | ConvertCSR2DER FilePath FilePath+    | SignCSR FilePath FilePath FilePath+    | GenTLSKey KeyType FilePath+    | -- | key, output cert, CN, days+      GenSelfSignedCa FilePath FilePath Domain Int+    | -- | CSR, CA cert, CA key, output cert, days+      SignCSRWithCa FilePath FilePath FilePath FilePath Int+    deriving (Show)++openssl :: Command "openssl" OpenSSLCommand+openssl = Command $ \cmd ->+    case cmd of+        (GenTLSKey kt filepath) ->+            case kt of+                RSA2048 -> proc "openssl" ["genrsa", "-out", filepath, "2048"]+                RSA4096 -> proc "openssl" ["genrsa", "-out", filepath, "4096"]+        (GenCSR keyPath csrPath dom) ->+            proc+                "openssl"+                [ "req"+                , "-new"+                , "-key"+                , keyPath+                , "-out"+                , csrPath+                , "-subj"+                , Text.unpack $ "/CN=" <> getDomain dom+                ]+        (ConvertCSR2DER csrPath derPath) ->+            proc+                "openssl"+                [ "req"+                , "-in"+                , csrPath+                , "-outform"+                , "DER"+                , "-out"+                , derPath+                ]+        (SignCSR csrPath keyPath pemPath) ->+            proc+                "openssl"+                [ "x509"+                , "-req"+                , "-in"+                , csrPath+                , "-signkey"+                , keyPath+                , "-out"+                , pemPath+                ]+        (GenSelfSignedCa keyPath certPath dom days) ->+            proc+                "openssl"+                [ "req"+                , "-x509"+                , "-new"+                , "-sha256"+                , "-key"+                , keyPath+                , "-days"+                , show days+                , "-subj"+                , Text.unpack $ "/CN=" <> getDomain dom+                , "-out"+                , certPath+                ]+        (SignCSRWithCa csrPath caCertPath caKeyPath pemPath days) ->+            proc+                "openssl"+                [ "x509"+                , "-req"+                , "-sha256"+                , "-in"+                , csrPath+                , "-CA"+                , caCertPath+                , "-CAkey"+                , caKeyPath+                , -- without a serial file openssl refuses outright; with+                  -- this it creates one next to the CA cert and increments+                  -- it, which is what makes two certificates issued to the+                  -- same CN distinguishable at revocation time.+                  "-CAcreateserial"+                , "-days"+                , show days+                , "-out"+                , pemPath+                ]
+ src/Salmon/Builtin/Nodes/Continuation.hs view
@@ -0,0 +1,32 @@+{- | for step processes where we need a special dance+the continuation itself is gonna be opaque+however the continuation setup itself may carry dependencies++it's basically dependency injection where the in-code dependency-injection+setup requires a concrete Operation++the implementation uses a Token that cannot be instanciated, hence forcing+to return a dependency-injected Op.+-}+module Salmon.Builtin.Nodes.Continuation (+    Continue (..),+    withContinuation,+) where++import GHC.TypeLits (Symbol)++import Salmon.Builtin.Extension+import Salmon.Op.OpGraph+import Salmon.Op.Track++data Token (sym :: Symbol) = Token++data Continue (sym :: Symbol) obj+    = Continue+    { tracked :: Track' (Token sym)+    , continue :: obj+    }++withContinuation :: forall a b. Continue a b -> (b -> Op) -> Op+withContinuation (Continue t cont) f =+    f cont `inject` run t (Token @a)
+ src/Salmon/Builtin/Nodes/CronTask.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DeriveGeneric #-}++module Salmon.Builtin.Nodes.CronTask where++import Data.Aeson (FromJSON, ToJSON)+import qualified Data.ByteString as ByteString+import GHC.Generics (Generic)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Salmon.Builtin.Extension+import Salmon.Op.Ref+import Salmon.Op.Track+import System.Directory (removeFile)+import System.FilePath ((</>))++type Minute = Text+type Hour = Text+type DOM = Text+type Month = Text+type DOW = Text++data Schedule+    = Schedule+    { minute :: Minute+    , hour :: Hour+    , dayOfMonth :: DOM+    , month :: Month+    , dayOfWeek :: DOW+    }+    deriving (Eq, Show, Generic)++instance FromJSON Schedule+instance ToJSON Schedule++everyMinute :: Schedule+everyMinute = Schedule "*" "*" "*" "*" "*"++-- | Every hour, on the given minute.+hourlyAt :: Minute -> Schedule+hourlyAt m = Schedule m "*" "*" "*" "*"++{- | Once a day, at the given hour and minute.++Both are taken rather than defaulted because a fleet of boxes all backing up+at @0 0@ is a self-inflicted thundering herd against whatever the dumps are+copied to.+-}+dailyAt :: Hour -> Minute -> Schedule+dailyAt h m = Schedule m h "*" "*" "*"++-- | Once a week, on a given day (@0@ or @7@ is Sunday).+weeklyAt :: DOW -> Hour -> Minute -> Schedule+weeklyAt d h m = Schedule m h "*" "*" d++data CronTask+    = CronTask+    { name :: Text+    , user :: Text+    , schedule :: Schedule+    , command :: FilePath+    , commandArgs :: [Text]+    }++platformCronPath :: FilePath+platformCronPath = "/etc/cron.d"++crontask :: Track' CronTask -> CronTask -> Op+crontask t task =+    op "crontask" (deps [run t task]) $ \actions ->+        actions+            { help = "setup " <> cmd <> " at " <> Text.pack path+            , ref = mkRef "crontask" path+            , up = up+            , down = removeFile path+            }+  where+    path :: FilePath+    path = platformCronPath </> Text.unpack (mconcat ["salmon-", task.name])++    cmd :: Text+    cmd = Text.pack task.command++    up :: IO ()+    up = ByteString.writeFile path $ Text.encodeUtf8 contents++    contents :: Text+    contents =+        Text.unlines+            [ "# salmon-task: " <> task.name+            , renderTask task+            ]++    renderTask :: CronTask -> Text+    renderTask task =+        Text.unwords+            [ renderSchedule task.schedule+            , task.user+            , cmd+            , Text.unwords task.commandArgs+            ]++    renderSchedule :: Schedule -> Text+    renderSchedule sched =+        Text.unwords+            [ sched.minute+            , sched.hour+            , sched.dayOfMonth+            , sched.month+            , sched.dayOfWeek+            ]
+ src/Salmon/Builtin/Nodes/Daemon.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | A process salmon owns and keeps running.++Every other builtin here is a one-shot idempotent action: @up@ runs to+completion and returns, and what it left behind — a file, a database role, a+route — stays put on its own. A long-running process does not. Nothing keeps+it alive but something watching it, which is why+"Salmon.Builtin.Nodes.Systemd" hands the whole problem to systemd rather+than solving it.++This is for where there is no systemd to hand it to: a container, a test+harness, or the supervisor of @specs\/salmon-as-init.md@. It fills in+'Salmon.Builtin.Extension.managed', so the node's own thread is in scope for+the process's entire lifetime and the handle never has to escape — which is+what makes ownership possible at all, and what @up :: IO ()@ (which ran and+returned into nothing) could not offer.++= Three things ownership buys over polling a @check@++Supervising an /unowned/ effect — a systemd unit, a container, a service on+another host — is a @check@ and a re-@up@, and "Salmon.Actions.Upkeep"+already does it. For a process salmon started itself that is a poor answer:++* __the exit status.__ A @check@ answers alive-or-dead; waiting on the+  process answers @ExitFailure 137@, which is the difference between+  restarting a service and respecting its decision to stop;+* __timeliness.__ The upkeep delay backs /off/ on success, to a minute. A+  service that dies a second after a successful check would stay dead for+  that minute;+* __identity.__ A pidfile plus @kill -0@ cannot survive pid reuse, and cannot+  tell a live process from a zombie. Here the pid is a local variable on the+  owning thread's stack, which is why no pid table appears anywhere in this+  design.++= Stopping is an escalation, not a @cancel@++Teardown is cancelling the node's thread, and the bracket in 'runDaemon' is+what does the killing — but a @cancel@ on its own is not a stop.+'System.Process.withCreateProcess' sends @SIGTERM@ and waits, and a service+that ignores @SIGTERM@ then wedges the teardown behind it. So: signal the+process __group__, wait 'stop_grace', then @SIGKILL@ and wait again. The+group matters as much as the escalation — a service that forks workers has to+take them with it, which is why 'runDaemon' forces @create_group@ on+regardless of what the caller's 'CreateProcess' said.++This is recovered rather than invented: it is what the removed+@Salmon.Builtin.Nodes.Supervised@ did, at @f9d7116@.++= Under a one-shot driver, this node fails on purpose++@run up@\/@run down@ call 'Salmon.Builtin.Extension.up', and a synchronous+one-pass driver has nowhere to put an action that never returns. So 'daemon'+throws 'NeedsSupervisor' from @up@ rather than no-oping: a node that cannot+be brought up by this driver should say so loudly, per CLAUDE.md's "failure+must not be swallowed". @run serve@ (which routes managed nodes to+"Salmon.Actions.Upkeep" and never calls their @up@) is the driver that can+hold one.++@down@ is the other way round and it is not an inconsistency: under @serve@+the process died when the machine holding it was cancelled, and under+@run down@ this process never held one — so there is genuinely nothing here+to stop, and @pure ()@ is the true answer rather than a swallowed failure.+The gap it leaves is a process left behind by a @serve@ that has since+exited, which nothing in v1 can recover: recovering it needs the pidfile+convention @specs\/per-node-state-machines.md@ lists under non-goals.+-}+module Salmon.Builtin.Nodes.Daemon (+    -- * The node+    Daemon (..),+    defaultDaemon,+    daemon,+    daemonRef,++    -- * How it stops+    Stop (..),+    defaultStop,++    -- * The action, for building your own node on+    runDaemon,++    -- * Observing+    Report (..),+    NeedsSupervisor (..),+) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (withAsync)+import Control.Exception (Exception, SomeException, bracket, throwIO, try)+import Control.Monad (void)+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Clock (getMonotonicTimeNSec)+import System.Exit (ExitCode (..))+import System.IO (Handle, hIsEOF)+import qualified System.IO as IO+import System.Posix.Signals (Signal, sigKILL, sigTERM, signalProcessGroup)+import System.Process (CreateProcess (..), Pid, ProcessHandle, StdStream (..), createProcess, getPid, getProcessExitCode, waitForProcess)++import Salmon.Builtin.Extension+import Salmon.Op.Ref (Ref, mkRef)+import Salmon.Op.Supervision (Micros (..), millis, seconds)+import Salmon.Reporter++-------------------------------------------------------------------------------++-- | How to stop a process that will not stop on its own.+data Stop = Stop+    { stop_signal :: !Signal+    -- ^ sent to the process /group/ first, politely.+    , stop_grace :: !Micros+    -- ^ how long to let it go on its own before @SIGKILL@.+    }++-- | @SIGTERM@, then five seconds, then @SIGKILL@.+defaultStop :: Stop+defaultStop = Stop sigTERM (seconds 5)++data Daemon = Daemon+    { daemon_name :: !Text+    -- ^ names it in reports, and is its 'Ref' — so it is the identity of the+    -- /effect site/, not of the command line. Two declarations giving one+    -- name two different commands are one node, and the magma's+    -- last-writer-wins picks between them; see @Salmon.Op.Dag@.+    , daemon_process :: !CreateProcess+    -- ^ @create_group@ is forced on when this is spawned, whatever it says.+    , daemon_stop :: !Stop+    , daemon_capture :: !Bool+    -- ^ pipe stdout and stderr into the node's own bounded ring, a line at a+    -- time. Worth having on: it is what an operator reads when the node has+    -- failed, and it is what tells a watchdog that a slow node is making+    -- progress rather than wedged. Turn it off for a process whose output+    -- should go where it would have gone anyway (a container's stdout, say),+    -- since capturing it here means it no longer reaches the parent's.+    }++-- | 'daemon_capture' on, 'defaultStop'.+defaultDaemon :: Text -> CreateProcess -> Daemon+defaultDaemon name cp = Daemon name cp defaultStop True++daemonRef :: Daemon -> Ref+daemonRef d = mkRef "daemon" d.daemon_name++data Report+    = Spawned !Text !(Maybe Pid)+    | -- | one line the process wrote (only with 'daemon_capture')+      Wrote !Text !Text+    | Exited !Text !ExitCode+    | -- | asked it to stop+      Signalling !Text !Signal+    | -- | it did not go within 'stop_grace'+      Killing !Text+    | Reaped !Text+    deriving (Show)++{- | Thrown by 'daemon''s @up@: this node cannot be brought up by a driver+that cannot hold a running action.+-}+newtype NeedsSupervisor = NeedsSupervisor Text++instance Show NeedsSupervisor where+    show (NeedsSupervisor name) =+        mconcat+            [ Text.unpack name+            , " is a process salmon owns, so it can only be brought up by a driver that can"+            , " hold it running (`run serve`). A one-shot `run up` has nowhere to put it."+            ]++instance Exception NeedsSupervisor++-------------------------------------------------------------------------------++daemon :: Reporter Report -> Daemon -> Op+daemon r d =+    op "daemon" nodeps $ \actions ->+        actions+            { help = "keeps " <> d.daemon_name <> " running"+            , ref = daemonRef d+            , managed = Just (runDaemon r d)+            , -- see the module header: loud rather than a silent no-op.+              up = throwIO (NeedsSupervisor d.daemon_name)+            , -- ...and, equally deliberately, not loud. There is nothing for+              -- a one-shot teardown to stop.+              down = pure ()+            }++{- | Spawn the process and block until it exits, tearing it down through the+bracket if this thread is cancelled.++Exposed because a node that wants more than 'daemon' offers — a @check@ of+its own, dependencies, a richer 'Ref' key — should build its own 'Op' around+this rather than reimplement the escalation:++@+op "webserver" (deps [config]) $ \\actions ->+    actions+        { ref = mkRef "webserver" name+        , managed = Just (runDaemon reportPrint d)+        , check = probeHttp url+        , up = throwIO (NeedsSupervisor name)+        }+@+-}+runDaemon :: Reporter Report -> Daemon -> Output -> IO ExitCode+runDaemon r d out =+    bracket spawn teardown wait+  where+    name = d.daemon_name++    cp :: CreateProcess+    cp =+        d.daemon_process+            { -- so the whole group goes: a service that forks workers must+              -- take them with it.+              create_group = True+            , std_out = if d.daemon_capture then CreatePipe else std_out d.daemon_process+            , std_err = if d.daemon_capture then CreatePipe else std_err d.daemon_process+            }++    spawn :: IO (Maybe Handle, Maybe Handle, ProcessHandle, Maybe Pid)+    spawn = do+        (_, mout, merr, ph) <- createProcess cp+        pid <- getPid ph+        runReporter r (Spawned name pid)+        pure (mout, merr, ph, pid)++    {- | Reading the pipes has to happen /while/ waiting, not after, or a+    process that fills a pipe buffer blocks forever and the node looks+    wedged for a reason nobody could see. 'withAsync' also means the readers+    go when the bracket does. -}+    wait :: (Maybe Handle, Maybe Handle, ProcessHandle, Maybe Pid) -> IO ExitCode+    wait (mout, merr, ph, _) =+        drain mout $+            drain merr $ do+                code <- waitForProcess ph+                runReporter r (Exited name code)+                pure code++    drain :: Maybe Handle -> IO a -> IO a+    drain Nothing k = k+    drain (Just h) k = withAsync (pump h) (const k)++    pump :: Handle -> IO ()+    pump h = do+        -- a process writing invalid UTF-8, or a handle closed under us, must+        -- not take the node down with it.+        _ <- try @SomeException go+        pure ()+      where+        go = do+            IO.hSetBuffering h IO.LineBuffering+            loop+        loop = do+            eof <- hIsEOF h+            if eof+                then pure ()+                else do+                    line <- Text.pack <$> IO.hGetLine h+                    out line+                    runReporter r (Wrote name line)+                    loop++    {- | @SIGTERM@ the group, wait, then @SIGKILL@ it and wait again.++    Signalling the group by pid rather than closing the handle is what makes+    the escalation possible at all: 'System.Process.terminateProcess' signals+    only the leader, and 'System.Process.withCreateProcess'\'s own cleanup+    waits indefinitely for a process that has decided to ignore it. -}+    teardown :: (Maybe Handle, Maybe Handle, ProcessHandle, Maybe Pid) -> IO ()+    teardown (_, _, ph, mpid) = do+        alive <- getProcessExitCode ph+        case (alive, mpid) of+            -- it exited on its own; nothing to stop, and `wait` has the code.+            (Just _, _) -> pure ()+            (Nothing, Nothing) -> pure ()+            (Nothing, Just pid) -> do+                runReporter r (Signalling name d.daemon_stop.stop_signal)+                signal d.daemon_stop.stop_signal pid+                gone <- waitGone ph d.daemon_stop.stop_grace+                if gone+                    then runReporter r (Reaped name)+                    else do+                        runReporter r (Killing name)+                        signal sigKILL pid+                        void (waitGone ph d.daemon_stop.stop_grace)+                        runReporter r (Reaped name)++    -- signalling a group that has already gone is not an error worth+    -- propagating out of a teardown.+    signal :: Signal -> Pid -> IO ()+    signal sig pid = void (try @SomeException (signalProcessGroup sig pid))++{- | Poll for the process to be gone, up to a deadline.++Polling rather than a second 'waitForProcess': this runs from a @bracket@+release while an async exception is in flight, and the thread that /was/+waiting on the handle has just been interrupted. Polling asks nothing of+whether two waits on one handle compose.+-}+waitGone :: ProcessHandle -> Micros -> IO Bool+waitGone ph grace = do+    deadline <- (+ toNanos grace) <$> getMonotonicTimeNSec+    go deadline+  where+    toNanos (Micros n) = fromIntegral n * 1000+    go deadline = do+        code <- getProcessExitCode ph+        case code of+            Just _ -> pure True+            Nothing -> do+                now <- getMonotonicTimeNSec+                if now >= deadline+                    then pure False+                    else threadDelay (unMicros (millis 20)) >> go deadline
+ src/Salmon/Builtin/Nodes/Debian/AptRepository.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE OverloadedStrings #-}++{- | An external apt repository as a node: a deb822 @.sources@ file naming a+pre-provisioned signing key, an optional @preferences.d@ pin, and the+@apt-get update@ that makes the index know about it.++Nothing here decides /whether/ a recipe wants an external repository — that+is a risk somebody has to choose to take. A recipe that needs packages from+one takes a @'Salmon.Builtin.Extension.Track'' 'AptRepository'@ argument and+its author (or its seed) passes 'aptRepositoryTrack' to take the risk, or+'Salmon.Builtin.Extension.ignoreTrack' to require that the package is+installable already. See 'pgdg' for the first user.++= What the node refuses++* __A key whose fingerprint is not the declared one.__ The key is a file+  somebody provisioned (this module does not care how it got there: rsync,+  a secret store, the repository's own download page), and the fingerprint+  is what the declaration was written against. It is read with+  @gpg --show-keys --with-colons@ before the key is installed, and a+  mismatch throws 'KeyFingerprintMismatch'. Only /primary/ keys count: a+  subkey's fingerprint is not a statement about who published the file.+  The fingerprint is __declared, never read from a file next to the key__,+  because a pin that travels with the thing it pins pins nothing.+* __Shadowing the distribution.__ A repository that carries packages the+  distribution also has (PGDG ships @postgresql-<major>@) wins by version+  under apt's default priorities. So the default 'Pinning' is+  'OnlyPackages': the repository is pinned to priority 1 for everything and+  500 for the named patterns, and the whole suite ('WholeSuite') is an+  explicit choice.++= down++Removes the sources file, the preference file and the key. Packages that were+installed from the repository are left alone (removing them is the business+of whichever node installed them), and no @apt-get update@ is run: the stale+index entries go on the next update anybody runs.++= Requirements on the machine++@gpg@ (the @gpg@ package on Debian), and root for anything outside a test+root. 'aptRepository' does not install @gpg@ itself: tearing the repository+down should not uninstall a tool something else may be using.+-}+module Salmon.Builtin.Nodes.Debian.AptRepository (+    AptRepository (..),+    Suite (..),+    Pinning (..),+    KeyFingerprintMismatch (..),+    aptRepository,+    aptRepositoryTrack,+    viaRepository,+    pgdg,++    -- * Pieces, exposed for tests+    renderSources,+    renderPreferences,+    resolveSuite,+    parseOsReleaseCodename,+    primaryFingerprints,+    normalizeFingerprint,+    repositoryHost,+    listsPrefix,+    keyDestination,+    sourcesPath,+    preferencesPath,+) where++import Control.Exception (Exception, throwIO)+import Control.Monad (unless, when)+import qualified Data.ByteString as ByteString+import Data.Foldable (toList)+import qualified Data.List.NonEmpty as NEList+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import GHC.IO.Exception (ExitCode (..))+import System.Directory (+    createDirectoryIfMissing,+    doesDirectoryExist,+    doesFileExist,+    getModificationTime,+    listDirectory,+ )+import System.FilePath (takeDirectory, takeExtension, (</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (proc)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Filesystem (FileContents (..), checkFileContents, removeFileIfPresent)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Op.Ref+import Salmon.Op.Track (Track (..))++-- | How the repository's suite is spelled.+data Suite+    = -- | The machine's @VERSION_CODENAME@ (from @/etc/os-release@, read when+      -- the node runs, not when the directive is written) followed by this+      -- suffix: @CodenameSuffixed "-pgdg"@ is @bookworm-pgdg@ on bookworm.+      CodenameSuffixed Text+    | -- | A suite that does not depend on the machine.+      FixedSuite Text+    deriving (Eq, Show)++-- | What the repository is allowed to supply.+data Pinning+    = -- | Only packages matching these patterns (apt's @Package:@ globs,+      -- e.g. @postgresql-*-pgvector@) are taken from the repository; every+      -- other package it carries stays at priority 1, i.e. is installed+      -- from it only when nothing else has it.+      OnlyPackages (NEList.NonEmpty Text)+    | -- | No preference file: the whole suite competes at apt's default+      -- priority, and a newer version there wins over the distribution's.+      WholeSuite+    deriving (Eq, Show)++data AptRepository = AptRepository+    { repoName :: Text+    -- ^ Stem of every file the node writes (@\<name\>.sources@, the key, the+    -- preference file); also the node's identity.+    , repoUris :: Text+    , repoSuite :: Suite+    , repoComponents :: [Text]+    , repoKeyFile :: FilePath+    -- ^ The pre-provisioned key (armored @.asc@ or binary @.gpg@; the+    -- extension is kept on the installed copy, since apt tells them apart+    -- by it).+    , repoKeyFingerprint :: Text+    -- ^ Full primary-key fingerprint, spaces and case ignored.+    , repoPin :: Pinning+    , repoAptDir :: FilePath+    -- ^ @/etc/apt@; a field so that a test can aim the node at a temporary+    -- directory.+    , repoListsDir :: FilePath+    -- ^ @/var/lib/apt/lists@, where the refreshed index shows up.+    }+    deriving (Eq, Show)++-- | The PostgreSQL project's repository (@apt.postgresql.org@), pinned to+-- @postgresql-*-pgvector@ only. Override 'repoPin' for other packages. The+-- fingerprint is the caller's to declare; see the module header for why it+-- is not baked in.+pgdg :: FilePath -> Text -> AptRepository+pgdg keyFile fingerprint =+    AptRepository+        { repoName = "pgdg"+        , repoUris = "https://apt.postgresql.org/pub/repos/apt"+        , repoSuite = CodenameSuffixed "-pgdg"+        , repoComponents = ["main"]+        , repoKeyFile = keyFile+        , repoKeyFingerprint = fingerprint+        , repoPin = OnlyPackages ("postgresql-*-pgvector" NEList.:| [])+        , repoAptDir = "/etc/apt"+        , repoListsDir = "/var/lib/apt/lists"+        }++-- | The value to pass where a recipe takes @Track' AptRepository@ and its+-- author decided to take the risk of the external repository.+aptRepositoryTrack :: Track' AptRepository+aptRepositoryTrack = Track aptRepository++-- | For a builtin that takes its package source as a @'Track'' ()@: provision+-- this repository first. Its counterpart for \"the package is already+-- installable\" is 'Salmon.Builtin.Extension.ignoreTrack'.+viaRepository :: AptRepository -> Track' ()+viaRepository = Track . const . aptRepository++-- | Thrown before a key is installed when none of its primary-key+-- fingerprints is the declared one.+data KeyFingerprintMismatch = KeyFingerprintMismatch+    { mismatchFile :: FilePath+    , mismatchDeclared :: Text+    , mismatchFound :: [Text]+    }++instance Show KeyFingerprintMismatch where+    show e =+        "key fingerprint mismatch for "+            <> e.mismatchFile+            <> ": declared "+            <> Text.unpack e.mismatchDeclared+            <> ", file has "+            <> (if null e.mismatchFound then "no primary key" else Text.unpack (Text.intercalate ", " e.mismatchFound))++instance Exception KeyFingerprintMismatch++-- | Key, then sources file (and preference file), then the index refresh.+-- The node returned is the refresh: depending on it is depending on the+-- repository being usable.+aptRepository :: AptRepository -> Op+aptRepository repo =+    op "apt-repository" (deps [sourcesNode, preferencesNode]) $ \actions ->+        actions+            { help = "refreshes the apt index for " <> repo.repoName+            , notes =+                [ "repository: " <> repo.repoUris+                , "key fingerprint pinned: " <> normalizeFingerprint repo.repoKeyFingerprint+                , case repo.repoPin of+                    OnlyPackages ps -> "only packages: " <> Text.unwords (toList ps)+                    WholeSuite -> "whole suite (no pin)"+                ]+            , ref = mkRef "apt-repository-index" repo.repoName+            , check = checkIndexFresh repo+            , up = runAptUpdate+            , down = pure ()+            }+  where+    keyNode = keyOp repo+    sourcesNode = sourcesOp repo keyNode+    preferencesNode = preferencesOp repo++keyOp :: AptRepository -> Op+keyOp repo =+    op "apt-repository-key" nodeps $ \actions ->+        actions+            { help = "installs the signing key for " <> repo.repoName+            , notes = ["pinned fingerprint: " <> normalizeFingerprint repo.repoKeyFingerprint]+            , ref = mkRef "apt-repository-key" dest+            , check = checkKey+            , up = do+                verifyKeyFingerprint repo.repoKeyFile repo.repoKeyFingerprint+                key <- ByteString.readFile repo.repoKeyFile+                createDirectoryIfMissing True (takeDirectory dest)+                ByteString.writeFile dest key+            , down = removeFileIfPresent dest+            }+  where+    dest = keyDestination repo++    checkKey :: IO CheckResult+    checkKey = do+        installed <- doesFileExist dest+        if not installed+            then pure (Failure ("missing: " <> Text.pack dest))+            else do+                a <- ByteString.readFile repo.repoKeyFile+                b <- ByteString.readFile dest+                pure $+                    if a == b+                        then Success+                        else Failure ("contents differ: " <> Text.pack dest)++sourcesOp :: AptRepository -> Op -> Op+sourcesOp repo keyNode =+    op "apt-repository-sources" (deps [keyNode]) $ \actions ->+        actions+            { help = "writes " <> Text.pack path+            , notes = ["suite is derived from /etc/os-release when this runs"]+            , ref = mkRef "apt-repository-sources" path+            , check = checkFileContents fc+            , up = do+                bytes <- rendered+                createDirectoryIfMissing True (takeDirectory path)+                ByteString.writeFile path bytes+            , down = removeFileIfPresent path+            }+  where+    path = sourcesPath repo+    rendered :: IO ByteString.ByteString+    rendered = do+        suite <- resolveSuite repo.repoSuite <$> readCodename+        pure (Text.encodeUtf8 (renderSources repo suite))+    fc :: FileContents (IO ByteString.ByteString)+    fc = FileContents path rendered++preferencesOp :: AptRepository -> Op+preferencesOp repo = case repo.repoPin of+    WholeSuite -> realNoop+    OnlyPackages pats ->+        op "apt-repository-preferences" nodeps $ \actions ->+            actions+                { help = "writes " <> Text.pack path+                , ref = mkRef "apt-repository-preferences" path+                , check = checkFileContents (FileContents path body)+                , up = do+                    createDirectoryIfMissing True (takeDirectory path)+                    ByteString.writeFile path body+                , down = removeFileIfPresent path+                }+      where+        body = Text.encodeUtf8 (renderPreferences repo pats)+  where+    path = preferencesPath repo++-------------------------------------------------------------------------------++sourcesPath, preferencesPath, keyDestination :: AptRepository -> FilePath+sourcesPath repo = repo.repoAptDir </> "sources.list.d" </> Text.unpack repo.repoName <> ".sources"+preferencesPath repo = repo.repoAptDir </> "preferences.d" </> Text.unpack repo.repoName <> ".pref"+keyDestination repo =+    repo.repoAptDir </> "keyrings" </> Text.unpack repo.repoName <> ext+  where+    ext = case takeExtension repo.repoKeyFile of+        "" -> ".gpg"+        e -> e++-- | The deb822 stanza, for a suite already resolved.+renderSources :: AptRepository -> Text -> Text+renderSources repo suite =+    Text.unlines+        [ "Types: deb"+        , "URIs: " <> repo.repoUris+        , "Suites: " <> suite+        , "Components: " <> Text.unwords repo.repoComponents+        , "Signed-By: " <> Text.pack (keyDestination repo)+        ]++-- | Priority 1 for the whole origin, then 500 for each named pattern.+renderPreferences :: AptRepository -> NEList.NonEmpty Text -> Text+renderPreferences repo pats =+    Text.intercalate "\n" (stanza "*" 1 : [stanza p 500 | p <- toList pats])+  where+    stanza pat prio =+        Text.unlines+            [ "Package: " <> pat+            , "Pin: origin " <> repositoryHost repo.repoUris+            , "Pin-Priority: " <> Text.pack (show (prio :: Int))+            ]++resolveSuite :: Suite -> Text -> Text+resolveSuite (FixedSuite s) _ = s+resolveSuite (CodenameSuffixed suffix) codename = codename <> suffix++-- | @VERSION_CODENAME@ from an @os-release@ file's text, unquoted.+parseOsReleaseCodename :: Text -> Maybe Text+parseOsReleaseCodename contents =+    case [Text.strip v | l <- Text.lines contents, Just v <- [Text.stripPrefix "VERSION_CODENAME=" (Text.strip l)]] of+        (v : _) | not (Text.null (unquote v)) -> Just (unquote v)+        _ -> Nothing+  where+    unquote = Text.dropAround (`elem` ['"', '\''])++readCodename :: IO Text+readCodename = do+    contents <- Text.decodeUtf8 <$> ByteString.readFile "/etc/os-release"+    maybe (ioError (userError "apt repository: no VERSION_CODENAME in /etc/os-release")) pure (parseOsReleaseCodename contents)++-- | The host part of a URI: what a @Pin: origin@ line matches.+repositoryHost :: Text -> Text+repositoryHost uri = Text.takeWhile (/= '/') (afterScheme uri)++afterScheme :: Text -> Text+afterScheme uri = case Text.breakOn "://" uri of+    (_, rest) | not (Text.null rest) -> Text.drop 3 rest+    _ -> uri++-- | The prefix apt gives the index files it downloads for a URI under+-- @lists/@: the URI without its scheme, slashes turned to underscores.+listsPrefix :: Text -> Text+listsPrefix = Text.map (\c -> if c == '/' then '_' else c) . Text.dropWhileEnd (== '/') . afterScheme++-------------------------------------------------------------------------------++-- | Upper-case, no spaces.+normalizeFingerprint :: Text -> Text+normalizeFingerprint = Text.toUpper . Text.filter (\c -> c /= ' ' && c /= '\t')++{- | The fingerprints of the /primary/ keys in @gpg --with-colons@ output:+the @fpr@ record that directly follows a @pub@ record. (A subkey's @fpr@+follows a @sub@; a user id's records follow the @fpr@.)+-}+primaryFingerprints :: Text -> [Text]+primaryFingerprints out = go (Text.splitOn ":" <$> Text.lines out)+  where+    go (("pub" : _) : rest) = case dropWhile (not . isKind ["fpr", "pub"]) rest of+        (("fpr" : fields) : rest') -> fprField fields : go rest'+        rest' -> go rest'+    go (_ : rest) = go rest+    go [] = []+    isKind ks (k : _) = k `elem` ks+    isKind _ [] = False+    -- fpr:::::::::<FINGERPRINT>:+    fprField fields = normalizeFingerprint (case drop 8 fields of (f : _) -> f; [] -> "")++verifyKeyFingerprint :: FilePath -> Text -> IO ()+verifyKeyFingerprint file wanted = do+    (code, out, err) <- readCreateProcessWithExitCode (proc "gpg" ["--show-keys", "--with-colons", "--with-fingerprint", file]) ""+    when (code /= ExitSuccess) $+        ioError (userError ("apt repository: gpg --show-keys failed on " <> file <> ": " <> Text.unpack (Text.decodeUtf8 err)))+    let fps = primaryFingerprints (Text.decodeUtf8 out)+    unless (normalizeFingerprint wanted `elem` fps) $+        throwIO (KeyFingerprintMismatch file (normalizeFingerprint wanted) fps)++-------------------------------------------------------------------------------++{- | Has the index been refreshed since the repository was last (re)declared?+The newest of the sources and preference files is the moment the+declaration last changed; an index file for this URI at least that new means+an @apt-get update@ has seen it. Nothing else can say so: apt keeps no record+of which sources it has fetched other than these files.+-}+checkIndexFresh :: AptRepository -> IO CheckResult+checkIndexFresh repo = do+    haveLists <- doesDirectoryExist repo.repoListsDir+    if not haveLists+        then pure (Failure ("no index directory: " <> Text.pack repo.repoListsDir))+        else do+            sourcesTime <- getModificationTime (sourcesPath repo)+            prefTimes <- traverse getModificationTime =<< filterExisting [preferencesPath repo]+            let declaredAt = maximum (sourcesTime : prefTimes)+            names <- listDirectory repo.repoListsDir+            let prefix = Text.unpack (listsPrefix repo.repoUris)+                ours = [repo.repoListsDir </> n | n <- names, take (length prefix) n == prefix]+            times <- traverse getModificationTime ours+            pure $+                if any (>= declaredAt) times+                    then Success+                    else Failure ("index older than the declaration of " <> repo.repoName)+  where+    filterExisting = fmap concat . traverse (\p -> (\e -> [p | e]) <$> doesFileExist p)++runAptUpdate :: IO ()+runAptUpdate = do+    (code, _out, err) <- readCreateProcessWithExitCode (proc "apt-get" ["update", "-q"]) ""+    case code of+        ExitSuccess -> pure ()+        ExitFailure n -> throwIO (Binary.CommandFailedSimple ("apt-get update: " <> take 500 (Text.unpack (Text.decodeUtf8 err))) n)
+ src/Salmon/Builtin/Nodes/Debian/Debootstrap.hs view
@@ -0,0 +1,201 @@+module Salmon.Builtin.Nodes.Debian.Debootstrap where++import Salmon.Actions.UpDown (CheckResult (..), skipIfFileExists)+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Control.Monad (void)+import Data.List (isInfixOf)+import Data.Text (Text)+import qualified Data.Text as Text++import System.Directory (doesFileExist)+import System.FilePath ((</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess (..), proc)++import Salmon.Builtin.Nodes.Debian.Package (Package (..))++-------------------------------------------------------------------------------+data Report+    = RunDebootstrap !DebootstrapCommand !Binary.Report+    | RunEnsureVm9pBoot !Vm9pBootCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------+data Suite+    = Stable+    | OldStable+    | Unstable+    | Testing+    deriving (Show)++type Includes =+    [Package]++{- | Packages a 'RootTree' needs beyond a bare chroot for it to be bootable+as a qemu guest and reachable once up: a kernel (so there's a+@\/boot\/vmlinuz-*@\/@initrd.img-*@ pair to hand qemu's @-kernel@\/@-initrd@+directly, skipping a bootloader entirely) and an SSH server (so a test+harness can reach in the same way "Salmon.Builtin.Nodes.Podman"-backed+tests @podman exec@ into a container). Debian's default debootstrap variant+already pulls in @systemd-sysv@ (so PID 1 reaches multi-user target) unless+@--variant=minbase@ was requested elsewhere — this list only adds what's+never on by default.++Merge into a caller's own 'Includes' with @<>@, e.g.:++> rootTree r boot (RootTree Stable "/var/lib/salmon-test-vms/foo/root" (vmEssentials <> [Package "curl"]))++A 'RootTree' meant to actually boot as a "Salmon.Builtin.Nodes.Qemu" guest+also needs 'ensureVm9pBoot' injected after 'rootTree' — this package list+alone gets you a kernel and sshd, not an initramfs that can find its own+root filesystem (see that function's haddock for why).+-}+vmEssentials :: Includes+vmEssentials =+    [ Package "linux-image-amd64"+    , Package "openssh-server"+    ]++data RootTree+    = RootTree+    { suite :: Suite+    , path :: FilePath+    , includes :: Includes+    }+    deriving (Show)++rootTree ::+    Reporter Report ->+    Track' (Binary "debootstrap") ->+    RootTree ->+    Op+rootTree r boot root =+    withBinary boot debootstrapCommand cmd $ \up ->+        op "debootstrap" (deps [rootdir]) $ \actions ->+            actions+                { help = Text.unwords ["debootstraps", Text.pack (show root.suite), "at", Text.pack root.path]+                , ref = mkRef "debootstrap" root.path+                , check = skipIfFileExists etcIssues+                , up = up r'+                }+  where+    r' = contramap (RunDebootstrap cmd) r+    cmd = MakeRoot root.includes root.suite root.path+    rootdir :: Op+    rootdir = dir (Directory root.path)+    etcIssues :: FilePath+    etcIssues = root.path </> "etc/issue"++data DebootstrapCommand+    = MakeRoot Includes Suite FilePath+    deriving (Show)++debootstrapCommand :: Command "debootstrap" DebootstrapCommand+debootstrapCommand = Command $ \cmd -> case cmd of+    (MakeRoot [] suite rootdir) ->+        proc+            "debootstrap"+            [ suiteName suite+            , rootdir+            ]+    (MakeRoot packages suite rootdir) ->+        proc+            "debootstrap"+            [ includearg packages+            , suiteName suite+            , rootdir+            ]+  where+    includearg xs =+        Text.unpack $+            "--include=" <> Text.intercalate "," (fmap pkgName xs)+    suiteName n =+        case n of+            Stable -> "stable"+            OldStable -> "oldstable"+            Unstable -> "unstable"+            Testing -> "testing"++-------------------------------------------------------------------------------++{- | Makes a 'vmEssentials'-equipped 'RootTree' actually able to boot as a+"Salmon.Builtin.Nodes.Qemu" guest: appends the 9p kernel modules+(@9p@\/@9pnet@\/@9pnet_virtio@\/@virtio@\/@virtio_pci@\/@virtio_ring@) to+@\/etc\/initramfs-tools\/modules@ and regenerates the initrd via a chroot+(hand-validated 2026-08-20, see @specs/qemu-test-vms-progress.md@).++Without this, the stock debootstrap initrd never even attempts a 9p mount+of its own root — @NET_9P@\/@NET_9P_VIRTIO@\/@9P_FS@ are modules, not+built into Debian's stock kernel, and nothing loads them, so+@initramfs-tools@'s @local_device_setup@ waits forever for a block device+that a 9p mount tag will never produce, then panics with @\/dev\/root does+not exist@.++Needs root (bind-mounts @\/proc@,@\/sys@,@\/dev@ into the chroot and+unmounts them after) — same privileged-execution assumption the rest of+this VM tier already carries. Idempotent: 'check' skips once+@\/etc\/initramfs-tools\/modules@ already mentions @9pnet_virtio@, so+rerunning after modules are already merged in only exits early rather than+running @update-initramfs@ (and its bind-mount dance) again.++Caller is expected to 'Salmon.Op.OpGraph.inject' this after the same+'RootTree''s 'rootTree', e.g.:++> ensureVm9pBoot r bash root \`inject\` rootTree r boot root+-}+ensureVm9pBoot :: Reporter Report -> Track' (Binary "bash") -> RootTree -> Op+ensureVm9pBoot r bash root =+    withBinary bash vm9pBootCommand cmd $ \up ->+        op "debootstrap-9p-boot" nodeps $ \actions ->+            actions+                { help = Text.unwords ["ensures", Text.pack root.path, "can boot its root filesystem over 9p"]+                , ref = mkRef "debootstrap-9p-boot" root.path+                , check = skipIf9pModulesConfigured root.path+                , up = up r'+                }+  where+    r' = contramap (RunEnsureVm9pBoot cmd) r+    cmd = EnsureVm9pBoot root.path++skipIf9pModulesConfigured :: FilePath -> IO CheckResult+skipIf9pModulesConfigured rootdir = do+    let modulesFile = rootdir </> "etc/initramfs-tools/modules"+    exists <- doesFileExist modulesFile+    if not exists+        then pure (Failure $ "no modules file under " <> Text.pack rootdir)+        else do+            contents <- readFile modulesFile+            pure $+                if "9pnet_virtio" `isInfixOf` contents+                    then Success+                    else Failure "9pnet_virtio not in the modules file"++newtype Vm9pBootCommand = EnsureVm9pBoot FilePath+    deriving (Show)++vm9pBootCommand :: Command "bash" Vm9pBootCommand+vm9pBootCommand = Command $ \(EnsureVm9pBoot rootdir) -> proc "bash" ["-c", ensureVm9pBootScript rootdir]++ensureVm9pBootScript :: FilePath -> String+ensureVm9pBootScript rootdir =+    unlines+        [ "set -e"+        , "root=" <> shellQuote rootdir+        , "modules=\"$root/etc/initramfs-tools/modules\""+        , "for m in 9p 9pnet 9pnet_virtio virtio virtio_pci virtio_ring; do"+        , "  grep -qxF \"$m\" \"$modules\" || echo \"$m\" >> \"$modules\""+        , "done"+        , "for d in proc sys dev; do mount --bind \"/$d\" \"$root/$d\"; done"+        , "chroot " <> shellQuote rootdir <> " update-initramfs -u -k all"+        , "for d in dev sys proc; do umount \"$root/$d\"; done"+        ]++shellQuote :: FilePath -> String+shellQuote p = "'" <> concatMap (\c -> if c == '\'' then "'\\''" else [c]) p <> "'"
+ src/Salmon/Builtin/Nodes/Debian/OS.hs view
@@ -0,0 +1,104 @@+module Salmon.Builtin.Nodes.Debian.OS where++import Salmon.Op.Track++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary+import Salmon.Builtin.Nodes.Debian.Package++import Data.Text (Text)++type Installer sym = Track' (Binary sym)++installWith :: Text -> Installer sym+installWith x = Track (const $ deb (Package x))++sshClient :: Installer "ssh-keygen"+sshClient = installWith "ssh-client"++openssl :: Installer "openssl"+openssl = installWith "openssl"++git :: Installer "git"+git = installWith "git-core"++bash :: Installer "bash"+bash = installWith "bash"++rsync :: Installer "rsync"+rsync = installWith "rsync"++ssh :: Installer "ssh"+ssh = installWith "ssh-client"++systemctl :: Installer "systemctl"+systemctl = installWith "systemd"++sudo :: Installer "sudo"+sudo = installWith "sudo"++podman :: Installer "podman"+podman = installWith "podman"++postgres :: Installer "postgres"+postgres = installWith "postgresql"++psql :: Installer "psql"+psql = installWith "postgresql-client"++pg_ctl :: Installer "pg_ctl"+pg_ctl = installWith "postgresql-client"++pg_ctlcluster :: Installer "pg_ctlcluster"+pg_ctlcluster = installWith "postgresql-common"++curl :: Installer "curl-keygen"+curl = installWith "curl"++useradd :: Installer "useradd"+useradd = installWith "passwd"++groupadd :: Installer "groupadd"+groupadd = installWith "passwd"++usermod :: Installer "usermod"+usermod = installWith "passwd"++chown :: Installer "chown"+chown = installWith "coreutils"++ip :: Installer "ip"+ip = installWith "iproute2"++setcap :: Installer "setcap"+setcap = installWith "libcap2-bin"++capsh :: Installer "capsh"+capsh = installWith "libcap2-bin"++wg :: Installer "wg"+wg = installWith "wireguard"++nft :: Installer "nft"+nft = installWith "netfilter"++sysctl :: Installer "sysctl"+sysctl = installWith "procps"++pgbouncer :: Installer "pgbouncer"+pgbouncer = installWith "pgbouncer"++nginx :: Installer "nginx"+nginx = installWith "nginx"++debootstrap :: Installer "debootstrap"+debootstrap = installWith "debootstrap"++upx :: Installer "upx"+upx = installWith "upx-ucl"++tar :: Installer "tar"+tar = installWith "tar"++minizinc :: Installer "minizinc"+minizinc = installWith "minizinc"
+ src/Salmon/Builtin/Nodes/Debian/Package.hs view
@@ -0,0 +1,325 @@+module Salmon.Builtin.Nodes.Debian.Package where++import Salmon.Builtin.Extension+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Op.OpGraph+import Salmon.Op.Ref+import Salmon.Op.Actions (Act (..))+-- only `addEdge` is needed here; `Rewritten` carries the `Dag` itself.+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Rewrite (Phase (..), Rewrite, Rewritten)+import qualified Salmon.Op.Rewrite as Rewrite+import Salmon.Reporter++import Data.Dynamic (toDyn)+import Data.Foldable (toList)+import qualified Data.List as List+import qualified Data.List.NonEmpty as NEList+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Set (Set)+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.IO.Exception (ExitCode (..))+import System.Environment (getEnvironment)+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess, env, proc)+import qualified Data.Text.Encoding as Text++import Salmon.Actions.UpDown (CheckResult (..))++data Package = Package {pkgName :: Text}+    deriving (Eq, Ord, Show)++-------------------------------------------------------------------------------++-- | Which apt-get invocation a 'Report' is for (including the full package set, e.g. to see why an install failed with "too many arguments").+data AptCommand+    = AptInstall !(NEList.NonEmpty Package)+    | AptRemove !(NEList.NonEmpty Package)+    deriving (Show)++data Report+    = RunAptGet !AptCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++deb :: Package -> Op+deb = debWith silent++-- | Like 'deb', but takes a 'Reporter' to observe the apt-get invocation (command, exit code, stdout/stderr).+debWith :: Reporter Report -> Package -> Op+debWith r pkg =+    op "deb" nodeps $ \actions ->+        actions+            { help = "installs " <> pkg.pkgName+            , ref = mkRef "debian-deb" pkg.pkgName+            , up = upAction+            , down = downAction+            , check = checkPackagesInstalled pkgs+            , dynamics = [toDyn pkg]+            }+  where+    pkgs :: NEList.NonEmpty Package+    pkgs = NEList.singleton pkg++    upAction :: IO ()+    upAction = do+        baseEnv <- getEnvironment+        Binary.untrackedExec (aptInstallCommand baseEnv) pkgs "" (contramap (RunAptGet (AptInstall pkgs)) r)+    downAction :: IO ()+    downAction =+        Binary.untrackedExec aptUninstallCommand pkgs "" (contramap (RunAptGet (AptRemove pkgs)) r)++debs :: NEList.NonEmpty Package -> Op+debs = debsWith silent++-- | Like 'debs', but takes a 'Reporter' to observe the apt-get invocation (command, exit code, stdout/stderr).+debsWith :: Reporter Report -> NEList.NonEmpty Package -> Op+debsWith r pkgs =+    op "debs" nodeps $ \actions ->+        actions+            { help = "installs " <> Text.pack (show (length pkgset)) <> " packages"+            , notes = pkgName <$> toList pkgset+            , ref = mkRef "debian-deb-set" (pkgName <$> Set.toList pkgset)+            , up = upAction+            , down = downAction+            , check = checkPackagesInstalled dedupedPkgs+            }+  where+    pkgset :: Set.Set Package+    pkgset = Set.fromList $ NEList.toList pkgs+    -- dedup before ever building the apt-get argv, not just for display (`help`/`notes`/`ref` above) —+    -- otherwise many predecessors depending on the same package (e.g. one per migration file) each+    -- contribute their own copy of it to the same apt-get invocation.+    dedupedPkgs :: NEList.NonEmpty Package+    dedupedPkgs = NEList.fromList $ Set.toList pkgset+    upAction :: IO ()+    upAction = do+        baseEnv <- getEnvironment+        Binary.untrackedExec (aptInstallCommand baseEnv) dedupedPkgs "" (contramap (RunAptGet (AptInstall dedupedPkgs)) r)+    downAction :: IO ()+    downAction =+        Binary.untrackedExec aptUninstallCommand dedupedPkgs "" (contramap (RunAptGet (AptRemove dedupedPkgs)) r)++{- | Collect every @deb@ node in the graph into one @apt-get@ invocation per+direction: one install batch for the packages some live declaration still+wants, one removal batch for the rest, and an ordering edge putting the+removal first.++This replaces the 'installAllDebsAtOnce' \/ 'removeSinglePackages' pair of+@Op -> Op@ passes an application used to apply by hand inside its own+'Salmon.Op.Track.Track' (both still work, both deprecated). Three things it+can do that they could not, all of them consequences of running after the fold+rather than over one directive's graph:++* __It sees every declaration.__ Under @run serve@ the old pass batched one+  seed's packages at a time, because that is all a @directive -> Op@ ever+  had. This batches across the lot.+* __It knows the direction.__ 'phaseDesired' is what says whether a @deb@+  node is being installed or removed, and nothing before the fold knows+  that — so the old pass could only ever emit a blind install batch. The+  partition here is conservative: a package any live declaration still wants+  goes to the install batch, and only a package absent from 'phaseDesired'+  is removed. Erring the other way would let one retraction uninstall a+  package another declaration is standing on.+* __It redirects the edges.__ Whatever depended on @deb foo@ now depends on+  the batch that installs it, instead of the old pass's trick of blanking the+  per-package nodes and 'Salmon.Op.OpGraph.inject'ing the batch under the+  root.++The ordering edge is there because @apt-get install@ and @apt-get remove@+both want the dpkg lock. Today the two batches are in different convergence+passes anyway, so the edge is redundant; once nodes run concurrently it is+what serialises them, and an edge costs nothing and needs no retry loop to+tell "could not lock" from "no such package". Removals first is also simply+the right order — it is what one would do by hand to clear conflicts.++A batch is one node, so a failure is attributed to all of its members: the+batch's @apt-get@ exiting non-zero says the batch failed, not which package,+and narrowing it would mean parsing apt's prose. That is the trade a+collection makes — efficiency for attribution.+-}+batchPackages :: Reporter Report -> Rewrite Extension+batchPackages r phase computed =+    edge . batchOf "installs" installRef wanted . batchOf "removes" removeRef unwanted $ computed+  where+    -- (ref, the packages that node declares) for every deb node this+    -- traversal is allowed to touch.+    declared :: [(Ref, [Package])]+    declared =+        [ (aref, pkgs)+        | (aref, pkgs) <- Rewrite.collectDynamic computed+        , not (Set.member aref phase.phaseIgnored)+        ]++    -- conservative: still-wanted wins. Only a package no live declaration+    -- asks for goes to the removal batch.+    wanted, unwanted :: [(Ref, [Package])]+    (wanted, unwanted) = List.partition (\(aref, _) -> Set.member aref phase.phaseDesired) declared++    installRef = batchRef "install" wanted+    removeRef = batchRef "remove" unwanted++    -- removals before installs: both want the dpkg lock, and clearing+    -- conflicts first is the order one would use by hand.+    edge c+        | Map.member installRef (Rewrite.computedMembers c)+        , Map.member removeRef (Rewrite.computedMembers c) =+            c{Rewrite.computedDag = Dag.addEdge (removeRef, installRef) (Rewrite.computedDag c)}+        | otherwise = c++    batchOf :: Text -> Ref -> [(Ref, [Package])] -> Rewritten Extension -> Rewritten Extension+    batchOf verb aref members c+        | Just pkgs <- NEList.nonEmpty (Set.toList (pkgsOf members))+        , Just act <- opAct (debsWith r pkgs) =+            Rewrite.introduce (relabel verb aref (pkgsOf members) act) (Set.fromList (fmap fst members)) c+        | otherwise = c++    -- 'debsWith' already knows how to run one apt-get over a package set; all+    -- this needs of it is a stable identity of its own (so the two batches+    -- are two nodes) and a help line that says which direction it is.+    relabel :: Text -> Ref -> Set Package -> Act Extension -> Act Extension+    relabel verb aref pkgset act =+        act+            { extension =+                act.extension+                    { ref = aref+                    , help = verb <> " " <> Text.pack (show (Set.size pkgset)) <> " packages in one apt-get"+                    }+            }++    pkgsOf :: [(Ref, [Package])] -> Set Package+    pkgsOf members = Set.fromList (concatMap snd members)++    batchRef :: Text -> [(Ref, [Package])] -> Ref+    batchRef what members = mkRef "debian-deb-batch" (what, pkgName <$> Set.toList (pkgsOf members))++{- | The pre-'batchPackages' way of doing this: an @Op -> Op@ an application+applied by hand inside its own 'Salmon.Op.Track.Track', paired with+'removeSinglePackages' to blank the per-package nodes it superseded.++Kept working, but it cannot become direction-aware and it cannot see past one+directive, which is the whole of why 'batchPackages' exists. Porting is:+delete the @optimizedDeps@-style wrapper from the 'Salmon.Op.Track.Track',+and pass @[batchPackages r]@ to+'Salmon.Builtin.CommandLine.execCommandOrSeedWithRewrites'.+-}+installAllDebsAtOnce :: Op -> Op+installAllDebsAtOnce = installAllDebsAtOnceWith silent+{-# DEPRECATED installAllDebsAtOnce "Register `batchPackages` as a rewrite instead; this cannot see other declarations or node directions." #-}++-- | Like 'installAllDebsAtOnce', but takes a 'Reporter' to observe the batched apt-get invocation.+installAllDebsAtOnceWith :: Reporter Report -> Op -> Op+installAllDebsAtOnceWith r =+    collectPackagesAsSet+  where+    collectPackagesAsSet :: Op -> Op+    collectPackagesAsSet root =+        case NEList.nonEmpty (concatMap snd $ collectDynamics root) of+            Just pkgs -> debsWith r pkgs+            Nothing -> realNoop+{-# DEPRECATED installAllDebsAtOnceWith "Register `batchPackages` as a rewrite instead; this cannot see other declarations or node directions." #-}++-- | Blanks every node 'installAllDebsAtOnceWith' has already batched.+removeSinglePackages :: Op -> Op+removeSinglePackages root+    | null (packages root) = root{predecessors = fmap (fmap removeSinglePackages) root.predecessors}+    | otherwise = realNoop{predecessors = fmap (fmap removeSinglePackages) root.predecessors}+  where+    packages :: Op -> [Package]+    packages root = getDynamics root+{-# DEPRECATED removeSinglePackages "Register `batchPackages` as a rewrite instead; it redirects precedence edges rather than blanking nodes." #-}++{- | Whether every one of these packages is already installed.++Written because @apt-get install@ needs root even when it has nothing to do,+so a graph naming packages it already has could not run at all as an ordinary+user -- which is what any local recipe going through+"Salmon.Builtin.Nodes.Self" does, via its @rsync@\/@ssh@ dependencies.++It has to understand __virtual packages__, or it is worse than no check at+all: several names used in this tree ("Salmon.Builtin.Nodes.Debian.OS" asks+for @ssh-client@) are virtual ones that @apt-get@ happily resolves to their+single provider, while @dpkg-query@ answers @not-installed@ for the name+itself forever. So this reads the whole catalogue once and counts a name as+installed when an installed package either /is/ it or @Provides@ it.++The behaviour change is worth stating: a @deb@ node for a package that is+installed but out of date is now skipped rather than handed to @apt-get+install@, which would have upgraded it. "Is this package installed" is what+this node's effect is; tracking the latest version is a different job, and+one nothing in this tree asked for.++One consequence for test harnesses: this check shells out, so it answers+about whatever machine it runs on. Anything redirecting a node's @up@+elsewhere has to redirect the check too, or the check answers about the host+while @up@ acts on the sandbox -- see @Test.PostgresInitSpec@'s shim list,+where leaving @dpkg-query@ out made a container skip an install the host+already had.+-}+checkPackagesInstalled :: NEList.NonEmpty Package -> IO CheckResult+checkPackagesInstalled pkgs = do+    (code, out, _err) <-+        readCreateProcessWithExitCode+            (proc "dpkg-query" ["-W", "-f=${db:Status-Status}|${binary:Package}|${Provides}\n"])+            ""+    pure $ interpretDpkgCatalog (fmap pkgName (toList pkgs)) code (Text.decodeUtf8 out)++{- | The verdict drawn from a @dpkg-query -W@ catalogue of+@status|package|provides@ lines, split out for testability.+-}+interpretDpkgCatalog :: [Text] -> ExitCode -> Text -> CheckResult+interpretDpkgCatalog _ (ExitFailure n) _ =+    -- 'Unknown', not 'Failure': dpkg-query exits non-zero when it cannot read+    -- the status database, which on a live machine mostly means something+    -- else holds the dpkg lock -- unattended-upgrades, typically. That is not+    -- evidence the package is missing, and calling it missing makes the node+    -- run `apt-get install`, which then fails on the same lock. A one-shot+    -- `run up` still applies (Unknown maps to Required), but a supervisor+    -- waits and looks again instead of installing on every busy moment.+    Unknown+interpretDpkgCatalog wanted ExitSuccess catalogue =+    case filter (not . (`Set.member` available)) wanted of+        [] -> Success+        missing -> Failure ("not installed: " <> Text.intercalate ", " missing)+  where+    available :: Set Text+    available = Set.fromList (concatMap namesOf (Text.lines catalogue))++    namesOf :: Text -> [Text]+    namesOf line =+        case Text.splitOn "|" line of+            (status : name : provides : _)+                | Text.strip status == "installed" ->+                    stripArch (Text.strip name) : fmap providedName (Text.splitOn "," provides)+            _ -> []++    -- "libfoo (= 1.2), bar" -> "libfoo" / "bar"+    providedName :: Text -> Text+    providedName = stripArch . Text.strip . Text.takeWhile (/= '(')++    -- dpkg prints "name:arch" for a package from a foreign architecture+    stripArch :: Text -> Text+    stripArch = Text.strip . Text.takeWhile (/= ':')++aptInstallCommand :: [(String, String)] -> Binary.Command "apt-get" (NEList.NonEmpty Package)+aptInstallCommand baseEnv = Binary.Command $ \pkgs -> aptInstallProcess pkgs baseEnv++aptInstallProcess :: NEList.NonEmpty Package -> [(String, String)] -> CreateProcess+aptInstallProcess pkgs baseEnv =+    (proc "apt-get" args){env = Just (("DEBIAN_FRONTEND", "noninteractive") : baseEnv)}+  where+    args :: [String]+    args = ["install", "-y", "-q"] <> [Text.unpack pkg.pkgName | pkg <- toList pkgs]++aptUninstallCommand :: Binary.Command "apt-get" (NEList.NonEmpty Package)+aptUninstallCommand = Binary.Command aptUninstallProcess++aptUninstallProcess :: NEList.NonEmpty Package -> CreateProcess+aptUninstallProcess pkgs =+    proc "apt-get" args+  where+    args :: [String]+    args = ["remove", "-q"] <> [Text.unpack pkg.pkgName | pkg <- toList pkgs]
+ src/Salmon/Builtin/Nodes/Demo.hs view
@@ -0,0 +1,19 @@+module Salmon.Builtin.Nodes.Demo where++import Salmon.Actions.Dot+import Salmon.Builtin.Extension+import Salmon.Op.Ref++import Data.Text as Text hiding (show)++collatz :: [Int] -> Op+collatz ks =+    op "collatzs-orbits" (deps [segment k | k <- ks]) id+  where+    opname k = "cltz-" <> (Text.pack $ show k)+    useRef k = \actions -> actions{ref = mkRef "collatz" k}+    depsAtLevel 1 = nodeps+    depsAtLevel n+        | n `mod` 2 == 0 = deps [segment (n `div` 2)]+        | otherwise = deps [segment (3 * n + 1)]+    segment k = op (opname k) (depsAtLevel k) (useRef k)
+ src/Salmon/Builtin/Nodes/Etcd.hs view
@@ -0,0 +1,354 @@+{-# LANGUAGE OverloadedStrings #-}++{- | etcd, as one member of a cluster: its config file, its systemd unit, and+a check that asks the cluster rather than the disk.++Only the v3 API is spoken (@etcdctl@ with @ETCDCTL_API=3@, which is what+Patroni's @etcd3:@ section wants too); there is no v2 option on purpose.+TLS material is taken as /paths/ to pre-provisioned files -- minting+certificates is a recipe's choice, not this builtin's.++__The trap is bootstrap.__ @initial-cluster-state@ is @new@ exactly once in a+cluster's life. This module implements the /seed/ phase: every member of the+declared cluster is started with @new@ and the same @initial-cluster@. What+it must never do is start a member with @new@ against a cluster that already+exists and does not list it -- that member would either refuse to start or,+worse, found a second cluster. 'seedGuard' is the node that stops this: it+asks every other member, and if one answers and its member list does not+contain this member, it throws 'ClusterExists' instead of letting the unit+start. Joining a member to a running cluster (@etcdctl member add@, then+start with @existing@) is a separate phase, not done here.++A member whose data directory already holds a bootstrapped member (a restart)+is never re-seeded: etcd ignores @initial-cluster*@ once it has data, and the+guard does not even ask.++The cluster-level 'check' compares /membership/ -- the declared peer URLs+against @etcdctl member list@ -- and not the config file, which says what was+intended and not what is.+-}+module Salmon.Builtin.Nodes.Etcd where++import Control.Concurrent (threadDelay)+import Control.Exception (Exception, SomeException, throwIO, try)+import Control.Monad (when)+import Data.Aeson (FromJSON (..), eitherDecodeStrict, withObject, (.!=), (.:?))+import qualified Data.ByteString as ByteString+import Data.List (sort, sortOn, (\\))+import Data.Text (Text)+import qualified Data.Text as Text+import System.Directory (doesDirectoryExist)+import System.FilePath ((</>))+import System.Process.ListLike (proc)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), justInstall)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import qualified Salmon.Builtin.Nodes.Filesystem as FS+import qualified Salmon.Builtin.Nodes.Systemd as Systemd+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++-- | A member as the cluster declares it. Every member must be listed in every member's config.+data Member+    = Member+    { member_name :: Text+    , member_peer_url :: Text+    -- ^ e.g. @https://10.0.0.1:2380@; identifies the member in the member list+    , member_client_url :: Text+    -- ^ e.g. @https://10.0.0.1:2379@; where @etcdctl@ reaches it+    }+    deriving (Eq, Show)++-- | Paths of pre-provisioned TLS files (the CA that signs the peers, a certificate and its key).+data TlsFiles+    = TlsFiles+    { tls_ca :: FilePath+    , tls_cert :: FilePath+    , tls_key :: FilePath+    }+    deriving (Eq, Show)++data EtcdConfig+    = EtcdConfig+    { etcd_self :: Member+    , etcd_cluster :: [Member]+    -- ^ every member, this one included+    , etcd_cluster_token :: Text+    , etcd_data_dir :: FilePath+    , etcd_config_file :: FilePath+    , etcd_user :: Text+    -- ^ the system user the unit runs as (must be able to read the TLS files and own the data dir)+    , etcd_client_tls :: TlsFiles+    , etcd_peer_tls :: TlsFiles+    , etcd_ready_timeout_seconds :: Int+    -- ^ how long 'etcdMember''s @up@ waits for health; in a seed it must cover the other members coming up+    }+    deriving (Show)++-------------------------------------------------------------------------------++{- | The config file etcd reads with @--config-file@. Always the seed phase:+@initial-cluster-state: new@. Harmless on a restart, since etcd ignores it+once the data directory is bootstrapped.+-}+renderConfig :: EtcdConfig -> Text+renderConfig cfg =+    Text.unlines+        [ "name: " <> self.member_name+        , "data-dir: " <> Text.pack cfg.etcd_data_dir+        , "listen-peer-urls: " <> self.member_peer_url+        , "listen-client-urls: " <> self.member_client_url+        , "advertise-client-urls: " <> self.member_client_url+        , "initial-advertise-peer-urls: " <> self.member_peer_url+        , "initial-cluster: " <> renderInitialCluster cfg.etcd_cluster+        , "initial-cluster-state: new"+        , "initial-cluster-token: " <> cfg.etcd_cluster_token+        , "client-transport-security:"+        , "  trusted-ca-file: " <> Text.pack cfg.etcd_client_tls.tls_ca+        , "  cert-file: " <> Text.pack cfg.etcd_client_tls.tls_cert+        , "  key-file: " <> Text.pack cfg.etcd_client_tls.tls_key+        , "  client-cert-auth: true"+        , "peer-transport-security:"+        , "  trusted-ca-file: " <> Text.pack cfg.etcd_peer_tls.tls_ca+        , "  cert-file: " <> Text.pack cfg.etcd_peer_tls.tls_cert+        , "  key-file: " <> Text.pack cfg.etcd_peer_tls.tls_key+        , "  client-cert-auth: true"+        ]+  where+    self = cfg.etcd_self++-- | @name=peerurl,...@, in a stable (name) order so equal clusters render equally.+renderInitialCluster :: [Member] -> Text+renderInitialCluster ms =+    Text.intercalate "," [m.member_name <> "=" <> m.member_peer_url | m <- sortOn (.member_name) ms]++unitConfig :: EtcdConfig -> Systemd.Config+unitConfig cfg =+    Systemd.Config Systemd.System "/etc/systemd/system" "etcd.service" unit svc install+  where+    unit = Systemd.Unit "etcd (from Salmon)" "network-online.target"+    svc =+        Systemd.Service+            Systemd.Simple+            cfg.etcd_user+            cfg.etcd_user+            "0027"+            (Systemd.Start "/usr/bin/etcd" ["--config-file", Text.pack cfg.etcd_config_file])+            Systemd.OnFailure+            Systemd.Process+            cfg.etcd_data_dir+    install = Systemd.Install "multi-user.target"++-------------------------------------------------------------------------------++-- | What we ask of @etcdctl@; always against one endpoint, over the client TLS files.+data EtcdctlCall+    = EndpointHealth TlsFiles Text+    | MemberList TlsFiles Text+    deriving (Show)++etcdctl :: Command "etcdctl" EtcdctlCall+etcdctl = Command go+  where+    go (EndpointHealth tls ep) = proc "etcdctl" (common tls ep <> ["endpoint", "health"])+    go (MemberList tls ep) = proc "etcdctl" (common tls ep <> ["member", "list", "-w", "json"])+    common :: TlsFiles -> Text -> [String]+    common tls ep =+        [ "--endpoints=" <> Text.unpack ep+        , "--cacert=" <> tls.tls_ca+        , "--cert=" <> tls.tls_cert+        , "--key=" <> tls.tls_key+        , "--command-timeout=5s"+        ]++-- | One member as @etcdctl member list -w json@ reports it. A member that was added but has not started has no name.+data Listed = Listed {listed_name :: Text, listed_peer_urls :: [Text]}+    deriving (Eq, Show)++newtype MemberList = MemberList' [Listed]+    deriving (Eq, Show)++instance FromJSON Listed where+    parseJSON = withObject "member" $ \o ->+        Listed <$> o .:? "name" .!= "" <*> o .:? "peerURLs" .!= []++instance FromJSON MemberList where+    parseJSON = withObject "member list" $ \o -> MemberList' <$> o .:? "members" .!= []++parseMemberList :: ByteString.ByteString -> Either Text [Listed]+parseMemberList bs = case eitherDecodeStrict bs of+    Left e -> Left (Text.pack e)+    Right (MemberList' ms) -> Right ms++{- | The membership verdict, pure: the declared peer URLs against the listed+ones. Names are not compared (an unstarted member has none); URLs are what+identify a member.+-}+interpretMembers :: [Member] -> [Listed] -> CheckResult+interpretMembers declared listed+    | null missing && null extra = Success+    | otherwise =+        Failure . Text.intercalate "; " $+            ["not in the cluster: " <> Text.intercalate "," missing | not (null missing)]+                <> ["unexpected in the cluster: " <> Text.intercalate "," extra | not (null extra)]+  where+    want = sort (fmap (.member_peer_url) declared)+    have = sort (concatMap (.listed_peer_urls) listed)+    missing = want \\ have+    extra = have \\ want++-- | Health and membership, as asked of the member itself.+checkMember :: EtcdConfig -> IO CheckResult+checkMember cfg = do+    h <- try (askHealth cfg cfg.etcd_self.member_client_url)+    case h of+        Left e -> pure (Failure ("etcdctl endpoint health: " <> shortErr e))+        Right False -> pure (Failure "endpoint is not healthy")+        Right True -> do+            l <- try (askMembers cfg cfg.etcd_self.member_client_url)+            case l of+                Left e -> pure (Failure ("etcdctl member list: " <> shortErr e))+                Right bs -> case parseMemberList bs of+                    Left e -> pure (Failure ("member list not understood: " <> e))+                    Right ms -> pure (interpretMembers cfg.etcd_cluster ms)++shortErr :: SomeException -> Text+shortErr = Text.take 200 . Text.pack . show++askHealth :: EtcdConfig -> Text -> IO Bool+askHealth cfg ep = do+    r <- try (Binary.untrackedExecOutput etcdctl (EndpointHealth cfg.etcd_client_tls ep) "" silent)+    case r of+        Right _ -> pure True+        Left (Binary.CommandFailed{}) -> pure False++askMembers :: EtcdConfig -> Text -> IO ByteString.ByteString+askMembers cfg ep = Binary.untrackedExecOutput etcdctl (MemberList cfg.etcd_client_tls ep) "" silent++-------------------------------------------------------------------------------++-- | Thrown instead of starting a member with @new@ against a cluster that does not know it.+data ClusterExists = ClusterExists {existing_endpoint :: Text, existing_member :: Text}++instance Show ClusterExists where+    show e =+        Text.unpack $+            "etcd: a cluster already answers at "+                <> e.existing_endpoint+                <> " and does not list member "+                <> e.existing_member+                <> "; starting it with initial-cluster-state=new would not join it. Use the join phase (member add) instead."++instance Exception ClusterExists++-- | Thrown when a member does not become healthy in time.+newtype NotHealthy = NotHealthy Text++instance Show NotHealthy where+    show (NotHealthy why) = "etcd: member did not become healthy: " <> Text.unpack why++instance Exception NotHealthy++{- | The seed decision, pure: given what each /other/ member said when asked+for its member list (Nothing: did not answer), may this member start with+@new@? Refuses iff somebody answered and does not list us.+-}+seedDecision :: Member -> [(Member, Maybe [Listed])] -> Either ClusterExists ()+seedDecision self answers =+    case [(m, ls) | (m, Just ls) <- answers, self.member_peer_url `notElem` concatMap (.listed_peer_urls) ls] of+        [] -> Right ()+        ((m, _) : _) -> Left (ClusterExists m.member_client_url self.member_name)++{- | Guards the seed phase. Satisfied (skipped) when the data directory+already holds a member -- a restart is not a bootstrap. Otherwise asks every+other member for its member list and throws 'ClusterExists' if the answer+says this is not a seed.+-}+seedGuard :: Track' (Binary "etcdctl") -> EtcdConfig -> Op+seedGuard etcdctlBin cfg =+    op "etcd-seed-guard" (deps [justInstall etcdctlBin]) $ \actions ->+        actions+            { help = "refuses to seed a member into a cluster that already exists"+            , notes = ["skipped when the data directory already holds a member"]+            , ref = mkRef "etcd-seed-guard" (Text.pack cfg.etcd_data_dir)+            , check = do+                bootstrapped <- isBootstrapped cfg+                pure (if bootstrapped then Success else Failure "data directory holds no member yet")+            , up = do+                answers <- mapM ask others+                either throwIO pure (seedDecision cfg.etcd_self answers)+            , down = pure ()+            }+  where+    others = filter (/= cfg.etcd_self) cfg.etcd_cluster+    ask :: Member -> IO (Member, Maybe [Listed])+    ask m = do+        r <- try (askMembers cfg m.member_client_url)+        case r of+            Left (_ :: SomeException) -> pure (m, Nothing)+            Right bs -> pure (m, either (const Nothing) Just (parseMemberList bs))++-- | etcd keeps its raft state in @DATA/member@; its presence means the member has been bootstrapped.+isBootstrapped :: EtcdConfig -> IO Bool+isBootstrapped cfg = doesDirectoryExist (cfg.etcd_data_dir </> "member")++-------------------------------------------------------------------------------++{- | One etcd member: binaries, data directory, config, unit, the seed guard,+and on top a node whose @check@ is 'checkMember'.++The unit watches the config file, so a changed config restarts the service.+@down@ stops the service (through the unit node) and deliberately leaves the+data directory alone: it is the cluster's memory, and removing it is how a+member comes back claiming to be somebody else.+-}+etcdMember ::+    Reporter Systemd.Report ->+    Track' (Binary "systemctl") ->+    Track' (Binary "etcd") ->+    Track' (Binary "etcdctl") ->+    EtcdConfig ->+    Op+etcdMember r systemctl etcdBin etcdctlBin cfg =+    op "etcd-member" (deps [service]) $ \actions ->+        actions+            { help = "an etcd cluster member, healthy and listed with the declared peers"+            , notes = ["v3 API only", "seed phase only: join is not implemented"]+            , ref = mkRef "etcd-member" cfg.etcd_self.member_peer_url+            , check = checkMember cfg+            , up = waitHealthy cfg+            , down = pure ()+            }+  where+    service :: Op+    service = Systemd.systemdServiceWatching [cfg.etcd_config_file] r systemctl (Track $ \_ -> prereqs) (unitConfig cfg)++    prereqs :: Op+    prereqs =+        op+            "etcd-setup"+            (deps [justInstall etcdBin, justInstall etcdctlBin, datadir, configFile, seedGuard etcdctlBin cfg])+            id++    datadir = FS.dir (FS.Directory cfg.etcd_data_dir)+    configFile = FS.filecontents (FS.FileContents cfg.etcd_config_file (renderConfig cfg))++-- | Polls until the member's check passes; throws 'NotHealthy' (with the last reason) at the deadline.+waitHealthy :: EtcdConfig -> IO ()+waitHealthy cfg = go (max 1 cfg.etcd_ready_timeout_seconds)+  where+    go :: Int -> IO ()+    go left = do+        v <- checkMember cfg+        case v of+            Success -> pure ()+            Failure why | left <= 1 -> throwIO (NotHealthy why)+            _ -> do+                when (left <= 1) $ throwIO (NotHealthy "no verdict")+                threadDelay 1000000+                go (left - 1)
+ src/Salmon/Builtin/Nodes/Filesystem.hs view
@@ -0,0 +1,568 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Salmon.Builtin.Nodes.Filesystem where++import Salmon.Builtin.Extension+import Salmon.Op.Ref++import qualified Data.Aeson as Aeson+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Base64.URL as Base64.URL+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy as LBytestring+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Crypto.Hash.SHA256 as SHA256+import Data.Bits ((.&.))+import Control.Monad (when)+import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)+import Numeric (showOct)+import qualified System.Posix.Files as Posix+import qualified System.Posix.Types as Posix+import qualified System.Posix.User as PosixUser+import GHC.TypeLits (Symbol)+import Salmon.Actions.UpDown (CheckResult (..), skipIfDirectoryIsMissing)+import Salmon.Op.OpGraph (inject)+import Salmon.Op.Supervision (defaultSupervision, supReapply, supervised)+import Salmon.Op.Track+import System.Directory+import System.FilePath++newtype Directory = Directory {directoryPath :: FilePath}+    deriving (Eq, Ord, Show)++{- | (R9). No 'check', by design rather than by omission: there is nothing+about a directory's existence worth a separate question, since+'createDirectoryIfMissing' already costs about what 'doesDirectoryExist'+would. So this declares 'Salmon.Op.Supervision.supReapply' instead — under+@run serve@ a tending machine for this node re-runs @up@ on the adaptive+delay rather than parking, which is what makes a directory removed behind+salmon's back come back on its own. Under a one-shot @run up@\/@run down@+this changes nothing at all: the field is read only by+"Salmon.Actions.Upkeep", and the check still answers+'Salmon.Actions.UpDown.Immaterial' either way.++This is the node 'Salmon.Op.Supervision.supReapply' was written for — see+its haddock for why almost nothing else in this tree should set it.+-}+dir :: Directory -> Op+dir directory =+    op "directory" nodeps $ \actions ->+        actions+            { help = Text.pack $ "ensures " <> path <> " exists, including subdirs"+            , notes =+                [ "create dir recursively"+                , "does not delete contents of the directory"+                , "reapplies rather than parking under supervision; see supReapply"+                ]+            , ref = mkRef "directory" path+            , up = createDirectoryIfMissing True path+            , -- same reasoning as 'filecontents': an absent directory is+              -- this node's effect being absent. A *non-empty* one still+              -- throws, which is a real signal (something in it was not+              -- declared, or did not go down).+              down = removeDirectoryIfPresent path+            , dynamics = [supervised defaultSupervision{supReapply = True}]+            }+  where+    path :: FilePath+    path = directory.directoryPath++{- | Like 'dir', except 'down' renames the directory to a timestamped suffix+instead of deleting it, for a directory whose contents are worth keeping+around after teardown rather than losing (e.g. retired certificate material —+see "Salmon.Builtin.Nodes.Certificates"). Idempotent the same way every other+@down@ is: a directory already gone is left alone rather than erroring.+-}+retainedDir :: Directory -> Op+retainedDir directory =+    op "retained-directory" nodeps $ \actions ->+        actions+            { help = Text.pack $ "ensures " <> path <> " exists, including subdirs"+            , notes =+                [ "create dir recursively"+                , "does not delete contents of the directory"+                , "down renames the directory to a timestamped suffix instead of deleting it"+                , "reapplies rather than parking under supervision; see supReapply"+                ]+            , ref = mkRef "retained-directory" path+            , up = createDirectoryIfMissing True path+            , down = retireDirectory path+            , dynamics = [supervised defaultSupervision{supReapply = True}]+            }+  where+    path :: FilePath+    path = directory.directoryPath++-- | Renames @path@ to @path@ suffixed with the current UTC timestamp. A+-- no-op if @path@ is already gone.+retireDirectory :: FilePath -> IO ()+retireDirectory path = do+    exists <- doesDirectoryExist path+    when exists $ do+        now <- getCurrentTime+        let suffix = formatTime defaultTimeLocale "%Y%m%dT%H%M%SZ" now+        renameDirectory path (path <> "." <> suffix)++-------------------------------------------------------------------------------++{- | Some file contents that get set once.++Default behaviour is to delete the file on down action+-}+data FileContents a = FileContents {filePath :: FilePath, contents :: a}+    deriving (Eq, Ord, Show, Functor)++filecontents :: (EncodeFileContents a) => FileContents a -> Op+filecontents fcontents =+    op "file-contents" (deps [enclosingdir]) $ \actions ->+        actions+            { help = Text.pack $ "writes " <> path <> " with some contents"+            , notes =+                [ "depends on the enclosing directory"+                ]+                    -- (I6): a content-derived note, when the instance can+                    -- give one, is what makes a content-only re-declaration+                    -- a genuine 'Salmon.Op.Dag.Representative' change —+                    -- see 'EncodeFileContents.contentFingerprint'.+                    <> maybe [] (\h -> ["content-hash: " <> h]) (contentFingerprint fcontents.contents)+            , ref = mkRef "file-contents" path+            , check = checkFileContents fcontents+            , up = ByteString.writeFile path =<< encodeFileContents fcontents.contents+            , -- a `down` that throws blocks the teardown of everything the+              -- node was declared on top of (here: the enclosing directory),+              -- and a file that is already gone is this node's effect being+              -- gone. Found by a teardown that could not remove its own+              -- working directory because an earlier pass had already removed+              -- the file inside it.+              down = removeFileIfPresent path+            }+  where+    enclosingdir :: Op+    enclosingdir = dir (Directory $ takeDirectory path)++    path :: FilePath+    path = fcontents.filePath++{- | Are the bytes on disk already the bytes this node would write?++The second builtin to get a real @check@, after+'Salmon.Builtin.Nodes.Systemd.checkService', and the one that reaches the+most graphs: nearly every recipe here writes a config file. Two things it+buys that are worth separating.++Under a one-shot @run up@ it is an /optimisation with a visible consequence/:+a file whose contents already match is 'Salmon.Actions.UpDown.Skipped', so+its mtime stops moving. That is not cosmetic downstream —+'Salmon.Builtin.Nodes.Systemd.systemdService' writes its unit file through+this node and then asks systemd whether the unit needs reloading, and+systemd answers that from the file's mtime. Rewriting identical bytes every+pass therefore made @NeedDaemonReload@ true every pass, which made+@checkService@ say 'Salmon.Actions.UpDown.Failure' every pass, which+reloaded and restarted a perfectly healthy service. The unit check could not+deliver what it promised until this one existed.++Under @run serve@ it is what makes a config file /supervised/: a+'Salmon.Actions.UpDown.Immaterial' node is parked and never looks again,+where this one notices the file being edited, truncated or deleted behind+salmon's back and puts it back. It also backstops a re-declaration that+changes a node's contents without changing its 'Salmon.Op.Ref.Ref': for an+instance without a 'EncodeFileContents.contentFingerprint' (the @IO a@+one), the convergence pass still records that node as converged and skips+it, and this check — on the tending machine's own next look — is the only+thing that then notices the new content (see (I6) in+@specs/per-node-state-machines-remaining.md@). For every other instance,+'filecontents' puts the fingerprint into 'notes', so the pass itself+notices the change and re-runs this check right away instead of waiting on+the tending loop.++Comparing bytes rather than mere existence is deliberate:+'Salmon.Actions.UpDown.skipIfFileExists' would call a file with the wrong+contents satisfied, which is the failure mode this node most needs to avoid.+The comparison is cheap in the sense that matters — the node's contents are+already in hand, since 'up' is about to encode them anyway.++Three details:++* __The size is compared first__, and a mismatch answers without reading the+  file. It is one @stat@, and it bounds what a node holding a few hundred+  bytes will read if something else has clobbered its path with something+  enormous.+* __The reason never quotes the contents.__ Failure text goes into reports,+  and the files this node writes include @pgbouncer@ userlists and+  @postgrest@ configurations with signing keys in them.+* __Contents are all it answers about__, because contents are all 'up' sets.+  A file whose mode somebody changed still matches; nothing here ever set+  the mode, so there is nothing to restore.++One hazard, for the @'EncodeFileContents' (IO a)@ instance only: the check+runs the encoder, so a generator with side effects runs once more per look,+and one that is not deterministic (a timestamp) makes this always answer+'Salmon.Actions.UpDown.Failure' and rewrite the file on every pass. That is+the safe direction rather than a correctness problem, but a node built that+way should either be given a stable encoder or set its own 'check'.+-}+checkFileContents :: (EncodeFileContents a) => FileContents a -> IO CheckResult+checkFileContents fcontents = do+    exists <- doesFileExist path+    if not exists+        then pure (Failure ("missing: " <> Text.pack path))+        else do+            wanted <- encodeFileContents fcontents.contents+            size <- getFileSize path+            if size /= fromIntegral (ByteString.length wanted)+                then pure (Failure ("wrong size: " <> Text.pack path))+                else do+                    there <- ByteString.readFile path+                    pure $+                        if there == wanted+                            then Success+                            else Failure ("contents differ: " <> Text.pack path)+  where+    path :: FilePath+    path = fcontents.filePath++{- | Utility class to write various file contents.+The Text instance encodes contents in UTF8.+-}+class EncodeFileContents a where+    encodeFileContents :: a -> IO ByteString.ByteString++    {- | A pure, stable fingerprint of the content this would write — (I6):+    what lets 'filecontents' put something content-derived into 'notes', so+    a re-declaration that only changes this node's content is a genuine+    'Salmon.Op.Dag.Representative' change (@Serve.record@'s 'changed' set)+    rather than one indistinguishable from "nothing changed". 'Nothing' —+    the default, and what the @IO a@ instance below must keep — opts a type+    out: its whole point is that the content isn't known until+    'encodeFileContents' actually runs, so nothing pure is available to put+    here, and (per 'checkFileContents'\'s haddock) that generator already+    has its own hazards to manage.+    -}+    contentFingerprint :: a -> Maybe Text.Text+    contentFingerprint _ = Nothing++instance EncodeFileContents Text.Text where+    encodeFileContents = pure . Text.encodeUtf8+    contentFingerprint = Just . hashBytes . Text.encodeUtf8++instance EncodeFileContents ByteString.ByteString where+    encodeFileContents = pure . id+    contentFingerprint = Just . hashBytes++instance EncodeFileContents String where+    encodeFileContents = pure . C8.pack+    contentFingerprint = Just . hashBytes . C8.pack++instance EncodeFileContents Aeson.Value where+    encodeFileContents = pure . LBytestring.toStrict . Aeson.encode+    contentFingerprint = Just . hashBytes . LBytestring.toStrict . Aeson.encode++instance (EncodeFileContents a) => EncodeFileContents (IO a) where+    encodeFileContents ioX = ioX >>= encodeFileContents+    -- default (Nothing) is correct here: deliberately not overridden.++-- | The same short, stable, content-derived tag 'Salmon.Actions.Query.shortRef'+-- uses for a 'Salmon.Op.Ref.Ref', applied to a file's content instead.+hashBytes :: ByteString.ByteString -> Text.Text+hashBytes = Text.take 12 . Text.decodeUtf8 . Base64.URL.encode . SHA256.hash++-------------------------------------------------------------------------------++fileCopy :: FilePath -> FilePath -> Op+fileCopy src tgt =+    op "file-copy" (deps [enclosingdir]) $ \actions ->+        actions+            { help = Text.pack $ "copies " <> src <> " " <> tgt+            , ref = mkRef "file-copy" (src, tgt)+            , up = copyFile src tgt+            , down = removeFile tgt+            }+  where+    enclosingdir :: Op+    enclosingdir = dir (Directory $ takeDirectory tgt)++-------------------------------------------------------------------------------+moveDirectory :: FilePath -> FilePath -> (Extension -> Extension) -> Op+moveDirectory src tgt modActions =+    op "move-dir" (deps [enclosingdir]) $ \actions ->+        modActions $+            actions+                { help = Text.pack $ "moves " <> src <> " " <> tgt+                , ref = mkRef "move-dir" (src, tgt)+                , up = renameDirectory src tgt+                }+  where+    enclosingdir :: Op+    enclosingdir = dir (Directory $ takeDirectory tgt)++-------------------------------------------------------------------------------+replaceDirectory :: FilePath -> FilePath -> FilePath -> Op+replaceDirectory src tgt trash =+    op "replace-dir" (deps [delete3 `inject` move2 `inject` move1]) $ \actions ->+        actions+            { help = Text.pack $ "replace " <> src <> " " <> tgt+            , ref = mkRef "replace-dir" (src, tgt)+            }+  where+    move1 :: Op+    move1 = moveDirectory tgt trash $ \actions ->+        actions{check = skipIfDirectoryIsMissing tgt}+    move2 :: Op+    move2 = moveDirectory src tgt id+    delete3 :: Op+    delete3 = destroyDirectory trash++-------------------------------------------------------------------------------+destroyDirectory :: FilePath -> Op+destroyDirectory trash =+    op "delete-dir" nodeps $ \actions ->+        actions+            { help = Text.pack $ "recursively trashes " <> trash+            , ref = mkRef "delete-dir" trash+            , up = removeDirectoryRecursive trash+            , check = skipIfDirectoryIsMissing trash+            }++-------------------------------------------------------------------------------++data File (sym :: Symbol)+    = PreExisting FilePath+    | Generated (Track' FilePath) FilePath++getFilePath :: File a -> FilePath+getFilePath (PreExisting path) = path+getFilePath (Generated _ path) = path++fileOp :: File a -> Op+fileOp (PreExisting path) = placeholder "pre-existing-file" (Text.pack path)+fileOp (Generated t path) = run t path++withFile :: File a -> (FilePath -> Op) -> Op+withFile file@(PreExisting path) f = f path `inject` fileOp file+withFile (Generated mkp path) f = tracking mkp (\x -> (x, x)) path f++generateFileContents :: (EncodeFileContents a) => a -> FilePath -> File b+generateFileContents c path =+    Generated (Track $ \_ -> filecontents $ FileContents path c) path++-- | 'removeFile', tolerating a file that is already gone.+removeFileIfPresent :: FilePath -> IO ()+removeFileIfPresent path = do+    exists <- doesFileExist path+    when exists (removeFile path)++-- | 'removeDirectory', tolerating a directory that is already gone.+removeDirectoryIfPresent :: FilePath -> IO ()+removeDirectoryIfPresent path = do+    exists <- doesDirectoryExist path+    when exists (removeDirectory path)++-------------------------------------------------------------------------------++-- | A line to ensure is present in a file, appending it if missing.+data AppendLineIfMissing = AppendLineIfMissing {appendLineFilePath :: FilePath, appendLineText :: Text.Text}++{- | Idempotent append: ensures a line is present in a file, appending it if+not already there verbatim (@grep -qxF ... || echo ... >>@, done in-process+rather than via a shell) — the same "append-if-missing" shape used for+@pg_hba.conf@ lines (see @Salmon.Builtin.Nodes.Postgres.ensureHbaLineScript@),+generalized to any file. Does not truncate or otherwise touch the file if the+line is already present. Creates the enclosing directory but not the file+itself (an absent file is treated as empty, and the append creates it).+-}+appendLineIfMissing :: AppendLineIfMissing -> Op+appendLineIfMissing item =+    op "append-line-if-missing" (deps [enclosingdir]) $ \actions ->+        actions+            { help = Text.pack $ "ensures a line is present in " <> path+            , notes = ["append-if-missing", "does not truncate or delete existing lines"]+            , ref = mkRef "append-line-if-missing" (path, item.appendLineText)+            , up = ensureLine+            }+  where+    path :: FilePath+    path = item.appendLineFilePath++    enclosingdir :: Op+    enclosingdir = dir (Directory $ takeDirectory path)++    ensureLine :: IO ()+    ensureLine = do+        exists <- doesFileExist path+        contents <- if exists then Text.decodeUtf8 <$> ByteString.readFile path else pure ""+        if item.appendLineText `elem` Text.lines contents+            then pure ()+            else ByteString.appendFile path (Text.encodeUtf8 $ item.appendLineText <> "\n")++-------------------------------------------------------------------------------++{- | The owner and mode a file must end up with, as a node of its own.++Declared separately from whatever /creates/ the file because the two are+usually authored by different parties: 'filecontents' or 'fileCopy' knows the+bytes, and only the service that will read them knows it must be+@postgres:postgres@ and @0600@. Keeping them apart also keeps the enforcement+idempotent — this node's whole effect is a @chown@ and a @chmod@, so a+re-run is a stat and nothing else.++The motivating case, and the one worth knowing about: Postgres __refuses to+start__ if @ssl_key_file@ is group- or world-readable, and @libpq@ applies+the same rule to a client key. Both fail with a message about permissions+rather than about TLS, some way from the node that wrote the file.+-}+data FileOwnership = FileOwnership+    { ownedPath :: FilePath+    , ownedUser :: Maybe Text.Text+    -- ^ 'Nothing' leaves the owning user alone.+    , ownedGroup :: Maybe Text.Text+    , ownedMode :: Posix.FileMode+    -- ^ the permission bits, e.g. @0o600@.+    }++{- | Ensures a file is owned by 'ownedUser'\/'ownedGroup' and has exactly+'ownedMode'.++The @check@ compares what is on disk, so a file already in the right state is+skipped; a file that is *missing* is a 'Failure' rather than something this+node creates, because the node that owns the bytes is the one that should+have made it and reporting otherwise would hide that failure behind this one.++When 'ownedPath' is a directory, the ownership (but not 'ownedMode') is+applied __recursively__ to everything already underneath it: a rootfs handed+over to an unprivileged user has packages installed into it (openssh-server's+@sshd_config.d@, say) that own only their own top-level entry, and a caller+declaring "this whole subtree is now theirs" means exactly that, not "the+directory entry is theirs but whatever some package dropped inside it stays+root's". Only the directory entry itself gets 'ownedMode' applied (as+before); every descendant keeps its own permission bits — chown, not chmod,+since 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. A missing directory is still a+'Failure', same as a missing file, since walking a tree that is not there+would have nothing to walk.+-}+ownedFile :: FileOwnership -> Op+ownedFile owner =+    op "file-ownership" nodeps $ \actions ->+        actions+            { help = Text.pack $ "owns " <> owner.ownedPath+            , notes = [Text.pack $ "mode " <> showOctalMode owner.ownedMode]+            , ref = mkRef "file-ownership" owner.ownedPath+            , check = checkOwnership owner+            , up = applyOwnership owner+            , -- Ownership is not an effect that can be removed on its own:+              -- there is no "unowned" state to return the file to, and the+              -- node holding the bytes deletes it outright.+              down = pure ()+            }++showOctalMode :: Posix.FileMode -> String+showOctalMode m = "0o" <> showOct (toInteger m) ""++{- | Resolves the wanted ids and compares them, plus the permission bits,+against the file's current status -- and, for a directory, against every+entry underneath it too (see 'ownedFile').++Note this uses 'doesPathExist' rather than 'doesFileExist': the latter is+'False' for a directory, which used to make this check report every+directory-shaped 'ownedFile' as permanently missing, no matter what @up@ had+already done to it.+-}+checkOwnership :: FileOwnership -> IO CheckResult+checkOwnership owner = do+    exists <- doesPathExist owner.ownedPath+    if not exists+        then pure (Failure $ "missing: " <> Text.pack owner.ownedPath)+        else do+            status <- Posix.getFileStatus owner.ownedPath+            wantedUid <- traverse lookupUid owner.ownedUser+            wantedGid <- traverse lookupGid owner.ownedGroup+            let actualMode = Posix.fileMode status .&. permissionBits+            treeIssue <- checkTreeOwnership wantedUid wantedGid owner.ownedPath+            pure $ case () of+                _+                    | actualMode /= owner.ownedMode ->+                        Failure $+                            Text.pack $+                                owner.ownedPath <> " is " <> showOctalMode actualMode <> ", wanted " <> showOctalMode owner.ownedMode+                    | maybe False (/= Posix.fileOwner status) wantedUid ->+                        Failure $ "wrong owner: " <> Text.pack owner.ownedPath+                    | maybe False (/= Posix.fileGroup status) wantedGid ->+                        Failure $ "wrong group: " <> Text.pack owner.ownedPath+                    | Just reason <- treeIssue -> Failure reason+                    | otherwise -> Success++applyOwnership :: FileOwnership -> IO ()+applyOwnership owner = do+    uid <- maybe (pure (-1)) lookupUid owner.ownedUser+    gid <- maybe (pure (-1)) lookupGid owner.ownedGroup+    -- chown before chmod: chown clears setuid/setgid bits, so doing it the+    -- other way round silently drops them.+    Posix.setOwnerAndGroup owner.ownedPath uid gid+    Posix.setFileMode owner.ownedPath owner.ownedMode+    isDir <- doesDirectoryExist owner.ownedPath+    when isDir $ do+        entries <- treeEntries owner.ownedPath+        mapM_ (chownEntry uid gid) entries++-- | The bits 'ownedMode' speaks about: permissions and the set-id/sticky+-- trio, never the file-type bits 'Posix.fileMode' also carries.+permissionBits :: Posix.FileMode+permissionBits = 0o7777++-- | Every descendant of a directory -- files, directories and symlinks+-- alike -- depth-first, without ever following a symlink into whatever it+-- points at (so a symlink under a handed-over tree is chowned itself, its+-- target is somebody else's business, and a symlink cycle can't loop this).+treeEntries :: FilePath -> IO [FilePath]+treeEntries path = do+    names <- listDirectory path+    let children = map (path </>) names+    descendants <- concat <$> traverse recurse children+    pure (children <> descendants)+  where+    recurse child = do+        isSymlink <- pathIsSymbolicLink child+        if isSymlink+            then pure []+            else do+                isDir <- doesDirectoryExist child+                if isDir then treeEntries child else pure []++-- | 'Nothing' means "checked only what 'checkOwnership' also checks at the+-- top" (not a directory, or nothing underneath owned wrong); reports the+-- first mismatch found, same shape as the top-level checks above.+checkTreeOwnership :: Maybe Posix.UserID -> Maybe Posix.GroupID -> FilePath -> IO (Maybe Text.Text)+checkTreeOwnership wantedUid wantedGid path = do+    isDir <- doesDirectoryExist path+    if not isDir+        then pure Nothing+        else do+            entries <- treeEntries path+            go entries+  where+    go [] = pure Nothing+    go (p : ps) = do+        st <- Posix.getSymbolicLinkStatus p+        if maybe False (/= Posix.fileOwner st) wantedUid+            then pure (Just $ "wrong owner: " <> Text.pack p)+            else+                if maybe False (/= Posix.fileGroup st) wantedGid+                    then pure (Just $ "wrong group: " <> Text.pack p)+                    else go ps++-- | Never follows a symlink to chown whatever it points at.+chownEntry :: Posix.UserID -> Posix.GroupID -> FilePath -> IO ()+chownEntry uid gid path = do+    isSymlink <- pathIsSymbolicLink path+    if isSymlink+        then Posix.setSymbolicLinkOwnerAndGroup path uid gid+        else Posix.setOwnerAndGroup path uid gid++lookupUid :: Text.Text -> IO Posix.UserID+lookupUid name = PosixUser.userID <$> PosixUser.getUserEntryForName (Text.unpack name)++lookupGid :: Text.Text -> IO Posix.GroupID+lookupGid name = PosixUser.groupID <$> PosixUser.getGroupEntryForName (Text.unpack name)
+ src/Salmon/Builtin/Nodes/Gcp/ArtifactRegistry.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE OverloadedStrings #-}++module Salmon.Builtin.Nodes.Gcp.ArtifactRegistry (+    RepoFormat (..),+    ArtifactRepo (..),+    artifactRepository,+    configureDockerAuth,+    interpretRepoDescribe,+    Report (..),+    ArtifactRegistryCommand (..),+    artifactRegistryCommand,+) where++import Data.Text (Text)+import qualified Data.Text as Text+import GHC.IO.Exception (ExitCode (..))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (proc)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Gcp.Core (Project (..), Region (..), gcloudProc, withProject)+import qualified Salmon.Builtin.Nodes.Gcp.Core as Core+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++data Report+    = RunArtifactRegistryCommand !ArtifactRegistryCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++-- | Format of an Artifact Registry repository.+data RepoFormat+    = Docker+    | Maven+    | Npm+    | Python+    | Apt+    | Yum+    deriving (Eq, Show)++renderRepoFormat :: RepoFormat -> Text+renderRepoFormat Docker = "docker"+renderRepoFormat Maven = "maven"+renderRepoFormat Npm = "npm"+renderRepoFormat Python = "python"+renderRepoFormat Apt = "apt"+renderRepoFormat Yum = "yum"++-- | An Artifact Registry repository.+data ArtifactRepo = ArtifactRepo+    { repoName :: Text+    , repoProject :: Project+    , repoLocation :: Region+    , repoFormat :: RepoFormat+    }+    deriving (Eq, Show)++-- | Idempotently creates an Artifact Registry repository.+artifactRepository :: Reporter Report -> Track' (Binary "gcloud") -> ArtifactRepo -> Op+artifactRepository r gcloudTrack repo =+    withBinary gcloudTrack artifactRegistryCommand (ReposCreate repo) $ \create ->+        withBinary gcloudTrack artifactRegistryCommand (ReposDelete repo) $ \delete ->+            op "gcp-artifact-registry" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["creates Artifact Registry repository", repo.repoName]+                    , ref = mkRef "gcp-artifact-registry" (repo.repoProject.projectId, repo.repoLocation.regionName, repo.repoName)+                    , up = Core.retryingIO Core.afterEnableRetries Core.afterEnableDelay (create r')+                    , down = Core.downIfPresent checkRepo (delete r')+                    , check = checkRepo+                    }+  where+    r' = contramap (RunArtifactRegistryCommand (ReposCreate repo)) r+    checkRepo :: IO CheckResult+    checkRepo = do+        (code, _out, _err) <-+            readCreateProcessWithExitCode+                (prepare artifactRegistryCommand (ReposDescribe repo))+                ""+        pure $ interpretRepoDescribe repo.repoName code++-- | The verdict drawn from @gcloud artifacts repositories describe@'s exit+-- code, split out for testability.+interpretRepoDescribe :: Text -> ExitCode -> CheckResult+interpretRepoDescribe _name ExitSuccess = Success+interpretRepoDescribe name (ExitFailure _) = Failure ("repository not found: " <> name)++-- | Configures the local docker client to authenticate with Artifact Registry.+configureDockerAuth :: Reporter Report -> Track' (Binary "gcloud") -> Project -> Region -> Op+configureDockerAuth r gcloudTrack project region =+    withBinary gcloudTrack artifactRegistryCommand (AuthConfigureDocker project region) $ \up ->+        op "gcp-docker-auth" nodeps $ \actions ->+            actions+                { help = Text.unwords ["configures docker auth for", dockerHost region]+                , ref = mkRef "gcp-docker-auth" (dockerHost region)+                , up = up r'+                }+  where+    r' = contramap (RunArtifactRegistryCommand (AuthConfigureDocker project region)) r++    dockerHost :: Region -> Text+    dockerHost rgn = rgn.regionName <> "-docker.pkg.dev"++-------------------------------------------------------------------------------++data ArtifactRegistryCommand+    = ReposCreate ArtifactRepo+    | ReposDescribe ArtifactRepo+    | ReposDelete ArtifactRepo+    | AuthConfigureDocker Project Region+    deriving (Show)++{- | @gcloud artifacts@ spells its regional flag @--location@; @--region@ is+rejected outright (@unrecognized arguments@), so this does not go through+"Salmon.Builtin.Nodes.Gcp.Core".@withRegion@ the way @run@\/@compute@ do.+-}+withLocation :: Region -> [String] -> [String]+withLocation rgn args = args <> ["--location", Text.unpack rgn.regionName]++artifactRegistryCommand :: Command "gcloud" ArtifactRegistryCommand+artifactRegistryCommand = Command $ \cmd -> case cmd of+    ReposCreate repo ->+        gcloudProc $+            withProject repo.repoProject+                ( withLocation repo.repoLocation+                    [ "artifacts"+                    , "repositories"+                    , "create"+                    , Text.unpack repo.repoName+                    , "--repository-format"+                    , Text.unpack (renderRepoFormat repo.repoFormat)+                    ]+                )+    ReposDescribe repo ->+        gcloudProc $+            withProject repo.repoProject+                ( withLocation repo.repoLocation+                    [ "artifacts"+                    , "repositories"+                    , "describe"+                    , Text.unpack repo.repoName+                    ]+                )+    ReposDelete repo ->+        gcloudProc $+            withProject repo.repoProject+                ( withLocation repo.repoLocation+                    [ "artifacts"+                    , "repositories"+                    , "delete"+                    , Text.unpack repo.repoName+                    , "--quiet"+                    ]+                )+    AuthConfigureDocker _project region ->+        gcloudProc+            [ "auth"+            , "configure-docker"+            , Text.unpack region.regionName <> "-docker.pkg.dev"+            ]
+ src/Salmon/Builtin/Nodes/Gcp/Billing.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Linking a GCP project to a billing account (@gcloud billing projects+link@) -- the other prerequisite (alongside+"Salmon.Builtin.Nodes.Gcp.ServiceUsage") that a freshly-created project+needs before most other APIs will do anything, since GCP refuses to enable+most billable services on a project with no billing account attached.++Resolving a billing account by its human-facing display name (as the koli+provisioning script this was ported from does, via @gcloud billing accounts+list --filter=displayName:...@) is left to config generation, same as+"Salmon.Builtin.Nodes.Gcp.Core".'Salmon.Builtin.Nodes.Gcp.Core.Project' --+this module only ever takes an already-resolved 'BillingAccount' id.+-}+module Salmon.Builtin.Nodes.Gcp.Billing (+    BillingAccount (..),+    linkBillingAccount,+    interpretBillingDescribe,+    Report (..),+    BillingCommand (..),+    billingCommand,+) where++import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import GHC.IO.Exception (ExitCode (..))+import System.Process.ByteString (readCreateProcessWithExitCode)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Gcp.Core (Project (..), gcloudProc)+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++data Report+    = RunBillingCommand !BillingCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++{- | A GCP billing account id, e.g. @XXXXXX-XXXXXX-XXXXXX@ -- bare, without+the @billingAccounts/@ resource-name prefix @gcloud billing accounts list@+returns it with, the same convention+"Salmon.Builtin.Nodes.Gcp.Core".'Salmon.Builtin.Nodes.Gcp.Core.Project'+uses for a bare project id.+-}+newtype BillingAccount = BillingAccount {billingAccountId :: Text}+    deriving (Eq, Ord, Show)++-- | Idempotently links a project to a billing account.+linkBillingAccount :: Reporter Report -> Track' (Binary "gcloud") -> Project -> BillingAccount -> Op+linkBillingAccount r gcloudTrack project account =+    withBinary gcloudTrack billingCommand (ProjectsLink project account) $ \link ->+        withBinary gcloudTrack billingCommand (ProjectsUnlink project) $ \unlink ->+            op "gcp-billing-link" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["links project", project.projectId, "to billing account", account.billingAccountId]+                    , ref = mkRef "gcp-billing-link" project.projectId+                    , up = link r'+                    , down = unlink r'+                    , check = checkLink+                    }+  where+    r' = contramap (RunBillingCommand (ProjectsLink project account)) r++    checkLink :: IO CheckResult+    checkLink = do+        (code, out, _err) <-+            readCreateProcessWithExitCode+                (prepare billingCommand (ProjectsDescribe project))+                ""+        pure $ interpretBillingDescribe account code (Text.decodeUtf8 out)++{- | The verdict drawn from @gcloud billing projects describe@'s exit code+and output, split out for testability. Plain (YAML-ish) output is used+rather than @--format=json@ so this stays a substring check, the same+shape as "Salmon.Builtin.Nodes.Gcp.Iam".@interpretBindingPolicy@.+-}+interpretBillingDescribe :: BillingAccount -> ExitCode -> Text -> CheckResult+interpretBillingDescribe _account (ExitFailure n) _outText =+    Failure ("could not describe project billing (exit " <> Text.pack (show n) <> ")")+interpretBillingDescribe account ExitSuccess outText =+    if accountLine `Text.isInfixOf` outText && enabledLine `Text.isInfixOf` outText+        then Success+        else Failure ("project not linked to billing account " <> account.billingAccountId)+  where+    accountLine = "billingAccountName: billingAccounts/" <> account.billingAccountId+    enabledLine = "billingEnabled: true"++-------------------------------------------------------------------------------++data BillingCommand+    = ProjectsLink Project BillingAccount+    | ProjectsDescribe Project+    | ProjectsUnlink Project+    deriving (Show)++billingCommand :: Command "gcloud" BillingCommand+billingCommand = Command $ \cmd -> case cmd of+    ProjectsLink project account ->+        gcloudProc+            [ "billing"+            , "projects"+            , "link"+            , Text.unpack project.projectId+            , "--billing-account"+            , Text.unpack account.billingAccountId+            ]+    ProjectsDescribe project ->+        gcloudProc+            [ "billing"+            , "projects"+            , "describe"+            , Text.unpack project.projectId+            ]+    ProjectsUnlink project ->+        gcloudProc+            [ "billing"+            , "projects"+            , "unlink"+            , Text.unpack project.projectId+            ]
+ src/Salmon/Builtin/Nodes/Gcp/CloudRun.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE OverloadedStrings #-}++module Salmon.Builtin.Nodes.Gcp.CloudRun (+    IngressSetting (..),+    SecretBinding (..),+    renderSecretBinding,+    CloudRunOptions (..),+    defaultCloudRunOptions,+    CloudRunService (..),+    cloudRunService,+    interpretServiceDescribe,+    interpretServicePresence,+    Report (..),+    CloudRunCommand (..),+    cloudRunCommand,+) where++import Data.Aeson (Value (..), eitherDecodeStrict)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Foldable (toList)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import GHC.IO.Exception (ExitCode (..))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (proc)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Gcp.Core (Project (..), Region (..), gcloudProc, withProject, withRegion)+import qualified Salmon.Builtin.Nodes.Gcp.Core as Core+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++data Report+    = RunCloudRunCommand !CloudRunCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++-- | Ingress settings for a CloudRun service.+data IngressSetting+    = All+    | Internal+    | InternalAndLoadBalancing+    deriving (Eq, Show)++renderIngress :: IngressSetting -> Text+renderIngress All = "all"+renderIngress Internal = "internal"+renderIngress InternalAndLoadBalancing = "internal-and-cloud-load-balancing"++{- | One Secret Manager secret made visible to the container, either as a+file or as an environment variable.++The file form is what credentials want. An environment variable is readable+by anything that can list the process's environment and tends to end up in+logs and crash reports; a mounted file can be read once at start-up and has+a path that is not printed by accident.++Mounting has one wrinkle that has bitten everyone who has done this with+@libpq@: __Cloud Run's secret volumes are read-only and cannot be chmod'ed__,+and libpq refuses a client key whose mode is wider than @0600@. The way+through is to mount somewhere neutral and have the entrypoint copy the+files, which is what "SreBox.Gcp.PostgrestCloudRun" generates.+-}+data SecretBinding+    = -- | mounted at this absolute path+      SecretFile FilePath Text Text+    | -- | injected as this environment variable+      SecretEnvVar Text Text Text+    deriving (Eq, Show)++-- | gcloud's own @--set-secrets@ syntax: @TARGET=SECRET:VERSION@.+renderSecretBinding :: SecretBinding -> Text+renderSecretBinding (SecretFile path name version) =+    Text.pack path <> "=" <> name <> ":" <> version+renderSecretBinding (SecretEnvVar var name version) =+    var <> "=" <> name <> ":" <> version++{- | The knobs beyond "run this image", grouped so that adding one does not+break every record construction in the tree.+-}+data CloudRunOptions = CloudRunOptions+    { croSecrets :: [SecretBinding]+    , croCpu :: Maybe Text+    , croMemory :: Maybe Text+    , croConcurrency :: Maybe Int+    , croTimeoutSeconds :: Maybe Int+    , croPort :: Maybe Int+    , croAllowUnauthenticated :: Bool+    -- ^ whether the service answers unauthenticated callers. 'False' (the+    -- default) leaves the deploy alone rather than passing+    -- @--no-allow-unauthenticated@, so a service fronted by a load balancer+    -- or governed by an org policy is not fought with on every pass.+    , croInvokerIamCheckDisabled :: Bool+    -- ^ @--no-invoker-iam-check@: the service answers every caller without+    -- consulting IAM at all. This is the way to make a service public under+    -- an organization whose @iam.allowedPolicyMemberDomains@ policy forbids+    -- the @allUsers@ binding that 'croAllowUnauthenticated' asks for: there,+    -- @gcloud run deploy --allow-unauthenticated@ deploys fine, only warns+    -- that the binding was refused, and the service answers 403 to everyone.+    -- Being part of the service's spec rather than a separate IAM write, it+    -- either deploys or fails. 'False' (the default) leaves the deploy alone.+    }+    deriving (Eq, Show)++-- | Nothing set: the same deploy this module made before these knobs existed.+defaultCloudRunOptions :: CloudRunOptions+defaultCloudRunOptions =+    CloudRunOptions+        { croSecrets = []+        , croCpu = Nothing+        , croMemory = Nothing+        , croConcurrency = Nothing+        , croTimeoutSeconds = Nothing+        , croPort = Nothing+        , croAllowUnauthenticated = False+        , croInvokerIamCheckDisabled = False+        }++-- | A CloudRun service.+data CloudRunService = CloudRunService+    { crsName :: Text+    , crsProject :: Project+    , crsRegion :: Region+    , crsImage :: Text+    , crsEnv :: Map Text Text+    , crsServiceAccount :: Text+    , crsIngress :: IngressSetting+    , crsMaxInstances :: Maybe Int+    , crsOptions :: CloudRunOptions+    }+    deriving (Eq, Show)++-- | Deploys a CloudRun service from an image already pushed to Artifact+-- Registry.+cloudRunService :: Reporter Report -> Track' (Binary "gcloud") -> CloudRunService -> Op+cloudRunService r gcloudTrack svc =+    withBinary gcloudTrack cloudRunCommand (RunDeploy svc) $ \deploy ->+        withBinary gcloudTrack cloudRunCommand (RunDelete svc) $ \delete ->+            op "gcp-cloudrun-service" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["deploys CloudRun service", svc.crsName]+                    , ref = mkRef "gcp-cloudrun-service" (svc.crsProject.projectId, svc.crsRegion.regionName, svc.crsName)+                    , up = Core.retryingIO Core.afterEnableRetries Core.afterEnableDelay (deploy r')+                    , -- Presence, not the image: a service running an older+                      -- image than the one declared is still there to delete.+                      -- Checking the image here made `down` skip every service+                      -- whose tag had moved with the code since its deploy.+                      down = Core.downIfPresent (uncurry interpretServicePresence <$> describeService) (delete r')+                    , check = checkService+                    }+  where+    r' = contramap (RunCloudRunCommand (RunDeploy svc)) r++    describeService :: IO (ExitCode, Text)+    describeService = do+        (code, out, _err) <-+            readCreateProcessWithExitCode+                (prepare cloudRunCommand (RunDescribe svc))+                ""+        pure (code, Text.decodeUtf8 out)++    checkService :: IO CheckResult+    checkService = uncurry (interpretServiceDescribe svc) <$> describeService++{- | The verdict drawn from @gcloud run services describe --format=json@'s+exit code and output, split out for testability.++The service is satisfied only when what it runs is what was declared, in+three respects, each compared /exactly/ against the service's template (the+revision a deploy would create):++* __the image__, by equality: @img:1@ is not @img:10@, which a substring+  match called the same;+* __the service account__;+* __the plain environment variables__, as a set. @gcloud run deploy+  --set-env-vars@ /replaces/ the service's variables, so a variable the+  service has and the declaration does not is drift too, as is one that has+  a different value or is missing. Variables bound from Secret Manager+  ('croSecrets') have no @value@ and are the secrets' business, not+  compared here.++Every drift is named in the 'Failure', which is what makes @run up@ deploy+again. The reason gives names, never an environment variable's value: those+go into reports. Output that is not the JSON this expects is 'Unknown' — the+check ran and could not tell — rather than a 'Failure' that would redeploy+every pass.+-}+interpretServiceDescribe :: CloudRunService -> ExitCode -> Text -> CheckResult+interpretServiceDescribe _ (ExitFailure n) _ =+    Failure ("CloudRun service not found (exit " <> Text.pack (show n) <> ")")+interpretServiceDescribe svc ExitSuccess outText =+    case eitherDecodeStrict (Text.encodeUtf8 outText) of+        Left _ -> Unknown+        Right v -> case templateOf v of+            Nothing -> Unknown+            Just tmpl -> case drifts svc tmpl of+                [] -> Success+                ds -> Failure ("CloudRun service found but differs from what is declared: " <> Text.intercalate "; " ds)++-- | The revision template's @spec@: its first container and its service account.+data Template = Template+    { tmplImage :: Maybe Text+    , tmplServiceAccount :: Maybe Text+    , tmplEnv :: Map Text Text+    -- ^ the plain variables only+    }++templateOf :: Value -> Maybe Template+templateOf v = do+    spec <- field "spec" v >>= field "template" >>= field "spec"+    let container = case field "containers" spec of+            Just (Array cs) | (c : _) <- toList cs -> Just c+            _ -> Nothing+        envEntries = case container >>= field "env" of+            Just (Array es) -> toList es+            _ -> []+        plain e = case (field "name" e, field "valueFrom" e) of+            (Just (String n), Nothing) -> Just (n, maybe "" id (textOf =<< field "value" e))+            _ -> Nothing+    pure+        Template+            { tmplImage = textOf =<< (container >>= field "image")+            , tmplServiceAccount = textOf =<< field "serviceAccountName" spec+            , tmplEnv = Map.fromList (mapMaybe plain envEntries)+            }+  where+    field k (Object o) = KeyMap.lookup (Key.fromText k) o+    field _ _ = Nothing+    textOf (String t) = Just t+    textOf _ = Nothing++drifts :: CloudRunService -> Template -> [Text]+drifts svc t =+    concat+        [ [ "image is " <> shown got <> ", not " <> svc.crsImage+          | got <- [t.tmplImage]+          , got /= Just svc.crsImage+          ]+        , [ "service account is " <> shown got <> ", not " <> svc.crsServiceAccount+          | got <- [t.tmplServiceAccount]+          , got /= Just svc.crsServiceAccount+          ]+        , [ "environment variable " <> k <> " is " <> why+          | (k, why) <- envDrift+          ]+        ]+  where+    shown = maybe "unset" id+    envDrift =+        [(k, "missing") | k <- Map.keys svc.crsEnv, not (Map.member k t.tmplEnv)]+            <> [(k, "not the declared value") | (k, v) <- Map.toList svc.crsEnv, Just got <- [Map.lookup k t.tmplEnv], got /= v]+            <> [(k, "set but not declared") | k <- Map.keys t.tmplEnv, not (Map.member k svc.crsEnv)]++-- | Whether the service exists at all, whatever it runs: what @down@ asks.+interpretServicePresence :: ExitCode -> Text -> CheckResult+interpretServicePresence (ExitFailure n) _ = Failure ("CloudRun service not found (exit " <> Text.pack (show n) <> ")")+interpretServicePresence ExitSuccess _ = Success++-------------------------------------------------------------------------------++data CloudRunCommand+    = RunDeploy CloudRunService+    | RunDescribe CloudRunService+    | RunDelete CloudRunService+    deriving (Show)++{- | The @--set-secrets@ family. One flag carrying every binding, not one+flag per binding: gcloud treats a repeated @--set-secrets@ as a replacement+rather than an addition, so the per-binding form silently deploys with only+the last one.+-}+optionArgs :: CloudRunOptions -> [String]+optionArgs opts =+    concat+        [ if null opts.croSecrets+            then []+            else ["--set-secrets", Text.unpack (Text.intercalate "," (map renderSecretBinding opts.croSecrets))]+        , maybe [] (\v -> ["--cpu", Text.unpack v]) opts.croCpu+        , maybe [] (\v -> ["--memory", Text.unpack v]) opts.croMemory+        , maybe [] (\v -> ["--concurrency", show v]) opts.croConcurrency+        , maybe [] (\v -> ["--timeout", show v]) opts.croTimeoutSeconds+        , maybe [] (\v -> ["--port", show v]) opts.croPort+        , ["--allow-unauthenticated" | opts.croAllowUnauthenticated]+        , ["--no-invoker-iam-check" | opts.croInvokerIamCheckDisabled]+        ]++cloudRunCommand :: Command "gcloud" CloudRunCommand+cloudRunCommand = Command $ \cmd -> case cmd of+    RunDeploy svc ->+        gcloudProc $+            withProject svc.crsProject+                ( withRegion svc.crsRegion+                    ( [ "run"+                      , "deploy"+                      , Text.unpack svc.crsName+                      , "--image"+                      , Text.unpack svc.crsImage+                      , "--service-account"+                      , Text.unpack svc.crsServiceAccount+                      , "--ingress"+                      , Text.unpack (renderIngress svc.crsIngress)+                      ]+                        <> concatMap (\(k, v) -> ["--set-env-vars", Text.unpack k <> "=" <> Text.unpack v]) (Map.toList svc.crsEnv)+                        <> maybe [] (\n -> ["--max-instances", show n]) svc.crsMaxInstances+                        <> optionArgs svc.crsOptions+                    )+                )+    RunDescribe svc ->+        gcloudProc $+            withProject svc.crsProject+                ( withRegion svc.crsRegion+                    [ "run"+                    , "services"+                    , "describe"+                    , Text.unpack svc.crsName+                    , "--format=json"+                    ]+                )+    RunDelete svc ->+        gcloudProc $+            withProject svc.crsProject+                ( withRegion svc.crsRegion+                    [ "run"+                    , "services"+                    , "delete"+                    , Text.unpack svc.crsName+                    , "--quiet"+                    ]+                )
+ src/Salmon/Builtin/Nodes/Gcp/Compute.hs view
@@ -0,0 +1,800 @@+{-# LANGUAGE OverloadedStrings #-}++module Salmon.Builtin.Nodes.Gcp.Compute (+    MachineType (..),+    BootDisk (..),+    Instance (..),+    InstancePower (..),+    gceInstance,+    Address (..),+    address,+    readAddress,+    interpretAddressDescribe,+    FirewallRule (..),+    firewallRule,+    interpretFirewallDescribe,+    SubnetPurpose (..),+    renderSubnetPurpose,+    Subnet (..),+    subnet,+    interpretSubnetDescribe,+    InstanceGroup (..),+    instanceGroup,+    interpretInstanceGroupDescribe,+    instanceGroupMember,+    interpretGroupMembership,+    interpretInstanceStatus,+    interpretInstancePresence,+    InstanceUpPlan (..),+    planInstanceUp,+    Report (..),+    ComputeCommand (..),+    computeCommand,+) where++import Control.Exception (throwIO)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import GHC.IO.Exception (ExitCode (..))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.IO.Error (userError)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Gcp.Core (Project (..), Region (..), Zone (..), gcloudProc, withProject, withZone)+import qualified Salmon.Builtin.Nodes.Gcp.Core as Core+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++data Report+    = RunComputeCommand !ComputeCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++-- | GCE machine type.+data MachineType+    = E2Medium+    | E2Standard2+    | N2Standard4+    | Custom Text+    deriving (Eq, Show)++renderMachineType :: MachineType -> Text+renderMachineType E2Medium = "e2-medium"+renderMachineType E2Standard2 = "e2-standard-2"+renderMachineType N2Standard4 = "n2-standard-4"+renderMachineType (Custom t) = t++-- | Boot disk configuration.+{- | A boot disk, named either by a specific image or by an image family (in+whichever project publishes it). A family is the usual choice: it tracks the+publisher's current image, where a name pins one that is eventually deleted.+-}+data BootDisk = BootDisk+    { bootDiskSizeGb :: Int+    , bootDiskImage :: Maybe Text+    , bootDiskImageFamily :: Maybe Text+    , bootDiskImageProject :: Maybe Text+    }+    deriving (Eq, Show)++{- | Whether the declared instance is meant to be running or stopped+(@TERMINATED@). A stopped instance keeps its disks and its reserved address+and bills for those only, so 'PoweredOff' is how a recipe pauses a machine+without giving up what is on it; @up@ moves between the two, and @down@+deletes either.+-}+data InstancePower = PoweredOn | PoweredOff+    deriving (Eq, Show)++-- | A GCE instance.+data Instance = Instance+    { instanceName :: Text+    , instancePower :: InstancePower+    -- ^ the state @up@ converges to; 'PoweredOn' is the usual one+    , instanceProject :: Project+    , instanceZone :: Zone+    , instanceMachineType :: MachineType+    , instanceBootDisk :: BootDisk+    , instanceNetwork :: Text+    , instanceSubnet :: Text+    , instanceServiceAccount :: Maybe Text+    , instanceMetadata :: Map Text Text+    , instanceMetadataFiles :: Map Text FilePath+    -- ^ metadata whose value is read from a local file+    -- (@--metadata-from-file@) -- how a multi-line @startup-script@ is+    -- passed without quoting it into a single argv value.+    , instanceAddress :: Maybe Text+    -- ^ a reserved static address to attach, by name (see 'address'); an+    -- instance with none gets an ephemeral one GCP picks.+    , instanceTags :: [Text]+    }+    deriving (Eq, Show)++-- | Idempotently manages a GCE instance.+--+-- * 'up': create the instance if absent, then bring it to 'instancePower':+--   start it if @TERMINATED@ or resume it if @SUSPENDED@ for 'PoweredOn',+--   stop it if @RUNNING@ for 'PoweredOff'. See 'planInstanceUp'.+-- * 'down': delete the instance, whatever state it is in.+-- * 'check': report 'Success' if the instance is in the declared state.+gceInstance :: Reporter Report -> Track' (Binary "gcloud") -> Instance -> Op+gceInstance r gcloudTrack inst =+    withBinary gcloudTrack computeCommand (InstancesCreate inst) $ \create ->+        withBinary gcloudTrack computeCommand (InstancesStart inst) $ \start ->+            withBinary gcloudTrack computeCommand (InstancesResume inst) $ \resume ->+                withBinary gcloudTrack computeCommand (InstancesStop inst) $ \stop ->+                    withBinary gcloudTrack computeCommand (InstancesDelete inst) $ \delete ->+                        op "gcp-instance" nodeps $ \actions ->+                            actions+                                { help = Text.unwords [verb, "GCE instance", inst.instanceName]+                                , ref = mkRef "gcp-instance" (inst.instanceProject.projectId, inst.instanceZone.zoneName, inst.instanceName)+                                , up = bringUp create start resume stop+                                , -- presence, not state: a stopped instance is still there to delete+                                  down = Core.downIfPresent (uncurry interpretInstancePresence <$> describeStatus) (delete (contramap (RunComputeCommand (InstancesDelete inst)) r))+                                , check = uncurry (interpretInstanceStatus inst.instancePower) <$> describeStatus+                                }+  where+    rFor cmd = contramap (RunComputeCommand cmd) r++    verb = case inst.instancePower of+        PoweredOn -> "creates"+        PoweredOff -> "creates, stopped,"++    describeStatus :: IO (ExitCode, Text)+    describeStatus = do+        (code, out, _err) <-+            readCreateProcessWithExitCode+                (prepare computeCommand (InstancesDescribeStatus inst))+                ""+        pure (code, Text.strip (Text.decodeUtf8 out))++    -- 'create' alone is what 'up' used to be, which made a stopped instance+    -- unrecoverable: the check says 'Failure', 'up' runs @create@, and+    -- @create@ refuses because the instance exists. Asking first costs one+    -- describe that the check has usually just done.+    bringUp create start resume stop = do+        plan <- uncurry (planInstanceUp inst.instancePower) <$> describeStatus+        case plan of+            CreateInstance -> do+                create (rFor (InstancesCreate inst))+                -- a created instance runs; a stopped declaration stops it right after+                case inst.instancePower of+                    PoweredOn -> pure ()+                    PoweredOff -> stop (rFor (InstancesStop inst))+            StartInstance -> start (rFor (InstancesStart inst))+            ResumeInstance -> resume (rFor (InstancesResume inst))+            StopInstance -> stop (rFor (InstancesStop inst))+            AlreadyThere -> pure ()+            CannotActYet status ->+                throwIO (userError ("instance " <> Text.unpack inst.instanceName <> " is " <> Text.unpack status <> "; retry once it settles"))++-- | The verdict drawn from @gcloud compute instances describe+-- --format=value(status)@ against the declared power state, split out for+-- testability.+interpretInstanceStatus :: InstancePower -> ExitCode -> Text -> CheckResult+interpretInstanceStatus _ (ExitFailure n) _ =+    Failure ("could not describe instance (exit " <> Text.pack (show n) <> ")")+interpretInstanceStatus power ExitSuccess status =+    case status of+        "RUNNING" -> case power of+            PoweredOn -> Success+            PoweredOff -> Failure "instance is RUNNING, stopped wanted"+        "TERMINATED" -> case power of+            PoweredOn -> Failure "instance is TERMINATED"+            PoweredOff -> Success+        "PROVISIONING" -> Unknown+        "STAGING" -> Unknown+        "STOPPING" -> Unknown+        "SUSPENDING" -> Unknown+        "REPAIRING" -> Unknown+        "SUSPENDED" -> Failure "instance is SUSPENDED"+        _ -> Failure ("unexpected instance status: " <> status)++-- | Whether the instance exists at all, whatever it is doing: what @down@ asks.+interpretInstancePresence :: ExitCode -> Text -> CheckResult+interpretInstancePresence (ExitFailure n) _ = Failure ("could not describe instance (exit " <> Text.pack (show n) <> ")")+interpretInstancePresence ExitSuccess _ = Success++-- | What 'gceInstance'\'s 'up' does given the declared power state and the instance's current status.+data InstanceUpPlan+    = CreateInstance+    | StartInstance+    | ResumeInstance+    | StopInstance+    | AlreadyThere+    | -- | a transitional (or unrecognized) status: nothing safe to run now+      CannotActYet Text+    deriving (Eq, Show)++{- | Split out of 'gceInstance' for testability. A failing describe is read+as "absent": if it failed for another reason (credentials, a missing API)+the @create@ that follows fails too, and says why more clearly than a+describe would. A @SUSPENDED@ instance cannot be stopped directly (gcloud+wants it resumed first), so for 'PoweredOff' it is left alone with a word.+-}+planInstanceUp :: InstancePower -> ExitCode -> Text -> InstanceUpPlan+planInstanceUp _ (ExitFailure _) _ = CreateInstance+planInstanceUp PoweredOn ExitSuccess status =+    case status of+        "RUNNING" -> AlreadyThere+        "TERMINATED" -> StartInstance+        "SUSPENDED" -> ResumeInstance+        _ -> CannotActYet status+planInstanceUp PoweredOff ExitSuccess status =+    case status of+        "RUNNING" -> StopInstance+        "TERMINATED" -> AlreadyThere+        "SUSPENDED" -> CannotActYet "SUSPENDED (resume it before declaring it stopped)"+        _ -> CannotActYet status++-------------------------------------------------------------------------------++{- | A reserved regional external IP.++Reserved rather than ephemeral because an ephemeral address is handed out at+instance-create time and taken back when the instance goes away, so nothing+that has to /name/ the machine (an SSH client, a DNS record, a config file)+can be written before it exists. A reserved one is a resource in its own+right: it can be created, read, attached and released on its own schedule.++It still cannot be known when the graph is /declared/ -- GCP picks the+address -- which is why 'readAddress' exists as a separate, out-of-graph+read for a driver to use between two passes.+-}+data Address = Address+    { addressName :: Text+    , addressProject :: Project+    , addressRegion :: Region+    }+    deriving (Eq, Show)++-- | Idempotently reserves a regional external IP.+address :: Reporter Report -> Track' (Binary "gcloud") -> Address -> Op+address r gcloudTrack addr =+    withBinary gcloudTrack computeCommand (AddressesCreate addr) $ \create ->+        withBinary gcloudTrack computeCommand (AddressesDelete addr) $ \delete ->+            op "gcp-address" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["reserves external IP", addr.addressName]+                    , ref = mkRef "gcp-address" (addr.addressProject.projectId, addr.addressRegion.regionName, addr.addressName)+                    , up = Core.retryingIO Core.afterEnableRetries Core.afterEnableDelay (create (rFor' (AddressesCreate addr)))+                    , down = Core.downIfPresent checkAddress (delete (rFor' (AddressesDelete addr)))+                    , check = checkAddress+                    }+  where+    rFor' cmd = contramap (RunComputeCommand cmd) r++    checkAddress :: IO CheckResult+    checkAddress = do+        (code, out, _err) <-+            readCreateProcessWithExitCode (prepare computeCommand (AddressesDescribe addr)) ""+        pure $ interpretAddressDescribe addr.addressName code (Text.strip (Text.decodeUtf8 out))++-- | The verdict drawn from @gcloud compute addresses describe+-- --format=value(address)@, split out for testability.+interpretAddressDescribe :: Text -> ExitCode -> Text -> CheckResult+interpretAddressDescribe name (ExitFailure _) _ = Failure ("address not reserved: " <> name)+interpretAddressDescribe name ExitSuccess out+    | Text.null out = Failure ("address reserved but has no IP: " <> name)+    | otherwise = Success++{- | Reads a reserved address's actual IP, outside any graph.++Deliberately not an 'Op': what GCP picked is knowable only after the address+node's @up@, while an 'Op' that needs the IP (an ssh endpoint, say) is built+before any @up@ runs. A driver that wants both therefore converges once,+calls this, and declares the rest -- see @salmon-apps@'s @GcpToy@ tier 2 and+its driver script. 'Nothing' when the address does not exist yet.+-}+readAddress :: Address -> IO (Maybe Text)+readAddress addr = do+    (code, out, _err) <-+        readCreateProcessWithExitCode (prepare computeCommand (AddressesDescribe addr)) ""+    let ip = Text.strip (Text.decodeUtf8 out)+    pure $ case code of+        ExitSuccess | not (Text.null ip) -> Just ip+        _ -> Nothing++-------------------------------------------------------------------------------++-- | An ingress firewall rule on a network, scoped to instances carrying a tag.+data FirewallRule = FirewallRule+    { firewallName :: Text+    , firewallProject :: Project+    , firewallNetwork :: Text+    , firewallAllow :: Text+    -- ^ gcloud's own @--allow@ syntax, e.g. @tcp:22@+    , firewallSourceRanges :: [Text]+    , firewallTargetTags :: [Text]+    }+    deriving (Eq, Show)++-- | Idempotently creates an ingress firewall rule.+firewallRule :: Reporter Report -> Track' (Binary "gcloud") -> FirewallRule -> Op+firewallRule r gcloudTrack fw =+    withBinary gcloudTrack computeCommand (FirewallCreate fw) $ \create ->+        withBinary gcloudTrack computeCommand (FirewallDelete fw) $ \delete ->+            op "gcp-firewall-rule" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["allows", fw.firewallAllow, "to", Text.intercalate "," fw.firewallTargetTags]+                    , ref = mkRef "gcp-firewall-rule" (fw.firewallProject.projectId, fw.firewallName)+                    , up = Core.retryingIO Core.afterEnableRetries Core.afterEnableDelay (create (rFor'' (FirewallCreate fw)))+                    , down = Core.downIfPresent checkFirewall (delete (rFor'' (FirewallDelete fw)))+                    , check = checkFirewall+                    }+  where+    rFor'' cmd = contramap (RunComputeCommand cmd) r++    checkFirewall :: IO CheckResult+    checkFirewall = do+        (code, _out, _err) <-+            readCreateProcessWithExitCode (prepare computeCommand (FirewallDescribe fw)) ""+        pure $ interpretFirewallDescribe fw.firewallName code++-- | The verdict drawn from @gcloud compute firewall-rules describe@.+interpretFirewallDescribe :: Text -> ExitCode -> CheckResult+interpretFirewallDescribe _name ExitSuccess = Success+interpretFirewallDescribe name (ExitFailure _) = Failure ("firewall rule not found: " <> name)++-------------------------------------------------------------------------------++{- | What a subnetwork is /for/, which for one kind of subnet is the whole+point of creating it.++@REGIONAL_MANAGED_PROXY@ is the proxy-only subnet a regional+@EXTERNAL_MANAGED@ Application Load Balancer runs its Envoy proxies in.+Nothing is ever placed in it by hand -- it holds no instances, and its range+is where the load balancer's connections to the backends /come from/, which+is what a backend's firewall rule has to allow. One @ACTIVE@ proxy-only+subnet may exist per network per region, and until it does, every attempt to+create such a balancer's forwarding rule fails.+-}+data SubnetPurpose+    = PrivateSubnet+    | RegionalManagedProxy+    deriving (Eq, Show)++renderSubnetPurpose :: SubnetPurpose -> Text+renderSubnetPurpose PrivateSubnet = "PRIVATE"+renderSubnetPurpose RegionalManagedProxy = "REGIONAL_MANAGED_PROXY"++-- | A subnetwork of a VPC network, in one region.+data Subnet = Subnet+    { subnetName :: Text+    , subnetProject :: Project+    , subnetRegion :: Region+    , subnetNetwork :: Text+    , subnetRange :: Text+    -- ^ CIDR. In an /auto mode/ network (which @default@ is), it must not+    -- overlap @10.128.0.0\/9@: that whole block is reserved for the subnets+    -- GCP creates per region on its own, including regions that do not exist+    -- yet.+    , subnetPurpose :: SubnetPurpose+    }+    deriving (Eq, Show)++-- | Idempotently creates a subnetwork.+subnet :: Reporter Report -> Track' (Binary "gcloud") -> Subnet -> Op+subnet r gcloudTrack net =+    withBinary gcloudTrack computeCommand (SubnetsCreate net) $ \create ->+        withBinary gcloudTrack computeCommand (SubnetsDelete net) $ \delete ->+            op "gcp-subnet" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["creates subnet", net.subnetName, "for", renderSubnetPurpose net.subnetPurpose]+                    , ref = mkRef "gcp-subnet" (net.subnetProject.projectId, net.subnetRegion.regionName, net.subnetName)+                    , up = Core.retryingIO Core.afterEnableRetries Core.afterEnableDelay (create (rSub (SubnetsCreate net)))+                    , down = Core.downIfPresent checkSubnet (delete (rSub (SubnetsDelete net)))+                    , check = checkSubnet+                    }+  where+    rSub cmd = contramap (RunComputeCommand cmd) r++    checkSubnet :: IO CheckResult+    checkSubnet = do+        (code, out, _err) <-+            readCreateProcessWithExitCode (prepare computeCommand (SubnetsDescribe net)) ""+        pure $ interpretSubnetDescribe net.subnetName (renderSubnetPurpose net.subnetPurpose) code (Text.strip (Text.decodeUtf8 out))++{- | The verdict drawn from @gcloud compute networks subnets describe+--format=value(purpose)@, split out for testability.++The purpose is compared rather than merely noting the subnet exists, because+a subnet of the wrong purpose is the one failure mode worth catching here: a+plain subnet answers @describe@ perfectly well and then the balancer refuses+to use it, at a point far away from this node.+-}+interpretSubnetDescribe :: Text -> Text -> ExitCode -> Text -> CheckResult+interpretSubnetDescribe name _ (ExitFailure _) _ = Failure ("subnet not found: " <> name)+interpretSubnetDescribe name wanted ExitSuccess out+    | out == wanted = Success+    -- gcloud renders an ordinary subnet's purpose as PRIVATE, but has also+    -- left it empty in the past; an empty answer is only satisfying if that+    -- is what was asked for.+    | Text.null out && wanted == "PRIVATE" = Success+    | otherwise = Failure ("subnet " <> name <> " has purpose " <> out <> ", wanted " <> wanted)++-------------------------------------------------------------------------------++{- | An /unmanaged/, zonal instance group: a bag of instances that already+exist, which is what makes it the right backend for a load balancer in front+of VMs salmon itself declared. (A managed group is the other way round -- it+creates the instances, from a template.)+-}+data InstanceGroup = InstanceGroup+    { groupName :: Text+    , groupProject :: Project+    , groupZone :: Zone+    }+    deriving (Eq, Show)++-- | Idempotently creates an unmanaged instance group.+instanceGroup :: Reporter Report -> Track' (Binary "gcloud") -> InstanceGroup -> Op+instanceGroup r gcloudTrack grp =+    withBinary gcloudTrack computeCommand (InstanceGroupsCreate grp) $ \create ->+        withBinary gcloudTrack computeCommand (InstanceGroupsDelete grp) $ \delete ->+            op "gcp-instance-group" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["creates unmanaged instance group", grp.groupName]+                    , ref = mkRef "gcp-instance-group" (grp.groupProject.projectId, grp.groupZone.zoneName, grp.groupName)+                    , up = Core.retryingIO Core.afterEnableRetries Core.afterEnableDelay (create (rGrp (InstanceGroupsCreate grp)))+                    , down = Core.downIfPresent checkGroup (delete (rGrp (InstanceGroupsDelete grp)))+                    , check = checkGroup+                    }+  where+    rGrp cmd = contramap (RunComputeCommand cmd) r++    checkGroup :: IO CheckResult+    checkGroup = do+        (code, _out, _err) <-+            readCreateProcessWithExitCode (prepare computeCommand (InstanceGroupsDescribe grp)) ""+        pure $ interpretInstanceGroupDescribe grp.groupName code++-- | The verdict drawn from @gcloud compute instance-groups unmanaged describe@.+interpretInstanceGroupDescribe :: Text -> ExitCode -> CheckResult+interpretInstanceGroupDescribe _name ExitSuccess = Success+interpretInstanceGroupDescribe name (ExitFailure _) = Failure ("instance group not found: " <> name)++{- | One instance's membership of an unmanaged group, as a node of its own+rather than a field of 'InstanceGroup'.++Separate because the two effects have genuinely different lifetimes and+different failure modes: the group can exist while the instance does not,+@add-instances@ is an error if the instance is already in, and a teardown+has to take the membership out before either end can go. Keeping them apart+also means the dependency edge that matters -- "the instance must exist+first" -- is expressible, which it would not be if membership were a field+of the group.+-}+instanceGroupMember :: Reporter Report -> Track' (Binary "gcloud") -> InstanceGroup -> Text -> Op+instanceGroupMember r gcloudTrack grp instName =+    withBinary gcloudTrack computeCommand (InstanceGroupsAddInstance grp instName) $ \add ->+        withBinary gcloudTrack computeCommand (InstanceGroupsRemoveInstance grp instName) $ \remove ->+            op "gcp-instance-group-member" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["adds", instName, "to instance group", grp.groupName]+                    , ref = mkRef "gcp-instance-group-member" (grp.groupProject.projectId, grp.groupZone.zoneName, grp.groupName, instName)+                    , up = add (rMem (InstanceGroupsAddInstance grp instName))+                    , down = Core.downIfPresent checkMember (remove (rMem (InstanceGroupsRemoveInstance grp instName)))+                    , check = checkMember+                    }+  where+    rMem cmd = contramap (RunComputeCommand cmd) r++    checkMember :: IO CheckResult+    checkMember = do+        (code, out, _err) <-+            readCreateProcessWithExitCode (prepare computeCommand (InstanceGroupsListInstances grp)) ""+        pure $ interpretGroupMembership instName code (Text.decodeUtf8 out)++{- | The verdict drawn from @gcloud compute instance-groups list-instances+--format=value(instance)@, whose lines are full resource URLs.++Matching on the last path segment rather than by substring, so that an+instance named @web@ is not read as present because @web-canary@ is.+-}+interpretGroupMembership :: Text -> ExitCode -> Text -> CheckResult+interpretGroupMembership name (ExitFailure _) _ = Failure ("could not list the group's instances (looking for " <> name <> ")")+interpretGroupMembership name ExitSuccess out+    | name `elem` map lastSegment (Text.lines out) = Success+    | otherwise = Failure ("instance not in the group: " <> name)+  where+    lastSegment = last . Text.splitOn "/" . Text.strip++-------------------------------------------------------------------------------++data ComputeCommand+    = InstancesCreate Instance+    | InstancesDescribe Instance+    | InstancesDescribeStatus Instance+    | InstancesStart Instance+    | InstancesResume Instance+    | InstancesStop Instance+    | InstancesDelete Instance+    | AddressesCreate Address+    | AddressesDescribe Address+    | AddressesDelete Address+    | FirewallCreate FirewallRule+    | FirewallDescribe FirewallRule+    | FirewallDelete FirewallRule+    | SubnetsCreate Subnet+    | SubnetsDescribe Subnet+    | SubnetsDelete Subnet+    | InstanceGroupsCreate InstanceGroup+    | InstanceGroupsDescribe InstanceGroup+    | InstanceGroupsDelete InstanceGroup+    | InstanceGroupsAddInstance InstanceGroup Text+    | InstanceGroupsRemoveInstance InstanceGroup Text+    | InstanceGroupsListInstances InstanceGroup+    deriving (Show)++computeCommand :: Command "gcloud" ComputeCommand+computeCommand = Command $ \cmd -> case cmd of+    InstancesCreate inst ->+        gcloudProc $+            withProject inst.instanceProject+                ( withZone inst.instanceZone+                    [ "compute"+                    , "instances"+                    , "create"+                    , Text.unpack inst.instanceName+                    , "--machine-type"+                    , Text.unpack (renderMachineType inst.instanceMachineType)+                    , "--boot-disk-size"+                    , show inst.instanceBootDisk.bootDiskSizeGb <> "GB"+                    , "--network"+                    , Text.unpack inst.instanceNetwork+                    , "--subnet"+                    , Text.unpack inst.instanceSubnet+                    ]+                )+                <> maybe [] (\img -> ["--image", Text.unpack img]) inst.instanceBootDisk.bootDiskImage+                <> maybe [] (\fam -> ["--image-family", Text.unpack fam]) inst.instanceBootDisk.bootDiskImageFamily+                <> maybe [] (\proj -> ["--image-project", Text.unpack proj]) inst.instanceBootDisk.bootDiskImageProject+                <> maybe [] (\sa -> ["--service-account", Text.unpack sa]) inst.instanceServiceAccount+                <> concatMap (\(k, v) -> ["--metadata", Text.unpack k <> "=" <> Text.unpack v]) (Map.toList inst.instanceMetadata)+                <> concatMap (\(k, v) -> ["--metadata-from-file", Text.unpack k <> "=" <> v]) (Map.toList inst.instanceMetadataFiles)+                <> maybe [] (\addr -> ["--address", Text.unpack addr]) inst.instanceAddress+                <> if null inst.instanceTags then [] else ["--tags", Text.unpack (Text.intercalate "," inst.instanceTags)]+    InstancesDescribe inst ->+        gcloudProc $+            withProject inst.instanceProject+                ( withZone inst.instanceZone+                    [ "compute"+                    , "instances"+                    , "describe"+                    , Text.unpack inst.instanceName+                    ]+                )+    InstancesDescribeStatus inst ->+        gcloudProc $+            withProject inst.instanceProject+                ( withZone inst.instanceZone+                    [ "compute"+                    , "instances"+                    , "describe"+                    , Text.unpack inst.instanceName+                    , "--format=value(status)"+                    ]+                )+    InstancesStart inst ->+        gcloudProc $+            withProject inst.instanceProject+                ( withZone inst.instanceZone+                    [ "compute"+                    , "instances"+                    , "start"+                    , Text.unpack inst.instanceName+                    ]+                )+    InstancesStop inst ->+        gcloudProc $+            withProject inst.instanceProject+                ( withZone inst.instanceZone+                    [ "compute"+                    , "instances"+                    , "stop"+                    , Text.unpack inst.instanceName+                    ]+                )+    InstancesResume inst ->+        gcloudProc $+            withProject inst.instanceProject+                ( withZone inst.instanceZone+                    [ "compute"+                    , "instances"+                    , "resume"+                    , Text.unpack inst.instanceName+                    ]+                )+    InstancesDelete inst ->+        gcloudProc $+            withProject inst.instanceProject+                ( withZone inst.instanceZone+                    [ "compute"+                    , "instances"+                    , "delete"+                    , Text.unpack inst.instanceName+                    , "--quiet"+                    ]+                )+    AddressesCreate addr ->+        gcloudProc $+            withProject addr.addressProject+                [ "compute"+                , "addresses"+                , "create"+                , Text.unpack addr.addressName+                , "--region"+                , Text.unpack addr.addressRegion.regionName+                ]+    AddressesDescribe addr ->+        gcloudProc $+            withProject addr.addressProject+                [ "compute"+                , "addresses"+                , "describe"+                , Text.unpack addr.addressName+                , "--region"+                , Text.unpack addr.addressRegion.regionName+                , "--format=value(address)"+                ]+    AddressesDelete addr ->+        gcloudProc $+            withProject addr.addressProject+                [ "compute"+                , "addresses"+                , "delete"+                , Text.unpack addr.addressName+                , "--region"+                , Text.unpack addr.addressRegion.regionName+                , "--quiet"+                ]+    FirewallCreate fw ->+        gcloudProc $+            withProject fw.firewallProject+                [ "compute"+                , "firewall-rules"+                , "create"+                , Text.unpack fw.firewallName+                , "--network"+                , Text.unpack fw.firewallNetwork+                , "--allow"+                , Text.unpack fw.firewallAllow+                , "--source-ranges"+                , Text.unpack (Text.intercalate "," fw.firewallSourceRanges)+                ]+                <> if null fw.firewallTargetTags then [] else ["--target-tags", Text.unpack (Text.intercalate "," fw.firewallTargetTags)]+    FirewallDescribe fw ->+        gcloudProc $+            withProject fw.firewallProject+                [ "compute"+                , "firewall-rules"+                , "describe"+                , Text.unpack fw.firewallName+                ]+    FirewallDelete fw ->+        gcloudProc $+            withProject fw.firewallProject+                [ "compute"+                , "firewall-rules"+                , "delete"+                , Text.unpack fw.firewallName+                , "--quiet"+                ]+    SubnetsCreate net ->+        gcloudProc $+            withProject net.subnetProject+                [ "compute"+                , "networks"+                , "subnets"+                , "create"+                , Text.unpack net.subnetName+                , "--network"+                , Text.unpack net.subnetNetwork+                , "--region"+                , Text.unpack net.subnetRegion.regionName+                , "--range"+                , Text.unpack net.subnetRange+                , "--purpose"+                , Text.unpack (renderSubnetPurpose net.subnetPurpose)+                ]+                -- a proxy-only subnet is either the region's ACTIVE one or a+                -- BACKUP held for a migration; gcloud demands the choice.+                <> case net.subnetPurpose of+                    RegionalManagedProxy -> ["--role", "ACTIVE"]+                    PrivateSubnet -> []+    SubnetsDescribe net ->+        gcloudProc $+            withProject net.subnetProject+                [ "compute"+                , "networks"+                , "subnets"+                , "describe"+                , Text.unpack net.subnetName+                , "--region"+                , Text.unpack net.subnetRegion.regionName+                , "--format=value(purpose)"+                ]+    SubnetsDelete net ->+        gcloudProc $+            withProject net.subnetProject+                [ "compute"+                , "networks"+                , "subnets"+                , "delete"+                , Text.unpack net.subnetName+                , "--region"+                , Text.unpack net.subnetRegion.regionName+                , "--quiet"+                ]+    InstanceGroupsCreate grp ->+        gcloudProc $+            withProject grp.groupProject+                ( withZone+                    grp.groupZone+                    ["compute", "instance-groups", "unmanaged", "create", Text.unpack grp.groupName]+                )+    InstanceGroupsDescribe grp ->+        gcloudProc $+            withProject grp.groupProject+                ( withZone+                    grp.groupZone+                    ["compute", "instance-groups", "unmanaged", "describe", Text.unpack grp.groupName]+                )+    InstanceGroupsDelete grp ->+        gcloudProc $+            withProject grp.groupProject+                ( withZone+                    grp.groupZone+                    ["compute", "instance-groups", "unmanaged", "delete", Text.unpack grp.groupName, "--quiet"]+                )+    InstanceGroupsAddInstance grp instName ->+        gcloudProc $+            withProject grp.groupProject+                ( withZone+                    grp.groupZone+                    [ "compute"+                    , "instance-groups"+                    , "unmanaged"+                    , "add-instances"+                    , Text.unpack grp.groupName+                    , "--instances"+                    , Text.unpack instName+                    ]+                )+    InstanceGroupsRemoveInstance grp instName ->+        gcloudProc $+            withProject grp.groupProject+                ( withZone+                    grp.groupZone+                    [ "compute"+                    , "instance-groups"+                    , "unmanaged"+                    , "remove-instances"+                    , Text.unpack grp.groupName+                    , "--instances"+                    , Text.unpack instName+                    ]+                )+    InstanceGroupsListInstances grp ->+        gcloudProc $+            withProject grp.groupProject+                ( withZone+                    grp.groupZone+                    [ "compute"+                    , "instance-groups"+                    , "list-instances"+                    , Text.unpack grp.groupName+                    , "--format=value(instance)"+                    ]+                )
+ src/Salmon/Builtin/Nodes/Gcp/Core.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE OverloadedStrings #-}++module Salmon.Builtin.Nodes.Gcp.Core (+    -- * GCP identity+    Project (..),+    Zone (..),+    Region (..),++    -- * gcloud binary+    gcloud,++    -- * Application Default Credentials+    applicationDefaultCredentials,+    interpretAdc,+    printAccessToken,+    Report (..),+    GcloudCommand (..),+    gcloudCommand,++    -- * teardown+    downIfPresent,++    -- * eventual consistency+    retryingIO,+    afterEnableRetries,+    afterEnableDelay,++    -- * CLI helpers+    gcloudProc,+    withProject,+    withZone,+    withRegion,+) where++import Control.Concurrent (threadDelay)+import Control.Exception (SomeException, throwIO, try)+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.IO.Exception (ExitCode (..))+import System.IO.Error (userError)+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess, proc)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++-- | A GCP project identifier.+newtype Project = Project {projectId :: Text}+    deriving (Eq, Ord, Show)++-- | A GCP zone.+newtype Zone = Zone {zoneName :: Text}+    deriving (Eq, Ord, Show)++-- | A GCP region.+newtype Region = Region {regionName :: Text}+    deriving (Eq, Ord, Show)++-------------------------------------------------------------------------------++data Report+    = RunGcloud !GcloudCommand !Binary.Report+    | RunAdc !Binary.Report+    deriving (Show)++-- | The various gcloud invocations that 'Core' knows how to run.+data GcloudCommand+    = AdcPrintAccessToken+    deriving (Show)++-- | Builds a 'CreateProcess' for a gcloud invocation.+gcloudCommand :: Command "gcloud" GcloudCommand+gcloudCommand = Command $ \cmd -> case cmd of+    AdcPrintAccessToken ->+        gcloudProc ["auth", "application-default", "print-access-token"]++-- | A provider for the @gcloud@ binary. For Phase 1 we assume @gcloud@ is on+-- @PATH@; callers can override with a real installer if they prefer.+gcloud :: Track' (Binary "gcloud")+gcloud = Track $ \_ ->+    op "gcloud" nodeps $ \actions ->+        actions+            { help = "gcloud CLI on PATH"+            , ref = mkRef "gcloud" ("gcloud" :: Text)+            }++-- | Validates Application Default Credentials. Almost every other GCP op+-- should depend on this node.+applicationDefaultCredentials :: Reporter Report -> Track' (Binary "gcloud") -> Op+applicationDefaultCredentials r gcloudTrack =+    withBinary gcloudTrack gcloudCommand AdcPrintAccessToken $ \up ->+        op "gcp-adc" nodeps $ \actions ->+            actions+                { help = "validates GCP Application Default Credentials"+                , ref = mkRef "gcp-adc" ("application-default-credentials" :: Text)+                , up = up r'+                , check = checkAdc+                }+  where+    r' = contramap RunAdc r++    checkAdc :: IO CheckResult+    checkAdc = do+        (code, _out, _err) <-+            readCreateProcessWithExitCode+                (gcloudProc ["auth", "application-default", "print-access-token"])+                ""+        pure $ interpretAdc code++-- | The verdict drawn from @gcloud auth application-default+-- print-access-token@'s exit code, split out for testability.+interpretAdc :: ExitCode -> CheckResult+interpretAdc ExitSuccess = Success+interpretAdc (ExitFailure n) = Failure ("gcloud ADC not available (exit " <> Text.pack (show n) <> ")")++{- | Fetches a fresh OAuth2 access token for the active gcloud identity+(ADC, unless a service account or user has been separately configured).++This is the credential a container registry expects for username+@oauth2accesstoken@ -- see "SreBox.Gcp.CloudRunDeploy", which feeds this+straight into "Salmon.Builtin.Nodes.Podman".@login@'s @IO Text@ password+argument so a fresh token is fetched right when @up@ runs rather than+baked into the graph when it was built (tokens like this are short-lived,+typically ~1h).+-}+printAccessToken :: IO Text+printAccessToken = do+    (code, out, err) <-+        readCreateProcessWithExitCode+            (gcloudProc ["auth", "print-access-token"])+            ""+    case code of+        ExitSuccess -> pure (Text.strip (Text.decodeUtf8 out))+        ExitFailure n ->+            throwIO (userError ("gcloud auth print-access-token failed (exit " <> show n <> "): " <> Text.unpack (Text.decodeUtf8With TextError.lenientDecode err)))++-------------------------------------------------------------------------------+-- Teardown++{- | Runs a teardown action only if the node's own check says the effect is+actually there.++@gcloud@ treats "delete something absent" as an error (@404@, @Service ...+could not be found@, or even @API has not been used in project ...@ when the+service was never enabled), and "Salmon.Actions.UpDown" contains a failing+@down@ by leaving that node standing and marking every /predecessor/+'Blocked'. A node that was never created therefore blocks the teardown of+everything it was declared on top of -- including, for a recipe that owns its+project, the project delete that would have swept it all. That is how four+half-built sandbox projects survived their own @run down@.++A node's check is deliberately never consulted /for/ teardown (it answers+"does my effect need creating", not "is it still there"), so this is the node+author's own business rather than something the driver can do. Erring toward+not-running is the safe direction here: 'Failure' means the effect is gone or+unreachable, and re-running @down@ costs nothing.+-}+downIfPresent :: IO CheckResult -> IO () -> IO ()+downIfPresent runCheck act = do+    result <- runCheck+    case result of+        Success -> act+        _ -> pure ()++-------------------------------------------------------------------------------+-- Eventual consistency++{- | Runs an action, retrying on failure with a fixed delay, rethrowing the+last failure.++GCP grants access asynchronously, past the point where the thing granting it+reports success. Two cases hit this tree, both found by+@salmon-apps@'s @salmon-gcp-toy@ against a real project:++* a __freshly enabled API__ answers @PERMISSION_DENIED ... (or it may not+  exist)@ to the very next create, for up to about a minute, even for a+  project owner;+* a __freshly created service account__ is not yet resolvable by the service+  owning the resource a binding names it on.++So a node whose @up@ can run moments after such a grant retries rather than+failing the whole traversal, since a one-shot driver has no other way to+wait. A genuine permission error still fails the node, just later.+-}+retryingIO :: Int -> Int -> IO () -> IO ()+retryingIO attempts delay act = do+    result <- try act+    case result of+        Right () -> pure ()+        Left (e :: SomeException)+            | attempts <= 1 -> throwIO e+            | otherwise -> threadDelay delay >> retryingIO (attempts - 1) delay act++-- | Attempts for a create that may follow an API enablement: 6 over ~50s.+afterEnableRetries :: Int+afterEnableRetries = 6++-- | Delay between those attempts.+afterEnableDelay :: Int+afterEnableDelay = 10000000++-------------------------------------------------------------------------------+-- CLI helpers++-- | A bare @gcloud@ process with the given sub-command arguments.+gcloudProc :: [String] -> CreateProcess+gcloudProc args = proc "gcloud" args++-- | Append @--project@ to a gcloud argument list.+withProject :: Project -> [String] -> [String]+withProject p args = args <> ["--project", Text.unpack p.projectId]++-- | Append @--zone@ to a gcloud argument list.+withZone :: Zone -> [String] -> [String]+withZone z args = args <> ["--zone", Text.unpack z.zoneName]++-- | Append @--region@ to a gcloud argument list.+withRegion :: Region -> [String] -> [String]+withRegion rgn args = args <> ["--region", Text.unpack rgn.regionName]
+ src/Salmon/Builtin/Nodes/Gcp/Iam.hs view
@@ -0,0 +1,415 @@+{-# LANGUAGE OverloadedStrings #-}++module Salmon.Builtin.Nodes.Gcp.Iam (+    Principal (..),+    IamBinding (..),+    serviceAccount,+    iamBinding,+    interpretServiceAccountDescribe,+    interpretBindingPolicy,+    CustomRole (..),+    customRole,+    interpretRoleDescribe,+    ServiceAccountKey (..),+    serviceAccountKey,+    Report (..),+    IamCommand (..),+    iamCommand,+) where++import Control.Concurrent (threadDelay)+import Control.Exception (throwIO)+import Control.Monad (when)+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.IO.Exception (ExitCode (..))+import System.Directory (doesFileExist, removeFile)+import System.Process.ByteString (readCreateProcessWithExitCode)+import qualified Data.Text.Encoding as Text+import System.Process.ListLike (proc)++import Salmon.Actions.UpDown (CheckResult (..), skipIfFileExists)+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Gcp.Core (Project (..), gcloudProc, retryingIO, withProject)+import qualified Salmon.Builtin.Nodes.Gcp.Core as Core+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++data Report+    = RunIamCommand !IamCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++-- | A GCP IAM principal.+data Principal+    = ServiceAccount Text+    | User Text+    | Group Text+    deriving (Eq, Show)++-- | A binding of a principal to a role on a resource.+data IamBinding = IamBinding+    { iamPrincipal :: Principal+    , iamRole :: Text+    , iamResource :: Text+    }+    deriving (Eq, Show)++renderPrincipal :: Principal -> Text+renderPrincipal (ServiceAccount x) = "serviceAccount:" <> x+renderPrincipal (User x) = "user:" <> x+renderPrincipal (Group x) = "group:" <> x++-- | Creates a service account if it does not exist.+serviceAccount :: Reporter Report -> Track' (Binary "gcloud") -> Project -> Text -> Op+serviceAccount r gcloudTrack project accountId =+    withBinary gcloudTrack iamCommand (ServiceAccountsCreate project accountId) $ \create ->+        withBinary gcloudTrack iamCommand (ServiceAccountsDelete project accountId) $ \delete ->+            op "gcp-service-account" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["creates service account", accountId]+                    , ref = mkRef "gcp-service-account" (project.projectId, accountId)+                    , up = retryingIO Core.afterEnableRetries Core.afterEnableDelay (create r') >> awaitVisible 30+                    , down = Core.downIfPresent checkServiceAccount (delete r')+                    , check = checkServiceAccount+                    }+  where+    r' = contramap (RunIamCommand (ServiceAccountsCreate project accountId)) r++    {- | Creating a service account is eventually consistent: @create@ returns+    before the account is resolvable, and a binding declared against it in the+    same graph then fails with "does not exist". Waiting here (rather than+    retrying in every dependant) is what makes the declared dependency edge+    mean what it looks like it means.+    -}+    awaitVisible :: Int -> IO ()+    awaitVisible remaining = do+        result <- checkServiceAccount+        case result of+            Success -> pure ()+            _+                | remaining <= 0 ->+                    throwIO (userError ("service account never became visible: " <> Text.unpack accountId))+                | otherwise -> threadDelay 2000000 >> awaitVisible (remaining - 1)++    checkServiceAccount :: IO CheckResult+    checkServiceAccount = do+        (code, _out, _err) <-+            readCreateProcessWithExitCode+                (prepare iamCommand (ServiceAccountsDescribe project accountId))+                ""+        pure $ interpretServiceAccountDescribe accountId code++-- | The verdict drawn from @gcloud iam service-accounts describe@'s exit+-- code, split out for testability.+interpretServiceAccountDescribe :: Text -> ExitCode -> CheckResult+interpretServiceAccountDescribe _accountId ExitSuccess = Success+interpretServiceAccountDescribe accountId (ExitFailure _) = Failure ("service account not found: " <> accountId)++-- | Grants a role to a principal on a resource.+--+-- The 'iamResource' should be a gcloud resource reference such as a project+-- id, a bucket name (@buckets\/BUCKET_NAME@), or a service account email.+iamBinding :: Reporter Report -> Track' (Binary "gcloud") -> IamBinding -> Op+iamBinding r gcloudTrack binding =+    withBinary gcloudTrack iamCommand (IamPolicyAddBinding binding) $ \add ->+        withBinary gcloudTrack iamCommand (IamPolicyRemoveBinding binding) $ \remove ->+            op "gcp-iam-binding" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["grants", binding.iamRole, "to", renderPrincipal binding.iamPrincipal]+                    , ref = mkRef "gcp-iam-binding" (renderPrincipal binding.iamPrincipal, binding.iamRole, binding.iamResource)+                    , up = retryingIO 5 3000000 (add r')+                    , down = Core.downIfPresent checkBinding (remove r')+                    , check = checkBinding+                    }+  where+    r' = contramap (RunIamCommand (IamPolicyAddBinding binding)) r++    checkBinding :: IO CheckResult+    checkBinding = do+        (code, out, _err) <-+            readCreateProcessWithExitCode+                (prepare iamCommand (IamPolicyGetBinding binding))+                ""+        pure $ interpretBindingPolicy binding code (Text.decodeUtf8 out)++{- | The verdict drawn from @gcloud ... get-iam-policy@'s exit code and+output, split out for testability.++Very simple heuristic: look for the role and the member on nearby lines. A+robust implementation would parse the YAML/JSON policy.+-}+interpretBindingPolicy :: IamBinding -> ExitCode -> Text -> CheckResult+interpretBindingPolicy _binding (ExitFailure n) _outText =+    Failure ("could not read IAM policy (exit " <> Text.pack (show n) <> ")")+interpretBindingPolicy binding ExitSuccess outText =+    if isBindingPresent+        then Success+        else Failure ("binding not present for " <> member <> " with role " <> role)+  where+    member = renderPrincipal binding.iamPrincipal+    role = binding.iamRole+    isBindingPresent =+        let roleLine = "role: " <> role+            memberLine = "- " <> member+         in Text.isInfixOf roleLine outText && Text.isInfixOf memberLine outText++-------------------------------------------------------------------------------++-- | A custom IAM role, defined by a permissions file (YAML or JSON, as+-- @gcloud iam roles create --file@ accepts).+data CustomRole = CustomRole+    { roleId :: Text+    , roleProject :: Project+    , roleDefinitionFile :: FilePath+    }+    deriving (Eq, Show)++{- | Idempotently creates a custom IAM role from a definition file.++Only handles creation, not drift: like+'Salmon.Builtin.Nodes.Gcp.ArtifactRegistry'.'Salmon.Builtin.Nodes.Gcp.ArtifactRegistry.artifactRepository',+'check' only asks whether the role exists, not whether its permissions+still match 'roleDefinitionFile' -- a changed file after the role's first+creation needs an explicit @gcloud iam roles update@ run by hand (or a+future content-aware check, along the lines of+"Salmon.Builtin.Nodes.Filesystem"'s @checkFileContents@).+-}+customRole :: Reporter Report -> Track' (Binary "gcloud") -> CustomRole -> Op+customRole r gcloudTrack role =+    withBinary gcloudTrack iamCommand (RolesCreate role) $ \create ->+        withBinary gcloudTrack iamCommand (RolesDelete role) $ \delete ->+            op "gcp-custom-role" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["creates custom IAM role", role.roleId]+                    , ref = mkRef "gcp-custom-role" (role.roleProject.projectId, role.roleId)+                    , up = create r'+                    , down = Core.downIfPresent checkRole (delete r')+                    , check = checkRole+                    }+  where+    r' = contramap (RunIamCommand (RolesCreate role)) r++    checkRole :: IO CheckResult+    checkRole = do+        (code, _out, _err) <-+            readCreateProcessWithExitCode+                (prepare iamCommand (RolesDescribe role))+                ""+        pure $ interpretRoleDescribe role.roleId code++-- | The verdict drawn from @gcloud iam roles describe@'s exit code, split+-- out for testability.+interpretRoleDescribe :: Text -> ExitCode -> CheckResult+interpretRoleDescribe _roleId ExitSuccess = Success+interpretRoleDescribe roleId (ExitFailure _) = Failure ("custom role not found: " <> roleId)++-------------------------------------------------------------------------------++{- | A service-account JSON key, written to a local file the first time+this node's 'up' runs.++Deliberately not idempotent the way most other nodes here are: each+@gcloud iam service-accounts keys create@ call mints a genuinely new key+(GCP allows several live keys per service account, with no "give me the+existing one back" verb), so idempotency instead comes from 'check' asking+whether the local file is already there and skipping if so -- the same+shape as "Salmon.Actions.UpDown".@skipIfFileExists@, and the same shape the+koli provisioning script this was ported from used (@[ ! -e "${keypath}"+]@). A key that gets deleted locally without also being revoked on GCP is+therefore replaced by a /second/, different live key on the next 'up' --+the stale one is orphaned on GCP, not overwritten. 'down' does not revoke+the GCP key (there is no reliable way to recover its key id from just the+local file after the fact); it only removes the local file, so a caller+wanting the key actually revoked has to do so by hand (e.g. @gcloud iam+service-accounts keys list@ against the account, then @... keys delete@).+-}+data ServiceAccountKey = ServiceAccountKey+    { sakProject :: Project+    , sakAccountId :: Text+    , sakPath :: FilePath+    }+    deriving (Eq, Show)++-- | Writes a service-account key to 'sakPath' if it isn't there already.+serviceAccountKey :: Reporter Report -> Track' (Binary "gcloud") -> ServiceAccountKey -> Op+serviceAccountKey r gcloudTrack key =+    withBinary gcloudTrack iamCommand (ServiceAccountKeysCreate key) $ \create ->+        op "gcp-service-account-key" nodeps $ \actions ->+            actions+                { help = Text.unwords ["writes a service account key for", key.sakAccountId, "to", Text.pack key.sakPath]+                , ref = mkRef "gcp-service-account-key" (key.sakProject.projectId, key.sakAccountId, key.sakPath)+                , up = create r'+                , down = removeIfPresent key.sakPath+                , check = skipIfFileExists key.sakPath+                }+  where+    r' = contramap (RunIamCommand (ServiceAccountKeysCreate key)) r++    removeIfPresent :: FilePath -> IO ()+    removeIfPresent path = do+        exists <- doesFileExist path+        when exists (removeFile path)++-------------------------------------------------------------------------------++data IamCommand+    = ServiceAccountsCreate Project Text+    | ServiceAccountsDescribe Project Text+    | ServiceAccountsDelete Project Text+    | IamPolicyAddBinding IamBinding+    | IamPolicyRemoveBinding IamBinding+    | IamPolicyGetBinding IamBinding+    | RolesCreate CustomRole+    | RolesDescribe CustomRole+    | RolesDelete CustomRole+    | ServiceAccountKeysCreate ServiceAccountKey+    deriving (Show)++iamCommand :: Command "gcloud" IamCommand+iamCommand = Command $ \cmd -> case cmd of+    ServiceAccountsCreate project accountId ->+        gcloudProc $+            withProject project+                [ "iam"+                , "service-accounts"+                , "create"+                , Text.unpack accountId+                ]+    ServiceAccountsDescribe project accountId ->+        gcloudProc $+            withProject project+                [ "iam"+                , "service-accounts"+                , "describe"+                , Text.unpack accountId <> "@" <> Text.unpack project.projectId <> ".iam.gserviceaccount.com"+                ]+    ServiceAccountsDelete project accountId ->+        gcloudProc $+            withProject project+                [ "iam"+                , "service-accounts"+                , "delete"+                , Text.unpack accountId <> "@" <> Text.unpack project.projectId <> ".iam.gserviceaccount.com"+                , "--quiet"+                ]+    IamPolicyAddBinding binding ->+        let (groupArgs, resourceArg, extraArgs) = iamResourceArgs binding.iamResource+         in gcloudProc $+            groupArgs+                <> [ "add-iam-policy-binding"+                   , resourceArg+                   ]+                <> extraArgs+                <> [ "--member"+                   , Text.unpack (renderPrincipal binding.iamPrincipal)+                   , "--role"+                   , Text.unpack binding.iamRole+                   ]+    IamPolicyRemoveBinding binding ->+        let (groupArgs, resourceArg, extraArgs) = iamResourceArgs binding.iamResource+         in gcloudProc $+            groupArgs+                <> [ "remove-iam-policy-binding"+                   , resourceArg+                   ]+                <> extraArgs+                <> [ "--member"+                   , Text.unpack (renderPrincipal binding.iamPrincipal)+                   , "--role"+                   , Text.unpack binding.iamRole+                   ]+    IamPolicyGetBinding binding ->+        let (groupArgs, resourceArg, extraArgs) = iamResourceArgs binding.iamResource+         in gcloudProc $ groupArgs <> ["get-iam-policy", resourceArg] <> extraArgs+    RolesCreate role ->+        gcloudProc $+            withProject role.roleProject+                [ "iam"+                , "roles"+                , "create"+                , Text.unpack role.roleId+                , "--file"+                , role.roleDefinitionFile+                ]+    RolesDescribe role ->+        gcloudProc $+            withProject role.roleProject+                [ "iam"+                , "roles"+                , "describe"+                , Text.unpack role.roleId+                ]+    RolesDelete role ->+        gcloudProc $+            withProject role.roleProject+                [ "iam"+                , "roles"+                , "delete"+                , Text.unpack role.roleId+                , "--quiet"+                ]+    ServiceAccountKeysCreate key ->+        gcloudProc $+            withProject key.sakProject+                [ "iam"+                , "service-accounts"+                , "keys"+                , "create"+                , key.sakPath+                , "--iam-account"+                , Text.unpack key.sakAccountId <> "@" <> Text.unpack key.sakProject.projectId <> ".iam.gserviceaccount.com"+                ]++{- | Maps a resource reference to the gcloud group arguments, the resource+argument, and any trailing flags to pass to+add\/remove\/get-iam-policy-binding.++Accepted forms:++* @projects\/PROJECT@ (or a bare project id)+* @buckets\/BUCKET@ -- rendered as @gs:\/\/BUCKET@, the URL form+  @gcloud storage buckets@ requires+* @serviceAccounts\/EMAIL@ -- the email already names its project+* @projects\/PROJECT\/secrets\/SECRET@ and+  @projects\/PROJECT\/locations\/LOCATION\/repositories\/REPO@ -- the+  project-qualified forms, which pass @--project@ explicitly+* @secrets\/SECRET@ and @artifacts\/repositories\/LOCATION\/REPO@ -- the+  short forms, which pass no @--project@ and so act on whatever project+  gcloud is configured with /on the machine running salmon/. Prefer the+  qualified forms: the short ones are only right by coincidence.++A resource under a regional collection carries its location, since+@gcloud artifacts repositories ... --location=...@ needs it as a flag placed+after the verb rather than as part of the resource name.+-}+iamResourceArgs :: Text -> ([String], String, [String])+iamResourceArgs res+    | ["projects", pid, "secrets", sec] <- segments =+        (["secrets"], Text.unpack sec, ["--project", Text.unpack pid])+    | ["projects", pid, "locations", location, "repositories", repo] <- segments =+        (["artifacts", "repositories"], Text.unpack repo, ["--location", Text.unpack location, "--project", Text.unpack pid])+    | Just pid <- Text.stripPrefix "projects/" res =+        (["projects"], Text.unpack pid, [])+    | Just bkt <- Text.stripPrefix "buckets/" res =+        (["storage", "buckets"], "gs://" <> Text.unpack (Text.dropWhile (== '/') (dropGs bkt)), [])+    | Just sa <- Text.stripPrefix "serviceAccounts/" res =+        (["iam", "service-accounts"], Text.unpack sa, [])+    | Just sec <- Text.stripPrefix "secrets/" res =+        (["secrets"], Text.unpack sec, [])+    | Just rest <- Text.stripPrefix "artifacts/repositories/" res+    , (location, repoName) <- Text.breakOn "/" rest+    , Just repo <- Text.stripPrefix "/" repoName =+        (["artifacts", "repositories"], Text.unpack repo, ["--location", Text.unpack location])+    | otherwise =+        -- Default: treat as a project id.+        (["projects"], Text.unpack res, [])+  where+    segments = Text.splitOn "/" res+    dropGs t = maybe t id (Text.stripPrefix "gs://" t)
+ src/Salmon/Builtin/Nodes/Gcp/LoadBalancing.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Salmon.Builtin.Nodes.Gcp.LoadBalancing (+    Backend (..),+    InstanceGroupLocation (..),+    HealthCheck (..),+    ApplicationLoadBalancer (..),+    applicationLoadBalancer,+    interpretLbDescribe,+    shellQuote,+    Report (..),+    LoadBalancingCommand (..),+    loadBalancingCommand,+) where++import Data.Text (Text)+import qualified Data.Text as Text+import GHC.IO.Exception (ExitCode (..))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (proc)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Gcp.Core (Project (..), Region (..), gcloudProc, withProject, withRegion)+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++data Report+    = RunLoadBalancingCommand !LoadBalancingCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++-- | A health check for instance-group backends.+data HealthCheck = HealthCheck+    { healthCheckName :: Text+    , healthCheckPort :: Int+    }+    deriving (Eq, Show)++{- | Where an instance group lives, which is not a detail the balancer can+guess: an /unmanaged/ group is zonal and a /managed/ one is usually regional,+and every gcloud call naming the group -- @describe@, @set-named-ports@,+@add-backend@ -- wants the matching flag. Passing the balancer's own region+for both (which this module used to do) simply fails against the common case,+an unmanaged group holding VMs that already exist.+-}+data InstanceGroupLocation+    = InstanceGroupZone Text+    | InstanceGroupRegion Text+    deriving (Eq, Show)++-- | Backend kinds supported by the high-level recipe.+data Backend+    = InstanceGroupBackend Text InstanceGroupLocation [Int]+    | CloudRunBackend Text+    deriving (Eq, Show)++-- | A high-level HTTP(S) load balancer.+data ApplicationLoadBalancer = ApplicationLoadBalancer+    { albName :: Text+    , albProject :: Project+    , albRegion :: Region+    , albNetwork :: Maybe Text+    , albBackends :: [Backend]+    , albHealthCheck :: Maybe HealthCheck+    }+    deriving (Eq, Show)++-- | Creates the load-balancer sub-resources. This is intentionally a single+-- recipe node rather than forcing users to wire every component manually.+applicationLoadBalancer :: Reporter Report -> Track' (Binary "gcloud") -> ApplicationLoadBalancer -> Op+applicationLoadBalancer r gcloudTrack alb =+    withBinary gcloudTrack loadBalancingCommand (LbCreate alb) $ \create ->+        withBinary gcloudTrack loadBalancingCommand (LbDelete alb) $ \delete ->+            op "gcp-application-lb" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["creates application load balancer", alb.albName]+                    , ref = mkRef "gcp-application-lb" (alb.albProject.projectId, alb.albRegion.regionName, alb.albName)+                    , up = create r'+                    , down = delete r'+                    , check = checkLb+                    }+  where+    r' = contramap (RunLoadBalancingCommand (LbCreate alb)) r++    checkLb :: IO CheckResult+    checkLb = do+        (code, _out, _err) <-+            readCreateProcessWithExitCode+                (prepare loadBalancingCommand (LbDescribe alb))+                ""+        pure $ interpretLbDescribe code++-- | The verdict drawn from @gcloud compute url-maps describe@'s exit code,+-- split out for testability. This only tells us the URL map exists, not+-- that every sub-resource it points at is healthy -- see the module-level+-- note on richer LB checks.+interpretLbDescribe :: ExitCode -> CheckResult+interpretLbDescribe ExitSuccess = Success+interpretLbDescribe (ExitFailure n) = Failure ("load balancer not found (exit " <> Text.pack (show n) <> ")")++-------------------------------------------------------------------------------++data LoadBalancingCommand+    = LbCreate ApplicationLoadBalancer+    | LbDescribe ApplicationLoadBalancer+    | LbDelete ApplicationLoadBalancer+    deriving (Show)++loadBalancingCommand :: Command "gcloud" LoadBalancingCommand+loadBalancingCommand = Command $ \cmd -> case cmd of+    LbCreate alb ->+        -- For Phase 1 we create a simple regional HTTP load balancer using a+        -- single backend service and a URL map. Serverless NEGs and managed SSL+        -- certificates are created as separate gcloud calls in a bash script.+        --+        -- The script is run by @bash@ itself, not through 'gcloudProc' (which+        -- would run @gcloud bash -c ...@). 'Command' is still indexed by+        -- @"gcloud"@ because that is the binary the script needs on @PATH@.+        proc "bash" ["-c", Text.unpack (renderLbScript alb)]+    LbDescribe alb ->+        gcloudProc $+            withProject alb.albProject+                ( withRegion alb.albRegion+                    [ "compute"+                    , "url-maps"+                    , "describe"+                    , Text.unpack (alb.albName <> "-url-map")+                    ]+                )+    LbDelete alb ->+        proc "bash" ["-c", Text.unpack (renderLbDeleteScript alb)]++{- | Single-quotes a value for safe interpolation into the generated bash+script (POSIX shell quoting: wrap in single quotes, escape embedded single+quotes as @'\''@). Every 'Text' that ends up in 'renderLbScript'\/+'renderLbDeleteScript' -- project id, region, ALB name, backend\/service+names -- must go through this: these scripts are run via @bash -c@, and+those values ultimately trace back to caller-supplied identifiers (e.g. a+tenant name in a multi-tenant recipe), not just author-typed literals.+-}+shellQuote :: Text -> Text+shellQuote t = "'" <> Text.replace "'" "'\\''" t <> "'"++{- | Renders a bash script that idempotently creates the LB components.++Every step is guarded by a @describe@ (or, for backend attachment, a look at+the backend service's current backends) rather than suffixed with+@|| true@: the latter made the script exit 0 whatever happened, so a+misconfigured balancer was reported as successfully brought up. Under+@set -e@ a failing create now fails the node, as the node-author conventions+require.++The balancer is a /regional external/ Application Load Balancer+(@EXTERNAL_MANAGED@), which GCP only accepts in a VPC network that already+has a proxy-only subnet in the region. This script does not create one --+see "Salmon.Builtin.Nodes.Gcp.Compute".@subnet@ with+'Salmon.Builtin.Nodes.Gcp.Compute.RegionalManagedProxy', which is the node to+put underneath this one.+-}+renderLbScript :: ApplicationLoadBalancer -> Text+renderLbScript alb =+    Text.unlines $+        [ "set -euo pipefail"+        , "PROJECT=" <> shellQuote alb.albProject.projectId+        , "REGION=" <> shellQuote alb.albRegion.regionName+        , -- A bare predicate: every caller appends its own location flags,+          -- because not every resource named here is regional (an unmanaged+          -- instance group is zonal) and this used to append --region to all+          -- of them.+          "exists() { \"$@\" >/dev/null 2>&1; }"+        ]+            <> healthCheckLines+            <> backendLines+            <> urlMapLines+            <> proxyLines+            <> forwardingRuleLines+  where+    resourceName :: Text -> Text+    resourceName suffix = shellQuote (alb.albName <> suffix)++    ensure :: Text -> Text -> Text+    ensure describeCmd createCmd =+        "exists " <> describeCmd <> " || " <> createCmd++    backendName = resourceName "-backend"++    -- attaching the same backend twice is an error, so look first+    attachUnlessPresent :: Text -> Text -> Text+    attachUnlessPresent groupPathSuffix addCmd =+        "gcloud compute backend-services describe "+            <> backendName+            <> regional+            <> " --format='value(backends[].group)'"+            <> " | tr ';' '\\n' | grep -q -- "+            <> shellQuote (groupPathSuffix <> "$")+            <> " || "+            <> addCmd++    createBackendService :: Text+    createBackendService =+        ensure+            ("gcloud compute backend-services describe " <> backendName <> regional)+            ( "gcloud compute backend-services create " <> backendName+                <> regional+                <> " --protocol=HTTP --load-balancing-scheme=EXTERNAL_MANAGED"+                <> maybe "" (\hc -> " --health-checks=" <> shellQuote hc.healthCheckName <> " --health-checks-region=\"$REGION\"") (instanceGroupHealthCheck)+            )++    instanceGroupHealthCheck =+        if any isInstanceGroup alb.albBackends then alb.albHealthCheck else Nothing++    isInstanceGroup = \case+        InstanceGroupBackend{} -> True+        CloudRunBackend _ -> False++    healthCheckLines = case alb.albHealthCheck of+        Just hc ->+            [ ensure+                ("gcloud compute health-checks describe " <> shellQuote hc.healthCheckName <> regional)+                ( "gcloud compute health-checks create tcp " <> shellQuote hc.healthCheckName+                    <> regional+                    <> " --port="+                    <> Text.pack (show hc.healthCheckPort)+                )+            ]+        Nothing -> []++    backendLines =+        createBackendService : flip concatMap alb.albBackends (\case+            InstanceGroupBackend ig loc ports ->+                namedPortsLine ig loc ports+                    <> [ attachUnlessPresent+                            ("/instanceGroups/" <> ig)+                            ( "gcloud compute backend-services add-backend " <> backendName+                                <> regional+                                <> " --instance-group=" <> shellQuote ig+                                <> groupBackendFlag loc+                            )+                       ]+            CloudRunBackend svc ->+                [ ensure+                    ("gcloud compute network-endpoint-groups describe " <> resourceName "-neg" <> regional)+                    ( "gcloud compute network-endpoint-groups create " <> resourceName "-neg"+                        <> regional+                        <> " --network-endpoint-type=serverless --cloud-run-service=" <> shellQuote svc+                    )+                , attachUnlessPresent+                    ("/networkEndpointGroups/" <> alb.albName <> "-neg")+                    ( "gcloud compute backend-services add-backend " <> backendName+                        <> regional+                        <> " --network-endpoint-group=" <> resourceName "-neg"+                        <> " --network-endpoint-group-region=\"$REGION\""+                    )+                ])++    -- set-named-ports replaces the whole set, so one call carrying every+    -- port (the first one named @http@, the backend service's default+    -- @--port-name@) rather than one call per port, each erasing the last.+    namedPortsLine _ _ [] = []+    namedPortsLine ig loc ports =+        [ "gcloud compute instance-groups set-named-ports " <> shellQuote ig+            <> groupLocation loc+            <> " --named-ports="+            <> Text.intercalate "," (zipWith namedPort [0 :: Int ..] ports)+        ]+    namedPort 0 p = "http:" <> Text.pack (show p)+    namedPort i p = "http-" <> Text.pack (show i) <> ":" <> Text.pack (show p)++    urlMapLines =+        [ ensure+            ("gcloud compute url-maps describe " <> resourceName "-url-map" <> regional)+            ( "gcloud compute url-maps create " <> resourceName "-url-map"+                <> regional+                <> " --default-service=" <> backendName+            )+        ]++    proxyLines =+        [ ensure+            ("gcloud compute target-http-proxies describe " <> resourceName "-proxy" <> regional)+            ( "gcloud compute target-http-proxies create " <> resourceName "-proxy"+                <> regional+                <> " --url-map=" <> resourceName "-url-map"+                <> " --url-map-region=\"$REGION\""+            )+        ]++    forwardingRuleLines =+        [ ensure+            ("gcloud compute forwarding-rules describe " <> resourceName "-fw" <> regional)+            ( "gcloud compute forwarding-rules create " <> resourceName "-fw"+                <> regional+                <> " --load-balancing-scheme=EXTERNAL_MANAGED"+                <> maybe "" ((" --network=" <>) . shellQuote) alb.albNetwork+                <> " --target-http-proxy=" <> resourceName "-proxy"+                <> " --target-http-proxy-region=\"$REGION\""+                <> " --ports=80"+            )+        ]++-- | The @--project@\/@--region@ pair every regional resource in these scripts+-- is addressed by, reading the variables the script sets up front.+regional :: Text+regional = " --project=\"$PROJECT\" --region=\"$REGION\""++-- | How to address the instance group itself.+groupLocation :: InstanceGroupLocation -> Text+groupLocation (InstanceGroupZone z) = " --project=\"$PROJECT\" --zone=" <> shellQuote z+groupLocation (InstanceGroupRegion rg) = " --project=\"$PROJECT\" --region=" <> shellQuote rg++-- | How @backend-services add-backend@ names the group's location.+groupBackendFlag :: InstanceGroupLocation -> Text+groupBackendFlag (InstanceGroupZone z) = " --instance-group-zone=" <> shellQuote z+groupBackendFlag (InstanceGroupRegion rg) = " --instance-group-region=" <> shellQuote rg++{- | Renders a bash script that deletes the LB components, dependants first.+A component that is already gone is skipped; one that exists and fails to+delete fails the script.+-}+renderLbDeleteScript :: ApplicationLoadBalancer -> Text+renderLbDeleteScript alb =+    Text.unlines $+        [ "set -euo pipefail"+        , "PROJECT=" <> shellQuote alb.albProject.projectId+        , "REGION=" <> shellQuote alb.albRegion.regionName+        , "exists() { \"$@\" >/dev/null 2>&1; }"+        , deleteIfPresent "forwarding-rules" (resourceName "-fw")+        , deleteIfPresent "target-http-proxies" (resourceName "-proxy")+        , deleteIfPresent "url-maps" (resourceName "-url-map")+        , deleteIfPresent "backend-services" (resourceName "-backend")+        ]+            <> deleteBackendSpecificLines+            <> maybe [] (\hc -> [deleteIfPresent "health-checks" (shellQuote hc.healthCheckName)]) alb.albHealthCheck+  where+    resourceName :: Text -> Text+    resourceName suffix = shellQuote (alb.albName <> suffix)++    deleteIfPresent :: Text -> Text -> Text+    deleteIfPresent collection name =+        "if exists gcloud compute " <> collection <> " describe " <> name <> regional+            <> "; then gcloud compute " <> collection <> " delete " <> name+            <> regional <> " --quiet; fi"++    -- The instance group is not deleted here: this recipe did not create it+    -- (it is the caller's, and may well outlive the balancer). Detaching is+    -- implicit in deleting the backend service.+    deleteBackendSpecificLines = flip concatMap alb.albBackends $ \case+        InstanceGroupBackend{} -> []+        CloudRunBackend _svc -> [deleteIfPresent "network-endpoint-groups" (resourceName "-neg")]
+ src/Salmon/Builtin/Nodes/Gcp/Monitoring.hs view
@@ -0,0 +1,579 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Google Cloud Monitoring: notification channels and alerting policies,+here for Cloud Run services.++Both resources get __server-assigned ids__ (@projects\/P\/notificationChannels\/123@,+@projects\/P\/alertPolicies\/456@), so unlike a bucket or a service account+a declaration cannot address its resource by a name it chose. The identity+used here is the __display name__: @check@ is a filtered @list@, @up@+creates when nothing answers to that name and updates when something does,+and @down@ deletes whatever the lookup finds. Two declarations with one+display name in one project are therefore one resource, which is what the+'Salmon.Op.Ref' keyed on @(project, display name)@ says too.++An alert policy is compared by a __fingerprint__: the rendered policy — the+conditions, the combiner, the documentation and the channel ids it names —+hashed into a @salmon-fingerprint@ user label. A policy whose label matches+what the declaration renders to is skipped; anything else (absent, edited in+the console, a channel recreated under a new id) is created or updated. That+is the same "compare the bytes I would write" shape as+"Salmon.Builtin.Nodes.Filesystem".@checkFileContents@, with the label+standing in for the file since the API's own representation of a policy+carries fields (creation records, mutation records, condition names) that a+declaration never wrote.++Policies are passed to @gcloud@ inline (@--policy JSON@) rather than through+a file: nothing in one is secret, and it keeps the node free of temporary+files. Channel kinds are a sum with one constructor today ('Email'), so that+adding webhooks and provider-specific ones is additive.++Everything here goes through @gcloud beta monitoring channels@ and+@gcloud alpha monitoring policies@ (the release tracks those command groups+live on), and needs @monitoring.googleapis.com@ enabled on the project —+declare that with "Salmon.Builtin.Nodes.Gcp.ServiceUsage".@enableService@+as a dependency, the way @run.googleapis.com@ is for a service.+-}+module Salmon.Builtin.Nodes.Gcp.Monitoring (+    -- * Notification channels+    ChannelKind (..),+    NotificationChannel (..),+    notificationChannel,+    channelLabels,+    Lookup (..),+    sequenceLookups,+    FoundChannel (..),+    lookupChannel,+    interpretChannelList,++    -- * Alert policies+    CloudRunTarget (..),+    CloudRunCondition (..),+    AlertPolicy (..),+    alertPolicy,+    renderCondition,+    renderPolicy,+    policyFingerprint,+    fingerprintLabel,+    FoundPolicy (..),+    lookupPolicy,+    interpretPolicyList,++    -- * Plumbing+    monitoringApi,+    Report (..),+    MonitoringCommand (..),+    monitoringCommand,+) where++import Control.Exception (throwIO)+import qualified Crypto.Hash.SHA256 as SHA256+import Data.Aeson (Value (..), object, (.=))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LByteString+import Data.Foldable (toList)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import GHC.IO.Exception (ExitCode (..))+import System.IO.Error (userError)+import System.Process.ByteString (readCreateProcessWithExitCode)+import Text.Printf (printf)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), untrackedExec, withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Gcp.Core (Project (..), Region (..), gcloudProc, withProject)+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++data Report+    = RunMonitoringCommand !MonitoringCommand !Binary.Report+    deriving (Show)++-- | The API these nodes need enabled: what to hand @ServiceUsage.enableService@.+monitoringApi :: Text+monitoringApi = "monitoring.googleapis.com"++-------------------------------------------------------------------------------+-- Notification channels++{- | Where a policy's notifications go. One constructor for now; the order+of arrival is email, then webhooks, then provider-specific kinds.+-}+newtype ChannelKind+    = -- | an email address+      Email Text+    deriving (Eq, Show)++channelType :: ChannelKind -> Text+channelType (Email _) = "email"++-- | The @--channel-labels@ a kind needs, as @key=value@ pairs.+channelLabels :: ChannelKind -> [(Text, Text)]+channelLabels (Email address) = [("email_address", address)]++data NotificationChannel = NotificationChannel+    { ncProject :: Project+    , ncDisplayName :: Text+    -- ^ the identity, see the module header; must not contain a double quote+    , ncKind :: ChannelKind+    }+    deriving (Eq, Show)++-- | A notification channel found by display name, and whether it already+-- carries the declared kind and labels.+data FoundChannel = FoundChannel+    { fcName :: Text+    -- ^ @projects\/P\/notificationChannels\/ID@+    , fcMatches :: Bool+    }+    deriving (Eq, Show)++-- | What a filtered @list@ said.+data Lookup a+    = -- | the command failed (exit code, first line of stderr)+      LookupFailed Text+    | -- | nothing answers to the display name+      Absent+    | -- | one does (several: the first, since the name is the identity)+      Present a+    deriving (Eq, Show, Functor)++-- | Every lookup present, or the first that was not.+sequenceLookups :: [Lookup a] -> Lookup [a]+sequenceLookups = foldr step (Present [])+  where+    step (Present x) (Present xs) = Present (x : xs)+    step (Present _) other = other+    step (LookupFailed why) _ = LookupFailed why+    step Absent (LookupFailed why) = LookupFailed why+    step Absent _ = Absent++{- | A notification channel of the declared kind, found by display name.+@up@ creates it, or updates the labels of one that exists with a different+address; @down@ deletes what the lookup finds.+-}+notificationChannel :: Reporter Report -> Track' (Binary "gcloud") -> NotificationChannel -> Op+notificationChannel r gcloudTrack ch =+    withBinary gcloudTrack monitoringCommand (ChannelsCreate ch) $ \_create ->+        op "gcp-monitoring-channel" nodeps $ \actions ->+            actions+                { help = Text.unwords ["notification channel", ch.ncDisplayName, "(" <> channelType ch.ncKind <> ")"]+                , ref = mkRef "gcp-monitoring-channel" (ch.ncProject.projectId, ch.ncDisplayName)+                , up = upChannel+                , down = downChannel+                , check = interpretChannelList ch <$> listChannel+                }+  where+    run :: MonitoringCommand -> IO ()+    run cmd = untrackedExec monitoringCommand cmd "" (contramap (RunMonitoringCommand cmd) r)++    listChannel :: IO (ExitCode, ByteString, ByteString)+    listChannel = readCreateProcessWithExitCode (prepare monitoringCommand (ChannelsList ch)) ""++    upChannel = do+        (code, out, err) <- listChannel+        case lookupChannel ch code out err of+            LookupFailed why -> throwIO (userError ("listing notification channels failed: " <> Text.unpack why))+            Absent -> run (ChannelsCreate ch)+            Present found+                | found.fcMatches -> pure ()+                | otherwise -> run (ChannelsUpdate found.fcName ch)++    downChannel = do+        (code, out, err) <- listChannel+        case lookupChannel ch code out err of+            Present found -> run (ChannelsDelete ch.ncProject found.fcName)+            -- absent, or unreachable: nothing to delete, and erring toward+            -- not-running is the safe direction (see 'Core.downIfPresent')+            _ -> pure ()++-- | Pure: what @gcloud beta monitoring channels list --format json@ said+-- about the declared channel.+lookupChannel :: NotificationChannel -> ExitCode -> ByteString -> ByteString -> Lookup FoundChannel+lookupChannel ch code out err =+    case code of+        ExitFailure n -> LookupFailed (Text.pack ("exit " <> show n) <> firstLine err)+        ExitSuccess -> case Aeson.decodeStrict' out of+            Just (Array items) | (item : _) <- filter (named ch.ncDisplayName) (toList items) ->+                Present+                    FoundChannel+                        { fcName = maybe "" id (textField "name" item)+                        , fcMatches =+                            textField "type" item == Just (channelType ch.ncKind)+                                && all (\(k, v) -> nestedTextField "labels" k item == Just v) (channelLabels ch.ncKind)+                        }+            Just (Array _) -> Absent+            _ -> LookupFailed "unparseable list output"+  where+    named name item = textField "displayName" item == Just name++-- | The 'CheckResult' for a channel: there, with the declared kind and address.+interpretChannelList :: NotificationChannel -> (ExitCode, ByteString, ByteString) -> CheckResult+interpretChannelList ch (code, out, err) =+    case lookupChannel ch code out err of+        LookupFailed why -> Failure ("cannot list notification channels: " <> why)+        Absent -> Failure ("no notification channel named " <> ch.ncDisplayName)+        Present found+            | found.fcMatches -> Success+            | otherwise -> Failure ("notification channel " <> ch.ncDisplayName <> " exists with a different kind or address")++-------------------------------------------------------------------------------+-- Alert policies++-- | The Cloud Run service a condition is about.+data CloudRunTarget = CloudRunTarget+    { crtProject :: Project+    , crtRegion :: Region+    , crtService :: Text+    }+    deriving (Eq, Show)++{- | A condition on one Cloud Run service, each a @conditionThreshold@ on+one of the @run.googleapis.com@ metrics. Durations are seconds the+condition must hold before the policy fires; thresholds are in the metric's+own unit.+-}+data CloudRunCondition+    = -- | the share of requests answered 5xx, over all requests: a ratio in+      -- @[0,1]@ (a @denominatorFilter@ condition on @request_count@)+      ServerErrorRatio {ratio :: Double, seconds :: Int}+    | -- | the 99th percentile of @request_latencies@, in milliseconds+      RequestLatencyP99 {milliseconds :: Double, seconds :: Int}+    | -- | active @container\/instance_count@, summed over the service's+      -- revisions — set it to the service's @--max-instances@ to hear about+      -- a service that is at its ceiling+      InstanceCount {instances :: Int, seconds :: Int}+    | -- | the 99th percentile of @container\/memory\/utilizations@, a+      -- fraction of the limit in @[0,1]@+      MemoryUtilization {fraction :: Double, seconds :: Int}+    deriving (Eq, Show)++data AlertPolicy = AlertPolicy+    { apProject :: Project+    , apDisplayName :: Text+    -- ^ the identity, see the module header; must not contain a double quote+    , apTarget :: CloudRunTarget+    , apConditions :: [CloudRunCondition]+    -- ^ combined with OR: any one firing fires the policy+    , apChannels :: [NotificationChannel]+    -- ^ resolved to their ids when the policy is checked or applied; each is+    -- also a dependency of the policy node+    , apDocumentation :: Text+    -- ^ markdown shown with the notification+    }+    deriving (Eq, Show)++{- | An alert policy on a Cloud Run service. Its channels are dependencies.+@up@ creates or updates so the policy carries the rendered conditions and+the fingerprint label; @down@ deletes what the lookup finds.+-}+alertPolicy :: Reporter Report -> Track' (Binary "gcloud") -> AlertPolicy -> Op+alertPolicy r gcloudTrack policy =+    withBinary gcloudTrack monitoringCommand (PoliciesList policy) $ \_list ->+        op "gcp-monitoring-policy" (deps channelNodes) $ \actions ->+            actions+                { help = Text.unwords ["alert policy", policy.apDisplayName, "on Cloud Run service", policy.apTarget.crtService]+                , notes =+                    [ "conditions: " <> Text.intercalate ", " (map conditionName policy.apConditions)+                    , "channels: " <> Text.intercalate ", " (map (.ncDisplayName) policy.apChannels)+                    ]+                , ref = mkRef "gcp-monitoring-policy" (policy.apProject.projectId, policy.apDisplayName)+                , up = upPolicy+                , down = downPolicy+                , check = checkPolicy+                }+  where+    channelNodes = map (notificationChannel r gcloudTrack) policy.apChannels++    run :: MonitoringCommand -> IO ()+    run cmd = untrackedExec monitoringCommand cmd "" (contramap (RunMonitoringCommand cmd) r)++    listPolicy :: IO (ExitCode, ByteString, ByteString)+    listPolicy = readCreateProcessWithExitCode (prepare monitoringCommand (PoliciesList policy)) ""++    -- the channels' resource names, in declaration order; a channel that+    -- cannot be found is an error here, since it is a dependency that+    -- should have been brought up first+    resolveChannels :: IO [Text]+    resolveChannels = mapM resolve policy.apChannels+      where+        resolve ch = do+            (code, out, err) <- readCreateProcessWithExitCode (prepare monitoringCommand (ChannelsList ch)) ""+            case lookupChannel ch code out err of+                Present found -> pure found.fcName+                Absent -> throwIO (userError ("notification channel not found: " <> Text.unpack ch.ncDisplayName))+                LookupFailed why -> throwIO (userError ("listing notification channels failed: " <> Text.unpack why))++    -- a check that cannot resolve a channel says so rather than comparing+    -- against a policy that could not be rendered+    checkPolicy :: IO CheckResult+    checkPolicy = do+        lookups <- mapM lookupOne policy.apChannels+        case sequenceLookups lookups of+            LookupFailed why -> pure (Failure ("cannot list notification channels: " <> why))+            Absent -> pure (Failure "a notification channel of the policy is missing")+            Present names -> interpretPolicyList policy names <$> listPolicy+      where+        lookupOne ch = do+            (code, out, err) <- readCreateProcessWithExitCode (prepare monitoringCommand (ChannelsList ch)) ""+            pure (fmap (.fcName) (lookupChannel ch code out err))++    upPolicy = do+        names <- resolveChannels+        (code, out, err) <- listPolicy+        case lookupPolicy policy code out err of+            LookupFailed why -> throwIO (userError ("listing alert policies failed: " <> Text.unpack why))+            Absent -> run (PoliciesCreate policy names)+            Present found+                | found.fpFingerprint == Just (policyFingerprint policy names) -> pure ()+                | otherwise -> run (PoliciesUpdate found.fpName policy names)++    downPolicy = do+        (code, out, err) <- listPolicy+        case lookupPolicy policy code out err of+            Present found -> run (PoliciesDelete policy.apProject found.fpName)+            _ -> pure ()++-- | An alert policy found by display name, and the fingerprint label it carries.+data FoundPolicy = FoundPolicy+    { fpName :: Text+    -- ^ @projects\/P\/alertPolicies\/ID@+    , fpFingerprint :: Maybe Text+    }+    deriving (Eq, Show)++-- | Pure: what @gcloud alpha monitoring policies list --format json@ said+-- about the declared policy.+lookupPolicy :: AlertPolicy -> ExitCode -> ByteString -> ByteString -> Lookup FoundPolicy+lookupPolicy policy code out err =+    case code of+        ExitFailure n -> LookupFailed (Text.pack ("exit " <> show n) <> firstLine err)+        ExitSuccess -> case Aeson.decodeStrict' out of+            Just (Array items) | (item : _) <- filter (named policy.apDisplayName) (toList items) ->+                Present+                    FoundPolicy+                        { fpName = maybe "" id (textField "name" item)+                        , fpFingerprint = nestedTextField "userLabels" fingerprintLabel item+                        }+            Just (Array _) -> Absent+            _ -> LookupFailed "unparseable list output"+  where+    named name item = textField "displayName" item == Just name++-- | The 'CheckResult' for a policy, given its channels' resolved names:+-- there, and carrying the fingerprint of what the declaration renders to.+interpretPolicyList :: AlertPolicy -> [Text] -> (ExitCode, ByteString, ByteString) -> CheckResult+interpretPolicyList policy channelNames (code, out, err) =+    case lookupPolicy policy code out err of+        LookupFailed why -> Failure ("cannot list alert policies: " <> why)+        Absent -> Failure ("no alert policy named " <> policy.apDisplayName)+        Present found+            | found.fpFingerprint == Just (policyFingerprint policy channelNames) -> Success+            | otherwise -> Failure ("alert policy " <> policy.apDisplayName <> " differs from its declaration")++-- | The user label the fingerprint rides on.+fingerprintLabel :: Text+fingerprintLabel = "salmon-fingerprint"++{- | A stable hash of everything the declaration renders into the policy,+channel ids included, in the alphabet a user label value allows+(lowercase hex, 16 characters).+-}+policyFingerprint :: AlertPolicy -> [Text] -> Text+policyFingerprint policy channelNames =+    Text.pack (take 16 (concatMap (printf "%02x") (ByteString.unpack digest)))+  where+    digest = SHA256.hash (LByteString.toStrict (Aeson.encode (renderPolicy' policy channelNames)))++-- | The policy JSON @gcloud alpha monitoring policies create --policy@+-- takes, fingerprint label included.+renderPolicy :: AlertPolicy -> [Text] -> Value+renderPolicy policy channelNames =+    withLabel (renderPolicy' policy channelNames)+  where+    withLabel (Object o) = Object (KeyMap.insert "userLabels" (object [Key.fromText fingerprintLabel .= policyFingerprint policy channelNames]) o)+    withLabel v = v++-- | The policy without its fingerprint: what the fingerprint is of.+renderPolicy' :: AlertPolicy -> [Text] -> Value+renderPolicy' policy channelNames =+    object+        [ "displayName" .= policy.apDisplayName+        , "combiner" .= ("OR" :: Text)+        , "enabled" .= True+        , "notificationChannels" .= channelNames+        , "conditions" .= map (renderCondition policy.apTarget) policy.apConditions+        , "documentation" .= object ["content" .= policy.apDocumentation, "mimeType" .= ("text/markdown" :: Text)]+        ]++conditionName :: CloudRunCondition -> Text+conditionName c = case c of+    ServerErrorRatio{} -> "5xx ratio"+    RequestLatencyP99{} -> "p99 latency"+    InstanceCount{} -> "instance count"+    MemoryUtilization{} -> "memory utilization"++-- | One condition as the API's @conditionThreshold@ object.+renderCondition :: CloudRunTarget -> CloudRunCondition -> Value+renderCondition target c =+    object+        [ "displayName" .= (target.crtService <> ": " <> conditionName c)+        , "conditionThreshold" .= object (common <> specific)+        ]+  where+    duration = Text.pack (show (seconds c)) <> "s"+    common =+        [ "comparison" .= ("COMPARISON_GT" :: Text)+        , "duration" .= duration+        , "trigger" .= object ["count" .= (1 :: Int)]+        ]+    specific = case c of+        ServerErrorRatio r _ ->+            [ "filter" .= metricFilter target "run.googleapis.com/request_count" [("metric.labels.response_code_class", "5xx")]+            , "denominatorFilter" .= metricFilter target "run.googleapis.com/request_count" []+            , "aggregations" .= [aggregation "ALIGN_RATE" "REDUCE_SUM"]+            , "denominatorAggregations" .= [aggregation "ALIGN_RATE" "REDUCE_SUM"]+            , "thresholdValue" .= r+            ]+        RequestLatencyP99 ms _ ->+            [ "filter" .= metricFilter target "run.googleapis.com/request_latencies" []+            , "aggregations" .= [aggregation "ALIGN_PERCENTILE_99" "REDUCE_MAX"]+            , "thresholdValue" .= ms+            ]+        InstanceCount n _ ->+            [ "filter" .= metricFilter target "run.googleapis.com/container/instance_count" [("metric.labels.state", "active")]+            , "aggregations" .= [aggregation "ALIGN_MAX" "REDUCE_SUM"]+            , "thresholdValue" .= (fromIntegral n - 0.5 :: Double)+            ]+        MemoryUtilization f _ ->+            [ "filter" .= metricFilter target "run.googleapis.com/container/memory/utilizations" []+            , "aggregations" .= [aggregation "ALIGN_PERCENTILE_99" "REDUCE_MAX"]+            , "thresholdValue" .= f+            ]++    aggregation :: Text -> Text -> Value+    aggregation aligner reducer =+        object+            [ "alignmentPeriod" .= ("60s" :: Text)+            , "perSeriesAligner" .= aligner+            , "crossSeriesReducer" .= reducer+            , "groupByFields" .= (["resource.label.service_name"] :: [Text])+            ]++-- | The monitoring filter selecting one Cloud Run service's series of a metric.+metricFilter :: CloudRunTarget -> Text -> [(Text, Text)] -> Text+metricFilter target metric extra =+    Text.intercalate+        " AND "+        ( [ "metric.type=\"" <> metric <> "\""+          , "resource.type=\"cloud_run_revision\""+          , "resource.labels.service_name=\"" <> target.crtService <> "\""+          , "resource.labels.location=\"" <> target.crtRegion.regionName <> "\""+          ]+            <> [k <> "=\"" <> v <> "\"" | (k, v) <- extra]+        )++-------------------------------------------------------------------------------+-- JSON helpers over gcloud's list output++textField :: Text -> Value -> Maybe Text+textField k (Object o) = case KeyMap.lookup (Key.fromText k) o of+    Just (String t) -> Just t+    _ -> Nothing+textField _ _ = Nothing++nestedTextField :: Text -> Text -> Value -> Maybe Text+nestedTextField outer k (Object o) = KeyMap.lookup (Key.fromText outer) o >>= textField k+nestedTextField _ _ _ = Nothing++firstLine :: ByteString -> Text+firstLine err = case Text.lines (Text.decodeUtf8 err) of+    (l : _) -> ": " <> l+    [] -> ""++-------------------------------------------------------------------------------++data MonitoringCommand+    = ChannelsList NotificationChannel+    | ChannelsCreate NotificationChannel+    | -- | update the labels of the channel with this resource name+      ChannelsUpdate Text NotificationChannel+    | ChannelsDelete Project Text+    | PoliciesList AlertPolicy+    | -- | create with these resolved channel names+      PoliciesCreate AlertPolicy [Text]+    | -- | update the policy with this resource name+      PoliciesUpdate Text AlertPolicy [Text]+    | PoliciesDelete Project Text+    deriving (Show)++-- | gcloud's resource filter selecting one display name.+displayNameFilter :: Text -> String+displayNameFilter name = "display_name=\"" <> Text.unpack (Text.filter (/= '"') name) <> "\""++renderLabels :: [(Text, Text)] -> String+renderLabels kvs = Text.unpack (Text.intercalate "," [k <> "=" <> v | (k, v) <- kvs])++policyJson :: AlertPolicy -> [Text] -> String+policyJson policy names = Text.unpack (Text.decodeUtf8 (LByteString.toStrict (Aeson.encode (renderPolicy policy names))))++monitoringCommand :: Command "gcloud" MonitoringCommand+monitoringCommand = Command $ \cmd -> case cmd of+    ChannelsList ch ->+        gcloudProc $+            withProject ch.ncProject+                ["beta", "monitoring", "channels", "list", "--filter", displayNameFilter ch.ncDisplayName, "--format", "json"]+    ChannelsCreate ch ->+        gcloudProc $+            withProject ch.ncProject+                [ "beta"+                , "monitoring"+                , "channels"+                , "create"+                , "--display-name"+                , Text.unpack ch.ncDisplayName+                , "--type"+                , Text.unpack (channelType ch.ncKind)+                , "--channel-labels"+                , renderLabels (channelLabels ch.ncKind)+                ]+    ChannelsUpdate name ch ->+        gcloudProc $+            withProject ch.ncProject+                [ "beta"+                , "monitoring"+                , "channels"+                , "update"+                , Text.unpack name+                , "--update-channel-labels"+                , renderLabels (channelLabels ch.ncKind)+                ]+    ChannelsDelete project name ->+        gcloudProc $+            withProject project ["beta", "monitoring", "channels", "delete", Text.unpack name, "--quiet"]+    PoliciesList policy ->+        gcloudProc $+            withProject policy.apProject+                ["alpha", "monitoring", "policies", "list", "--filter", displayNameFilter policy.apDisplayName, "--format", "json"]+    PoliciesCreate policy names ->+        gcloudProc $+            withProject policy.apProject+                ["alpha", "monitoring", "policies", "create", "--policy", policyJson policy names]+    PoliciesUpdate name policy names ->+        gcloudProc $+            withProject policy.apProject+                ["alpha", "monitoring", "policies", "update", Text.unpack name, "--policy", policyJson policy names]+    PoliciesDelete project name ->+        gcloudProc $+            withProject project ["alpha", "monitoring", "policies", "delete", Text.unpack name, "--quiet"]
+ src/Salmon/Builtin/Nodes/Gcp/ResourceManager.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Creating (and deleting) a GCP project itself -- the node every other+"Salmon.Builtin.Nodes.Gcp" node sits on top of once a recipe owns the+project rather than being handed one.++Two properties of projects shape this module and are worth knowing before+using it as a sandbox:++* A deleted project is not gone: it sits in @DELETE_REQUESTED@ for ~30 days+  (restorable with @gcloud projects undelete@) and its id cannot be reused by+  anybody in that window. 'interpretProjectState' therefore reports that+  state with its own message rather than as a plain "not found", because the+  @up@ that follows is going to fail and the operator needs to know it is the+  id, not the credentials.+* Deleting a project deletes everything in it. That is exactly what makes it+  a good blast-radius bound for a throwaway validation (see+  @salmon-apps@'s @GcpToy@), and exactly why a recipe that did not create the+  project should not use this node.+-}+module Salmon.Builtin.Nodes.Gcp.ResourceManager (+    Parent (..),+    ProjectSpec (..),+    project,+    interpretProjectState,+    Report (..),+    ResourceManagerCommand (..),+    resourceManagerCommand,+) where++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import GHC.IO.Exception (ExitCode (..))+import System.Process.ByteString (readCreateProcessWithExitCode)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Gcp.Core (Project (..), gcloudProc)+import qualified Salmon.Builtin.Nodes.Gcp.Core as Core+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++data Report+    = RunResourceManagerCommand !ResourceManagerCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++-- | Where a project is created in the resource hierarchy.+data Parent+    = -- | bare numeric organization id+      Organization Text+    | -- | bare numeric folder id+      Folder Text+    | -- | no parent: only possible for accounts outside any organization+      NoParent+    deriving (Eq, Show)++data ProjectSpec = ProjectSpec+    { projectSpecProject :: Project+    , projectSpecParent :: Parent+    , projectSpecLabels :: Map Text Text+    -- ^ labels are the cheap way to find leaked throwaway projects later+    -- (@gcloud projects list --filter=labels.KEY=VALUE@).+    }+    deriving (Eq, Show)++-- | Creates a project if it does not exist; deletes it on 'down'.+project :: Reporter Report -> Track' (Binary "gcloud") -> ProjectSpec -> Op+project r gcloudTrack spec =+    withBinary gcloudTrack resourceManagerCommand (ProjectsCreate spec) $ \create ->+        withBinary gcloudTrack resourceManagerCommand (ProjectsDelete spec.projectSpecProject) $ \delete ->+            op "gcp-project" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["creates GCP project", pid]+                    , notes = ["down deletes the project and everything still in it"]+                    , ref = mkRef "gcp-project" pid+                    , up = create r'+                    , down = Core.downIfPresent checkProject (delete r')+                    , check = checkProject+                    }+  where+    pid = spec.projectSpecProject.projectId+    r' = contramap (RunResourceManagerCommand (ProjectsCreate spec)) r++    checkProject :: IO CheckResult+    checkProject = do+        (code, out, _err) <-+            readCreateProcessWithExitCode+                (prepare resourceManagerCommand (ProjectsDescribeState spec.projectSpecProject))+                ""+        pure $ interpretProjectState pid code (Text.strip (Text.decodeUtf8 out))++{- | The verdict drawn from @gcloud projects describe+--format=value(lifecycleState)@, split out for testability.+-}+interpretProjectState :: Text -> ExitCode -> Text -> CheckResult+interpretProjectState pid (ExitFailure n) _ =+    Failure ("project not found or not visible: " <> pid <> " (exit " <> Text.pack (show n) <> ")")+interpretProjectState pid ExitSuccess state =+    case state of+        "ACTIVE" -> Success+        "DELETE_REQUESTED" ->+            Failure ("project " <> pid <> " is pending deletion: its id cannot be reused for ~30 days (undelete it, or pick another id)")+        _ -> Failure ("unexpected project lifecycle state for " <> pid <> ": " <> state)++-------------------------------------------------------------------------------++data ResourceManagerCommand+    = ProjectsCreate ProjectSpec+    | ProjectsDescribeState Project+    | ProjectsDelete Project+    deriving (Show)++resourceManagerCommand :: Command "gcloud" ResourceManagerCommand+resourceManagerCommand = Command $ \cmd -> case cmd of+    ProjectsCreate spec ->+        gcloudProc $+            [ "projects"+            , "create"+            , Text.unpack spec.projectSpecProject.projectId+            ]+                <> parentArgs spec.projectSpecParent+                <> labelArgs spec.projectSpecLabels+    ProjectsDescribeState p ->+        gcloudProc+            [ "projects"+            , "describe"+            , Text.unpack p.projectId+            , "--format=value(lifecycleState)"+            ]+    ProjectsDelete p ->+        gcloudProc+            [ "projects"+            , "delete"+            , Text.unpack p.projectId+            , "--quiet"+            ]+  where+    parentArgs (Organization org) = ["--organization", Text.unpack org]+    parentArgs (Folder folder) = ["--folder", Text.unpack folder]+    parentArgs NoParent = []++    labelArgs labels+        | Map.null labels = []+        | otherwise =+            [ "--labels"+            , Text.unpack (Text.intercalate "," [k <> "=" <> v | (k, v) <- Map.toList labels])+            ]
+ src/Salmon/Builtin/Nodes/Gcp/SecretManager.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Google Secret Manager: a named secret, and the versions holding its+bytes.++Two nodes rather than one, because they are two effects with different+lifetimes. A secret is a long-lived container with an IAM policy on it (see+"Salmon.Builtin.Nodes.Gcp.Iam", whose @iamResourceArgs@ already understands+@projects\/P\/secrets\/S@); a version is immutable content, and adding one+never replaces what is there.++That second property is the whole design problem here. @gcloud secrets+versions add@ is not idempotent in any useful sense -- it always creates a+new version -- so a node that simply ran it on every @up@ would leave a+project accumulating a version per pass, each one billed, with the older+ones still readable. 'secretVersion' therefore has a real @check@: it reads+the current @latest@ back and compares it with the bytes it would upload. No+change, no version.+-}+module Salmon.Builtin.Nodes.Gcp.SecretManager (+    Secret (..),+    secret,+    interpretSecretDescribe,+    SecretVersion (..),+    secretVersion,+    interpretSecretContents,+    Report (..),+    SecretManagerCommand (..),+    secretManagerCommand,+) where++import qualified Data.ByteString as ByteString+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.IO.Exception (ExitCode (..))+import System.Directory (doesFileExist)+import System.Process.ByteString (readCreateProcessWithExitCode)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Gcp.Core (Project (..), gcloudProc, withProject)+import qualified Salmon.Builtin.Nodes.Gcp.Core as Core+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++data Report+    = RunSecretManagerCommand !SecretManagerCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++-- | A secret: a name, an IAM policy, and a stack of versions.+data Secret = Secret+    { secretName :: Text+    , secretProject :: Project+    , secretReplication :: Text+    -- ^ @automatic@, or @user-managed@ with locations set out of band.+    }+    deriving (Eq, Show)++-- | Idempotently creates a secret. Deleting one destroys every version in it.+secret :: Reporter Report -> Track' (Binary "gcloud") -> Secret -> Op+secret r gcloudTrack sec =+    withBinary gcloudTrack secretManagerCommand (SecretsCreate sec) $ \create ->+        withBinary gcloudTrack secretManagerCommand (SecretsDelete sec) $ \delete ->+            op "gcp-secret" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["creates secret", sec.secretName]+                    , notes = ["down destroys every version of the secret"]+                    , ref = mkRef "gcp-secret" (sec.secretProject.projectId, sec.secretName)+                    , up = Core.retryingIO Core.afterEnableRetries Core.afterEnableDelay (create (rFor (SecretsCreate sec)))+                    , down = Core.downIfPresent checkSecret (delete (rFor (SecretsDelete sec)))+                    , check = checkSecret+                    }+  where+    rFor cmd = contramap (RunSecretManagerCommand cmd) r++    checkSecret :: IO CheckResult+    checkSecret = do+        (code, _out, _err) <-+            readCreateProcessWithExitCode (prepare secretManagerCommand (SecretsDescribe sec)) ""+        pure $ interpretSecretDescribe sec.secretName code++-- | The verdict drawn from @gcloud secrets describe@.+interpretSecretDescribe :: Text -> ExitCode -> CheckResult+interpretSecretDescribe _name ExitSuccess = Success+interpretSecretDescribe name (ExitFailure _) = Failure ("secret not found: " <> name)++-------------------------------------------------------------------------------++{- | The contents of a secret's latest version, taken from a local file.++The file is read at @up@ time rather than being baked into the graph, so a+certificate re-issued by an earlier node in the same pass is the one that+gets uploaded.+-}+data SecretVersion = SecretVersion+    { versionSecret :: Secret+    , versionSourceFile :: FilePath+    }+    deriving (Eq, Show)++{- | Ensures the secret's latest version holds this file's bytes.++The @check@ reads the secret back and compares, which is what keeps a+re-converged graph from stacking up a new version per pass. Two consequences+worth knowing:++* the comparison happens __in this process__ and the value is never+  reported, logged or passed to a shell. It is still a read of the secret,+  so whoever runs salmon needs @secretmanager.versions.access@ and will+  appear in the audit log doing so on every pass.+* a secret whose latest version was @disabled@ or @destroyed@ reads as a+  failure, and this node then adds a fresh version -- which is the right+  answer, but it does mean disabling a version does not hold if salmon+  converges afterwards.++There is no @down@: versions are immutable, and destroying them is what+deleting the enclosing 'secret' does.+-}+secretVersion :: Reporter Report -> Track' (Binary "gcloud") -> SecretVersion -> Op+secretVersion r gcloudTrack version =+    withBinary gcloudTrack secretManagerCommand (VersionsAdd version) $ \add ->+        op "gcp-secret-version" (deps [secret r gcloudTrack version.versionSecret]) $ \actions ->+            actions+                { help = Text.unwords ["uploads", Text.pack version.versionSourceFile, "to secret", sec.secretName]+                , notes = ["adds a version only when the contents differ from the latest one"]+                , ref = mkRef "gcp-secret-version" (sec.secretProject.projectId, sec.secretName, version.versionSourceFile)+                , up = add (contramap (RunSecretManagerCommand (VersionsAdd version)) r)+                , check = checkContents+                }+  where+    sec = version.versionSecret++    checkContents :: IO CheckResult+    checkContents = do+        present <- doesFileExist version.versionSourceFile+        if not present+            then pure (Failure ("nothing to upload: " <> Text.pack version.versionSourceFile))+            else do+                wanted <- ByteString.readFile version.versionSourceFile+                (code, out, _err) <-+                    readCreateProcessWithExitCode (prepare secretManagerCommand (VersionsAccessLatest sec)) ""+                pure $ interpretSecretContents sec.secretName wanted code out++{- | Whether the bytes read back are the bytes we would upload.++Compared exactly, with no trimming: a secret is whatever bytes were put in+it, and a PEM file's trailing newline is part of the file. Trimming here+would make a node that had just uploaded its own file report a difference+forever after.+-}+interpretSecretContents :: Text -> ByteString.ByteString -> ExitCode -> ByteString.ByteString -> CheckResult+interpretSecretContents name _wanted (ExitFailure _) _ =+    Failure ("no readable version of secret: " <> name)+interpretSecretContents name wanted ExitSuccess got+    | wanted == got = Success+    | otherwise = Failure ("secret " <> name <> " holds different contents")++-------------------------------------------------------------------------------++data SecretManagerCommand+    = SecretsCreate Secret+    | SecretsDescribe Secret+    | SecretsDelete Secret+    | VersionsAdd SecretVersion+    | VersionsAccessLatest Secret+    deriving (Show)++secretManagerCommand :: Command "gcloud" SecretManagerCommand+secretManagerCommand = Command $ \cmd -> case cmd of+    SecretsCreate sec ->+        gcloudProc $+            withProject sec.secretProject+                [ "secrets"+                , "create"+                , Text.unpack sec.secretName+                , "--replication-policy"+                , Text.unpack sec.secretReplication+                ]+    SecretsDescribe sec ->+        gcloudProc $+            withProject sec.secretProject ["secrets", "describe", Text.unpack sec.secretName]+    SecretsDelete sec ->+        gcloudProc $+            withProject sec.secretProject ["secrets", "delete", Text.unpack sec.secretName, "--quiet"]+    VersionsAdd version ->+        gcloudProc $+            withProject version.versionSecret.secretProject+                [ "secrets"+                , "versions"+                , "add"+                , Text.unpack version.versionSecret.secretName+                , -- via a file rather than --data-file=- on stdin: the bytes+                  -- never become an argv entry, and argv is world-readable+                  -- through /proc for as long as the process lives.+                  "--data-file"+                , version.versionSourceFile+                ]+    VersionsAccessLatest sec ->+        gcloudProc $+            withProject sec.secretProject+                [ "secrets"+                , "versions"+                , "access"+                , "latest"+                , "--secret"+                , Text.unpack sec.secretName+                ]
+ src/Salmon/Builtin/Nodes/Gcp/ServiceUsage.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Enabling GCP APIs (@gcloud services enable ...@) -- the prerequisite+almost every other 'Salmon.Builtin.Nodes.Gcp' node silently assumes (Cloud+Run, Artifact Registry, and IAM all 404 a caller who hasn't flipped the+corresponding service on for the project first). Split out on its own+rather than folded into "Salmon.Builtin.Nodes.Gcp.Core" because a project's+set of enabled services is itself just data -- one node per API, so a+recipe depends on exactly the services it needs.+-}+module Salmon.Builtin.Nodes.Gcp.ServiceUsage (+    Api (..),+    enableService,+    interpretServiceList,+    Report (..),+    ServiceUsageCommand (..),+    serviceUsageCommand,+) where++import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import GHC.IO.Exception (ExitCode (..))+import System.Process.ByteString (readCreateProcessWithExitCode)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Gcp.Core (Project (..), gcloudProc, withProject)+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++data Report+    = RunServiceUsageCommand !ServiceUsageCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++-- | A GCP service/API identifier, e.g. @run.googleapis.com@.+newtype Api = Api {apiName :: Text}+    deriving (Eq, Ord, Show)++-- | Idempotently enables an API on a project.+enableService :: Reporter Report -> Track' (Binary "gcloud") -> Project -> Api -> Op+enableService r gcloudTrack project api =+    withBinary gcloudTrack serviceUsageCommand (ServicesEnable project api) $ \up ->+        op "gcp-service-enable" nodeps $ \actions ->+            actions+                { help = Text.unwords ["enables the", api.apiName, "API"]+                , ref = mkRef "gcp-service-enable" (project.projectId, api.apiName)+                , up = up r'+                , check = checkEnabled+                }+  where+    r' = contramap (RunServiceUsageCommand (ServicesEnable project api)) r++    checkEnabled :: IO CheckResult+    checkEnabled = do+        (code, out, _err) <-+            readCreateProcessWithExitCode+                (prepare serviceUsageCommand (ServicesList project api))+                ""+        pure $ interpretServiceList api code (Text.decodeUtf8 out)++{- | The verdict drawn from @gcloud services list --enabled@'s exit code and+output, split out for testability. @--filter@ narrows the listing to the+API in question, so any non-empty output line naming it means it's enabled.+-}+interpretServiceList :: Api -> ExitCode -> Text -> CheckResult+interpretServiceList _api (ExitFailure n) _outText =+    Failure ("could not list enabled services (exit " <> Text.pack (show n) <> ")")+interpretServiceList api ExitSuccess outText =+    if Text.isInfixOf api.apiName outText+        then Success+        else Failure ("service not enabled: " <> api.apiName)++-------------------------------------------------------------------------------++data ServiceUsageCommand+    = ServicesEnable Project Api+    | ServicesList Project Api+    deriving (Show)++serviceUsageCommand :: Command "gcloud" ServiceUsageCommand+serviceUsageCommand = Command $ \cmd -> case cmd of+    ServicesEnable project api ->+        gcloudProc $+            withProject project+                [ "services"+                , "enable"+                , Text.unpack api.apiName+                ]+    ServicesList project api ->+        gcloudProc $+            withProject project+                [ "services"+                , "list"+                , "--enabled"+                , "--filter"+                , "config.name:" <> Text.unpack api.apiName+                ]
+ src/Salmon/Builtin/Nodes/Gcp/SshAccess.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE OverloadedStrings #-}++module Salmon.Builtin.Nodes.Gcp.SshAccess (+    SshEndpoint (..),+    ProbePolicy (..),+    defaultProbePolicy,+    sshAvailable,+    sshAvailableWithin,+    SshUnreachable (..),+    MetadataSshCa (..),+    installMetadataCaKey,+    Report (..),+    SshAccessCommand (..),+    sshAccessCommand,+) where++import Control.Concurrent (threadDelay)+import Control.Exception (Exception, throwIO)+import Control.Monad (void)+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.IO.Exception (ExitCode (..))+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Encoding.Error as TextError+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (proc)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Gcp.Core (Project (..), gcloudProc, withProject)+import qualified Salmon.Builtin.Nodes.Ssh as Ssh+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++data Report+    = RunSshAccessCommand !SshAccessCommand !Binary.Report+    | RunSshProbe !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++-- | An SSH endpoint to probe.+data SshEndpoint = SshEndpoint+    { sshUser :: Maybe Text+    -- ^ 'Nothing' connects as whatever @ssh@ defaults to (the local user),+    -- which is rarely the principal a signed certificate was issued for.+    , sshHost :: Text+    , sshPort :: Int+    , sshClientOpts :: Ssh.ClientOpts+    -- ^ the key to authenticate with, and where to keep host keys -- the+    -- same options the upload and the remote call will use, or the probe is+    -- not answering the question they are about to ask.+    }+    deriving (Eq, Show)++-- | How long 'sshAvailable'\'s 'up' keeps probing before giving up.+data ProbePolicy = ProbePolicy+    { probeAttempts :: Int+    , probeDelayMicros :: Int+    }+    deriving (Eq, Show)++-- | 30 attempts, 10s apart: a fresh VM's sshd is normally up well inside that.+defaultProbePolicy :: ProbePolicy+defaultProbePolicy = ProbePolicy 30 10000000++data SshUnreachable = SshUnreachable+    { unreachableHost :: Text+    , unreachableAttempts :: Int+    , unreachableLastError :: Text+    }+    deriving (Show)++instance Exception SshUnreachable++-- | 'sshAvailableWithin' 'defaultProbePolicy'.+sshAvailable :: Reporter Report -> SshEndpoint -> Op+sshAvailable = sshAvailableWithin defaultProbePolicy++{- | Verifies that an SSH endpoint is reachable, and /waits/ for it to be.++The 'up' is what makes this node a gate rather than an observation. With a+no-op 'up', a failing 'check' is simply followed by that no-op succeeding,+and everything depending on this node proceeds against an unreachable host+-- the opposite of what the node exists for. So 'up' re-probes on+'ProbePolicy' and throws 'SshUnreachable' if the host never answers, which+is what makes the one-shot drivers report dependants 'Blocked'.++Host keys are accepted on first sight (@StrictHostKeyChecking=accept-new@):+the host being probed is typically a VM created moments earlier, whose key+nothing could have known in advance, and under @BatchMode@ the default+policy would fail the probe forever. A /changed/ key is still refused.+-}+sshAvailableWithin :: ProbePolicy -> Reporter Report -> SshEndpoint -> Op+sshAvailableWithin policy _r endpoint =+    op "gcp-ssh-available" nodeps $ \actions ->+        actions+            { help = Text.unwords ["checks SSH is reachable on", endpoint.sshHost]+            , ref = mkRef "gcp-ssh-available" (endpoint.sshUser, endpoint.sshHost, endpoint.sshPort)+            , check = either (Failure . ("SSH not reachable: " <>)) (const Success) <$> probe+            , up = waitReachable policy.probeAttempts ""+            }+  where+    waitReachable :: Int -> Text -> IO ()+    waitReachable remaining lastErr+        | remaining <= 0 =+            throwIO (SshUnreachable endpoint.sshHost policy.probeAttempts lastErr)+        | otherwise = do+            result <- probe+            case result of+                Right () -> pure ()+                Left err+                    -- A host key that no longer matches never resolves by+                    -- waiting: this is a machine rebuilt at an address salmon+                    -- reserved, so "same address, new host" is the expected+                    -- case rather than an attack. Forget the recorded key and+                    -- retry at once; if the mismatch somehow persists, the+                    -- ordinary budget still runs out and still throws.+                    | Ssh.isHostKeyMismatch err+                    , Just hosts <- endpoint.sshClientOpts.optKnownHosts -> do+                        forgetHostKey hosts endpoint.sshHost+                        waitReachable (remaining - 1) err+                    | otherwise -> do+                        threadDelay policy.probeDelayMicros+                        waitReachable (remaining - 1) err++    -- ssh-keygen -R rewrites the file in place, and succeeds when there was+    -- nothing to remove.+    forgetHostKey :: FilePath -> Text -> IO ()+    forgetHostKey hosts host =+        void $ readCreateProcessWithExitCode (proc "ssh-keygen" ["-R", Text.unpack host, "-f", hosts]) ""++    probe :: IO (Either Text ())+    probe = do+        (code, _out, err) <-+            readCreateProcessWithExitCode+                ( proc+                    "ssh"+                    ( [ "-o"+                      , "ConnectTimeout=5"+                      , "-o"+                      , "BatchMode=yes"+                      ]+                        <> Ssh.clientArgs endpoint.sshClientOpts+                        <> [ "-p"+                           , show endpoint.sshPort+                           , Text.unpack (maybe endpoint.sshHost (\u -> u <> "@" <> endpoint.sshHost) endpoint.sshUser)+                           , "true"+                           ]+                    )+                )+                ""+        pure $ case code of+            ExitSuccess -> Right ()+            ExitFailure _ -> Left (endpoint.sshHost <> ": " <> Text.strip (Text.decodeUtf8With TextError.lenientDecode err))++-------------------------------------------------------------------------------++-- | Configuration for injecting an SSH CA public key via project metadata.+data MetadataSshCa = MetadataSshCa+    { sshCaProject :: Project+    , sshCaPublicKey :: FilePath+    }+    deriving (Eq, Show)++-- | Installs an SSH CA public key into project metadata so that GCE instances+-- trust it.+installMetadataCaKey :: Reporter Report -> Track' (Binary "gcloud") -> MetadataSshCa -> Op+installMetadataCaKey r gcloudTrack cfg =+    withBinary gcloudTrack sshAccessCommand (MetadataAddSshCa cfg) $ \up ->+        op "gcp-metadata-ssh-ca" nodeps $ \actions ->+            actions+                { help = Text.unwords ["installs SSH CA public key into project metadata"]+                , ref = mkRef "gcp-metadata-ssh-ca" (cfg.sshCaProject.projectId, cfg.sshCaPublicKey)+                , up = up r'+                }+  where+    r' = contramap (RunSshAccessCommand (MetadataAddSshCa cfg)) r++-------------------------------------------------------------------------------++data SshAccessCommand+    = MetadataAddSshCa MetadataSshCa+    deriving (Show)++sshAccessCommand :: Command "gcloud" SshAccessCommand+sshAccessCommand = Command $ \cmd -> case cmd of+    MetadataAddSshCa cfg ->+        gcloudProc $+            withProject cfg.sshCaProject+                [ "compute"+                , "project-info"+                , "add-metadata"+                , "--metadata-from-file"+                , "ssh-ca=" <> cfg.sshCaPublicKey+                ]
+ src/Salmon/Builtin/Nodes/Gcp/Storage.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}++module Salmon.Builtin.Nodes.Gcp.Storage (+    Bucket (..),+    bucket,+    interpretBucketDescribe,+    Report (..),+    StorageCommand (..),+    storageCommand,+) where++import Data.Text (Text)+import qualified Data.Text as Text+import GHC.IO.Exception (ExitCode (..))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (proc)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Gcp.Core (Project (..), Region (..), gcloudProc, withProject, withRegion)+import qualified Salmon.Builtin.Nodes.Gcp.Core as Core+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++data Report+    = RunStorageCommand !StorageCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++-- | A Google Cloud Storage bucket.+data Bucket = Bucket+    { bucketName :: Text+    , bucketProject :: Project+    , bucketLocation :: Region+    , bucketUniformBucketLevelAccess :: Bool+    }+    deriving (Eq, Show)++-- | Idempotently creates a GCS bucket.+--+-- * 'up': create the bucket if it does not exist.+-- * 'down': delete the bucket.+-- * 'check': describe the bucket and report 'Success' if it exists.+bucket :: Reporter Report -> Track' (Binary "gcloud") -> Bucket -> Op+bucket r gcloudTrack bkt =+    withBinary gcloudTrack storageCommand (BucketsCreate bkt) $ \create ->+        withBinary gcloudTrack storageCommand (BucketsDelete bkt) $ \delete ->+            op "gcp-bucket" nodeps $ \actions ->+                actions+                    { help = Text.unwords ["creates GCS bucket", bkt.bucketName]+                    , ref = mkRef "gcp-bucket" bkt.bucketName+                    , up = Core.retryingIO Core.afterEnableRetries Core.afterEnableDelay (create r')+                    , down = Core.downIfPresent checkBucket (delete r')+                    , check = checkBucket+                    }+  where+    r' = contramap (RunStorageCommand (BucketsCreate bkt)) r++    checkBucket :: IO CheckResult+    checkBucket = do+        (code, _out, _err) <-+            readCreateProcessWithExitCode+                (prepare storageCommand (BucketsDescribe bkt))+                ""+        pure $ interpretBucketDescribe bkt.bucketName code++-- | The verdict drawn from @gcloud storage buckets describe@'s exit code,+-- split out for testability.+interpretBucketDescribe :: Text -> ExitCode -> CheckResult+interpretBucketDescribe _name ExitSuccess = Success+interpretBucketDescribe name (ExitFailure _) = Failure ("bucket not found: " <> name)++-------------------------------------------------------------------------------++data StorageCommand+    = BucketsCreate Bucket+    | BucketsDescribe Bucket+    | BucketsDelete Bucket+    deriving (Show)++storageCommand :: Command "gcloud" StorageCommand+storageCommand = Command $ \cmd -> case cmd of+    BucketsCreate b ->+        gcloudProc $+            withProject b.bucketProject+                [ "storage"+                , "buckets"+                , "create"+                , "gs://" <> Text.unpack b.bucketName+                , "--location"+                , Text.unpack b.bucketLocation.regionName+                ]+                <> if b.bucketUniformBucketLevelAccess then ["--uniform-bucket-level-access"] else []+    BucketsDescribe b ->+        gcloudProc $+            withProject b.bucketProject+                [ "storage"+                , "buckets"+                , "describe"+                , "gs://" <> Text.unpack b.bucketName+                ]+    BucketsDelete b ->+        gcloudProc $+            withProject b.bucketProject+                [ "storage"+                , "buckets"+                , "delete"+                , "gs://" <> Text.unpack b.bucketName+                , "--quiet"+                ]
+ src/Salmon/Builtin/Nodes/Git.hs view
@@ -0,0 +1,428 @@+module Salmon.Builtin.Nodes.Git where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.OpGraph (inject)+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Control.Monad (void)+import qualified Data.ByteString.Char8 as ByteString+import Data.Text (Text)+import qualified Data.Text as Text++import System.Directory (doesDirectoryExist)+import System.FilePath (makeRelative, (</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess (..), proc)++-------------------------------------------------------------------------------+data Report+    = CloneRepo !Repo !Binary.Report+    | PullRepo !Repo !Binary.Report+    | AddFileChanges !Repo !([FilePath]) !Binary.Report+    | ApplyTag !TagName !Repo !Binary.Report+    | SkippedApplyingTag !String !TagName !Repo+    | ApplyCommit !Headline !Repo !Binary.Report+    | PushRepo !Repo !Remote !Binary.Report+    | DefineRemote !Repo !RemoteName !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------+newtype Remote = Remote {getRemote :: Text}+    deriving (Eq, Ord, Show)++type BranchName = Text++newtype Branch = Branch {getBranch :: BranchName}+    deriving (Eq, Ord, Show)++data Repo = Repo {repoClonedir :: FilePath, repoLocalName :: Text, repoRemote :: Remote, repoBranch :: Branch}+    deriving (Eq, Ord, Show)++clonedir :: Repo -> FilePath+clonedir r = r.repoClonedir </> Text.unpack r.repoLocalName++{- | @git clone@ fails outright if its destination already exists and is+non-empty — unlike the rest of the tree's builtins, it has no "set" verb of+its own to lean on. So a plain @clone >> pull@ 'up' is only idempotent on+the very first run: every run afterwards re-attempts the clone into an+already-populated directory and fails, despite the "force sync" this node's+help text promises. Skipping the clone once a @.git@ subdir is already+there — and always still pulling — is what actually delivers that.+-}+cloneThenPull :: FilePath -> IO () -> IO () -> IO ()+cloneThenPull path doClone doPull = do+    alreadyCloned <- doesDirectoryExist (path </> ".git")+    if alreadyCloned then pure () else doClone+    doPull++-- | Clones a repository.+repo :: Reporter Report -> Track' (Binary "git") -> Repo -> Op+repo r git repository =+    withBinary git gitDLcommand (Clone Shallow remote branch (clonedir repository)) $ \clone ->+        withBinary git gitDLcommand (Pull remote branch (clonedir repository)) $ \pull ->+            op "git-repo" (deps [enclosingdir]) $ \actions ->+                actions+                    { help = "clones and force sync a repo"+                    , ref = mkRef "repo" (clonedir repository)+                    , up = cloneThenPull (clonedir repository) (clone r1') (pull r2')+                    }+  where+    r1' = contramap (CloneRepo repository) r+    r2' = contramap (PullRepo repository) r+    cloneparentdir :: FilePath+    cloneparentdir = repository.repoClonedir++    remote :: Remote+    remote = repository.repoRemote++    branch :: Branch+    branch = repository.repoBranch++    enclosingdir :: Op+    enclosingdir = dir (Directory cloneparentdir)++repoFull :: Reporter Report -> Track' (Binary "git") -> Repo -> Op+repoFull r git repository =+    withBinary git gitDLcommand (Clone Full remote branch (clonedir repository)) $ \clone ->+        withBinary git gitDLcommand (Pull remote branch (clonedir repository)) $ \pull ->+            op "git-repo" (deps [enclosingdir]) $ \actions ->+                actions+                    { help = "clones and force sync a repo"+                    , ref = mkRef "repo" (clonedir repository)+                    , up = cloneThenPull (clonedir repository) (clone r1') (pull r2')+                    }+  where+    r1' = contramap (CloneRepo repository) r+    r2' = contramap (PullRepo repository) r+    cloneparentdir :: FilePath+    cloneparentdir = repository.repoClonedir++    remote :: Remote+    remote = repository.repoRemote++    branch :: Branch+    branch = repository.repoBranch++    enclosingdir :: Op+    enclosingdir = dir (Directory cloneparentdir)++data CloneDepth+    = Shallow+    | Full++data GitDownloadCommand+    = Clone CloneDepth Remote Branch FilePath+    | Pull Remote Branch FilePath++gitDLcommand :: Command "git" GitDownloadCommand+gitDLcommand = Command $ \cmd -> case cmd of+    (Clone Shallow repo branch localdir) ->+        proc+            "git"+            [ "clone"+            , "--recurse-submodules"+            , "-b"+            , Text.unpack branch.getBranch+            , "--depth"+            , "1"+            , Text.unpack repo.getRemote+            , localdir+            ]+    (Clone Full repo branch localdir) ->+        proc+            "git"+            [ "clone"+            , "--recurse-submodules"+            , "-b"+            , Text.unpack branch.getBranch+            , Text.unpack repo.getRemote+            , localdir+            ]+    (Pull repo branch dir) ->+        ( proc+            "git"+            [ "pull"+            , Text.unpack repo.getRemote+            , Text.unpack branch.getBranch+            ]+        )+            { cwd = Just dir+            }++-------------------------------------------------------------------------------++addfiles ::+    Reporter Report ->+    Track' (Binary "git") ->+    Track' Repo ->+    Repo ->+    [File "change"] ->+    Op+addfiles _ _ _ _ [] = noop "git-add-nothing"+addfiles r git mkrepo repository files =+    withBinary git gitModCommand (AddFiles repodir paths) $ \up ->+        op "git-add" (deps filechanges) $ \actions ->+            actions+                { help = Text.unwords ["add", Text.pack (show (length files)), "in repo", repository.repoLocalName]+                , notes = fmap Text.pack paths+                , ref = mkRef "git-add" (repodir, paths)+                , up = up (contramap (AddFileChanges repository paths) r)+                }+  where+    filechanges :: [Op]+    filechanges = fmap (\x -> fileOp x `inject` run mkrepo repository) files+    paths :: [FilePath]+    paths = fmap (\x -> makeRelative repodir (getFilePath x)) files+    repodir :: FilePath+    repodir = clonedir repository++commit ::+    Reporter Report ->+    Track' (Binary "git") ->+    Track' Repo ->+    Track' Author ->+    Repo ->+    Author ->+    CommitMessage ->+    Op ->+    Op+commit r git mkrepo mkauthor repository author msg modrepo =+    withBinary git gitModCommand (Commit (clonedir repository) author msg) $ \up ->+        op "git-commit" (deps [run mkauthor author, repochange]) $ \actions ->+            actions+                { help = Text.unwords ["commits", headline.getHeadline, "on repo", repository.repoLocalName]+                , ref = mkRef "commit" (headline.getHeadline, repository.repoLocalName)+                , up = up (contramap (ApplyCommit headline repository) r)+                }+  where+    headline :: Headline+    headline = msg.commitHeadline++    repochange :: Op+    repochange = modrepo `inject` run mkrepo repository++tag ::+    Reporter Report ->+    Track' (Binary "git") ->+    Track' Repo ->+    Repo ->+    TagName ->+    Maybe Message ->+    Op+tag r git mkrepo repository name msg =+    withBinary git gitModCommand (VerifyClean (clonedir repository)) $ \checkClean ->+        withBinary git gitModCommand (Tag (clonedir repository) name msg) $ \f ->+            op "git-tag" (deps [run mkrepo repository]) $ \actions ->+                actions+                    { help = Text.unwords ["apply git tag", name.getTagName, "on repo", repository.repoLocalName]+                    , ref = mkRef "tag" (name.getTagName, repository.repoLocalName)+                    , up = do+                        checkClean (reportBoth r' (applyTagOnCleanRepository (f r')))+                    }+  where+    r' = contramap (ApplyTag name repository) r++    reportSkip txt = runReporter r (SkippedApplyingTag (ByteString.unpack txt) name repository)++    applyTagOnCleanRepository :: IO () -> Reporter Binary.Report+    applyTagOnCleanRepository applyTag = ReporterM go+      where+        go br = case br of+            Binary.Requested _ brr -> go brr+            Binary.CommandSuccess out _ ->+                if ByteString.null out+                    then applyTag+                    else reportSkip out+            Binary.CommandStopped _ _ _ err ->+                reportSkip err+            otherwise -> pure ()++remote ::+    Reporter Report ->+    Track' (Binary "git") ->+    Track' Repo ->+    Repo ->+    RemoteName ->+    Remote ->+    Op+remote r git mkrepo repository name remote =+    withBinary git gitModCommand (AddRemote (clonedir repository) name remote) $ \up ->+        op "git-add-remote" (deps [run mkrepo repository]) $ \actions ->+            actions+                { help = Text.unwords ["add remote", name.getRemoteName, "on repo", repository.repoLocalName]+                , ref = mkRef "remote" (name.getRemoteName, repository.repoLocalName)+                , up = up (contramap (DefineRemote repository name) r)+                }++newtype Headline = Headline {getHeadline :: Text}+    deriving (Eq, Ord, Show)++type Message = Text++data CommitMessage+    = CommitMessage+    { commitHeadline :: !Headline+    , commitBody :: !Message+    }+    deriving (Eq, Ord, Show)++commitMessage :: CommitMessage -> Text+commitMessage (CommitMessage h b) = Text.unlines [h.getHeadline, b]++newtype TagName = TagName {getTagName :: Text}+    deriving (Eq, Ord, Show)++newtype RemoteName = RemoteName {getRemoteName :: Text}+    deriving (Eq, Ord, Show)++newtype Author = Author {getAuthor :: Text}+    deriving (Eq, Ord, Show)++data GitModifyCommand+    = AddFiles FilePath [FilePath]+    | Commit FilePath Author CommitMessage+    | Tag FilePath TagName (Maybe Message)+    | AddRemote FilePath RemoteName Remote+    | VerifyClean FilePath++gitModCommand :: Command "git" GitModifyCommand+gitModCommand = Command $ \cmd -> case cmd of+    (AddFiles dir paths) ->+        ( proc+            "git"+            ("add" : paths)+        )+            { cwd = Just dir+            }+    (AddRemote dir name spec) ->+        ( proc+            "git"+            [ "remote"+            , "add"+            , Text.unpack name.getRemoteName+            , Text.unpack spec.getRemote+            ]+        )+            { cwd = Just dir+            }+    (Commit dir author msg) ->+        ( proc+            "git"+            [ "commit"+            , "--author"+            , Text.unpack author.getAuthor+            , "-a"+            , "-m"+            , Text.unpack (commitMessage msg)+            ]+        )+            { cwd = Just dir+            }+    (Tag dir name Nothing) ->+        ( proc+            "git"+            [ "tag"+            , "-f"+            , Text.unpack name.getTagName+            ]+        )+            { cwd = Just dir+            }+    (Tag dir name (Just msg)) ->+        ( proc+            "git"+            [ "tag"+            , "-f"+            , Text.unpack name.getTagName+            , "-m"+            , Text.unpack msg+            ]+        )+            { cwd = Just dir+            }+    (VerifyClean dir) ->+        ( proc+            "git"+            [ "status"+            , "--untracked-files=no"+            , "--porcelain"+            ]+        )+            { cwd = Just dir+            }++-------------------------------------------------------------------------------++push ::+    Reporter Report ->+    Track' (Binary "git") ->+    Track' Repo ->+    -- | the local branch to push is taken from this repo+    Repo ->+    -- | the remote to push to+    Remote ->+    -- | name given to the remote we push to (e.g., "origin")+    RemoteName ->+    Op ->+    Op+push r git mkrepo repository remoteSpec remotename modrepo =+    withBinary git gitULCommand (Push (clonedir repository) remoteSpec branch) $ \up ->+        op "git-push" (deps [referenceRemote, repochange]) $ \actions ->+            actions+                { help = Text.unwords ["pushes", branch.getBranch, "of repo", repository.repoLocalName, "to", remoteSpec.getRemote]+                , ref = mkRef "push" (repository.repoLocalName, remoteSpec.getRemote, branch.getBranch)+                , up = up (contramap (PushRepo repository remoteSpec) r)+                }+  where+    repochange :: Op+    repochange = modrepo `inject` run mkrepo repository+    branch :: Branch+    branch = repository.repoBranch+    referenceRemote = remote r git mkrepo repository remotename remoteSpec++data GitULCommand+    = Push FilePath Remote Branch++gitULCommand :: Command "git" GitULCommand+gitULCommand = Command $ \cmd -> case cmd of+    (Push dir remote branch) ->+        ( proc+            "git"+            [ "push"+            , "-f"+            , "--tags"+            , Text.unpack remote.getRemote+            , Text.unpack branch.getBranch+            ]+        )+            { cwd = Just dir+            }++-------------------------------------------------------------------------------++-- | Provides a file from an existing repository.+repofile :: Track' Repo -> Repo -> FilePath -> File a+repofile t r sub =+    let+        path = clonedir r </> sub+     in+        Generated mkPath path+  where+    mkPath :: Track' FilePath+    mkPath = Track $ \_ -> run t r++-- | Provides a Directory from an existing repository.+repodir :: Track' Repo -> Repo -> FilePath -> Tracked' Directory+repodir t r sub =+    let+        path = clonedir r </> sub+     in+        Tracked mkPath (Directory path)+  where+    mkPath :: Track' a+    mkPath = Track $ \_ -> run t r
+ src/Salmon/Builtin/Nodes/Keys.hs view
@@ -0,0 +1,179 @@+module Salmon.Builtin.Nodes.Keys where++import Salmon.Actions.UpDown (skipIfFileExists)+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Control.Monad (void)+import qualified Crypto.JOSE.JWK as JWK+import Data.Aeson (encode)+import qualified Data.ByteString.Lazy as LBS+import Data.Functor.Contravariant (contramap)+import Data.Text (Text)+import qualified Data.Text as Text++import System.FilePath ((</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess, proc)++data Report+    = MakeSshKey !SSHKeyPair Binary.Report+    | SignKeyReport !SSHKeyPair Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++data KeyType+    = RSA2048+    | RSA4096+    | ED25519+    deriving (Eq, Ord, Show)++data SSHKeyPair = SSHKeyPair {sshKeyType :: KeyType, sshKeyDir :: FilePath, sshKeyName :: Text}+    deriving (Eq, Ord, Show)++privateKeyPath :: SSHKeyPair -> FilePath+privateKeyPath key = key.sshKeyDir </> Text.unpack key.sshKeyName++publicKeyPath :: SSHKeyPair -> FilePath+publicKeyPath key = key.sshKeyDir </> Text.unpack key.sshKeyName <> ".pub"++publicCAKeyPath :: SSHKeyPair -> FilePath+publicCAKeyPath key = key.sshKeyDir </> Text.unpack key.sshKeyName <> "-cert.pub"++-------------------------------------------------------------------------------++sshKey :: Reporter Report -> Track' (Binary "ssh-keygen") -> SSHKeyPair -> Op+sshKey r bin key =+    withBinary bin sshkeygen (Keygen (key.sshKeyType, filepath)) $ \up ->+        op "ssh-key" (deps [enclosingdir]) $ \actions ->+            actions+                { help = "generate an ssh-key"+                , notes =+                    [ "keeps keys around"+                    ]+                , ref = mkRef "ssh" (sshdir, key.sshKeyName)+                , check = skipIfFileExists filepath+                , up = up r'+                }+  where+    r' :: Reporter Binary.Report+    r' = contramap (MakeSshKey key) r+    filename :: FilePath+    filename = Text.unpack key.sshKeyName++    sshdir :: FilePath+    sshdir = key.sshKeyDir++    filepath :: FilePath+    filepath = sshdir </> filename++    enclosingdir :: Op+    enclosingdir = dir (Directory sshdir)++newtype Keygen = Keygen (KeyType, FilePath)++sshkeygen :: Command "ssh-keygen" Keygen+sshkeygen = Command $ \(Keygen (kt, filepath)) ->+    case kt of+        RSA2048 -> proc "ssh-keygen" ["-t", "rsa", "-b", "2048", "-N", "", "-f", filepath]+        RSA4096 -> proc "ssh-keygen" ["-t", "rsa", "-b", "4096", "-N", "", "-f", filepath]+        ED25519 -> proc "ssh-keygen" ["-t", "ed25519", "-N", "", "-f", filepath]++newtype KeyIdentifier = KeyIdentifier {getIdentifier :: Text}+    deriving (Eq, Ord, Show)++data SSHCertificateAuthority = SSHCertificateAuthority {sshcaKey :: SSHKeyPair}+    deriving (Eq, Ord, Show)++-------------------------------------------------------------------------------++newtype Principal = Principal {getPrincipal :: Text}+    deriving (Eq, Ord, Show)++{- | @principals@ must be non-empty: modern OpenSSH (checked against 9.6p1)+rejects a certificate with an empty principal list outright at auth time+(@Certificate lacks principal list@), even with a matching+@TrustedUserCAKeys@ — it is not, as older docs/folklore suggest, "valid for+any principal" (hand-validated 2026-08-20, see+@specs/qemu-test-vms-progress.md@). Pass the login name(s) this key is+meant to authenticate as, e.g. @[Principal "root"]@.+-}+signKey ::+    Reporter Report ->+    Track' (Binary "ssh-keygen") ->+    SSHCertificateAuthority ->+    KeyIdentifier ->+    [Principal] ->+    SSHKeyPair ->+    Op+signKey r bin ca kid principals keyToSign =+    withBinary bin sshsign (SignKey (ca, kid, principals, (privateKeyPath keyToSign))) $ \up ->+        op "ssh-ca-sign" (deps preds) $ \actions ->+            actions+                { help = "sign a SSH-key"+                , ref = mkRef "ssh-ca-sign" (show ca, kid.getIdentifier)+                , check = skipIfFileExists (publicCAKeyPath keyToSign)+                , up = up r'+                }+  where+    r' = contramap (SignKeyReport keyToSign) r+    preds =+        [ sshKey r bin keyToSign+        , sshKey r bin ca.sshcaKey+        ]++newtype SignKey = SignKey (SSHCertificateAuthority, KeyIdentifier, [Principal], FilePath)++sshsign :: Command "ssh-keygen" SignKey+sshsign = Command $ \(SignKey (ca, kid, principals, certifiedPath)) ->+    proc "ssh-keygen" $+        [ "-s"+        , privateKeyPath ca.sshcaKey+        , "-I"+        , Text.unpack kid.getIdentifier+        , "-n"+        , Text.unpack (Text.intercalate "," (map getPrincipal principals))+        , certifiedPath+        ]++data JWKKeyPair = JWKKeyPair {jwkKeyType :: KeyType, jwkKeyDir :: FilePath, jwkKeyName :: Text}+    deriving (Eq, Ord, Show)++jwkfilepath :: JWKKeyPair -> FilePath+jwkfilepath key =+    key.jwkKeyDir </> Text.unpack key.jwkKeyName++jwkKey :: JWKKeyPair -> Op+jwkKey key =+    op "jwk-key" (deps [enclosingdir]) $ \actions ->+        actions+            { help = "generate a jwk-key"+            , notes = ["keeps keys around"]+            , ref = mkRef "jwk" (jwkdir, key.jwkKeyName)+            , check = skipIfFileExists (jwkfilepath key)+            , up = up+            }+  where+    up :: IO ()+    up = jwk >>= LBS.writeFile (jwkfilepath key) . encode++    jwk :: IO JWK.JWK+    jwk = case key.jwkKeyType of+        RSA2048 -> JWK.genJWK (JWK.RSAGenParam (2048 `div` 8))+        RSA4096 -> JWK.genJWK (JWK.RSAGenParam (4096 `div` 8))+        ED25519 -> JWK.genJWK (JWK.OKPGenParam JWK.Ed25519)++    filename :: FilePath+    filename = Text.unpack key.jwkKeyName++    jwkdir :: FilePath+    jwkdir = key.jwkKeyDir++    enclosingdir :: Op+    enclosingdir = dir (Directory jwkdir)
+ src/Salmon/Builtin/Nodes/LinuxBridge.hs view
@@ -0,0 +1,279 @@+{- | Linux bridge and tap-device primitives, for giving qemu VMs (or anything+else) a real local L2 network to sit on — the @-- TODO: Ip, Ip6, Arp, Bridge,+NetDev@ "Salmon.Builtin.Nodes.Netfilter" never got to.++Neither @ip link add ... type bridge@ nor @ip tuntap add@ is idempotent on+its own (both fail with "File exists" on a second run) — same shape as+"Salmon.Builtin.Nodes.Netfilter"'s @nft add rule@ problem, so this uses the+same fix already established as this project's convention: check whether+the link already exists (@ip link show@) and report+'Salmon.Actions.UpDown.Success' via 'check' instead of trying to force the+@ip@ invocation itself to be+idempotent (see 'skipIfLinkExists', mirroring+"Salmon.Builtin.Nodes.Podman".'Salmon.Builtin.Nodes.Podman.skipIfNetworkExists').+-}+module Salmon.Builtin.Nodes.LinuxBridge where++import Salmon.Actions.UpDown (CheckResult (..), upTree)+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Control.Exception (throwIO)+import Control.Monad (unless)+import Control.Monad.Identity (runIdentity)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Encoding.Error as Text++import GHC.IO.Exception (ExitCode (..))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess, proc)++-------------------------------------------------------------------------------+data Report+    = RunIpLink !IpLinkCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++type DevName = Text++-- | A local Linux bridge, identified by its device name (e.g. @salmontest0@).+newtype Bridge = Bridge {bridgeName :: DevName}+    deriving (Eq, Ord, Show)++{- | A tap device attached to a 'Bridge' — what a qemu VM's @-netdev tap@+plugs into. 'tapOwner', if given, is the unprivileged user allowed to open+the resulting @\/dev\/tapN@ without root (matches @ip tuntap add ... user+\<name\>@).+-}+data Tap+    = Tap+    { tapName :: DevName+    , tapBridge :: Bridge+    , tapOwner :: Maybe Text+    }+    deriving (Eq, Ord, Show)++-- | An IPv4 address in CIDR notation, e.g. @Cidr "10.99.0.1" 24@ for @10.99.0.1/24@.+data Cidr = Cidr {cidrAddr :: Text, cidrPrefix :: Int}+    deriving (Eq, Ord, Show)++cidrText :: Cidr -> Text+cidrText c = c.cidrAddr <> "/" <> Text.pack (show c.cidrPrefix)++-------------------------------------------------------------------------------++-- | Creates a bridge device and brings it up.+bridge :: Reporter Report -> Track' (Binary "ip") -> Bridge -> Op+bridge r ip br =+    withBinary ip ipLinkCommand (AddBridge br) $ \add ->+        op "linux-bridge" nodeps $ \actions ->+            actions+                { help = "creates a Linux bridge device " <> br.bridgeName+                , ref = mkRef "linux-bridge" br.bridgeName+                , check = skipIfLinkExists br.bridgeName+                , up = add r' >> Binary.untrackedExec ipLinkCommand (SetUp br.bridgeName) "" r'+                , down = Binary.untrackedExec ipLinkCommand (DeleteLink br.bridgeName) "" r'+                }+  where+    r' = contramap (RunIpLink (AddBridge br)) r++{- | Creates a tap device, attaches it to its bridge, and brings both the tap+and the bridge up.++Deliberately does *not* declare the bridge as a graph dependency (@deps+[bridge ...]@) — a persistent, shared bridge (the documented, intended+lifecycle here: many taps/VMs come and go, the bridge outlives all of+them) must never be reachable as *this tap's own* predecessor, or+'Salmon.Actions.UpDown.downTree''s "release a predecessor once its last+dependent is torn down" rule (correct in general — see the directory/+two-files example in CLAUDE.md) would delete the bridge out from under+every *other* still-running tap the moment any single one of them tears+down, since each tap's own 'Salmon.Op.OpGraph.OpGraph' traversal has no+visibility into sibling taps' graphs (different process, different+'downTree' call). Hand-observed 2026-09-08: several real qemu VMs' taps+left dangling (@NO-CARRIER@) after the bridge vanished this way mid test+session — see @specs/qemu-test-vms-progress.md@.++Instead, 'up' ensures the bridge exists via a *nested* 'upTree' run+(same accepted pattern as+"Salmon.Builtin.Nodes.PostgresMigrations".@remoteMigrateOpaqueSetup@ —+check the returned 'Bool', 'throwIO' if it's 'False', since that's the+only way a nested traversal's failure becomes visible to the outer one)+rather than a plain graph dependency, so the bridge is brought up as a+precondition without ever becoming *this* op's own teardown-reachable+predecessor. Whoever wants the bridge gone does so explicitly (e.g.+'bridge'\/'bridgeAddr' torn down directly) — never implicitly as a side+effect of one tap going down.+-}+tap :: Reporter Report -> Track' (Binary "ip") -> Tap -> Op+tap r ip t =+    withBinary ip ipLinkCommand (AddTap t) $ \add ->+        op "linux-tap" nodeps $ \actions ->+            actions+                { help = "creates tap device " <> t.tapName <> " on bridge " <> t.tapBridge.bridgeName+                , ref = mkRef "linux-tap" (t.tapBridge.bridgeName, t.tapName)+                , check = skipIfLinkExists t.tapName+                , up = ensureBridge >> add r' >> attach r' >> Binary.untrackedExec ipLinkCommand (SetUp t.tapName) "" r'+                , down = Binary.untrackedExec ipLinkCommand (DeleteLink t.tapName) "" r'+                }+  where+    r' = contramap (RunIpLink (AddTap t)) r+    attach r'' = Binary.untrackedExec ipLinkCommand (SetMaster t.tapName t.tapBridge) "" r''+    ensureBridge = do+        ok <- upTree silent (pure . runIdentity) (bridge r ip t.tapBridge)+        unless ok (throwIO (userError ("linux-tap: failed to bring up bridge " <> Text.unpack t.tapBridge.bridgeName)))++{- | Assigns an IPv4 address to an already-existing 'Bridge' (e.g. so the host+side of a test network has something to route SSH traffic through to a+guest sitting on the same bridge). Depends on the bridge already existing.+-}+bridgeAddr :: Reporter Report -> Track' (Binary "ip") -> Bridge -> Cidr -> Op+bridgeAddr r ip br cidr =+    withBinary ip ipLinkCommand (AddAddr br.bridgeName cidr) $ \add ->+        op "linux-addr" (deps [bridge r ip br]) $ \actions ->+            actions+                { help = "assigns " <> cidrText cidr <> " to " <> br.bridgeName+                , ref = mkRef "linux-addr" (br.bridgeName, cidrText cidr)+                , check = skipIfAddrExists br.bridgeName cidr+                , up = add r'+                , down = Binary.untrackedExec ipLinkCommand (DelAddr br.bridgeName cidr) "" r'+                }+  where+    r' = contramap (RunIpLink (AddAddr br.bridgeName cidr)) r++{- | @ip addr show dev \<name\>@ succeeds and lists every address currently+assigned — 'Salmon.Actions.UpDown.Success' iff the wanted CIDR text is+already one of them, same+"does the effect already exist" shape as 'skipIfLinkExists'.+-}+skipIfAddrExists :: DevName -> Cidr -> IO CheckResult+skipIfAddrExists name cidr = do+    (code, out, _err) <- readCreateProcessWithExitCode (proc "ip" ["addr", "show", "dev", Text.unpack name]) ""+    pure $ case code of+        ExitSuccess | cidrText cidr `Text.isInfixOf` Text.decodeUtf8With Text.lenientDecode out -> Success+        _ -> Failure ("address not on the link: " <> cidrText cidr)++{- | @ip link show \<name\>@ succeeds (exit 0) iff a link by that name already+exists — the same "does the effect already exist" shape as+'Salmon.Builtin.Nodes.Podman.skipIfNetworkExists' \/+'Salmon.Builtin.Nodes.Netfilter.skipIfNftRuleExists'.+-}+skipIfLinkExists :: DevName -> IO CheckResult+skipIfLinkExists name = do+    (code, _, _) <- readCreateProcessWithExitCode (proc "ip" ["link", "show", Text.unpack name]) ""+    pure $ case code of+        ExitSuccess -> Success+        _ -> Failure ("no such link: " <> name)++-------------------------------------------------------------------------------+data IpLinkCommand+    = AddBridge Bridge+    | AddTap Tap+    | SetMaster DevName Bridge+    | SetUp DevName+    | DeleteLink DevName+    | AddAddr DevName Cidr+    | DelAddr DevName Cidr+    deriving (Show)++{- | Every @ip@ invocation here goes through @capsh@ instead of calling+@ip@ directly — hand-validated 2026-09-08 against a real unprivileged run+(see @specs/qemu-test-vms-progress.md@): granting @ip@ itself+@cap_net_admin@ via plain @setcap@ does not work. @strace@ on a failing+@ip link add@ showed @ip@ unconditionally calling+@capset({...}, {effective=0, permitted=0, inheritable=0})@ at startup —+iproute2 drops its *entire* capability set on exec and only trusts the+*ambient* set to re-populate what it needs, which a plain file-capability+grant can never populate (the kernel zeroes ambient for any exec of a+"privileged" file, by design — see @capabilities(7)@). The fix is a+launcher that already holds the capability (via file caps, granted on+@capsh@ itself — see 'Salmon.Builtin.Nodes.Capabilities.grantCapabilities')+raising it into its *own* ambient set (which requires it in both the+permitted and — separately, since exec does not carry a file's inheritable+bit into the new process's own inheritable set — the inheritable set+first) before exec'ing the real, uncapped @ip@; ambient capabilities do+propagate across exec and are what iproute2 actually honors. Works+identically whether the caller is real root (whose permitted set is+already full, so @--inh=@/@--addamb=@ trivially succeed with no file+capability needed at all) or an unprivileged user with the capability+granted on @capsh@ — so this wrapping is unconditional, not privilege-mode+-specific.+-}+ipLinkCommand :: Command "ip" IpLinkCommand+ipLinkCommand = Command $ \cmd -> capshAmbient (rawIpArgs cmd)++rawIpArgs :: IpLinkCommand -> [String]+rawIpArgs cmd = case cmd of+    (AddBridge br) ->+        [ "link"+        , "add"+        , "name"+        , Text.unpack br.bridgeName+        , "type"+        , "bridge"+        ]+    (AddTap t) ->+        mconcat+            [ ["tuntap", "add", "dev", Text.unpack t.tapName, "mode", "tap"]+            , maybe [] (\owner -> ["user", Text.unpack owner]) t.tapOwner+            ]+    (SetMaster name br) ->+        [ "link"+        , "set"+        , Text.unpack name+        , "master"+        , Text.unpack br.bridgeName+        ]+    (SetUp name) ->+        [ "link"+        , "set"+        , Text.unpack name+        , "up"+        ]+    (DeleteLink name) ->+        [ "link"+        , "delete"+        , Text.unpack name+        ]+    (AddAddr name cidr) ->+        [ "addr"+        , "add"+        , Text.unpack (cidrText cidr)+        , "dev"+        , Text.unpack name+        ]+    (DelAddr name cidr) ->+        [ "addr"+        , "del"+        , Text.unpack (cidrText cidr)+        , "dev"+        , Text.unpack name+        ]++{- | Runs @ip \<args\>@ via @capsh --inh=cap_net_admin --addamb=cap_net_admin+-- -c "ip ...quoted args..."@ — see 'ipLinkCommand's haddock for why. The+inner @-c@ string is re-split by a shell, so each arg is individually+single-quoted first (same "one Haskell string, one remote/shell token"+concern as "Test.Harness".'Test.Harness.quoteForRemoteShell', just for a+local shell instead of ssh's).+-}+capshAmbient :: [String] -> CreateProcess+capshAmbient args =+    proc+        "capsh"+        [ "--inh=cap_net_admin"+        , "--addamb=cap_net_admin"+        , "--"+        , "-c"+        , unwords (map shellQuote ("ip" : args))+        ]++shellQuote :: String -> String+shellQuote s = "'" <> concatMap (\c -> if c == '\'' then "'\\''" else [c]) s <> "'"
+ src/Salmon/Builtin/Nodes/LlamaServer.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE OverloadedStrings #-}++{- | @llama-server@ (llama.cpp) serving an __embedding model__, so text can be+turned into the vectors of a @vector(N)@ column ("Salmon.Builtin.Nodes.PgVector").+Text only; the image-and-text counterpart is a different builtin.++Nodes, in dependency order: 'llamaInstall' (a pinned release archive),+'llamaModel' (a GGUF file with a pinned sha256), then the server in one of+two run modes, and 'llamaReady' to wait for it.++What running build b11195 with a bge-small model showed, which the code is+shaped by:++* @GET \/health@ needs no key and answers @{"status":"ok"}@; refused+  connections are what one sees before it listens. @POST \/v1\/embeddings@+  wants the key when @--api-key-file@ is given (@401@ otherwise) and answers+  @data[0].embedding@, a list of as many numbers as the model has dimensions.+* @--pooling@ is passed explicitly rather than left to the model's default,+  because the vectors an index holds are only comparable with ones produced+  the same way.+* The release archive is a @tar.gz@ whose one top directory is+  @llama-\<build\>@ and whose binary finds its libraries through+  @RUNPATH=$ORIGIN@, so it runs from where it was extracted with no+  environment.++= The check is the dimension++Being up is not the question; producing vectors the column can hold is.+'llamaCheck' asks @\/health@, then embeds a fixed string and compares the+length of the answer with 'lsDimension'. A model swapped for one with another+width, which would make every later insert fail, is a 'Failure' naming both.+pgvector's indexes take at most 2000 dimensions for a @vector@ (4000 for+@halfvec@); a declared dimension above that is put in the node's notes.++= Two run modes++'llamaServerDaemon' is a process salmon owns (@Nodes/Daemon@): it comes up+only under @run serve@, and a one-shot @run up@ refuses it rather than+pretending. That is the mode for demos and tests. 'llamaServerSystemd' is a+unit for a host that should keep it, followed by 'llamaReady' (a model takes+seconds to load and @systemctl restart@ returns at once).++= Exposure++Loopback by default. The key is read from a file and never appears in argv+(nor in the @curl@ that checks the server: its configuration goes to @curl@+on stdin). A unix socket path is an option for owner-only access.+-}+module Salmon.Builtin.Nodes.LlamaServer (+    LlamaRelease (..),+    llamaInstall,+    llamaBinary,+    ModelFile (..),+    llamaModel,+    Pooling (..),+    Listen (..),+    LlamaServer (..),+    defaultLlamaServer,+    serverArgs,+    llamaServerDaemon,+    llamaServerSystemd,+    llamaReady,+    llamaCheck,++    -- * Pieces, exposed for tests+    interpretHealth,+    interpretEmbedding,+    dimensionNote,+    curlConfig,+    curlBase,+    sha256File,+) where++import Control.Concurrent (threadDelay)+import Control.Exception (throwIO)+import Control.Monad (unless, when)+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LByteString+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.IO.Exception (ExitCode (..))+import System.Directory (createDirectoryIfMissing, doesFileExist, removeDirectoryRecursive, removeFile, renameFile)+import System.FilePath (takeDirectory, (</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (proc)+import Text.Printf (printf)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import qualified Salmon.Builtin.Nodes.Daemon as Daemon+import qualified Salmon.Builtin.Nodes.Systemd as Systemd+import Salmon.Op.OpGraph (inject)+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++-- | A pinned release: the build tag, the archive and the sha256 it must have+-- (GitHub shows it as the asset's digest), and where it is extracted.+data LlamaRelease = LlamaRelease+    { llamaBuild :: Text+    -- ^ @b11195@+    , llamaArchiveUrl :: Text+    , llamaArchiveSha256 :: Text+    , llamaInstallDir :: FilePath+    -- ^ the archive's @llama-\<build\>\/@ lands inside this+    }+    deriving (Eq, Show)++-- | Where the binary is after 'llamaInstall'.+llamaBinary :: LlamaRelease -> FilePath+llamaBinary rel = llamaInstallDir rel </> ("llama-" <> Text.unpack (llamaBuild rel)) </> "llama-server"++{- | Download, refuse unless the sha256 matches, extract. @check@ asks the+binary its build number; @down@ removes the extracted directory (which this+node made, and nothing else lives in).+-}+llamaInstall :: LlamaRelease -> Op+llamaInstall rel =+    op "llama-install" nodeps $ \actions ->+        actions+            { help = "installs llama.cpp " <> rel.llamaBuild+            , notes = ["pinned sha256: " <> rel.llamaArchiveSha256, "from " <> rel.llamaArchiveUrl]+            , ref = mkRef "llama-install" (rel.llamaBuild, rel.llamaInstallDir)+            , check = do+                there <- doesFileExist (llamaBinary rel)+                if not there+                    then pure (Failure ("no binary at " <> Text.pack (llamaBinary rel)))+                    else do+                        (code, out, _) <- readCreateProcessWithExitCode (proc (llamaBinary rel) ["--version"]) ""+                        let said = decode out+                        pure $ case code of+                            ExitSuccess | ("build " <> Text.drop 1 rel.llamaBuild <> ",") `Text.isInfixOf` said -> Success+                            _ -> Failure ("the binary is not " <> rel.llamaBuild)+            , up = do+                let archive = rel.llamaInstallDir </> ("llama-" <> Text.unpack rel.llamaBuild <> ".tar.gz.part")+                createDirectoryIfMissing True rel.llamaInstallDir+                _ <- run' "curl" ["-fsSL", "-o", archive, Text.unpack rel.llamaArchiveUrl]+                actual <- sha256File archive+                when (Text.toLower rel.llamaArchiveSha256 /= actual) $ do+                    removeFile archive+                    ioError (userError ("llama.cpp archive has sha256 " <> Text.unpack actual <> ", expected " <> Text.unpack rel.llamaArchiveSha256))+                _ <- run' "tar" ["xzf", archive, "-C", rel.llamaInstallDir]+                removeFile archive+            , down = removeDirectoryRecursive (takeDirectory (llamaBinary rel))+            }++-------------------------------------------------------------------------------++-- | A GGUF model with the sha256 it must have. Models are large, so this is+-- normally provisioned by somebody else; 'modelUrl' lets the node fetch it once.+data ModelFile = ModelFile+    { modelPath :: FilePath+    , modelSha256 :: Text+    , modelUrl :: Maybe Text+    }+    deriving (Eq, Show)++{- | @check@ hashes the file (streamed: a model is gigabytes). @up@ fetches to+a @.part@ file, verifies, and renames, or says the model has to be+provisioned. @down@ leaves it: a model is expensive to get back and is+not something this node made unless it fetched it.+-}+llamaModel :: ModelFile -> Op+llamaModel m =+    op "llama-model" nodeps $ \actions ->+        actions+            { help = "GGUF model at " <> Text.pack m.modelPath+            , notes = ["pinned sha256: " <> m.modelSha256, "down leaves the file"]+            , ref = mkRef "llama-model" m.modelPath+            , check = do+                there <- doesFileExist m.modelPath+                if not there+                    then pure (Failure ("missing: " <> Text.pack m.modelPath))+                    else do+                        actual <- sha256File m.modelPath+                        pure (if actual == Text.toLower m.modelSha256 then Success else Failure ("sha256 differs: " <> Text.pack m.modelPath))+            , up = case m.modelUrl of+                Nothing -> ioError (userError ("model " <> m.modelPath <> " is missing or is not the pinned one, and no url was given to fetch it"))+                Just url -> do+                    let part = m.modelPath <> ".part"+                    createDirectoryIfMissing True (takeDirectory m.modelPath)+                    _ <- run' "curl" ["-fsSL", "-o", part, Text.unpack url]+                    actual <- sha256File part+                    unless (actual == Text.toLower m.modelSha256) $ do+                        removeFile part+                        ioError (userError ("model has sha256 " <> Text.unpack actual <> ", expected " <> Text.unpack m.modelSha256))+                    renameFile part m.modelPath+            , down = pure ()+            }++-- | Streamed, lower-case hex.+sha256File :: FilePath -> IO Text+sha256File path = hex . SHA256.hashlazy <$> LByteString.readFile path++hex :: ByteString.ByteString -> Text+hex = Text.pack . concatMap (printf "%02x") . ByteString.unpack++-------------------------------------------------------------------------------++data Pooling = PoolNone | PoolMean | PoolCls | PoolLast | PoolRank+    deriving (Eq, Show)++poolingArg :: Pooling -> Text+poolingArg p = case p of+    PoolNone -> "none"+    PoolMean -> "mean"+    PoolCls -> "cls"+    PoolLast -> "last"+    PoolRank -> "rank"++data Listen+    = -- | 127.0.0.1 on this port+      Loopback Int+    | -- | another address; exposing it is the caller's decision+      Address Text Int+    | -- | a unix socket path (owner-only access)+      UnixSocket FilePath+    deriving (Eq, Show)++data LlamaServer = LlamaServer+    { lsName :: Text+    -- ^ identity of the node (and the unit's name)+    , lsRelease :: LlamaRelease+    , lsModel :: ModelFile+    , lsDimension :: Int+    -- ^ what the model must produce, i.e. the @vector(N)@ it feeds+    , lsPooling :: Pooling+    , lsListen :: Listen+    , lsApiKeyFile :: Maybe FilePath+    -- ^ keys, one per line; also what the check authenticates with+    , lsContext :: Maybe Int+    , lsThreads :: Maybe Int+    , lsUser :: Text+    -- ^ the systemd unit's @User=@ (unused by the daemon mode)+    }+    deriving (Eq, Show)++-- | Loopback on 8080, no key, the model's own context and thread count, run as root.+defaultLlamaServer :: Text -> LlamaRelease -> ModelFile -> Int -> Pooling -> LlamaServer+defaultLlamaServer name rel model dim pooling =+    LlamaServer name rel model dim pooling (Loopback 8080) Nothing Nothing Nothing "root"++-- | The arguments after the binary. The key's /path/ only.+serverArgs :: LlamaServer -> [Text]+serverArgs s =+    mconcat+        [ ["-m", Text.pack s.lsModel.modelPath, "--embedding", "--pooling", poolingArg s.lsPooling]+        , case s.lsListen of+            Loopback p -> ["--host", "127.0.0.1", "--port", tshow p]+            Address h p -> ["--host", h, "--port", tshow p]+            UnixSocket path -> ["--host", Text.pack path]+        , maybe [] (\f -> ["--api-key-file", Text.pack f]) s.lsApiKeyFile+        , maybe [] (\n -> ["-c", tshow n]) s.lsContext+        , maybe [] (\n -> ["-t", tshow n]) s.lsThreads+        ]++-- | Set when the dimension is beyond what pgvector indexes.+dimensionNote :: Int -> Maybe Text+dimensionNote n+    | n > 4000 = Just (tshow n <> " dimensions exceeds what pgvector can index at all (4000 for halfvec): truncate the vectors")+    | n > 2000 = Just (tshow n <> " dimensions exceeds the 2000 pgvector indexes for a vector: use halfvec, or truncate")+    | otherwise = Nothing++tshow :: (Show a) => a -> Text+tshow = Text.pack . show++-------------------------------------------------------------------------------++{- | A process salmon owns, kept running by @run serve@ (see+"Salmon.Builtin.Nodes.Daemon"). Its @check@ is 'llamaCheck', so the tending+loop notices a server that is up but wrong.+-}+llamaServerDaemon :: Reporter Daemon.Report -> LlamaServer -> Op+llamaServerDaemon r s =+    op "llama-server" (deps [llamaInstall s.lsRelease, llamaModel s.lsModel]) $ \actions ->+        actions+            { help = "keeps llama-server " <> s.lsName <> " running"+            , notes = maybe [] pure (dimensionNote s.lsDimension)+            , ref = mkRef "llama-server" s.lsName+            , managed = Just (Daemon.runDaemon r d)+            , check = llamaCheck s+            , up = throwIO (Daemon.NeedsSupervisor s.lsName)+            , down = pure ()+            }+  where+    d = Daemon.defaultDaemon ("llama-server-" <> s.lsName) (proc (llamaBinary s.lsRelease) (Text.unpack <$> serverArgs s))++{- | A systemd unit that keeps it, then 'llamaReady' on top: depend on the+returned node to depend on a server that produces vectors.+-}+llamaServerSystemd :: Reporter Systemd.Report -> Track' (Binary "systemctl") -> LlamaServer -> Op+llamaServerSystemd r systemctl s =+    llamaReady s 120 `inject` Systemd.systemdService r systemctl trackConfig config+  where+    config :: Systemd.Config+    config =+        Systemd.Config+            Systemd.System+            "/etc/systemd/system"+            ("salmon-llama-server-" <> s.lsName <> ".service")+            (Systemd.Unit ("llama-server from Salmon (" <> s.lsName <> ")") "network-online.target")+            ( Systemd.Service+                Systemd.Simple+                s.lsUser+                s.lsUser+                "077"+                (Systemd.Start (llamaBinary s.lsRelease) (serverArgs s))+                Systemd.OnFailure+                Systemd.Process+                (llamaInstallDir s.lsRelease)+            )+            (Systemd.Install "multi-user.target")+    trackConfig :: Track' Systemd.Config+    trackConfig = Track $ \_ ->+        op "llama-server-prerequisites" (deps [llamaInstall s.lsRelease, llamaModel s.lsModel]) $ \actions ->+            actions{ref = mkRef "llama-server-prerequisites" s.lsName}++{- | Waits (up to this many seconds) for 'llamaCheck' to pass. For after+something that starts the server and returns before it can answer.+-}+llamaReady :: LlamaServer -> Int -> Op+llamaReady s seconds =+    op "llama-server-ready" nodeps $ \actions ->+        actions+            { help = "llama-server " <> s.lsName <> " produces " <> tshow s.lsDimension <> "-dimensional vectors"+            , notes = maybe [] pure (dimensionNote s.lsDimension)+            , ref = mkRef "llama-server-ready" s.lsName+            , check = llamaCheck s+            , up = wait seconds+            }+  where+    wait n = do+        verdict <- llamaCheck s+        case verdict of+            Success -> pure ()+            Failure why | n <= 0 -> ioError (userError ("llama-server " <> Text.unpack s.lsName <> " is not producing vectors: " <> Text.unpack why))+            _ | n <= 0 -> ioError (userError ("llama-server " <> Text.unpack s.lsName <> " could not be checked in time"))+            _ -> threadDelay 1000000 >> wait (n - 1 :: Int)++-------------------------------------------------------------------------------++{- | @GET \/health@, then embed a fixed string and compare the vector's length+with the declared dimension.+-}+llamaCheck :: LlamaServer -> IO CheckResult+llamaCheck s = do+    key <- traverse readKey s.lsApiKeyFile+    (hcode, hout, _) <- curl (curlConfig s.lsListen "/health" Nothing key)+    let health = interpretHealth hcode (statusOf (decode hout))+    case health of+        Success -> do+            (ecode, eout, _) <- curl (curlConfig s.lsListen "/v1/embeddings" (Just "{\"input\":\"salmon\"}") key)+            pure $ case ecode of+                ExitSuccess -> let (body, status) = splitStatus (decode eout) in interpretEmbedding s.lsDimension status body+                ExitFailure _ -> Unknown+        other -> pure other+  where+    readKey f = Text.strip . Text.takeWhile (/= '\n') . decode <$> ByteString.readFile f+    curl cfg = readCreateProcessWithExitCode (proc "curl" curlBase) (Text.encodeUtf8 cfg)++-- | @curl@'s own arguments: everything else, the key included, is on stdin.+curlBase :: [String]+curlBase = ["-K", "-"]++{- | The @curl@ configuration (read from stdin) for one request. The key is+here and not in argv, where any user could read it off @ps@.+-}+curlConfig :: Listen -> Text -> Maybe Text -> Maybe Text -> Text+curlConfig listen path body key =+    Text.unlines . concat $+        [ ["silent", "max-time = 20", "write-out = \"\\n%{http_code}\""]+        , ["url = " <> quote url]+        , ["unix-socket = " <> quote (Text.pack sock) | UnixSocket sock <- [listen]]+        , ["header = " <> quote ("Authorization: Bearer " <> k) | Just k <- [key]]+        , concat [["header = \"Content-Type: application/json\"", "data = " <> quote b] | Just b <- [body]]+        ]+  where+    url = case listen of+        Loopback p -> "http://127.0.0.1:" <> tshow p <> path+        Address h p -> "http://" <> h <> ":" <> tshow p <> path+        UnixSocket _ -> "http://localhost" <> path+    quote t = "\"" <> Text.replace "\"" "\\\"" (Text.replace "\\" "\\\\" t) <> "\""++-- | The HTTP status from what @curl@ wrote: the body, a newline, the code.+splitStatus :: Text -> (Text, Int)+splitStatus out =+    case Text.breakOnEnd "\n" out of+        (body, code) | [(n, "")] <- reads (Text.unpack (Text.strip code)) -> (Text.dropWhileEnd (== '\n') body, n)+        _ -> (out, 0)++statusOf :: Text -> Int+statusOf = snd . splitStatus++{- | The verdict from @\/health@: refused (curl exit 7) is 'Failure', a+loading model (503) is 'Unknown', so a slow start is waited out rather than+restarted.+-}+interpretHealth :: ExitCode -> Int -> CheckResult+interpretHealth (ExitFailure 7) _ = Failure "llama-server is not listening"+interpretHealth (ExitFailure _) _ = Unknown+interpretHealth ExitSuccess 200 = Success+interpretHealth ExitSuccess 503 = Unknown+interpretHealth ExitSuccess n = Failure ("llama-server answers /health with " <> tshow n)++{- | The verdict from the embedding of a fixed string: the vector must be+as long as declared. A refused key is a 'Failure' too, since nothing else can+tell that the file this node reads is not the one the server was given.+-}+interpretEmbedding :: Int -> Int -> Text -> CheckResult+interpretEmbedding dim status body+    | status == 401 = Failure "the api key was refused"+    | status /= 200 = Unknown+    | otherwise = case Aeson.decodeStrict (Text.encodeUtf8 body) of+        Just (Aeson.Object o)+            | Just (Aeson.Array ds) <- KeyMap.lookup "data" o+            , (Aeson.Object d : _) <- foldr (:) [] ds+            , Just (Aeson.Array v) <- KeyMap.lookup "embedding" d ->+                let n = length v+                 in if n == dim then Success else Failure ("the model produces " <> tshow n <> " dimensions, " <> tshow dim <> " declared")+        _ -> Unknown++-------------------------------------------------------------------------------++decode :: ByteString.ByteString -> Text+decode = Text.decodeUtf8With TextError.lenientDecode++run' :: String -> [String] -> IO Text+run' cmd args = do+    (code, out, err) <- readCreateProcessWithExitCode (proc cmd args) ""+    case code of+        ExitSuccess -> pure (decode out)+        ExitFailure n -> throwIO (Binary.CommandFailedSimple (cmd <> ": " <> take 500 (Text.unpack (decode err))) n)
+ src/Salmon/Builtin/Nodes/Netfilter.hs view
@@ -0,0 +1,253 @@+module Salmon.Builtin.Nodes.Netfilter where++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import qualified Salmon.Builtin.Nodes.Filesystem as FS+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import System.IO (IOMode (ReadMode, WriteMode), withFile)++import Control.Monad (void)+import Data.Dynamic (toDyn)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Encoding.Error as Text+import qualified Data.Text.IO as Text+import GHC.IO.Exception (ExitCode (..))+import GHC.IO.Handle (Handle)++import System.FilePath (takeDirectory, (</>))+import System.Process (StdStream (UseHandle), waitForProcess)+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess (..), proc)++-------------------------------------------------------------------------------+data Report+    = RunNftCommand !NftCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++data NetFamily+    = Inet+    deriving (Show)++-- TODO: Ip, Ip6, Arp, Bridge, NetDev++netFamily :: NetFamily -> Text+netFamily Inet = "inet"++data Table+    = Table+    { tableName :: Text+    , tableFamily :: NetFamily+    }+    deriving (Show)++{- | A base chain is one hooked into the netfilter packet path (as opposed to a+regular chain, which only runs when jumped to explicitly). Needed for e.g. NAT+postrouting or forwarding decisions to actually fire.+-}+data ChainType+    = FilterChain+    | NatChain+    deriving (Show)++chainTypeTxt :: ChainType -> Text+chainTypeTxt FilterChain = "filter"+chainTypeTxt NatChain = "nat"++data Hook+    = PreRouting+    | Input+    | Forward+    | Output+    | PostRouting+    deriving (Show)++hookTxt :: Hook -> Text+hookTxt PreRouting = "prerouting"+hookTxt Input = "input"+hookTxt Forward = "forward"+hookTxt Output = "output"+hookTxt PostRouting = "postrouting"++data ChainPolicy+    = Accept+    | Drop+    deriving (Show)++policyTxt :: ChainPolicy -> Text+policyTxt Accept = "accept"+policyTxt Drop = "drop"++data BaseChainSpec+    = BaseChainSpec+    { baseChainType :: ChainType+    , baseChainHook :: Hook+    , baseChainPriority :: Int+    , baseChainPolicy :: ChainPolicy+    }+    deriving (Show)++data Chain+    = Chain+    { chainName :: Text+    , chainTable :: Table+    , chainBase :: Maybe BaseChainSpec+    }+    deriving (Show)++-- | A regular (non-hooked) chain, only reachable via explicit jumps.+regularChain :: Text -> Table -> Chain+regularChain name t = Chain name t Nothing++-- | A base chain, hooked into the netfilter packet path.+baseChain :: Text -> Table -> BaseChainSpec -> Chain+baseChain name t spec = Chain name t (Just spec)++data Rule+    = RawRule [Text]+    deriving (Show)++data NftCommand+    = AddTable Table+    | AddChain Chain+    | AddRule Chain Rule+    deriving (Show)++table :: Reporter Report -> Track' (Binary "nft") -> Table -> Op+table r nft t =+    withBinary nft nftcommand cmd $ \add ->+        op "nft-table" nodeps $ \actions ->+            actions+                { help = "creates an Netfilter table"+                , ref = mkRef "nft-table" t.tableName+                , up = add r'+                , dynamics = [toDyn cmd]+                }+  where+    r' = contramap (RunNftCommand cmd) r+    cmd = AddTable t++chain :: Reporter Report -> Track' (Binary "nft") -> Chain -> Op+chain r nft c =+    withBinary nft nftcommand cmd $ \add ->+        op "nft-chain" (deps [table r nft c.chainTable]) $ \actions ->+            actions+                { help = "creates an Netfilter chain"+                , ref = mkRef "nft-chain" (c.chainTable.tableName, c.chainName)+                , up = add r'+                , dynamics = [toDyn cmd]+                }+  where+    r' = contramap (RunNftCommand cmd) r+    cmd = AddChain c++rule :: Reporter Report -> Track' (Binary "nft") -> Chain -> Rule -> Op+rule r nft c nftrule =+    withBinary nft nftcommand cmd $ \add ->+        op "nft-rule" (deps [chain r nft c]) $ \actions ->+            actions+                { help = "creates an Netfilter rule"+                , ref = mkRef "nft-rule" (c.chainTable.tableName, c.chainName, textual nftrule)+                , check = skipIfNftRuleExists c nftrule+                , up = add r'+                , dynamics = [toDyn cmd]+                }+  where+    r' = contramap (RunNftCommand cmd) r+    cmd = AddRule c nftrule+    textual :: Rule -> Text+    textual (RawRule txts) = Text.unwords txts++{- | @nft add rule@ is not idempotent on its own — reapplying the same rule+appends a duplicate each time instead of a no-op (nft rule handles aren't+content-addressed, so there's no equivalent of @ip route replace@ here).+Instead, this checks whether a line matching the rule's own rendered text is+already present in @nft list chain@'s output and, if so, reports+'Salmon.Actions.UpDown.Success' — the same "does the effect already exist"+shape as 'Salmon.Actions.UpDown.skipIfFileExists', just backed by a command's+output instead of the filesystem. If the chain itself doesn't exist yet (e.g.+the very first run, before its dependency has created it) a+'Salmon.Actions.UpDown.Failure' is naturally correct too: there is nothing to+find, so nothing to skip.+-}+skipIfNftRuleExists :: Chain -> Rule -> IO CheckResult+skipIfNftRuleExists c (RawRule terms) = do+    (code, out, _err) <-+        readCreateProcessWithExitCode+            ( proc+                "nft"+                [ "list"+                , "chain"+                , Text.unpack (netFamily c.chainTable.tableFamily)+                , Text.unpack c.chainTable.tableName+                , Text.unpack c.chainName+                ]+            )+            ""+    pure $ case code of+        ExitSuccess | wanted `Text.isInfixOf` Text.decodeUtf8With Text.lenientDecode out -> Success+        _ -> Failure ("no such rule in the chain: " <> wanted)+  where+    wanted :: Text+    wanted = Text.unwords terms++baseChainSpecTerms :: BaseChainSpec -> [Text]+baseChainSpecTerms spec =+    [ "{"+    , "type"+    , chainTypeTxt spec.baseChainType+    , "hook"+    , hookTxt spec.baseChainHook+    , "priority"+    , Text.pack (show spec.baseChainPriority)+    , ";"+    , "policy"+    , policyTxt spec.baseChainPolicy+    , ";"+    , "}"+    ]++nftcommand :: Command "nft" NftCommand+nftcommand = Command $ \cmd -> case cmd of+    (AddTable table) ->+        proc+            "nft"+            [ "add"+            , "table"+            , Text.unpack $ netFamily table.tableFamily+            , Text.unpack table.tableName+            ]+    (AddChain chain) ->+        proc "nft" $+            mconcat+                [+                    [ "add"+                    , "chain"+                    , Text.unpack $ netFamily chain.chainTable.tableFamily+                    , Text.unpack chain.chainTable.tableName+                    , Text.unpack chain.chainName+                    ]+                , maybe [] (fmap Text.unpack . baseChainSpecTerms) chain.chainBase+                ]+    (AddRule chain (RawRule terms)) ->+        proc "nft" $+            mconcat+                [+                    [ "add"+                    , "rule"+                    , Text.unpack $ netFamily chain.chainTable.tableFamily+                    , Text.unpack chain.chainTable.tableName+                    , Text.unpack chain.chainName+                    ]+                , fmap Text.unpack terms+                ]++-- todo: ruleset turning chains into single-run
+ src/Salmon/Builtin/Nodes/Nginx.hs view
@@ -0,0 +1,106 @@+{- | nginx as a reverse-proxy load balancer, configured purely from a list of+DNS-name -> upstream(s) mappings — one @server{}@ block per name, proxying+to a load-balanced upstream group.+-}+module Salmon.Builtin.Nodes.Nginx where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, justInstall)+import qualified Salmon.Builtin.Nodes.Filesystem as FS+import qualified Salmon.Builtin.Nodes.Systemd as Systemd+import Salmon.Op.OpGraph (inject)+import Salmon.Op.Track+import Salmon.Reporter++import Data.Text (Text)+import qualified Data.Text as Text++import System.FilePath ((</>))++-------------------------------------------------------------------------------++type ServerName = Text++data Upstream+    = Upstream+    { upstream_host :: Text+    , upstream_port :: Int+    }+    deriving (Show)++data Scheme+    = Http+    | Https+    deriving (Show)++schemeTxt :: Scheme -> Text+schemeTxt Http = "http"+schemeTxt Https = "https"++-- | One DNS name routed to a (possibly load-balanced) set of backends.+data VHost+    = VHost+    { vhost_server_name :: ServerName+    , vhost_listen_port :: Int+    , vhost_upstream_scheme :: Scheme+    , vhost_upstreams :: [Upstream]+    }++data NginxConfig+    = NginxConfig+    { nginx_sites_dir :: FilePath+    -- ^ e.g. \/etc\/nginx\/conf.d+    , nginx_vhosts :: [VHost]+    }++vhostFileName :: VHost -> FilePath+vhostFileName v = Text.unpack v.vhost_server_name <> ".conf"++-------------------------------------------------------------------------------++configFiles :: NginxConfig -> Op+configFiles cfg =+    op "nginx-config" (deps $ fmap vhostFile cfg.nginx_vhosts) id+  where+    vhostFile v = FS.filecontents $ FS.FileContents (cfg.nginx_sites_dir </> vhostFileName v) (renderVHost v)++renderVHost :: VHost -> Text+renderVHost v =+    Text.unlines $+        mconcat+            [+                [ "upstream " <> upstreamName <> " {"+                ]+            , fmap renderUpstream v.vhost_upstreams+            ,+                [ "}"+                , ""+                , "server {"+                , "    listen " <> Text.pack (show v.vhost_listen_port) <> ";"+                , "    server_name " <> v.vhost_server_name <> ";"+                , ""+                , "    location / {"+                , "        proxy_pass " <> schemeTxt v.vhost_upstream_scheme <> "://" <> upstreamName <> ";"+                , "        proxy_set_header Host $host;"+                , "        proxy_set_header X-Real-IP $remote_addr;"+                , "        proxy_set_header X-Forwarded-For $proxy_add_x_forwarded_for;"+                , "        proxy_set_header X-Forwarded-Proto $scheme;"+                , "    }"+                , "}"+                ]+            ]+  where+    upstreamName :: Text+    upstreamName = "upstream_" <> Text.replace "." "_" v.vhost_server_name++    renderUpstream :: Upstream -> Text+    renderUpstream u = mconcat ["    server ", u.upstream_host, ":", Text.pack (show u.upstream_port), ";"]++-------------------------------------------------------------------------------++-- | Installs nginx, renders every vhost's config, and reloads the (package-shipped) service.+setup :: Reporter Systemd.Report -> Track' (Binary "systemctl") -> Track' (Binary "nginx") -> NginxConfig -> Op+setup r systemctl nginxBin cfg =+    Systemd.restartService r systemctl "nginx.service"+        `inject` configFiles cfg+        `inject` justInstall nginxBin
+ src/Salmon/Builtin/Nodes/Npm.hs view
@@ -0,0 +1,54 @@+module Salmon.Builtin.Nodes.Npm where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Data.Text (Text)+import qualified Data.Text as Text+import GHC.TypeLits (Symbol)++import System.FilePath (takeDirectory, (</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess, cwd, proc)++-------------------------------------------------------------------------------+data Report+    = NpmInstall !Npm !Binary.Report+    deriving (Show)++isInstallSuccess :: Report -> Bool+isInstallSuccess r = case r of+    (NpmInstall _ cmd) ->+        Binary.isCommandSuccessful cmd++-------------------------------------------------------------------------------+data Npm = Npm {npmDir :: FilePath}+    deriving (Eq, Ord, Show)++-------------------------------------------------------------------------------+data NpmRun+    = Install Npm++-------------------------------------------------------------------------------+install :: Reporter Report -> Track' (Binary "npm") -> Npm -> Op+install r npm s =+    withBinary npm npmRun (Install s) $ \up ->+        op "npm-install" nodeps $ \actions ->+            actions+                { help = "npm installs a project"+                , ref = mkRef "npm-install" (show s)+                , up = up r'+                }+  where+    r' = contramap (NpmInstall s) r++-------------------------------------------------------------------------------+npmRun :: Command "npm" NpmRun+npmRun = Command $ go+  where+    go (Install c) = (proc "npm" ["install"]){cwd = Just c.npmDir}
+ src/Salmon/Builtin/Nodes/PgBouncer.hs view
@@ -0,0 +1,199 @@+{- | pgbouncer, configured to sit in front of one or more upstream Postgres+databases and pool connections for a set of client-facing users.++Deliberately decoupled from "Salmon.Builtin.Nodes.Postgres": callers pass+plain host\/port\/dbname\/user\/password values, so this module doesn't need+to know anything about how the upstream cluster/roles were provisioned (they+may not even be managed by salmon on this machine, e.g. a remote replica).+-}+module Salmon.Builtin.Nodes.PgBouncer where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, justInstall)+import qualified Salmon.Builtin.Nodes.Filesystem as FS+import qualified Salmon.Builtin.Nodes.Systemd as Systemd+import Salmon.Op.Track+import Salmon.Reporter++import Data.Text (Text)+import qualified Data.Text as Text++import System.FilePath ((</>))+import System.Process (readProcess)++-------------------------------------------------------------------------------++type DbAlias = Text++-- | The upstream Postgres database a client-facing alias is pooled against.+data UpstreamDb+    = UpstreamDb+    { upstream_host :: Text+    , upstream_port :: Int+    , upstream_dbname :: Text+    }+    deriving (Show)++data BouncerDatabase+    = BouncerDatabase+    { bouncer_db_alias :: DbAlias+    -- ^ the name clients connect to through pgbouncer+    , bouncer_db_upstream :: UpstreamDb+    }+    deriving (Show)++-- | A client-facing user allowed to authenticate against pgbouncer.+data AuthUser+    = AuthUser+    { auth_user :: Text+    , auth_password :: Text+    -- ^ cleartext; only ever touches disk already-hashed, in the auth_file+    }++data PoolMode+    = SessionPooling+    | TransactionPooling+    | StatementPooling+    deriving (Show)++poolModeTxt :: PoolMode -> Text+poolModeTxt SessionPooling = "session"+poolModeTxt TransactionPooling = "transaction"+poolModeTxt StatementPooling = "statement"++data BouncerConfig+    = BouncerConfig+    { bouncer_config_dir :: FilePath+    -- ^ e.g. \/etc\/pgbouncer+    , bouncer_listen_addr :: Text+    , bouncer_listen_port :: Int+    , bouncer_databases :: [BouncerDatabase]+    , bouncer_users :: [AuthUser]+    , bouncer_pool_mode :: PoolMode+    , bouncer_max_client_conn :: Int+    , bouncer_default_pool_size :: Int+    , bouncer_admin_users :: [Text]+    -- ^ users allowed on the admin console (database @pgbouncer@), which is+    -- how anything moves traffic without restarting: @PAUSE@, @RELOAD@,+    -- @RESUME@, and the @SHOW@s that say where clients are being sent. They+    -- authenticate like any other user, so each one also belongs in+    -- 'bouncer_users'.+    , bouncer_routing_file :: Maybe FilePath+    -- ^ a second config file, pulled in with @%include@, for databases whose+    -- upstream is somebody else's to decide -- a pair's routing, say+    -- (@SreBox.PostgresPair@).+    --+    -- It exists so that ownership is divisible. This node owns the service+    -- and the static configuration, and watches those files, so that a+    -- change to them is noticed and applied -- by a restart. Traffic must+    -- not move that way: a restart drops every client this process exists to+    -- hold. So the routing file is deliberately /not/ watched, and whoever+    -- owns it applies a change the gentle way, through the admin console.+    -- It must exist before the service starts, since pgbouncer refuses a+    -- missing include.+    }++configPath :: BouncerConfig -> FilePath+configPath cfg = cfg.bouncer_config_dir </> "pgbouncer.ini"++userlistPath :: BouncerConfig -> FilePath+userlistPath cfg = cfg.bouncer_config_dir </> "userlist.txt"++-------------------------------------------------------------------------------++-- | Renders @pgbouncer.ini@ and the @auth_file@ (@userlist.txt@, md5-hashed passwords).+configFiles :: BouncerConfig -> Op+configFiles cfg =+    op "pgbouncer-config" (deps [iniFile, userlistFile]) id+  where+    iniFile = FS.filecontents $ FS.FileContents (configPath cfg) (renderIni cfg)+    userlistFile = FS.filecontents $ FS.FileContents (userlistPath cfg) (renderUserlist cfg.bouncer_users)++renderIni :: BouncerConfig -> Text+renderIni cfg =+    Text.unlines $+        mconcat+            [+                [ "[databases]"+                ]+            , fmap renderDb cfg.bouncer_databases+            ,+                [ ""+                , "[pgbouncer]"+                , "listen_addr = " <> cfg.bouncer_listen_addr+                , "listen_port = " <> Text.pack (show cfg.bouncer_listen_port)+                , "auth_type = md5"+                , "auth_file = " <> Text.pack (userlistPath cfg)+                , "pool_mode = " <> poolModeTxt cfg.bouncer_pool_mode+                , "max_client_conn = " <> Text.pack (show cfg.bouncer_max_client_conn)+                , "default_pool_size = " <> Text.pack (show cfg.bouncer_default_pool_size)+                ]+            , ["admin_users = " <> Text.intercalate "," cfg.bouncer_admin_users | not (null cfg.bouncer_admin_users)]+            , maybe [] (\path -> ["", "%include " <> Text.pack path]) cfg.bouncer_routing_file+            ]+  where+    renderDb :: BouncerDatabase -> Text+    renderDb db =+        mconcat+            [ db.bouncer_db_alias+            , " = host="+            , db.bouncer_db_upstream.upstream_host+            , " port="+            , Text.pack (show db.bouncer_db_upstream.upstream_port)+            , " dbname="+            , db.bouncer_db_upstream.upstream_dbname+            ]++-- | @"user" "md5<hex(md5(password<>username))>"@ per entry, one per line —+-- pgbouncer's own md5 @auth_file@ format (matching Postgres's md5 auth scheme).+renderUserlist :: [AuthUser] -> IO Text+renderUserlist users = Text.unlines <$> mapM renderUser users+  where+    renderUser :: AuthUser -> IO Text+    renderUser u = do+        h <- md5AuthHash u.auth_password u.auth_user+        pure $ mconcat ["\"", u.auth_user, "\" \"", h, "\""]++md5AuthHash :: Text -> Text -> IO Text+md5AuthHash password username = do+    out <- readProcess "openssl" ["dgst", "-md5", "-r"] (Text.unpack (password <> username))+    pure $ "md5" <> Text.takeWhile (/= ' ') (Text.pack out)++-------------------------------------------------------------------------------++{- | Installs pgbouncer, renders its config, and runs it as a systemd service.++The ini and the userlist are 'Systemd.systemdServiceWatching'\'s watched+files, without which a changed upstream or a rotated password is written to+disk and never reaches the running process: the unit is untouched, so the+service node is skipped. Note that acting on such a change is a restart,+which drops the clients this process exists to hold on to -- a node that+means to move traffic should @PAUSE@ the bouncers, change the config, and+@RESUME@ them, rather than let this node notice on its own.++'bouncer_routing_file' is the seam for exactly that: it is included by the+ini and is /not/ watched here, so the node that owns it can move traffic+through the admin console without this one restarting the service underneath+it. See @SreBox.PostgresPair@, which owns one.+-}+setup :: Reporter Systemd.Report -> Track' (Binary "systemctl") -> Track' (Binary "pgbouncer") -> BouncerConfig -> Op+setup r systemctl pgbouncerBin cfg =+    Systemd.systemdServiceWatching [configPath cfg, userlistPath cfg] r systemctl trackConfig systemdCfg+  where+    trackConfig :: Track' Systemd.Config+    trackConfig = Track $ \_ -> op "pgbouncer-setup" (deps [configFiles cfg, justInstall pgbouncerBin]) id++    systemdCfg :: Systemd.Config+    systemdCfg = Systemd.Config Systemd.System "/etc/systemd/system" "pgbouncer.service" unit svc install++    unit :: Systemd.Unit+    unit = Systemd.Unit "PgBouncer (from Salmon)" "network-online.target"++    svc :: Systemd.Service+    svc = Systemd.Service Systemd.Simple "postgres" "postgres" "0022" start Systemd.OnFailure Systemd.Process cfg.bouncer_config_dir++    start :: Systemd.Start+    start = Systemd.Start "/usr/sbin/pgbouncer" [Text.pack (configPath cfg)]++    install :: Systemd.Install+    install = Systemd.Install "multi-user.target"
+ src/Salmon/Builtin/Nodes/PgVector.hs view
@@ -0,0 +1,96 @@+{- | pgvector: the @vector@ type and the @hnsw@ / @ivfflat@ access methods.++The simplest of the Postgres extensions: files from a package, then+@CREATE EXTENSION vector@ in each database. No @shared_preload_libraries@+entry, no restart.++Two decisions the node makes so a caller does not have to:++* __The package name comes from a declared major version__+  (@postgresql-\<major\>-pgvector@), not from the running cluster. 'deb'+  takes a static name, and a declared major keeps the graph hermetic (and+  lets 'Salmon.Builtin.Nodes.Debian.Package.batchPackages' see it). A wrong+  declaration is loud: @CREATE EXTENSION@ then cannot find its control file.+* __Where the package comes from is the caller's choice.__ The package is+  in the PostgreSQL project's own repository (and, on some releases, the+  distribution's). 'pgvSource' is a @'Track'' ()@: pass+  @'Salmon.Builtin.Nodes.Debian.AptRepository.viaRepository' ('Salmon.Builtin.Nodes.Debian.AptRepository.pgdg' key fingerprint)@+  to take on the external repository, or+  'Salmon.Builtin.Extension.ignoreTrack' to require that the package is+  installable already.++Out of scope: vector columns and indexes (schema: migrations), and the+per-query knobs (@hnsw.ef_search@, @ivfflat.probes@).+-}+module Salmon.Builtin.Nodes.PgVector (+    PgVector (..),+    pgvector,+    pgvectorPackage,+) 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.Debian.Package (Package (..))+import qualified Salmon.Builtin.Nodes.Debian.Package as Package+import Salmon.Builtin.Nodes.Postgres (DatabaseName, PgExtension (..), Port)+import qualified Salmon.Builtin.Nodes.Postgres as Postgres+import Salmon.Op.OpGraph (inject)+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++data PgVector = PgVector+    { pgvMajor :: Int+    -- ^ the cluster's major version; 13 is the floor+    , pgvPort :: Port+    , pgvDatabases :: [DatabaseName]+    , pgvUpgrade :: Bool+    -- ^ also @ALTER EXTENSION vector UPDATE@ when the package is newer (see 'extUpgrade')+    }+    deriving (Eq, Show)++-- | @postgresql-16-pgvector@ for major 16.+pgvectorPackage :: Int -> Package+pgvectorPackage major = Package ("postgresql-" <> Text.pack (show major) <> "-pgvector")++{- | Install the package (after its source, if the caller supplied one), then+make @vector@ usable in each declared database.++@down@ drops the extension from each database without @CASCADE@, so a+database with vector columns refuses, and leaves the package installed.+-}+pgvector ::+    Reporter Postgres.Report ->+    Reporter Package.Report ->+    Track' (Binary "psql") ->+    Track' () ->+    Track' DatabaseName ->+    PgVector ->+    Op+pgvector r pkgReporter psql source mkdb cfg =+    op "pgvector" (deps exts) $ \actions ->+        actions+            { help = "pgvector for postgresql " <> Text.pack (show cfg.pgvMajor) <> " in " <> Text.pack (show (length cfg.pgvDatabases)) <> " database(s)"+            , ref = mkRef "pgvector" (cfg.pgvPort, cfg.pgvDatabases)+            }+  where+    package :: Op+    package = Package.debWith pkgReporter (pgvectorPackage cfg.pgvMajor) `inject` run source ()++    exts :: [Op]+    exts =+        [ Postgres.extension r psql cfg.pgvPort mkdb (spec db) `inject` package+        | db <- cfg.pgvDatabases+        ]++    spec :: DatabaseName -> PgExtension+    spec db =+        PgExtension+            { extName = "vector"+            , extDatabase = db+            , extMinServerVersion = Just 130000+            , extUpgrade = cfg.pgvUpgrade+            }
+ src/Salmon/Builtin/Nodes/Plakar.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Plakar (<https://github.com/PlakarKorp/plakar>): encrypted, deduplicated+snapshots in a /Kloset/ store. Three nodes, in the order they depend on each+other: the binary ('plakarInstall'), a store ('kloset') and a scheduled+backup job with a freshness check ('plakarJob').++What running v1.1.7 taught, and the code is shaped by:++* __Exit codes are not the whole story.__ A failure to start the background+  cache process (@failed to run cached@) is printed and exits @0@. So the+  store is confirmed by the @CONFIG@ file it should have written, the backup+  by the line @backup completed without errors@, and a listing that printed+  nothing and complained on stderr is 'Unknown', never \"no snapshot\".+* __The cache process talks over a unix socket under the cache directory__,+  so a home directory whose path is long enough to overflow @sun_path@ makes+  every command fail as above. Nothing here can fix that; know it when a+  job's @$HOME@ is deep.+* __@prune@ without a filter refuses, and with one it is a dry run__ until+  @-apply@. The job passes @-apply@ only with a declared 'KeepPolicy'.+* __@ls@ prints one snapshot per line, newest first when asked for+  @-latest@__: @TIMESTAMP ID SIZE DURATION PATH@ with an RFC 3339 UTC+  timestamp. @-json@ does not change @ls@ in this version.++Deliberate refusals: a store without a declared, non-empty, owner-only+keyfile (salmon never generates the passphrase: losing it makes the backups+unrecoverable by design); and a job without a retention policy (prune deletes+snapshots irreversibly). A store's @down@ does nothing, because deleting a+backup store is not something a teardown gets to do.++v1 is a local store. Remote stores (S3-compatible, GCS) are Plakar+integrations installed with @plakar pkg add@ and are a follow-up.+-}+module Salmon.Builtin.Nodes.Plakar (+    PlakarRelease (..),+    plakarInstall,+    plakarBinary,+    KlosetStore (..),+    kloset,+    KeepPolicy (..),+    keepDays,+    pruneArgs,+    PlakarJob (..),+    plakarJob,++    -- * Pieces, exposed for tests+    interpretVersion,+    interpretSnapshotList,+    keyfileProblem,+    renderBackupScript,+    sha256Hex,+) where++import Control.Exception (throwIO)+import Control.Monad (unless, when)+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Data.ByteString as ByteString+import Data.Foldable (asum)+import Data.Maybe (catMaybes)+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 Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)+import Data.Time.Format.ISO8601 (iso8601ParseM)+import GHC.IO.Exception (ExitCode (..))+import System.Directory (doesFileExist, removeFile)+import qualified System.Posix.Files as Posix+import qualified System.Posix.Types as Posix+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (proc)+import Text.Printf (printf)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, justInstall)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.CronTask (CronTask (..), Schedule, crontask)+import Salmon.Builtin.Nodes.Filesystem (FileContents (..), filecontents)+import Salmon.Op.Ref+import Salmon.Op.Track++-------------------------------------------------------------------------------++-- | A pinned release: the version it reports, where its @.deb@ is, and the+-- sha256 that file must have (from the release's @checksums.txt@).+data PlakarRelease = PlakarRelease+    { plakarVersion :: Text+    -- ^ @1.1.7@+    , plakarDebUrl :: Text+    , plakarDebSha256 :: Text+    }+    deriving (Eq, Show)++-- | Where a caller wanting @Track' (Binary "plakar")@ gets it from.+plakarBinary :: PlakarRelease -> Track' (Binary "plakar")+plakarBinary = Track . const . plakarInstall++{- | Installs the pinned @.deb@: download, refuse unless the sha256 matches,+@dpkg -i@. The check is @plakar version@ naming the wanted version; @down@ is+@dpkg -r plakar@ (a store is left alone).+-}+plakarInstall :: PlakarRelease -> Op+plakarInstall rel =+    op "plakar-install" nodeps $ \actions ->+        actions+            { help = "installs plakar " <> rel.plakarVersion+            , notes = ["pinned sha256: " <> rel.plakarDebSha256, "from " <> rel.plakarDebUrl]+            , ref = mkRef "plakar-install" rel.plakarVersion+            , check = do+                (code, out, _) <- readCreateProcessWithExitCode (proc "plakar" ["version"]) ""+                pure $ case code of+                    ExitSuccess -> interpretVersion rel.plakarVersion (decode out)+                    ExitFailure _ -> Failure "plakar is not installed"+            , up = do+                let path = "/tmp/salmon-plakar-" <> Text.unpack rel.plakarDebSha256 <> ".deb"+                _ <- run' "curl" ["-fsSL", "-o", path, Text.unpack rel.plakarDebUrl]+                bytes <- ByteString.readFile path+                let actual = sha256Hex bytes+                when (Text.toLower rel.plakarDebSha256 /= actual) $ do+                    removeFile path+                    ioError (userError ("plakar .deb has sha256 " <> Text.unpack actual <> ", expected " <> Text.unpack rel.plakarDebSha256))+                _ <- run' "dpkg" ["-i", path]+                removeFile path+            , down = () <$ run' "dpkg" ["-r", "plakar"]+            }++{- | @plakar version@ prints @plakar/v1.1.7@ (after a one-off welcome text on+a first run, so the lines are searched).+-}+interpretVersion :: Text -> Text -> CheckResult+interpretVersion wanted out+    | ("plakar/v" <> wanted) `elem` Text.lines out = Success+    | otherwise = Failure ("plakar is not at " <> wanted)++sha256Hex :: ByteString.ByteString -> Text+sha256Hex = Text.pack . concatMap (printf "%02x") . ByteString.unpack . SHA256.hash++-------------------------------------------------------------------------------++-- | A local Kloset store and the keyfile holding its passphrase.+data KlosetStore = KlosetStore+    { storePath :: FilePath+    , storeKeyFile :: FilePath+    -- ^ provisioned by somebody else; salmon never writes it+    }+    deriving (Eq, Show)++{- | Creates the store if it is not there. Refuses (at @up@) a keyfile that is+missing, empty, or readable by anyone but its owner. The store exists when its+@CONFIG@ file does, which is also what @create@ is checked against, since it+can fail with exit @0@. @down@ deletes nothing.+-}+kloset :: Track' (Binary "plakar") -> KlosetStore -> Op+kloset plakar store =+    op "plakar-store" (deps [justInstall plakar]) $ \actions ->+        actions+            { help = "kloset store at " <> Text.pack store.storePath+            , notes =+                [ "passphrase from " <> Text.pack store.storeKeyFile <> ", never generated by salmon"+                , "down does not delete the store"+                ]+            , ref = mkRef "plakar-store" store.storePath+            , check = do+                exists <- doesFileExist (configFile store)+                pure (if exists then Success else Failure ("no store at " <> Text.pack store.storePath))+            , up = do+                problem <- keyfileStatus store.storeKeyFile+                maybe (pure ()) (\p -> ioError (userError ("keyfile " <> store.storeKeyFile <> ": " <> Text.unpack p))) problem+                _ <- run' "plakar" ["-keyfile", store.storeKeyFile, "at", store.storePath, "create"]+                created <- doesFileExist (configFile store)+                unless created $ ioError (userError ("plakar create left no store at " <> store.storePath))+            , down = pure ()+            }++configFile :: KlosetStore -> FilePath+configFile store = store.storePath <> "/CONFIG"++-- | What is wrong with a keyfile of this size and mode, if anything.+keyfileProblem :: Integer -> Posix.FileMode -> Maybe Text+keyfileProblem size mode+    | size == 0 = Just "is empty"+    | mode `Posix.intersectFileModes` 0o077 /= 0 = Just "is readable by group or others (want 0600)"+    | otherwise = Nothing++keyfileStatus :: FilePath -> IO (Maybe Text)+keyfileStatus path = do+    exists <- doesFileExist path+    if not exists+        then pure (Just "is missing")+        else do+            st <- Posix.getFileStatus path+            pure (keyfileProblem (fromIntegral (Posix.fileSize st)) (Posix.fileMode st))++-------------------------------------------------------------------------------++-- | What to keep. At least one rule must be set: 'pruneArgs' refuses an empty one.+data KeepPolicy = KeepPolicy+    { keepLastHours :: Maybe Int+    , keepLastDays :: Maybe Int+    , keepLastMonths :: Maybe Int+    }+    deriving (Eq, Show)++-- | Keep the last N days.+keepDays :: Int -> KeepPolicy+keepDays n = KeepPolicy Nothing (Just n) Nothing++-- | The @plakar prune@ filter arguments, or why there are none.+pruneArgs :: KeepPolicy -> Either Text [Text]+pruneArgs p+    | null rules = Left "no retention rule declared: prune deletes snapshots irreversibly, so a job without one is refused"+    | any ((<= 0) . snd) rules = Left "a retention rule must be positive"+    | otherwise = Right (concat [[flag, Text.pack (show n)] | (flag, n) <- rules])+  where+    rules :: [(Text, Int)]+    rules = catMaybes [fmap ((,) "-hours") p.keepLastHours, fmap ((,) "-days") p.keepLastDays, fmap ((,) "-months") p.keepLastMonths]++data PlakarJob = PlakarJob+    { jobName :: Text+    , jobStore :: KlosetStore+    , jobSource :: FilePath+    , jobSchedule :: Schedule+    , jobUser :: Text+    , jobKeep :: KeepPolicy+    , jobMaxAge :: NominalDiffTime+    -- ^ how old the newest snapshot may be before the job is not fresh+    , jobScriptPath :: FilePath+    }++{- | A cron entry running a script that backs up and then prunes, and a check+that answers what a hand-rolled cron line never does: is there a recent+snapshot? When there is not, @up@ runs the script once, which is the remedy.++The check reads the store as whoever runs salmon, so that user must be able+to read the keyfile as well as the job's user.+-}+plakarJob :: Track' (Binary "plakar") -> PlakarJob -> Op+plakarJob plakar job = case pruneArgs job.jobKeep of+    Left why ->+        op "plakar-job" nodeps $ \actions ->+            actions+                { help = "refused: " <> why+                , ref = mkRef "plakar-job" job.jobName+                , up = ioError (userError (Text.unpack why))+                }+    Right prune ->+        let script = renderBackupScript job prune+            scriptOp = filecontents (FileContents job.jobScriptPath script)+            cronOp = crontask ignoreTrack (CronTask job.jobName job.jobUser job.jobSchedule "/bin/bash" [Text.pack job.jobScriptPath])+         in op "plakar-job" (deps [kloset plakar job.jobStore, scriptOp, cronOp]) $ \actions ->+                actions+                    { help = "backs up " <> Text.pack job.jobSource <> " into " <> Text.pack job.jobStore.storePath+                    , notes = ["fresh means a snapshot newer than " <> Text.pack (show job.jobMaxAge), "up runs the backup once"]+                    , ref = mkRef "plakar-job" job.jobName+                    , check = do+                        now <- getCurrentTime+                        (code, out, err) <-+                            readCreateProcessWithExitCode (proc "plakar" ["-keyfile", job.jobStore.storeKeyFile, "at", job.jobStore.storePath, "ls", "-latest"]) ""+                        pure (interpretSnapshotList now job.jobMaxAge code (decode out) (decode err))+                    , up = do+                        (code, _, err) <- readCreateProcessWithExitCode (proc "/bin/bash" [job.jobScriptPath]) ""+                        case code of+                            ExitSuccess -> pure ()+                            ExitFailure n -> throwIO (Binary.CommandFailedSimple ("plakar backup job: " <> take 500 (Text.unpack (decode err))) n)+                    }++{- | The freshness verdict from @plakar ls -latest@.++A listing that printed no snapshot /and/ said something on stderr is+'Unknown': the exit code is @0@ even when plakar could not start its cache+process, and "the store is empty" is not what that means.+-}+interpretSnapshotList :: UTCTime -> NominalDiffTime -> ExitCode -> Text -> Text -> CheckResult+interpretSnapshotList _ _ (ExitFailure _) _ _ = Unknown+interpretSnapshotList now maxAge ExitSuccess out err =+    case asum (fmap stamp (Text.lines out)) of+        Just t+            | now `diffUTCTime` t <= maxAge -> Success+            | otherwise ->+                Failure ("newest snapshot is " <> hours (now `diffUTCTime` t) <> "h old, the limit is " <> hours maxAge <> "h")+        Nothing+            | Text.null (Text.strip err) && all (Text.null . Text.strip) (Text.lines out) -> Failure "the store has no snapshot"+            | otherwise -> Unknown+  where+    stamp :: Text -> Maybe UTCTime+    stamp line = case Text.words line of+        (w : _) -> iso8601ParseM (Text.unpack w)+        [] -> Nothing+    hours :: NominalDiffTime -> Text+    hours d = Text.pack (show (floor (realToFrac d / 3600 :: Double) :: Int))++{- | The script the cron entry runs. Backup output is captured and required to+say it completed without errors, because a plakar that could not start its+cache process exits @0@; the prune only runs after that, and only with the+declared policy.+-}+renderBackupScript :: PlakarJob -> [Text] -> Text+renderBackupScript job prune =+    Text.unlines+        [ "#!/bin/bash"+        , "# generated by salmon (plakar job " <> job.jobName <> "); do not edit"+        , "set -euo pipefail"+        , "out=$(plakar -keyfile " <> q key <> " at " <> q store <> " backup " <> q source <> " 2>&1) || { echo \"$out\" >&2; exit 1; }"+        , "echo \"$out\""+        , "echo \"$out\" | grep -q 'completed without errors' || { echo 'plakar backup did not report success' >&2; exit 1; }"+        , "plakar -keyfile " <> q key <> " at " <> q store <> " prune " <> Text.unwords prune <> " -apply"+        ]+  where+    key = Text.pack job.jobStore.storeKeyFile+    store = Text.pack job.jobStore.storePath+    source = Text.pack job.jobSource+    q t = "'" <> Text.replace "'" "'\\''" t <> "'"++-------------------------------------------------------------------------------++decode :: ByteString.ByteString -> Text+decode = Text.decodeUtf8With TextError.lenientDecode++-- | Runs a command, throwing on a non-zero exit; returns its stdout.+run' :: String -> [String] -> IO Text+run' cmd args = do+    (code, out, err) <- readCreateProcessWithExitCode (proc cmd args) ""+    case code of+        ExitSuccess -> pure (decode out)+        ExitFailure n -> throwIO (Binary.CommandFailedSimple (cmd <> ": " <> take 500 (Text.unpack (decode err))) n)
+ src/Salmon/Builtin/Nodes/Podman.hs view
@@ -0,0 +1,421 @@+module Salmon.Builtin.Nodes.Podman where++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), CommandIO (..), checkExitCode, withBinary, withBinaryIO)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import qualified Salmon.Builtin.Nodes.Filesystem as FS+import Salmon.Op.OpGraph (inject)+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Control.Monad (void, when)+import qualified Data.ByteString.Char8 as ByteString+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text++import GHC.IO.Exception (ExitCode (..))+import GHC.IO.Handle (Handle, hClose)+import System.Directory (doesFileExist, removeFile)+import System.FilePath (takeDirectory, takeFileName, (</>))+import System.Process (StdStream (CreatePipe), waitForProcess)+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess (..), proc)++-------------------------------------------------------------------------------+data Report+    = PullImage !Registry !Image !Binary.Report+    | BuildImage !FilePath !TagName !Binary.Report+    | PushImage !(Maybe AuthFile) !TagName !Binary.Report+    | LoginRegistry !AuthFile !Registry !Username+    | LogoutRegistry !AuthFile !Registry !Binary.Report+    | RunContainer !Registry !Image !ContainerName !RunOptions !Binary.Report+    | CreateNetwork !NetworkName !Binary.Report+    | RemoveImage !Registry !Image !Binary.Report+    | RemoveBuiltImage !TagName !Binary.Report+    | RemoveContainer !ContainerName !Binary.Report+    | RemoveNetwork !NetworkName !Binary.Report+    -- todo: prune volumes, import for bootstrap+    deriving (Show)++-------------------------------------------------------------------------------+newtype Registry = Registry {getRegistry :: Text}+    deriving (Eq, Ord, Show)++newtype Image = Image {getImage :: Text}+    deriving (Eq, Ord, Show)++type TagName = Text++{- | An explicit @--authfile@ path (podman's isolated credential store,+distinct from Docker's @~\/.docker\/config.json@ and podman's own default+@\$XDG_RUNTIME_DIR\/containers\/auth.json@).++The whole point of threading one of these through explicitly, rather than+letting 'login'\/'push'\/'pullImage' fall back to the ambient default: two+salmon processes on the same user authenticating to the __same__ registry+under __different__ credentials (e.g. two tenants each with their own+Artifact Registry push token) would otherwise clobber each other's login by+sharing one global credential file. Pointing each process at its own+'AuthFile' path makes that impossible by construction — there is no shared+mutable state left to race on.+-}+newtype AuthFile = AuthFile {getAuthFile :: FilePath}+    deriving (Eq, Ord, Show)++-- | The username 'login' authenticates as (e.g. @oauth2accesstoken@ for GCP+-- Artifact Registry, where the password is a short-lived access token).+newtype Username = Username {getUsername :: Text}+    deriving (Eq, Ord, Show)++-- | A container needs a stable, caller-chosen identity: podman assigns a+-- random name otherwise, which would leave 'down' with nothing to target.+newtype ContainerName = ContainerName {getContainerName :: Text}+    deriving (Eq, Ord, Show)++{- | A user-defined podman network — needed for containers to resolve each+other by name (podman's implicit default network doesn't reliably do this,+at least in rootless mode; a network created via @podman network create@+does, via embedded DNS).+-}+newtype NetworkName = NetworkName {getNetworkName :: Text}+    deriving (Eq, Ord, Show)++type PortSpec = Text++data PortProtocol+    = TCPPort+    | UDPPort+    deriving (Eq, Ord, Show)++data PortMapping+    = PortMapping+    { portOnHost :: PortSpec+    , portInGuest :: PortSpec+    , portProtocol :: PortProtocol+    }+    deriving (Eq, Ord, Show)++-- | A container environment variable, e.g. for a connstring or a secret path.+type EnvVar = (Text, Text)++data VolumeMode+    = ReadOnly+    | ReadWrite+    deriving (Eq, Ord, Show)++data VolumeMount+    = VolumeMount+    { volumeHostPath :: FilePath+    , volumeGuestPath :: FilePath+    , volumeMode :: VolumeMode+    }+    deriving (Eq, Ord, Show)++{- | Everything besides image/name needed to start a container: published+ports, env vars (config/secrets), bind-mounted volumes, and an optional+podman network to join. 'noRunOptions' is the empty starting point.+-}+data RunOptions+    = RunOptions+    { runPorts :: [PortMapping]+    , runEnv :: [EnvVar]+    , runVolumes :: [VolumeMount]+    , runNetwork :: Maybe Text+    }+    deriving (Eq, Ord, Show)++noRunOptions :: RunOptions+noRunOptions = RunOptions [] [] [] Nothing++-------------------------------------------------------------------------------+pullImage :: Reporter Report -> Track' (Binary "podman") -> Registry -> Image -> Op+pullImage r podman reg img =+    withBinary podman podmanCommand (Pull reg img) $ \pull ->+        op "podman-pull" (deps []) $ \actions ->+            actions+                { help = "pulls a podman image"+                , ref = mkRef "podman-pull" (getRegistry reg, getImage img)+                , up = pull r'+                , down = Binary.untrackedExec podmanCommand (Rmi reg img) "" r''+                }+  where+    r' = contramap (PullImage reg img) r+    r'' = contramap (RemoveImage reg img) r++buildImage :: Reporter Report -> Track' (Binary "podman") -> FS.File "containerfile" -> TagName -> Op+buildImage r podman containerfile tagname =+    FS.withFile containerfile $ \containerfilepath ->+        withBinary podman podmanCommand (Build containerfilepath tagname) $ \build ->+            op "podman-build" (deps []) $ \actions ->+                actions+                    { help = "builds a podman image in container path and tag it"+                    , ref = mkRef "podman-build" tagname+                    , up = build (r' containerfilepath)+                    , down = Binary.untrackedExec podmanCommand (RmiTag tagname) "" r''+                    }+  where+    r' containerfilepath = contramap (BuildImage containerfilepath tagname) r+    r'' = contramap (RemoveBuiltImage tagname) r++{- | Logs in to a registry, writing credentials to an explicit 'AuthFile'+rather than the ambient default (see 'AuthFile'’s own note on why that+isolation matters).++The password is read as @IO Text@ rather than a plain 'Text' so a+short-lived, freshly-fetched credential (a GCP access token, say) can be+obtained right when 'up' runs rather than baked into the graph when it was+built — and it is piped over stdin via @--password-stdin@, never passed as+a CLI argument, so it never shows up in @ps@ output or a process-start log+line.++There is deliberately no 'check': whether the credential already in+'AuthFile' is still valid is not answerable without hitting the registry+(and for a short-lived token, "still in the file" and "still valid" are+different questions anyway), so — like 'push' — this defaults to+'Salmon.Actions.UpDown.Immaterial' and simply re-authenticates on every+'up'. 'down' runs @podman logout --authfile@ against the same file (only if that+file actually holds credentials for this registry -- logging out of nothing+is an error, and a failing 'down' blocks a whole sub-DAG) and then removes+the file, which logout itself leaves behind, emptied.+-}+login :: Reporter Report -> Track' (Binary "podman") -> AuthFile -> Registry -> Username -> IO Text -> Op+login r podman authfile reg user getPassword =+    withBinaryIO podman logincommand (LoginCmd authfile reg user) $ \mkProc ->+        op "podman-login" (deps [enclosingdir]) $ \actions ->+            actions+                { help = Text.unwords ["logs in to", getRegistry reg, "via", Text.pack (getAuthFile authfile)]+                , ref = mkRef "podman-login" (getAuthFile authfile, getRegistry reg, getUsername user)+                , up = do+                    runReporter r (LoginRegistry authfile reg user)+                    pw <- getPassword+                    (mStdin, _, _, ph) <- mkProc ()+                    case mStdin of+                        Just hin -> Text.hPutStr hin pw >> hClose hin+                        Nothing -> pure ()+                    waitForProcess ph >>= checkExitCode "podman login"+                , down = do+                    -- `podman logout` is an error ("not logged into ...",+                    -- exit 125) when there is nothing to log out of, and a+                    -- failing `down` blocks the teardown of everything this+                    -- node was declared on top of. So ask first -- the+                    -- credentials live in this node's own authfile, which+                    -- makes that a file read.+                    exists <- doesFileExist (getAuthFile authfile)+                    when exists $ do+                        creds <- ByteString.readFile (getAuthFile authfile)+                        when (ByteString.pack (Text.unpack (getRegistry reg)) `ByteString.isInfixOf` creds) $+                            Binary.untrackedExec podmanCommand (Logout authfile reg) "" r''+                        -- logout only empties the credentials, leaving the+                        -- file ({"auths":{}}) behind to block the enclosing+                        -- Filesystem.dir's own `down`. This node caused the+                        -- file to exist, so this node removes it.+                        removeFile (getAuthFile authfile)+                }+  where+    r'' = contramap (LogoutRegistry authfile reg) r+    enclosingdir = FS.dir (FS.Directory (takeDirectory (getAuthFile authfile)))++{- | Pushes a locally-tagged image to whatever registry its tag names.++Deliberately takes only the one 'TagName' rather than a separate+local-tag\/remote-ref pair: the simplest way to make @podman build@,+@podman push@, and a downstream consumer (e.g.+"Salmon.Builtin.Nodes.Gcp.CloudRun"'s @crsImage@) agree on what image is+meant is to tag the build with the fully-qualified remote reference (e.g.+@us-docker.pkg.dev\/project\/repo\/image:tag@) in the first place — see+'buildImage' — rather than push introducing a second name for the same+thing. The optional 'AuthFile' should be the same one passed to 'login';+'Nothing' falls back to podman's ambient default, which is fine for a+public registry but defeats the isolation 'login'\/'AuthFile' exist for.++There is no 'check': whether a remote registry already has the bytes this+tag would push is not answerable any cheaper than pushing, so like+'buildImage' this defaults to 'Salmon.Actions.UpDown.Immaterial'. 'down' is+a no-op — @podman@ has no "unpush", and deleting a remote artifact is a+registry-side operation (e.g. `Gcp.ArtifactRegistry`), not a podman one.+-}+push :: Reporter Report -> Track' (Binary "podman") -> Maybe AuthFile -> TagName -> Op+push r podman mAuthFile tagname =+    withBinary podman podmanCommand (Push mAuthFile tagname) $ \doPush ->+        op "podman-push" (deps []) $ \actions ->+            actions+                { help = "pushes " <> tagname <> " to its registry"+                , ref = mkRef "podman-push" (tagname, fmap getAuthFile mAuthFile)+                , up = doPush r'+                }+  where+    r' = contramap (PushImage mAuthFile tagname) r++-- | Runs a detached container under a caller-chosen 'ContainerName' (so+-- 'down' has a stable target to remove), with the given ports/env/volumes/network.+runContainer :: Reporter Report -> Track' (Binary "podman") -> Registry -> Image -> ContainerName -> RunOptions -> Op+runContainer r podman reg img cname opts =+    withBinary podman podmanCommand (Run reg img cname opts) $ \run ->+        op "podman-run" (deps []) $ \actions ->+            actions+                { help = "runs a podman container"+                , ref = mkRef "podman-run" (getContainerName cname)+                , up = run r'+                , down = Binary.untrackedExec podmanCommand (Rm cname) "" r''+                }+  where+    r' = contramap (RunContainer reg img cname opts) r+    r'' = contramap (RemoveContainer cname) r++-- | Creates a user-defined podman network under a caller-chosen 'NetworkName'+-- (idempotent: skipped via 'check' if @podman network exists@ already says yes,+-- since @podman network create@ itself errors on a duplicate name).+network :: Reporter Report -> Track' (Binary "podman") -> NetworkName -> Op+network r podman name =+    withBinary podman podmanCommand (CreateNetworkCmd name) $ \create ->+        op "podman-network" (deps []) $ \actions ->+            actions+                { help = "creates a podman network"+                , ref = mkRef "podman-network" (getNetworkName name)+                , check = skipIfNetworkExists name+                , up = create r'+                , down = Binary.untrackedExec podmanCommand (RemoveNetworkCmd name) "" r''+                }+  where+    r' = contramap (CreateNetwork name) r+    r'' = contramap (RemoveNetwork name) r++skipIfNetworkExists :: NetworkName -> IO CheckResult+skipIfNetworkExists name = do+    (code, _, _) <- readCreateProcessWithExitCode (proc "podman" ["network", "exists", Text.unpack (getNetworkName name)]) ""+    pure $ case code of+        ExitSuccess -> Success+        _ -> Failure ("no such podman network: " <> getNetworkName name)++-------------------------------------------------------------------------------+data PodmanCommand+    = Pull !Registry !Image+    | Run !Registry !Image !ContainerName !RunOptions+    | Build !FilePath !TagName+    | Push !(Maybe AuthFile) !TagName+    | Logout !AuthFile !Registry+    | CreateNetworkCmd !NetworkName+    | Rmi !Registry !Image+    | RmiTag !TagName+    | Rm !ContainerName+    | RemoveNetworkCmd !NetworkName++podmanCommand :: Command "podman" PodmanCommand+podmanCommand = Command $ \cmd -> case cmd of+    (Pull r i) ->+        proc+            "podman"+            [ "pull"+            , (Text.unpack $ getRegistry r) </> (Text.unpack $ getImage i)+            ]+    (Build fullpath tagname) ->+        ( proc+            "podman"+            [ "build"+            , "-t"+            , Text.unpack tagname+            , "-f"+            , takeFileName fullpath+            ]+        )+            { cwd = Just $ takeDirectory fullpath+            }+    (Push mAuthFile tagname) ->+        proc "podman" $+            -- --authfile is a flag of `podman push`, not a global option:+            -- podman rejects it before the subcommand with "unknown flag".+            ["push"]+                <> maybe [] (\af -> ["--authfile", getAuthFile af]) mAuthFile+                <> [Text.unpack tagname]+    (Logout authfile reg) ->+        proc "podman" ["logout", "--authfile", getAuthFile authfile, Text.unpack (getRegistry reg)]+    (Run r i cname opts) ->+        proc "podman" $+            mconcat+                [+                    [ "run"+                    , "-dt"+                    , "--name"+                    , Text.unpack (getContainerName cname)+                    ]+                , concatMap portArgs opts.runPorts+                , concatMap envArgs opts.runEnv+                , concatMap volumeArgs opts.runVolumes+                , maybe [] (\net -> ["--network", Text.unpack net]) opts.runNetwork+                , [(Text.unpack $ getRegistry r) </> (Text.unpack $ getImage i)]+                ]+      where+        portArgs :: PortMapping -> [String]+        portArgs pm =+            let+                proto = case pm.portProtocol of+                    TCPPort -> "tcp"+                    UDPPort -> "udp"+             in+                ["-p", mconcat [Text.unpack pm.portOnHost, ":", Text.unpack pm.portInGuest, "/", proto]]+        envArgs :: EnvVar -> [String]+        envArgs (k, v) = ["--env", mconcat [Text.unpack k, "=", Text.unpack v]]+        volumeArgs :: VolumeMount -> [String]+        volumeArgs vol =+            let+                mode = case vol.volumeMode of+                    ReadOnly -> "ro"+                    ReadWrite -> "rw"+             in+                ["-v", mconcat [vol.volumeHostPath, ":", vol.volumeGuestPath, ":", mode]]+    (Rmi r i) ->+        proc+            "podman"+            [ "rmi"+            , (Text.unpack $ getRegistry r) </> (Text.unpack $ getImage i)+            ]+    (CreateNetworkCmd name) ->+        proc "podman" ["network", "create", Text.unpack (getNetworkName name)]+    (RmiTag tagname) ->+        -- --ignore: `podman rmi` on an absent image is an error ("image not+        -- known"), and this is a `down`, where a failure blocks the teardown+        -- of everything the node was declared on top of. An image that is+        -- already gone is this node's effect being gone.+        proc "podman" ["rmi", "--ignore", Text.unpack tagname]+    (Rm cname) ->+        proc "podman" ["rm", "-f", Text.unpack (getContainerName cname)]+    (RemoveNetworkCmd name) ->+        proc "podman" ["network", "rm", Text.unpack (getNetworkName name)]++-------------------------------------------------------------------------------++data LoginCommand+    = LoginCmd !AuthFile !Registry !Username++{- | @podman login@'s password has to arrive over stdin+(@--password-stdin@, never a CLI argument -- see 'login'), so this needs a+pipe created before the process starts and written to after, which the+plain 'Command' framework (a fixed 'CreateProcess' plus a fixed stdin+'System.Process.ByteString.ByteString' known up front) has no room for.+@CommandIO@'s @ioarg@ would normally carry caller-supplied handles (see+"Salmon.Builtin.Nodes.WireGuard"), but here there is nothing to redirect+*in* — only a pipe this command itself asks 'System.Process.createProcess'+to allocate — so 'logincommand' ignores its @()@ and 'login' reads the pipe+back out of the 'RunningCommand' tuple 'withBinaryIO' hands it.+-}+logincommand :: CommandIO "podman" LoginCommand ()+logincommand = CommandIO $ \(LoginCmd authfile reg user) () ->+    pure+        ( (proc "podman" ["login", "--authfile", getAuthFile authfile, "--username", Text.unpack (getUsername user), "--password-stdin", Text.unpack (getRegistry reg)])+            { std_in = CreatePipe+            }+        )++-------------------------------------------------------------------------------+-- some builtins++-------------------------------------------------------------------------------+dockerRegistry :: Registry+dockerRegistry = Registry "docker.io"++ubuntuLatest :: Image+ubuntuLatest = Image "ubuntu:latest"
+ src/Salmon/Builtin/Nodes/Postgres.hs view
@@ -0,0 +1,1536 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Salmon.Builtin.Nodes.Postgres where++import Data.Aeson (FromJSON, ToJSON)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import GHC.Generics+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Encoding.Error as TextError+import System.Exit (ExitCode (..))+import System.FilePath+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess (..), proc)++import Salmon.Actions.UpDown (CheckResult (..))++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), justInstall, untrackedExec, withBinary, withBinaryStdin)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem (File, withFile)+import qualified Salmon.Builtin.Nodes.Filesystem as FS+import Salmon.Op.OpGraph+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------+-- todo: collapse PsqlAdmin commands as a single constructor+data Report+    = PGStartLocalCluster !Binary.Report+    | PGCreateDatabase !Database !Binary.Report+    | PGCreateUser !User !Binary.Report+    | PGSetUserPass !User !Binary.Report+    | PGCreateGroup !Group !Binary.Report+    | PGGrant !AccessRight !Binary.Report+    | PGGroupMembership !Group !Role !Binary.Report+    | PGDatabaseOwnership !Database !Role !Binary.Report+    | PGScript !FilePath !Binary.Report+    | PGAdminScript !FilePath !Binary.Report+    | PGChmod !FilePath !Binary.Report+    | PGCreateReplicationUser !User !Binary.Report+    | PGClusterOp !PgCtl !Binary.Report+    | PGAlterSystem !Text !Text !Binary.Report+    | PGReloadConf !Binary.Report+    | PGReplicationSlot !Text !Binary.Report+    | PGTemplate !DatabaseName !Binary.Report+    | PGCloneDatabase !Clone !Binary.Report+    | PGDropClone !DatabaseName !Binary.Report+    | PGExtension !PgExtension !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------+type Host = Text+type Port = Int++-- | todo: distinguish server (to which we connect to) and cluster (with version)+data Server+    = Server+    { serverHost :: Host+    , serverPort :: Port+    }+    deriving (Eq, Ord, Show, Generic)++instance ToJSON Server+instance FromJSON Server++localServer :: Server+localServer = Server "127.0.0.1" 5432++type Version = Int++{- | Which Debian package's default postgres major version ends up installed+varies by release (e.g. 13 on bullseye, 15 on bookworm) and shifts over+time, so we can't bake a version number in here — instead the started+command detects, on the target machine at 'up' time, whichever cluster+"postgresql-common" actually created (via @pg_lsclusters@) and starts that+one. If several versions are installed, the highest one wins.+-}+pgLocalCluster :: Reporter Report -> Track' (Binary "postgres") -> Track' (Binary "pg_ctlcluster") -> Server -> Op+pgLocalCluster r pg pgctl server =+    withBinary pgctl pgctlRun (Start server.serverPort) $ \start ->+        op "pg-server" (deps [justInstall pg]) $ \actions ->+            actions+                { notes = ["default server"]+                , help = Text.unwords ["start pg cluster"]+                , up = start r'+                }+  where+    r' = contramap PGStartLocalCluster r++type ClusterName = Text++mainCluster :: ClusterName+mainCluster = "main"++data PgCtl+    = Start Port+    | CreateCluster !ClusterName !Port+    | StartCluster !ClusterName+    | StopCluster !ClusterName+    | RestartCluster !ClusterName+    | PromoteCluster !ClusterName+    | EnsureHbaLine !ClusterName !Text+    | CloneFromPrimary !StandbySetup+    deriving (Show)++pgctlRun :: Command "pg_ctlcluster" PgCtl+pgctlRun = Command go+  where+    go (Start _port) = proc "bash" ["-c", detectVersionAndStartMainCluster]+    go (CreateCluster name port) = proc "bash" ["-c", createClusterScript name port]+    go (StartCluster name) = proc "bash" ["-c", clusterCtlScript name "start"]+    go (StopCluster name) = proc "bash" ["-c", clusterCtlScript name "stop"]+    go (RestartCluster name) = proc "bash" ["-c", clusterCtlScript name "restart"]+    go (PromoteCluster name) = proc "bash" ["-c", clusterCtlScript name "promote"]+    go (EnsureHbaLine name line) = proc "bash" ["-c", ensureHbaLineScript name line]+    go (CloneFromPrimary setup) = proc "bash" ["-c", cloneFromPrimaryScript setup]++{- | @pg_lsclusters@'s header-less output is one line per cluster:+@Ver Cluster Port Status Owner DataDirectory LogFile@; sort numerically and+take the highest version so a freshly-provisioned box with a single cluster+just works, and a box with several installed versions picks the newest.+-}+detectVersionAndStartMainCluster :: String+detectVersionAndStartMainCluster =+    -- `pg_ctlcluster start` exits 2 on a cluster that is already running, so+    -- starting unconditionally failed every pass after the first (and every+    -- pass on a box where apt's own service had started it).+    "set -e; version=$(pg_lsclusters --no-header | awk '{print $1}' | sort -n | tail -n1); pg_ctlcluster \"$version\" main status >/dev/null || pg_ctlcluster \"$version\" main start"++-- | Shared preamble: detects the (single) installed major version, same way as 'detectVersionAndStartMainCluster'.+detectVersion :: String+detectVersion = "version=$(pg_lsclusters --no-header | awk '{print $1}' | sort -n | tail -n1)"++-- | Idempotent: only creates the named cluster if @pg_lsclusters@ doesn't already list it.+createClusterScript :: ClusterName -> Port -> String+createClusterScript name port =+    unlines+        [ "set -e"+        , detectVersion+        , "pg_lsclusters --no-header | awk '{print $2}' | grep -qx " <> shellQuote name <> " || pg_createcluster \"$version\" " <> Text.unpack name <> " -p " <> show port <> " -- --auth-local=peer --auth-host=md5"+        ]++clusterCtlScript :: ClusterName -> String -> String+clusterCtlScript name action =+    unlines+        [ "set -e"+        , detectVersion+        , "pg_ctlcluster \"$version\" " <> Text.unpack name <> " " <> action+        ]++-- | Appends a @pg_hba.conf@ line for the named cluster (skipping if already present) and reloads it.+ensureHbaLineScript :: ClusterName -> Text -> String+ensureHbaLineScript name line =+    unlines+        [ "set -e"+        , detectVersion+        , "hba=/etc/postgresql/$version/" <> Text.unpack name <> "/pg_hba.conf"+        , "grep -qxF " <> shellQuote line <> " \"$hba\" || echo " <> shellQuote line <> " >> \"$hba\""+        , "pg_ctlcluster \"$version\" " <> Text.unpack name <> " reload"+        ]++{- | Clones the named cluster's data directory from a running primary via+@pg_basebackup -R@ (which writes both @standby.signal@ and+@primary_conninfo@, so the cluster comes up in streaming-standby mode as+soon as it's started) and starts it.++= What decides whether to clone++The clone begins @rm -rf@ on a data directory, so what guards it is the+whole safety of this node. That guard is the __system identifier__: every+cluster gets one at @initdb@ time and a @pg_basebackup@ copy inherits its+primary's, so "this data directory holds a copy of that primary's cluster"+is a question with an exact answer. The primary's is read over the+replication protocol (@IDENTIFY_SYSTEM@), which is the one connection the+replication role is already authorized for in @pg_hba.conf@; the local one+comes from @pg_controldata@, no server needed.++* __Same identifier__: this directory is already a member of the primary's+  cluster. Leave it alone, and start it if it is down.+* __No cluster here at all__: clone.+* __A different identifier__: clone only if that cluster is /pristine/, i.e.+  holds no database beyond the ones @initdb@ makes, which is what a freshly+  @pg_createcluster@-d standby looks like. Otherwise refuse, loudly, and+  touch nothing.++The guard this replaces was @standby.signal@'s presence, which is deleted by+/promotion/: a promoted standby therefore looked exactly like a cluster that+had never been cloned, and the next @up@ with an unchanged directive would+@rm -rf@ the data directory of what is now the primary -- then fail to clone+from the old primary, which is typically the machine that just died. The+identifier survives promotion, which is the point of using it.++Pristineness is settled by looking at @base/@ for a directory whose name is+at or above @FirstNormalObjectId@ (16384), rather than by starting the+cluster and asking it: starting somebody else's cluster to find out whether+it is somebody else's is already the side effect worth avoiding.+-}+cloneFromPrimaryScript :: StandbySetup -> String+cloneFromPrimaryScript setup =+    unlines+        [ "set -e"+        , detectVersion+        , -- pg_controldata is a server program: postgresql-common puts a+          -- wrapper on PATH for the client ones only.+          "pg_controldata=/usr/lib/postgresql/$version/bin/pg_controldata"+        , "[ -x \"$pg_controldata\" ] || pg_controldata=pg_controldata"+        , "datadir=/var/lib/postgresql/$version/" <> cluster+        , -- the replication protocol's own identity command: available to a+          -- REPLICATION role over the `host replication` line the standby+          -- already needs, with no rights on any database.+          "primary_sysid=$(" <> pgpassword <> " psql -tAX -d " <> shellQuote replConninfo <> " -c 'IDENTIFY_SYSTEM' | head -n1 | cut -d'|' -f1)"+        , "if [ -z \"$primary_sysid\" ]; then echo 'cannot read the primary system identifier' >&2; exit 1; fi"+        , "local_sysid=''"+        , "if [ -e \"$datadir/global/pg_control\" ]; then"+        , "  local_sysid=$(\"$pg_controldata\" -D \"$datadir\" | sed -n 's/^Database system identifier: *//p')"+        , "fi"+        , "if [ \"$local_sysid\" = \"$primary_sysid\" ]; then"+        , "  " <> pgctl "status" <> " >/dev/null || " <> pgctl "start"+        , "  exit 0"+        , "fi"+        , "if [ -n \"$local_sysid\" ]; then"+        , "  others=$(ls \"$datadir/base\" 2>/dev/null | awk '$1 ~ /^[0-9]+$/ && $1+0 >= 16384' | wc -l)"+        , "  if [ \"$others\" != 0 ]; then"+        , "    echo \"refusing to clone over $datadir: it holds cluster $local_sysid with $others database(s), and the primary is $primary_sysid\" >&2"+        , "    exit 1"+        , "  fi"+        , "fi"+        , pgctl "stop" <> " || true"+        , "rm -rf \"$datadir\""+        , pgpassword+            <> " pg_basebackup -h "+            <> Text.unpack setup.standby_primary_host+            <> " -p "+            <> show setup.standby_primary_port+            <> " -U "+            <> Text.unpack setup.standby_repl_user.userRole+            <> " -D \"$datadir\" -Fp -Xs -R"+            <> slotArg+        , "chown -R postgres:postgres \"$datadir\""+        , pgctl "start"+        ]+  where+    cluster = Text.unpack setup.standby_cluster+    pgctl action = "pg_ctlcluster \"$version\" " <> cluster <> " " <> action+    -- PGPASSFILE, not PGPASSWORD: a path rather than the secret itself, and+    -- the same file `primary_conninfo` names once this is streaming.+    pgpassword = "PGPASSFILE=" <> shellQuote (Text.pack setup.standby_repl_passfile)+    replConninfo =+        Text.unwords+            [ "host=" <> setup.standby_primary_host+            , "port=" <> Text.pack (show setup.standby_primary_port)+            , "user=" <> setup.standby_repl_user.userRole+            , "dbname=postgres"+            , -- @true@, not @database@: a "database" replication connection+              -- is the logical one, and @pg_hba.conf@ matches it against the+              -- database name, so it is refused by the @host replication@+              -- line this role has. @true@ is the physical connection that+              -- line is for -- the same kind @pg_basebackup@ makes below.+              "replication=true"+            ]+    -- the slot (if any) is expected to already exist on the primary, created+    -- independently via 'replicationSlot'/'primaryReplicationSetup'+    slotArg = maybe "" (\slot -> " -S " <> Text.unpack slot) setup.standby_slot++shellQuote :: Text -> String+shellQuote t = "'" <> Text.unpack (Text.replace "'" "'\\''" t) <> "'"++type DatabaseName = Text++newtype Database = Database {getDatabase :: DatabaseName}+    deriving (Show, ToJSON, FromJSON)++database :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> Database -> Op+database r server psql port db =+    withBinary psql (psqlAdminRun_Sudo port) (CreateDB db.getDatabase) $ \up ->+        op "pg-database" (deps [run server localServer]) $ \actions ->+            actions+                { -- keyed by port as well as name, for the reason given at+                  -- 'alterSystemSet': two clusters on one box each hold their+                  -- own "appdb". 'cloneDatabase' uses the same key on+                  -- purpose, since a clone is a database at the same site.+                  ref = mkRef "pg-db" (port, db.getDatabase)+                , up = up r'+                , help = Text.unwords ["create db", db.getDatabase]+                }+  where+    r' = contramap (PGCreateDatabase db) r++type RoleName = Text++newtype Password = Password {revealPassword :: Text}++readPassword :: FilePath -> IO Password+readPassword path = Password <$> Text.readFile path++instance Show Password where+    show _ = "<password>"++newtype User = User {userRole :: RoleName}+    deriving (Show, ToJSON, FromJSON)++user :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> User -> Password -> Op+user r server psql port user pwd =+    withBinary psql (psqlAdminRun_Sudo port) (CreateUser user.userRole pwd) $ \up ->+        op "pg-user" (deps [run server localServer]) $ \actions ->+            actions+                { ref = mkRef "pg-user" user.userRole+                , help = Text.unwords ["create user", user.userRole]+                , up = up r'+                }+  where+    r' = contramap (PGCreateUser user) r++userPassFile :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> File "passfile" -> User -> Op+userPassFile r server psql port genpass user =+    withFile genpass $ \passfile ->+        op "pg-user" (deps [runningServer, justInstall psql]) $ \actions ->+            actions+                { ref = mkRef "pg-user" user.userRole+                , help = Text.unwords ["set user password for", user.userRole, "from file at", Text.pack passfile]+                , up = do+                    up =<< fmap Password (Text.readFile passfile)+                }+  where+    r' = contramap (PGSetUserPass user) r+    runningServer = run server localServer+    up pass = untrackedExec (psqlAdminRun_Sudo port) (CreateUser user.userRole pass) "" r'++data Group = Group {groupRole :: RoleName}+    deriving (Show, Generic)+instance ToJSON Group+instance FromJSON Group++group :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> Group -> Op+group r server psql port group =+    withBinary psql (psqlAdminRun_Sudo port) (CreateGroup group.groupRole) $ \up ->+        op "pg-group" (deps [run server localServer]) $ \actions ->+            actions+                { ref = mkRef "pg-group" group.groupRole+                , up = up r'+                , help = Text.unwords ["creates group", group.groupRole]+                }+  where+    r' = contramap (PGCreateGroup group) r++data Role+    = UserRole User+    | GroupRole Group+    deriving (Show, Generic)+instance ToJSON Role+instance FromJSON Role++roleName :: Role -> RoleName+roleName (UserRole u) = u.userRole+roleName (GroupRole g) = g.groupRole++data PGRight+    = CREATE+    | CONNECT+    deriving (Show, Generic)+instance ToJSON PGRight+instance FromJSON PGRight++data AccessRight+    = AccessRight+    { access_database :: Database+    , access_role :: Role+    , access_rights :: [PGRight]+    }+    deriving (Show, Generic)+instance ToJSON AccessRight+instance FromJSON AccessRight++grant :: Reporter Report -> Track' (Binary "psql") -> Port -> Track' Role -> AccessRight -> Op+grant r psql port role acl =+    withBinary psql (psqlAdminRun_Sudo port) (Grant acl) $ \up ->+        op "pg-grant" (deps [dbrole]) $ \actions ->+            actions+                { ref = mkRef "pg-grant" (roleName acl.access_role)+                , up = if null acl.access_rights then pure () else up r'+                , help = Text.unwords ["grant", roleName acl.access_role]+                }+  where+    r' = contramap (PGGrant acl) r+    dbrole = run role acl.access_role++databaseOnwership ::+    Reporter Report ->+    Track' Server ->+    Track' (Binary "psql") ->+    Port ->+    Track' Database ->+    Database ->+    Track' Role ->+    Role ->+    Op+databaseOnwership r server psql port mkdb db role u =+    withBinary psql (psqlAdminRun_Sudo port) (DatabaseOwnership db.getDatabase (roleName u)) $ \up ->+        op "pg-member" (deps [run mkdb db, dbuser]) $ \actions ->+            actions+                { ref = mkRef "pg-ownership" (db.getDatabase, roleName u)+                , up = up r'+                , help = Text.unwords ["grant", db.getDatabase, "ownership to", roleName u]+                }+  where+    r' = contramap (PGDatabaseOwnership db u) r+    dbuser = run role u++groupMember :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> Group -> Track' Role -> Role -> Op+groupMember r server psql port g role u =+    withBinary psql (psqlAdminRun_Sudo port) (GroupMembership g.groupRole (roleName u)) $ \up ->+        op "pg-member" (deps [dbgroup, dbuser]) $ \actions ->+            actions+                { ref = mkRef "pg-member" (g.groupRole, roleName u)+                , up = up r'+                , help = Text.unwords ["add", roleName u, "to", g.groupRole]+                }+  where+    r' = contramap (PGGroupMembership g u) r+    dbgroup = group r server psql port g+    dbuser = run role u++adminScript ::+    Reporter Report ->+    Track' (Binary "psql") ->+    Port ->+    Track' DatabaseName ->+    DatabaseName ->+    File "psql-script" ->+    Op+adminScript r psql port mkdb dbname file =+    withFile file $ \path ->+        let accessiblePath = adminDir </> path+         in withBinary psql (psqlAdminRun_Sudo port) (ChmodAdminScript accessiblePath) $ \chmod ->+                withBinary psql (psqlAdminRun_Sudo port) (AdminScript dbname accessiblePath) $ \up ->+                    op "pg-admin-script" (deps [run mkdb dbname, FS.fileCopy path accessiblePath `inject` enclosingdir]) $ \actions ->+                        actions+                            { ref = mkRef "pg-admin-script" path+                            , up = chmod (r1 accessiblePath) >> up (r2 accessiblePath)+                            , help = Text.unwords ["runs pg script", Text.pack path]+                            }+  where+    adminDir :: FilePath+    adminDir = "/opt/salmon/postgres/migrations/admin"+    enclosingdir :: Op+    enclosingdir = FS.dir (FS.Directory adminDir)++    r1 path = contramap (PGChmod path) r+    r2 path = contramap (PGAdminScript path) r++{- | commands to bootstrap PG roles and dbs as admin+expected to run as user "postgres" in Debian to handle the nopassword initial state+-}+data PsqlAdmin+    = CreateDB DatabaseName+    | CreateUser RoleName Password+    | CreateReplicationUser RoleName Password+    | CreateGroup RoleName+    | Grant AccessRight+    | GroupMembership RoleName RoleName+    | AdminScript DatabaseName FilePath+    | DatabaseOwnership DatabaseName RoleName+    | ChmodAdminScript FilePath+    | AlterSystemSet Text Text+    | ReloadConf+    | EnsurePhysicalReplicationSlot Text++{- | Every case connects to the locally-running cluster on 'port' explicitly+(via @-p@) rather than relying on @psql@'s default (which only ever reaches+whichever cluster happens to be on the default port, i.e. "main" — see+'Postgres.CreateDB' below and the "Conventions for node authors" note in+CLAUDE.md for why this matters once more than one named cluster exists on a+box).++todo: workaround chmod and sudo hack with some calling preference+- we'll need to request more than a Track' (Binary "psql") but some more complex logic+with sudo, the user, and the right binary+-}+psqlAdminRun_Sudo :: Port -> Command "psql" PsqlAdmin+psqlAdminRun_Sudo port = Command go+  where+    portArgs :: [String]+    portArgs = ["-p", show port]++    go (ChmodAdminScript path) =+        proc "chmod" ["a+r", path]+    go (AdminScript name path) =+        proc "sudo" (["-u", "postgres", "psql"] <> portArgs <> ["-f", path, Text.unpack name])+    -- CREATE DATABASE can't run inside a transaction/DO block (a hard Postgres+    -- restriction), so unlike the role-creation commands below, idempotency+    -- has to be a shell-level check-then-create rather than a SQL one.+    go (CreateDB name) =+        proc+            "sudo"+            [ "-u"+            , "postgres"+            , "bash"+            , "-c"+            , mconcat+                [ "psql -p "+                , show port+                , " -tAc \"SELECT 1 FROM pg_database WHERE datname = '"+                , Text.unpack name+                , "'\" | grep -q 1 || psql -p "+                , show port+                , " -c 'CREATE DATABASE "+                , Text.unpack name+                , "'"+                ]+            ]+    -- CREATE ROLE has no IF NOT EXISTS form, but (unlike CREATE DATABASE) it's+    -- fine inside a DO block, so we guard it with an explicit existence check.+    -- The password is set unconditionally afterward, the same way+    -- CreateReplicationUser does below: guarding the ALTER behind the IF NOT+    -- EXISTS, as this used to, means a rotated password never reaches the+    -- cluster and the failure arrives later as "password authentication+    -- failed" somewhere that looks unrelated.+    go (CreateUser name pass) =+        proc+            "sudo"+            ( ["-u", "postgres", "psql"]+                <> portArgs+                <> [ "-c"+                   , mconcat+                        [ "DO $$ BEGIN IF NOT EXISTS (SELECT FROM pg_roles WHERE rolname = '"+                        , Text.unpack name+                        , "') THEN CREATE ROLE "+                        , Text.unpack name+                        , " WITH LOGIN; END IF; END $$; ALTER ROLE "+                        , Text.unpack name+                        , " WITH LOGIN PASSWORD "+                        , quotePass pass+                        , ";"+                        ]+                   ]+            )+    go (CreateReplicationUser name pass) =+        proc+            "sudo"+            ( ["-u", "postgres", "psql"]+                <> portArgs+                <> [ "-c"+                   , mconcat+                        -- created if missing, and its password set either+                        -- way: the password is part of what this node+                        -- declares, so a role that exists with some other+                        -- one has drifted from the declaration rather than+                        -- been left alone deliberately. Guarding the ALTER+                        -- behind the IF NOT EXISTS, as this used to, means a+                        -- rotated password never reaches the cluster and the+                        -- failure arrives later as "password authentication+                        -- failed" somewhere that looks unrelated.+                        [ "DO $$ BEGIN IF NOT EXISTS (SELECT FROM pg_roles WHERE rolname = '"+                        , Text.unpack name+                        , "') THEN CREATE ROLE "+                        , Text.unpack name+                        , " WITH REPLICATION LOGIN; END IF; END $$; ALTER ROLE "+                        , Text.unpack name+                        , " WITH REPLICATION LOGIN PASSWORD "+                        , quotePass pass+                        , ";"+                        ]+                   ]+            )+    go (AlterSystemSet param val) =+        proc+            "sudo"+            ( ["-u", "postgres", "psql"]+                <> portArgs+                <> ["-c", unwords ["ALTER SYSTEM SET", Text.unpack param, "=", "'" <> Text.unpack val <> "'"]]+            )+    go ReloadConf =+        proc "sudo" (["-u", "postgres", "psql"] <> portArgs <> ["-c", "SELECT pg_reload_conf();"])+    go (EnsurePhysicalReplicationSlot slot) =+        proc+            "sudo"+            ( ["-u", "postgres", "psql"]+                <> portArgs+                <> [ "-c"+                   , mconcat+                        [ "DO $$ BEGIN IF NOT EXISTS (SELECT 1 FROM pg_replication_slots WHERE slot_name = '"+                        , Text.unpack slot+                        , "') THEN PERFORM pg_create_physical_replication_slot('"+                        , Text.unpack slot+                        , "'); END IF; END $$;"+                        ]+                   ]+            )+    go (CreateGroup name) =+        proc+            "sudo"+            ( ["-u", "postgres", "psql"]+                <> portArgs+                <> [ "-c"+                   , mconcat+                        [ "DO $$ BEGIN IF NOT EXISTS (SELECT FROM pg_roles WHERE rolname = '"+                        , Text.unpack name+                        , "') THEN CREATE ROLE "+                        , Text.unpack name+                        , "; END IF; END $$;"+                        ]+                   ]+            )+    go (GroupMembership g u) =+        proc+            "sudo"+            ( ["-u", "postgres", "psql"]+                <> portArgs+                <> [ "-c"+                   , unwords+                        [ "ALTER GROUP"+                        , Text.unpack g+                        , "ADD USER"+                        , Text.unpack u+                        ]+                   ]+            )+    go (DatabaseOwnership d u) =+        proc+            "sudo"+            ( ["-u", "postgres", "psql"]+                <> portArgs+                <> [ "-c"+                   , unwords+                        [ "ALTER DATABASE"+                        , Text.unpack d+                        , "OWNER TO"+                        , Text.unpack u+                        ]+                   ]+            )+    go (Grant acl) =+        proc+            "sudo"+            ( ["-u", "postgres", "psql"]+                <> portArgs+                <> [ "-c"+                   , unwords+                        [ "GRANT"+                        , Text.unpack $ commaList $ fmap renderRight acl.access_rights+                        , "ON DATABASE"+                        , Text.unpack acl.access_database.getDatabase+                        , "TO"+                        , Text.unpack (roleName acl.access_role)+                        ]+                   ]+            )++    quotePass :: Password -> String+    quotePass pwd = "'" <> Text.unpack pwd.revealPassword <> "'"++    renderRight :: PGRight -> Text+    renderRight CREATE = "CREATE"+    renderRight CONNECT = "CONNECT"++    commaList :: [Text] -> Text+    commaList = Text.intercalate ","++-------------------------------------------------------------------------------++data ConnString pass = ConnString+    { connstring_server :: Server+    , connstring_user :: User+    , connstring_user_pass :: pass+    , connstring_db :: Database+    }+    deriving (Generic, Functor)+instance (ToJSON a) => ToJSON (ConnString a)+instance (FromJSON a) => FromJSON (ConnString a)++type UnknownPassword = ()++connstring :: ConnString Password -> Text+connstring (ConnString server user pass db) =+    mconcat+        [ "postgresql://"+        , user.userRole+        , ":"+        , pass.revealPassword+        , "@"+        , server.serverHost+        , ":"+        , Text.pack $ show server.serverPort+        , "/"+        , db.getDatabase+        ]++withPassword :: ConnString a -> Password -> ConnString Password+withPassword c pass = const pass <$> c++userScriptInMemoryPass ::+    Reporter Report ->+    Track' (Binary "psql") ->+    Track' (ConnString Password) ->+    ConnString Password ->+    File "psql-script" ->+    Op+userScriptInMemoryPass r psql mksetup c@(ConnString server user pass db) file =+    withFile file $ \path ->+        withBinary psql (psqlUserRun c) (UserScript path) $ \up ->+            op "pg-script" (deps [run mksetup c]) $ \actions ->+                actions+                    { ref = mkRef "pg-script" path+                    , up = up (r' path)+                    , help = Text.unwords ["runs pg script", Text.pack path]+                    }+  where+    r' path = contramap (PGScript path) r++userScript ::+    Reporter Report ->+    Track' (Binary "psql") ->+    Track' (ConnString FilePath) ->+    ConnString FilePath ->+    File "psql-script" ->+    Op+userScript r psql mksetup c@(ConnString server user passFile db) file =+    withFile file $ \path ->+        op "pg-script" (deps [run mksetup c, justInstall psql]) $ \actions ->+            actions+                { ref = mkRef "pg-script" path+                , up = do+                    up path =<< fmap Password (Text.readFile passFile)+                , help = Text.unwords ["runs pg script", Text.pack path]+                }+  where+    r' path = contramap (PGScript path) r+    up path pass = untrackedExec (psqlUserRun $ c `withPassword` pass) (UserScript path) "" (r' path)++data PsqlUser+    = UserScript FilePath++psqlUserRun :: ConnString Password -> Command "psql" PsqlUser+psqlUserRun c = Command go+  where+    go (UserScript path) =+        proc+            "psql"+            [ Text.unpack $ connstring c+            , "-f"+            , path+            ]++-------------------------------------------------------------------------------+-- Cluster lifecycle (named, non-"main" clusters)++-- | @pg_createcluster@s a new, empty cluster under Debian's cluster management+-- (idempotent: a no-op if a cluster by that name already exists).+createCluster :: Reporter Report -> Track' (Binary "postgres") -> Track' (Binary "pg_ctlcluster") -> ClusterName -> Port -> Op+createCluster r pg pgctl name port =+    withBinary pgctl pgctlRun cmd $ \run ->+        op "pg-create-cluster" (deps [justInstall pg]) $ \actions ->+            actions+                { ref = mkRef "pg-create-cluster" name+                , help = Text.unwords ["creates pg cluster", name, "on port", Text.pack (show port)]+                , up = run r'+                }+  where+    cmd = CreateCluster name port+    r' = contramap (PGClusterOp cmd) r++clusterCtl :: Reporter Report -> Track' (Binary "pg_ctlcluster") -> ClusterName -> PgCtl -> Text -> IO CheckResult -> Op+clusterCtl r pgctl name cmd label chk =+    withBinary pgctl pgctlRun cmd $ \run ->+        op "pg-cluster-ctl" nodeps $ \actions ->+            actions+                { ref = mkRef "pg-cluster-ctl" (name, label)+                , help = Text.unwords [label, "pg cluster", name]+                , check = chk+                , up = run r'+                }+  where+    r' = contramap (PGClusterOp cmd) r++startCluster, stopCluster, restartCluster, promoteCluster :: Reporter Report -> Track' (Binary "pg_ctlcluster") -> ClusterName -> Op+-- | @pg_ctlcluster start@ exits 2 on a cluster that is already running, so this asks first.+startCluster r pgctl name = clusterCtl r pgctl name (StartCluster name) "start" (checkClusterIs Online name)+-- | The mirror image: @stop@ exits 2 on a cluster that is already down.+stopCluster r pgctl name = clusterCtl r pgctl name (StopCluster name) "stop" (checkClusterIs Down name)++{- | Restarts unconditionally, on every pass.++There is no check to write here: a restart's effect is not a state the+cluster can be found in afterwards. 'restartClusterIfPending' is the form+with a reason to stop, and is what 'primaryReplicationSetup' uses.+-}+restartCluster r pgctl name = clusterCtl r pgctl name (RestartCluster name) "restart" (pure Immaterial)++{- | Promotes unconditionally.++Deliberately left without a check: "this cluster is not in recovery" is a+fact about a /pair/ of machines, and answering it from one of them is how a+promotion happens twice. The node that will own that question is the+switchover node in @specs\/pg-switchover.md@.+-}+promoteCluster r pgctl name = clusterCtl r pgctl name (PromoteCluster name) "promote" (pure Immaterial)++{- | Restarts the cluster if any setting is waiting for one.++The check is @pg_settings.pending_restart@, which is Postgres's own record+of "you changed something that only a restart applies" -- the same shape of+answer as systemd's @NeedDaemonReload@, and for the same reason: the change+is already on disk, so nothing on disk can still testify that the running+server is stale.++An unreachable cluster answers 'Unknown', which the one-shot drivers treat+as "go ahead": @pg_ctlcluster restart@ on a stopped cluster starts it.+-}+restartClusterIfPending :: Reporter Report -> Track' (Binary "pg_ctlcluster") -> Port -> ClusterName -> Op+restartClusterIfPending r pgctl port name =+    clusterCtl r pgctl name (RestartCluster name) "restart" (checkNoPendingRestart port)++-- | The two states @pg_lsclusters@ reports that this module has an opinion about.+data ClusterState = Online | Down+    deriving (Eq, Show)++-- | Is the named cluster in this state?+checkClusterIs :: ClusterState -> ClusterName -> IO CheckResult+checkClusterIs wanted name =+    either (const Unknown) (interpretClusterStatus wanted name) <$> clusterStatusOutput++{- | @pg_lsclusters --no-header@ is one line per cluster, @Ver Cluster Port+Status Owner DataDirectory LogFile@, and the status column is the one word+this reads. A cluster absent from the listing does not exist, which is not+the same as being down, and is a 'Failure' either way: it is not in the+state the caller asked for, and the reasons read differently to an operator.++Statuses other than @online@ and @down@ exist, and none of them is a state+to stop at: a cluster @online,recovery@ is still coming up, and+@online,recovery@ read as "already started" would let a dependant run+against a server still replaying WAL.+-}+interpretClusterStatus :: ClusterState -> ClusterName -> Text -> CheckResult+interpretClusterStatus wanted name out =+    case [fields | line <- Text.lines out, fields <- [Text.words line], take 1 (drop 1 fields) == [name]] of+        [] -> Failure ("no cluster named " <> name)+        (fields : _) -> case drop 3 fields of+            (status : _) -> verdict status+            [] -> Unknown+  where+    verdict status+        | status == expected = Success+        | status `elem` ["online", "down"] = Failure (name <> " is " <> status)+        | otherwise = Failure (name <> " is " <> status <> ", neither online nor down")+    expected = case wanted of+        Online -> "online"+        Down -> "down"++clusterStatusOutput :: IO (Either Text Text)+clusterStatusOutput = do+    (code, out, err) <- readCreateProcessWithExitCode (proc "pg_lsclusters" ["--no-header"]) ""+    pure $ case code of+        ExitSuccess -> Right (Text.decodeUtf8With TextError.lenientDecode out)+        ExitFailure _ -> Left (Text.decodeUtf8With TextError.lenientDecode err)++-- | Is any setting on this cluster waiting for a restart?+checkNoPendingRestart :: Port -> IO CheckResult+checkNoPendingRestart port =+    either (const Unknown) interpretPendingRestart+        <$> psqlQuery_Sudo port "SELECT coalesce(string_agg(name, ','), '') FROM pg_settings WHERE pending_restart"++-- | The verdict 'checkNoPendingRestart' draws, split out so it is testable without a cluster.+interpretPendingRestart :: Text -> CheckResult+interpretPendingRestart out =+    case Text.strip out of+        "" -> Success+        names -> Failure ("settings waiting for a restart: " <> names)++-------------------------------------------------------------------------------+-- Physical (WAL streaming) replication++{- | Settings a primary needs to accept streaming replicas. Debian's default+@postgresql.conf@ already ships @wal_level = replica@ on modern versions,+but we set it explicitly since a misconfigured value there is a silent+failure mode (replication just won't start).+-}+data ReplicationTuning+    = ReplicationTuning+    { repl_max_wal_senders :: Int+    , repl_max_replication_slots :: Int+    , repl_wal_log_hints :: Bool+    -- ^ whether @pg_rewind@ can ever be used on this cluster. See 'defaultReplicationTuning'.+    , repl_max_slot_wal_keep_size :: Maybe Text+    -- ^ a cap on the WAL a lagging standby's slot may pin, @Nothing@ for none.+    }+    deriving (Show)++{- | Ten senders and ten slots, hint logging on, and ten gigabytes of WAL a+slot may pin.++The last two are opinions, and both are about what happens on a bad day.++@wal_log_hints@ is what makes @pg_rewind@ possible, and it can only be+turned on by a /restart/: a cluster that did not have it when its primary+died cannot rewind the old primary onto the new one's history, so the only+way to put that machine back is to copy the whole cluster over the network+again. Deciding this after the fact is deciding it too late, and the cost+while nothing is wrong is some extra WAL.++@max_slot_wal_keep_size@ bounds that WAL. A replication slot with no cap+keeps every segment its standby has not consumed, for as long as the standby+is away -- so a standby that stays down long enough fills the primary's disk+and takes the __primary__ down with it. Past the cap, the slot is+invalidated instead and that standby has to be re-seeded, which is the+better of the two bad outcomes: one machine to rebuild rather than two.+-}+defaultReplicationTuning :: ReplicationTuning+defaultReplicationTuning = ReplicationTuning 10 10 True (Just "10GB")++{- | The @ALTER SYSTEM@ settings a primary needs, as (parameter, value)+pairs. Split out of 'primaryReplicationSetup' so a test can read them+without building a graph.++@wal_level@ is set explicitly although Debian's @postgresql.conf@ already+ships @replica@: a wrong value there fails silently, in the sense that+replication simply never starts.+-}+replicationSettings :: ReplicationTuning -> [(Text, Text)]+replicationSettings tuning =+    [ ("wal_level", "replica")+    , ("max_wal_senders", tshow tuning.repl_max_wal_senders)+    , ("max_replication_slots", tshow tuning.repl_max_replication_slots)+    , ("listen_addresses", "*")+    , ("wal_log_hints", if tuning.repl_wal_log_hints then "on" else "off")+    ]+        <> foldMap (\cap -> [("max_slot_wal_keep_size", cap)]) tuning.repl_max_slot_wal_keep_size+  where+    tshow = Text.pack . show++-- | A host or CIDR allowed to authenticate as the replication role, e.g. the standby's address.+type AllowedCidr = Text++type ReplicationSlotName = Text++-- | Everything needed to clone an empty (or freshly created) cluster off a running primary and start it as a streaming standby.+data StandbySetup+    = StandbySetup+    { standby_cluster :: ClusterName+    , standby_primary_host :: Host+    , standby_primary_port :: Port+    , standby_repl_user :: User+    , standby_repl_passfile :: FilePath+    -- ^ a @.pgpass@ file on the standby holding the replication role's+    -- password. A path, not the password: this setup is rendered into a+    -- shell script, and a script is visible in @ps@ and printed verbatim by+    -- every 'Binary.Report' along the way. Pre-provisioned by the caller,+    -- readable only by whoever runs this node.+    --+    -- @.pgpass@ format rather than a bare password, because+    -- @primary_conninfo@'s @passfile=@ can read nothing else -- so one file+    -- serves both the clone and the streaming that follows it, and a pair+    -- has one secret per role rather than two spellings of it.+    , standby_slot :: Maybe ReplicationSlotName+    }+    deriving (Show)++-- | A login role carrying the @REPLICATION@ attribute, for a standby's @pg_basebackup@\/streaming connection.+replicationUser :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> User -> Password -> Op+replicationUser r server psql port u pwd =+    withBinary psql (psqlAdminRun_Sudo port) (CreateReplicationUser u.userRole pwd) $ \up ->+        op "pg-replication-user" (deps [run server localServer]) $ \actions ->+            actions+                { ref = mkRef "pg-replication-user" u.userRole+                , help = Text.unwords ["create replication user", u.userRole]+                , up = up r'+                }+  where+    r' = contramap (PGCreateReplicationUser u) r++alterSystemSet :: Reporter Report -> Track' (Binary "psql") -> Port -> Text -> Text -> Op+alterSystemSet r psql port param val =+    withBinary psql (psqlAdminRun_Sudo port) (AlterSystemSet param val) $ \up ->+        op "pg-alter-system" nodeps $ \actions ->+            actions+                { -- keyed by port as well as parameter: a box running two+                  -- clusters has two genuinely different settings of the same+                  -- name, and keying on the name alone deduped them into one+                  -- node, silently dropping whichever was declared second.+                  ref = mkRef "pg-alter-system" (port, param)+                , help = Text.unwords ["ALTER SYSTEM SET", param, "=", val]+                , up = up r'+                }+  where+    r' = contramap (PGAlterSystem param val) r++reloadConf :: Reporter Report -> Track' (Binary "psql") -> Port -> Op+reloadConf r psql port =+    withBinary psql (psqlAdminRun_Sudo port) ReloadConf $ \up ->+        op "pg-reload-conf" nodeps $ \actions ->+            actions+                { -- same reasoning as 'alterSystemSet': one reload per+                  -- cluster, not one reload for the whole machine.+                  ref = mkRef "pg-reload-conf" port+                , up = up r'+                }+  where+    r' = contramap PGReloadConf r++-- | Ensures a physical replication slot exists on the primary (idempotent: skips if already present).+replicationSlot :: Reporter Report -> Track' (Binary "psql") -> Port -> ReplicationSlotName -> Op+replicationSlot r psql port slot =+    withBinary psql (psqlAdminRun_Sudo port) (EnsurePhysicalReplicationSlot slot) $ \up ->+        op "pg-replication-slot" nodeps $ \actions ->+            actions+                { ref = mkRef "pg-replication-slot" slot+                , help = Text.unwords ["ensure replication slot", slot]+                , up = up r'+                }+  where+    r' = contramap (PGReplicationSlot slot) r++{- | Ensures an arbitrary line is present in a cluster's @pg_hba.conf@, then+reloads it.++'allowReplicationFrom' and 'allowClientCertFrom' are the two lines this repo+has an opinion about; this is the escape hatch for the rest of+@pg_hba.conf@'s vocabulary, which is large and changes between major+versions. The line is matched verbatim (@grep -qxF@), so a line differing+only in whitespace is a /second/ line rather than an update of the first --+which is also why a caller changing its mind leaves the old line behind.+-}+hbaLine :: Reporter Report -> Track' (Binary "pg_ctlcluster") -> ClusterName -> Text -> Op+hbaLine r pgctl name line =+    withBinary pgctl pgctlRun cmd $ \run ->+        op "pg-hba-line" nodeps $ \actions ->+            actions+                { ref = mkRef "pg-hba-line" (name, line)+                , help = Text.unwords ["ensure pg_hba line on", name <> ":", line]+                , notes = ["appended verbatim; changing it leaves the previous line in place"]+                , up = run r'+                }+  where+    cmd = EnsureHbaLine name line+    r' = contramap (PGClusterOp cmd) r++{- | Authenticates a role by __client certificate only__, over TLS:+@hostssl \<db\> \<role\> \<cidr\> cert clientcert=verify-full@.++Two properties make this the interesting @pg_hba@ line rather than just+another one. @hostssl@ refuses a plaintext connection outright, so there is+no password path left to get wrong, and @clientcert=verify-full@ requires the+certificate's @CN@ to __equal the role name__ -- which turns "who may connect+as this role" into "who holds a certificate this cluster's CA issued for that+name", with no secret on the client that is not also a key.++The cluster must already be serving TLS and trusting the right CA for this to+be usable at all; that is 'serverTls'. A @hostssl@ line on a cluster with+@ssl = off@ is accepted by @pg_hba.conf@ and matches nothing.+-}+allowClientCertFrom ::+    Reporter Report ->+    Track' (Binary "pg_ctlcluster") ->+    ClusterName ->+    DatabaseName ->+    RoleName ->+    AllowedCidr ->+    Op+allowClientCertFrom r pgctl name db role cidr =+    hbaLine r pgctl name (Text.unwords ["hostssl", db, role, cidr, "cert", "clientcert=verify-full"])++{- | Where a cluster's TLS material lives. Paths are on the /database/ host,+and the key must be readable by the @postgres@ user and by nobody else --+see "Salmon.Builtin.Nodes.Filesystem".@ownedFile@, which exists for this.+-}+data ServerTls+    = ServerTls+    { tls_certFile :: FilePath+    , tls_keyFile :: FilePath+    , tls_caFile :: FilePath+    -- ^ the CA whose certificates this cluster will accept from clients.+    }+    deriving (Eq, Ord, Show)++{- | Turns TLS on for a cluster and points it at its certificate, key and+client CA.++All four settings are @sighup@-able, so this reloads rather than restarting:+a cluster serving traffic picks up a renewed certificate without dropping a+connection. (That also means a __broken__ certificate is not noticed until+something tries to connect, since the reload itself succeeds.)+-}+serverTls :: Reporter Report -> Track' (Binary "psql") -> Port -> ServerTls -> Op+serverTls r psql port tls =+    op "pg-server-tls" (deps [reload]) $ \actions ->+        actions+            { ref = mkRef "pg-server-tls" (port, tls.tls_certFile)+            , help = Text.unwords ["serves TLS on port", Text.pack (show port)]+            }+  where+    reload = foldl inject (reloadConf r psql port) settings+    settings =+        [ alterSystemSet r psql port "ssl" "on"+        , alterSystemSet r psql port "ssl_cert_file" (Text.pack tls.tls_certFile)+        , alterSystemSet r psql port "ssl_key_file" (Text.pack tls.tls_keyFile)+        , alterSystemSet r psql port "ssl_ca_file" (Text.pack tls.tls_caFile)+        ]++allowReplicationFrom :: Reporter Report -> Track' (Binary "pg_ctlcluster") -> ClusterName -> RoleName -> AllowedCidr -> Op+allowReplicationFrom r pgctl name replRole cidr =+    withBinary pgctl pgctlRun cmd $ \run ->+        op "pg-hba-replication" nodeps $ \actions ->+            actions+                { ref = mkRef "pg-hba-replication" (name, replRole, cidr)+                , help = Text.unwords ["allow replication from", cidr, "as", replRole, "on", name]+                , up = run r'+                }+  where+    line = Text.unwords ["host", "replication", replRole, cidr, "md5"]+    cmd = EnsureHbaLine name line+    r' = contramap (PGClusterOp cmd) r++{- | Turns an already-running, named cluster into a replication-capable+primary: WAL/replication-slot tuning (restart-required, so this restarts the+cluster), a @pg_hba.conf@ entry authorizing the standby, and the physical+replication slot the standby will stream from. Does /not/ create the+replication role itself — do that once via 'replicationUser' (it's shared+infrastructure, not per-standby).+-}+primaryReplicationSetup ::+    Reporter Report ->+    Track' (Binary "psql") ->+    Track' (Binary "pg_ctlcluster") ->+    Port ->+    ClusterName ->+    ReplicationTuning ->+    RoleName ->+    AllowedCidr ->+    ReplicationSlotName ->+    Op+primaryReplicationSetup r psql pgctl port name tuning replRole cidr slot =+    op "pg-primary-replication-setup" (deps [replicationSlot r psql port slot, allowReplicationFrom r pgctl name replRole cidr, restartOp]) id+  where+    -- restart-if-pending rather than restart: this node is re-applied on+    -- every pass, and an unconditional restart here is an outage per pass.+    restartOp = restartClusterIfPending r pgctl port name `inject` applySettings+    applySettings = op "pg-primary-wal-settings" (deps $ fmap (uncurry (alterSystemSet r psql port)) (replicationSettings tuning)) id++-- | Clones 'StandbySetup's cluster off its primary via @pg_basebackup -R@ and starts it as a streaming standby.+standbyReplicationSetup :: Reporter Report -> Track' (Binary "pg_ctlcluster") -> StandbySetup -> Op+standbyReplicationSetup r pgctl setup =+    withBinary pgctl pgctlRun cmd $ \run ->+        op "pg-standby-setup" nodeps $ \actions ->+            actions+                { ref = mkRef "pg-standby-setup" setup.standby_cluster+                , help = Text.unwords ["clone", setup.standby_cluster, "from", setup.standby_primary_host, "as a streaming standby"]+                , up = run r'+                }+  where+    cmd = CloneFromPrimary setup+    r' = contramap (PGClusterOp cmd) r++-------------------------------------------------------------------------------+-- Template databases, and databases cloned from them++{- $templates+@CREATE DATABASE c TEMPLATE t@ copies @t@ at the file level, which is how a+database that took a whole migration history to build is handed out in a+second. What makes that safe to automate is almost entirely about who else+is touching @t@:++* Nothing may be connected to @t@ while it is copied, or the copy fails with+  "source database is being accessed by other users". A template is therefore+  /locked/ once built: @ALLOW_CONNECTIONS false@, and any session still+  attached is terminated.+* @IS_TEMPLATE true@ lets a role with only @CREATEDB@ clone it, and makes+  @DROP DATABASE@ refuse, so every teardown has to flip it back first.++Both the template and its clones are databases salmon /drops/ -- to rebuild a+template, and to take a clone down -- so each carries a marker in its+database comment ('templateMarker', 'cloneMarker') and every statement that+would drop or adopt one refuses a database without it. That is what stops a+template or clone named after an existing database from replacing it: the+name is the caller's to choose, and nothing else about a database says who+made it.++The statements are fed to @psql@ on stdin rather than with @-c@, because+@CREATE DATABASE@ cannot run inside a transaction or a @DO@ block, and+@\\gexec@ is the one conditional form it tolerates. @DROP DATABASE ... WITH+(FORCE)@ needs Postgres 13 or later.+-}++-- | The comment prefix on a database salmon built as a template.+templateMarker :: Text+templateMarker = "salmon-template:"++-- | The comment prefix on a database salmon cloned from a template.+cloneMarker :: Text+cloneMarker = "salmon-clone:"++-- | A double-quoted SQL identifier.+quoteIdent :: Text -> Text+quoteIdent t = "\"" <> Text.replace "\"" "\"\"" t <> "\""++-- | A single-quoted SQL string literal (with @standard_conforming_strings@, the default since 9.1).+quoteLiteral :: Text -> Text+quoteLiteral t = "'" <> Text.replace "'" "''" t <> "'"++{- | Dollar-quotes a @DO@ body with a tag that does not occur in it.++A bare @$$@ is broken out of by a database name containing @$$@, and+'quoteLiteral' does nothing about that because inside a dollar-quoted body+nothing is a literal yet.+-}+dollarQuote :: Text -> Text+dollarQuote body = tag <> body <> tag+  where+    -- the search terminates: a body of length n contains fewer than n tags+    tag = case [t | n <- [0 :: Int ..], let t = "$salmon" <> Text.pack (show n) <> "$", not (t `Text.isInfixOf` body)] of+        (t : _) -> t+        [] -> error "unreachable: infinitely many candidate tags"++-- | A batch of SQL, fed to @psql@ on stdin as the @postgres@ OS user.+data PsqlBatch = PsqlBatch++{- | @ON_ERROR_STOP@ is not optional: @psql@ reading a script carries on past+a failed statement and exits @0@, so without it a refused drop would be+followed by the @CREATE@ it was guarding, and the node would report success.+-}+psqlBatchRun_Sudo :: Port -> Command "psql" PsqlBatch+psqlBatchRun_Sudo port = psqlBatchIn_Sudo port "postgres"++-- | 'psqlBatchRun_Sudo' connected to a named database (an extension lives in one).+psqlBatchIn_Sudo :: Port -> DatabaseName -> Command "psql" PsqlBatch+psqlBatchIn_Sudo port db = Command go+  where+    go PsqlBatch =+        proc "sudo" ["-u", "postgres", "psql", "-p", show port, "-X", "-q", "-v", "ON_ERROR_STOP=1", "-d", Text.unpack db]++-- | Aborts the batch unless @name@ is absent or its comment starts with @marker@.+refuseUnmarked :: Text -> Text -> DatabaseName -> Text+refuseUnmarked marker verb name =+    "DO " <> dollarQuote body <> ";\n"+  where+    body =+        Text.unwords+            [ "BEGIN IF EXISTS (SELECT FROM pg_database WHERE datname =" <> quoteLiteral name+            , "AND coalesce(left(shobj_description(oid, 'pg_database'), " <> Text.pack (show (Text.length marker)) <> "), '') <>" <> quoteLiteral marker <> ")"+            , "THEN RAISE EXCEPTION '%'," <> quoteLiteral ("refusing to " <> verb <> " database " <> name <> ": salmon did not create it") <> ";"+            , "END IF; END"+            ]++-- | Drops a template salmon built, if it is there.+dropTemplateSql :: DatabaseName -> Text+dropTemplateSql name =+    refuseUnmarked templateMarker "drop" name+        <> Text.unlines+            [ "SELECT format('ALTER DATABASE %I IS_TEMPLATE false', datname) FROM pg_database WHERE datname = " <> quoteLiteral name <> " \\gexec"+            , "DROP DATABASE IF EXISTS " <> quoteIdent name <> " WITH (FORCE);"+            ]++{- | Starts a template build from nothing: whatever was there before is+dropped, and the fresh database is marked as a build in progress, so that a+build which dies half-way is recognisably salmon's to replace next time.+-}+prepareTemplateSql :: DatabaseName -> Text+prepareTemplateSql name =+    refuseUnmarked templateMarker "replace" name+        <> Text.unlines+            [ "SELECT format('ALTER DATABASE %I IS_TEMPLATE false', datname) FROM pg_database WHERE datname = " <> quoteLiteral name <> " \\gexec"+            , "DROP DATABASE IF EXISTS " <> quoteIdent name <> " WITH (FORCE);"+            , "CREATE DATABASE " <> quoteIdent name <> ";"+            , "COMMENT ON DATABASE " <> quoteIdent name <> " IS " <> quoteLiteral (templateMarker <> "building") <> ";"+            ]++{- | Finishes a build: stamps the inputs it was built from, locks it, and+evicts whatever is still connected -- a session left on the template is the+thing that makes the next clone fail.+-}+lockTemplateSql :: DatabaseName -> Text -> Text+lockTemplateSql name fingerprint =+    Text.unlines+        [ "COMMENT ON DATABASE " <> quoteIdent name <> " IS " <> quoteLiteral (templateMarker <> fingerprint) <> ";"+        , "ALTER DATABASE " <> quoteIdent name <> " WITH IS_TEMPLATE true ALLOW_CONNECTIONS false;"+        , "SELECT pg_terminate_backend(pid) FROM pg_stat_activity WHERE datname = " <> quoteLiteral name <> " AND pid <> pg_backend_pid();"+        ]++-- | One row, @datistemplate|datallowconn|comment@, or none.+inspectTemplateSql :: DatabaseName -> Text+inspectTemplateSql name =+    "SELECT datistemplate, datallowconn, coalesce(shobj_description(oid, 'pg_database'), '') FROM pg_database WHERE datname = " <> quoteLiteral name++-- | Is @name@ a finished, locked template built from @fingerprint@.+checkTemplate :: Port -> DatabaseName -> Text -> IO CheckResult+checkTemplate port name fingerprint =+    either (const Unknown) (interpretTemplateRow name fingerprint) <$> psqlQuery_Sudo port (inspectTemplateSql name)++{- | The verdict 'checkTemplate' draws, split out so it is testable without a+cluster.++Everything short of "locked, and stamped with these inputs" is a 'Failure',+and every one of them means the same thing to the node -- rebuild -- but the+reasons are kept apart because they are different stories for an operator:+a template built from older migrations is routine, a half-built one means a+build died, and an unlocked one means somebody has been connected to it.+-}+interpretTemplateRow :: DatabaseName -> Text -> Text -> CheckResult+interpretTemplateRow name fingerprint out =+    case Text.lines (Text.strip out) of+        [] -> Failure ("template " <> name <> " does not exist")+        (row : _) -> case Text.splitOn "|" row of+            (istemplate : allowconn : rest) -> verdict istemplate allowconn (Text.intercalate "|" rest)+            _ -> Unknown+  where+    verdict istemplate allowconn comment+        | not (templateMarker `Text.isPrefixOf` comment) =+            Failure (name <> " exists and salmon did not build it as a template")+        | comment == templateMarker <> "building" =+            Failure ("template " <> name <> " is half-built: a previous build did not finish")+        | comment /= templateMarker <> fingerprint =+            Failure ("template " <> name <> " was built from different inputs")+        | istemplate /= "t" || allowconn /= "f" =+            Failure ("template " <> name <> " is not locked")+        | otherwise = Success++-- | A database copied from a template once, on creation.+data Clone+    = Clone+    { clone_database :: DatabaseName+    , clone_template :: DatabaseName+    , clone_owner :: Maybe RoleName+    -- ^ must already exist; 'Nothing' leaves it owned by @postgres@. The+    -- objects /inside/ keep whichever owners they had in the template.+    }+    deriving (Eq, Show, Generic)++instance ToJSON Clone+instance FromJSON Clone++cloneDatabaseSql :: Clone -> Text+cloneDatabaseSql c =+    refuseUnmarked cloneMarker "adopt" c.clone_database+        <> Text.unlines+            [ "SELECT " <> quoteLiteral create <> " WHERE NOT EXISTS (SELECT FROM pg_database WHERE datname = " <> quoteLiteral c.clone_database <> ") \\gexec"+            , "COMMENT ON DATABASE " <> quoteIdent c.clone_database <> " IS " <> quoteLiteral (cloneMarker <> c.clone_template) <> ";"+            ]+  where+    create =+        Text.unwords $+            ["CREATE DATABASE", quoteIdent c.clone_database, "TEMPLATE", quoteIdent c.clone_template]+                <> maybe [] (\o -> ["OWNER", quoteIdent o]) c.clone_owner++dropCloneSql :: DatabaseName -> Text+dropCloneSql name =+    refuseUnmarked cloneMarker "drop" name+        <> Text.unlines ["DROP DATABASE IF EXISTS " <> quoteIdent name <> " WITH (FORCE);"]++-- | One row, @row:\<comment\>@, or none; the prefix tells an uncommented database from a missing one.+inspectCloneSql :: DatabaseName -> Text+inspectCloneSql name =+    "SELECT 'row:' || coalesce(shobj_description(oid, 'pg_database'), '') FROM pg_database WHERE datname = " <> quoteLiteral name++checkClone :: Port -> DatabaseName -> IO CheckResult+checkClone port name =+    either (const Unknown) (interpretCloneRow name) <$> psqlQuery_Sudo port (inspectCloneSql name)++{- | A clone that exists is satisfied whichever template it came from: a+clone is somebody's data from the moment it is made, and re-declaring it+from a newer template is not a reason to throw that away.+-}+interpretCloneRow :: DatabaseName -> Text -> CheckResult+interpretCloneRow name out =+    case Text.lines (Text.strip out) of+        [] -> Failure ("database " <> name <> " does not exist")+        (row : _)+            | (("row:" <> cloneMarker) `Text.isPrefixOf` row) -> Success+            | otherwise -> Failure (name <> " exists and salmon did not clone it")++{- | What taking a clone down does to its data.++The choice belongs to the declaration rather than to the clone, because the+same database changes hands during its life. A clone backing a pull+request's environment should survive that environment being torn down and+redeployed while the PR is open (somebody's test data is in it), and should+go once the PR is merged. That is one database declared 'Retain' and later+'Discard' -- see 'retainedClone' and 'disposableClone'.+-}+data Retention+    = -- | @down@ leaves the database in place.+      Retain+    | -- | @down@ drops the database, data included.+      Discard+    deriving (Eq, Show, Generic)++instance ToJSON Retention+instance FromJSON Retention++{- | A database copied from a template.++The copy is taken __once__: a template rebuilt later does not reach an+existing clone. To pick up a newer template, take the clone down with+'Discard' and bring it up again.++With 'Discard', @down@ refuses a database salmon did not clone, same as @up@+refuses to adopt one. The 'Retention' is in the node's @notes@, so under+@run serve@ re-declaring a clone with the other one is seen as a change to+it, and a graph holding both is reported as a conflict.+-}+cloneDatabase :: Reporter Report -> Track' (Binary "psql") -> Port -> Track' DatabaseName -> Retention -> Clone -> Op+cloneDatabase r psql port mktemplate retention c =+    withBinaryStdin psql (psqlBatchRun_Sudo port) PsqlBatch (Text.encodeUtf8 (cloneDatabaseSql c)) $ \create ->+        withBinaryStdin psql (psqlBatchRun_Sudo port) PsqlBatch (Text.encodeUtf8 (dropCloneSql c.clone_database)) $ \dropIt ->+            op "pg-clone" (deps [run mktemplate c.clone_template]) $ \actions ->+                actions+                    { ref = mkRef "pg-db" (port, c.clone_database)+                    , help = Text.unwords ["clone", c.clone_database, "from template", c.clone_template]+                    , notes = ["copied once: rebuilding the template does not refresh it", retentionNote]+                    , check = checkClone port c.clone_database+                    , up = create (contramap (PGCloneDatabase c) r)+                    , down = case retention of+                        Retain -> pure ()+                        Discard -> dropIt (contramap (PGDropClone c.clone_database) r)+                    }+  where+    retentionNote = case retention of+        Retain -> "down keeps the database"+        Discard -> "down drops the database"++-- | A clone whose data outlives a teardown: an open PR's environment.+retainedClone :: Reporter Report -> Track' (Binary "psql") -> Port -> Track' DatabaseName -> Clone -> Op+retainedClone r psql port mktemplate = cloneDatabase r psql port mktemplate Retain++-- | A clone that goes with its teardown: a test fixture, or a PR's environment once merged.+disposableClone :: Reporter Report -> Track' (Binary "psql") -> Port -> Track' DatabaseName -> Clone -> Op+disposableClone r psql port mktemplate = cloneDatabase r psql port mktemplate Discard++{- | Runs one query as the @postgres@ OS user, unaligned and tuples-only.++@Left@ when it could not be asked at all (cluster down, no @psql@), which the+checks above read as 'Unknown' rather than as the effect being absent.+-}+psqlQuery_Sudo :: Port -> Text -> IO (Either Text Text)+psqlQuery_Sudo port = psqlQueryIn_Sudo port "postgres"++-- | 'psqlQuery_Sudo' connected to a named database.+psqlQueryIn_Sudo :: Port -> DatabaseName -> Text -> IO (Either Text Text)+psqlQueryIn_Sudo port db sql = do+    (code, out, err) <-+        readCreateProcessWithExitCode+            (proc "sudo" ["-u", "postgres", "psql", "-p", show port, "-X", "-tA", "-F", "|", "-d", Text.unpack db, "-c", Text.unpack sql])+            ""+    pure $ case code of+        ExitSuccess -> Right (Text.decodeUtf8With TextError.lenientDecode out)+        ExitFailure _ -> Left (Text.decodeUtf8With TextError.lenientDecode err)++-------------------------------------------------------------------------------++{- | A @CREATE EXTENSION@ in one database.++The tree had no such node before pgvector wanted one; it is here rather than+in "Salmon.Builtin.Nodes.PgVector" because every extension (pg_textsearch,+pg_turret) needs the same three things.+-}+data PgExtension = PgExtension+    { extName :: Text+    , extDatabase :: DatabaseName+    , extMinServerVersion :: Maybe Int+    -- ^ @server_version_num@ floor (@130000@ for PostgreSQL 13). Refused at+    -- @up@ with the running version in the message, since a package built+    -- for an older server is not something @CREATE EXTENSION@ can explain.+    , extUpgrade :: Bool+    -- ^ Whether the node also runs @ALTER EXTENSION ... UPDATE@ when the+    -- installed version is older than the package's default. Off by+    -- default: an extension upgrade can rewrite catalog entries of the+    -- indexes built on it, which is an operator's decision, not a side+    -- effect of converging.+    }+    deriving (Eq, Show)++-- | @CREATE EXTENSION IF NOT EXISTS@ (and, if asked, the upgrade), after the version floor.+createExtensionSql :: PgExtension -> Text+createExtensionSql e =+    Text.unlines $+        maybe [] (\n -> [floorCheck n]) e.extMinServerVersion+            <> ["CREATE EXTENSION IF NOT EXISTS " <> quoteIdent e.extName <> ";"]+            <> ["ALTER EXTENSION " <> quoteIdent e.extName <> " UPDATE;" | e.extUpgrade]+  where+    floorCheck n =+        "DO "+            <> dollarQuote+                ( "BEGIN IF current_setting('server_version_num')::int < "+                    <> Text.pack (show n)+                    <> " THEN RAISE EXCEPTION '%', "+                    <> quoteLiteral ("refusing to create extension " <> e.extName <> ": it needs server_version_num >= " <> Text.pack (show n) <> ", this server is ")+                    <> " || current_setting('server_version'); END IF; END"+                )+            <> ";"++-- | No @CASCADE@: an extension whose types are in use is refused, which is the answer a teardown should hear.+dropExtensionSql :: PgExtension -> Text+dropExtensionSql e = "DROP EXTENSION IF EXISTS " <> quoteIdent e.extName <> ";\n"++-- | Empty when the extension is not installed; otherwise @installed|default@.+inspectExtensionSql :: PgExtension -> Text+inspectExtensionSql e =+    "SELECT e.extversion || '|' || coalesce(a.default_version, '') FROM pg_extension e LEFT JOIN pg_available_extensions a ON a.name = e.extname WHERE e.extname = "+        <> quoteLiteral e.extName++{- | The verdict from 'inspectExtensionSql''s output. Present is 'Success'+unless 'extUpgrade' is on and the installed version is older than the+package's default, in which case it is a 'Failure' naming both.+-}+interpretExtensionRow :: PgExtension -> Text -> CheckResult+interpretExtensionRow e out =+    case Text.lines (Text.strip out) of+        [] -> Failure ("extension " <> e.extName <> " is not installed in " <> e.extDatabase)+        (row : _) -> case Text.splitOn "|" row of+            [installed, available]+                | e.extUpgrade+                , not (Text.null available)+                , versionKey installed < versionKey available ->+                    Failure ("extension " <> e.extName <> " is at " <> installed <> ", the package has " <> available)+            _ -> Success++-- | @"0.8.6"@ as @[0, 8, 6]@; a part that is not a number counts as 0.+versionKey :: Text -> [Int]+versionKey = fmap (\p -> case Text.unpack p of ds | not (null ds), all (`elem` ['0' .. '9']) ds -> read ds; _ -> 0) . Text.splitOn "."++extension :: Reporter Report -> Track' (Binary "psql") -> Port -> Track' DatabaseName -> PgExtension -> Op+extension r psql port mkdb e =+    withBinaryStdin psql (psqlBatchIn_Sudo port e.extDatabase) PsqlBatch (Text.encodeUtf8 (createExtensionSql e)) $ \create ->+        withBinaryStdin psql (psqlBatchIn_Sudo port e.extDatabase) PsqlBatch (Text.encodeUtf8 (dropExtensionSql e)) $ \dropIt ->+            op "pg-extension" (deps [run mkdb e.extDatabase]) $ \actions ->+                actions+                    { ref = mkRef "pg-extension" (port, e.extDatabase, e.extName)+                    , help = Text.unwords ["extension", e.extName, "in", e.extDatabase]+                    , notes =+                        ["upgrades the extension when the package is newer" | e.extUpgrade]+                            <> ["needs server_version_num >= " <> Text.pack (show n) | Just n <- [e.extMinServerVersion]]+                    , check = either (const Unknown) (interpretExtensionRow e) <$> psqlQueryIn_Sudo port e.extDatabase (inspectExtensionSql e)+                    , up = create (contramap (PGExtension e) r)+                    , down = dropIt (contramap (PGExtension e) r)+                    }
+ src/Salmon/Builtin/Nodes/Qemu.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE ScopedTypeVariables #-}++{- | Runs a qemu VM as a systemd unit — see @specs/qemu-test-vms.md@ (§2) for+the design this implements.++A VM's disk is (v1) a plain "Salmon.Builtin.Nodes.Debian.Debootstrap" chroot+directory, exported to the guest via qemu's @virtfs@ 9p passthrough rather+than a loop-mounted disk image (no @mkfs@\/loop-device step, and the guest's+files stay plain files on the host, trivially inspectable — see §3 of the+same spec for the tradeoffs). Booting skips a bootloader entirely: the+kernel\/initrd already unpacked into the chroot's own @\/boot@ by+'Salmon.Builtin.Nodes.Debian.Debootstrap.vmEssentials' are handed to qemu+directly via @-kernel@\/@-initrd@.++Two details below only became certain after actually booting one of these+(hand-validated 2026-08-20, see @specs/qemu-test-vms-progress.md@):++* The 9p @fsdev@ uses @security_model=passthrough@, not the more obvious+  @mapped@: qemu (and this whole tier) already runs as root on the host+  (see 'Qemu.setup's haddock below), so there's no need for @mapped@'s+  host-uid remapping — and @mapped@ actively breaks booting here, because+  it doesn't round-trip Debian's @\/bin -> usr\/bin@-style symlinks+  faithfully, which @run-init@ then sees as a symlink loop+  (@\/sbin\/init: Too many symbolic links encountered@).+* The 9p mount tag (and the kernel's @root=@) is @vroot@, not+  @\/dev\/root@: Debian's stock @initramfs-tools@ @\/scripts\/local@ only+  skips its udev block-device wait for a @ROOT@ that neither starts with+  @\/dev@ nor contains @=@ (see @local_device_setup@) — anything else, 9p+  mount tags included, it waits on forever since a 9p mount never produces+  a udev block device. A tag with no @\/dev@ prefix takes that fast path+  and hands the tag straight to @mount -t 9p@, which resolves it fine.++The kernel command line also always carries @net.ifnames=0 biosdevname=0@+(see 'kernelCmdline'): Debian's default predictable-naming udev rules+rename the single virtio-net device to something like @ens4@, not @eth0@,+which breaks a caller-supplied @ip=...:eth0:off@ kernel arg silently (VM+boots, network never comes up). Forcing classic naming keeps the "single+NIC, always @eth0@" assumption this whole tier's networking (fixed+@ip=@\/'Salmon.Builtin.Nodes.Debian.Debootstrap.ensureVm9pBoot') already+makes actually true.++Lifecycle (start\/stop) is delegated entirely to+"Salmon.Builtin.Nodes.Systemd" — a VM is just another systemd unit from the+host's point of view, exactly like 'Salmon.Builtin.Nodes.Nginx.setup' or+'Salmon.Builtin.Nodes.PgBouncer.setup' delegate to it, so 'up'\/'down' reuse+that module's process-supervision instead of this module inventing its own.++Stopping is graceful first: 'setup''s @down@ asks the guest for an ACPI+shutdown through the monitor socket (@system_powerdown@, see 'shutdown'),+waits up to 'defaultShutdownGrace' seconds for qemu to exit (a guest that+ignores ACPI, or is not running, is the fallback's case), and only then runs+the unit's @systemctl stop@, whose SIGTERM makes qemu quit immediately. A+qemu that exits by itself with status 0 is not restarted by the unit's+@Restart=on-failure@, so the two stops do not fight. See+@specs/qemu-test-vms.md@ §2.+-}+module Salmon.Builtin.Nodes.Qemu where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, justInstall)+import qualified Salmon.Builtin.Nodes.LinuxBridge as LinuxBridge+import qualified Salmon.Builtin.Nodes.Systemd as Systemd+import Salmon.Op.OpGraph (OpGraph (..), inject)+import Salmon.Op.Track+import Salmon.Reporter++import Control.Concurrent (threadDelay)+import Control.Exception (SomeException, bracket, throwIO, try)+import Control.Monad (filterM, void)+import qualified Data.ByteString as BS+import Data.List (isPrefixOf)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Network.Socket as Socket+import qualified Network.Socket.ByteString as SocketBS++import System.Directory (doesFileExist, listDirectory)+import System.FilePath ((</>))+import System.Timeout (timeout)++-------------------------------------------------------------------------------++type VmName = Text++-- | Absolute path to a qemu monitor unix socket (for out-of-band control; see the module haddock).+type MonitorSocket = FilePath++data VmConfig+    = VmConfig+    { vm_name :: VmName+    , vm_memory_mb :: Int+    , vm_smp :: Int+    , vm_rootfs :: FilePath+    -- ^ a 'Salmon.Builtin.Nodes.Debian.Debootstrap.RootTree' path, exported via 9p+    , vm_kernel :: FilePath+    , vm_initrd :: FilePath+    -- ^ resolve both with 'resolveKernelInitrd' before constructing a 'VmConfig' —+    -- see its haddock for why this can't happen inside the 'Op' itself+    , vm_extra_kernel_args :: [Text]+    , vm_tap :: LinuxBridge.Tap+    , vm_mac :: Text+    , vm_monitor_socket :: MonitorSocket+    , vm_enable_kvm :: Bool+    , vm_user :: Systemd.User+    , vm_group :: Systemd.Group+    , vm_working_dir :: FilePath+    , vm_systemd_scope :: Systemd.Scope+    , vm_unit_dir :: FilePath+    -- ^ @\/etc\/systemd\/system@ for 'Systemd.System' scope, or a+    -- caller-resolved @~\/.config\/systemd\/user@ for 'Systemd.User' scope+    -- (needs no root at all — see "Test.Harness".'Test.Harness.withVmAt',+    -- the only 'Systemd.User'-scope caller so far) — same "resolve before+    -- constructing" rule as 'resolveKernelInitrd' above.+    }++{- | Finds the single @vmlinuz-*@\/@initrd.img-*@ pair a+'Salmon.Builtin.Nodes.Debian.Debootstrap.vmEssentials'-equipped chroot's+@\/boot@ was left with, so a caller building a 'VmConfig' doesn't have to+know the exact kernel version string. This has to be an ordinary 'IO'+function run at seed\/'Salmon.Op.Configure.Configure'-generation time, not+something resolved inside the 'Op' itself: 'Salmon.Op.OpGraph.OpGraph'+values in this codebase are always built from already-concrete data — an+'Op' has no mechanism to hand a discovered path to a sibling node's+arguments mid-traversal, so this resolution has to happen before a+'VmConfig' is constructed at all.++Throws if @\/boot@ doesn't contain exactly one of each, which is what a+fresh, single-kernel debootstrap chroot should always have; ambiguity (an+upgraded/held-over old kernel) is a caller-visible error rather than a+silent "pick one."+-}+resolveKernelInitrd :: FilePath -> IO (FilePath, FilePath)+resolveKernelInitrd rootfs = do+    (,) <$> theOne "vmlinuz-" <*> theOne "initrd.img-"+  where+    bootDir = rootfs </> "boot"+    theOne prefix = do+        entries <- listDirectory bootDir+        let matches = filter (prefix `isPrefixOf`) entries+        files <- filterM (doesFileExist . (bootDir </>)) matches+        case files of+            [f] -> pure (bootDir </> f)+            [] -> throwIO (userError ("resolveKernelInitrd: no " <> prefix <> "* under " <> bootDir))+            fs -> throwIO (userError ("resolveKernelInitrd: ambiguous " <> prefix <> "* under " <> bootDir <> ": " <> show fs))++-------------------------------------------------------------------------------++{- | Installs qemu, brings up the VM's tap device (see+"Salmon.Builtin.Nodes.LinuxBridge"), and runs the VM as a systemd unit.+Its @down@ is a graceful 'shutdown' first, with 'defaultShutdownGrace'.+-}+setup :: Reporter Systemd.Report -> Reporter LinuxBridge.Report -> Track' (Binary "systemctl") -> Track' (Binary "qemu-system-x86_64") -> Track' (Binary "ip") -> VmConfig -> Op+setup = setupWithGrace defaultShutdownGrace++-- | 'setup' with the number of seconds 'shutdown' waits for the guest before the unit is stopped hard.+setupWithGrace :: Int -> Reporter Systemd.Report -> Reporter LinuxBridge.Report -> Track' (Binary "systemctl") -> Track' (Binary "qemu-system-x86_64") -> Track' (Binary "ip") -> VmConfig -> Op+setupWithGrace grace r rTap systemctl qemuBin ip cfg =+    graceful (Systemd.systemdService r systemctl trackConfig systemdCfg)+        `inject` LinuxBridge.tap rTap ip cfg.vm_tap+  where+    -- the unit's own @down@ (systemctl stop) still runs, after the guest had its chance+    graceful o = o{node = fmap (\e -> e{down = void (shutdown grace cfg.vm_monitor_socket) >> e.down}) o.node}++    trackConfig :: Track' Systemd.Config+    trackConfig = Track $ \_ -> op "qemu-setup" (deps [justInstall qemuBin]) id++    systemdCfg :: Systemd.Config+    systemdCfg = Systemd.Config cfg.vm_systemd_scope cfg.vm_unit_dir unitName unit svc install++    unitName :: Systemd.UnitTarget+    unitName = "salmon-vm-" <> cfg.vm_name <> ".service"++    -- | @network-online.target@/@multi-user.target@ only exist in the+    -- system manager — a 'Systemd.User'-scope unit orders against and is+    -- wanted by the user session's own @default.target@ instead.+    unit :: Systemd.Unit+    unit = Systemd.Unit ("Salmon-managed qemu VM: " <> cfg.vm_name) afterTarget++    afterTarget :: Systemd.UnitTarget+    afterTarget = case cfg.vm_systemd_scope of+        Systemd.System -> "network-online.target"+        Systemd.User -> "default.target"++    svc :: Systemd.Service+    svc = Systemd.Service Systemd.Simple cfg.vm_user cfg.vm_group "0022" start Systemd.OnFailure Systemd.Process cfg.vm_working_dir++    start :: Systemd.Start+    start = Systemd.Start "/usr/bin/qemu-system-x86_64" (qemuArgs cfg)++    install :: Systemd.Install+    install = Systemd.Install wantedByTarget++    wantedByTarget :: Systemd.UnitTarget+    wantedByTarget = case cfg.vm_systemd_scope of+        Systemd.System -> "multi-user.target"+        Systemd.User -> "default.target"++-- | The command-line qemu is started with — see @specs/qemu-test-vms.md@ §2 for the design.+qemuArgs :: VmConfig -> [Text]+qemuArgs cfg =+    mconcat+        [+            [ "-name"+            , cfg.vm_name+            , "-m"+            , Text.pack (show cfg.vm_memory_mb)+            , "-smp"+            , Text.pack (show cfg.vm_smp)+            ]+        ,+            [ "-fsdev"+            , "local,id=root,path=" <> Text.pack cfg.vm_rootfs <> ",security_model=passthrough"+            , "-device"+            , "virtio-9p-pci,fsdev=root,mount_tag=vroot"+            ]+        ,+            [ "-kernel"+            , Text.pack cfg.vm_kernel+            , "-initrd"+            , Text.pack cfg.vm_initrd+            , "-append"+            , kernelCmdline cfg+            ]+        ,+            [ "-netdev"+            , "tap,id=net0,ifname=" <> cfg.vm_tap.tapName <> ",script=no,downscript=no"+            , "-device"+            , "virtio-net-pci,netdev=net0,mac=" <> cfg.vm_mac+            ]+        ,+            [ "-monitor"+            , "unix:" <> Text.pack cfg.vm_monitor_socket <> ",server,nowait"+            , "-nographic"+            , "-serial"+            , "mon:stdio"+            ]+        , if cfg.vm_enable_kvm then ["-enable-kvm", "-cpu", "host"] else []+        ]++kernelCmdline :: VmConfig -> Text+kernelCmdline cfg =+    Text.unwords $+        mconcat+            [+                [ "root=vroot"+                , "rootfstype=9p"+                , "rootflags=trans=virtio"+                , "rw"+                , "console=ttyS0"+                , "net.ifnames=0"+                , "biosdevname=0"+                ]+            , cfg.vm_extra_kernel_args+            ]++-------------------------------------------------------------------------------++-- | Seconds 'setup' gives a guest to power itself off before the unit is stopped hard.+defaultShutdownGrace :: Int+defaultShutdownGrace = 30++{- | Asks the guest for an ACPI power-off through the monitor socket and waits+for qemu to go away, up to @grace@ seconds. 'True' when the VM is gone (also+when it was never running: nothing is sent to a socket nobody listens on),+'False' when it was still there at the deadline — the caller's cue to stop it+hard. Never throws: a monitor that cannot be talked to is a 'False', since the+answer the caller needs is "is it safe to skip the hard stop", and it is not.+-}+shutdown :: Int -> MonitorSocket -> IO Bool+shutdown grace sock = do+    up <- listening sock+    if not up+        then pure True+        else do+            _ <- monitorCommand sock "system_powerdown"+            waitGone (grace * 10)+  where+    waitGone :: Int -> IO Bool+    waitGone n = do+        up <- listening sock+        if not up+            then pure True+            else+                if n <= 0+                    then pure False+                    else threadDelay 100000 >> waitGone (n - 1)++-- | A hard guest reset through the monitor socket (@system_reset@), for tests of what survives one. 'False' if the monitor could not be talked to.+reset :: MonitorSocket -> IO Bool+reset sock = monitorCommand sock "system_reset"++{- | Sends one command line to a qemu monitor and waits for qemu to have read+it: the write side is closed and the connection drained until qemu hangs up+(or two seconds pass), because a client that disconnects at once can leave+the command unread. Never throws.+-}+monitorCommand :: MonitorSocket -> Text -> IO Bool+monitorCommand sock cmd = withMonitor sock $ \s -> do+    SocketBS.sendAll s (Text.encodeUtf8 (cmd <> "\n"))+    Socket.shutdown s Socket.ShutdownSend+    _ <- timeout 2000000 (drain s)+    pure ()+  where+    drain s = do+        bs <- SocketBS.recv s 4096+        if BS.null bs then pure () else drain s++-- | Is something accepting connections on the monitor socket?+listening :: MonitorSocket -> IO Bool+listening sock = withMonitor sock (\_ -> pure ())++-- | Connects, runs the action, closes; 'False' if any of it threw.+withMonitor :: MonitorSocket -> (Socket.Socket -> IO ()) -> IO Bool+withMonitor sock act = do+    r <-+        try $+            bracket (Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol) Socket.close $ \s -> do+                Socket.connect s (Socket.SockAddrUnix sock)+                act s+    pure (either (\(_ :: SomeException) -> False) (const True) r)
+ src/Salmon/Builtin/Nodes/Routes.hs view
@@ -0,0 +1,92 @@+module Salmon.Builtin.Nodes.Routes where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Data.Text (Text)+import qualified Data.Text as Text++import System.Process (readProcess)+import System.Process.ListLike (proc)++-------------------------------------------------------------------------------+data Report+    = RunIp !IpCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++type DevName = Text++type GatewayAddr = Text++data Route+    = Route+    { routeDestination :: DestinationNetwork+    , routeDevice :: DevName+    , routeVia :: Maybe GatewayAddr+    }+    deriving (Show)++data DestinationNetwork+    = Default+    | RawNetwork Text+    deriving (Show)++{- | Idempotently sets a route (uses @ip route replace@, which unlike @ip route add@+does not fail when the route already exists).+-}+route ::+    Reporter Report ->+    Track' (Binary "ip") ->+    Route ->+    Op+route r ip netroute =+    withBinary ip ipcommand cmd $ \addroute ->+        op "ip-route" nodeps $ \actions ->+            actions+                { help = mconcat ["route ", dst, " dev ", netroute.routeDevice, via]+                , ref = mkRef "ip-route" (netroute.routeDevice, netroute.routeVia)+                , up = addroute r'+                }+  where+    cmd = ReplaceRoute netroute+    r' = contramap (RunIp cmd) r+    dst = case netroute.routeDestination of Default -> "default"; RawNetwork d -> d+    via = maybe "" (\gw -> " via " <> gw) netroute.routeVia++data IpCommand+    = ReplaceRoute Route+    deriving (Show)++ipcommand :: Command "ip" IpCommand+ipcommand = Command $ \cmd -> case cmd of+    (ReplaceRoute (Route dstnet name via)) ->+        proc "ip" $+            mconcat+                [ ["route", "replace", dst]+                , ["dev", Text.unpack name]+                , maybe [] (\gw -> ["via", Text.unpack gw]) via+                ]+      where+        dst = case dstnet of Default -> "default"; RawNetwork d -> Text.unpack d++{- | Discovers the (gateway, device) the kernel currently uses to reach a given+host, by shelling out to @ip route get@. Useful to pin a host route to its+current path before overriding the default route (e.g. so VPN client traffic+destined to the VPN server's own endpoint keeps using the physical uplink).+-}+discoverGatewayFor :: Text -> IO (Maybe GatewayAddr, DevName)+discoverGatewayFor host = do+    out <- readProcess "ip" ["route", "get", Text.unpack host] ""+    let ws = Text.words (Text.pack out)+    pure (findAfter "via" ws, maybe (error $ "no `dev` in `ip route get " <> Text.unpack host <> "` output") id (findAfter "dev" ws))+  where+    findAfter tok (a : b : rest)+        | a == tok = Just b+        | otherwise = findAfter tok (b : rest)+    findAfter _ _ = Nothing
+ src/Salmon/Builtin/Nodes/Rsync.hs view
@@ -0,0 +1,151 @@+module Salmon.Builtin.Nodes.Rsync where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import qualified Salmon.Builtin.Nodes.Ssh as Ssh+import Salmon.Op.Ref+import Salmon.Reporter++import Control.Monad (void)+import Data.Text (Text)+import qualified Data.Text as Text++import System.FilePath (takeDirectory, (</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess, proc)++import Salmon.Op.Track++-------------------------------------------------------------------------------+data Report+    = RunRsyncCommand !RsyncCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++data Remote = Remote {remoteUser :: Text, remoteHost :: Text}+    deriving (Show, Ord, Eq)++-- | Copies a file to a remote, authenticating however ssh would by default.+sendFile :: Reporter Report -> Track' (Binary "rsync") -> File "source" -> Remote -> FilePath -> Op+sendFile = sendFileWith Ssh.noClientOpts++{- | 'sendFile', with explicit ssh client options -- rsync has no @-i@, so+they go through @--rsh@. See "Salmon.Builtin.Nodes.Ssh".'Salmon.Builtin.Nodes.Ssh.ClientOpts'.+-}+sendFileWith :: Ssh.ClientOpts -> Reporter Report -> Track' (Binary "rsync") -> File "source" -> Remote -> FilePath -> Op+sendFileWith opts r rsync src remote remotepath =+    withFile src $ \filepath ->+        let cmd = (SendFile filepath remote remotepath opts)+         in withBinary rsync rsyncRun cmd $ \up ->+                op "rsync:sendfile" nodeps $ \actions ->+                    actions+                        { help = "copies " <> Text.pack filepath <> " to " <> Text.pack remotepath <> " over rsync"+                        , ref = mkRef "rsync-sendfile" (filepath, remotepath, remote.remoteUser, remote.remoteHost)+                        , up = up (r' cmd)+                        }+  where+    r' cmd = contramap (RunRsyncCommand cmd) r++{- | Copies a file /from/ a remote to a local path: the direction+'sendFile' does not go.++It exists for fetching something whose /name/ the local side knows but whose+/content/ only the remote can produce -- a database dump being the case it+was written for. That constraint is the interesting one: rsync cannot fetch+a file it cannot name, so a recipe that pulls has to fix the name on the+controlling side and hand it to the remote, rather than letting the remote+choose one (see "SreBox.PostgresBackup"'s @pgb_fixedTimestamp@).++Pulling rather than having the remote push is also the cheaper trust+arrangement: the controller already holds credentials for the remote,+whereas a push would need the remote to hold credentials for wherever the+file is going.++The enclosing directory is created first: rsync will not make a missing+destination directory for a single-file transfer, and fails in a way that+reads like a permissions problem.+-}+receiveFile :: Reporter Report -> Track' (Binary "rsync") -> Track' Directory -> Remote -> FilePath -> FilePath -> Op+receiveFile = receiveFileWith Ssh.noClientOpts++-- | 'receiveFile', with explicit ssh client options.+receiveFileWith ::+    Ssh.ClientOpts ->+    Reporter Report ->+    Track' (Binary "rsync") ->+    Track' Directory ->+    Remote ->+    -- | path on the remote+    FilePath ->+    -- | path to write locally+    FilePath ->+    Op+receiveFileWith opts r rsync mkdir remote remotepath localpath =+    withBinary rsync rsyncRun cmd $ \up ->+        op "rsync:receivefile" (deps [run mkdir (Directory (takeDirectory localpath))]) $ \actions ->+            actions+                { help = "copies " <> Text.pack remotepath <> " from " <> loginAtHost remote <> " over rsync"+                , ref = mkRef "rsync-receivefile" (remotepath, localpath, remote.remoteUser, remote.remoteHost)+                , up = up r'+                , -- the local copy is this node's effect, and a fetch that+                  -- happened is not undone by deleting the only copy of a+                  -- backup. Removing it is the caller's retention policy.+                  down = pure ()+                }+  where+    cmd = ReceiveFile remote remotepath localpath opts+    r' = contramap (RunRsyncCommand cmd) r++-- | Copies a directory to a remote, authenticating however ssh would by default.+sendDir :: Reporter Report -> Track' (Binary "rsync") -> Track' Directory -> Directory -> Remote -> FilePath -> Op+sendDir = sendDirWith Ssh.noClientOpts++{- | 'sendDir', with explicit ssh client options -- the same @--rsh@+treatment as 'sendFileWith', for a key ssh would not offer on its own (one+a recipe generated and had signed, typically).+-}+sendDirWith :: Ssh.ClientOpts -> Reporter Report -> Track' (Binary "rsync") -> Track' Directory -> Directory -> Remote -> FilePath -> Op+sendDirWith opts r rsync mkdir dir remote remotepath =+    withBinary rsync rsyncRun cmd $ \up ->+        op "rsync:send-dir" (deps [run mkdir dir]) $ \actions ->+            actions+                { help = "copies " <> Text.pack dirpath <> " to " <> Text.pack remotepath <> " over rsync"+                , ref = mkRef "rsync-senddir" (dirpath, remote.remoteUser, remote.remoteHost)+                , up = up r'+                }+  where+    cmd = SendDir dirpath remote remotepath opts+    r' = contramap (RunRsyncCommand cmd) r+    dirpath :: FilePath+    dirpath = dir.directoryPath++data RsyncCommand+    = SendFile FilePath Remote FilePath Ssh.ClientOpts+    | ReceiveFile Remote FilePath FilePath Ssh.ClientOpts+    | SendDir FilePath Remote FilePath Ssh.ClientOpts+    deriving (Show)++rsyncRun :: Command "rsync" RsyncCommand+rsyncRun = Command $ \run ->+    case run of+        (SendFile src rem dst opts) ->+            proc "rsync" $+                ["--copy-links"]+                    <> (case Ssh.clientArgs opts of [] -> []; args -> ["--rsh", unwords ("ssh" : args)])+                    <> [src, Text.unpack (loginAtHost rem) <> ":" <> dst]+        (ReceiveFile rem src dst opts) ->+            proc "rsync" $+                ["--copy-links"]+                    <> (case Ssh.clientArgs opts of [] -> []; args -> ["--rsh", unwords ("ssh" : args)])+                    <> [Text.unpack (loginAtHost rem) <> ":" <> src, dst]+        (SendDir src rem dst opts) ->+            proc "rsync" $+                ["--copy-links", "--recursive"]+                    <> (case Ssh.clientArgs opts of [] -> []; args -> ["--rsh", unwords ("ssh" : args)])+                    <> [src, Text.unpack (loginAtHost rem) <> ":" <> dst]++loginAtHost :: Remote -> Text+loginAtHost rem = mconcat [rem.remoteUser, "@", rem.remoteHost]
+ src/Salmon/Builtin/Nodes/Secrets.hs view
@@ -0,0 +1,84 @@+module Salmon.Builtin.Nodes.Secrets where++import Salmon.Actions.UpDown (skipIfFileExists)+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem as FS+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Control.Monad (void)+import qualified Data.ByteString.Char8 as ByteString+import Data.Text (Text)+import qualified Data.Text as Text++import System.FilePath (takeDirectory, (</>))+import System.Process.ListLike (CreateProcess, proc)++-------------------------------------------------------------------------------+data Report+    = Generate !Secret !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++data SecretType+    = Base64+    | Base64SafeUrl+    | Hex+    deriving (Show)++data Secret+    = Secret+    { secret_type :: SecretType+    , secret_bytes :: Int+    , secret_path :: FilePath+    }+    deriving (Show)++sharedSecretFile :: Reporter Report -> Track' (Binary "openssl") -> Secret -> Op+sharedSecretFile r bin sec =+    withBinary bin openssl (GenRandom sec) $ \up -> do+        op "secret:gen" (deps [enclosingdir]) $ \actions ->+            actions+                { help = "generates a secret file for shared-secret"+                , ref = mkRef "gen-secret" sec.secret_path+                , check = skipIfFileExists sec.secret_path+                , up = up r' >> modifyInPlace sec.secret_path+                }+  where+    r' = contramap (Generate sec) r+    enclosingdir :: Op+    enclosingdir = FS.dir (FS.Directory $ takeDirectory sec.secret_path)+    modifyInPlace path =+        case sec.secret_type of+            Base64SafeUrl -> chompNewLines path >> safeUrlizeB64 path+            Base64 -> chompNewLines path+            Hex -> chompNewLines path++data GenRandom+    = GenRandom Secret++openssl :: Command "openssl" GenRandom+openssl = Command $ \(GenRandom s) ->+    case s.secret_type of+        Hex -> proc "openssl" ["rand", "-hex", "-out", s.secret_path, show s.secret_bytes]+        Base64 -> proc "openssl" ["rand", "-base64", "-out", s.secret_path, show s.secret_bytes]+        Base64SafeUrl -> proc "openssl" ["rand", "-base64", "-out", s.secret_path, show s.secret_bytes]++chompNewLines :: FilePath -> IO ()+chompNewLines path =+    ByteString.readFile path >>= ByteString.writeFile path . chomp+  where+    chomp = ByteString.filter ((/=) '\n')++safeUrlizeB64 :: FilePath -> IO ()+safeUrlizeB64 path =+    ByteString.readFile path >>= ByteString.writeFile path . tr+  where+    tr = ByteString.map f+    f '+' = '-'+    f '/' = '_'+    f x = x
+ src/Salmon/Builtin/Nodes/Self.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE DeriveGeneric #-}++-- | todo: pass rsync in+module Salmon.Builtin.Nodes.Self where++import Data.Aeson (FromJSON, ToJSON, encode)+import Data.ByteString.Lazy (toStrict)+import qualified Data.ByteString.Lazy as LByteString+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 System.FilePath (takeFileName, (</>))++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.Rsync as Rsync+import qualified Salmon.Builtin.Nodes.Ssh as Ssh+import Salmon.Op.Ref+import Salmon.Op.Track (Track (..), Tracked (..), bindTracked, trackedGraph, using, (>*<))+import Salmon.Reporter++import System.Posix.Files (readSymbolicLink)++-------------------------------------------------------------------------------+data Report+    = RunRsync !Rsync.Report+    | RunSsh !Ssh.Report+    deriving (Show)++-------------------------------------------------------------------------------++newtype SelfPath = SelfPath {getSelfPath :: FilePath}+    deriving (Show, Ord, Eq, Generic)++instance ToJSON SelfPath+instance FromJSON SelfPath++readSelfPath_linux :: IO SelfPath+readSelfPath_linux = SelfPath <$> readSymbolicLink "/proc/self/exe"++data Remote = Remote {remoteUser :: Text, remoteHost :: Text}+    deriving (Show, Ord, Eq)++data RemoteSelf = RemoteSelf {selfRemote :: Remote, selfRemotePath :: FilePath}++uploadSelf :: Reporter Report -> FilePath -> Remote -> SelfPath -> Tracked' RemoteSelf+uploadSelf = uploadSelfWith Ssh.noClientOpts++-- | 'uploadSelf', with explicit ssh client options.+uploadSelfWith :: Ssh.ClientOpts -> Reporter Report -> FilePath -> Remote -> SelfPath -> Tracked' RemoteSelf+uploadSelfWith opts r remotedir remote path =+    Tracked (Track $ \self -> op "copy-oneself" (deps [copy]) id) (RemoteSelf remote selfpathOnRemote)+  where+    selfpathOnRemote = remotedir </> takeFileName (getSelfPath path)+    rsyncRemote = Rsync.Remote remote.remoteUser remote.remoteHost+    copy =+        Rsync.sendFileWith+            opts+            r'+            Debian.rsync+            (FS.PreExisting $ getSelfPath path)+            rsyncRemote+            selfpathOnRemote+    r' = contramap RunRsync r++data RemoteCall a+    = RemoteCall+    { remoteCall_command :: CLI.BaseCommand+    , remoteCall_directive :: a+    }+    deriving (Show, Eq, Generic)+instance (ToJSON a) => ToJSON (RemoteCall a)+instance (FromJSON a) => FromJSON (RemoteCall a)++callSelf ::+    forall directive.+    (ToJSON directive, FromJSON directive) =>+    Reporter Report ->+    Track' Ssh.Remote ->+    RemoteSelf ->+    Track' directive ->+    CLI.BaseCommand ->+    directive ->+    Tracked' (RemoteCall directive)+callSelf r mkRemote self simulate base directive =+    Tracked (Track $ \_ -> op "self-call" (deps [callOverSSH]) modActions) rc+  where+    modActions actions =+        actions+            { ref = mkRef "call-self" (encode directive)+            , dynamics = [toDyn $ CLI.RemoteOp $ run simulate directive]+            }+    rc = RemoteCall base directive+    sshRemote = Ssh.Remote self.selfRemote.remoteUser self.selfRemote.remoteHost+    cmdArgs = ["run", CLI.argForBaseCommand base]+    cmdStdin = toStrict $ encode directive+    callOverSSH = Ssh.call r' Debian.ssh mkRemote sshRemote self.selfRemotePath cmdArgs cmdStdin+    r' = contramap RunSsh r++callSelfAsSudo ::+    forall directive.+    (ToJSON directive, FromJSON directive) =>+    Reporter Report ->+    Track' Ssh.Remote ->+    RemoteSelf ->+    Track' directive ->+    CLI.BaseCommand ->+    directive ->+    Tracked' (RemoteCall directive)+callSelfAsSudo = callSelfAsSudoWith Ssh.noClientOpts++-- | 'callSelfAsSudo', with explicit ssh client options.+callSelfAsSudoWith ::+    forall directive.+    (ToJSON directive, FromJSON directive) =>+    Ssh.ClientOpts ->+    Reporter Report ->+    Track' Ssh.Remote ->+    RemoteSelf ->+    Track' directive ->+    CLI.BaseCommand ->+    directive ->+    Tracked' (RemoteCall directive)+callSelfAsSudoWith opts r mkRemote self simulate base directive =+    Tracked (Track $ \_ -> op "self-call" (deps [callOverSSH]) modActions) rc+  where+    modActions actions =+        actions+            { ref = mkRef "call-self-sudo" (encode directive)+            , dynamics = [toDyn $ CLI.RemoteOp $ run simulate directive]+            }+    rc = RemoteCall base directive+    sshRemote = Ssh.Remote self.selfRemote.remoteUser self.selfRemote.remoteHost+    cmdArgs = [Text.pack self.selfRemotePath, "run", CLI.argForBaseCommand base]+    cmdStdin = toStrict $ encode directive+    callOverSSH = Ssh.callWith opts r' Debian.ssh mkRemote sshRemote "sudo" cmdArgs cmdStdin+    r' = contramap RunSsh r++-- | Upload this binary to a remote host, then invoke it there over SSH with+-- a directive — the composition every recipe that self-orchestrates a+-- remote step was hand-rolling via uploadSelf `bindTracked` callSelf.+uploadAndCallSelf ::+    forall directive.+    (ToJSON directive, FromJSON directive) =>+    Reporter Report ->+    Reporter Report ->+    FilePath ->+    Remote ->+    SelfPath ->+    Track' Ssh.Remote ->+    Track' directive ->+    CLI.BaseCommand ->+    directive ->+    Tracked' (RemoteCall directive)+uploadAndCallSelf rUpload rCall remotedir uploadRemote selfpath mkRemote simulate base directive =+    uploadSelf rUpload remotedir uploadRemote selfpath `bindTracked` \self ->+        callSelf rCall mkRemote self simulate base directive++-- | Same as 'uploadAndCallSelf', but invokes the remote binary via sudo.+uploadAndCallSelfAsSudo ::+    forall directive.+    (ToJSON directive, FromJSON directive) =>+    Reporter Report ->+    Reporter Report ->+    FilePath ->+    Remote ->+    SelfPath ->+    Track' Ssh.Remote ->+    Track' directive ->+    CLI.BaseCommand ->+    directive ->+    Tracked' (RemoteCall directive)+uploadAndCallSelfAsSudo = uploadAndCallSelfAsSudoWith Ssh.noClientOpts++{- | 'uploadAndCallSelfAsSudo', running both the upload and the call under+explicit ssh client options -- the key an SSH-CA recipe just had signed (which+ssh would otherwise never offer), and a known-hosts file of the recipe's own.+-}+uploadAndCallSelfAsSudoWith ::+    forall directive.+    (ToJSON directive, FromJSON directive) =>+    Ssh.ClientOpts ->+    Reporter Report ->+    Reporter Report ->+    FilePath ->+    Remote ->+    SelfPath ->+    Track' Ssh.Remote ->+    Track' directive ->+    CLI.BaseCommand ->+    directive ->+    Tracked' (RemoteCall directive)+uploadAndCallSelfAsSudoWith opts rUpload rCall remotedir uploadRemote selfpath mkRemote simulate base directive =+    uploadSelfWith opts rUpload remotedir uploadRemote selfpath `bindTracked` \self ->+        callSelfAsSudoWith opts rCall mkRemote self simulate base directive++remoteDir ::+    forall directive.+    (ToJSON directive, FromJSON directive) =>+    Reporter Report ->+    RemoteSelf ->+    Track' directive ->+    (FilePath -> directive) ->+    FilePath ->+    Op+remoteDir r self simulate mkpath path =+    trackedGraph $ callSelf r ignoreTrack self simulate CLI.Up (mkpath path)
+ src/Salmon/Builtin/Nodes/Spago.hs view
@@ -0,0 +1,71 @@+module Salmon.Builtin.Nodes.Spago where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Data.Text (Text)+import qualified Data.Text as Text+import GHC.TypeLits (Symbol)++import System.FilePath (takeDirectory, (</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess, cwd, proc)++-------------------------------------------------------------------------------+data Report+    = SpagoBuild !Spago !Binary.Report+    | SpagoBundle !Spago !FilePath !Binary.Report+    deriving (Show)++isBuildSuccess :: Report -> Bool+isBuildSuccess r = case r of+    (SpagoBuild _ cmd) ->+        Binary.isCommandSuccessful cmd+    otherwise -> False++-------------------------------------------------------------------------------+data Spago = Spago {spagoDir :: FilePath}+    deriving (Eq, Ord, Show)++type MainModule = Text++data SpagoRun+    = Build Spago+    | BundleApp Spago MainModule FilePath++build :: Reporter Report -> Track' (Binary "spago") -> Spago -> Op+build r spago s =+    withBinary spago spagoRun (Build s) $ \up ->+        op "spago-build" nodeps $ \actions ->+            actions+                { help = "spago builds a target"+                , ref = mkRef "spago-build" (show s)+                , up = up r'+                }+  where+    r' = contramap (SpagoBuild s) r++bundleApp :: Reporter Report -> Track' (Binary "spago") -> Spago -> MainModule -> FilePath -> Op+bundleApp r spago s m path =+    withBinary spago spagoRun (BundleApp s m path) $ \up ->+        op "spago-build" (deps [enclosingdir]) $ \actions ->+            actions+                { help = "spago bundles a target"+                , ref = mkRef "spago-bundle" path+                , up = up r'+                }+  where+    r' = contramap (SpagoBundle s path) r+    enclosingdir = dir (Directory dirpath)+    dirpath = takeDirectory path++spagoRun :: Command "spago" SpagoRun+spagoRun = Command $ go+  where+    go (Build c) = (proc "spago" ["build"]){cwd = Just c.spagoDir}+    go (BundleApp c m t) = (proc "spago" ["bundle-app", "-m", Text.unpack m, "-t", t]){cwd = Just c.spagoDir}
+ src/Salmon/Builtin/Nodes/Ssh.hs view
@@ -0,0 +1,137 @@+module Salmon.Builtin.Nodes.Ssh where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinaryStdin)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.Ref+import Salmon.Op.Track (Track (..), run)+import Salmon.Reporter++import Control.Monad (void)+import Data.ByteString (ByteString)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++import System.FilePath ((</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess, proc)++-------------------------------------------------------------------------------+data Report+    = RunSSHCommand !SSHCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++data Remote = Remote {remoteUser :: Text, remoteHost :: Text}+    deriving (Show, Ord, Eq)++{- | How the local ssh client should authenticate, and where it should keep+host keys.++Additive rather than fields on 'Remote' on purpose: every existing caller+authenticates ambiently against @~\/.ssh@, and changing 'Remote' would break+them all (including out-of-tree ones) for parameters they do not have.+-}+data ClientOpts = ClientOpts+    { optIdentity :: Maybe FilePath+    -- ^ a private key to offer. A certificate signed by+    -- "Salmon.Builtin.Nodes.Keys".@signKey@ sits next to it as+    -- @\<key\>-cert.pub@, which is what @ssh -i \<key\>@ picks up, so this+    -- one path carries both halves of an SSH-CA login.+    , optKnownHosts :: Maybe FilePath+    -- ^ a known-hosts file of this recipe's own. Worth setting whenever the+    -- hosts being reached are ephemeral: a VM rebuilt at a reserved address+    -- presents a new host key, and an entry for the old one in the user's+    -- @~\/.ssh\/known_hosts@ fails every later connection with+    -- @REMOTE HOST IDENTIFICATION HAS CHANGED@ (which @accept-new@ does not,+    -- and should not, override).+    }+    deriving (Eq, Show)++-- | Authenticate however ssh would by default.+noClientOpts :: ClientOpts+noClientOpts = ClientOpts Nothing Nothing++-- | The @ssh@ flags 'ClientOpts' asks for.+clientArgs :: ClientOpts -> [String]+clientArgs opts =+    maybe [] (\key -> ["-i", key, "-o", "IdentitiesOnly=yes"]) opts.optIdentity+        <> maybe [] (\hosts -> ["-o", "UserKnownHostsFile=" <> hosts, "-o", "StrictHostKeyChecking=accept-new"]) opts.optKnownHosts++{- | Calls a command on a remote over ssh, with whatever identities ssh+would offer by default (an agent, or @~\/.ssh\/id_*@).++See 'callWith' when the key to authenticate with is one salmon itself+generated, which ssh has no reason to try.+-}+call ::+    Reporter Report ->+    Track' (Binary "ssh") ->+    Track' Remote ->+    Remote ->+    FilePath ->+    [Text] ->+    ByteString ->+    Op+call = callWith noClientOpts++-- | 'call', with explicit client options.+callWith ::+    ClientOpts ->+    Reporter Report ->+    Track' (Binary "ssh") ->+    Track' Remote ->+    Remote ->+    FilePath ->+    [Text] ->+    ByteString ->+    Op+callWith opts r ssh tRemote remote remotepath args stdin =+    withBinaryStdin ssh sshRun cmd stdin $ \up ->+        op "ssh:call" (deps [run tRemote remote]) $ \actions ->+            actions+                { help = "calls " <> Text.pack remotepath <> " on " <> remote.remoteHost <> " with args " <> Text.intercalate " " args <> " and stdin " <> Text.decodeUtf8 stdin+                , notes = Text.pack remotepath : args+                , ref = mkRef "ssh-run" (show (remotepath, remote, args, stdin))+                , up = up r'+                }+  where+    cmd = Call remotepath remote args opts+    r' = contramap (RunSSHCommand cmd) r++data SSHCommand = Call FilePath Remote [Text] ClientOpts+    deriving (Show)++sshRun :: Command "ssh" SSHCommand+sshRun = Command $ \(Call path rem args opts) ->+    proc+        "ssh"+        ( clientArgs opts+            <> [ Text.unpack (loginAtHost rem)+               , path+               ]+            <> map Text.unpack args+        )++{- | Whether an ssh failure is a host key that no longer matches what the+known-hosts file recorded.++Worth singling out because it is the one ssh failure that never resolves by+waiting, and the one a recipe rebuilding disposable machines at a stable+address produces routinely: same address, new host. See+"Salmon.Builtin.Nodes.Gcp.SshAccess".@sshAvailable@, which forgets the stale+entry and retries rather than spending its whole probe budget on it.+-}+isHostKeyMismatch :: Text -> Bool+isHostKeyMismatch err =+    "REMOTE HOST IDENTIFICATION HAS CHANGED" `Text.isInfixOf` err+        || "Host key verification failed" `Text.isInfixOf` err++loginAtHost :: Remote -> Text+loginAtHost rem = mconcat [rem.remoteUser, "@", rem.remoteHost]++preExistingRemoteMachine :: Track' Remote+preExistingRemoteMachine = Track $ \r -> placeholder "remote" ("a remote at" <> r.remoteHost)
+ src/Salmon/Builtin/Nodes/Sysctl.hs view
@@ -0,0 +1,54 @@+module Salmon.Builtin.Nodes.Sysctl where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Data.Text (Text)+import qualified Data.Text as Text++import System.Process.ListLike (proc)++-------------------------------------------------------------------------------+data Report+    = RunSysctl !SysctlCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++data Setting+    = Setting+    { settingKey :: Text+    , settingValue :: Text+    }+    deriving (Show)++-- | Idempotently sets a runtime kernel parameter (e.g. @net.ipv4.ip_forward@).+set :: Reporter Report -> Track' (Binary "sysctl") -> Setting -> Op+set r sysctl s =+    withBinary sysctl sysctlcommand cmd $ \apply ->+        op "sysctl-set" nodeps $ \actions ->+            actions+                { help = mconcat ["sets kernel parameter ", s.settingKey, " = ", s.settingValue]+                , ref = mkRef "sysctl-set" s.settingKey+                , up = apply r'+                }+  where+    r' = contramap (RunSysctl cmd) r+    cmd = Set s++data SysctlCommand+    = Set Setting+    deriving (Show)++sysctlcommand :: Command "sysctl" SysctlCommand+sysctlcommand = Command $ \cmd -> case cmd of+    (Set s) ->+        proc+            "sysctl"+            [ "-w"+            , Text.unpack (s.settingKey <> "=" <> s.settingValue)+            ]
+ src/Salmon/Builtin/Nodes/Systemd.hs view
@@ -0,0 +1,407 @@+module Salmon.Builtin.Nodes.Systemd where++import qualified Crypto.Hash.SHA256 as SHA256+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Char8 as C8+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 System.Directory (doesFileExist)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.Process.ByteString (readCreateProcessWithExitCode)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import System.Process.ListLike (CreateProcess, proc)++-------------------------------------------------------------------------------+data Report+    = CallSystemCtl !SystemCtlCall !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++systemdService ::+    Reporter Report ->+    Track' (Binary "systemctl") ->+    Track' Config ->+    Config ->+    Op+systemdService = systemdServiceWatching []++{- | 'systemdService', told which files the service /reads/ at start.++Without this, a service whose config file changed is not restarted, and+nothing about that is visible: 'checkService' asks after the __unit__ file,+and a config file the unit merely points at (a @pgbouncer.ini@, a+@postgrest.conf@) leaves no trace in anything systemd knows. The unit is+active, enabled and loaded as written, so the node is skipped and the+running process keeps serving the old configuration -- silently, and+indefinitely.++The fix reuses the mechanism that already works rather than adding a second+one: the watched files' contents are hashed into a comment at the end of the+unit file. A changed config therefore changes the unit file, which is+exactly what @NeedDaemonReload@ is for, and the ordinary path (reload,+enable, restart) takes it from there. Nothing new to check, and a node with+no watched files renders byte-identically to before.++Two things to know. The hash is computed by the encoder, so this node uses+the @IO Text@ 'EncodeFileContents' instance and inherits its hazard: it is+read once by the check and once by @up@, and a file that changes between+those two reads simply gets picked up on the next pass. And the reaction to+a changed config is a __restart__, which for a connection-holding service+(pgbouncer) drops its clients -- the gentler @PAUSE@\/@RELOAD@\/@RESUME@+belongs to whatever node is orchestrating the change, see+@specs\/pg-switchover.md@.+-}+systemdServiceWatching ::+    [FilePath] ->+    Reporter Report ->+    Track' (Binary "systemctl") ->+    Track' Config ->+    Config ->+    Op+systemdServiceWatching watched r systemctl t cfg =+    withCommand (DaemonReload cfg.config_scope) $ \reload ->+        withCommand (Enable cfg.config_scope cfg.config_target) $ \enable ->+            withCommand (Up cfg.config_scope cfg.config_target) $ \up ->+                withCommand (Stop cfg.config_scope cfg.config_target) $ \stop ->+                    op "systemd-service" (deps [configContents, run t cfg]) $ \actions ->+                        actions+                            { help = "installs a systemd-unit and up it"+                            , ref = mkRef "systemd-unit" cfg.config_target+                            , check = checkService cfg+                            , up = reload >> enable >> up+                            , down = stop+                            }+  where+    r' cmd = contramap (CallSystemCtl cmd) r+    withCommand cmd f =+        let+            g :: (Reporter Binary.Report -> IO ()) -> Op+            g callbin = f (callbin (r' cmd))+         in+            withBinary systemctl callSystemctl cmd g+    unitPath :: FilePath+    unitPath = cfg.config_unit_dir </> Text.unpack cfg.config_target++    configContents :: Op+    configContents+        | null watched = filecontents $ FileContents unitPath (render_config cfg)+        | otherwise = filecontents $ FileContents unitPath (withWatchedFingerprint watched (render_config cfg))++{- | The unit text, with a comment carrying a hash of the watched files'+contents. A file that does not exist hashes as empty, so it appearing later+is itself a change.+-}+withWatchedFingerprint :: [FilePath] -> Text -> IO Text+withWatchedFingerprint paths unitText = do+    parts <- concat <$> traverse framed paths+    let digest = SHA256.finalize (SHA256.updates SHA256.init parts)+    pure (unitText <> "# salmon-watches: " <> Text.decodeUtf8 (Base64.encode digest) <> "\n")+  where+    framed :: FilePath -> IO [ByteString.ByteString]+    framed path = do+        exists <- doesFileExist path+        bytes <- if exists then ByteString.readFile path else pure ByteString.empty+        pure [C8.pack (path <> ":" <> show (ByteString.length bytes) <> ":"), bytes]++{- | Does this unit already exist, loaded as written, enabled and running?++The first @check@ on a long-running effect salmon does __not__ own, which is+the largest category of node in this repository and the one supervision was+built for. Without it, @systemdService@ takes the default answer,+'Salmon.Actions.UpDown.Immaterial' — and that verdict is a claim, made on+the node author's behalf, that there is nothing here worth asking about. For+a unit that can be stopped, crash, or be disabled behind salmon's back it is+simply false: the node would be brought up once by the declaring pass and+then parked, with nothing left in the system able to notice it had died.+Writing this check is what turns @systemdService@ from a node that is+applied into a node that is /supervised/.++Three properties, one @systemctl show@ (which exits 0 even for a unit it has+never heard of, so there is no error path to distinguish from an answer):++* __@ActiveState@__ is the effect itself. @active@ is+  'Salmon.Actions.UpDown.Success' and @inactive@\/@failed@ are+  'Salmon.Actions.UpDown.Failure'. The transitional states —+  @activating@, @deactivating@, @reloading@ — are+  'Salmon.Actions.UpDown.Unknown', which is exactly what that verdict is+  for: a service that is part-way through starting has not gone away, and+  restarting it on the strength of a half-finished transition is how a slow+  starter becomes a restart loop. @Unknown@ makes the supervisor wait and+  look again, which is the right answer and the only one available.+* __@UnitFileState@__ catches somebody having @systemctl disable@d the unit+  underneath us. The service is still running, so @ActiveState@ alone would+  say everything is fine, right up until the next reboot.+* __@NeedDaemonReload@__ is what makes a /changed/ unit file take effect.+  This node's own dependency rewrites the file before this check ever runs,+  so comparing the bytes on disk against what we would write can only ever+  say "they match"; systemd's own record of "the file changed since I loaded+  it" is the only thing that still remembers. Without it, editing a unit+  would rewrite the file and never restart the service.++= This changes what @run up@ does, deliberately++A @systemdService@ whose unit is already installed, enabled, loaded and+running is now __skipped__ rather than reloaded-enabled-restarted on every+@run up@. That is the point of giving a node a @check@ — and it is a real+behaviour change for existing callers, so it is worth being explicit: if you+were relying on @run up@ to bounce a service whose unit file did not change,+that no longer happens. Change the file (any change) and @NeedDaemonReload@+makes it happen again.+-}+checkService :: Config -> IO CheckResult+checkService cfg = do+    (code, out, _err) <-+        readCreateProcessWithExitCode+            ( proc+                "systemctl"+                ( scopeArgs cfg.config_scope+                    <> [ "show"+                       , Text.unpack cfg.config_target+                       , "--property=ActiveState"+                       , "--property=UnitFileState"+                       , "--property=NeedDaemonReload"+                       ]+                )+            )+            ""+    pure $ case code of+        ExitSuccess -> interpretShow (Text.lines (Text.decodeUtf8With TextError.lenientDecode out))+        ExitFailure _ ->+            -- not "the unit is down": we could not ask. Saying 'Failure'+            -- here would have a supervisor restart every unit on a box+            -- whose systemd is not answering.+            Unknown++{- | The verdict 'checkService' draws from @systemctl show@'s output, split+out because it is the whole of the decision and the only part worth testing+without a systemd to hand.++A property that is missing entirely is treated as absent rather than assumed:+@systemctl show@ omits @UnitFileState@ for a unit it has never heard of, and+"never heard of" is a 'Salmon.Actions.UpDown.Failure' by way of+@ActiveState=inactive@ rather than by way of a special case.+-}+interpretShow :: [Text] -> CheckResult+interpretShow ls+    | property "NeedDaemonReload" == Just "yes" =+        Failure "the unit file on disk has changed since systemd loaded it"+    | otherwise = case property "ActiveState" of+        Just "active" -> case property "UnitFileState" of+            Just st+                | st `elem` ["enabled", "enabled-runtime", "static", "indirect"] -> Success+                | otherwise -> Failure ("the unit is running but " <> st)+            -- running, and systemd has no install state for it at all: not+            -- a thing this node can author, so not a thing to complain+            -- about either.+            Nothing -> Success+        Just "activating" -> Unknown+        Just "deactivating" -> Unknown+        Just "reloading" -> Unknown+        Just other -> Failure ("the unit is " <> other)+        Nothing -> Failure "systemctl said nothing about the unit's state"+  where+    property :: Text -> Maybe Text+    property name =+        case [Text.drop 1 v | l <- ls, let (k, v) = Text.breakOn "=" l, k == name, not (Text.null v)] of+            (x : _) -> Just (Text.strip x)+            [] -> Nothing++{- | Restarts a pre-existing systemd service (e.g. one shipped by a Debian+package, such as nginx) — unlike 'systemdService', this does not author a+unit file of its own.+-}+restartService :: Reporter Report -> Track' (Binary "systemctl") -> UnitTarget -> Op+restartService r systemctl target =+    withCommand (Up System target) $ \restart ->+        op "systemd-restart-service" nodeps $ \actions ->+            actions+                { help = "restarts " <> target+                , ref = mkRef "systemd-restart" target+                , up = restart+                }+  where+    r' cmd = contramap (CallSystemCtl cmd) r+    withCommand cmd f =+        let+            g :: (Reporter Binary.Report -> IO ()) -> Op+            g callbin = f (callbin (r' cmd))+         in+            withBinary systemctl callSystemctl cmd g++{- | A system-wide unit (@systemctl@ against @\/etc\/systemd\/system@, the+original and still-default behavior) vs. a per-user one (@systemctl --user@+against a caller-resolved @~\/.config\/systemd\/user@, see 'Config's+@config_unit_dir@) — the latter needs no root at all, which is what+"Salmon.Builtin.Nodes.Qemu" uses for its VM units so the whole Layer-3 test+tier (see @specs/qemu-test-vms.md@) doesn't need it either. Systemd itself+rejects @User=@\/@Group=@ directives in a user-manager unit (a user session+can't switch users), so 'render_service' omits them for 'User' scope.+-}+data Scope = System | User+    deriving (Eq, Show)++scopeArgs :: Scope -> [String]+scopeArgs System = []+scopeArgs User = ["--user"]++data SystemCtlCall+    = DaemonReload Scope+    | Enable Scope UnitTarget+    | Up Scope UnitTarget+    | Stop Scope UnitTarget+    deriving (Show)++callSystemctl :: Command "systemctl" SystemCtlCall+callSystemctl = Command go+  where+    go (DaemonReload sc) = proc "systemctl" (scopeArgs sc <> ["daemon-reload"])+    go (Enable sc u) = proc "systemctl" (scopeArgs sc <> ["enable", Text.unpack u])+    go (Up sc u) = proc "systemctl" (scopeArgs sc <> ["restart", Text.unpack u])+    go (Stop sc u) = proc "systemctl" (scopeArgs sc <> ["stop", Text.unpack u])++-------------------------------------------------------------------------------++data Config+    = Config+    { config_scope :: Scope+    , config_unit_dir :: FilePath+    -- ^ @\/etc\/systemd\/system@ for 'System' scope; a caller-resolved+    -- @~\/.config\/systemd\/user@ for 'User' scope (this module has no+    -- opinion on how @~@ is found — same "resolve before constructing"+    -- rule as 'Salmon.Builtin.Nodes.Qemu.resolveKernelInitrd').+    , config_target :: UnitTarget+    , config_unit :: Unit+    , config_service :: Service+    , config_install :: Install+    }++render_config :: Config -> Text+render_config c =+    Text.unlines+        [ render_unit c.config_unit+        , ""+        , render_service c.config_scope c.config_service+        , ""+        , render_install c.config_install+        ]++type UnitTarget = Text++data Unit+    = Unit+    { unit_description :: Text+    , unit_after :: UnitTarget+    }++render_unit :: Unit -> Text+render_unit u =+    Text.unlines+        [ "[Unit]"+        , "Description=" <> u.unit_description+        , "After=" <> u.unit_after+        ]++data ServiceType+    = Simple++type User = Text+type Group = Text+type UMask = Text++data Start+    = Start+    { start_path :: FilePath+    , start_args :: [Text]+    }++-- | The @Restart=@ directive salmon writes into a unit file, for systemd+-- itself to act on. Not to be confused with 'Salmon.Op.Supervision.Restart',+-- salmon's own restart decision about a node — the two used to share a name+-- ((R8) in @specs/per-node-state-machines-remaining.md@) until a systemd+-- node with a 'Salmon.Op.Supervision.Supervision' needed both in scope.+data RestartDirective+    = OnFailure++data KillMode+    = Process++data Service+    = Service+    { service_type :: ServiceType+    , service_user :: User+    , service_group :: Group+    , service_umask :: UMask+    , service_execStart :: Start+    , service_restart :: RestartDirective+    , service_killmode :: KillMode+    , service_working_dir :: FilePath+    }++render_service :: Scope -> Service -> Text+render_service scope s =+    Text.unlines $+        mconcat+            [ ["[Service]", "Type=" <> render_type s.service_type]+            , case scope of+                System -> ["User=" <> s.service_user, "Group=" <> s.service_group]+                User -> []+            ,+                [ "UMask=" <> s.service_umask+                , "ExecStart=" <> render_start s.service_execStart+                , "Restart=" <> render_restart s.service_restart+                , "KillMode=" <> render_killmode s.service_killmode+                , "WorkingDirectory=" <> Text.pack s.service_working_dir+                ]+            ]+  where+    render_type :: ServiceType -> Text+    render_type Simple = "simple"++    -- | Quotes an arg that contains whitespace, per systemd's own+    -- @ExecStart=@ word-splitting rules (docs: @systemd.service(5)@ §+    -- "Command lines"): unlike @Text.unwords@ alone, a bare multi-word+    -- string here (e.g. a kernel @-append@ value) would otherwise be split+    -- back into several separate argv entries by systemd's parser when the+    -- unit file is loaded — this bit "Salmon.Builtin.Nodes.Qemu" for+    -- exactly that reason (hand-validated 2026-08-20, see+    -- @specs/qemu-test-vms-progress.md@).+    render_start :: Start -> Text+    render_start s = Text.unwords (Text.pack s.start_path : map quoteArg s.start_args)++    quoteArg :: Text -> Text+    quoteArg a+        | Text.any (`elem` (" \t\"'$`\\" :: String)) a =+            "\"" <> Text.replace "\"" "\\\"" (Text.replace "\\" "\\\\" a) <> "\""+        | otherwise = a++    render_restart :: RestartDirective -> Text+    render_restart OnFailure = "on-failure"++    render_killmode :: KillMode -> Text+    render_killmode Process = "process"++data Install+    = Install+    { install_wantedBy :: UnitTarget+    }++render_install :: Install -> Text+render_install i =+    Text.unlines+        [ "[Install]"+        , "WantedBy=" <> i.install_wantedBy+        ]
+ src/Salmon/Builtin/Nodes/Tar.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE ExistentialQuantification #-}++module Salmon.Builtin.Nodes.Tar where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Data.Text (Text)+import qualified Data.Text as Text+import GHC.TypeLits (Symbol)++import System.FilePath (takeDirectory, (</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess, cwd, proc)++-------------------------------------------------------------------------------+data Report+    = TarCreate !FilePath !Binary.Report+    | TarExtract !FilePath !FilePath !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++data Compression+    = Uncompressed+    | Gzip+    | Bzip2+    | Xz+    deriving (Eq, Ord, Show)++data Tar = Tar {tarPath :: FilePath, tarCompression :: Compression}+    deriving (Eq, Ord, Show)++data Tarfile = forall a. Tarfile (File a)++tarfilePath :: Tarfile -> FilePath+tarfilePath (Tarfile file) = getFilePath file++data FileList = FileList [Tarfile]++filePaths :: FileList -> [FilePath]+filePaths (FileList files) = fmap tarfilePath files++-------------------------------------------------------------------------------+create :: Reporter Report -> Track' (Binary "tar") -> Tar -> FilePath -> FileList -> Op+create r tar t dirpath files =+    withBinary tar tarRun (Create t dirpath files) $ \up ->+        op "tar-create" (deps [enclosingdir]) $ \actions ->+            actions+                { help = "creates a tar archive"+                , ref = mkRef "tar-create" t.tarPath+                , up = up r'+                }+  where+    r' = contramap (TarCreate t.tarPath) r+    enclosingdir :: Op+    enclosingdir = dir (Directory $ takeDirectory t.tarPath)++-------------------------------------------------------------------------------+extract :: Reporter Report -> Track' (Binary "tar") -> Tar -> FilePath -> Op+extract r tar t dirpath =+    withBinary tar tarRun (Extract t dirpath) $ \up ->+        op "tar-extract" (deps [extractiondir]) $ \actions ->+            actions+                { help = "extracts a tar archive"+                , ref = mkRef "tar-extract" t.tarPath+                , up = up r'+                }+  where+    r' = contramap (TarExtract t.tarPath dirpath) r+    extractiondir :: Op+    extractiondir = dir (Directory dirpath)++-------------------------------------------------------------------------------+data TarRun+    = Create Tar FilePath FileList+    | Extract Tar FilePath++-------------------------------------------------------------------------------+tarRun :: Command "tar" TarRun+tarRun = Command $ go+  where+    compressionFlags Uncompressed = []+    compressionFlags Gzip = ["--gzip"]+    compressionFlags Bzip2 = ["--bzip2"]+    compressionFlags Xz = ["--xz"]++    go (Create t dir files) =+        let args = compressionFlags t.tarCompression ++ ["--create", "--file", t.tarPath, "--directory", dir] ++ filePaths files+         in proc "tar" args+    go (Extract t dir) =+        let args = compressionFlags t.tarCompression ++ ["--extract", "-f", t.tarPath, "--directory", dir]+         in proc "tar" args
+ src/Salmon/Builtin/Nodes/Upx.hs view
@@ -0,0 +1,43 @@+module Salmon.Builtin.Nodes.Upx where++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Data.Text (Text)+import qualified Data.Text as Text+import GHC.TypeLits (Symbol)++import System.FilePath (takeDirectory, (</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess, cwd, proc)++-------------------------------------------------------------------------------+data Report+    = UpxPack !FilePath !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------+data UpxRun+    = Pack FilePath++pack :: Reporter Report -> Track' (Binary "upx") -> FilePath -> Op+pack r upx path =+    withBinary upx upxRun (Pack path) $ \up ->+        op "upx-pack" nodeps $ \actions ->+            actions+                { help = "upx packs a binary"+                , ref = mkRef "upx-pack" path+                , up = up r'+                }+  where+    r' = contramap (UpxPack path) r++upxRun :: Command "upx" UpxRun+upxRun = Command $ go+  where+    go (Pack path) = proc "upx" [path]
+ src/Salmon/Builtin/Nodes/User.hs view
@@ -0,0 +1,213 @@+module Salmon.Builtin.Nodes.User where++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinary)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Builtin.Nodes.Filesystem+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import Control.Monad (void)+import Data.Text (Text)+import qualified Data.Text as Text++import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess (..), proc)++-------------------------------------------------------------------------------+data Report+    = RunGroupAdd !GroupAddCommand !Binary.Report+    | RunUserAdd !UserAddCommand !Binary.Report+    | RunUserMod !UserModCommand !Binary.Report+    | RunChown !ChownCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------++newtype Group = Group {groupName :: Text}++group :: Reporter Report -> Track' (Binary "groupadd") -> Group -> Op+group r groupadd grp =+    withBinary groupadd runGroupAdd cmd $ \add ->+        op "group" nodeps $ \actions ->+            actions+                { help = "creates a system group"+                , ref = mkRef "group" (groupName grp)+                , check = skipIfGroupExists grp+                , up = add r'+                }+  where+    cmd = AddGroup grp.groupName+    r' = contramap (RunGroupAdd cmd) r++data GroupAddCommand+    = AddGroup Text+    deriving (Show)++runGroupAdd :: Command "groupadd" GroupAddCommand+runGroupAdd = Command go+  where+    go (AddGroup name) =+        proc+            "groupadd"+            [ Text.unpack name+            ]++-- | @groupadd@ has no idempotent form (no @-f@-equivalent that's safe across+-- all cases), so skip it via 'check' if @getent group@ already knows about it.+skipIfGroupExists :: Group -> IO CheckResult+skipIfGroupExists grp = do+    (code, _out, _err) <-+        readCreateProcessWithExitCode+            (proc "getent" ["group", Text.unpack grp.groupName])+            ""+    pure $ case code of+        ExitSuccess -> Success+        _ -> Failure ("no such group: " <> grp.groupName)++-------------------------------------------------------------------------------++newtype User = User {userName :: Text}++data NewUser = NewUser {newUser :: User, groups :: [Group]}++user :: Reporter Report -> Track' (Binary "useradd") -> Track' Group -> NewUser -> Op+user r useradd grp nu =+    withBinary useradd runUserAdd cmd $ \add ->+        op "user" (deps userGroups) $ \actions ->+            actions+                { help = "creates a system user"+                , ref = mkRef "user" nu.newUser.userName+                , check = skipIfUserExists nu.newUser+                , up = add r'+                }+  where+    cmd = AddUser nu.newUser.userName (fmap groupName nu.groups)+    r' = contramap (RunUserAdd cmd) r++    userGroups :: [Op]+    userGroups = groupForUser : fmap (run grp) (groups nu)++    groupForUser :: Op+    groupForUser = run grp (Group nu.newUser.userName)++data UserAddCommand+    = AddUser Text [Text]+    deriving (Show)++runUserAdd :: Command "useradd" UserAddCommand+runUserAdd = Command go+  where+    go (AddUser name []) =+        proc+            "useradd"+            [ "-M"+            , "-c"+            , "salmon-created user"+            , "-g"+            , Text.unpack name+            , Text.unpack name+            ]+    go (AddUser name grps) =+        proc+            "useradd"+            [ "-M"+            , "-c"+            , "salmon-created user"+            , "-G"+            , Text.unpack $ Text.intercalate "," grps+            , "-g"+            , Text.unpack name+            , Text.unpack name+            ]++-- | @useradd@ has no idempotent form either, so skip it via 'check' if+-- @getent passwd@ already knows about it.+skipIfUserExists :: User -> IO CheckResult+skipIfUserExists u = do+    (code, _out, _err) <-+        readCreateProcessWithExitCode+            (proc "getent" ["passwd", Text.unpack u.userName])+            ""+    pure $ case code of+        ExitSuccess -> Success+        _ -> Failure ("no such user: " <> u.userName)++-------------------------------------------------------------------------------++-- | Clears a user's password (@usermod -p '*'@), locking out password-based+-- login while leaving the account otherwise usable (e.g. for key-based ssh).+-- @usermod -p@ is a set rather than an add, so it's already idempotent and+-- needs no 'check' guard.+passwordless :: Reporter Report -> Track' (Binary "usermod") -> Track' User -> User -> Op+passwordless r usermod trackUser u =+    withBinary usermod runUserMod cmd $ \remove ->+        op "passwordless" (deps [run trackUser u]) $ \actions ->+            actions+                { help = "removes a system user's password"+                , ref = mkRef "passwordless" u.userName+                , up = remove r'+                }+  where+    cmd = RemovePassword u.userName+    r' = contramap (RunUserMod cmd) r++data UserModCommand+    = RemovePassword Text+    deriving (Show)++runUserMod :: Command "usermod" UserModCommand+runUserMod = Command go+  where+    go (RemovePassword name) =+        proc+            "usermod"+            [ "-p"+            , "*"+            , Text.unpack name+            ]++-------------------------------------------------------------------------------++-- | A user/group pair to hand to 'chown'.+data Owner = Owner {ownerUser :: User, ownerGroup :: Group}++{- | Sets a path's ownership (@chown user:group path@, optionally @-R@).+@chown@ is a set rather than an add, so it's already idempotent and needs no+'check' guard. Unlike 'dir'/'filecontents', this does not itself create the+path — callers are expected to wire the path's own creation as a dependency+(e.g. via 'Salmon.Op.OpGraph.inject').+-}+chown :: Reporter Report -> Track' (Binary "chown") -> Bool -> Owner -> FilePath -> Op+chown r chownBin recursive owner path =+    withBinary chownBin runChown cmd $ \apply ->+        op "chown" nodeps $ \actions ->+            actions+                { help = Text.pack $ "sets ownership of " <> path <> " to " <> Text.unpack ownerText+                , ref = mkRef "chown" (path, owner.ownerUser.userName, owner.ownerGroup.groupName)+                , up = apply r'+                }+  where+    ownerText = owner.ownerUser.userName <> ":" <> owner.ownerGroup.groupName+    cmd = Chown recursive owner.ownerUser.userName owner.ownerGroup.groupName path+    r' = contramap (RunChown cmd) r++data ChownCommand+    = Chown Bool Text Text FilePath+    deriving (Show)++runChown :: Command "chown" ChownCommand+runChown = Command go+  where+    go (Chown recursive u g path) =+        proc+            "chown"+            ( ["-R" | recursive]+                <> [ Text.unpack u <> ":" <> Text.unpack g+                   , path+                   ]+            )
+ src/Salmon/Builtin/Nodes/Web.hs view
@@ -0,0 +1,28 @@+module Salmon.Builtin.Nodes.Web where++import Salmon.Builtin.Extension+import Salmon.Op.Ref+import Salmon.Op.Track++import Control.Monad (void)+import Data.Text (Text)+import qualified Data.Text as Text++import Network.HTTP.Client (Manager, Request, httpNoBody)++data Call+    = Call+    { callManager :: Manager+    , callRequest :: Request+    }++call :: Track' Call -> Call -> Op+call t call =+    op "http-call" (deps [run t call]) $ \actions ->+        actions+            { help = "performs an HTTP call"+            , ref = mkRef "http-call" (show call.callRequest)+            , up = up+            }+  where+    up = void $ httpNoBody call.callRequest call.callManager
+ src/Salmon/Builtin/Nodes/WireGuard.hs view
@@ -0,0 +1,495 @@+{-# LANGUAGE OverloadedStrings #-}++module Salmon.Builtin.Nodes.WireGuard where++import Salmon.Actions.UpDown (CheckResult (..), skipIfFileExists)+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), CommandIO (..), checkExitCode, justInstall, untrackedExec, withBinary, withBinaryIO)+import qualified Salmon.Builtin.Nodes.Binary as Binary+import qualified Salmon.Builtin.Nodes.Filesystem as FS+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++import System.IO (IOMode (ReadMode, WriteMode), withFile)++import Control.Monad (unless)+import qualified Data.ByteString as ByteString+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text.Encoding as Text+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import GHC.IO.Handle (Handle)++import System.FilePath (takeDirectory, (</>))+import GHC.IO.Exception (ExitCode (..))+import System.Process (StdStream (UseHandle), waitForProcess)+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (CreateProcess (..), proc)++-------------------------------------------------------------------------------+data Report+    = RunWg !WgCommand !Binary.Report+    | RunIp !IpCommand !Binary.Report+    deriving (Show)++-------------------------------------------------------------------------------+newtype PrivateKeyForWriting = PrivateKeyForWriting {getWritePkHandle :: Handle}++newtype PublicKeyForWriting = PublicKeyForWriting {getWritePubPkHandle :: Handle}++newtype PrivateKeyForReading = PrivateKeyForReading {getReadPkHandle :: Handle}++privateKey ::+    Track' (Binary "wg") ->+    FilePath ->+    Op+privateKey wg path =+    withBinaryIO wg genkeycommand GenKey $ \writePK ->+        op "wg-private-key" (deps [enclosingdir]) $ \actions ->+            actions+                { help = "privkey at " <> Text.pack path+                , ref = mkRef "wg-write-pk" path+                , check = skipIfFileExists path+                , up = withFile path WriteMode $ \h -> do+                    (_, _, _, ph) <- writePK (PrivateKeyForWriting h)+                    waitForProcess ph >>= checkExitCode "wg genkey"+                }+  where+    enclosingdir :: Op+    enclosingdir = FS.dir (FS.Directory $ takeDirectory path)++publicKey ::+    Track' (Binary "wg") ->+    Track' FilePath ->+    FilePath ->+    FilePath ->+    Op+publicKey wg mkprivate private path =+    withBinaryIO wg pubkeycommand PubKey $ \writePK ->+        op "wg-public-key" (deps [run mkprivate private, enclosingdir]) $ \actions ->+            actions+                { help = "pubkey at " <> Text.pack path+                , ref = mkRef "wg-write-public-pk" path+                , check = skipIfFileExists path+                , up =+                    withFile private ReadMode $ \hIn ->+                        withFile path WriteMode $ \hOut -> do+                            (_, _, _, ph) <- writePK ((PrivateKeyForReading hIn), (PublicKeyForWriting hOut))+                            waitForProcess ph >>= checkExitCode "wg pubkey"+                }+  where+    enclosingdir :: Op+    enclosingdir = FS.dir (FS.Directory $ takeDirectory path)++data GenKeyCommand+    = GenKey++data PubKeyCommand+    = PubKey++genkeycommand :: CommandIO "wg" GenKeyCommand PrivateKeyForWriting+genkeycommand = CommandIO $ \cmd -> case cmd of+    GenKey -> \h -> do+        pure ((proc "wg" ["genkey"]){std_out = UseHandle (getWritePkHandle h)})++pubkeycommand :: CommandIO "wg" PubKeyCommand (PrivateKeyForReading, PublicKeyForWriting)+pubkeycommand = CommandIO $ \cmd -> case cmd of+    PubKey -> \(hin, hout) -> do+        pure ((proc "wg" ["pubkey"]){std_in = UseHandle (getReadPkHandle hin), std_out = UseHandle (getWritePubPkHandle hout)})++-------------------------------------------------------------------------------+type Ipv4 = Text+type Ipv4PrefixSize = Int++data IpNet+    = Ipv4Cidr Ipv4 Ipv4PrefixSize+    deriving (Show)++nettxt :: IpNet -> Text+nettxt (Ipv4Cidr ipv4 cidr) = ipv4 <> "/" <> Text.pack (show cidr)++iptxt :: IpNet -> Text+iptxt (Ipv4Cidr ipv4 _) = ipv4++data RFC1918+    = Ten8+    | OneSevenTwo12+    | OneNineTwoOneSixEight16++type NetworkNum = Int+type MachineNum = Int++rfc1918_slash24 :: RFC1918 -> NetworkNum -> MachineNum -> IpNet+rfc1918_slash24 rfc n m =+    let+        n', m' :: Text+        n' = Text.pack (show n)+        m' = Text.pack (show m)+     in+        case rfc of+            Ten8 ->+                Ipv4Cidr (mconcat ["10.0.", n', ".", m']) 24+            OneSevenTwo12 ->+                Ipv4Cidr (mconcat ["172.16.", n', ".", m']) 24+            OneNineTwoOneSixEight16 ->+                Ipv4Cidr (mconcat ["192.168.", n', ".", m']) 24++type WgName = Text++{- | A WireGuard interface with an address, up.++'up' tolerates an interface that is already there: @ip link add@ fails on a+second run, so the link is only added when @ip link show@ does not know it,+and the address is set with @ip address replace@ (a set, not an insert). The+'check' answers whether the link exists, is @UP@ and carries the address, so+a second @run up@ skips it and, under @run serve@, a link deleted behind+salmon's back is put back.++__The interface does not survive a reboot__ and nothing here makes it: under+@run serve@ the tending loop re-creates it from the 'check', and a host that+wants it before salmon is running is a @systemd-networkd@ netdev, which is a+different node.+-}+iface ::+    Reporter Report ->+    Track' (Binary "ip") ->+    WgName ->+    IpNet ->+    Op+iface r ip wg net =+    withCommand (AddWg wg) $ \addwg ->+        withCommand (SetWgAddr wg net) $ \setAddr ->+            withCommand (UpWg wg) $ \activate ->+                op "wireguard-iface" nodeps $ \actions ->+                    actions+                        { help = "wireguard interface " <> wg <> " at " <> nettxt net+                        , ref = mkRef "wg-iface" wg+                        , check = checkIface wg net+                        , up = do+                            exists <- linkExists wg+                            unless exists addwg+                            setAddr+                            activate+                        }+  where+    r' cmd = contramap (RunIp cmd) r+    withCommand :: IpCommand -> (IO () -> Op) -> Op+    withCommand cmd f =+        let+            g :: (Reporter Binary.Report -> IO ()) -> Op+            g callbin = f (callbin (r' cmd))+         in+            withBinary ip ipcommand cmd g++-- | Does @ip link show dev NAME@ know the link?+linkExists :: WgName -> IO Bool+linkExists wg = do+    (code, _, _) <- readCreateProcessWithExitCode (proc "ip" ["link", "show", "dev", Text.unpack wg]) ""+    pure (code == ExitSuccess)++checkIface :: WgName -> IpNet -> IO CheckResult+checkIface wg net = do+    (lcode, lout, _) <- readCreateProcessWithExitCode (proc "ip" ["-o", "link", "show", "dev", Text.unpack wg]) ""+    (acode, aout, _) <- readCreateProcessWithExitCode (proc "ip" ["-o", "-4", "address", "show", "dev", Text.unpack wg]) ""+    pure $ case (lcode, acode) of+        (ExitSuccess, ExitSuccess) -> interpretIface wg net (Text.decodeUtf8 lout) (Text.decodeUtf8 aout)+        (ExitFailure _, _) -> Failure ("no such link: " <> wg)+        _ -> Unknown++{- | The verdict from @ip -o link show dev NAME@ and @ip -o -4 address show dev+NAME@ output (split out so it can be tested without a network namespace): the+link must carry the @UP@ flag and the address must be listed.+-}+interpretIface :: WgName -> IpNet -> Text -> Text -> CheckResult+interpretIface wg net link addrs+    | not ("UP" `elem` flags) = Failure ("link not up: " <> wg)+    | nettxt net `notElem` concatMap Text.words (Text.lines addrs) = Failure ("address missing on " <> wg <> ": " <> nettxt net)+    | otherwise = Success+  where+    -- "5: wg0: <POINTOPOINT,NOARP,UP,LOWER_UP> mtu 1420 ..."+    flags = Text.splitOn "," (Text.takeWhile (/= '>') (Text.drop 1 (Text.dropWhile (/= '<') link)))++data IpCommand+    = AddWg WgName+    | SetWgAddr WgName IpNet+    | UpWg WgName+    deriving (Show)++ipcommand :: Command "ip" IpCommand+ipcommand = Command $ \cmd -> case cmd of+    (AddWg name) ->+        proc+            "ip"+            [ "link"+            , "add"+            , "dev"+            , Text.unpack name+            , "type"+            , "wireguard"+            ]+    (SetWgAddr name ipnet) ->+        proc+            "ip"+            [ "address"+            , "replace"+            , "dev"+            , Text.unpack name+            , Text.unpack $ nettxt ipnet+            ]+    (UpWg name) ->+        proc+            "ip"+            [ "link"+            , "set"+            , "up"+            , Text.unpack name+            ]++-------------------------------------------------------------------------------++type Endpoint = Text++type B64PubKey = Text++type AllowedIps = Text++type PortNum = Int++server ::+    Reporter Report ->+    Track' (Binary "wg") ->+    Track' FilePath ->+    Track' WgName ->+    WgName ->+    FilePath ->+    PortNum ->+    Op+server r wg key iface wgname privateKeyPath port =+    withBinary wg wgcommand cmd $ \config ->+        op "wireguard-server" (deps [run key privateKeyPath, run iface wgname]) $ \actions ->+            actions+                { ref = mkRef "wg-server" wgname+                , up = config r'+                }+  where+    cmd = SetupServer wgname port privateKeyPath+    r' = contramap (RunWg cmd) r++client ::+    Reporter Report ->+    Track' (Binary "wg") ->+    Track' FilePath ->+    Track' WgName ->+    WgName ->+    FilePath ->+    Op+client r wg key iface wgname privatekeyPath =+    op "wireguard-client" (deps [justInstall wg, pk, netdev]) $ \actions ->+        actions+            { ref = mkRef "wg-client" (wgname, privatekeyPath)+            , up = do+                let cmd = SetupClient wgname privatekeyPath+                untrackedExec wgcommand cmd "" (r' cmd)+            }+  where+    r' cmd = contramap (RunWg cmd) r+    pk = run key privatekeyPath+    netdev = run iface wgname++type KeepaliveSeconds = Int++-- | Where a peer's public key comes from.+data PeerKey+    = -- | A file some other node provides (the track provisions it); read when the node runs.+      PeerKeyFile (Track' FilePath) FilePath+    | -- | The base64 key itself, e.g. from a generated document that carries it inline.+      PeerKeyValue B64PubKey++peer ::+    Reporter Report ->+    Track' (Binary "wg") ->+    Track' FilePath ->+    Track' WgName ->+    Track' Endpoint ->+    WgName ->+    FilePath ->+    Maybe Endpoint ->+    AllowedIps ->+    Op+peer r wg key iface endpoint wgname publicKeyPath ep ips =+    peerKeepalive r wg key iface endpoint wgname publicKeyPath ep ips Nothing++{- | Like 'peer', but also sets a persistent-keepalive interval. Needed on the+side behind a NAT/dynamic-IP (typically the client) so the tunnel stays+punched through and the far (static-IP) side can keep sending it traffic.+-}+peerKeepalive ::+    Reporter Report ->+    Track' (Binary "wg") ->+    Track' FilePath ->+    Track' WgName ->+    Track' Endpoint ->+    WgName ->+    FilePath ->+    Maybe Endpoint ->+    AllowedIps ->+    Maybe KeepaliveSeconds ->+    Op+peerKeepalive r wg key iface endpoint wgname publicKeyPath =+    peerWith r wg iface endpoint wgname (PeerKeyFile key publicKeyPath)++{- | A peer, with its key given either way ('PeerKey').++* 'check' reads @wg show IF dump@ and compares the peer's public key,+  allowed-ips, endpoint and persistent-keepalive with what is declared (see+  'interpretWgDump'); a peer already as declared is skipped, and one whose+  allowed-ips changed is re-applied (@wg set@ replaces them).+* 'down' is @wg set IF peer KEY remove@, so a peer dropped from a declaration+  leaves the interface and only that peer does.+-}+peerWith ::+    Reporter Report ->+    Track' (Binary "wg") ->+    Track' WgName ->+    Track' Endpoint ->+    WgName ->+    PeerKey ->+    Maybe Endpoint ->+    AllowedIps ->+    Maybe KeepaliveSeconds ->+    Op+peerWith r wg iface endpoint wgname pkey ep ips keepalive =+    op "wireguard-peer" (deps [justInstall wg, pk, netdev, peersetup]) $ \actions ->+        actions+            { help = "wireguard peer on " <> wgname+            , ref = case pkey of+                PeerKeyFile _ path -> mkRef "wg-peer" (wgname, path)+                PeerKeyValue v -> mkRef "wg-peer-value" (wgname, v)+            , check = do+                k <- resolve+                (code, out, _) <- readCreateProcessWithExitCode (prepare wgcommand (ShowDump wgname)) ""+                pure $ case code of+                    ExitSuccess -> interpretWgDump (PeerSpec k ep ips keepalive) (Text.decodeUtf8 out)+                    ExitFailure _ -> Unknown+            , up = do+                k <- resolve+                let cmd = AddPeer wgname k ep ips keepalive+                untrackedExec wgcommand cmd "" (r' cmd)+            , down = do+                k <- resolve+                let cmd = RemovePeer wgname k+                untrackedExec wgcommand cmd "" (r' cmd)+            }+  where+    r' cmd = contramap (RunWg cmd) r+    pk = case pkey of+        PeerKeyFile key path -> run key path+        PeerKeyValue _ -> realNoop+    resolve :: IO B64PubKey+    resolve = case pkey of+        PeerKeyFile _ path -> Text.strip <$> Text.readFile path+        PeerKeyValue v -> pure (Text.strip v)+    netdev = run iface wgname+    peersetup = maybe realNoop (run endpoint) ep++-- | What a peer node declares, for comparison with @wg show ... dump@.+data PeerSpec = PeerSpec+    { specKey :: B64PubKey+    , specEndpoint :: Maybe Endpoint+    , specAllowedIps :: AllowedIps+    , specKeepalive :: Maybe KeepaliveSeconds+    }++{- | The verdict from @wg show IF dump@. The interface line has 4 tab-separated+fields; a peer line has 8: public key, preshared key, endpoint, allowed-ips,+latest handshake, rx, tx, persistent-keepalive (@off@ or seconds).++Fields the declaration leaves out are not compared: @wg set@ without an+endpoint or a keepalive leaves what is there alone, so declaring none of it+is not a statement that it is unset. An endpoint given as a host name is not+compared either, since @wg@ shows the address it resolved to. Allowed-ips are+compared as sets, a bare address counting as its @/32@ (or @/128@).++The reasons name the field and never quote the dump, whose first line is the+interface's private key.+-}+interpretWgDump :: PeerSpec -> Text -> CheckResult+interpretWgDump spec dump =+    case [fields | fields@[k, _, _, _, _, _, _, _] <- Text.splitOn "\t" <$> Text.lines dump, k == spec.specKey] of+        [] -> Failure "peer not on the interface"+        [_, _, endpoint, allowed, _, _, _, keepalive] : _ ->+            case [reason | (False, reason) <- comparisons endpoint allowed keepalive] of+                [] -> Success+                reasons -> Failure (Text.intercalate "; " reasons)+        _ -> Unknown+  where+    comparisons endpoint allowed keepalive =+        [ (normalizeIps allowed == normalizeIps spec.specAllowedIps, "allowed-ips differ")+        , (maybe True (\e -> not (isIpLiteralEndpoint e) || e == endpoint) spec.specEndpoint, "endpoint differs")+        , (maybe True (\k -> keepalive == Text.pack (show k)) spec.specKeepalive, "persistent-keepalive differs")+        ]++normalizeIps :: Text -> Set.Set Text+normalizeIps = Set.fromList . filter (/= "(none)") . fmap norm . Text.splitOn "," . Text.filter (/= ' ')+  where+    norm ip+        | Text.null ip = ip+        | Text.any (== '/') ip = ip+        | Text.any (== ':') ip = ip <> "/128"+        | otherwise = ip <> "/32"++-- | @1.2.3.4:51820@ or @[::1]:51820@, as opposed to @host.example:51820@.+isIpLiteralEndpoint :: Endpoint -> Bool+isIpLiteralEndpoint e+    | "[" `Text.isPrefixOf` e = True+    | otherwise = not (Text.null host) && Text.all (`elem` ("0123456789." :: String)) host+  where+    host = Text.takeWhile (/= ':') e++data WgCommand+    = SetupServer WgName PortNum FilePath+    | SetupClient WgName FilePath+    | AddPeer WgName B64PubKey (Maybe Endpoint) AllowedIps (Maybe KeepaliveSeconds)+    | RemovePeer WgName B64PubKey+    | ShowDump WgName+    deriving (Show)++wgcommand :: Command "wg" WgCommand+wgcommand = Command $ \cmd -> case cmd of+    (SetupServer name port key) ->+        proc+            "wg"+            [ "set"+            , Text.unpack name+            , "listen-port"+            , show port+            , "private-key"+            , key+            ]+    (SetupClient name key) ->+        proc+            "wg"+            [ "set"+            , Text.unpack name+            , "private-key"+            , key+            ]+    (AddPeer name b64pk ep allowedIps keepalive) ->+        proc "wg" $+            mconcat+                [+                    [ "set"+                    , Text.unpack name+                    , "peer"+                    , Text.unpack b64pk+                    ]+                , maybe [] (\e -> ["endpoint", Text.unpack e]) ep+                , ["allowed-ips", Text.unpack allowedIps]+                , maybe [] (\k -> ["persistent-keepalive", show k]) keepalive+                ]+    (RemovePeer name b64pk) ->+        proc "wg" ["set", Text.unpack name, "peer", Text.unpack b64pk, "remove"]+    (ShowDump name) ->+        proc "wg" ["show", Text.unpack name, "dump"]
+ src/Salmon/Client/Http.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | A small typed client over the five HTTP surfaces of @run serve --http+PATH@ (or @--http-tcp HOST:PORT@) ("Salmon.Actions.Serve.Http"): the four reads, the command in both+modes, and the event stream.++Milestone 6 of @specs\/generic-server.md@ ("terminal client against the+socket") wants the client to be __a client of the socket, not a mode of+@serve@__, so that it works against a remote host over @ssh -L@ unchanged.+This is that client, minus any terminal: @salmon-tui@ in @salmon-apps@ is+one caller, and a script or a CI step is another. It speaks in the wire+objects ('Aeson.Value') and in "Salmon.Client.Model"'s 'Event', never in+the server's Haskell types — the same generic stance the server takes+(the protocol never interprets a seed), so this client drives any salmon+binary.++Two ways to reach a server, and no third: 'newUnixClient' for the unix+socket, where permissions are the whole access story and nothing is sent+but the request, and 'newTlsClient' for @--http-tcp@'s listener, which is+only ever TLS with a bearer token (milestone 8) — so there is no+constructor for plain HTTP over TCP here either, matching the server's+'Salmon.Actions.Serve.Http.Bind'. The TLS client verifies the server's+certificate: against exactly the one in @--cacert@ when given (a+self-signed certificate is pinned, not trusted in general), against the+system's store otherwise; there is no switch that turns verification off,+since the token is sent on every request and a client that would send it+to anyone is how it leaks.++= Reads bypass the loop++'dag', 'status', 'history' and 'seedHelp' read the loop's own world through+the server and __never stand the tending machines down__: only 'command'+and 'commandAsync' put a line in the inbox, and a line is what stops+tending before it runs. A client that polls a read is therefore free; a+client that types is acting, and should say so to whoever is watching.++= The stream++'events' opens @\/events@ once and hands each event to a callback until the+callback says stop, the connection ends, or an exception escapes.+Reconnecting is the caller's, with the last 'Model.eventSeq' it saw as+@since@: the server replays what its ring still holds and sends a @gap@+first when it does not, and what to do about a gap (re-read @\/dag@) is a+decision about the caller's model, not about the connection. A keep-alive+comment line is consumed here and never reaches the callback.+-}+module Salmon.Client.Http (+    -- * A client+    Client,+    clientTarget,+    newUnixClient,+    TlsTarget (..),+    newTlsClient,+    ClientError (..),++    -- * Reads+    dag,+    status,+    history,+    seedHelp,++    -- * Commands+    command,+    commandAsync,+    Enqueued (..),++    -- * The stream+    events,+    Since,+    Filter (..),+    noFilter,++    -- * Parsing the stream+    SseBlock (..),+    splitBlocks,+    parseBlock,+) where++import Control.Exception (Exception, throwIO)+import Control.Monad (unless)+import Data.Aeson (FromJSON (..), Result (..), Value (..), eitherDecode, eitherDecodeStrict, encode, fromJSON, object, withObject, (.:), (.=))+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 as LByteString+import Data.Foldable (toList)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.X509.CertificateStore as X509+import qualified Network.Connection as Connection+import Data.Word (Word64)+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.TLS as HTTPS+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 qualified Network.TLS as TLS+import System.Posix.IO (FdOption (CloseOnExec), setFdOption)+import System.Posix.Types (Fd (..))+import Text.Read (readMaybe)++import Salmon.Actions.Serve.Events (Filter (..), noFilter)+import Salmon.Client.Model (Event (..), eventOf)++-------------------------------------------------------------------------------++-- | A connection factory for one server: a socket path, or a TLS address with its token.+data Client = Client+    { clientTarget :: String+    -- ^ what the client points at, for messages: the socket path or the base URL+    , clientBase :: String+    -- ^ what every route is appended to+    , clientHeaders :: [HTTP.Header]+    -- ^ sent with every request: the bearer token over TLS, nothing on the socket+    , clientManager :: HTTP.Manager+    }++{- | A client for the unix socket at the path. Every connection it opens is+marked close-on-exec, for the reason "Salmon.Actions.Serve.Events"'s spec+found: a child spawned from the same process inherits any descriptor not+so marked, and a stream held open by a child looks like a client that+never hung up.+-}+newUnixClient :: FilePath -> IO Client+newUnixClient path = do+    manager <-+        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)+                , -- a stream is open for as long as the loop runs+                  HTTP.managerResponseTimeout = HTTP.responseTimeoutNone+                }+    pure (Client path "http://salmon" [] manager)++-- | Where an @--http-tcp@ listener is, and what to present to it.+data TlsTarget = TlsTarget+    { tlsUrl :: String+    -- ^ @https:\/\/HOST:PORT@, a trailing slash allowed+    , tlsToken :: ByteString.ByteString+    -- ^ the content of the server's @--token-file@, trimmed+    , tlsCaFile :: Maybe FilePath+    -- ^ the certificate to trust, and only it; the system's store when 'Nothing'+    }++{- | A client for an @--http-tcp@ listener. Refuses a URL that is not+@https@ (a 'BadTarget' naming it) rather than sending a token in the+clear, and a CA file with no certificate in it. The token goes in an+@Authorization: Bearer@ header on every request, @\/events@ included.+Connections are made by @http-client-tls@ and not marked close-on-exec,+unlike 'newUnixClient''s — a caller spawning children while a stream is+open should know.+-}+newTlsClient :: TlsTarget -> IO Client+newTlsClient t = do+    let base = reverse (dropWhile (== '/') (reverse t.tlsUrl))+    req <- HTTP.parseRequest base+    unless (HTTP.secure req && HTTP.path req == "/" && ByteString.null (HTTP.queryString req)) $+        throwIO (BadTarget ("not an https://HOST:PORT address: " <> Text.pack t.tlsUrl))+    settings <- case t.tlsCaFile of+        Nothing -> pure HTTPS.tlsManagerSettings+        Just caFile -> do+            mstore <- X509.readCertificateStore caFile+            store <- maybe (throwIO (BadTarget ("no certificate in " <> Text.pack caFile))) pure mstore+            let params0 = TLS.defaultParamsClient (Char8.unpack (HTTP.host req)) ""+                params = params0{TLS.clientShared = params0.clientShared{TLS.sharedCAStore = store}}+            pure (HTTPS.mkManagerSettings (Connection.TLSSettings params) Nothing)+    manager <- HTTP.newManager settings{HTTP.managerResponseTimeout = HTTP.responseTimeoutNone}+    pure (Client base base [(HTTP.hAuthorization, "Bearer " <> t.tlsToken)] manager)++-- | A request for the route on the client's server, with its headers.+request :: Client -> String -> IO HTTP.Request+request c route = do+    req <- HTTP.parseRequest (c.clientBase <> route)+    pure req{HTTP.requestHeaders = c.clientHeaders ++ HTTP.requestHeaders req}++-- | What the server answered with when it did not answer the question.+data ClientError+    = -- | a non-2xx status, with the @error@ text the server put in the body+      Refused !Int !Text+    | -- | a 2xx answer that was not the JSON expected+      Undecodable !Text+    | -- | 'newTlsClient' was handed something it will not send a token to:+      -- not an @https@ address, or a CA file with no certificate in it+      BadTarget !Text+    deriving (Show, Eq)++instance Exception ClientError++-------------------------------------------------------------------------------+-- reads++-- | @GET \/dag@: the envelope, with @mode@, @seq@ and @nodes@.+dag :: Client -> IO Value+dag c = getJSON c "/dag"++-- | @GET \/status@: the object @status --json@ prints, plus @seq@.+status :: Client -> IO Value+status c = getJSON c "/status"++-- | @GET \/history@: the object @history --json@ prints, plus @elided@.+history :: Client -> IO Value+history c = getJSON c "/history"++-- | @GET \/help\/seed@: the binary's own @config --help@ and the command reference.+seedHelp :: Client -> IO Value+seedHelp c = getJSON c "/help/seed"++getJSON :: Client -> String -> IO Value+getJSON c route = do+    req <- request c route+    resp <- HTTP.httpLbs req c.clientManager+    decodeAnswer resp++-------------------------------------------------------------------------------+-- commands++-- | The synchronous @POST \/command@: the reports the line produced.+command :: Client -> Text -> IO [Value]+command c line = do+    v <- postLine c "/command" line+    case v of+        Array xs -> pure (toList xs)+        other -> throwIO (Undecodable ("a sync command answers with an array: " <> Text.pack (show other)))++-- | The @?async@ answer: the number the line was queued at, and the origin+-- its reports carry.+data Enqueued = Enqueued+    { enqueuedSeq :: !Word64+    , enqueuedOrigin :: !Text+    }+    deriving (Show, Eq)++instance FromJSON Enqueued where+    parseJSON = withObject "enqueued" $ \o -> Enqueued <$> o .: "seq" <*> o .: "origin"++-- | @POST \/command?async@: queued, and the number to read @\/events@ from.+commandAsync :: Client -> Text -> IO Enqueued+commandAsync c line = do+    v <- postLine c "/command?async" line+    case fromJSON v of+        Success e -> pure e+        Error err -> throwIO (Undecodable ("an async command answers with seq and origin: " <> Text.pack err))++postLine :: Client -> String -> Text -> IO Value+postLine c route line = do+    req0 <- request c route+    let req =+            req0+                { HTTP.method = "POST"+                , HTTP.requestHeaders = HTTP.requestHeaders req0 ++ [(HTTP.hContentType, "application/json")]+                , HTTP.requestBody = HTTP.RequestBodyLBS (encode (object ["line" .= line]))+                }+    resp <- HTTP.httpLbs req c.clientManager+    decodeAnswer resp++decodeAnswer :: HTTP.Response LByteString.ByteString -> IO Value+decodeAnswer resp = do+    let code = HTTP.statusCode (HTTP.responseStatus resp)+        body = HTTP.responseBody resp+    unless (code >= 200 && code < 300) $+        throwIO (Refused code (fromMaybe (Text.decodeUtf8 (LByteString.toStrict body)) (errorText body)))+    either (throwIO . Undecodable . Text.pack) pure (eitherDecode body)+  where+    -- the server's own {"error": ...} text when the body is one+    errorText body = case eitherDecode body of+        Right (Object o) | Just (String t) <- KeyMap.lookup (Key.fromText "error") o -> Just t+        _ -> Nothing++-------------------------------------------------------------------------------+-- the stream++-- | 'Nothing' for live only; @'Just' n@ for everything after @n@ the ring still holds.+type Since = Maybe Word64++{- | Open @\/events@ and hand every event to the callback until it answers+'False'. Returns normally when the callback stops it or the server ends the+stream (the loop quit); a connection error is the exception @http-client@+raises. The @gap@ event arrives like any other, with 'eventSeq' 'Nothing'.+-}+events :: Client -> Since -> Filter -> (Event -> IO Bool) -> IO ()+events c since filt onEvent = do+    req <- request c ("/events" <> query)+    HTTP.withResponse req c.clientManager $ \resp -> do+        let code = HTTP.statusCode (HTTP.responseStatus resp)+        unless (code == 200) $ do+            body <- LByteString.fromChunks <$> HTTP.brConsume (HTTP.responseBody resp)+            throwIO (Refused code (Text.decodeUtf8 (LByteString.toStrict body)))+        buf <- newIORef ByteString.empty+        let loop = do+                chunk <- HTTP.brRead (HTTP.responseBody resp)+                if ByteString.null chunk+                    then pure ()+                    else do+                        b <- readIORef buf+                        let (blocks, rest) = splitBlocks (b <> chunk)+                        writeIORef buf rest+                        more <- deliver (concatMap parseBlock blocks)+                        if more then loop else pure ()+            deliver [] = pure True+            deliver (SseComment : bs) = deliver bs+            deliver (SseEvent _ v : bs) = do+                more <- onEvent (eventOf v)+                if more then deliver bs else pure False+        loop+  where+    query = case params of+        [] -> ""+        ps -> "?" <> Text.unpack (Text.intercalate "&" ps)+    params =+        [ "since=" <> Text.pack (show n) | Just n <- [since] ]+            ++ [ "stream=" <> Text.intercalate "," (Set.toList ss) | Just ss <- [filt.filterStreams] ]+            ++ [ "origin=" <> o | Just os <- [filt.filterOrigins], o <- Set.toList os ]++-- | One block of the stream: an event with its @id@ (absent on a @gap@), or a comment.+data SseBlock+    = SseEvent !(Maybe Word64) !Value+    | SseComment+    deriving (Show, Eq)++-- | The complete blocks (ended by a blank line) in a buffer, and what 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)++{- | One block. A block whose every line is a comment is 'SseComment'; one+with a @data:@ line that is JSON is an event; anything else (an empty+block, a @data:@ line that is not JSON) is dropped, since the server never+sends one and a client has nothing to do with it.+-}+parseBlock :: ByteString.ByteString -> [SseBlock]+parseBlock block+    | null ls = []+    | all (":" `ByteString.isPrefixOf`) ls = [SseComment]+    | otherwise =+        case [eitherDecodeStrict raw | Just raw <- fmap (fieldOf "data:") ls] of+            (Right v : _) -> [SseEvent (readMaybe . Char8.unpack =<< headMay [i | Just i <- fmap (fieldOf "id:") ls]) v]+            _ -> []+  where+    ls = Char8.lines block+    fieldOf name l+        | name `ByteString.isPrefixOf` l = Just (Char8.dropWhile (== ' ') (ByteString.drop (ByteString.length name) l))+        | otherwise = Nothing+    headMay (x : _) = Just x+    headMay [] = Nothing
+ src/Salmon/Client/Model.hs view
@@ -0,0 +1,503 @@+{-# LANGUAGE OverloadedStrings #-}++{- | The client's read model: a @\/dag@ snapshot with the event stream folded+onto it, one view per node.++Milestone 6 of @specs\/generic-server.md@ says a client rebuilds the current+state as @dag ⊕ events since the dag's sequence number@. This module is+that ⊕, and nothing else: no socket, no terminal. "Salmon.Client.Http" is+what fetches the two inputs, and a terminal client (@salmon-tui@ in+@salmon-apps@) is a thin rendering of the 'Model' this produces. Keeping+the fold pure is what makes it testable against a recorded event sequence+('Test.ClientModelSpec'), and it is also what keeps the client honest about+the spec's design constraint — __the client holds no state the server does+not__: everything here is derived from @\/dag@ and @\/events@, so a restart+of the client is one @\/dag@ read, and a client that has fallen behind+('modelResync') re-reads rather than guessing.++= What is folded, and what is not++The inputs are the wire objects "Salmon.Reporter.Tagged" and+"Salmon.Actions.Serve.Events" describe, read as 'Aeson.Value': the model+takes every event as data (an 'Event' is what 'eventOf' can see in the+object — @seq@, @stream@, @kind@, @ref@, @origin@ — plus the object itself)+rather than decoding the four report sums back into Haskell. That is+deliberate: the client is generic over salmon binaries the way the server+is, and it should keep rendering a report kind it was not written for+(as its 'nodeLastKind') instead of failing to decode it.++What moves a node's view:++  * the @updown@ stream (and an @upkeep@ @acted@ wrapping one): @eval@ is+    the node being worked on, @done@ and @skip@ make it @converged@ in its+    direction, @failed@ makes it @errored@ with the error kept, @blocked@+    makes it @blocked@ — the same words @\/dag@ uses for @convergence@;+  * the @upkeep@ stream: @next-look@ carries the node's own last check+    verdict, which is the one thing the snapshot cannot keep fresh (a+    @\/dag@ read is at most one command old, and tending happens between+    commands); every other kind is recorded as the node's last event;+  * the @serve@ stream: @converge-start@\/@converge-stop@ for the loop's+    pass, @supervised@, and the two that change the __shape__ of the graph+    — @declared@ and @cleared@ — which set 'modelResync', because an event+    names nodes by 'Ref' and a declaration adds or retires nodes the model+    has never seen.++A node wanted @down@ whose @done@ arrives is dropped: the loop prunes it+after the pass, and @\/dag@ would not show it either.++= Replays are dropped, per stamp++One counter numbers everything on the stream, and a snapshot carries the+last number handed out before it was read. Every part of the model+remembers the number it is current to — each node its 'nodeSeq' (the+snapshot's, then each event's about it), the loop-level fields+('modelPass', 'modelSupervised', 'modelResync') their 'modelLoopSeq' — and+an event numbered at or below the stamp of the part it would change is+one already accounted for, so 'step' leaves that part untouched. That is+what the server's ordering relies on ("Salmon.Actions.Serve.Http" reads+the number before the world so a racing event is replayed rather than+skipped), and it is what lets a client keep folding the live stream while+a re-read snapshot is on its way: the events that land in between are+replayed onto the new snapshot and fall away.++Two stamps rather than one because the two inputs cover different things.+A snapshot says everything about the nodes and nothing about the loop —+whether a pass is running is not in @\/dag@ — so a fresh snapshot must+not swallow the @converge-stop@ of a pass whose @converge-start@ the+client already showed. 'rebase' is how a re-read snapshot joins a model+that has been folding: the nodes are the snapshot's, the loop-level+fields and their stamp are carried over. The @gap@ event has no number+and always applies.+-}+module Salmon.Client.Model (+    -- * Events+    Event (..),+    eventOf,+    RefId (..),++    -- * The model+    Model (..),+    Node (..),+    Check (..),+    Pass (..),+    fromDag,+    step,+    modelResync,+    resolve,+    rebase,++    -- * Reading it+    nodesInOrder,+    Counts (..),+    counts,+    lookupNode,++    -- * Rendering pieces+    renderNodeRow,+    renderHeader,+    renderEventLine,+    describeEvent,+) where++import Data.Aeson (Result (..), Value (..), fromJSON)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Foldable (toList)+import Data.List (foldl')+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Word (Word64)++-------------------------------------------------------------------------------+-- events++-- | A node's identity on the wire: the short tag and the full text.+data RefId = RefId+    { refShort :: !Text+    , refFull :: !Text+    }+    deriving (Show, Eq, Ord)++{- | One event as the stream carried it. The fields are what every client+needs to route the object; 'eventValue' keeps the whole thing for whatever+else a report says.+-}+data Event = Event+    { eventSeq :: !(Maybe Word64)+    -- ^ 'Nothing' only for the @gap@ event, which the server sends without one+    , eventStream :: !Text+    , eventKind :: !Text+    , eventRef :: !(Maybe RefId)+    , eventOrigin :: !(Maybe Text)+    -- ^ the origin's name, for an event produced for a command+    , eventValue :: !Value+    }+    deriving (Show, Eq)++-- | Read an event out of its wire object. Total: a shapeless object is an+-- event of kind @?@ with no ref, which the model records and moves past.+eventOf :: Value -> Event+eventOf v =+    Event+        { eventSeq = numberAt ["seq"] v+        , eventStream = fromMaybe "?" (textAt ["stream"] v)+        , eventKind = fromMaybe "?" (textAt ["kind"] v)+        , eventRef = refAt ["ref"] v+        , eventOrigin = textAt ["origin", "name"] v+        , eventValue = v+        }++-------------------------------------------------------------------------------+-- the model++-- | A node's own last word on its effect, as @next-look@ and @\/dag@ carry it.+data Check = Check+    { checkVerdict :: !Text+    -- ^ @success@\/@skipped@\/@completed@\/@failure@\/@unknown@\/@immaterial@+    , checkReason :: !(Maybe Text)+    }+    deriving (Show, Eq)++data Node = Node+    { nodeRef :: !RefId+    , nodeShorthand :: !Text+    , nodeHelp :: !Text+    , nodeNotes :: ![Text]+    , nodeDirection :: !Text+    -- ^ @up@ or @down@+    , nodeConvergence :: !Text+    -- ^ @pending@\/@stale@\/@converged@\/@errored@\/@blocked@+    , nodeCheck :: !(Maybe Check)+    , nodeOutput :: ![Text]+    -- ^ the snapshot's output ring, oldest first+    , nodeError :: !(Maybe Text)+    -- ^ the last @failed@'s error, cleared by a later @done@\/@skip@+    , nodeLastKind :: !(Maybe Text)+    -- ^ the kind of the last event about this node, and its stream+    , nodeLastSeq :: !(Maybe Word64)+    , nodeSeq :: !Word64+    -- ^ the number this view is current to: the snapshot's, then each event's+    , nodeDependencies :: ![RefId]+    , nodeDependants :: ![RefId]+    , nodePaths :: ![Text]+    }+    deriving (Show, Eq)++-- | The loop's last convergence pass as the stream told it.+data Pass+    = -- | @converge-start@: nodes to turn down, nodes to turn up+      Converging !Int !Int+    | -- | @converge-stop@: everything applied cleanly, nodes left+      Stopped !Bool !Int+    deriving (Show, Eq)++data Model = Model+    { modelMode :: !Text+    -- ^ @interactive@\/@replay@\/@following@, from the snapshot's envelope+    , modelSeq :: !Word64+    -- ^ the highest sequence number seen: the snapshot's, then each+    -- event's; the cursor to resume @\/events@ from+    , modelLoopSeq :: !Word64+    -- ^ the number the loop-level fields are current to+    , modelOrder :: ![RefId]+    -- ^ the snapshot's dependency order ('Salmon.Op.Dag.dagOrder')+    , modelNodes :: !(Map RefId Node)+    , modelPass :: !(Maybe Pass)+    , modelSupervised :: !(Maybe Bool)+    -- ^ 'Nothing' until a @supervised@ event says+    , modelLast :: !(Maybe Event)+    -- ^ the last event folded, whatever it was about+    , modelResyncReason :: !(Maybe Text)+    -- ^ why the snapshot should be re-read; cleared by 'resolve' or 'fromDag'+    }+    deriving (Show, Eq)++-- | The snapshot should be re-read: a @gap@, or a declaration changed the+-- node set. The reason is human text for a status line.+modelResync :: Model -> Maybe Text+modelResync = modelResyncReason++-- | Forget the resync request (the snapshot is being re-read).+resolve :: Model -> Model+resolve m = m{modelResyncReason = Nothing}++{- | A re-read snapshot joining a model that has been folding: the nodes,+order and mode are the fresh snapshot's; the loop-level fields, their+stamp and the last event are the old model's; the cursor is the higher of+the two; and the resync request is answered. See the module header for+why the loop's part is not simply the snapshot's.+-}+rebase :: Model -> Model -> Model+rebase old fresh =+    fresh+        { modelSeq = max old.modelSeq fresh.modelSeq+        , modelLoopSeq = old.modelLoopSeq+        , modelPass = old.modelPass+        , modelSupervised = old.modelSupervised+        , modelLast = old.modelLast+        , modelResyncReason = Nothing+        }++{- | A model from a @\/dag@ answer. 'Left' names what is missing; a @\/dag@+answer always has @nodes@ and @seq@, so a 'Left' is a wrong URL, not a+version skew.+-}+fromDag :: Value -> Either String Model+fromDag v = do+    nodes <- maybe (Left "/dag answer has no nodes array") Right (arrayAt ["nodes"] v)+    seqNo <- maybe (Left "/dag answer carries no seq") Right (numberAt ["seq"] v)+    parsed <- traverse (nodeOf seqNo) nodes+    pure+        Model+            { modelMode = fromMaybe "?" (textAt ["mode"] v)+            , modelSeq = seqNo+            , modelLoopSeq = 0+            , modelOrder = fmap nodeRef parsed+            , modelNodes = Map.fromList [(nodeRef n, n) | n <- parsed]+            , modelPass = Nothing+            , modelSupervised = Nothing+            , modelLast = Nothing+            , modelResyncReason = Nothing+            }+  where+    nodeOf :: Word64 -> Value -> Either String Node+    nodeOf seqNo n = do+        r <- maybe (Left ("a node without a ref: " <> show n)) Right (refAt ["ref"] n)+        pure+            Node+                { nodeRef = r+                , nodeShorthand = fromMaybe "?" (textAt ["shorthand"] n)+                , nodeHelp = fromMaybe "" (textAt ["help"] n)+                , nodeNotes = maybe [] (mapMaybe asText) (arrayAt ["notes"] n)+                , nodeDirection = fromMaybe "?" (textAt ["direction"] n)+                , nodeConvergence = fromMaybe "?" (textAt ["convergence"] n)+                , nodeCheck = checkAt ["status", "check"] n+                , nodeOutput = maybe [] (mapMaybe asText) (arrayAt ["status", "output"] n)+                , nodeError = Nothing+                , nodeLastKind = Nothing+                , nodeLastSeq = Nothing+                , nodeSeq = seqNo+                , nodeDependencies = maybe [] (mapMaybe (refAt [])) (arrayAt ["dependencies"] n)+                , nodeDependants = maybe [] (mapMaybe (refAt [])) (arrayAt ["dependants"] n)+                , nodePaths = maybe [] (mapMaybe asText) (arrayAt ["paths"] n)+                }++{- | Fold one event in. Total; an event already accounted for (numbered at+or below the stamp of the part it would change, see the module header)+leaves that part as it was. Otherwise the cursor moves to the event's+number, the node the event is about is updated, and the loop-level fields+follow the @serve@ stream. An event that changes nothing still becomes+'modelLast' if it is new to the cursor.+-}+step :: Model -> Event -> Model+step m0 e+    | Just s <- e.eventSeq, s <= m0.modelSeq = byStream m0+    | otherwise = byStream (m0{modelSeq = fromMaybe m0.modelSeq e.eventSeq, modelLast = Just e})+  where+    byStream m = case (e.eventStream, e.eventKind) of+        ("server", "gap") -> m{modelResyncReason = Just ("events " <> fromText (numberAt ["from"] e.eventValue) <> " fell off the ring")}+        ("server", _) -> m+        ("serve", "declared") ->+            onLoop m $ \l -> l{modelResyncReason = Just ("epoch " <> fromText (numberAt ["epoch"] e.eventValue) <> " declared " <> fromMaybe "?" (textAt ["direction"] e.eventValue))}+        ("serve", "cleared") -> onLoop m $ \l -> l{modelResyncReason = Just "every seed retired"}+        ("serve", "converge-start") ->+            onLoop m $ \l -> l{modelPass = Just (Converging (intAt ["down"] e.eventValue) (intAt ["up"] e.eventValue))}+        ("serve", "converge-stop") ->+            onLoop m $ \l -> l{modelPass = Just (Stopped (fromMaybe False (boolAt ["ok"] e.eventValue)) (intAt ["remaining"] e.eventValue))}+        ("serve", "supervised") -> onLoop m $ \l -> l{modelSupervised = boolAt ["on"] e.eventValue}+        ("serve", _) -> m+        ("updown", k) -> maybe m (\r -> onNode r (settle k e.eventValue) m) e.eventRef+        -- an @acted@ wraps what the tending machine did in the pass's+        -- vocabulary; the inner object carries the ref+        ("upkeep", "acted") ->+            case KeyMap.lookup "report" =<< asObject e.eventValue of+                Just inner | Just r <- refAt ["ref"] inner ->+                    let k = fromMaybe "?" (textAt ["kind"] inner)+                     in onNode r (updown k inner . touch ("acted " <> k)) m+                _ -> m+        ("upkeep", "next-look") ->+            maybe m (\r -> onNode r (\n -> (touch e.eventKind n){nodeCheck = checkAt ["check"] e.eventValue}) m) e.eventRef+        ("upkeep", k) -> maybe m (\r -> onNode r (touch k) m) e.eventRef+        _ -> m++    -- the loop-level fields, unless the event is at or below their stamp+    onLoop :: Model -> (Model -> Model) -> Model+    onLoop m f = case e.eventSeq of+        Just s | s <= m.modelLoopSeq -> m+        _ -> (f m){modelLoopSeq = fromMaybe m.modelLoopSeq e.eventSeq}++    -- update the node (unless the event is at or below its stamp), or+    -- drop it: a node wanted down that a pass has brought down is pruned+    -- by the loop after the pass, and /dag would no longer show it+    onNode :: RefId -> (Node -> Node) -> Model -> Model+    onNode r f m = case Map.lookup r m.modelNodes of+        Nothing -> m+        Just n+            | Just s <- e.eventSeq, s <= n.nodeSeq -> m+            | otherwise ->+                let n' = (f n){nodeSeq = fromMaybe n.nodeSeq e.eventSeq}+                 in if n'.nodeDirection == "down" && n'.nodeConvergence == "converged" && n'.nodeLastKind `elem` [Just "done", Just "acted done"]+                        then m{modelNodes = Map.delete r m.modelNodes, modelOrder = filter (/= r) m.modelOrder}+                        else m{modelNodes = Map.insert r n' m.modelNodes}++    touch :: Text -> Node -> Node+    touch k n = n{nodeLastKind = Just k, nodeLastSeq = e.eventSeq}++    -- the pass's verdict on a node, in /dag's convergence words+    settle :: Text -> Value -> Node -> Node+    settle k v n = updown k v (touch k n)++    updown :: Text -> Value -> Node -> Node+    updown k v n = case k of+        "done" -> n{nodeConvergence = "converged", nodeError = Nothing}+        "skip" -> n{nodeConvergence = "converged", nodeError = Nothing}+        "failed" -> n{nodeConvergence = "errored", nodeError = textAt ["error"] v}+        "blocked" -> n{nodeConvergence = "blocked"}+        _ -> n++-------------------------------------------------------------------------------+-- reading it++-- | The nodes in the snapshot's dependency order.+nodesInOrder :: Model -> [Node]+nodesInOrder m = mapMaybe (`Map.lookup` m.modelNodes) m.modelOrder++lookupNode :: RefId -> Model -> Maybe Node+lookupNode r m = Map.lookup r m.modelNodes++data Counts = Counts+    { countConverged :: !Int+    , countErrored :: !Int+    , countTotal :: !Int+    }+    deriving (Show, Eq)++counts :: Model -> Counts+counts m =+    foldl' tally (Counts 0 0 0) (Map.elems m.modelNodes)+  where+    tally :: Counts -> Node -> Counts+    tally (Counts c e t) n =+        Counts+            (c + fromEnum (n.nodeConvergence == "converged"))+            (e + fromEnum (n.nodeConvergence == "errored"))+            (t + 1)++-------------------------------------------------------------------------------+-- rendering pieces: the text a terminal shows, kept here so it is testable++{- | One line per node, the columns @salmon-tui@ shows: ref, shorthand,+direction, convergence, last check, last event. Widths are fixed for the+first four so the table reads as one; the last two are open-ended.+-}+renderNodeRow :: Node -> Text+renderNodeRow n =+    Text.unwords+        [ Text.justifyLeft 10 ' ' n.nodeRef.refShort+        , Text.justifyLeft 22 ' ' (Text.take 22 n.nodeShorthand)+        , Text.justifyLeft 4 ' ' n.nodeDirection+        , Text.justifyLeft 9 ' ' n.nodeConvergence+        , Text.justifyLeft 12 ' ' (maybe "-" renderCheck n.nodeCheck)+        , lastEvent+        ]+  where+    lastEvent = case (n.nodeLastKind, n.nodeLastSeq) of+        (Nothing, _) -> "-"+        (Just k, ms) -> k <> maybe "" (\s -> " #" <> Text.pack (show s)) ms <> maybe "" (": " <>) n.nodeError++renderCheck :: Check -> Text+renderCheck c = c.checkVerdict++-- | The header line: socket, mode, seq, the pass, and the counts.+renderHeader :: Text -> Model -> Text+renderHeader socket m =+    Text.unwords+        [ socket+        , "mode=" <> m.modelMode+        , "seq=" <> Text.pack (show m.modelSeq)+        , "converged=" <> tshow c.countConverged+        , "errored=" <> tshow c.countErrored+        , "total=" <> tshow c.countTotal+        , maybe "" renderPass m.modelPass+        , maybe "" (\on -> if on then "supervising" else "not supervising") m.modelSupervised+        ]+  where+    c = counts m+    tshow = Text.pack . show+    renderPass (Converging d u) = "converging(" <> tshow d <> " down, " <> tshow u <> " up)"+    renderPass (Stopped ok left) = (if left == 0 then "converged" else "incomplete(" <> tshow left <> " left)") <> (if ok then "" else "+failure")++-- | An event as one line: its number, stream, kind, and what it is about.+renderEventLine :: Event -> Text+renderEventLine e =+    Text.unwords+        [ maybe "#-" (\s -> "#" <> Text.pack (show s)) e.eventSeq+        , e.eventStream+        , e.eventKind+        , describeEvent e+        ]++-- | The words after the kind: the node's short ref, or the loop-level+-- fields worth a glance.+describeEvent :: Event -> Text+describeEvent e = case e.eventRef of+    Just r -> r.refShort <> maybe "" (" " <>) (textAt ["node", "shorthand"] e.eventValue)+    Nothing -> Text.unwords (mapMaybe (\k -> (\t -> k <> "=" <> t) <$> scalarAt [k] e.eventValue) ["line", "epoch", "direction", "nodes", "down", "up", "ok", "remaining", "from", "error", "on"])++-------------------------------------------------------------------------------+-- reading JSON, totally++asObject :: Value -> Maybe (KeyMap.KeyMap Value)+asObject (Object o) = Just o+asObject _ = Nothing++asText :: Value -> Maybe Text+asText (String t) = Just t+asText _ = Nothing++at :: [Text] -> Value -> Maybe Value+at [] v = Just v+at (k : ks) (Object o) = KeyMap.lookup (Key.fromText k) o >>= at ks+at _ _ = Nothing++textAt :: [Text] -> Value -> Maybe Text+textAt ks v = at ks v >>= asText++numberAt :: [Text] -> Value -> Maybe Word64+numberAt ks v = case fromJSON <$> at ks v of+    Just (Success n) -> Just n+    _ -> Nothing++intAt :: [Text] -> Value -> Int+intAt ks v = maybe 0 fromIntegral (numberAt ks v)++boolAt :: [Text] -> Value -> Maybe Bool+boolAt ks v = case at ks v of+    Just (Bool b) -> Just b+    _ -> Nothing++arrayAt :: [Text] -> Value -> Maybe [Value]+arrayAt ks v = case at ks v of+    Just (Array xs) -> Just (toList xs)+    _ -> Nothing++refAt :: [Text] -> Value -> Maybe RefId+refAt ks v = RefId <$> textAt (ks ++ ["short"]) v <*> textAt (ks ++ ["full"]) v++checkAt :: [Text] -> Value -> Maybe Check+checkAt ks v = Check <$> textAt (ks ++ ["verdict"]) v <*> pure (textAt (ks ++ ["reason"]) v)++scalarAt :: [Text] -> Value -> Maybe Text+scalarAt ks v = case at ks v of+    Just (String t) -> Just t+    Just (Number n) -> Just $ Text.pack $ case fromJSON (Number n) of+        Success (i :: Integer) -> show i+        _ -> show n+    Just (Bool b) -> Just (if b then "true" else "false")+    _ -> Nothing++fromText :: Maybe Word64 -> Text+fromText = maybe "?" (Text.pack . show)
+ src/Salmon/Op/Concurrency.hs view
@@ -0,0 +1,65 @@+{- | A single global knob capping how many nodes' @check@\/@up@\/@down@ run+at once across one traversal (R6 in+@specs/per-node-state-machines-remaining.md@).++"Salmon.Actions.Concurrent" runs one thread per node and lets 'STM' order+them: a node's thread blocks on its neighbours settling and then, once+unblocked, runs its own work immediately. That is deliberately unbounded —+the only thing standing between two nodes and running at once is an edge or a+collection (see the module's own header) — which is fine for two nodes+genuinely fighting over one resource (an edge fixes that) and is not what+this module is for. What it does not help with is unbounded /width/: a wide+DAG (many independent leaves — a large batch of files, say) spawns one+thread per leaf, and every one of those threads reaches its own 'IO' action+at once, which is a problem of machine capacity (CPU, file descriptors, an+outbound connection limit) rather than of any particular pair of nodes+sharing a resource.++A 'ConcurrencyLimit' is a cap on that width, orthogonal to the DAG's edges:+it says nothing about /order/ (edges and 'Salmon.Op.Status.waitStability'+still own that entirely) and everything about how many nodes may be+/inside their own action/ at the same moment. Optional throughout — a caller+that passes 'Nothing' pays nothing, not even a semaphore allocation, so+nothing about existing callers changes until one opts in.+-}+module Salmon.Op.Concurrency (+    ConcurrencyLimit,+    newConcurrencyLimit,+    withConcurrencyLimit,+) where++import Control.Concurrent.QSem (QSem, newQSem, signalQSem, waitQSem)+import Control.Exception (bracket_)++-- | A cap on how many actions gated by 'withConcurrencyLimit' may run at+-- once, shared across everyone holding this value — so one limit passed to+-- both a teardown pass and a bring-up pass bounds the two of them together,+-- not each separately.+newtype ConcurrencyLimit = ConcurrencyLimit QSem++{- | @n@ must be positive: a limit of zero would mean "run nothing", which+is not what a concurrency cap is for (that is what excluding every node from+the pass, or not running the pass at all, already says) and would instead+deadlock every gated action against a semaphore that can never be signalled.+Throws rather than silently building a limit nothing can ever pass.+-}+newConcurrencyLimit :: Int -> IO ConcurrencyLimit+newConcurrencyLimit n+    | n <= 0 = error ("Salmon.Op.Concurrency.newConcurrencyLimit: limit must be positive, got " <> show n)+    | otherwise = ConcurrencyLimit <$> newQSem n++{- | Run an 'IO' action, holding one slot of the limit for its duration.+'Nothing' means unbounded, matching the driver's behaviour before this+module existed.++Held only around the action itself, never around anything that waits on a+neighbour: "Salmon.Actions.Concurrent" already guarantees a node acquires no+slot until every node it depends on has settled and released its own, so+two nodes never hold a slot each while waiting on one another through this+mechanism — the only thing a wait can be for is a free slot, not another+node's turn.+-}+withConcurrencyLimit :: Maybe ConcurrencyLimit -> IO a -> IO a+withConcurrencyLimit Nothing act = act+withConcurrencyLimit (Just (ConcurrencyLimit sem)) act =+    bracket_ (waitQSem sem) (signalQSem sem) act
+ src/Salmon/Op/Configure.hs view
@@ -0,0 +1,12 @@+module Salmon.Op.Configure where++{- | Configure is a newtype wrapper around functions that effectfully generate+ a value from an input. The type is so general and that we legitimately question why we need a dedicated type.+ Well, in Salmon we want to capture the specific effect turning a+ configuration seed into an operation graph.  While operations are+ IO-heavy in nature, we may not want the configuration step to be IO-bearing.+ And, when both the configuration and the execution steps are in IO, we want them+ to be treated as two separate and hermetic steps.+-}+newtype Configure m seed a+    = Configure {gen :: seed -> m a}
+ src/Salmon/Op/Dag.hs view
@@ -0,0 +1,499 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | The collapse of an expanded 'Cofree' 'Graph' into a flat, 'Ref'-keyed DAG:+one representative per node, both adjacency directions, and a record of the+representatives that were replaced on the way.++This used to live inside "Salmon.Actions.UpDown".'Salmon.Actions.UpDown.downTreeWith',+which needed it for one reason only: teardown ordering ("a node is free once+its /last/ dependant is done") cannot be read off a structure that only knows+each node's predecessors. Lifting it out is what+@specs\/per-node-state-machines.md@ calls the /magma/ plus /precedence/, and+it is a prerequisite for everything else there, because the whole model in+that document is derived from folding declared graphs into state rather than+from walking one graph.++Three properties matter and none of them hold for the 'Cofree' itself:++* __It is keyed by 'Ref'.__ So folding a /second/ graph into an existing 'Dag'+  is a merge rather than a replacement ('mergeDag'), which is what lets a+  long-running driver take new declarations without rebuilding everything.+* __It carries dependants as well as dependencies.__ 'dagDependants' is+  maintained as edges are recorded, not recovered by a separate counting pass.+* __It is pure.__ 'expand' is the only effectful step; everything here is a+  fold over its result, so it can be unit-tested without running a node.++= Representatives, and what happens when two collide++A 'Ref' is /location-addressed/: 'Salmon.Op.Ref.mkRef' hashes a kind tag plus+an author-chosen identity key, and that key is deliberately not the node's+behaviour (@filecontents@ keys on the path alone). So an equal 'Ref' means+"the same effect site", not an equal node, and two declarations writing+different bytes to the same path collapse to one entry here.++__Last writer wins, and the loser is recorded.__ Last rather than first+because re-declaring a node is how an operator changes it, and first-wins+would make the newer declaration silently inert. Recorded because this fold is+the first thing in salmon that /can/ notice: @upTree@ dedupes by 'Ref' too,+but per-traversal and discarded at the end, so two declarations fighting over+one file is invisible today.++Deciding whether a replacement is a genuine conflict needs an equality, and+'Salmon.Builtin.Extension.Extension' has none — @up :: IO ()@ is not 'Eq'. So+'foldDag' takes the test as an argument, and 'sameRepresentative' is the+best one available: 'Representative', i.e. the fields that /are/ comparable.+That is a heuristic — it misses a node whose action changed behind an+identical description, and 'Dynamic' only renders its type — but it is+strictly more than the zero available today.++Note this needs no @instance Semigroup Extension@: choosing a representative+is not combining two.+-}+module Salmon.Op.Dag (+    -- * The structure+    Dag (..),+    emptyDag,+    dagOrder,+    dependenciesOf,+    dependantsOf,+    dagEdges,+    representativeOf,+    roots,+    leaves,+    stuck,++    -- * Building one+    foldDag,+    mergeDag,+    fromMagma,+    record,+    collapseInto,+    addEdge,++    -- * Colliding representatives+    Conflict (..),+    Representative (..),+    representative,+    sameRepresentative,+) where++import Control.Comonad.Cofree (Cofree (..))+import Data.Dynamic (Dynamic, fromDynamic)+import Data.Foldable (toList)+import Data.List (foldl')+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import GHC.Records (HasField (..))++import Salmon.Op.Actions+import Salmon.Op.Graph+import Salmon.Op.OpGraph+import Salmon.Op.Ref+import Salmon.Op.Supervision (Supervision)++-------------------------------------------------------------------------------++{- | Every node seen so far, keyed by 'Ref', with both adjacency directions.++Invariant: every 'Ref' in 'dagOrder' is a key of 'dagNodes',+'dagDependencies' and 'dagDependants' (possibly mapping to an empty edge+list), and the three maps have exactly the keys 'dagOrder' lists.+-}+data Dag ext = Dag+    { dagNodes :: !(Map Ref (Act ext))+    -- ^ The magma: the current representative of each node — its+    -- 'Salmon.Op.Actions.shorthand' and its extension, never an+    -- @Op@. Deliberately not an @Op@: @Op@'s @predecessors@ field retains the+    -- whole expanded closure, so a map of them would retain every graph ever+    -- folded and bound nothing at all. All structure lives in the two+    -- adjacency maps.+    , dagDependencies :: !(Map Ref [Ref])+    -- ^ What each node depends on: its /effective/ predecessors, i.e. the+    -- nearest 'Ref'-carrying nodes below it, descending through 'Actionless'+    -- glue. Deduplicated, in first-seen order.+    , dagDependants :: !(Map Ref [Ref])+    -- ^ The transpose: what depends on each node. This is the direction a+    -- teardown needs and the one the 'Cofree' cannot answer.+    , dagOrderRev :: ![Ref]+    -- ^ 'dagOrder' reversed, which is how it is accumulated. Use 'dagOrder'.+    , dagConflicts :: ![Conflict ext]+    -- ^ Representatives replaced by a /differing/ one, newest first. Empty+    -- for the overwhelmingly common case of one node reached by several+    -- paths, which replaces a representative with an indistinguishable one.+    }++-- | A representative that lost to last-writer-wins, and the one that beat it.+data Conflict ext = Conflict+    { conflictRef :: !Ref+    , conflictKept :: !(Act ext)+    -- ^ The representative that replaced 'conflictReplaced'. Note a /later/+    -- write may have replaced this one in turn; @'dagNodes' dag '!'+    -- 'conflictRef'@ is the final answer.+    , conflictReplaced :: !(Act ext)+    }++emptyDag :: Dag ext+emptyDag = Dag Map.empty Map.empty Map.empty [] []++{- | Nodes in the order they were first seen — root-first, for a fold of a+single rooted graph. Only ever a tie-break: it is what makes a traversal that+is otherwise order-independent (which nodes are ready at the same time)+deterministic, and it is the key order of all three maps.+-}+dagOrder :: Dag ext -> [Ref]+dagOrder = reverse . dagOrderRev++-- | Total: a 'Ref' the 'Dag' has never seen simply depends on nothing.+dependenciesOf :: Dag ext -> Ref -> [Ref]+dependenciesOf dag r = Map.findWithDefault [] r (dagDependencies dag)++-- | Total, as 'dependenciesOf'. An empty list means the node is a teardown+-- starting point: nothing is standing on it.+dependantsOf :: Dag ext -> Ref -> [Ref]+dependantsOf dag r = Map.findWithDefault [] r (dagDependants dag)++{- | Every edge as a flat @(dependency, dependant)@ set — the shape+"Salmon.Op.Ledger" keeps per declaration, where it has to be unionable and+retractable rather than walkable.+-}+dagEdges :: Dag ext -> Set (Ref, Ref)+dagEdges dag =+    Set.fromList+        [ (d, r)+        | (r, ds) <- Map.toList (dagDependencies dag)+        , d <- ds+        ]++representativeOf :: Dag ext -> Ref -> Maybe (Act ext)+representativeOf dag r = Map.lookup r (dagNodes dag)++-- | The nodes nothing depends on, in first-seen order — where a teardown+-- starts, and (for a fold of a single rooted graph) normally just the root.+roots :: Dag ext -> [Ref]+roots dag = [r | r <- dagOrder dag, null (dependantsOf dag r)]++-- | The nodes that depend on nothing, in first-seen order — where a bring-up+-- starts. The mirror of 'roots', and the reason both adjacency directions are+-- kept rather than one being recovered on demand.+leaves :: Dag ext -> [Ref]+leaves dag = [r | r <- dagOrder dag, null (dependenciesOf dag r)]++{- | The nodes that can never become ready: everything on a cycle, and+everything behind one.++@waitsOn@ is what a node waits for in the direction of interest —+'dependenciesOf' going up, 'dependantsOf' coming down. Kahn's algorithm, and+what is left over when it runs out of ready nodes is the answer.++Worth having because a 'Dag' assembled from a flat edge set /can/ describe a+cycle, unlike one folded from an expanded 'Control.Comonad.Cofree.Cofree':+two declarations can each contribute one leg of it. A driver that waits for+neighbours would wait forever on such a node, so it needs to know up front+which nodes those are rather than discovering it by hanging.+-}+stuck :: (Dag ext -> Ref -> [Ref]) -> Dag ext -> Set Ref+stuck waitsOn dag = go (Set.fromList (dagOrder dag))+  where+    go remaining =+        let ready =+                Set.filter+                    (\r -> all (`Set.notMember` remaining) (waitsOn dag r))+                    remaining+         in if Set.null ready+                then remaining+                else go (remaining `Set.difference` ready)++-------------------------------------------------------------------------------++{- | Collapse an expanded graph.++The walk visits every occurrence of a node, so the edge sets are the union+over all of them and the representative is the last one seen. It does not+prune already-seen 'Ref's the way the collapse inside @downTreeWith@ used to:+that pruning dropped the edges of every occurrence after the first, which is+exactly what a merge must not do. The cost is a full walk of the expanded+'Cofree' — the same cost the old tree-walking @upTree@ paid before milestone+4 moved it onto this module, and 'expand' before it.++The first argument decides whether replacing a representative is worth+reporting: it answers "are these two the same node?", so 'True' records no+'Conflict'. Pass 'sameRepresentative' unless you have something better; pass+@\\_ _ -> True@ to opt out of conflict detection entirely.+-}+foldDag ::+    forall m ext.+    (HasField "ref" ext Ref) =>+    (Act ext -> Act ext -> Bool) ->+    Cofree Graph (OpGraph m (Actions ext)) ->+    Dag ext+foldDag same = go emptyDag+  where+    go ::+        Dag ext ->+        Cofree Graph (OpGraph m (Actions ext)) ->+        Dag ext+    go dag (x :< g) =+        case x.node of+            Actionless -> foldl' go dag (effPreds g)+            Actions act ->+                let aref = getField @"ref" act.extension+                    preds = effPreds g+                    predRefs = nubOrd [pr | p <- preds, Just pr <- [refOf p]]+                 in foldl' go (record same aref act predRefs dag) preds++    -- The effective predecessors of a node: the nearest 'Ref'-carrying+    -- subtrees below it, descending through 'Actionless' nodes, which are+    -- structural glue with no identity and nothing to run.+    effPreds ::+        Graph (Cofree Graph (OpGraph m (Actions ext))) ->+        [Cofree Graph (OpGraph m (Actions ext))]+    effPreds g = concatMap pick (toList g)+      where+        pick c@(x :< g') =+            case x.node of+                Actions _ -> [c]+                Actionless -> effPreds g'++    refOf :: Cofree Graph (OpGraph m (Actions ext)) -> Maybe Ref+    refOf (x :< _) =+        case x.node of+            Actions act -> Just (getField @"ref" act.extension)+            Actionless -> Nothing++{- | Add one node and its outgoing dependency edges, last-writer-wins.++Idempotent in the edges (they are a set) but not in the representative, which+is the point: this is where a re-declaration takes over a node.+-}+record ::+    (Act ext -> Act ext -> Bool) ->+    Ref ->+    Act ext ->+    [Ref] ->+    Dag ext ->+    Dag ext+record same aref act predRefs dag =+    Dag+        { dagNodes = Map.insert aref act (dagNodes dag)+        , dagDependencies = foldl' addDependency deps0 predRefs+        , dagDependants = foldl' addDependant dependants0 predRefs+        , dagOrderRev = order'+        , dagConflicts = conflicts'+        }+  where+    previous = Map.lookup aref (dagNodes dag)++    conflicts'+        | Just old <- previous, not (same old act) =+            Conflict aref act old : dagConflicts dag+        | otherwise = dagConflicts dag++    order'+        | Map.member aref (dagNodes dag) = dagOrderRev dag+        | otherwise = aref : dagOrderRev dag++    -- every node is a key of both maps, even with no edges either way.+    deps0 = Map.insertWith (\_ old -> old) aref [] (dagDependencies dag)+    dependants0 = Map.insertWith (\_ old -> old) aref [] (dagDependants dag)++    addDependency m d = Map.insertWith snoc aref [d] (Map.insertWith (\_ old -> old) d [] m)+    addDependant m d = Map.insertWith snoc d [aref] m++    -- append-if-absent, keeping first-seen order.+    snoc [new] old+        | new `elem` old = old+        | otherwise = old <> [new]+    snoc new old = old <> filter (`notElem` old) new++{- | Rebuild a 'Dag' from a magma and a flat edge set — the inverse of+'dagEdges', and how a driver that keeps nodes and precedence separately (as+"Salmon.Op.Ledger" does, because edges have to be retractable there) gets+back something it can walk.++Restricted to the magma: an edge naming a node the magma no longer holds is+dropped rather than resurrecting a node with no representative. 'dagOrder' is+the magma's key order, which is arbitrary but stable — the walk this feeds is+order-independent apart from tie-breaks.+-}+fromMagma :: Map Ref (Act ext) -> Set (Ref, Ref) -> Dag ext+fromMagma magma edges = foldl' add emptyDag (Map.keys magma)+  where+    -- \_ _ -> True: these representatives are already the survivors of+    -- whatever fold produced the magma, so there is no collision left to+    -- report here.+    add dag r = record (\_ _ -> True) r (magma Map.! r) (deps r) dag++    deps :: Ref -> [Ref]+    deps r = Map.findWithDefault [] r incoming++    incoming :: Map Ref [Ref]+    incoming =+        Map.fromListWith+            (flip (<>))+            [ (dependant, [dependency])+            | (dependency, dependant) <- Set.toList edges+            , Map.member dependency magma+            , Map.member dependant magma+            ]++{- | Replace a set of nodes with one node that stands in for all of them,+redirecting every edge that touched a member onto the replacement.++This is what a collection rewrite needs and the only structural edit this+module offers: "twenty @apt-get install@ nodes become one @apt-get install@+node, and whatever depended on any of them now depends on that one". Edges+purely between members collapse to self-edges and are dropped, which is the+whole reason this cannot be done by editing the magma alone.++The replacement takes the position of the first member in 'dagOrder', so a+collection lands where its members were rather than at the end. If no member+is present the 'Dag' is returned unchanged — a rewrite that finds nothing to+do is a no-op, not an empty node.+-}+collapseInto :: Ref -> Act ext -> Set Ref -> Dag ext -> Dag ext+collapseInto into act members dag+    | Set.null present = dag+    | otherwise =+        Dag+            { dagNodes = Map.insert into act survivors+            , dagDependencies = Map.map (nubOrd . fmap rename) keptDeps+            , dagDependants = transposeOf (Map.map (nubOrd . fmap rename) keptDeps)+            , dagOrderRev = reverse order'+            , dagConflicts = dagConflicts dag+            }+  where+    present = Set.intersection members (Map.keysSet (dagNodes dag))+    survivors = Map.withoutKeys (dagNodes dag) present++    rename r = if Set.member r present then into else r++    -- every surviving node's dependencies, with members renamed and the+    -- resulting self-edges dropped; the replacement inherits the union of its+    -- members' own dependencies.+    keptDeps :: Map Ref [Ref]+    keptDeps =+        Map.insert into inherited $+            Map.mapMaybeWithKey+                ( \r ds ->+                    if Set.member r present+                        then Nothing+                        else Just [d | d <- ds, rename d /= r]+                )+                (dagDependencies dag)++    inherited =+        [ d+        | m <- Set.toList present+        , d <- Map.findWithDefault [] m (dagDependencies dag)+        , not (Set.member d present)+        ]++    order' =+        case break (`Set.member` present) (dagOrder dag) of+            (before, []) -> before <> [into]+            (before, _ : after) -> before <> [into] <> filter (not . (`Set.member` present)) after++-- | Add one precedence edge, @(dependency, dependant)@. Both ends must+-- already be nodes; an edge to a node the magma does not hold is ignored,+-- matching 'fromMagma'.+addEdge :: (Ref, Ref) -> Dag ext -> Dag ext+addEdge (dependency, dependant) dag+    | not (Map.member dependency (dagNodes dag)) = dag+    | not (Map.member dependant (dagNodes dag)) = dag+    | otherwise =+        let deps' = Map.adjust (\ds -> nubOrd (ds <> [dependency])) dependant (dagDependencies dag)+         in dag{dagDependencies = deps', dagDependants = transposeOf deps'}++-- | Invert a dependency map into a dependant map. Left-biased 'Map.union' so+-- the computed entry wins; the right-hand map only supplies the empty list+-- for nodes nothing depends on, which have to stay keys.+transposeOf :: Map Ref [Ref] -> Map Ref [Ref]+transposeOf deps =+    Map.union+        (Map.fromListWith (flip (<>)) [(d, [r]) | (r, ds) <- Map.toList deps, d <- ds])+        (Map.map (const []) deps)++{- | Fold the right 'Dag' into the left one: representatives from the right+win, edges and order accumulate. This is how a second declaration joins a+running world.+-}+mergeDag :: (Act ext -> Act ext -> Bool) -> Dag ext -> Dag ext -> Dag ext+mergeDag same into from = foldl' step into (dagOrder from)+  where+    step dag r =+        case representativeOf from r of+            Nothing -> dag+            Just act -> record same r act (dependenciesOf from r) dag++-------------------------------------------------------------------------------++{- | The part of a node two representatives can actually be compared on.++Everything an 'Salmon.Builtin.Extension.Extension' is /for/ — @up@, @check@,+@down@ — is a function and therefore outside any equality, so this is the+whole of the available evidence. 'Data.Dynamic.Dynamic' renders as its type+alone by default, which would make two 'Salmon.Op.Supervision.Supervision'+dynamics with different restart policies compare equal here — 'showDynamic'+special-cases 'Salmon.Op.Supervision.Supervision' to render its 'Show'+instance instead, precisely so that this comparison (and so adoption, see+"Salmon.Actions.Upkeep"'s @startUpkeep@) can see a changed policy. Every+other 'Dynamic' payload still renders as its type name alone.+-}+data Representative = Representative+    { repShorthand :: !ShortHand+    , repHelp :: !Text+    , repNotes :: ![Text]+    , repDynamics :: ![String]+    }+    deriving (Show, Eq)++{- | Render one 'Dynamic' for 'Representative' comparison: by value where a+type's value matters to identity ('Salmon.Op.Supervision.Supervision', so a+changed policy is a changed representative — see (I5) in+@specs\/per-node-state-machines-remaining.md@), by type name otherwise+(the 'Dynamic' default, e.g. 'Salmon.Builtin.Nodes.Debian.Package.Package'+dynamics, whose identity 'foldDag' does not need to track this way).+-}+showDynamic :: Dynamic -> String+showDynamic d = maybe (show d) show (fromDynamic d :: Maybe Supervision)++representative ::+    ( HasField "help" ext Text+    , HasField "notes" ext [Text]+    , HasField "dynamics" ext [Dynamic]+    ) =>+    Act ext ->+    Representative+representative act =+    Representative+        { repShorthand = act.shorthand+        , repHelp = getField @"help" act.extension+        , repNotes = getField @"notes" act.extension+        , repDynamics = fmap showDynamic (getField @"dynamics" act.extension)+        }++-- | The default conflict test for 'foldDag': equality on 'Representative'.+sameRepresentative ::+    ( HasField "help" ext Text+    , HasField "notes" ext [Text]+    , HasField "dynamics" ext [Dynamic]+    ) =>+    Act ext ->+    Act ext ->+    Bool+sameRepresentative a b = representative a == representative b++-------------------------------------------------------------------------------++-- | order-preserving dedup.+nubOrd :: (Ord b) => [b] -> [b]+nubOrd = go Set.empty+  where+    go _ [] = []+    go s (y : ys)+        | Set.member y s = go s ys+        | otherwise = y : go (Set.insert y s) ys
+ src/Salmon/Op/Ledger.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE ScopedTypeVariables #-}++{- | What each declaration still wants: a set of nodes and a set of edges per+declaration, and nothing else.++This is the second half of @specs\/per-node-state-machines.md@'s "four+structures" — "Salmon.Op.Dag" holds what a node /is/, and this holds who+still wants it. Together they replace keeping a per-declaration graph around,+which is what "Salmon.Actions.Serve" used to do and what made its storage+grow with the shape of what had been declared rather than with how much was+declared.++= Why a set and not a count++Refcounting each node is the tempting implementation and it is wrong in four+separate ways that a set gets structurally:++* a node reached by several paths within one graph double-counts — here it is+  a 'Data.Set.Set', so one membership;+* a @down@ of something never up drives a count negative — here a retraction+  of an absent key is a no-op;+* re-declaring the same seed takes its count to 2, so one @down@ strands it+  up — here the same key replaces, rather than adds;+* two declarations wanting one node must not cancel each other out — here+  they union, and the node leaves when the last set does.++The one thing counting buys is @O(1)@ lookup per node, which is not worth+having: declarations are rare (a human, or a control plane, types them),+while node state changes are the hot path and never touch the ledger at all.+So 'desired' is recomputed when a declaration changes, and memoised only if+it ever shows up in a profile.++= Why edges, and why retraction retires rather than deletes++Both are the same answer: edges have to be retractable, and a retracted+declaration's edges are needed /after/ it is retracted.++Needed after, because retracting is exactly when an edge matters most. Given+@A@ depends on @B@, both wanted down, that edge is the whole of what says+@A@ comes down before @B@ does; delete the contribution outright and the+teardown order goes with it. Hence 'contribLive': 'retract' clears the flag,+which takes the contribution out of 'desired' while leaving its edges in+'precedenceOf', and 'collect' drops it only once none of its nodes is still+standing.++Retractable, because a stale edge is not inert. In the one-shot traversals a+leftover edge would at worst re-walk something; in the supervised model the+spec builds on this, a stale @A → B@ where @B@ is no longer wanted leaves+@A@ waiting on a node that has settled and will never move again — a silent+deadlock, with no report and no failure, which is strictly worse than the+'Salmon.Actions.UpDown.Blocked' a traversal would have produced.+-}+module Salmon.Op.Ledger (+    -- * The structure+    Edge,+    Contribution (..),+    Ledger,+    emptyLedger,+    contribution,++    -- * Folding declarations in+    declare,+    retract,+    retractAll,+    retractOthers,++    -- * Reading it back+    desired,+    precedenceOf,+    knownRefs,+    liveKeys,+    isLive,+    liveCount,++    -- * Collection+    collect,+) where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set++import Salmon.Op.Dag (Dag, dagEdges)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Ref (Ref)++-- | A precedence edge, @(dependency, dependant)@ — the dependency comes up+-- first and goes down last.+type Edge = (Ref, Ref)++{- | What one declaration asks for: which nodes, and in which order relative+to each other. Both flat sets, so this is bounded by the declaration's node+count and not by the shape or depth of the graph it came from.+-}+data Contribution = Contribution+    { contribRefs :: !(Set Ref)+    , contribEdges :: !(Set Edge)+    , contribLive :: !Bool+    -- ^ 'False' from 'retract' until 'collect' — the declaration no longer+    -- wants these nodes up, but its edges still say how to take them down.+    }+    deriving (Show, Eq)++{- | Keyed by whatever identifies a declaration. "Salmon.Actions.Serve" uses+the encoded directive, so that two spellings of the same desired state are+one declaration.+-}+type Ledger key = Map key Contribution++emptyLedger :: Ledger key+emptyLedger = Map.empty++-- | Read a declaration's contribution off the graph it evaluated to.+contribution :: Dag ext -> Contribution+contribution dag =+    Contribution+        { contribRefs = Map.keysSet (Dag.dagNodes dag)+        , contribEdges = dagEdges dag+        , contribLive = True+        }++-------------------------------------------------------------------------------++{- | Declare (or re-declare) one key. Replaces rather than accumulates: the+same key declared twice is one declaration, which is what makes a single+@down@ afterwards enough to retract it.+-}+declare :: (Ord key) => key -> Contribution -> Ledger key -> Ledger key+declare = Map.insert++{- | Retire a key: it stops contributing to 'desired' immediately, keeps+contributing to 'precedenceOf', and is dropped by 'collect' once its nodes+have settled. Retracting a key that was never declared is a no-op.+-}+retract :: (Ord key) => key -> Ledger key -> Ledger key+retract = Map.adjust (\c -> c{contribLive = False})++-- | @clear@: retire every declaration.+retractAll :: Ledger key -> Ledger key+retractAll = fmap (\c -> c{contribLive = False})++-- | @only@: retire every declaration but this one.+retractOthers :: (Ord key) => key -> Ledger key -> Ledger key+retractOthers k = Map.mapWithKey (\k' c -> if k' == k then c else c{contribLive = False})++-------------------------------------------------------------------------------++-- | Every node some /live/ declaration still asks for: what should be up.+desired :: Ledger key -> Set Ref+desired = Set.unions . fmap contribRefs . filter contribLive . Map.elems++{- | Every edge any declaration contributed, retiring ones included — see the+module header for why liveness is not consulted here.+-}+precedenceOf :: Ledger key -> Set Edge+precedenceOf = Set.unions . fmap contribEdges . Map.elems++-- | Every node any retained declaration mentions, whether or not it is still+-- wanted up. The nodes this ledger can still say something about.+knownRefs :: Ledger key -> Set Ref+knownRefs = Set.unions . fmap contribRefs . Map.elems++liveKeys :: (Ord key) => Ledger key -> Set key+liveKeys = Map.keysSet . Map.filter contribLive++isLive :: (Ord key) => key -> Ledger key -> Bool+isLive k = maybe False contribLive . Map.lookup k++liveCount :: Ledger key -> Int+liveCount = length . filter contribLive . Map.elems++{- | Drop the retired declarations that have nothing left to say. The+predicate answers "is this node still standing?" — for a convergence loop,+"still to be turned down". A live declaration is never collected, however+settled its nodes are: it is what keeps them up.+-}+collect :: (Ref -> Bool) -> Ledger key -> Ledger key+collect standing = Map.filter needed+  where+    needed c = contribLive c || any standing (contribRefs c)
+ src/Salmon/Op/Mailbox.hs view
@@ -0,0 +1,121 @@+{- | One bounded mailbox per node: the things a node must be told, as opposed+to the things it can work out by looking at its neighbours.++"Salmon.Op.Status" covers everything derivable from the graph — a node pulls+its neighbours' state with 'Salmon.Op.Status.waitStability' and needs nobody+to tell it anything. Instructions are the complement: statements an operator+makes that are not a property of any neighbour at all.++@+Force    -- run @up@ even though @check@ says it need not; the operator knows+            something the check does not+Satisfy  -- treat as satisfied without acting+Recheck  -- collapse the adaptive delay to its floor and look now+Pause    -- stop tending this node, without tearing its effect down+Resume   -- start again+@++= Why a mailbox rather than replacing the node++The alternative is to swap the node's definition (and its running machine) for+a decorated one. That cannot express a /transient/ instruction without killing+and restarting the machine, which for a node that owns a process means killing+a healthy process in order to set a flag.++Swapping keeps exactly one narrow job, and it is not this one: when the fold+replaces a node's representative under last-writer-wins, the machine started+from the old representative has to go. That is a fold-time event. Everything+an operator wants to /say/ comes through here.++There is a third channel, and keeping the three apart is the point: a+'Salmon.Actions.Query.Plan' is part of a declaration, so its exclusions are+applied as the graph is folded — the node enters with its check pre-answered+and no running machine is disturbed. Declaration-time forcing is decoration;+run-time forcing is a mailbox.++= Bounded, dropping the oldest, and saying so++Bounded because a control plane can outrun a node that is busy doing something+slow, and an unbounded mailbox turns a wedged node into a memory leak.++Dropping the /oldest/ because these are statements about current intent — if+one has to go, the stale one is the one to lose. A drop is reported rather+than silent, or forcing a node becomes unreliable in a way nobody can see.++Provisional on purpose: whether drop-oldest is right, or whether a coalescing+mailbox (at most one pending instruction of each kind) would be better,+depends on how instructions actually get used, and there is no way to know+that before something is driving them.+-}+module Salmon.Op.Mailbox (+    Instruction (..),+    Mailbox,+    newMailbox,+    defaultCapacity,+    post,+    tryTake,+    takeAll,+    dropped,+) where++import Control.Concurrent.STM (STM, TBQueue, TVar, atomically, flushTBQueue, isFullTBQueue, modifyTVar', newTBQueueIO, newTVarIO, readTBQueue, readTVarIO, tryReadTBQueue, writeTBQueue)+import Numeric.Natural (Natural)++data Instruction+    = -- | act even though 'Salmon.Actions.UpDown.CheckResult' says otherwise+      Force+    | -- | treat as satisfied without acting. @specs\/per-node-state-machines.md@+      -- calls this @Skip@; renamed to keep it out of+      -- 'Salmon.Actions.UpDown.Report''s way, whose 'Salmon.Actions.UpDown.Skip'+      -- is what a node reports when it takes this instruction.+      Satisfy+    | -- | look now rather than at the end of the current delay+      Recheck+    | -- | stop tending this node, leaving its effect alone+      Pause+    | Resume+    deriving (Show, Eq, Ord)++data Mailbox = Mailbox+    { mailboxQueue :: !(TBQueue Instruction)+    , mailboxDropped :: !(TVar Int)+    }++-- | Small: a node with a dozen pending instructions has a control plane+-- problem, not a queueing one.+defaultCapacity :: Natural+defaultCapacity = 8++newMailbox :: Natural -> IO Mailbox+newMailbox cap = Mailbox <$> newTBQueueIO cap <*> newTVarIO 0++{- | Deliver an instruction, evicting the oldest if the mailbox is full.+Returns 'False' iff something was evicted to make room, which the caller is+expected to report.+-}+post :: Mailbox -> Instruction -> IO Bool+post box instruction = atomically $ do+    full <- isFullTBQueue box.mailboxQueue+    if full+        then do+            _ <- readTBQueue box.mailboxQueue+            modifyTVar' box.mailboxDropped (+ 1)+            writeTBQueue box.mailboxQueue instruction+            pure False+        else do+            writeTBQueue box.mailboxQueue instruction+            pure True++-- | The next instruction, if there is one. Never blocks: a node reads its+-- mailbox as one branch of a choice, not as its reason to wait.+tryTake :: Mailbox -> STM (Maybe Instruction)+tryTake = tryReadTBQueue . mailboxQueue++-- | Everything pending, oldest first. What a one-shot pass wants: it acts+-- once, so it needs the operator's whole say before it decides.+takeAll :: Mailbox -> STM [Instruction]+takeAll = flushTBQueue . mailboxQueue++-- | How many instructions this mailbox has evicted, ever.+dropped :: Mailbox -> IO Int+dropped = readTVarIO . mailboxDropped
+ src/Salmon/Op/Ref.hs view
@@ -0,0 +1,69 @@+module Salmon.Op.Ref (+    Ref,+    unRef,+    shortRef,+    dotRef,+    mkRef,+) where++import Data.Aeson (FromJSON (..), ToJSON (..))+import qualified Data.ByteString.Base64.URL as Base64.URL+import Data.Hashable (Hashable, hash, hashWithSalt)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Text.Printf (printf)++newtype Ref = Ref {unRef :: Text}+    deriving (Show, Eq, Ord)++{- | The bare text of the 'Ref'. This is what a 'Salmon.Actions.Query.Plan'+file carries and pastes back in, so it stays a plain string; the report+streams ("Salmon.Reporter.Tagged") render a 'Ref' as an object holding both+this and 'shortRef', through their own encoder rather than this instance.+-}+instance ToJSON Ref where+    toJSON = toJSON . unRef++instance FromJSON Ref where+    parseJSON = fmap Ref . parseJSON++instance Semigroup Ref where+    r1 <> r2 = dotRef $ unRef r1 <> unRef r2++{- | A short, stable, content-derived tag for a 'Ref' (the base64url encoding+of its own text, truncated to 8 characters) — the same "abbreviated SHA" idea.+'Salmon.Actions.Query.renderAnnotated' uses it to disambiguate colliding path+text without resorting to an arbitrary, traversal-order-dependent counter,+and a @#@-prefixed selector matches on it (see+'Salmon.Actions.Query.resolveRewrittenSelectors'). Lives here rather than in+"Salmon.Actions.Query" so that anything rendering a 'Ref' — the JSON report+encoding in particular — prints the same tag without importing the query+machinery.+-}+shortRef :: Ref -> Text+shortRef = Text.take 8 . Text.decodeUtf8 . Base64.URL.encode . Text.encodeUtf8 . unRef++{- | Build a 'Ref' from a "kind" tag and a structured 'Hashable' key that+identifies a node's identity within that kind — e.g. the node's own input+value (a 'FilePath', a tuple of fields, or a whole record), rather than a+hand-concatenated 'Text' string. Two calls with the same kind and equal keys+always produce the same 'Ref' (barring hash collisions, same caveat as+'dotRef'). Prefer this over 'dotRef' for new/touched call sites.+-}+mkRef :: (Hashable key) => Text -> key -> Ref+mkRef kind key = fromHash (hashWithSalt (hash kind) key)++{-# DEPRECATED dotRef "Prefer mkRef, which takes a kind tag plus a structured Hashable key instead of a hand-concatenated Text string." #-}+dotRef :: Text -> Ref+dotRef orig = fromHash (hash orig)++fromHash :: Int -> Ref+fromHash x =+    Ref $+        if x > 0+            then str x+            else "n" <> str (negate x)+  where+    str :: Int -> Text+    str = Text.pack . printf "%d"
+ src/Salmon/Op/Rewrite.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | Rewrites: what a graph turns into just before it is walked, and the one+place cross-declaration knowledge is allowed to live.++= Why this is a phase and not a recipe++A recipe author supplies a @'Salmon.Op.Track.Track' directive@, i.e.+@directive -> Op@ — a function of __one directive in isolation__. It cannot+see the other live declarations, it cannot see which way each of their nodes+is wanted, and it cannot see what was declared before. So "batch this package+with the other packages that are also currently wanted up" is not awkward to+write in a recipe; it is inexpressible there, because nothing in+@directive -> Op@ has the second argument.++Widening the recipe to @Ledger -> directive -> Op@ is the tempting fix and is+wrong three times over: expansion stops being deterministic in the directive+(so @run up@ is no longer reproducible), 'Salmon.Actions.Query.planDirectiveDigest'+stops identifying a graph (it pins a plan to the directive's digest), and+retraction becomes uncomputable (a declaration's contribution would depend on+what order declarations arrived in).++So recipes stay a pure function of their own directive, and cross-declaration+knowledge lives here, after the fold — which is simply where that information+first exists. @'Salmon.Builtin.Extension.dynamics' :: [Dynamic]@ is the+channel: a node says /"I am a Package"/ without knowing what will be done+about it, and a phase collects the set and acts on it.++= What a phase may assume++A 'Rewrite' sees the whole folded 'Dag' — every declaration's nodes, merged —+plus a 'Phase' saying which of them are wanted up and which this traversal+will not touch at all. Two rules follow and both matter:++* __Partition conservatively.__ A node in 'phaseDesired' is still wanted by+  some live declaration; only a node absent from it is going away. Sweeping a+  still-wanted node into a teardown batch would let one retraction pull+  something out from under a declaration still standing on it, which is the+  one failure here that retrying does not recover.+* __Leave 'phaseIgnored' alone.__ Those nodes are excluded by a plan or a+  @converge --select@, and collecting one into a batch would quietly execute+  what the operator asked to skip.++A phase that introduces a node records what that node stands in for, in+'computedMembers'. That is what lets a driver's gate and its convergence+recording keep speaking in terms of the nodes the operator declared: the+ledger is /declared intent/ and keeps per-package nodes, while a collection+is an /execution-plan detail/ that exists only here. They never disagree+because they answer different questions.+-}+module Salmon.Op.Rewrite (+    Phase (..),+    wholeGraph,+    Rewritten (..),+    Rewrite,+    rewrite,+    membersOf,+    collectDynamic,+    introduce,+) where++import Data.Dynamic (Dynamic, Typeable, fromDynamic)+import Data.List (foldl')+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import GHC.Records (HasField (..))++import Salmon.Op.Actions (Act (..))+import Salmon.Op.Dag (Dag)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Ref (Ref)++{- | What the traversal about to happen knows that the graph does not.++'phaseDesired' is the ledger's @desired@ for a @serve@ convergence, every+node for a @run up@, and nothing at all for a @run down@ — which is exactly+what makes one direction-aware rewrite do the right thing in all three.+-}+data Phase = Phase+    { phaseDesired :: !(Set Ref)+    , phaseIgnored :: !(Set Ref)+    -- ^ Nodes this traversal will not touch: a plan's excluded refs, or the+    -- complement of a @converge --select@. A rewrite must not collect them.+    }+    deriving (Show, Eq)++-- | The 'Phase' for a one-shot traversal of a whole graph: everything in it+-- is wanted, nothing is excluded. @run down@ passes @'Phase' mempty mempty@.+wholeGraph :: Dag ext -> Phase+wholeGraph dag = Phase (Set.fromList (Dag.dagOrder dag)) Set.empty++-- | A folded graph plus whatever the rewrites did to it.+data Rewritten ext = Rewritten+    { computedDag :: !(Dag ext)+    -- ^ What will actually execute.+    , computedMembers :: !(Map Ref (Set Ref))+    -- ^ For each node a rewrite introduced, the declared nodes it stands in+    -- for. A node absent from this map stands in for itself; use 'membersOf'+    -- rather than reading it directly.+    }++type Rewrite ext = Phase -> Rewritten ext -> Rewritten ext++-- | Run the registered phases in order over a freshly folded 'Dag'.+rewrite :: [Rewrite ext] -> Phase -> Dag ext -> Rewritten ext+rewrite phases phase dag = foldl' (\r f -> f phase r) (Rewritten dag Map.empty) phases++{- | The declared nodes a computed node stands in for — itself, when it stands+in for nothing, which is every node in a graph no rewrite touched.++A driver uses this twice: to decide whether a node is worth touching (it is,+if any member is), and to record what happened (it happened to every member).+-}+membersOf :: Rewritten ext -> Ref -> Set Ref+membersOf r aref = Map.findWithDefault (Set.singleton aref) aref (computedMembers r)++{- | Every node carrying a 'Dynamic' of the given type, with the values it+carries. This is the input side of a rewrite: the magma read across every+declaration at once, which is what a recipe could not do.+-}+collectDynamic ::+    forall a ext.+    (Typeable a, HasField "dynamics" ext [Dynamic]) =>+    Rewritten ext ->+    [(Ref, [a])]+collectDynamic r =+    [ (aref, vals)+    | (aref, act) <- Map.toList (Dag.dagNodes (computedDag r))+    , let vals = mapMaybe fromDynamic (getField @"dynamics" act.extension)+    , not (null vals)+    ]++{- | Collapse a set of declared nodes into the given node, which then stands+in for them, recording the membership so the drivers can still speak in+declared terms.++The replacement's own 'Salmon.Builtin.Extension.ref' is its identity here, so+it has to be one no declared node uses — two batches in one graph need two+refs, or the second silently replaces the first.++Members already standing in for something else are flattened through, so+collections compose: collecting a collection names the original nodes, not+the intermediate.+-}+introduce ::+    (HasField "ref" ext Ref) =>+    Act ext ->+    Set Ref ->+    Rewritten ext ->+    Rewritten ext+introduce act members r+    | Set.null members = r+    | otherwise =+        Rewritten+            { computedDag = Dag.collapseInto into act members (computedDag r)+            , computedMembers =+                Map.insert into flattened $+                    Map.withoutKeys (computedMembers r) members+            }+  where+    -- taken from the node rather than passed alongside it: the drivers look+    -- a collection's members up by the ref the node carries, so the two+    -- diverging would silently gate the collection out of every pass.+    into = getField @"ref" act.extension+    flattened = Set.unions (fmap (membersOf r) (Set.toList members))
+ src/Salmon/Op/Status.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE ScopedTypeVariables #-}++{- | What a node's own thread publishes about itself, and how its neighbours+wait on it.++Until now a node had no state of its own: a traversal held the ordering in+counters on its own stack, and a node was whatever the traversal had most+recently done to it. Giving each node a 'TVar' 'Status' moves that+information to where the node is, which buys three things at once — ordering+becomes a blocking read rather than a counter, several nodes can be in flight+without a scheduler, and something outside the traversal (an operator, a+status command, a supervisor) can ask a node how it is doing while it is+doing it.++= Ordering is a blocking read++'waitStability' is the whole of dependency ordering:++* a node going up waits on its /dependencies/ being 'Stable' in 'TurnUp';+* a node coming down waits on its /dependants/ being 'Stable' in 'TurnDown'.++That single inversion replaces the counting the synchronous+'Salmon.Actions.UpDown.walk' does in either direction, and it is only+expressible because "Salmon.Op.Dag" kept both adjacency directions. STM+'retry' means no polling, no wakeup channel and no scheduler: a node blocks+until a neighbour's state actually changes.++= Settled, and separately, making progress++'Stability' is deliberately two-valued, because it is what 'waitStability'+blocks on and a richer value would wake dependants on every twitch. But two+values cannot tell a node that has been 'Transient' for four seconds because+it is building from one that has been 'Transient' for four seconds because it+is wedged — which is exactly the distinction a restart decision needs.++So progress is a monotonic timestamp rather than a third state: anything+observable a node does bumps 'statusLastActive' (a transition, a check+returning, a line of output arriving), and "wedged" is a derived predicate.+'wedged' takes the watchdog as an argument rather than assuming one, because+a @cabal build@ is legitimately silent for minutes and a web server's startup+is not — only the node's author knows which, and a node that declares no+watchdog is never considered wedged. Silence is evidence only once somebody+has said what silence would mean.++= Output is a bounded ring++'statusOutput' keeps the last few lines a node produced. A ring rather than a+buffer, because a chatty node would otherwise be quietly accumulated into the+heap. It pays for itself three times: it is what an operator wants to see when+a node has failed, it is what feeds 'statusLastActive', and it lets a crash+report carry the lines that preceded the crash rather than just an exit code.+-}+module Salmon.Op.Status (+    -- * Which way a node is wanted+    Direction (..),+    opposite,++    -- * Whether it has got there+    Stability (..),+    Status (..),+    newStatus,+    readStatus,++    -- * Publishing+    settle,+    unsettle,+    touch,+    note,++    -- * Waiting+    waitStability,+    settled,++    -- * Progress+    wedged,++    -- * The output ring+    Ring,+    emptyRing,+    ringSize,+    pushRing,+    ringLines,+) where++import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar', newTVarIO, readTVar, readTVarIO, retry)+import Data.Text (Text)+import Data.Word (Word64)+import GHC.Clock (getMonotonicTimeNSec)++import Salmon.Actions.UpDown (CheckResult (..))++-- | Which way a node is currently wanted.+data Direction+    = TurnUp+    | TurnDown+    deriving (Show, Eq, Ord)++opposite :: Direction -> Direction+opposite TurnUp = TurnDown+opposite TurnDown = TurnUp++{- | Whether a node has finished moving. Two-valued on purpose: this is what+'waitStability' blocks on, so a value that changed often would wake every+dependant every time it did.+-}+data Stability+    = Stable+    | Transient+    deriving (Show, Eq, Ord)++data Status = Status+    { statusCheck :: !CheckResult+    -- ^ the node's own last word on its effect.+    , statusDirection :: !Direction+    , statusStability :: !Stability+    , statusLastActive :: !Word64+    -- ^ monotonic nanoseconds at the node's last observable activity. Only+    -- ever compared against a later reading of the same clock.+    , statusEpoch :: !Word64+    -- ^ how many times this node has stopped being settled. Monotonic, and+    -- the only durable record that it moved at all.+    --+    -- 'Stability' cannot answer "did this node go away and come back?" — a+    -- node that fell over and recovered between two readings looks exactly+    -- like one that never moved, and STM offers no queue of the transitions+    -- in between. Something watching a neighbour for departures rather than+    -- for its current state therefore has to compare a number it remembers+    -- against a number that only ever grows; see+    -- 'Salmon.Actions.Upkeep.crossing'.+    , statusOutput :: !Ring+    }+    deriving (Show)++{- | A node's status before its machine starts, and deliberately 'Transient'.++Initialising 'Stable' would let every dependant proceed before the node had+done anything at all — one line, and otherwise the kind of thing that only+shows up as a heisenbug on a wide graph.+-}+newStatus :: Direction -> IO (TVar Status)+newStatus dir = do+    now <- getMonotonicTimeNSec+    newTVarIO (Status Unknown dir Transient now 0 emptyRing)++readStatus :: TVar Status -> IO Status+readStatus = readTVarIO++-------------------------------------------------------------------------------++-- | The node has finished moving, with this as its last word.+settle :: TVar Status -> CheckResult -> IO ()+settle var result = do+    now <- getMonotonicTimeNSec+    atomically $+        modifyTVar' var $ \st ->+            st{statusCheck = result, statusStability = Stable, statusLastActive = now}++{- | The node is moving again — and, if the direction changed, moving the+other way, which resets what it has to say about itself.++A settled node moving is what bumps 'statusEpoch', and only that: an+already-moving node moving some more is not a second departure.+-}+unsettle :: TVar Status -> Direction -> IO ()+unsettle var dir = do+    now <- getMonotonicTimeNSec+    atomically $+        modifyTVar' var $ \st ->+            st+                { statusDirection = dir+                , statusStability = Transient+                , statusLastActive = now+                , statusCheck = if statusDirection st == dir then statusCheck st else Unknown+                , statusEpoch =+                    if st.statusStability == Stable+                        then st.statusEpoch + 1+                        else st.statusEpoch+                }++-- | Record activity without changing anything else: the node is still doing+-- whatever it was doing, and is not wedged.+touch :: TVar Status -> IO ()+touch var = do+    now <- getMonotonicTimeNSec+    atomically $ modifyTVar' var $ \st -> st{statusLastActive = now}++-- | A line of output (or of the node's own narration): into the ring, and+-- counts as activity.+note :: TVar Status -> Text -> IO ()+note var line = do+    now <- getMonotonicTimeNSec+    atomically $+        modifyTVar' var $ \st ->+            st{statusOutput = pushRing line st.statusOutput, statusLastActive = now}++-------------------------------------------------------------------------------++{- | Block until every one of these nodes has settled in the given direction.++The whole of dependency ordering. Pass a node's dependencies when it is going+up and its dependants when it is coming down; an empty list never blocks,+which is what makes a leaf start immediately.++Reads direction and stability only — never 'statusCheck' — so a node that+settled having failed is indistinguishable here from one that settled having+succeeded. That is deliberate: whether a dependant should proceed past a+failure is a policy the driver applies, not a property of the neighbour, and+the two drivers answer it differently (a one-shot pass reports+'Salmon.Actions.UpDown.Blocked' and moves on; a supervisor waits, because the+neighbour may yet be repaired).+-}+waitStability :: Direction -> Stability -> [TVar Status] -> STM ()+waitStability dir stab vars = do+    sts <- traverse readTVar vars+    if all ok sts then pure () else retry+  where+    ok :: Status -> Bool+    ok st = st.statusStability == stab && st.statusDirection == dir++-- | 'waitStability' for the common case: settled, in this direction.+settled :: Direction -> [TVar Status] -> STM ()+settled dir = waitStability dir Stable++{- | Has this node been silent for longer than its author said silence should+ever last? 'Nothing' for a watchdog means the node never declares itself+wedged, which is the default and the right one.++Three conditions, and the middle one is easy to leave out and wrong to. A+node is wedged if it has not settled, /has said something at least once/, and+has said nothing since. Without the middle condition a node sitting in+'Salmon.Actions.Upkeep.WaitUp' behind a slow dependency trips its own+watchdog, having never run at all: it is not silent, it has not started. The+node actually worth reporting there is the dependency, which /is/ doing+something and will trip its own.++A node's own machine notes its transitions into the ring precisely so this+has something to read.+-}+wedged :: Word64 -> Maybe Word64 -> Status -> Bool+wedged _ Nothing _ = False+wedged now (Just watchdogNs) st =+    st.statusStability == Transient+        && ringSize st.statusOutput > 0+        && now - st.statusLastActive > watchdogNs++-------------------------------------------------------------------------------++{- | The last few lines a node produced, newest first, dropping the oldest+once full.+-}+data Ring = Ring+    { ringCap :: !Int+    , ringHeld :: !Int+    , ringRev :: ![Text]+    }+    deriving (Show)++-- | A few hundred lines: enough to explain a failure, small enough that a+-- chatty node costs nothing. Anything wanting real logs should be shipping+-- them somewhere, which is a node of its own.+emptyRing :: Ring+emptyRing = Ring 256 0 []++ringSize :: Ring -> Int+ringSize = ringHeld++pushRing :: Text -> Ring -> Ring+pushRing line ring+    | ring.ringHeld < ring.ringCap = ring{ringHeld = ring.ringHeld + 1, ringRev = line : ring.ringRev}+    | otherwise = ring{ringRev = line : dropLast ring.ringRev}+  where+    dropLast xs = take (length xs - 1) xs++-- | Oldest first, the way one would read them.+ringLines :: Ring -> [Text]+ringLines = reverse . ringRev
+ src/Salmon/Op/Supervision.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | What a node says about how it wants to be tended.++A handful of knobs, all optional, all authored on the node itself: how+eagerly to put it back when it stops being up ('Restart'), how long its+silence has to last before somebody should worry ('supWatchdog'), and what+its going away means for the nodes standing on it ('Strategy').++= Why this rides 'Data.Dynamic.Dynamic' rather than a new field++'Salmon.Builtin.Extension.Extension' already has a channel for "a node states+something about itself that a later pass acts on": @dynamics@. It is what+@Package@ uses (@Nodes\/Debian\/Package.hs@) so that the post-fold collection+rewrite can find every package in the graph, and the argument for reusing it+here is the same one "Salmon.Op.Rewrite" makes — the information belongs to+the node, the decision belongs to something that sees more than the node.++Three things fall out of that choice:++* __Nothing changes for the many nodes with no opinion.__ There is no new+  field for every existing builtin to fill in with a default.+* __The default is structural.__ "A node that declares no watchdog is never+  considered wedged" is 'getDynamics' returning @[]@, not a 'Nothing' every+  author has to write. Silence is evidence only once somebody has said what+  silence would mean.+* __It is one line to add__, which was the bar: a watchdog is only as good as+  authors' willingness to set one.++The cost is that it is untyped and unenforced — nothing stops two conflicting+'Supervision' dynamics on one node. That is the same weakness the collection+rewrite already lives with, and it gets the same treatment as a conflicting+magma representative: take one, report the rest. Which one is arbitrary+(the first, here); what matters is that the loser is not silent.++= Time is 'Micros', not @DiffTime@++@specs\/per-node-state-machines.md@ writes @Maybe DiffTime@. salmon-ops has+no @time@ dependency and neither consumer of these values wants one:+'Control.Concurrent.threadDelay' takes microseconds and+'GHC.Clock.getMonotonicTimeNSec' hands back an integral nanosecond count.+An @Int@ of microseconds is what both ends already speak.+-}+module Salmon.Op.Supervision (+    -- * Policy+    Restart (..),+    Strategy (..),+    Supervision (..),+    defaultSupervision,+    supervised,++    -- * Reading it back off a node+    supervisionOf,+    supervisionsOf,++    -- * Durations+    Micros (..),+    micros,+    millis,+    seconds,+    toNanos,+) where++import Data.Dynamic (Dynamic, fromDynamic, toDyn)+import Data.Maybe (mapMaybe)+import Data.Word (Word64)+import GHC.Records (HasField, getField)++{- | When to put a node back after it has stopped being up.++Over the one-shot nodes this milestone covers — a @up :: IO ()@ that returns,+the only lifecycle 'Salmon.Builtin.Extension.Extension' can express today —+the policy is read against the node's own+'Salmon.Actions.UpDown.CheckResult' rather than against an exit code:++* 'OnFailure' (the default) re-runs @up@ when the check says the effect is+  gone ('Salmon.Actions.UpDown.Failure'), and only then.+* 'Never' leaves it alone: the node is reported as having fallen over and an+  operator decides. For a node whose @up@ is destructive to repeat, or whose+  failure means something worse happened upstream.+* 'Always' additionally re-runs it when the check says+  'Salmon.Actions.UpDown.Completed' — the one-shot reading of systemd's+  "restart a service that exits cleanly on reload". A job that means to run+  once should not be 'Always'.++'Salmon.Actions.UpDown.Unknown' never triggers a restart under any policy.+That is a deliberate departure from the one-shot drivers, where+'Salmon.Actions.UpDown.requirement' maps it to+'Salmon.Actions.UpDown.Required': erring toward acting is right for a single+pass over an idempotent action, and wrong for a loop, where it would spin a+node that simply has no check at its delay floor forever. "I could not look"+is not evidence the effect went away; only 'Salmon.Actions.UpDown.Failure'+is.++For a node that owns a process ('Salmon.Builtin.Extension.managed') the same+three answers are read against its 'System.Exit.ExitCode' instead, with one+ordering rule that matters: __the check is consulted before the policy.__ A+process that exits 0 because it daemonised is still up, and the check is the+only thing that can say so.+-}+data Restart+    = Always+    | OnFailure+    | Never+    deriving (Show, Eq, Ord)++{- | What a node leaving 'Salmon.Actions.Upkeep.Up' means for the nodes that+depend on it. Erlang's two supervision strategies, read along dependency+edges.++* 'OneForOne' (the default) is today's behaviour exactly: putting this node+  back is a statement about this node. A dependant that has already reached+  'Salmon.Actions.Upkeep.Up' is not disturbed.+* 'RestForOne' additionally sends every dependant back to+  'Salmon.Actions.Upkeep.WaitUp', to be brought up again on top of whatever+  this node turns into. A configuration file is the case that wants it: a+  service reading a config that has just been rewritten should be bounced,+  and only the config node knows that.++__This is authored on the node that goes away, not on the ones that get+bounced__, which is what makes it usable: the config file's author knows+their content is load-bearing, while the six services reading it would each+have to know, separately, that it might change under them.++Note the default is the opposite kind from 'supRestart''s. Restarting a node+that fell over is an active choice about that node, and 'OnFailure' makes it.+Bouncing a node's dependants is a decision about /other people's/ nodes, so+nothing happens until somebody says it should — which is also what makes this+safe to have added: a graph that names no strategy behaves as it did before.++The cascade is free rather than built: a demoted node is itself no longer up,+so a dependant of /it/ that also declares 'RestForOne' sees the same thing and+goes back too, all the way out to the edge of the opted-in cone.+-}+data Strategy+    = OneForOne+    | RestForOne+    deriving (Show, Eq, Ord)++data Supervision = Supervision+    { supRestart :: !Restart+    , supStrategy :: !Strategy+    -- ^ what this node leaving 'Salmon.Actions.Upkeep.Up' does to the nodes+    -- that depend on it. See 'Strategy'.+    , supReapply :: !Bool+    -- ^ for a node whose check answers+    -- 'Salmon.Actions.UpDown.Immaterial' (the default for a node with no+    -- @check@ at all): re-run @up@ on the tending loop instead of parking.+    --+    -- 'Salmon.Actions.UpDown.Immaterial' says "asking would cost what+    -- applying costs" — it does not say the effect can never go away, only+    -- that this node has no cheap way to tell. Most nodes that answer it+    -- should still park (see 'Salmon.Actions.Upkeep' @Rest@): re-running+    -- @up@ on a schedule is safe only if it is genuinely cheap /and/+    -- genuinely idempotent, a strictly stronger claim than @Immaterial@+    -- itself makes. 'Salmon.Builtin.Nodes.Filesystem.dir' is the case this+    -- exists for — @createDirectoryIfMissing@ costs about what+    -- @doesDirectoryExist@ would, so there is nothing to lose by preferring+    -- the former.+    --+    -- __Ignored for a node that holds a running action__+    -- ('Salmon.Builtin.Extension.managed'): such a node's @up@ throws by+    -- convention (see "Salmon.Builtin.Nodes.Daemon"), and re-running it on+    -- a schedule would crash-loop a service that is working fine. Such a+    -- node parks regardless of this field.+    --+    -- __Never demotes this node's own dependants.__ A scheduled re-apply+    -- does not go through 'Salmon.Actions.Upkeep.WaitUp' \/+    -- 'Salmon.Actions.Upkeep.Upping' and does not touch+    -- 'Salmon.Op.Status.statusEpoch', so a 'RestForOne' dependant watching+    -- this node is not told anything happened — nothing did, as far as that+    -- contract is concerned: the node never stopped being up. A re-apply+    -- that /fails/ is a different story and is folded back into the normal+    -- failure machinery ('supRestart', 'supGiveUpAfter'), which does have a+    -- way to say so.+    , supWatchdog :: !(Maybe Micros)+    -- ^ how long this node may go without doing anything observable before+    -- it should be called wedged. 'Nothing' — the default — means never.+    , supStableAfter :: !Micros+    -- ^ having been up this long counts as working: the backoff and the+    -- consecutive-failure count both reset.+    --+    -- This is what stops a service that falls over once a day from+    -- eventually being treated as a crash loop — only /consecutive quick/+    -- failures count. Without it, 'supGiveUpAfter' would latch off any+    -- long-lived node given enough days.+    , supDemoteEvery :: !Micros+    -- ^ 'RestForOne' rate limit: a node is demoted by a dependency at most+    -- once per this interval, so a dependency that is flapping cannot+    -- rebuild the whole cone behind it on every flap.+    --+    -- A separate field from 'supStableAfter' on purpose (see (I3) in+    -- @specs\/per-node-state-machines-remaining.md@) — "how long before a+    -- crash counts as a new one" and "how often may this node's dependants+    -- legitimately be rebuilt" are different questions with no reason to+    -- share a timescale. Defaults to 'supStableAfter''s value in+    -- 'defaultSupervision', so nothing changes for a node that has not+    -- thought about it.+    , supGiveUpAfter :: !(Maybe Int)+    -- ^ stop putting the node back after this many consecutive failures.+    -- 'Nothing' — the default — never gives up.+    --+    -- Right for a service whose repeated failure is information rather than+    -- an emergency; wrong for anything the machine cannot come back without,+    -- which is why the default is to keep trying. A node that has given up+    -- says so in its status and is not touched again until an operator+    -- forces it.+    }+    deriving (Show, Eq)++{- | 'OnFailure', 'OneForOne', never reapply on a schedule, no watchdog, ten+seconds of uptime counts as stable, never gives up: what a node that says+nothing gets.++Note the difference in kind between the two defaults that /do/ something.+'OnFailure' is an active choice — a node declared up that has stopped being+up is a convergence gap, and quietly accepting it would make this model+weaker than @run up@ already is (systemd's own default is the opposite, and+systemd is not converging a declared graph). Never giving up is the passive+choice: latching off is a decision only the node's author can justify.+-}+defaultSupervision :: Supervision+defaultSupervision = Supervision OnFailure OneForOne False Nothing (seconds 10) (seconds 10) Nothing++{- | State a supervision policy on a node, for a later pass to read back:++@+op "webserver" nodeps $ \\actions ->+    actions+        { ...+        , dynamics = [supervised defaultSupervision{supWatchdog = Just (seconds 30)}]+        }+@++Prefer amending 'defaultSupervision' to spelling out every field: the record+has grown once already and will again, and a node that only cares about its+watchdog should not have to have an opinion about giving up.+-}+supervised :: Supervision -> Dynamic+supervised = toDyn++{- | The policy this node is to be tended under, plus every other policy it+declared and lost.++An empty second component is the overwhelmingly common case (no declaration+at all, hence 'defaultSupervision'); a non-empty one is a node whose author+said two contradictory things, and the caller is expected to report it rather+than pick silently.+-}+supervisionOf ::+    (HasField "dynamics" ext [Dynamic]) =>+    ext ->+    (Supervision, [Supervision])+supervisionOf ext =+    case supervisionsOf ext of+        [] -> (defaultSupervision, [])+        (s : rest) -> (s, rest)++-- | Every 'Supervision' this node declared, in the order it declared them.+supervisionsOf ::+    (HasField "dynamics" ext [Dynamic]) =>+    ext ->+    [Supervision]+supervisionsOf ext = mapMaybe cast (getField @"dynamics" ext)+  where+    cast :: Dynamic -> Maybe Supervision+    cast = fromDynamic++-------------------------------------------------------------------------------++-- | Microseconds, the unit 'Control.Concurrent.threadDelay' takes.+newtype Micros = Micros {unMicros :: Int}+    deriving (Show, Eq, Ord)++micros :: Int -> Micros+micros = Micros++millis :: Int -> Micros+millis n = Micros (n * 1000)++seconds :: Int -> Micros+seconds n = Micros (n * 1000000)++-- | For comparing against 'GHC.Clock.getMonotonicTimeNSec'.+toNanos :: Micros -> Word64+toNanos (Micros n) = fromIntegral n * 1000
+ src/Salmon/Op/Window.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Maintenance windows: a pure value saying when disruptive nodes may run,+and the 'Gate' that holds them back the rest of the time.++A node opts in with 'disruptive' (a marker on @dynamics@, the channel+"Salmon.Op.Supervision" uses for the same reason), so nothing changes for the+many nodes with no opinion. The window itself belongs to whoever runs the+graph, not to the node: the node knows it is a restart, only the operator+knows when a restart is welcome. @run up --maintenance-window SPEC@ supplies+it; @--override-window@ is the operator who means it.++A node held by the gate is reported 'Skippable' like any gated node, and+stays wanted: the gate says "not now", nothing is frozen, so the next pass+inside the window applies it. Dependants of a skipped node are not blocked by+that (a 'Skip' is not a failure); order, not success, is what edges carry.++Time zones: a window carries a fixed UTC offset, because salmon-ops has no+time-zone database. A zone with daylight saving needs its offsets spelled+twice, as two windows.+-}+module Salmon.Op.Window (+    Window (..),+    parseWindow,+    renderWindow,+    inWindow,+    inAnyWindow,+    nextOpening,++    -- * Nodes opting in+    Disruptive (..),+    disruptive,+    isDisruptive,++    -- * The gate+    windowGate,+    windowGateAt,+) where++import Data.Dynamic (Dynamic, fromDynamic, toDyn)+import Data.Char (isAlpha)+import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time (+    DayOfWeek (..),+    UTCTime (..),+    addDays,+    addUTCTime,+    dayOfWeek,+    getCurrentTime,+    secondsToDiffTime,+ )+import GHC.Records (HasField, getField)+import Text.Read (readMaybe)++import Salmon.Actions.UpDown (Gate, Requirement (..))+import Salmon.Op.Actions (Act (..))+import Salmon.Builtin.Extension (Extension)+import qualified Salmon.Builtin.Extension as Extension++{- | One recurring span. Minutes are counted from local midnight; a span+whose start is later than its end crosses midnight (a weekly one then ends+on the following day).+-}+data Window = Window+    { winDay :: Maybe DayOfWeek+    -- ^ 'Nothing' is every day.+    , winStart :: Int+    , winEnd :: Int+    , winOffset :: Int+    -- ^ minutes east of UTC.+    }+    deriving (Show, Eq, Ord)++dayNames :: [(Text, DayOfWeek)]+dayNames =+    [ ("Mon", Monday), ("Tue", Tuesday), ("Wed", Wednesday), ("Thu", Thursday)+    , ("Fri", Friday), ("Sat", Saturday), ("Sun", Sunday)+    ]++{- | @HH:MM-HH:MM@ or @Day:HH:MM-HH:MM@, optionally followed by+@\@UTC@ or @\@+HH:MM@ / @\@-HH:MM@ (UTC when absent). Start and end must+differ.+-}+parseWindow :: Text -> Either Text Window+parseWindow spec = do+    let (body, zone) = Text.breakOn "@" spec+    off <- if Text.null zone then Right 0 else parseOffset (Text.drop 1 zone)+    let (dayTxt, afterDay) = Text.breakOn ":" body+    (day, times) <-+        if not (Text.null dayTxt) && Text.all isAlpha dayTxt+            then case lookup dayTxt dayNames of+                Just wd -> Right (Just wd, Text.drop 1 afterDay)+                Nothing -> Left ("unknown day in window " <> quoted)+            else Right (Nothing, body)+    (s, e) <- case Text.splitOn "-" times of+        [a, b] -> (,) <$> parseHm a <*> parseHm b+        _ -> Left ("malformed window " <> quoted)+    if s == e then Left ("empty window " <> quoted) else Right (Window day s e off)+  where+    quoted = "\"" <> spec <> "\""+    parseHm t = case Text.splitOn ":" t of+        [h, m]+            | Just h' <- readMaybe (Text.unpack h)+            , Just m' <- readMaybe (Text.unpack m)+            , Text.length h <= 2+            , Text.length m == 2+            , h' >= 0+            , h' < (24 :: Int)+            , m' >= 0+            , m' < (60 :: Int) ->+                Right (h' * 60 + m')+        _ -> Left ("malformed time \"" <> t <> "\" in window " <> quoted)+    parseOffset z+        | z `elem` ["UTC", "Z"] = Right 0+        | Just (sign, rest) <- Text.uncons z+        , sign `elem` ("+-" :: String)+        , [h, m] <- Text.splitOn ":" rest+        , Just h' <- readMaybe (Text.unpack h)+        , Just m' <- readMaybe (Text.unpack m)+        , h' <= (14 :: Int)+        , m' < (60 :: Int) =+            Right ((if sign == '-' then negate else id) (h' * 60 + m'))+        | otherwise = Left ("malformed zone \"" <> z <> "\" in window " <> quoted)++renderWindow :: Window -> Text+renderWindow w =+    maybe "" (\d -> maybe "" id (lookup d [(b, a) | (a, b) <- dayNames]) <> ":") w.winDay+        <> hm w.winStart+        <> "-"+        <> hm w.winEnd+        <> zone+  where+    hm n = pad (n `div` 60) <> ":" <> pad (n `mod` 60)+    pad n = Text.justifyRight 2 '0' (Text.pack (show n))+    zone+        | w.winOffset == 0 = "@UTC"+        | otherwise =+            "@" <> (if w.winOffset < 0 then "-" else "+")+                <> hm (abs w.winOffset)++-- | Local (day of week, minute of day) at an instant.+localParts :: Int -> UTCTime -> (DayOfWeek, Int)+localParts off t = (dayOfWeek (utctDay l), floor (utctDayTime l) `div` 60)+  where+    l = addUTCTime (fromIntegral off * 60) t++inWindow :: Window -> UTCTime -> Bool+inWindow w t+    | w.winStart < w.winEnd = dayOk dow && m >= w.winStart && m < w.winEnd+    | otherwise =+        (dayOk dow && m >= w.winStart) || (dayOk (pred' dow) && m < w.winEnd)+  where+    (dow, m) = localParts w.winOffset t+    dayOk d = maybe True (== d) w.winDay+    pred' d = toEnum ((fromEnum d + 5) `mod` 7 + 1)++inAnyWindow :: [Window] -> UTCTime -> Bool+inAnyWindow ws t = any (`inWindow` t) ws++{- | When the next window opens after an instant that is inside none of them.+'Nothing' when one is open now, or there are no windows.+-}+nextOpening :: [Window] -> UTCTime -> Maybe UTCTime+nextOpening ws t+    | inAnyWindow ws t = Nothing+    | null candidates = Nothing+    | otherwise = Just (minimum candidates)+  where+    candidates = concatMap starts ws+    starts w =+        [ i+        | k <- [0 .. 8]+        , let d = addDays k (utctDay (addUTCTime (fromIntegral w.winOffset * 60) t))+        , maybe True (== dayOfWeek d) w.winDay+        , let i =+                addUTCTime (negate (fromIntegral w.winOffset * 60)) $+                    UTCTime d (secondsToDiffTime (fromIntegral w.winStart * 60))+        , i > t+        ]++-- | Marker: this node restarts, upgrades or otherwise disturbs something.+data Disruptive = Disruptive+    deriving (Show, Eq)++-- | Mark a node as one a maintenance window applies to.+disruptive :: Extension -> Extension+disruptive e = e{Extension.dynamics = toDyn Disruptive : Extension.dynamics e}++isDisruptive :: (HasField "dynamics" ext [Dynamic]) => ext -> Bool+isDisruptive ext = any (isJust . (fromDynamic :: Dynamic -> Maybe Disruptive)) (getField @"dynamics" ext)++{- | A 'Gate' holding every 'disruptive' node while the clock is outside all+the windows. No windows means no gate. The callback is told which node is+held and when the next window opens, for the caller to report.+-}+windowGate :: [Window] -> (Act Extension -> Maybe UTCTime -> IO ()) -> Gate Extension+windowGate = windowGateAt getCurrentTime++-- | 'windowGate' over a caller's clock, so a test can move time.+windowGateAt :: IO UTCTime -> [Window] -> (Act Extension -> Maybe UTCTime -> IO ()) -> Gate Extension+windowGateAt _ [] _ = const (pure Required)+windowGateAt clock ws onHeld = \act -> gate act+  where+    gate :: Act Extension -> IO Requirement+    gate act+        | not (isDisruptive act.extension) = pure Required+        | otherwise = do+            now <- clock+            if inAnyWindow ws now+                then pure Required+                else onHeld act (nextOpening ws now) >> pure Skippable+
+ src/Salmon/Reporter.hs view
@@ -0,0 +1,126 @@+-- https://www.youtube.com/watch?v=qzOQOmmkKEM&feature=emb_logo++module Salmon.Reporter (+    Reporter,+    ReporterM (..),+    silent,+    reportIf,+    reportWhen,+    reportBoth,+    reportPick,++    -- * common utilities+    reportPrint,+    reportHPrint,+    reportHPut,+    encodeJSON,+    pulls,++    -- * re-exports+    Contravariant (..),+    Divisible (..),+    Decidable (..),+) where++import Control.Monad ((>=>))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (ToJSON, encode)+import Data.ByteString.Lazy (ByteString, hPut)+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible+import System.IO (Handle, hPrint)++type Reporter = ReporterM IO++newtype ReporterM m a = ReporterM {runReporter :: (a -> m ())}++instance Contravariant (ReporterM m) where+    contramap f (ReporterM g) = ReporterM (g . f)++instance (Applicative m) => Divisible (ReporterM m) where+    conquer = silent+    divide = reportSplit++instance (Applicative m) => Decidable (ReporterM m) where+    lose _ = silent+    choose = reportPick++-- | Disable Tracing.+{-# INLINE silent #-}+silent :: (Applicative m) => ReporterM m a+silent = ReporterM (const $ pure ())++{- | Splits a reporter into two chunks that are run sequentially.++This name can be confusing but it has to be thought backwards for Contravariant logging:+We compose a target reporter from two reporters but we split the content of the report.++Note that the split function may actually duplicate inputs (that's how reportBoth works).+-}+{-# INLINEABLE reportSplit #-}+reportSplit :: (Applicative m) => (c -> (a, b)) -> ReporterM m a -> ReporterM m b -> ReporterM m c+reportSplit split (ReporterM f1) (ReporterM f2) = ReporterM (go . split)+  where+    go (b, c) = f1 b *> f2 c++{- | If you are given two reporters and want to pass both.+Composition occurs in sequence.+-}+{-# INLINEABLE reportBoth #-}+reportBoth :: (Applicative m) => ReporterM m a -> ReporterM m a -> ReporterM m a+reportBoth t1 t2 = reportSplit (\x -> (x, x)) t1 t2++{- | Picks a reporter based on the emitted object.+Example logic that can be built is reportIf that silent messages.+-}+{-# INLINEABLE reportPick #-}+reportPick :: (Applicative m) => (c -> Either a b) -> ReporterM m a -> ReporterM m b -> ReporterM m c+reportPick split (ReporterM f1) (ReporterM f2) = ReporterM $ \a ->+    let e = split a+     in either f1 f2 e++-- | Filter by dynamically testing values.+{-# INLINEABLE reportIf #-}+reportIf :: forall m a. (Applicative m) => (a -> Bool) -> ReporterM m a -> ReporterM m a+reportIf predicate t = reportPick f silent t+  where+    f :: a -> Either () a+    f x = if predicate x then Right x else Left ()++-- | Like @reportIf@ but using a @Predicate@.+{-# INLINEABLE reportWhen #-}+reportWhen :: forall m a. (Applicative m) => Predicate a -> ReporterM m a -> ReporterM m a+reportWhen (Predicate predicate) t =+    reportIf predicate t++-- | A reporter that prints emitted events.+reportPrint :: (MonadIO m, Show a) => ReporterM m a+reportPrint = ReporterM (liftIO . print)++-- | A reporter that prints emitted to some handle.+reportHPrint :: (MonadIO m, Show a) => Handle -> ReporterM m a+reportHPrint handle = ReporterM (liftIO . hPrint handle)++-- | A reporter that puts some ByteString to some handle.+reportHPut :: (MonadIO m) => Handle -> ReporterM m ByteString+reportHPut handle = ReporterM (liftIO . hPut handle)++-- | A conversion encoding values to JSON.+{-# INLINE encodeJSON #-}+encodeJSON :: (ToJSON a) => ReporterM m ByteString -> ReporterM m a+encodeJSON = contramap encode++{- | Pulls a value to complete a report when a report occurs.++This function allows to combines pushed values with pulled values.  Hence,+performing some scheduling between behaviours.+Typical usage would be to annotate a report with a background value, or perform+data augmentation in a pipelines of reports.++Note that if you rely on this function you need to pay attention of the+blocking effect of 'pulls': the reported value c is not forwarded until a+value b is available.+-}+{-# INLINE pulls #-}+pulls :: (Monad m) => (c -> m b) -> ReporterM m b -> ReporterM m c+pulls act (ReporterM f1) = ReporterM $ act >=> f1
+ src/Salmon/Reporter/Tagged.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{- | The four report streams as one, and as JSON.++A salmon binary reports through four vocabularies: 'UpDown.Report' (what a+node did, from the one-shot drivers and, wrapped in 'Upkeep.Acted', from the+tending loop), 'Upkeep.Report' (what a node's own machine is doing between+commands), 'Serve.Report' (what the @run serve@ loop is doing) and+'Follow.Report' (what the fetcher of @run serve --follow@ is doing on its own+thread). Each has its own text rendering, and each is emitted through its own+'Reporter'. 'Tagged' is the sum of the four, tagged by stream, so that one+'Reporter' 'Tagged' can be split contravariantly into the four the drivers+expect ('serveStream'/'updownStream'/'upkeepStream'/'followStream' are the+'contramap's) and so that a second consumer — a JSON line writer, a status+sink ("Salmon.Actions.Serve.StatusSink"), a server (see+@specs\/generic-server.md@) — sees every event in one place, composed beside+the text one with 'reportBoth' rather than as a second reporting mechanism.++The 'ToJSON' instances live here rather than beside the types for one+reason: the two parametric streams are only encodable at 'Extension', which+"Salmon.Actions.UpDown" cannot import (it is what "Salmon.Builtin.Extension"+imports). Keeping all four together, orphans included, also makes this the+one module a client reads to know the wire format.++The format: every report is an object with a @kind@, a @ref@ (an object with+the 'shortRef' and the full text) wherever there is one node the report is+about, and named fields. A report that nests another stream's report+('Upkeep.Acted', 'Serve.Tended') nests the inner object as-is under+@report@. 'Tagged' adds @stream@ to the object — @serve@, @updown@,+@upkeep@ or @follow@; the key is not @origin@ because that word names who typed a+command (see 'Serve.Origin'), which the event stream will carry too. Report+text — @help@,+@notes@, failure text — is public and encoded verbatim; see the spec's+decisions. Sequence numbers are added on the event stream alone, by+"Salmon.Actions.Serve.Events".+-}+module Salmon.Reporter.Tagged (+    -- * The sum+    Tagged (..),+    serveStream,+    updownStream,+    upkeepStream,+    followStream,++    -- * Reporters+    reportJSONLines,+    reportTexts,++    -- * Encoding pieces+    refValue,+    actPairs,+    checkResultValue,+    nodeStatePairs,+    representativeValue,+    nodeStateValue,+    epochValue,+    originValue,+) where++import Control.Exception (SomeException)+import Data.Aeson (Key, ToJSON (..), Value (..), object, (.=))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Lazy as LByteString+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import System.IO (Handle, hFlush)++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.UpDown as UpDown+import qualified Salmon.Actions.Upkeep as Upkeep+import Salmon.Builtin.Extension (Extension (..))+import Salmon.Op.Actions (Act (..))+import qualified Salmon.Op.Mailbox as Mailbox+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Ref (Ref, shortRef, unRef)+import qualified Salmon.Op.Status as Status+import Salmon.Op.Supervision (Micros (..), Restart (..), Strategy (..), Supervision (..))+import Salmon.Reporter++-------------------------------------------------------------------------------++-- | One of the four streams, tagged by where it came from.+data Tagged+    = FromServe !Serve.Report+    | FromUpDown !(UpDown.Report Extension)+    | FromUpkeep !(Upkeep.Report Extension)+    | FromFollow !Follow.Report+    deriving (Show)++serveStream :: Reporter Tagged -> Reporter Serve.Report+serveStream = contramap FromServe++updownStream :: Reporter Tagged -> Reporter (UpDown.Report Extension)+updownStream = contramap FromUpDown++upkeepStream :: Reporter Tagged -> Reporter (Upkeep.Report Extension)+upkeepStream = contramap FromUpkeep++followStream :: Reporter Tagged -> Reporter Follow.Report+followStream = contramap FromFollow++{- | The four text reporters, behind one 'Tagged' one. Dispatches and does+nothing else, so whatever each of the four prints, it prints unchanged —+this is what a binary's own reporters go through when @--json@ is absent.+-}+reportTexts ::+    Reporter Serve.Report ->+    Reporter (UpDown.Report Extension) ->+    Reporter (Upkeep.Report Extension) ->+    Reporter Follow.Report ->+    Reporter Tagged+reportTexts serveR updownR upkeepR followR = ReporterM $ \tagged ->+    case tagged of+        FromServe rep -> runReporter serveR rep+        FromUpDown rep -> runReporter updownR rep+        FromUpkeep rep -> runReporter upkeepR rep+        FromFollow rep -> runReporter followR rep++{- | One JSON object per line, flushed as it is written so a consumer on the+other end of a pipe (@| jq@) sees each report when it happens rather than+when the buffer fills. Each line is handed to the handle as one strict+chunk: the concurrent drivers already serialise 'runReporter' through an+'Control.Concurrent.MVar.MVar', and a single write on top of that is what+keeps two reports from interleaving inside a line.+-}+reportJSONLines :: Handle -> Reporter Tagged+reportJSONLines h = ReporterM $ \tagged -> do+    LByteString.hPut h (LByteString.fromStrict (LByteString.toStrict (Aeson.encode tagged <> "\n")))+    hFlush h++-------------------------------------------------------------------------------++instance ToJSON Tagged where+    toJSON tagged =+        case tagged of+            FromServe rep -> withOrigin "serve" (toJSON rep)+            FromUpDown rep -> withOrigin "updown" (toJSON rep)+            -- a node's output lines are their own stream, so that+            -- `?stream=output` is a live tail and a client not following one+            -- never has to read them+            FromUpkeep rep@(Upkeep.Output _ _) -> withOrigin "output" (toJSON rep)+            FromUpkeep rep -> withOrigin "upkeep" (toJSON rep)+            FromFollow rep -> withOrigin "follow" (toJSON rep)+      where+        withOrigin :: Text -> Value -> Value+        withOrigin origin (Object o) = Object (KeyMap.insert "stream" (String origin) o)+        -- every instance below produces an object; kept total rather than+        -- partial so a future non-object encoding degrades to a wrapper+        -- instead of a crash in a reporter.+        withOrigin origin v = object ["stream" .= origin, "report" .= v]++-------------------------------------------------------------------------------++-- | A 'Ref' as both its short tag and its full text.+refValue :: Ref -> Value+refValue r = object ["short" .= shortRef r, "full" .= unRef r]++-- | The fields every report about one node carries: its @ref@ at the top+-- level, and what the node says it is under @node@.+actPairs :: Act Extension -> [(Key, Value)]+actPairs act =+    [ "ref" .= refValue act.extension.ref+    , "node" .= nodeValue act+    ]++nodeValue :: Act Extension -> Value+nodeValue act =+    object+        [ "shorthand" .= act.shorthand+        , "help" .= act.extension.help+        , "notes" .= act.extension.notes+        ]++{- | The 'Dag.representative' projection of a node — exactly the fields+'Dag.sameRepresentative' compares — as one object. What @\/dag@ shows for+each side of a 'Serve.Collision'.+-}+representativeValue :: Act Extension -> Value+representativeValue act =+    object+        [ "shorthand" .= rep.repShorthand+        , "help" .= rep.repHelp+        , "notes" .= rep.repNotes+        , "dynamics" .= rep.repDynamics+        ]+  where+    rep = Dag.representative act++kind :: Text -> (Key, Value)+kind k = "kind" .= k++exceptionValue :: SomeException -> Value+exceptionValue = String . Text.pack . show++checkResultValue :: UpDown.CheckResult -> Value+checkResultValue cr =+    case cr of+        UpDown.Success -> verdict "success" []+        UpDown.Skipped -> verdict "skipped" []+        UpDown.Completed -> verdict "completed" []+        UpDown.Failure reason -> verdict "failure" ["reason" .= reason]+        UpDown.Unknown -> verdict "unknown" []+        UpDown.Immaterial -> verdict "immaterial" []+  where+    verdict :: Text -> [(Key, Value)] -> Value+    verdict v rest = object (("verdict" .= v) : rest)++instructionValue :: Mailbox.Instruction -> Value+instructionValue instr =+    String $ case instr of+        Mailbox.Force -> "force"+        Mailbox.Satisfy -> "satisfy"+        Mailbox.Recheck -> "recheck"+        Mailbox.Pause -> "pause"+        Mailbox.Resume -> "resume"++microsValue :: Micros -> Value+microsValue (Micros us) = toJSON us++directionValue :: Status.Direction -> Value+directionValue Status.TurnUp = "up"+directionValue Status.TurnDown = "down"++stabilityValue :: Status.Stability -> Value+stabilityValue Status.Stable = "stable"+stabilityValue Status.Transient = "transient"++supervisionValue :: Supervision -> Value+supervisionValue sup =+    object+        [ "restart" .= restart sup.supRestart+        , "strategy" .= strategy sup.supStrategy+        , "reapply" .= sup.supReapply+        , "watchdog_us" .= fmap microsValue sup.supWatchdog+        , "stable_after_us" .= microsValue sup.supStableAfter+        , "demote_every_us" .= microsValue sup.supDemoteEvery+        , "give_up_after" .= sup.supGiveUpAfter+        ]+  where+    restart :: Restart -> Text+    restart Always = "always"+    restart OnFailure = "on-failure"+    restart Never = "never"+    strategy :: Strategy -> Text+    strategy OneForOne = "one-for-one"+    strategy RestForOne = "rest-for-one"++{- | The loop's mode, as @status@ renders it: @interactive@, @following@+or @replay@. On the wire in two places (@status@\'s object and @\/dag@\'s+envelope), so it is encoded once, here, beside the other orphans.+-}+instance ToJSON Serve.Mode where+    toJSON = String . Serve.renderMode++-------------------------------------------------------------------------------++instance ToJSON (UpDown.Report Extension) where+    toJSON rep =+        object $ case rep of+            UpDown.Skip act -> kind "skip" : actPairs act+            UpDown.Eval act -> kind "eval" : actPairs act+            UpDown.Done act -> kind "done" : actPairs act+            UpDown.Failed act e -> kind "failed" : actPairs act ++ ["error" .= exceptionValue e]+            UpDown.Blocked act -> kind "blocked" : actPairs act+            UpDown.Conflicting r kept replaced ->+                [ kind "conflicting"+                , "ref" .= refValue r+                , "kept" .= nodeValue kept+                , "replaced" .= nodeValue replaced+                ]+            UpDown.Instructed act instr -> kind "instructed" : actPairs act ++ ["instruction" .= instructionValue instr]+            UpDown.DroppedInstructions act n -> kind "dropped-instructions" : actPairs act ++ ["dropped" .= n]++-------------------------------------------------------------------------------++instance ToJSON (Upkeep.Report Extension) where+    toJSON rep =+        object $ case rep of+            Upkeep.Acted inner -> [kind "acted", "report" .= inner]+            Upkeep.Upkeep act st -> kind "upkeep" : actPairs act ++ ["state" .= upkeepState st]+            Upkeep.Downkeep act st -> kind "downkeep" : actPairs act ++ ["state" .= downkeepState st]+            Upkeep.NextLook act cr delay ->+                kind "next-look" : actPairs act ++ ["check" .= checkResultValue cr, "delay_us" .= microsValue delay]+            Upkeep.Wedged act silent -> kind "wedged" : actPairs act ++ ["silent_us" .= microsValue silent]+            Upkeep.Unwedged act -> kind "unwedged" : actPairs act+            Upkeep.Output act line -> kind "output" : actPairs act ++ ["line" .= line]+            Upkeep.Demoted act dep -> kind "demoted" : actPairs act ++ ["dependency" .= refValue dep]+            Upkeep.Parked act -> kind "parked" : actPairs act+            Upkeep.Reapplying act delay -> kind "reapplying" : actPairs act ++ ["delay_us" .= microsValue delay]+            Upkeep.Paused act -> kind "paused" : actPairs act+            Upkeep.Resumed act -> kind "resumed" : actPairs act+            Upkeep.GaveUp act n -> kind "gave-up" : actPairs act ++ ["failures" .= n]+            Upkeep.Adopted act -> kind "adopted" : actPairs act+            Upkeep.Released act -> kind "released" : actPairs act+            Upkeep.Policy act sup ignored ->+                kind "policy" : actPairs act ++ ["supervision" .= supervisionValue sup, "ignored" .= fmap supervisionValue ignored]+            Upkeep.Untended act -> kind "untended" : actPairs act+            Upkeep.Escaped act e -> kind "escaped" : actPairs act ++ ["error" .= exceptionValue e]+            Upkeep.Supervising nup ndown -> [kind "supervising", "up" .= nup, "down" .= ndown]+            Upkeep.Retired n -> [kind "retired", "machines" .= n]+            Upkeep.Holding n -> [kind "holding", "machines" .= n]+      where+        upkeepState :: Upkeep.UpkeepState -> Text+        upkeepState Upkeep.WaitUp = "wait-up"+        upkeepState Upkeep.Upping = "upping"+        upkeepState Upkeep.Up = "up"+        downkeepState :: Upkeep.DownkeepState -> Text+        downkeepState Upkeep.WaitDown = "wait-down"+        downkeepState Upkeep.Downing = "downing"+        downkeepState Upkeep.Down = "down"++-------------------------------------------------------------------------------++instance ToJSON Serve.Report where+    toJSON rep =+        object $ case rep of+            Serve.Started -> [kind "started"]+            Serve.Stopped -> [kind "stopped"]+            Serve.HungUp origin -> [kind "hung-up", "from" .= Serve.originName origin]+            Serve.BadCommand err -> [kind "bad-command", "error" .= err]+            Serve.BadSeed err -> [kind "bad-seed", "error" .= err]+            Serve.BadDirective err -> [kind "bad-directive", "error" .= err]+            Serve.BadLoad err -> [kind "bad-load", "error" .= err]+            Serve.Loading path -> [kind "loading", "path" .= path]+            Serve.LoadDone path n -> [kind "load-done", "path" .= path, "lines" .= n]+            Serve.Declared eid dir nnodes nactive ->+                [ kind "declared"+                , "epoch" .= eid.unEpochId+                , "direction" .= directionValue dir+                , "nodes" .= nnodes+                , "active_seeds" .= nactive+                ]+            Serve.Cleared n -> [kind "cleared", "retired" .= n]+            Serve.Supervised on -> [kind "supervised", "on" .= on]+            Serve.AutoConverged on -> [kind "auto-converged", "on" .= on]+            Serve.Instructed instr n -> [kind "instructed", "instruction" .= instructionValue instr, "nodes" .= n]+            Serve.FetchRequested following -> [kind "fetch-requested", "following" .= following]+            Serve.Tended inner -> [kind "tended", "report" .= inner]+            Serve.ConvergeStart ndown nup -> [kind "converge-start", "down" .= ndown, "up" .= nup]+            Serve.ConvergeStop ok remaining -> [kind "converge-stop", "ok" .= ok, "remaining" .= remaining]+            Serve.StatusReport mode xs paths ->+                [kind "status", "mode" .= mode, "nodes" .= fmap (nodeStateValue paths Nothing) xs]+            Serve.HistoryReport xs -> [kind "history", "seeds" .= fmap epochValue xs]+            Serve.HistoryElided n -> [kind "history-elided", "elided" .= n]+            Serve.QueryReport xs sel exc paths ->+                [kind "query", "nodes" .= fmap (nodeStateValue paths (Just (sel, exc))) xs]+            -- the topic asked for, and the same lines the text reporter+            -- would print: the reference is prose, and there is nothing+            -- more structured to say about it.+            Serve.HelpText mtopic -> [kind "help", "topic" .= mtopic, "lines" .= Serve.renderReport rep]+            Serve.SinkFailed path err -> [kind "sink-failed", "path" .= path, "error" .= err]++-------------------------------------------------------------------------------++{- | The fetcher's stream. A label is its text, a digest its hex; the+schedule ('Scheduler.Config') is spelled out in microseconds, the unit the+scheduler itself keeps, under the same names the @--follow-*@ flags use.+-}+instance ToJSON Follow.Report where+    toJSON rep =+        object $ case rep of+            Follow.Following reg lbls cfg ->+                [kind "following", "registry" .= reg, "labels" .= fmap Follow.labelText lbls, "schedule" .= scheduleValue cfg]+            Follow.Injected lbl did dg nup ndown ->+                kind "injected" : labelled lbl ++ ["document" .= did, "sha256" .= dg.unDigest, "up" .= nup, "down" .= ndown]+            Follow.NoDiff lbl did dg -> kind "no-diff" : labelled lbl ++ ["document" .= did, "sha256" .= dg.unDigest]+            Follow.Deferred lbl did dg -> kind "deferred" : labelled lbl ++ ["document" .= did, "sha256" .= dg.unDigest]+            Follow.Backoff n us -> [kind "backoff", "failures" .= n, "next_us" .= us]+            Follow.Missing lbl -> kind "missing" : labelled lbl+            Follow.Vanished lbl -> kind "vanished" : labelled lbl+            Follow.Malformed lbl dg err -> kind "malformed" : labelled lbl ++ ["sha256" .= dg.unDigest, "error" .= err]+            Follow.FetchFailed lbl err -> kind "fetch-failed" : labelled lbl ++ ["error" .= err]+            Follow.Replayed lbl did dg -> kind "replayed" : labelled lbl ++ ["document" .= did, "sha256" .= dg.unDigest]+            Follow.Stale lbl did -> kind "stale" : labelled lbl ++ ["document" .= did]+            Follow.BadCache lbl err -> kind "bad-cache" : labelled lbl ++ ["error" .= err]+            Follow.Rejected lbl dg err -> kind "rejected" : labelled lbl ++ ["sha256" .= dg.unDigest, "reason" .= err]+            Follow.CacheFailed lbl err -> kind "cache-failed" : labelled lbl ++ ["error" .= err]+      where+        labelled :: Follow.Label -> [(Key, Value)]+        labelled lbl = ["label" .= Follow.labelText lbl]++scheduleValue :: Scheduler.Config -> Value+scheduleValue cfg =+    object+        [ "base_us" .= cfg.schedBase+        , "factor" .= cfg.schedFactor+        , "cap_us" .= cfg.schedCap+        , "jitter" .= cfg.schedJitter+        , "debounce_us" .= cfg.schedDebounce+        , "max_wait_us" .= cfg.schedMaxWait+        ]++-------------------------------------------------------------------------------++{- | A node as @status@\/@query@ list it: its 'Ref', what it is, which way it+is wanted, how far it has got, its machine's last snapshot, and the paths a+selector can name it by. The pairs rather than the object, so that a+consumer with more to say about the node — the @\/dag@ read in+"Salmon.Actions.Serve.Http", which adds its edges — extends the same+encoding rather than keeping a second one.+-}+nodeStatePairs :: Map Ref [Text] -> Maybe (Set Ref, Set Ref) -> (Ref, Serve.NodeState) -> [(Key, Value)]+nodeStatePairs paths selection (r, st) =+    [ "ref" .= refValue r+    , "shorthand" .= st.nodeShorthand+    , "help" .= st.nodeHelp+    , "direction" .= directionValue st.nodeDirection+    , "convergence" .= convergence st.nodeConvergence+    , "status" .= fmap statusValue st.nodeStatus+    , "paths" .= Map.findWithDefault [] r paths+    ]+        ++ case selection of+            Nothing -> []+            Just (sel, exc) ->+                [ "selected" .= (r `Set.member` sel)+                , "excluded" .= (r `Set.member` exc)+                ]++nodeStateValue :: Map Ref [Text] -> Maybe (Set Ref, Set Ref) -> (Ref, Serve.NodeState) -> Value+nodeStateValue paths selection = object . nodeStatePairs paths selection++convergence :: Serve.Convergence -> Text+convergence Serve.Pending = "pending"+convergence Serve.Stale = "stale"+convergence Serve.Converged = "converged"+convergence Serve.Errored = "errored"+convergence Serve.Blocked = "blocked"++-- the snapshot 'Serve.NodeState' keeps of a node's machine: the+-- clock reading is left out, since it is only meaningful against+-- a later reading of the same monotonic clock in the same process.+statusValue :: Status.Status -> Value+statusValue ms =+    object+        [ "check" .= checkResultValue ms.statusCheck+        , "direction" .= directionValue ms.statusDirection+        , "stability" .= stabilityValue ms.statusStability+        , "epoch" .= ms.statusEpoch+        , "output" .= Status.ringLines ms.statusOutput+        ]++-- | One line of @history@.+epochValue :: (Serve.EpochId, Serve.Declaration, Bool, Serve.Origin, [String]) -> Value+epochValue (eid, decl, active, origin, args) =+    object+        [ "epoch" .= eid.unEpochId+        , "declaration" .= declaration decl+        , "active" .= active+        , "origin" .= originValue origin+        , "args" .= args+        ]++-- the input-language word, the same one 'Serve.renderReport' prints+declaration :: Serve.Declaration -> Text+declaration Serve.Add = "up"+declaration Serve.Replace = "only"+declaration Serve.Remove = "down"++-- | Who made a declaration (or, on the event stream, typed a command):+-- the same distinction the text @history@ draws with its trailing+-- @[fetched ...]@\/@[loaded ...]@ annotation.+originValue :: Serve.Origin -> Value+originValue origin = case origin of+    Serve.Stdin -> object ["kind" .= ("stdin" :: Text)]+    Serve.Origin name -> object ["kind" .= ("other" :: Text), "name" .= name]+    Serve.Loaded path -> object ["kind" .= ("loaded" :: Text), "path" .= path]+    Serve.Fetched prov ->+        object+            [ "kind" .= ("fetched" :: Text)+            , "registry" .= prov.provRegistry+            , "label" .= prov.provLabel+            , "document" .= prov.provDocument+            , "sha256" .= prov.provDigest+            ]
+ ui/auth.html view
@@ -0,0 +1,30 @@+<!doctype html>+<html lang="en">+<head>+<meta charset="utf-8">+<meta name="viewport" content="width=device-width, initial-scale=1">+<title>salmon serve</title>+<link rel="icon" href="data:,">+<style>+  :root { color-scheme: light dark; font-family: system-ui, sans-serif; }+  body { margin: 0; min-height: 100vh; display: grid; place-items: center; }+  form { display: grid; gap: .75rem; width: min(22rem, calc(100vw - 2rem)); }+  h1 { margin: 0; font-size: 1.25rem; }+  input, button { font: inherit; padding: .5rem .6rem; }+  .refused { margin: 0; color: #c0392b; }+  .ended { margin: 0; opacity: .8; }+</style>+</head>+<body>+<!-- Served by the TCP listener to a browser without a session; see+     Salmon.Actions.Serve.Http.requireToken. It is posted, never fetched from+     script, so the token never passes through the page's JavaScript. -->+<form method="post" action="auth">+  <h1>salmon</h1>+  <label for="token">Token (the content of <code>--token-file</code>)</label>+  <input id="token" name="token" type="password" autocomplete="current-password" required autofocus>+  <!--refused-->+  <button type="submit">Sign in</button>+</form>+</body>+</html>
+ ui/index.html view
@@ -0,0 +1,116 @@+<!doctype html>+<html lang="en">+<head>+<meta charset="utf-8">+<meta name="viewport" content="width=device-width, initial-scale=1">+<title>salmon serve</title>+<link rel="icon" href="data:,">+<link rel="stylesheet" href="ui/ui.css">+</head>+<body>+<header id="header">+  <h1>salmon</h1>+  <dl id="summary">+    <div><dt>mode</dt><dd id="h-mode">–</dd></div>+    <div><dt>seq</dt><dd id="h-seq">–</dd></div>+    <div><dt>nodes</dt><dd id="h-counts">–</dd></div>+    <div><dt>last converge</dt><dd id="h-converge">–</dd></div>+    <div><dt>stream</dt><dd id="h-stream">connecting</dd></div>+  </dl>+  <nav id="actions" aria-label="world actions">+    <button type="button" data-line="converge" title="re-attempt whatever has not converged">converge</button>+    <span class="pair">supervise+      <button type="button" data-line="supervise on">on</button><button type="button" data-line="supervise off">off</button>+    </span>+    <span class="pair">autoconverge+      <button type="button" data-line="autoconverge on">on</button><button type="button" data-line="autoconverge off">off</button>+    </span>+    <button type="button" data-line="fetch" title="ask the fetcher for a round now (--follow)">fetch</button>+    <button type="button" data-line="clear" data-confirm="Retire every seed? Everything known goes down." class="danger">clear</button>+    <button type="button" id="seeds-toggle" aria-expanded="false" aria-controls="seeds">seeds</button>+    <button id="reload" type="button" title="fetch /dag again and resubscribe">reload</button>+    <!-- a plain form: the server answers with the expired cookie and the sign-in page -->+    <form id="signout" method="post" action="auth/logout" hidden>+      <button type="submit" title="end this browser's session (--http-tcp); streams it opened close too">sign out</button>+    </form>+  </nav>+</header>+<main id="main">+  <section id="graph-wrap">+    <section id="seeds" hidden aria-label="seeds">+      <h2>seeds</h2>+      <details id="seed-help-wrap" open>+        <summary>this binary's seed (<code>config --help</code>)</summary>+        <pre id="seed-help">loading…</pre>+      </details>+      <details id="seed-commands-wrap">+        <summary>the loop's commands</summary>+        <pre id="seed-commands"></pre>+      </details>+      <form id="seed-form">+        <label for="seed-words">seed words</label>+        <input id="seed-words" type="text" autocomplete="off" spellcheck="false" placeholder="the words that would follow config">+        <span class="buttons">+          <button type="submit" data-verb="up" title="declare this seed up">up</button>+          <button type="button" data-verb="only" title="declare this seed up and retire every other one">only</button>+          <button type="button" data-verb="down" title="retire this seed">down</button>+        </span>+      </form>+      <h3>history <span id="history-elided" class="muted"></span></h3>+      <p id="history-empty" class="muted" hidden>no seed declared yet</p>+      <table id="history">+        <thead><tr><th>epoch</th><th>declared</th><th>seed</th><th>origin</th><th>state</th><th></th></tr></thead>+        <tbody id="history-rows"></tbody>+      </table>+    </section>+    <p id="empty" hidden>Nothing declared yet. Declare a seed (the <em>seeds</em> button above, or <code>POST /command</code> with <code>up …</code>) and it appears here.</p>+    <div id="graph-viewport">+      <svg id="graph" xmlns="http://www.w3.org/2000/svg" role="img" aria-label="the world's dag">+        <defs>+          <marker id="arrow" viewBox="0 0 10 10" refX="9" refY="5" markerWidth="7" markerHeight="7" orient="auto-start-reverse">+            <path d="M 0 0 L 10 5 L 0 10 z"></path>+          </marker>+        </defs>+        <g id="viewport">+          <g id="edges"></g>+          <g id="nodes"></g>+        </g>+      </svg>+      <div id="zoom-controls" aria-label="zoom controls">+        <button type="button" id="zoom-in" title="zoom in">+</button>+        <button type="button" id="zoom-out" title="zoom out">−</button>+        <button type="button" id="zoom-reset" title="fit the whole graph in the view">fit</button>+      </div>+    </div>+    <ol id="list"></ol>+    <ul id="legend">+      <li class="pending">pending</li>+      <li class="stale">stale</li>+      <li class="converged">converged</li>+      <li class="errored">errored</li>+      <li class="blocked">blocked</li>+      <li class="retiring">retiring (wanted down)</li>+      <li class="touched">touched by a command from this page</li>+    </ul>+  </section>+  <aside id="panel" hidden>+    <button id="panel-close" type="button" aria-label="close">×</button>+    <div id="panel-body"></div>+  </aside>+</main>+<div id="dock" hidden aria-label="live output tails"></div>+<footer id="cli">+  <form id="cli-form">+    <label for="cli-line" class="mono">:</label>+    <input id="cli-line" type="text" autocomplete="off" spellcheck="false" placeholder="a line of the input language — up …, status, help … (: focuses, Esc leaves)">+    <button type="submit">send</button>+  </form>+  <details id="cli-log">+    <summary>log <span id="cli-log-count" class="muted"></span></summary>+    <ol id="cli-log-list"></ol>+  </details>+</footer>+<div id="toasts" aria-live="polite"></div>+<script type="module" src="ui/ui.js"></script>+</body>+</html>
+ ui/ui.css view
@@ -0,0 +1,480 @@+/* The web UI's one stylesheet. Colours are tokens on :root so that the six+   convergence states read the same in the graph, the list and the legend. */++:root {+  --bg: #f7f7f5;+  --fg: #1d1d1b;+  --muted: #6b6b66;+  --line: #d5d5d0;+  --panel: #ffffff;+  --accent: #2456c4;+  --edge: #9a9a94;+  --pending: #e8e8e4;+  --pending-fg: #4a4a46;+  --stale: #fbe9b3;+  --stale-fg: #6a4b00;+  --converged: #cfeedb;+  --converged-fg: #14532d;+  --errored: #f9cfcf;+  --errored-fg: #7f1d1d;+  --blocked: #fbd9b5;+  --blocked-fg: #7c2d12;+  --retiring: #e3d9f5;+  --retiring-fg: #4c1d95;+  --pulse: #2456c4;+  --touch: #d97706;+  --danger: #b91c1c;+}++@media (prefers-color-scheme: dark) {+  :root:not([data-theme="light"]) {+    --bg: #17181a;+    --fg: #e6e6e2;+    --muted: #9c9c96;+    --line: #34363a;+    --panel: #202225;+    --accent: #7ea2ff;+    --edge: #6b6d72;+    --pending: #2b2d31;+    --pending-fg: #c9c9c4;+    --stale: #4d3c0a;+    --stale-fg: #f4d78a;+    --converged: #173c28;+    --converged-fg: #a4e2bd;+    --errored: #4a1c1c;+    --errored-fg: #f5b3b3;+    --blocked: #4a2a12;+    --blocked-fg: #f6c79c;+    --retiring: #33235a;+    --retiring-fg: #d3c1f7;+    --pulse: #7ea2ff;+    --touch: #fbbf24;+    --danger: #f87171;+  }+}++* { box-sizing: border-box; }++html, body { margin: 0; height: 100%; }++body {+  background: var(--bg);+  color: var(--fg);+  font: 14px/1.4 system-ui, -apple-system, "Segoe UI", Roboto, sans-serif;+  display: flex;+  flex-direction: column;+}++code, .mono { font-family: ui-monospace, SFMono-Regular, Menlo, Consolas, monospace; }++/* header ------------------------------------------------------------- */++#header {+  display: flex;+  align-items: center;+  gap: 24px;+  padding: 8px 16px;+  border-bottom: 1px solid var(--line);+  background: var(--panel);+  flex-wrap: wrap;+}++#header h1 { font-size: 16px; margin: 0; font-weight: 600; }++#summary {+  display: flex;+  gap: 20px;+  margin: 0;+  flex-wrap: wrap;+}++#summary div { display: flex; flex-direction: column; }+#summary dt { font-size: 11px; text-transform: uppercase; letter-spacing: .04em; color: var(--muted); }+#summary dd { margin: 0; font-family: ui-monospace, SFMono-Regular, Menlo, Consolas, monospace; }++#h-stream.live { color: var(--converged-fg); }+#h-stream.lost { color: var(--errored-fg); }++button {+  font: inherit;+  font-size: 13px;+  padding: 3px 9px;+  border: 1px solid var(--line);+  border-radius: 4px;+  background: var(--bg);+  color: var(--fg);+  cursor: pointer;+}++button:hover { border-color: var(--accent); }+button:disabled { opacity: .5; cursor: default; }+button.danger { color: var(--danger); }++.muted { color: var(--muted); }++/* world actions */++#actions {+  margin-left: auto;+  display: flex;+  align-items: center;+  gap: 6px;+  flex-wrap: wrap;+  font-size: 12px;+  color: var(--muted);+}++#actions .pair { display: inline-flex; align-items: center; gap: 3px; }+#signout { display: inline; margin: 0; }+#signout[hidden] { display: none; }+#actions .pair button { padding: 2px 6px; }+#actions .pair button:first-of-type { border-radius: 4px 0 0 4px; }+#actions .pair button:last-of-type { border-radius: 0 4px 4px 0; margin-left: -1px; }+#seeds-toggle[aria-expanded="true"] { border-color: var(--accent); color: var(--accent); }+#reload { margin-left: 8px; }++/* main --------------------------------------------------------------- */++#main {+  flex: 1;+  display: flex;+  min-height: 0;+}++#graph-wrap {+  flex: 1;+  display: flex;+  flex-direction: column;+  gap: 12px;+  overflow: auto;+  padding: 16px;+  position: relative;+}++#empty { color: var(--muted); }++/* a fixed, clipping viewport: the SVG no longer sizes itself to the graph's+   content and shrink-to-fit via max-width — content is drawn at its natural+   size and panned/zoomed within this box instead */+#graph-viewport {+  flex: 1;+  min-height: 320px;+  position: relative;+  overflow: hidden;+  border: 1px solid var(--line);+  border-radius: 6px;+  background: var(--panel);+  touch-action: none;+}++#graph { display: block; width: 100%; height: 100%; cursor: grab; }+#graph.panning { cursor: grabbing; }++#zoom-controls {+  position: absolute;+  right: 8px;+  bottom: 8px;+  display: flex;+  gap: 4px;+  z-index: 2;+}+#zoom-controls button { width: 26px; height: 26px; padding: 0; font-size: 15px; line-height: 1; }++#list { display: none; }++#legend {+  list-style: none;+  padding: 0;+  margin: 16px 0 0;+  display: flex;+  gap: 12px;+  flex-wrap: wrap;+  font-size: 12px;+  color: var(--muted);+}++#legend li::before {+  content: "";+  display: inline-block;+  width: 12px;+  height: 12px;+  border: 1px solid var(--line);+  border-radius: 2px;+  margin-right: 4px;+  vertical-align: -2px;+}++#legend .pending::before { background: var(--pending); }+#legend .stale::before { background: var(--stale); }+#legend .converged::before { background: var(--converged); }+#legend .errored::before { background: var(--errored); }+#legend .blocked::before { background: var(--blocked); }+#legend .retiring::before { background: var(--retiring); border-style: dashed; }+#legend .touched::before { border: 2px solid var(--touch); }++/* the graph ---------------------------------------------------------- */++#edges path {+  fill: none;+  stroke: var(--edge);+  stroke-width: 1.4;+  marker-end: url(#arrow);+}++#edges path.hi { stroke: var(--accent); stroke-width: 2; }++#arrow path { fill: var(--edge); }++.node { cursor: pointer; }++.node rect {+  stroke: var(--line);+  stroke-width: 1;+  rx: 5;+  fill: var(--pending);+}++.node.selected rect { stroke: var(--accent); stroke-width: 2; }++.node text { fill: var(--pending-fg); pointer-events: none; }+.node .ref { font-family: ui-monospace, SFMono-Regular, Menlo, Consolas, monospace; font-size: 11px; }+.node .shorthand { font-size: 13px; font-weight: 600; }+.node .state { font-size: 11px; }+.node .last { font-size: 10px; opacity: .8; }++.node.pending rect { fill: var(--pending); }+.node.pending text { fill: var(--pending-fg); }+.node.stale rect { fill: var(--stale); }+.node.stale text { fill: var(--stale-fg); }+.node.converged rect { fill: var(--converged); }+.node.converged text { fill: var(--converged-fg); }+.node.errored rect { fill: var(--errored); }+.node.errored text { fill: var(--errored-fg); }+.node.blocked rect { fill: var(--blocked); }+.node.blocked text { fill: var(--blocked-fg); }+.node.retiring rect { fill: var(--retiring); stroke-dasharray: 4 3; }+.node.retiring text { fill: var(--retiring-fg); }++.node.touched rect { stroke: var(--touch); stroke-width: 2.5; }+.node.selected rect { stroke: var(--accent); stroke-width: 2; }++.node.pulse rect { animation: pulse 900ms ease-out 1; }++@keyframes pulse {+  0% { stroke: var(--pulse); stroke-width: 4; }+  100% { stroke: var(--line); stroke-width: 1; }+}++/* the list (narrow screens) ----------------------------------------- */++#list li {+  border: 1px solid var(--line);+  border-radius: 5px;+  padding: 6px 10px;+  margin-bottom: 6px;+  background: var(--pending);+  color: var(--pending-fg);+  cursor: pointer;+}++#list li.stale { background: var(--stale); color: var(--stale-fg); }+#list li.converged { background: var(--converged); color: var(--converged-fg); }+#list li.errored { background: var(--errored); color: var(--errored-fg); }+#list li.blocked { background: var(--blocked); color: var(--blocked-fg); }+#list li.retiring { background: var(--retiring); color: var(--retiring-fg); border-style: dashed; }+#list li.touched { box-shadow: 0 0 0 2px var(--touch); }+#list li.selected { outline: 2px solid var(--accent); }+#list li .ref { font-size: 11px; }+#list li .deps { font-size: 11px; color: inherit; opacity: .8; }++/* the side panel ----------------------------------------------------- */++#panel {+  width: 380px;+  flex: none;+  border-left: 1px solid var(--line);+  background: var(--panel);+  overflow: auto;+  padding: 16px;+  position: relative;+}++#panel[hidden] { display: none; }++#panel-close {+  position: absolute;+  top: 8px;+  right: 8px;+  font: 18px/1 system-ui, sans-serif;+  border: 0;+  background: transparent;+  color: var(--muted);+  cursor: pointer;+}++#panel h2 { font-size: 15px; margin: 0 0 4px; padding-right: 24px; }+#panel h3 { font-size: 11px; text-transform: uppercase; letter-spacing: .04em; color: var(--muted); margin: 14px 0 4px; }+#panel p { margin: 0 0 4px; }+#panel pre { margin: 0; white-space: pre-wrap; word-break: break-all; font-size: 12px; }+#panel ul { margin: 0; padding-left: 18px; }+#panel a { color: var(--accent); cursor: pointer; text-decoration: none; }+#panel a:hover { text-decoration: underline; }+#panel .badge {+  display: inline-block;+  padding: 1px 7px;+  border-radius: 3px;+  font-size: 12px;+  border: 1px solid var(--line);+  background: var(--pending);+  color: var(--pending-fg);+}+#panel .badge.stale { background: var(--stale); color: var(--stale-fg); }+#panel .badge.converged { background: var(--converged); color: var(--converged-fg); }+#panel .badge.errored { background: var(--errored); color: var(--errored-fg); }+#panel .badge.blocked { background: var(--blocked); color: var(--blocked-fg); }+#panel .badge.retiring { background: var(--retiring); color: var(--retiring-fg); }+#panel .output { max-height: 200px; overflow: auto; background: var(--bg); padding: 6px; border-radius: 4px; }+#panel .node-actions { display: flex; gap: 6px; flex-wrap: wrap; margin: 8px 0 0; }+#panel .seed-row { display: flex; gap: 8px; align-items: baseline; margin: 0 0 4px; }+#panel .seed-row .words { flex: 1; font-size: 12px; word-break: break-all; }++/* the seed panel ---------------------------------------------------- */++#seeds {+  border: 1px solid var(--line);+  border-radius: 6px;+  background: var(--panel);+  padding: 12px 16px;+  margin-bottom: 16px;+}++#seeds[hidden] { display: none; }+#seeds h2 { font-size: 15px; margin: 0 0 8px; }+#seeds h3 { font-size: 11px; text-transform: uppercase; letter-spacing: .04em; color: var(--muted); margin: 14px 0 4px; }+#seeds details { margin: 0 0 8px; }+#seeds summary { cursor: pointer; color: var(--muted); font-size: 12px; }+#seeds pre { margin: 4px 0 0; max-height: 240px; overflow: auto; background: var(--bg); padding: 8px; border-radius: 4px; font-size: 12px; white-space: pre-wrap; }+#seed-form { display: flex; gap: 8px; align-items: center; flex-wrap: wrap; margin-top: 8px; }+#seed-form label { font-size: 12px; color: var(--muted); }+#seed-form input { flex: 1; min-width: 200px; }+#seed-form .buttons { display: inline-flex; gap: 4px; }++input[type="text"] {+  font: inherit;+  font-family: ui-monospace, SFMono-Regular, Menlo, Consolas, monospace;+  font-size: 13px;+  padding: 4px 8px;+  border: 1px solid var(--line);+  border-radius: 4px;+  background: var(--bg);+  color: var(--fg);+}++input[type="text"]:focus { outline: 2px solid var(--accent); outline-offset: -1px; }++#history { border-collapse: collapse; width: 100%; font-size: 12px; }+#history th { text-align: left; font-weight: 500; color: var(--muted); padding: 2px 8px 2px 0; border-bottom: 1px solid var(--line); }+#history td { padding: 3px 8px 3px 0; border-bottom: 1px solid var(--line); vertical-align: top; }+#history td.words { font-family: ui-monospace, SFMono-Regular, Menlo, Consolas, monospace; word-break: break-all; cursor: pointer; }+#history td.words:hover { color: var(--accent); }+#history tr.retired td { color: var(--muted); }+#history .badge { display: inline-block; padding: 0 6px; border-radius: 3px; border: 1px solid var(--line); background: var(--pending); color: var(--pending-fg); }+#history .badge.active { background: var(--converged); color: var(--converged-fg); }++/* the command line --------------------------------------------------- */++#cli {+  border-top: 1px solid var(--line);+  background: var(--panel);+  padding: 6px 16px;+}++#cli-form { display: flex; gap: 8px; align-items: center; }+#cli-form label { color: var(--muted); }+#cli-form input { flex: 1; min-width: 0; }+#cli-log { margin-top: 4px; font-size: 12px; }+#cli-log summary { cursor: pointer; color: var(--muted); }+#cli-log-list { margin: 4px 0 0; padding: 0; list-style: none; max-height: 30vh; overflow: auto; font-family: ui-monospace, SFMono-Regular, Menlo, Consolas, monospace; }+#cli-log-list > li { margin: 0 0 6px; }+#cli-log-list .request { font-weight: 600; }+#cli-log-list .request .origin { font-weight: 400; color: var(--muted); }+#cli-log-list ul { margin: 0; padding-left: 16px; list-style: none; }+#cli-log-list li.bad { color: var(--errored-fg); }+#cli-log-list li.done { color: var(--converged-fg); }++/* toasts ------------------------------------------------------------- */++#toasts {+  position: fixed;+  right: 16px;+  bottom: 72px;+  display: flex;+  flex-direction: column;+  gap: 6px;+  z-index: 10;+  max-width: min(420px, calc(100vw - 32px));+}++.toast {+  background: var(--panel);+  color: var(--fg);+  border: 1px solid var(--accent);+  border-left-width: 4px;+  border-radius: 4px;+  padding: 6px 10px;+  font-size: 12px;+  box-shadow: 0 2px 8px rgba(0, 0, 0, .15);+  cursor: pointer;+  word-break: break-word;+}++.toast.bad { border-color: var(--danger); }+.toast.ok { border-color: var(--converged-fg); }+.toast .mono { color: var(--muted); }++/* below 700px the graph gives way to a list, and the panel to a sheet */++@media (max-width: 700px) {+  #graph-viewport, #legend { display: none; }+  #list { display: block; padding: 0; margin: 0; list-style: none; }+  #main { flex-direction: column; }+  #panel { width: auto; border-left: 0; border-top: 1px solid var(--line); max-height: 50vh; }+  #graph-wrap { padding: 16px; }+  #actions { margin-left: 0; }+  #history th:nth-child(4), #history td:nth-child(4) { display: none; }+}++/* live tails: a strip of small terminals above the command line */+#dock {+  display: flex;+  gap: 8px;+  padding: 6px 8px;+  border-top: 1px solid var(--line);+  background: var(--panel);+  overflow-x: auto;+}+#dock[hidden] { display: none; }+.tail {+  flex: 1 1 22em;+  min-width: 16em;+  max-width: 40em;+  display: flex;+  flex-direction: column;+  border: 1px solid var(--line);+  border-radius: 4px;+}+.tail > header { padding: 3px 6px; border-bottom: 1px solid var(--line); font-size: 0.85em; }+.tail > header button { margin-left: 4px; font-size: 0.85em; }+.tail-title { font-weight: 600; }+.tail-body {+  margin: 0;+  padding: 4px 6px;+  height: 9em;+  overflow: auto;+  font-family: ui-monospace, SFMono-Regular, Menlo, monospace;+  font-size: 0.8em;+  white-space: pre-wrap;+  word-break: break-all;+  background: var(--bg);+  color: var(--fg);+}
+ ui/ui.js view
@@ -0,0 +1,1372 @@+// The web UI: `/dag` drawn as a layered graph, kept live from `/events`.+//+// Holds no state the server does not. The picture is the last `/dag`+// snapshot; what moves between snapshots is applied from the event stream+// subscribed at that snapshot's `seq`, and anything that changes the node+// set or settles convergence (`declared`, `cleared`, `converge-stop`, a+// `gap`, a lost stream) is answered by fetching `/dag` again and+// resubscribing from its `seq`. Reload is the same thing by hand.+//+// Every write is `POST /command?async`: the line is queued, the answer is+// the sequence number it was queued at and the origin it was queued under,+// and what it did is read off `/events` like everything else — the reports+// carrying that origin are the command's, which is what lights the nodes it+// touched, fills the log under the command line and says when it is done+// (`hung-up`). Never the synchronous form: a sync `up` holds the request for+// the whole pass, and this page is the thing that would be waiting.+//+// The seed form is `/help/seed` (the binary's own `config --help`) in a+// `<pre>`, a text field for the words, and the three declaring verbs; the+// history under it is `/history`, fetched again on `declared`/`cleared`.+// `quit` is deliberately not offered: a page cannot answer for the socket it+// is served on, and leaving the loop is not something to click.++const $ = (id) => document.getElementById(id);+const SVG = "http://www.w3.org/2000/svg";++// ---------------------------------------------------------------------------+// state++const state = {+  nodes: new Map(), // full ref -> node object from /dag, plus live overlay+  order: [], // full refs in dagOrder+  seq: 0,+  mode: "–",+  converge: null, // last converge-stop {ok, remaining}+  selected: null, // full ref+  source: null, // the EventSource+  reloadTimer: null,+  retryDelay: 1000,+  requests: new Map(), // origin name -> {seq, origin, line, reports, done, li}+  unclaimed: [], // events with an origin no request has claimed yet+  history: null, // last /history: {seeds: [...], elided}+  seedHelpLoaded: false,+  tails: new Map(), // full ref -> {lines, paused, held, pre} for each pinned live tail+  zoom: { scale: 1, tx: 0, ty: 0 }, // the #viewport transform; world units are the raw layout() pixels+  zoomInit: false, // true once the first fit-to-view has run+  worldSize: null, // the current layout()'s {width, height}, for fitView+};++const MIN_ZOOM = 0.1;+const MAX_ZOOM = 4;++// The dock holds a few windows, not one per node: a tail is for the node+// being watched right now.+const TAIL_MAX_WINDOWS = 4;+const TAIL_MAX_LINES = 500;+const TAIL_STORE = "salmon-tails";++// How long a node stays marked as touched once the command that touched it+// has been handled.+const TOUCH_LINGER_MS = 4000;+const TOAST_MS = 6000;++// ---------------------------------------------------------------------------+// fetching and subscribing++async function loadDag() {+  clearTimeout(state.reloadTimer);+  state.reloadTimer = null;+  closeStream();+  let dag;+  try {+    const r = await fetch("dag", { cache: "no-store" });+    if (r.status === 401) return signedOut();+    if (!r.ok) throw new Error(`/dag answered ${r.status}`);+    dag = await r.json();+  } catch (err) {+    setStream("lost", String(err.message || err));+    state.retryDelay = Math.min(state.retryDelay * 2, 15000);+    state.reloadTimer = setTimeout(loadDag, state.retryDelay);+    return;+  }+  state.retryDelay = 1000;+  state.seq = dag.seq;+  state.mode = dag.mode;+  const before = state.nodes;+  state.nodes = new Map();+  state.order = [];+  for (const n of dag.nodes) {+    n.last = null;+    n.lastReason = null;+    n.machine = null;+    // a snapshot is fetched on `declared` and `converge-stop`, mid-command,+    // and which command touched a node is this page's knowledge, not /dag's+    n.touched = before.has(n.ref.full) ? before.get(n.ref.full).touched : null;+    state.nodes.set(n.ref.full, n);+    state.order.push(n.ref.full);+  }+  if (state.selected && !state.nodes.has(state.selected)) state.selected = null;+  reconcileTails();+  render();+  subscribe(dag.seq);+}++// Coalesce: several events in a row that each want a fresh snapshot cost+// one fetch.+function scheduleReload() {+  if (state.reloadTimer) return;+  state.reloadTimer = setTimeout(loadDag, 250);+}++function closeStream() {+  if (state.source) {+    state.source.close();+    state.source = null;+  }+}++function subscribe(since) {+  const es = new EventSource(`events?since=${since}`);+  state.source = es;+  es.onopen = () => setStream("live");+  es.onmessage = (m) => {+    let e;+    try {+      e = JSON.parse(m.data);+    } catch {+      return;+    }+    if (typeof e.seq === "number") state.seq = e.seq;+    applyEvent(e);+    attribute(e);+    renderHeader();+  };+  es.onerror = () => {+    // EventSource would reconnect on its own, but with Last-Event-ID, which+    // the server does not read; resuming is `/dag` then `?since=` its seq.+    if (state.source !== es) return;+    closeStream();+    setStream("lost");+    scheduleReload();+  };+}++function setStream(cls, detail) {+  const el = $("h-stream");+  el.className = cls;+  el.textContent = cls === "live" ? "live" : detail ? `lost: ${detail}` : "reconnecting";+}++// ---------------------------------------------------------------------------+// events onto nodes++function applyEvent(e) {+  switch (e.stream) {+    case "server":+      if (e.kind === "gap") scheduleReload();+      return;+    case "serve":+      applyServe(e);+      return;+    case "updown":+      applyUpDown(e);+      return;+    case "upkeep":+      applyUpkeep(e);+      return;+    case "output":+      applyOutput(e);+      return;+    default:+      return;+  }+}++// ---------------------------------------------------------------------------+// live tails: a dock of pinned mini terminals, one per node. Besides a+// managed action's own `output` lines, a tailed node's updown/upkeep reports+// are formatted into the same window (prefixed by stream) — those exist for+// every node, so a one-shot builtin's tail is not silent just because it has+// no `managed` action to produce raw output.++function storedPins() {+  try {+    const v = JSON.parse(localStorage.getItem(TAIL_STORE) || "[]");+    return Array.isArray(v) ? v.filter((x) => typeof x === "string") : [];+  } catch {+    return [];+  }+}++function storePins() {+  try {+    localStorage.setItem(TAIL_STORE, JSON.stringify([...state.tails.keys()]));+  } catch {+    // page storage may be unavailable; windows just do not survive a reload+  }+}++// After every /dag: a window for a node that is no longer there closes (the+// node was retired and pruned), and the pins remembered from a previous page+// load are opened for the nodes that are. The ring the snapshot carries is+// the backlog a window is seeded from, but only when it has nothing yet:+// lines that arrived live since are newer than that snapshot.+function reconcileTails() {+  for (const ref of storedPins()) {+    if (state.nodes.has(ref) && !state.tails.has(ref) && state.tails.size < TAIL_MAX_WINDOWS) {+      state.tails.set(ref, { lines: [], paused: false, held: [], pre: null });+    }+  }+  for (const ref of [...state.tails.keys()]) {+    const n = state.nodes.get(ref);+    if (!n) {+      state.tails.delete(ref);+      continue;+    }+    const t = state.tails.get(ref);+    if (t.lines.length === 0 && n.status && Array.isArray(n.status.output)) {+      t.lines = n.status.output.slice(-TAIL_MAX_LINES);+    }+  }+  storePins();+  renderDock();+}++function toggleTail(ref) {+  if (state.tails.has(ref)) {+    state.tails.delete(ref);+  } else {+    // the oldest pin makes room+    if (state.tails.size >= TAIL_MAX_WINDOWS) state.tails.delete(state.tails.keys().next().value);+    const n = state.nodes.get(ref);+    const seed = n && n.status && Array.isArray(n.status.output) ? n.status.output.slice(-TAIL_MAX_LINES) : [];+    state.tails.set(ref, { lines: seed, paused: false, held: [], pre: null });+  }+  storePins();+  renderDock();+  renderPanel();+}++function applyOutput(e) {+  if (e.ref && typeof e.line === "string") pushTailLine(e.ref.full, e.line);+}++// Shared by a managed action's raw output and by the formatted updown/upkeep+// report lines below; a no-op if that ref has no open tail window.+function pushTailLine(ref, line) {+  const t = state.tails.get(ref);+  if (!t) return;+  // paused holds the view still; what arrives meanwhile is kept for resume+  const into = t.paused ? t.held : t.lines;+  into.push(line);+  if (into.length > TAIL_MAX_LINES) into.splice(0, into.length - TAIL_MAX_LINES);+  if (!t.paused) paintTail(t);+}++function formatUpDownLine(e) {+  switch (e.kind) {+    case "failed":+      return `failed: ${e.error}`;+    case "conflicting":+      return `conflicting: kept ${e.kept && e.kept.shorthand}, replaced ${e.replaced && e.replaced.shorthand}`;+    case "instructed":+      return `instructed: ${e.instruction}`;+    case "dropped-instructions":+      return `dropped ${e.dropped} instruction(s)`;+    default:+      return e.kind;+  }+}++function formatUpkeepLine(e) {+  switch (e.kind) {+    case "next-look":+      return `next-look: ${(e.check && e.check.kind) || "?"}${e.delay_us != null ? ` (retry in ${Math.round(e.delay_us / 1e6)}s)` : ""}`;+    case "upkeep":+      return `upkeep: ${e.state}`;+    case "downkeep":+      return `downkeep: ${e.state}`;+    case "demoted":+      return `demoted by ${e.dependency && e.dependency.short}`;+    case "gave-up":+      return `gave up after ${e.failures} failure(s)`;+    case "wedged":+      return `wedged (${Math.round(e.silent_us / 1e6)}s silent)`;+    case "reapplying":+      return `reapplying (retry in ${Math.round(e.delay_us / 1e6)}s)`;+    default:+      return e.kind;+  }+}++function paintTail(t) {+  if (!t.pre) return;+  const stick = t.pre.scrollTop + t.pre.clientHeight >= t.pre.scrollHeight - 4;+  t.pre.textContent = t.lines.join("\n");+  if (stick) t.pre.scrollTop = t.pre.scrollHeight;+}++function renderDock() {+  const dock = $("dock");+  dock.replaceChildren();+  dock.hidden = state.tails.size === 0;+  for (const [ref, t] of state.tails) {+    const n = state.nodes.get(ref);+    const win = document.createElement("section");+    win.className = "tail";+    const bar = document.createElement("header");+    const title = document.createElement("span");+    title.className = "tail-title";+    title.textContent = n ? n.shorthand : ref.slice(0, 8);+    const st = document.createElement("span");+    st.className = `badge ${n ? stateClass(n) : ""}`;+    st.textContent = n ? n.convergence : "gone";+    bar.append(title, " ", st);+    const button = (label, hint, fn) => {+      const b = document.createElement("button");+      b.type = "button";+      b.textContent = label;+      b.title = hint;+      b.addEventListener("click", fn);+      return b;+    };+    const pause = button(t.paused ? "resume" : "pause", "hold the window still; lines keep arriving", () => {+      t.paused = !t.paused;+      if (!t.paused) {+        t.lines.push(...t.held);+        t.held = [];+        if (t.lines.length > TAIL_MAX_LINES) t.lines.splice(0, t.lines.length - TAIL_MAX_LINES);+        paintTail(t);+      }+      pause.textContent = t.paused ? "resume" : "pause";+    });+    bar.append(+      pause,+      button("clear", "empty this window (the node's own ring is untouched)", () => {+        t.lines = [];+        t.held = [];+        paintTail(t);+      }),+      button("unpin", "close this window", () => toggleTail(ref)),+    );+    const pre = document.createElement("pre");+    pre.className = "tail-body";+    t.pre = pre;+    win.append(bar, pre);+    dock.appendChild(win);+    pre.textContent = t.lines.join("\n");+    pre.scrollTop = pre.scrollHeight;+  }+}++function applyServe(e) {+  switch (e.kind) {+    case "declared":+    case "cleared":+      scheduleReload();+      if (state.history) loadHistory();+      break;+    case "converge-start":+      state.converge = { running: true, down: e.down, up: e.up };+      break;+    case "converge-stop":+      state.converge = { ok: e.ok, remaining: e.remaining };+      scheduleReload();+      break;+    case "tended":+      if (e.report) applyUpkeep({ ...e.report, stream: "upkeep" });+      break;+    default:+      break;+  }+}++function nodeOf(e) {+  return e.ref && state.nodes.get(e.ref.full);+}++function applyUpDown(e) {+  if (e.ref) pushTailLine(e.ref.full, `[updown] ${formatUpDownLine(e)}`);+  const n = nodeOf(e);+  if (!n) return;+  n.last = e.kind;+  switch (e.kind) {+    case "eval":+      n.lastReason = null;+      pulse(n);+      break;+    case "done":+      n.convergence = "converged";+      pulse(n);+      break;+    case "skip":+      n.convergence = "converged";+      break;+    case "failed":+      n.convergence = "errored";+      n.lastReason = e.error;+      pulse(n);+      break;+    case "blocked":+      n.convergence = "blocked";+      break;+    case "conflicting":+      n.lastReason = `conflicting: kept ${e.kept && e.kept.shorthand}, replaced ${e.replaced && e.replaced.shorthand}`;+      break;+    default:+      break;+  }+  paintNode(n);+}++function applyUpkeep(e) {+  if (e.kind === "acted" && e.report) {+    applyUpDown({ ...e.report, stream: "updown" });+    return;+  }+  if (e.ref) pushTailLine(e.ref.full, `[upkeep] ${formatUpkeepLine(e)}`);+  const n = nodeOf(e);+  if (!n) return;+  n.last = e.kind;+  switch (e.kind) {+    case "next-look":+      if (!n.status) n.status = {};+      n.status.check = e.check;+      n.lastReason = e.check && e.check.reason ? e.check.reason : null;+      break;+    case "upkeep":+    case "downkeep":+      n.machine = e.state;+      break;+    case "demoted":+      n.lastReason = `sent back by ${e.dependency && e.dependency.short}`;+      break;+    case "gave-up":+      n.lastReason = `gave up after ${e.failures} failure(s)`;+      break;+    case "escaped":+      n.lastReason = e.error;+      break;+    case "wedged":+      n.lastReason = `silent for ${Math.round(e.silent_us / 1e6)}s`;+      break;+    case "unwedged":+      n.lastReason = null;+      break;+    default:+      break;+  }+  paintNode(n);+}++function pulse(n) {+  n.pulse = true;+}++// ---------------------------------------------------------------------------+// layout: longest-path layering, then barycentre ordering (Sugiyama-lite)++const BOX_W = 176;+const BOX_H = 66;+const GAP_X = 28;+const GAP_Y = 64;+const PAD = 12;++function layout() {+  const ids = state.order;+  const depsOf = (id) => (state.nodes.get(id).dependencies || []).map((r) => r.full).filter((d) => state.nodes.has(d));+  const dependantsOf = (id) => (state.nodes.get(id).dependants || []).map((r) => r.full).filter((d) => state.nodes.has(d));++  // layer = longest path from a node with no dependencies; a cycle (which+  // the drivers report Blocked) is cut wherever it is first re-entered.+  const layer = new Map();+  const visiting = new Set();+  const layerOf = (id) => {+    if (layer.has(id)) return layer.get(id);+    if (visiting.has(id)) return 0;+    visiting.add(id);+    let l = 0;+    for (const d of depsOf(id)) l = Math.max(l, layerOf(d) + 1);+    visiting.delete(id);+    layer.set(id, l);+    return l;+  };+  ids.forEach(layerOf);++  const layers = [];+  for (const id of ids) {+    const l = layer.get(id);+    (layers[l] ||= []).push(id);+  }++  // order within a layer by the mean position of neighbours in the layers+  // already ordered: down sweeps look at dependencies, up sweeps at+  // dependants; a node with none keeps its place.+  const pos = new Map();+  const place = () => layers.forEach((row) => row.forEach((id, i) => pos.set(id, i)));+  place();+  const bary = (id, neigh) => {+    const ps = neigh(id).map((d) => pos.get(d)).filter((p) => p !== undefined);+    return ps.length ? ps.reduce((a, b) => a + b, 0) / ps.length : pos.get(id);+  };+  const sortRow = (row, neigh) => {+    const keyed = row.map((id) => [bary(id, neigh), pos.get(id), id]);+    keyed.sort((a, b) => a[0] - b[0] || a[1] - b[1]);+    return keyed.map((k) => k[2]);+  };+  for (let sweep = 0; sweep < 4; sweep++) {+    for (let l = 1; l < layers.length; l++) layers[l] = sortRow(layers[l], depsOf);+    place();+    for (let l = layers.length - 2; l >= 0; l--) layers[l] = sortRow(layers[l], dependantsOf);+    place();+  }++  // coordinates: each layer a row, centred on the widest one+  const widest = Math.max(...layers.map((r) => r.length));+  const width = widest * BOX_W + (widest - 1) * GAP_X + 2 * PAD;+  const coords = new Map();+  layers.forEach((row, l) => {+    const rowWidth = row.length * BOX_W + (row.length - 1) * GAP_X;+    const x0 = PAD + (width - 2 * PAD - rowWidth) / 2;+    row.forEach((id, i) => {+      coords.set(id, { x: x0 + i * (BOX_W + GAP_X), y: PAD + l * (BOX_H + GAP_Y) });+    });+  });+  const height = layers.length * BOX_H + (layers.length - 1) * GAP_Y + 2 * PAD;+  return { coords, width, height };+}++// ---------------------------------------------------------------------------+// rendering++function stateClass(n) {+  return n.direction === "down" ? "retiring" : n.convergence;+}++function stateLine(n) {+  const parts = [n.direction, n.convergence];+  if (n.machine) parts.push(n.machine);+  return parts.join(" · ");+}++function lastLine(n) {+  const parts = [];+  if (n.last) parts.push(n.last);+  const check = n.status && n.status.check;+  if (check && check.verdict) parts.push(`check: ${check.verdict}`);+  return parts.join("  ");+}++function render() {+  renderHeader();+  const empty = state.order.length === 0;+  $("empty").hidden = !empty;+  $("graph-viewport").style.display = empty ? "none" : "";+  renderGraph();+  renderList();+  renderPanel();+}++function renderHeader() {+  $("h-mode").textContent = state.mode;+  $("h-seq").textContent = String(state.seq);+  let converged = 0;+  let errored = 0;+  for (const n of state.nodes.values()) {+    if (n.convergence === "converged") converged++;+    if (n.convergence === "errored" || n.convergence === "blocked") errored++;+  }+  $("h-counts").textContent = `${converged} converged / ${errored} errored / ${state.nodes.size}`;+  const c = state.converge;+  $("h-converge").textContent = !c+    ? "–"+    : c.running+      ? `running (${c.down} down, ${c.up} up)`+      : `${c.ok ? "ok" : "failed"}, ${c.remaining} remaining`;+}++function renderGraph() {+  const edges = $("edges");+  const nodes = $("nodes");+  edges.replaceChildren();+  nodes.replaceChildren();+  if (state.order.length === 0) return;+  const { coords, width, height } = layout();+  state.worldSize = { width, height };++  for (const id of state.order) {+    const n = state.nodes.get(id);+    const to = coords.get(id);+    for (const d of n.dependencies || []) {+      const from = coords.get(d.full);+      if (!from) continue;+      const x1 = from.x + BOX_W / 2;+      const y1 = from.y + BOX_H;+      const x2 = to.x + BOX_W / 2;+      const y2 = to.y;+      const bend = Math.max(20, (y2 - y1) / 2);+      const p = document.createElementNS(SVG, "path");+      p.setAttribute("d", `M ${x1} ${y1} C ${x1} ${y1 + bend}, ${x2} ${y2 - bend}, ${x2} ${y2}`);+      p.dataset.from = d.full;+      p.dataset.to = id;+      edges.appendChild(p);+    }+  }++  for (const id of state.order) {+    const n = state.nodes.get(id);+    const c = coords.get(id);+    const g = document.createElementNS(SVG, "g");+    g.setAttribute("transform", `translate(${c.x} ${c.y})`);+    g.dataset.ref = id;+    const rect = document.createElementNS(SVG, "rect");+    rect.setAttribute("width", BOX_W);+    rect.setAttribute("height", BOX_H);+    g.appendChild(rect);+    g.appendChild(text("ref", 8, 15, `#${n.ref.short}`));+    g.appendChild(text("shorthand", 8, 32, n.shorthand));+    g.appendChild(text("state", 8, 47, ""));+    g.appendChild(text("last", 8, 60, ""));+    const title = document.createElementNS(SVG, "title");+    title.textContent = n.help;+    g.appendChild(title);+    // Selection is handled by the delegated, coordinate-based hit test+    // below (pointer capture retargets click's own bubble path away from+    // this element), not a listener here.+    g.addEventListener("animationend", () => g.classList.remove("pulse"));+    nodes.appendChild(g);+    n.el = g;+    paintNode(n);+  }+  highlightEdges();+  if (state.zoomInit) applyZoom();+  else fitView();+}++// ---------------------------------------------------------------------------+// pan/zoom: a transform on #viewport, world units = layout()'s raw pixels.+// The SVG itself has no viewBox (so 1 user unit = 1 CSS pixel of the+// rendered element), which is what keeps the wheel/drag math below in plain+// screen pixels instead of also tracking a separate content scale.++function applyZoom() {+  const z = state.zoom;+  $("viewport").setAttribute("transform", `translate(${z.tx} ${z.ty}) scale(${z.scale})`);+}++// Fits the whole graph in the viewport, centred. Called once on first load+// and from the "fit" button; a later re-render (a live update) keeps+// whatever the operator has already panned/zoomed to.+function fitView() {+  const vp = $("graph-viewport");+  const w = vp.clientWidth || 800;+  const h = vp.clientHeight || 500;+  const world = state.worldSize || { width: w, height: h };+  const raw = Math.min((w - 24) / world.width, (h - 24) / world.height) || 1;+  const scale = Math.max(MIN_ZOOM, Math.min(MAX_ZOOM, raw));+  state.zoom = {+    scale,+    tx: (w - world.width * scale) / 2,+    ty: (h - world.height * scale) / 2,+  };+  state.zoomInit = true;+  applyZoom();+}++// Zooms by `factor`, keeping the point at (cx, cy) — viewport-relative+// screen pixels — fixed under the cursor.+function zoomAt(cx, cy, factor) {+  const z = state.zoom;+  const newScale = Math.max(MIN_ZOOM, Math.min(MAX_ZOOM, z.scale * factor));+  const localX = (cx - z.tx) / z.scale;+  const localY = (cy - z.ty) / z.scale;+  z.scale = newScale;+  z.tx = cx - localX * newScale;+  z.ty = cy - localY * newScale;+  applyZoom();+}++function text(cls, x, y, content) {+  const t = document.createElementNS(SVG, "text");+  t.setAttribute("class", cls);+  t.setAttribute("x", x);+  t.setAttribute("y", y);+  t.textContent = clip(content, cls === "shorthand" ? 22 : 26);+  return t;+}++function clip(s, n) {+  s = String(s ?? "");+  return s.length > n ? s.slice(0, n - 1) + "…" : s;+}++// Repaint one box (and its list row) from the node's current fields.+function paintNode(n) {+  const cls = stateClass(n);+  if (n.el) {+    const g = n.el;+    g.setAttribute("class", `node ${cls}${n.touched ? " touched" : ""}${state.selected === n.ref.full ? " selected" : ""}`);+    g.querySelector(".state").textContent = clip(stateLine(n), 26);+    g.querySelector(".last").textContent = clip(lastLine(n), 30);+    if (n.pulse) {+      n.pulse = false;+      g.classList.remove("pulse");+      void g.getBoundingClientRect();+      g.classList.add("pulse");+    }+  }+  if (n.li) {+    n.li.className = `${cls}${n.touched ? " touched" : ""}${state.selected === n.ref.full ? " selected" : ""}`;+    n.li.querySelector(".state").textContent = stateLine(n) + (lastLine(n) ? ` — ${lastLine(n)}` : "");+  }+  if (state.selected === n.ref.full) renderPanel();+}++function renderList() {+  const list = $("list");+  list.replaceChildren();+  for (const id of state.order) {+    const n = state.nodes.get(id);+    const li = document.createElement("li");+    const ref = document.createElement("div");+    ref.className = "ref mono";+    ref.textContent = `#${n.ref.short}`;+    const sh = document.createElement("div");+    sh.textContent = n.shorthand;+    sh.style.fontWeight = "600";+    const st = document.createElement("div");+    st.className = "state";+    const deps = document.createElement("div");+    deps.className = "deps";+    deps.textContent = (n.dependencies || []).length ? `depends on ${n.dependencies.map((d) => "#" + d.short).join(", ")}` : "no dependencies";+    li.append(ref, sh, st, deps);+    li.addEventListener("click", () => select(id));+    list.appendChild(li);+    n.li = li;+    paintNode(n);+  }+}++function highlightEdges() {+  for (const p of $("edges").querySelectorAll("path")) {+    p.classList.toggle("hi", state.selected !== null && (p.dataset.from === state.selected || p.dataset.to === state.selected));+  }+}++// ---------------------------------------------------------------------------+// the side panel++function select(id) {+  const prev = state.selected;+  state.selected = state.selected === id ? null : id;+  if (prev && state.nodes.has(prev)) paintNode(state.nodes.get(prev));+  if (state.selected) paintNode(state.nodes.get(state.selected));+  highlightEdges();+  renderPanel();+}++function renderPanel() {+  const panel = $("panel");+  const n = state.selected && state.nodes.get(state.selected);+  if (!n) {+    panel.hidden = true;+    return;+  }+  panel.hidden = false;+  const body = $("panel-body");+  body.replaceChildren();+  const h = document.createElement("h2");+  h.textContent = n.shorthand;+  body.appendChild(h);+  body.appendChild(para("mono", `#${n.ref.short}`));++  const badges = document.createElement("p");+  for (const [cls, label] of [[stateClass(n), n.convergence], ["", `wanted ${n.direction}`], ...(n.machine ? [["", n.machine]] : [])]) {+    const b = document.createElement("span");+    b.className = `badge ${cls}`;+    b.textContent = label;+    badges.appendChild(b);+    badges.appendChild(document.createTextNode(" "));+  }+  body.appendChild(badges);++  // the four mailbox instructions, addressed by ref: the `#`-prefixed+  // selector is a prefix of the short ref, the same text the box prints.+  const actions = document.createElement("p");+  actions.className = "node-actions";+  for (const verb of ["force", "recheck", "pause", "resume"]) {+    const b = document.createElement("button");+    b.type = "button";+    b.textContent = verb;+    b.title = `${verb} --select #${n.ref.short}`;+    b.addEventListener("click", () => post(`${verb} --select ${quote("#" + n.ref.short)}`));+    actions.appendChild(b);+  }+  const tail = document.createElement("button");+  tail.type = "button";+  tail.textContent = state.tails.has(n.ref.full) ? "untail" : "tail";+  tail.title = "pin a live window of this node's output at the bottom of the page";+  tail.addEventListener("click", () => toggleTail(n.ref.full));+  actions.appendChild(tail);+  body.appendChild(actions);++  section(body, "help", n.help);+  section(body, "notes", n.notes);+  if (n.dynamics && n.dynamics.length) list(body, "dynamics", n.dynamics.map(String));+  if (n.paths && n.paths.length) list(body, "paths", n.paths, "mono");+  refList(body, "dependencies", n.dependencies);+  refList(body, "dependants", n.dependants);++  const check = n.status && n.status.check;+  const h3 = document.createElement("h3");+  h3.textContent = "last check";+  body.appendChild(h3);+  if (check) {+    body.appendChild(para("", check.verdict + (check.reason ? `: ${check.reason}` : "")));+  } else {+    body.appendChild(para("", "never tended"));+  }+  if (n.last) section(body, "last event", n.last + (n.lastReason ? `: ${n.lastReason}` : ""));+  if (n.status && n.status.output && n.status.output.length) {+    const h4 = document.createElement("h3");+    h4.textContent = "output";+    body.appendChild(h4);+    const pre = document.createElement("pre");+    pre.className = "output";+    pre.textContent = n.status.output.join("\n");+    body.appendChild(pre);+  }+  body.appendChild(sectionTitle("full ref"));+  const full = document.createElement("pre");+  full.textContent = n.ref.full;+  body.appendChild(full);++  // A node does not know which seed declared it, and /history does not say+  // which nodes an epoch declared, so the choice is the operator's: every+  // live declaration, each with its `down`.+  body.appendChild(sectionTitle("retire a seed"));+  if (!state.history) {+    const a = document.createElement("a");+    a.textContent = "load the history";+    a.addEventListener("click", () => loadHistory().then(renderPanel));+    body.appendChild(para("", "")).appendChild(a);+    return;+  }+  const live = state.history.seeds.filter((h) => h.active);+  if (live.length === 0) {+    body.appendChild(para("", "no live declaration"));+    return;+  }+  body.appendChild(para("muted", "the server does not say which of these declared this node"));+  for (const h of live) {+    const row = document.createElement("p");+    row.className = "seed-row";+    const words = document.createElement("span");+    words.className = "words mono";+    words.textContent = `${h.declaration} ${h.args.map(quote).join(" ")}`;+    const b = document.createElement("button");+    b.type = "button";+    b.textContent = "down";+    b.addEventListener("click", () => post(`down ${h.args.map(quote).join(" ")}`));+    row.append(words, b);+    body.appendChild(row);+  }+}++function sectionTitle(t) {+  const h = document.createElement("h3");+  h.textContent = t;+  return h;+}++function para(cls, t) {+  const p = document.createElement("p");+  if (cls) p.className = cls;+  p.textContent = t;+  return p;+}++function section(body, title, content) {+  body.appendChild(sectionTitle(title));+  const pre = document.createElement("pre");+  pre.textContent = content == null || content === "" ? "–" : String(content);+  body.appendChild(pre);+}++function list(body, title, items, cls) {+  body.appendChild(sectionTitle(title));+  const ul = document.createElement("ul");+  for (const it of items) {+    const li = document.createElement("li");+    if (cls) li.className = cls;+    li.textContent = it;+    ul.appendChild(li);+  }+  body.appendChild(ul);+}++function refList(body, title, refs) {+  body.appendChild(sectionTitle(title));+  if (!refs || refs.length === 0) {+    body.appendChild(para("", "none"));+    return;+  }+  const ul = document.createElement("ul");+  for (const r of refs) {+    const li = document.createElement("li");+    const a = document.createElement("a");+    const target = state.nodes.get(r.full);+    a.textContent = `#${r.short}${target ? ` ${target.shorthand}` : ""}`;+    a.addEventListener("click", () => select(r.full));+    li.appendChild(a);+    ul.appendChild(li);+  }+  body.appendChild(ul);+}++// ---------------------------------------------------------------------------+// commands: one POST /command?async, then the events carrying its origin++// A word of the input language, quoted for `Serve.tokenize` when it needs it.+function quote(w) {+  w = String(w);+  return /^[A-Za-z0-9_@%+=:,./#-]+$/.test(w) ? w : `'${w.replace(/\\/g, "\\\\").replace(/'/g, "\\'")}'`;+}++async function post(line) {+  line = String(line).trim();+  if (!line) return null;+  let r;+  let body;+  try {+    r = await fetch("command?async", { method: "POST", headers: { "content-type": "text/plain" }, body: line });+    if (r.status === 401) return signedOut();+    body = await r.json();+  } catch (err) {+    toast(`not sent: ${err.message || err}`, "bad");+    return null;+  }+  if (!r.ok) {+    toast(`${r.status}: ${body && body.error ? body.error : "refused"} — ${line}`, "bad");+    return null;+  }+  const req = { seq: body.seq, origin: body.origin, line, reports: [], done: false, li: null };+  state.requests.set(req.origin, req);+  logRequest(req);+  toast(`queued at seq ${body.seq}: ${line}`);+  // its reports may already have arrived: the stream does not wait for the+  // POST's answer to be read+  const early = state.unclaimed.filter((e) => claimant(e) === req.origin);+  state.unclaimed = state.unclaimed.filter((e) => !early.includes(e));+  early.forEach((e) => reportFor(req, e));+  return req;+}++// The request an event belongs to, by the origin it carries; `hung-up`+// names the origin it is about rather than being stamped with it.+function claimant(e) {+  if (e.kind === "hung-up" && e.from) return e.from;+  return e.origin && e.origin.kind === "other" ? e.origin.name : null;+}++function attribute(e) {+  const name = claimant(e);+  if (!name) return;+  const req = state.requests.get(name);+  if (req) {+    reportFor(req, e);+    return;+  }+  state.unclaimed.push(e);+  if (state.unclaimed.length > 500) state.unclaimed.shift();+}++function reportFor(req, e) {+  if (req.done) return;+  req.reports.push(e);+  if (e.kind === "enqueued") return;+  logLine(req, e);+  const n = nodeOf(e);+  if (n) {+    n.touched = req.origin;+    paintNode(n);+  }+  if (e.stream !== "serve") return;+  switch (e.kind) {+    case "hung-up":+      req.done = true;+      req.li.classList.add("done");+      setTimeout(() => untouch(req.origin), TOUCH_LINGER_MS);+      break;+    case "instructed":+      toast(`${e.instruction}: ${e.nodes} node(s)`, "ok");+      break;+    case "declared":+      toast(`declared ${e.direction}: epoch ${e.epoch}, ${e.nodes} node(s), ${e.active_seeds} live seed(s)`, "ok");+      break;+    case "cleared":+      toast(`cleared: ${e.retired} seed(s) retired`, "ok");+      break;+    case "converge-stop":+      toast(`converge: ${e.ok ? "ok" : "failed"}, ${e.remaining} remaining`, e.ok ? "ok" : "bad");+      break;+    case "fetch-requested":+      toast(e.following ? "fetch requested" : "nothing is being followed", e.following ? "ok" : "bad");+      break;+    default:+      if (e.kind.startsWith("bad-")) toast(`${errText(e.error)} — ${req.line}`, "bad");+      break;+  }+}++function untouch(origin) {+  for (const n of state.nodes.values()) {+    if (n.touched === origin) {+      n.touched = null;+      paintNode(n);+    }+  }+}++// ---------------------------------------------------------------------------+// toasts++function toast(text, cls) {+  const el = document.createElement("div");+  el.className = `toast${cls ? ` ${cls}` : ""}`;+  el.textContent = text;+  el.addEventListener("click", () => el.remove());+  $("toasts").appendChild(el);+  setTimeout(() => el.remove(), TOAST_MS);+}++// ---------------------------------------------------------------------------+// the log under the command line: one entry per request, its reports under it++function logRequest(req) {+  const li = document.createElement("li");+  const head = document.createElement("div");+  head.className = "request";+  head.textContent = `${req.seq} ${req.line} `;+  const origin = document.createElement("span");+  origin.className = "origin";+  origin.textContent = req.origin;+  head.appendChild(origin);+  const ul = document.createElement("ul");+  li.append(head, ul);+  req.li = li;+  const list = $("cli-log-list");+  list.appendChild(li);+  $("cli-log-count").textContent = `(${state.requests.size})`;+  list.scrollTop = list.scrollHeight;+}++function logLine(req, e) {+  const li = document.createElement("li");+  li.textContent = summarize(e);+  if (e.error || e.kind === "failed" || e.kind === "blocked") li.className = "bad";+  req.li.querySelector("ul").appendChild(li);+  if ($("cli-log").open) {+    const list = $("cli-log-list");+    list.scrollTop = list.scrollHeight;+  }+}++function summarize(e) {+  const parts = [String(e.seq ?? ""), `${e.stream}/${e.kind}`];+  if (e.ref && e.ref.short) parts.push(`#${e.ref.short}`);+  if (e.node && e.node.shorthand) parts.push(e.node.shorthand);+  switch (e.kind) {+    case "declared":+      parts.push(`epoch ${e.epoch} ${e.direction}, ${e.nodes} node(s), ${e.active_seeds} live`);+      break;+    case "cleared":+      parts.push(`${e.retired} retired`);+      break;+    case "converge-start":+      parts.push(`${e.down} down, ${e.up} up`);+      break;+    case "converge-stop":+      parts.push(`${e.ok ? "ok" : "failed"}, ${e.remaining} remaining`);+      break;+    case "instructed":+      parts.push(e.instruction, e.nodes !== undefined ? `${e.nodes} node(s)` : "");+      break;+    case "supervised":+    case "auto-converged":+      parts.push(e.on ? "on" : "off");+      break;+    case "hung-up":+      parts.push("done");+      break;+    case "help":+      parts.push(`${(e.lines || []).length} line(s)`);+      break;+    case "status":+    case "query":+      parts.push(`${(e.nodes || []).length} node(s)`);+      break;+    case "history":+      parts.push(`${(e.seeds || []).length} seed(s)`);+      break;+    default:+      break;+  }+  if (e.error) parts.push(errText(e.error));+  return parts.filter(Boolean).join(" ");+}++function errText(x) {+  return typeof x === "string" ? x : JSON.stringify(x);+}++// ---------------------------------------------------------------------------+// the seed panel: /help/seed, the form, /history++async function loadSeedHelp() {+  if (state.seedHelpLoaded) return;+  try {+    const r = await fetch("help/seed", { cache: "no-store" });+    if (!r.ok) throw new Error(`/help/seed answered ${r.status}`);+    const h = await r.json();+    $("seed-help").textContent = h.seed || "–";+    $("seed-commands").textContent = (h.commands || []).join("\n");+    state.seedHelpLoaded = true;+  } catch (err) {+    $("seed-help").textContent = `could not load: ${err.message || err}`;+  }+}++async function loadHistory() {+  let h;+  try {+    const r = await fetch("history", { cache: "no-store" });+    if (!r.ok) throw new Error(`/history answered ${r.status}`);+    h = await r.json();+  } catch (err) {+    toast(`history: ${err.message || err}`, "bad");+    return;+  }+  state.history = { seeds: h.seeds || [], elided: h.elided || 0 };+  renderHistory();+  if (state.selected) renderPanel();+}++function originText(o) {+  if (!o) return "–";+  switch (o.kind) {+    case "stdin":+      return "stdin";+    case "other":+      return o.name;+    case "loaded":+      return `loaded ${o.path}`;+    case "fetched":+      return `fetched ${o.label}`;+    default:+      return o.kind;+  }+}++function renderHistory() {+  const rows = $("history-rows");+  rows.replaceChildren();+  const h = state.history;+  if (!h) return;+  $("history-elided").textContent = h.elided ? `(${h.elided} older entries elided)` : "";+  $("history-empty").hidden = h.seeds.length > 0;+  $("history").hidden = h.seeds.length === 0;+  for (const s of [...h.seeds].reverse()) {+    const tr = document.createElement("tr");+    tr.className = s.active ? "active" : "retired";+    const words = s.args.map(quote).join(" ");+    const cells = [String(s.epoch), s.declaration, words, originText(s.origin)];+    cells.forEach((c, i) => {+      const td = document.createElement("td");+      td.textContent = c;+      if (i === 2) {+        td.className = "words";+        td.title = "put these words in the form";+        td.addEventListener("click", () => {+          $("seed-words").value = words;+          $("seed-words").focus();+        });+      }+      tr.appendChild(td);+    });+    const st = document.createElement("td");+    const badge = document.createElement("span");+    badge.className = `badge${s.active ? " active" : ""}`;+    badge.textContent = s.active ? "active" : "retired";+    st.appendChild(badge);+    tr.appendChild(st);+    const act = document.createElement("td");+    if (s.active) {+      const b = document.createElement("button");+      b.type = "button";+      b.textContent = "down";+      b.title = `down ${words}`;+      b.addEventListener("click", () => post(`down ${words}`));+      act.appendChild(b);+    }+    tr.appendChild(act);+    rows.appendChild(tr);+  }+}++function toggleSeeds(open) {+  const panel = $("seeds");+  const want = open === undefined ? panel.hidden : open;+  panel.hidden = !want;+  $("seeds-toggle").setAttribute("aria-expanded", String(want));+  if (want) {+    loadSeedHelp();+    loadHistory();+    $("seed-words").focus();+  }+}++function declare(verb) {+  const words = $("seed-words").value.trim();+  if (!words) {+    toast("no seed words", "bad");+    $("seed-words").focus();+    return;+  }+  post(`${verb} ${words}`);+}++// ---------------------------------------------------------------------------+// wiring++$("panel-close").addEventListener("click", () => select(state.selected));+$("reload").addEventListener("click", loadDag);++// wheel to zoom (centred on the cursor), drag to pan; a drag that actually+// moved suppresses the click it ends with, so panning never also selects+// whatever node the pointer happened to end up over.+{+  const svg = $("graph");+  const vp = $("graph-viewport");+  let dragging = false;+  let justPanned = false;+  let start = null;++  svg.addEventListener(+    "wheel",+    (ev) => {+      ev.preventDefault();+      const rect = svg.getBoundingClientRect();+      zoomAt(ev.clientX - rect.left, ev.clientY - rect.top, ev.deltaY < 0 ? 1.15 : 1 / 1.15);+    },+    { passive: false },+  );++  svg.addEventListener("pointerdown", (ev) => {+    if (ev.button !== 0) return;+    dragging = true;+    justPanned = false;+    start = { x: ev.clientX, y: ev.clientY, tx: state.zoom.tx, ty: state.zoom.ty };+    svg.setPointerCapture(ev.pointerId);+    svg.classList.add("panning");+  });+  svg.addEventListener("pointermove", (ev) => {+    if (!dragging) return;+    const dx = ev.clientX - start.x;+    const dy = ev.clientY - start.y;+    if (Math.hypot(dx, dy) > 3) justPanned = true;+    state.zoom.tx = start.tx + dx;+    state.zoom.ty = start.ty + dy;+    applyZoom();+  });+  const endDrag = (ev) => {+    if (!dragging) return;+    dragging = false;+    svg.classList.remove("panning");+    if (ev && ev.pointerId !== undefined) {+      try {+        svg.releasePointerCapture(ev.pointerId);+      } catch {+        // already released+      }+    }+  };+  svg.addEventListener("pointerup", endDrag);+  svg.addEventListener("pointercancel", endDrag);+  // Pointer capture is set on every pointerdown (above), which means the+  // browser retargets the whole click's mouse-compat sequence to `svg`+  // itself rather than whatever node is under the cursor — so a node `g`'s+  // own click listener never sees it. Hit-test from coordinates instead of+  // relying on the (retargeted) event target/bubble path.+  svg.addEventListener(+    "click",+    (ev) => {+      if (justPanned) {+        justPanned = false;+        ev.stopPropagation();+        ev.preventDefault();+        return;+      }+      const hit = document.elementFromPoint(ev.clientX, ev.clientY);+      const nodeEl = hit && hit.closest ? hit.closest("[data-ref]") : null;+      if (nodeEl) select(nodeEl.dataset.ref);+    },+    true,+  );++  $("zoom-in").addEventListener("click", () => zoomAt(vp.clientWidth / 2, vp.clientHeight / 2, 1.3));+  $("zoom-out").addEventListener("click", () => zoomAt(vp.clientWidth / 2, vp.clientHeight / 2, 1 / 1.3));+  $("zoom-reset").addEventListener("click", fitView);+}++for (const b of document.querySelectorAll("#actions button[data-line]")) {+  b.addEventListener("click", () => {+    if (b.dataset.confirm && !window.confirm(b.dataset.confirm)) return;+    post(b.dataset.line);+  });+}++$("seeds-toggle").addEventListener("click", () => toggleSeeds());+$("seed-form").addEventListener("submit", (ev) => {+  ev.preventDefault();+  declare("up");+});+for (const b of document.querySelectorAll("#seed-form button[data-verb]")) {+  if (b.type === "submit") continue;+  b.addEventListener("click", () => declare(b.dataset.verb));+}++$("cli-form").addEventListener("submit", (ev) => {+  ev.preventDefault();+  const input = $("cli-line");+  const line = input.value.trim();+  if (!line) return;+  input.value = "";+  post(line);+});++// `:` focuses the command line, as in `vi`/`less`; Esc leaves it.+document.addEventListener("keydown", (ev) => {+  const t = ev.target;+  const typing = t && (t.tagName === "INPUT" || t.tagName === "TEXTAREA");+  if (ev.key === ":" && !typing && !ev.ctrlKey && !ev.metaKey && !ev.altKey) {+    ev.preventDefault();+    $("cli-line").focus();+  } else if (ev.key === "Escape" && typing) {+    t.blur();+  }+});++// Over --http-tcp the page is signed in with a session cookie it cannot+// read (HttpOnly), so it asks; on the unix socket the answer is false and+// the button stays hidden.+async function offerSignOut() {+  try {+    const r = await fetch("auth/session", { cache: "no-store" });+    if (r.ok && (await r.json()).session === true) $("signout").hidden = false;+  } catch {+    // no button is the safe way to be wrong+  }+}++// A 401 means the session ended — signed out in another tab, expired, or+// the server restarted — and the sign-in page is the only thing that fixes it.+function signedOut() {+  closeStream();+  location.assign("auth?ended");+  return null;+}++offerSignOut();+loadDag();