diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,52 @@ # Revision history for salmon-ops -## 0.1.0.0 -- unreleased +## 0.2.0.0 -- unreleased + +Breaking: several exported records gained or changed fields (e.g. `Gcp.Compute`'s instance, +`Client.Model`'s model) and some exported functions changed signature. Requires +`salmon-core ^>=0.1.0.0` (unchanged). + +Packaging: a manual `http-server` flag (default on). `constraints: salmon-ops -http-server` +builds the library without `Salmon.Actions.Serve.Http` and without warp, warp-tls and wai, for a +binary that never serves HTTP; `run serve` then refuses `--http`/`--http-tcp`. The listener +configuration (`Bind`, `TlsBind`, `SessionPolicy`, `readTokenFile`) is now defined in +`Salmon.Actions.Serve.HttpBind` and still re-exported by `Salmon.Actions.Serve.Http`. + +New builtins: + +* `Podman.Quadlet`: containers as systemd services (bind volumes, `UserNS=keep-id`, readiness + wait, registry login from a GCE instance, container jobs); `Systemd.Job`: oneshot units, timers + and a node reading how the last run went. +* Postgres high availability: `Patroni`, `PgBackRest` (archive, PITR, replica method), + `Haproxy` routing to the leader by health check, `Etcd` join phase. +* `PgTextSearch`, `ClipCpp` (embeddings for pgvector), `Plakar` integrations and GCS store. +* `LlamaServer.llamaEmbed`: one text's vector from a running llama-server, for a loader. +* `SecretDelivery` (a pre-provisioned secret onto a machine), `Deferred` (a sub-graph built at + `up` from a value read then), `Netbird` peer enrolment, `PortMapping` (UPnP-IGD via `upnpc`), + `Rsync.receiveDir`. +* GCP: `Gcp.CloudDns` (managed zones; A, AAAA, CNAME, TXT, MX record sets); the load balancer + as one node per resource (HTTPS proxy, managed and replaceable certificates, host/path rules, + backend buckets, redirects, path rewrites, removal of what is no longer declared); + `Gcp.Storage` bucket IAM, lifecycle, website settings and published directories; + `Gcp.Compute` pinned internal address, access scopes, machine-type resize, run limit; + `Gcp.Core` declared gcloud account; Cloud Run min instances and always-allocated CPU. +* `Salmon.Builtin.Guarded` / `Salmon.Op.Guard`: guarded risky operations (preconditions in + `check`, park on failure, hold siblings). + +Behaviour: + +* Processes started for a node no longer inherit the pass's standard input. +* `Binary`: choose where a command's stdout/stderr go, with per-node log lines + (`Salmon.Builtin.NodeLog`); `Ssh`/`Self` follow a remote call's output and reports. +* `Dag.foldDag` visits each node once instead of each occurrence. +* `Query`/`serve`: paths are matched, never listed; a retraction redescribes nothing. +* Web UI: compact DAG layout, `/history` timeline, `Conflicting` pairs side by side. +* Web UI: an optional Tramaj card template per node (`withCardTemplate`), served on `/dag` as + `template` and drawn in place of the default card; presentation only, not part of the + representative. +* `Builtin.Cards`: opt-in card templates for `filecontents`, `dir`, `systemdService` and + Postgres `database` (`withCard (Cards.fileContents path) op`); no builtin attaches one itself. + +## 0.1.0.0 -- 2026-10-01 * First release. diff --git a/fixtures/QemuSmokeRootfsFixture.hs b/fixtures/QemuSmokeRootfsFixture.hs new file mode 100644 --- /dev/null +++ b/fixtures/QemuSmokeRootfsFixture.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} + +{- | The smoke rootfs of the Layer 3 qemu test tier, built by ops. + +"Test.QemuSmokeSpec" boots @\/var\/lib\/salmon-test-vms\/smoke\/root@. That +tree was first made by a hand-typed @debootstrap@ and then fixed by hand in +a chroot so that its initrd could mount a 9p root (see +@specs\/qemu-test-vms-progress.md@ §2). This is the same tree as three +nodes, the shape of @salmon-toy-qemu-pg-ha prereqs@ and of +@salmon-patroni-rootfs@: + + * 'Debootstrap.rootTree' with 'Debootstrap.vmEssentials' (a kernel and + sshd, nothing else: the smoke test only asks that the guest answers ssh); + * 'Debootstrap.ensureVm9pBoot', the node the hand-applied fix became; + * the @etc\/ssh@ subtree handed to the unprivileged user who runs the + tests, since "Test.Harness".'Test.Harness.ensureVmSshAccess' writes a + per-boot CA and an sshd drop-in there, on the host, before qemu starts. + Recursive, as @salmon-qemu-host-setup-fixture@ does it: the drop-in goes + into @sshd_config.d@, which debootstrap leaves to root. + +It needs root (debootstrap, and the bind mounts around @update-initramfs@): + +> sudo $(cabal list-bin salmon-qemu-smoke-rootfs-fixture) "$USER" +> sudo $(cabal list-bin salmon-qemu-smoke-rootfs-fixture) "$USER" /some/other/root + +Idempotent, and that cuts both ways: both Debootstrap nodes have a 'check' +(@etc\/issue@ exists; the modules file names @9pnet_virtio@), so a tree +that is already there is left as it is, however it was made. To /rebuild/ +the smoke rootfs, move the old tree aside first. The binary says so on +stderr when it finds one. +-} +module Main (main) where + +import Control.Monad (unless, when) +import Control.Monad.Identity (runIdentity) +import qualified Data.Text as Text +import System.Directory (doesFileExist) +import System.Environment (getArgs) +import System.Exit (die, exitFailure) +import System.FilePath (()) +import System.IO (hPutStrLn, stderr) + +import Salmon.Actions.UpDown (upTree) +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.Binary as Binary +import qualified Salmon.Builtin.Nodes.Debian.Debootstrap as Debootstrap +import qualified Salmon.Builtin.Nodes.Debian.OS as Debian +import qualified Salmon.Builtin.Nodes.User as User +import Salmon.Op.OpGraph (inject) +import Salmon.Reporter (reportPrint) + +-- | Where "Test.QemuSmokeSpec" looks for it. +defaultSmokeRootfs :: FilePath +defaultSmokeRootfs = "/var/lib/salmon-test-vms/smoke/root" + +-- | The tree, able to boot over 9p, with @etc\/ssh@ handed over. +smokeRootfs :: User.Owner -> FilePath -> Op +smokeRootfs owner rootfs = + handOver `inject` bootable + where + tree = Debootstrap.RootTree Debootstrap.Stable rootfs Debootstrap.vmEssentials + bootable = + Debootstrap.ensureVm9pBoot reportPrint bashTrack tree + `inject` Debootstrap.rootTree reportPrint debootstrapTrack tree + handOver = User.chown reportPrint Debian.chown True owner (rootfs "etc/ssh") + +bashTrack :: Track' (Binary.Binary "bash") +bashTrack = ignoreTrack + +debootstrapTrack :: Track' (Binary.Binary "debootstrap") +debootstrapTrack = ignoreTrack + +main :: IO () +main = do + args <- getArgs + case args of + [user] -> build user defaultSmokeRootfs + [user, rootfs] -> build user rootfs + _ -> die "usage: salmon-qemu-smoke-rootfs-fixture [rootfs-path]" + where + build user rootfs = do + existing <- doesFileExist (rootfs "etc/issue") + when existing $ + hPutStrLn stderr $ + "note: a tree already exists at " + <> rootfs + <> " and is left as it is; move it aside first to rebuild it from nothing" + let owner = User.Owner (User.User (Text.pack user)) (User.Group (Text.pack user)) + ok <- upTree reportPrint (pure . runIdentity) (smokeRootfs owner rootfs) + unless ok exitFailure diff --git a/fixtures/ServeFixture.hs b/fixtures/ServeFixture.hs --- a/fixtures/ServeFixture.hs +++ b/fixtures/ServeFixture.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} @@ -99,16 +100,39 @@ 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. + += The @--build N@ half + +A node that has something to say while its @up@ runs, which no other node +here does: a pretend build, a @\/bin\/sh@ loop printing @N@ steps a second +apart on stdout and a warning per step on stderr, run with +'Binary.streamed' routing, plus a progress message of its own +('NodeLog.say'). Under @run serve --http@ its lines reach the web UI's tail +window of that node live, and, from @\/dag@'s per-node @tail@, after a page +reload too: + +> up --dir /tmp/play --name web --file index.html --build 5 + += The @--card@ half + +The bundle node carries a card template ('withCardTemplate'): selecting it in +the web UI draws its card from the template instead of the default sections, +with a button back to the default card. Nothing else about the node changes +(same @ref@, @help@, representative). Each file node carries the builtin +file card ('Salmon.Builtin.Cards.fileContents') the same way: + +> up --dir /tmp/play --name web --file index.html --card -} module Main (main) where import Control.Exception (throwIO) +import Control.Monad (when) 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 Options.Applicative (auto, execParser, fullDesc, header, info, long, many, metavar, option, progDesc, strOption, switch, value) import qualified Options.Applicative as Opt import Options.Generic (ParseRecord (..)) import System.Directory (doesFileExist, removeFile) @@ -117,14 +141,17 @@ 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 Salmon.Builtin.Extension (Op, Track', check, deps, down, dynamics, help, ignoreTrack, managed, nodeps, notes, op, ref, up, withCardTemplate) +import qualified Salmon.Builtin.NodeLog as NodeLog +import qualified Salmon.Builtin.Nodes.Binary as Binary import qualified Salmon.Builtin.Nodes.Daemon as Daemon +import qualified Salmon.Builtin.Cards as Cards 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) +import Salmon.Reporter (reportIf, reportPrint, silent) ------------------------------------------------------------------------------- @@ -136,6 +163,8 @@ , seedDaemon :: Bool , seedGreeting :: Text , seedStaleCheck :: Bool + , seedBuild :: Int + , seedCard :: Bool } deriving (Generic, Show) @@ -156,6 +185,8 @@ ( long "stale-check" <> Opt.help "give the daemon a plausible-but-stale check (\"my log exists\"), which a bounce then ignores. See (I1)." ) + <*> option auto (long "build" <> metavar "N" <> value 0 <> Opt.help "also run a pretend build printing N steps, streamed, so a tail has lines (0: none)") + <*> switch (long "card" <> Opt.help "give the bundle node a card template, which the web UI draws in place of its default card") -- | 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 @@ -164,6 +195,11 @@ { specRoot :: FilePath , specFiles :: [FilePath] , specDaemon :: Maybe DaemonSpec + , specBuild :: Maybe Int + -- ^ the @--build N@ half, absent when not asked for + , specCard :: Maybe Text + -- ^ the @--card@ half: the bundle node's card template, absent when not + -- asked for (and in a directive written before it existed) } deriving (Eq, Show, Generic) @@ -205,16 +241,38 @@ , daemonStaleCheck = seed.seedStaleCheck } ) + (if seed.seedBuild > 0 then Just seed.seedBuild else Nothing) + (if seed.seedCard then Just bundleCard else Nothing) 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)} + op "serve-fixture-bundle" (deps (fmap (fileOp spec.specCard) spec.specFiles <> foldMap (pure . daemonOp) spec.specDaemon <> foldMap (pure . buildOp spec.specRoot) spec.specBuild)) $ \actions -> + maybe id withCardTemplate spec.specCard $ + 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"))) + fileOp :: Maybe Text -> FilePath -> Op + fileOp card path = + -- with --card, each file node carries the builtin file card too + -- ("Salmon.Builtin.Cards"); without it, the node is as it was + maybe id (const (Cards.withCard (Cards.fileContents path))) card $ + FS.filecontents (FS.FileContents path (Text.pack ("managed by salmon-ops-serve-fixture: " <> path <> "\n"))) +{- | The @--card@ half: a card template for the bundle node (contract in +@salmon-ops\/ui\/card-template.js@). Tramaj's @branch(else, cond, then)@ +evaluates both arms, which is why @$ctx.check@ is always an object. +-} +bundleCard :: Text +bundleCard = + Text.unlines + [ ".div(" + , " .p(class: branch(\"t-muted\", eq($ctx.convergence, \"converged\"), \"t-ok\"), \"a bundle of \", str(count($ctx.dependencies)), \" nodes, \", $ctx.convergence)," + , " .h4(\"paths\")," + , " .ul(map($ctx.paths, (p) => .li(.code($p))))," + , " .h4(\"last check\")," + , " .p(branch($ctx.check.verdict, eq($ctx.check.verdict, null), \"never checked\"))" + , ")" + ] + ------------------------------------------------------------------------------- -- the --daemon half: a process salmon owns, and the config it stands on @@ -319,6 +377,39 @@ chatter = reportIf notWrote reportPrint notWrote Daemon.Wrote{} = False notWrote _ = True + +------------------------------------------------------------------------------- +-- the --build half: a node that says things while its `up` runs + +shCommand :: Binary.Command "sh" String +shCommand = Binary.Command (\script -> proc "/bin/sh" ["-c", script]) + +{- | A pretend build. No @check@, so it is 'Immaterial': applied by the pass +that brings it up, then parked by its machine rather than re-run. Not +attached to the bundle directory, since it writes nothing. +-} +buildOp :: FilePath -> Int -> Op +buildOp root n = + Binary.withBinaryWith Binary.streamed ignoreTrack shCommand script $ \run -> + op "fixture-build" nodeps $ \actions -> + actions + { help = Text.pack ("a pretend build for " <> root <> ", " <> show n <> " steps") + , ref = self + , up = do + NodeLog.say self (Text.pack ("building " <> show n <> " steps")) + run silent + when (n > 0) $ NodeLog.say self "built" + } + where + self = mkRef "fixture-build" (root, n) + script = + mconcat + [ "for i in $(seq 1 " + , show n + , "); do echo \"step $i/" + , show n + , "\"; echo \"warning: step $i is pretend\" >&2; sleep 1; done" + ] ------------------------------------------------------------------------------- diff --git a/openapi/serve-api.openapi.json b/openapi/serve-api.openapi.json --- a/openapi/serve-api.openapi.json +++ b/openapi/serve-api.openapi.json @@ -4,7 +4,7 @@ "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 ` 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." + "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 ` 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`, refused with 403 whatever the line when the server was started with `--http-read-only` (`GET /access` says which). 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": [ { @@ -140,7 +140,7 @@ "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`.", + "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`. Under `run serve --http-read-only` every request is answered 403 before its body is read: nothing is queued or numbered.", "parameters": [ { "name": "async", @@ -203,6 +203,16 @@ } } }, + "403": { + "description": "the server is read-only (`--http-read-only`): it takes no command over HTTP", + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/Error" + } + } + } + }, "503": { "description": "the loop is not taking commands", "content": { @@ -216,6 +226,25 @@ } } }, + "/access": { + "get": { + "operationId": "getAccess", + "summary": "Whether this server takes commands", + "description": "`read-write` by default; `read-only` under `run serve --http-read-only`, where `POST /command` answers 403 on every listener. The page reads it to hide its buttons. The loop's other inputs (stdin, `--listen`) are not restricted by it.", + "responses": { + "200": { + "description": "the answer", + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/AccessAnswer" + } + } + } + } + } + } + }, "/events": { "get": { "operationId": "getEvents", @@ -605,6 +634,17 @@ "type": "string" } }, + "held_until": { + "oneOf": [ + { + "type": "string", + "format": "date-time" + }, + { + "type": "null" + } + ] + }, "selected": { "type": "boolean" }, @@ -621,7 +661,7 @@ "status", "paths" ], - "description": "A node as `status` lists it. `selected` and `excluded` are present in a `query` report only." + "description": "A node as `status` lists it. `selected` and `excluded` are present in a `query` report only. `paths` is at most 8 of the paths a `--select`/`--exclude` pattern can name the node by, the shortest first: a node under shared dependencies has more than can be listed, and a pattern built from one that is not listed still selects it. `held_until` is present only while the node is held back by a maintenance window (`run serve --maintenance-window`): when the next window opens, or null if none ever does." }, "Representative": { "type": "object", @@ -711,6 +751,12 @@ "$ref": "#/components/schemas/Ref" } }, + "tail": { + "type": "array", + "items": { + "$ref": "#/components/schemas/EventData" + } + }, "conflict": { "type": "object", "properties": { @@ -725,6 +771,9 @@ "kept", "replaced" ] + }, + "template": { + "type": "string" } }, "required": [ @@ -738,9 +787,10 @@ "notes", "dynamics", "dependencies", - "dependants" + "dependants", + "tail" ], - "description": "One node of the computed DAG. `conflict` is present while two live declarations disagree about the node." + "description": "One node of the computed DAG. `conflict` is present while two live declarations disagree about the node. `template` is present only on a node that carries a card template: Tramaj source the web UI evaluates against the node's own public fields to draw its card instead of the default one (contract in `ui/card-template.js`); it is presentation only, not part of the node's representative, and clients may ignore it. `paths` is at most 8 paths, the shortest first, as in a `status` node. `tail` is the newest events about this node, oldest first, exactly as `/events` sent them (each with its `seq`, none above the answer's `seq`): up to 256 of its `output` stream (a held action's lines, and what the node said while its `up` ran) and up to 64 of its `updown`/`upkeep` reports. It is what a view of one node is seeded from after a reload; unlike `status.output` (a tending machine's ring, snapshotted once per command) it includes what a one-shot `up` said during a pass." }, "NodeDescription": { "type": "object", @@ -1770,6 +1820,73 @@ "delay_us" ] }, + "Upkeep_held": { + "type": "object", + "properties": { + "stream": { + "const": "upkeep" + }, + "kind": { + "const": "held" + }, + "ref": { + "$ref": "#/components/schemas/Ref" + }, + "node": { + "$ref": "#/components/schemas/NodeDescription" + }, + "until": { + "oneOf": [ + { + "type": "string", + "format": "date-time" + }, + { + "type": "null" + } + ] + } + }, + "required": [ + "stream", + "kind", + "ref", + "node", + "until" + ], + "description": "A node marked disruptive whose effect needs applying while no maintenance window (`run serve --maintenance-window`) is open: its `up` waits. `until` is when the next window opens (null only if none ever does). Said once per episode by the node's machine, and by a convergence pass (inside `tended`) for a node its gate held back." + }, + "UpkeepUntagged_held": { + "type": "object", + "properties": { + "kind": { + "const": "held" + }, + "ref": { + "$ref": "#/components/schemas/Ref" + }, + "node": { + "$ref": "#/components/schemas/NodeDescription" + }, + "until": { + "oneOf": [ + { + "type": "string", + "format": "date-time" + }, + { + "type": "null" + } + ] + } + }, + "required": [ + "kind", + "ref", + "node", + "until" + ] + }, "Upkeep_paused": { "type": "object", "properties": { @@ -3204,6 +3321,9 @@ "$ref": "#/components/schemas/Upkeep_reapplying" }, { + "$ref": "#/components/schemas/Upkeep_held" + }, + { "$ref": "#/components/schemas/Upkeep_paused" }, { @@ -3301,6 +3421,9 @@ "$ref": "#/components/schemas/UpkeepUntagged_reapplying" }, { + "$ref": "#/components/schemas/UpkeepUntagged_held" + }, + { "$ref": "#/components/schemas/UpkeepUntagged_paused" }, { @@ -3460,6 +3583,39 @@ ], "description": "" }, + "Node_log": { + "type": "object", + "properties": { + "stream": { + "const": "output" + }, + "kind": { + "const": "log" + }, + "ref": { + "$ref": "#/components/schemas/Ref" + }, + "channel": { + "type": "string", + "enum": [ + "stdout", + "stderr", + "message" + ] + }, + "line": { + "type": "string" + } + }, + "required": [ + "stream", + "kind", + "ref", + "channel", + "line" + ], + "description": "One line a node said while working: a line of the output of a command it runs with streaming chosen (`stdout`, `stderr`), or a progress message of its own (`message`). Emitted while the node's `up` is still running, during a pass or under tending; filed on the `output` stream beside a held action's lines, names its node by `ref` alone, and carries no `origin`." + }, "Report": { "oneOf": [ { @@ -3473,9 +3629,12 @@ }, { "$ref": "#/components/schemas/FollowReport" + }, + { + "$ref": "#/components/schemas/Node_log" } ], - "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.", + "description": "One report, tagged by `stream` (who reported: `serve` the loop, `updown` a convergence pass, `upkeep` a tending machine, `follow` the pull-mode fetcher, `output` a node itself: a held action's lines and what any node says while it works) and `kind` (the constructor, kebab-cased). Exactly what `--json` prints, one object per line. Report text is public and carried verbatim.", "discriminator": { "propertyName": "stream" } @@ -3647,6 +3806,21 @@ } ], "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." + }, + "AccessAnswer": { + "type": "object", + "properties": { + "access": { + "type": "string", + "enum": [ + "read-write", + "read-only" + ] + } + }, + "required": [ + "access" + ] }, "AsyncAnswer": { "type": "object", diff --git a/salmon-ops.cabal b/salmon-ops.cabal --- a/salmon-ops.cabal +++ b/salmon-ops.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: salmon-ops -version: 0.1.0.0 +version: 0.2.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/ @@ -19,6 +19,12 @@ ui/ui.js ui/ui.css ui/auth.html + ui/tail-template.js + ui/card-template.js + ui/vendor/tramaj-js/*.js + ui/vendor/tramaj-js/LICENSE + ui-test/tail-template.test.mjs + ui-test/card-template.test.mjs openapi/serve-api.openapi.json source-repository head @@ -26,6 +32,16 @@ location: https://github.com/lucasdicioccio/salmon subdir: salmon-ops +flag http-server + description: Build @run serve@'s HTTP surface (@--http@, @--http-tcp@, + the web UI, "Salmon.Actions.Serve.Http"), and with it warp, + warp-tls and wai. Turn it off (@constraints: salmon-ops + -http-server@) for a binary that never serves HTTP; @serve@ + over standard input and @--listen@, pull mode and the + status sink stay. + default: True + manual: True + library exposed-modules: Salmon.Actions.Concurrent , Salmon.Actions.Follow @@ -38,7 +54,7 @@ , Salmon.Actions.Help , Salmon.Actions.Serve , Salmon.Actions.Serve.Events - , Salmon.Actions.Serve.Http + , Salmon.Actions.Serve.HttpBind , Salmon.Actions.Serve.Socket , Salmon.Actions.Serve.StatusSink , Salmon.Actions.Fleet @@ -49,13 +65,21 @@ , Salmon.Client.Http , Salmon.Client.Model , Salmon.Builtin.Extension + , Salmon.Builtin.Cards + , Salmon.Builtin.Cards.Gcp + , Salmon.Builtin.Cards.Keys + , Salmon.Builtin.Cards.Patroni + , Salmon.Builtin.Cards.Postgres + , Salmon.Builtin.Guarded , Salmon.Builtin.CommandLine , Salmon.Builtin.Helpers , Salmon.Builtin.Migrations , Salmon.Builtin.Nodes.Bash + , Salmon.Builtin.NodeLog , Salmon.Builtin.Nodes.Binary , Salmon.Builtin.Nodes.Cabal , Salmon.Builtin.Nodes.Daemon + , Salmon.Builtin.Nodes.Detached , Salmon.Builtin.Nodes.Capabilities , Salmon.Builtin.Nodes.Certificates , Salmon.Builtin.Nodes.Continuation @@ -67,6 +91,7 @@ , Salmon.Builtin.Nodes.Demo , Salmon.Builtin.Nodes.Gcp.ArtifactRegistry , Salmon.Builtin.Nodes.Gcp.Billing + , Salmon.Builtin.Nodes.Gcp.CloudDns , Salmon.Builtin.Nodes.Gcp.CloudRun , Salmon.Builtin.Nodes.Gcp.Compute , Salmon.Builtin.Nodes.Gcp.Core @@ -82,32 +107,49 @@ , Salmon.Builtin.Nodes.Git , Salmon.Builtin.Nodes.User , Salmon.Builtin.Nodes.Keys + , Salmon.Builtin.Nodes.Deferred , Salmon.Builtin.Nodes.LinuxBridge , Salmon.Builtin.Nodes.Netfilter + , Salmon.Builtin.Nodes.Netbird , Salmon.Builtin.Nodes.Nginx , Salmon.Builtin.Nodes.Npm , Salmon.Builtin.Nodes.PgBouncer + , Salmon.Builtin.Nodes.Haproxy + , Salmon.Builtin.Nodes.PortMapping + , Salmon.Builtin.Nodes.PortMapping.Upnpc , Salmon.Builtin.Nodes.Etcd + , Salmon.Builtin.Nodes.Patroni + , Salmon.Builtin.Nodes.Patroni.PreferredLeader + , Salmon.Builtin.Nodes.Patroni.RollingMaintenance + , Salmon.Builtin.Nodes.PgBackRest , Salmon.Builtin.Nodes.Postgres + , Salmon.Builtin.Nodes.ClipCpp , Salmon.Builtin.Nodes.LlamaServer , Salmon.Builtin.Nodes.PgVector + , Salmon.Builtin.Nodes.PgTextSearch , Salmon.Builtin.Nodes.Plakar , Salmon.Builtin.Nodes.Podman + , Salmon.Builtin.Nodes.Podman.Quadlet , Salmon.Builtin.Nodes.Qemu + , Salmon.Builtin.Nodes.Readiness , Salmon.Builtin.Nodes.Rsync , Salmon.Builtin.Nodes.Routes , Salmon.Builtin.Nodes.Self + , Salmon.Builtin.Nodes.SecretDelivery , Salmon.Builtin.Nodes.Secrets , Salmon.Builtin.Nodes.Spago , Salmon.Builtin.Nodes.Ssh , Salmon.Builtin.Nodes.Sysctl , Salmon.Builtin.Nodes.Systemd + , Salmon.Builtin.Nodes.Systemd.Job , Salmon.Builtin.Nodes.Tar , Salmon.Builtin.Nodes.Upx , Salmon.Builtin.Nodes.Web , Salmon.Builtin.Nodes.WireGuard + , Salmon.Op.CardTemplate , Salmon.Op.Concurrency , Salmon.Op.Dag + , Salmon.Op.Guard , Salmon.Op.Ledger , Salmon.Op.Mailbox , Salmon.Op.Rewrite @@ -118,7 +160,9 @@ , Salmon.Op.Ref , Salmon.Reporter , Salmon.Reporter.Tagged + , Salmon.Reporter.UpDownText build-depends: base >=4.16.3.0 && <4.22 + , array , async , aeson , base64-bytestring @@ -149,11 +193,17 @@ , text , time , unix - , wai - , warp , tls - , warp-tls hs-source-dirs: src + if flag(http-server) + exposed-modules: Salmon.Actions.Serve.Http + build-depends: wai + , warp + , warp-tls + cpp-options: -DSALMON_HTTP_SERVER + else + other-modules: Salmon.Actions.Serve.NoHttp + hs-source-dirs: src-no-http-server default-language: Haskell2010 default-extensions: KindSignatures , DataKinds @@ -169,7 +219,7 @@ build-depends: base >=4.16.3.0 && <4.22 , mtl , salmon-core ^>=0.1.0.0 - , salmon-ops ^>=0.1.0.0 + , salmon-ops ^>=0.2.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. @@ -185,7 +235,7 @@ build-depends: base >=4.16.3.0 && <4.22 , mtl , salmon-core ^>=0.1.0.0 - , salmon-ops ^>=0.1.0.0 + , salmon-ops ^>=0.2.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. @@ -203,7 +253,7 @@ , mtl , filepath , salmon-core ^>=0.1.0.0 - , salmon-ops ^>=0.1.0.0 + , salmon-ops ^>=0.2.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. @@ -213,6 +263,22 @@ , OverloadedRecordDot , ScopedTypeVariables +executable salmon-qemu-smoke-rootfs-fixture + main-is: QemuSmokeRootfsFixture.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.2.0.0 + , text + ghc-options: -threaded + default-language: Haskell2010 + default-extensions: OverloadedStrings + , OverloadedRecordDot + , ScopedTypeVariables + executable salmon-ops-serve-fixture main-is: ServeFixture.hs hs-source-dirs: fixtures @@ -224,7 +290,7 @@ , optparse-generic , process , salmon-core ^>=0.1.0.0 - , salmon-ops ^>=0.1.0.0 + , salmon-ops ^>=0.2.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. diff --git a/src-no-http-server/Salmon/Actions/Serve/NoHttp.hs b/src-no-http-server/Salmon/Actions/Serve/NoHttp.hs new file mode 100644 --- /dev/null +++ b/src-no-http-server/Salmon/Actions/Serve/NoHttp.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE EmptyCase #-} + +{- | What "Salmon.Builtin.CommandLine" uses of "Salmon.Actions.Serve.Http", +for a @salmon-ops@ built with @-http-server@: the same names, a 'Server' that +cannot exist, and a 'withHttpServerOn' that refuses. + +Hidden (an @other-module@) and named apart on purpose: code that imports +"Salmon.Actions.Serve.Http" fails to build without the flag, rather than +compiling against a server that never answers. The command line refuses +@--http@\/@--http-tcp@ before it gets here, so 'withHttpServerOn' is the +second line of defence, not the message an operator reads. +-} +module Salmon.Actions.Serve.NoHttp ( + module Salmon.Actions.Serve.HttpBind, + Server, + withHttpServerOn, + serverObserver, + serverProducer, + serverReporters, + serverFollowReporter, + serverNodeLogReporter, +) where + +import Data.Text (Text) + +import Salmon.Actions.Serve (Producer, Mode) +import qualified Salmon.Actions.Serve.Events as Events +import Salmon.Actions.Serve.HttpBind +import Salmon.Reporter (Reporter) + +-- | No value: without the flag there is no server to hand anything. +data Server + +withHttpServerOn :: Events.Config -> [Bind] -> Text -> IO Mode -> (Server -> IO a) -> IO a +withHttpServerOn _ _ _ _ _ = ioError (userError "salmon-ops was built without its http-server flag: no HTTP listener") + +serverObserver :: Server -> IO w -> IO () +serverObserver s = case s of {} + +serverProducer :: Server -> Producer +serverProducer s = case s of {} + +serverReporters :: Server -> a -> a +serverReporters s = case s of {} + +serverFollowReporter :: Server -> Reporter a +serverFollowReporter s = case s of {} + +serverNodeLogReporter :: Server -> Reporter a +serverNodeLogReporter s = case s of {} diff --git a/src/Salmon/Actions/Query.hs b/src/Salmon/Actions/Query.hs --- a/src/Salmon/Actions/Query.hs +++ b/src/Salmon/Actions/Query.hs @@ -9,6 +9,13 @@ 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'. + +The paths themselves are never listed to do that. The expanded graph is a +/tree/: a shared predecessor is a whole subtree again under each of its +parents, so the number of paths to a node doubles with every diamond above +it. Everything here that must answer on any graph goes through an 'Outline' +instead — the same graph with one entry per 'Ref' — and only 'pathedNodes', +which is asked for exactly that listing, still walks every occurrence. -} module Salmon.Actions.Query ( -- * Patterns @@ -16,6 +23,20 @@ parsePattern, matchPattern, + -- * One entry per node + Outline, + outline, + outlineRefs, + outlineRoots, + outlineChildren, + outlineFirstPaths, + matchOutline, + pathLimit, + pathCap, + ListedPath (..), + outlinePaths, + renderListedPath, + -- * Resolving selectors against an expanded graph pathedRefs, pathedNodes, @@ -97,11 +118,315 @@ ------------------------------------------------------------------------------- --- | Every node's path (as segments, root-to-node) paired with the 'Ref' found there. +{- | An expanded graph with one entry per 'Ref': what a node is called, the +nodes directly under it, and the path it was first met at. + +Building it ('outline') descends into a 'Ref' the first time it is met and +not again, which is what keeps it linear in nodes and edges where the tree +it is read from is exponential in the number of diamonds. A later occurrence +is looked at one level deep: a node directly under it that was not under +this 'Ref' before is added and walked in turn, which is enough for a node +declared a second time with one more dependency. What it does not see is an +occurrence whose own dependencies are the ones already known but whose +dependencies' subtrees differ from their first occurrence; and a 'Ref' met +under two shorthands keeps the first. +-} +data Outline = Outline + { outlineEntries :: !(Map Ref Entry) + , outlineRootsRev :: ![Ref] + -- ^ the nodes with no 'Ref'-carrying node above them, last met first + , outlineRootSet :: !(Set Ref) + -- ^ the same, as a set: what asking whether a node is a root reads, so + -- that a graph with many roots is not searched once per root. + , outlineOrderRev :: ![Ref] + -- ^ every node, last met first + } + +data Entry = Entry + { entryShorthand :: !Text + , entryHelp :: !Text + , entryFirstPath :: ![Text] + , entryChildrenRev :: ![Ref] + , entryChildSet :: !(Set Ref) + -- ^ the same, as a set: what asking whether a node is already under + -- this one reads, so that a node with many children (a fan) is not + -- searched once per child. + } + +-- | See 'Outline'. +outline :: Cofree Graph Op -> Outline +outline = go Nothing [] (Outline Map.empty [] Set.empty []) + where + -- the node above (if any), the path to it, and what has been seen so far. + go :: Maybe Ref -> [Text] -> Outline -> Cofree Graph Op -> Outline + go parent pfx acc (x :< g) = + case x.node of + Actionless -> List.foldl' (go parent pfx) acc (toList g) + Actions act -> + let ref = act.extension.ref + in case Map.lookup ref acc.outlineEntries of + Nothing -> + let path = pfx <> [shorthand act] + entered = + acc + { outlineEntries = + Map.insert ref (Entry (shorthand act) act.extension.help path [] Set.empty) acc.outlineEntries + , outlineOrderRev = ref : acc.outlineOrderRev + } + in List.foldl' (go (Just ref) path) (link parent ref entered) (toList g) + Just e -> + List.foldl' (peek ref e.entryFirstPath) (link parent ref acc) (toList g) + + -- a later occurrence of @ref@: only what is new directly under it is walked. + peek :: Ref -> [Text] -> Outline -> Cofree Graph Op -> Outline + peek ref path acc c@(x :< g) = + case x.node of + Actionless -> List.foldl' (peek ref path) acc (toList g) + Actions act + | linked (Just ref) act.extension.ref acc -> acc + | otherwise -> go (Just ref) path acc c + + linked :: Maybe Ref -> Ref -> Outline -> Bool + linked Nothing ref acc = ref `Set.member` acc.outlineRootSet + linked (Just parent) ref acc = + maybe False (Set.member ref . (.entryChildSet)) (Map.lookup parent acc.outlineEntries) + + link :: Maybe Ref -> Ref -> Outline -> Outline + link parent ref acc + | linked parent ref acc = acc + | otherwise = case parent of + Nothing -> acc{outlineRootsRev = ref : acc.outlineRootsRev, outlineRootSet = Set.insert ref acc.outlineRootSet} + Just p -> + acc{outlineEntries = Map.adjust (\e -> e{entryChildrenRev = ref : e.entryChildrenRev, entryChildSet = Set.insert ref e.entryChildSet}) p acc.outlineEntries} + +-- | Every node of the graph. +outlineRefs :: Outline -> Set Ref +outlineRefs = Map.keysSet . (.outlineEntries) + +-- | The nodes with no node above them, in the order they were first met. +outlineRoots :: Outline -> [Ref] +outlineRoots o = reverse o.outlineRootsRev + +-- | The nodes directly under a node, in the order they were first met under +-- it; nothing for a 'Ref' the outline does not hold. +outlineChildren :: Outline -> Ref -> [Ref] +outlineChildren o ref = maybe [] (reverse . (.entryChildrenRev)) (Map.lookup ref o.outlineEntries) + +{- | Each node once, in the order and at the path a walk of the whole tree +first meets it, with its help text: 'pathedNodes' keeping the first entry +per 'Ref', without listing the others. +-} +outlineFirstPaths :: Outline -> [([Text], Ref, Text)] +outlineFirstPaths o = + [ (e.entryFirstPath, ref, e.entryHelp) + | ref <- reverse o.outlineOrderRev + , Just e <- [Map.lookup ref o.outlineEntries] + ] + +{- | The nodes reached by at least one path the pattern matches: what +filtering 'pathedRefs' with 'matchPattern' gives, without the listing. + +The pattern is read as an automaton whose states are its suffixes, and the +graph is searched for the (node, suffix) pairs that can occur, each visited +once — so the cost is nodes and edges times the pattern's length, however +many paths there are. +-} +matchOutline :: [PatternSegment] -> Outline -> Set Ref +matchOutline pat o = go Set.empty Set.empty [(r, i) | r <- o.outlineRootsRev, i <- closure 0] + where + n = length pat + segments = Map.fromList (zip [0 :: Int ..] pat) + + -- a @**@ may match nothing, so being at one is also being past it. + closure :: Int -> [Int] + closure i = case Map.lookup i segments of + Just DoubleStar -> i : closure (i + 1) + _ -> [i] + + -- where reading one path segment at suffix @i@ leaves the pattern. + consume :: Text -> Int -> [Int] + consume seg i = case Map.lookup i segments of + Just (Lit l) | l == seg -> closure (i + 1) + Just Star -> closure (i + 1) + Just DoubleStar -> closure i + _ -> [] + + go :: Set (Ref, Int) -> Set Ref -> [(Ref, Int)] -> Set Ref + go _ matched [] = matched + go visited matched (item@(ref, i) : rest) + | item `Set.member` visited = go visited matched rest + | otherwise = case Map.lookup ref o.outlineEntries of + Nothing -> go (Set.insert item visited) matched rest + Just e -> + let after = consume e.entryShorthand i + matched' = if n `elem` after then Set.insert ref matched else matched + next = [(c, j) | c <- e.entryChildrenRev, j <- after, j < n] + in go (Set.insert item visited) matched' (next <> rest) + +-- | How many paths per node the callers in this tree ask 'outlinePaths' for. +pathLimit :: Int +pathLimit = 8 + +{- | The rendered length (as @\/a\/b@, one character per separator) above +which a listed path is not spelled out in full: 'outlinePaths' keeps only +its last segments and 'renderListedPath' shows them after a @**\/@. + +Counted in characters, not segments, for two reasons. The listing is ordered +by rendered length first, so every path at or under the cap sorts before +every path over it: the paths that are still spelled out are exactly the +ones the uncapped listing had at or under the cap, in the same order and at +the same positions. And characters are what a path costs to hold and to +send, whatever its segments are called. + +256 so that a recipe's paths (a few dozen characters; the deepest a @serve@ +test asserts is 161) are left alone, while a node on a chain of thousands +costs a few hundred characters a path instead of its depth. Not derived from +a survey of real graphs: change it here. +-} +pathCap :: Int +pathCap = 256 + +{- | A path as 'outlinePaths' lists it. + +'listedWidth' is always the full path's rendered length (as @\/a\/b@), even +when only its tail is kept, so a capped path still sorts by how long it +really is. 'listedSegments' is every segment, root first, when +'listedWidth' is at most the cap; otherwise ('listedCapped') it is the +longest tail whose own rendered length is at most the cap, and never less +than the node's own segment. +-} +data ListedPath = ListedPath + { listedWidth :: !Int + , listedCapped :: !Bool + , listedSegments :: ![Text] + } + deriving (Show, Eq) + +{- | What a listed path shows, the way 'Salmon.Actions.Serve.worldPaths' +renders paths (segments joined by @\/@, no leading one): the path itself, +or for a capped one @**\/@ and its tail. Either is a pattern that selects +the node ('matchOutline'); a capped one may select other nodes as well. +This is the one place that decides what a capped path looks like. +-} +renderListedPath :: ListedPath -> Text +renderListedPath p + | p.listedCapped = "**/" <> Text.intercalate "/" p.listedSegments + | otherwise = Text.intercalate "/" p.listedSegments + +{- | @outlinePaths limit cap@: at most @limit@ paths to each node, shortest +first by rendered length. A path whose rendered length is at most @cap@ is +listed in full, and those are exactly, in the same order, what sorting +'pathedRefs' per 'Ref' by (rendered length, segments) gives at or under +@cap@. A longer path keeps only its tail (see 'ListedPath'): the capped +paths listed are still the shortest by rendered length, but which of several +of equal length are kept, and in what order, is decided step by step on what +each step still has (their tails read from the node upwards), not over every +path; two that leave the same tail show the same text and are listed once +(the shorter), so a node can list fewer than @limit@ although it has more +paths. A node with more paths +than that is reachable by paths not listed here, and a pattern built from +one of those still selects it ('matchOutline'). + +Computed from the top down, each node's paths from those of the nodes above +it; the shortest paths to a node extend shortest paths to the node above, so +keeping @limit@ at each step loses none of the final ones that are spelled +out. Each step handles at most @limit@ paths per edge of at most @cap@ +characters (plus the node's own segment) each, so the cost is per node and +edge, not per node times its depth: on a chain the uncapped listing held +nodes x depth segments. +-} +outlinePaths :: Int -> Int -> Outline -> Map Ref [ListedPath] +outlinePaths limit cap o = List.foldl' place Map.empty topDown + where + childrenOf ref = maybe [] (.entryChildrenRev) (Map.lookup ref o.outlineEntries) + + parents :: Map Ref [Ref] + parents = Map.fromListWith (<>) [(c, [p]) | (p, e) <- Map.toList o.outlineEntries, c <- e.entryChildrenRev] + + roots = Set.fromList o.outlineRootsRev + + -- every node after all the nodes above it (a depth-first post-order, + -- reversed). An edge closing a cycle is one whose upper end comes later + -- and has no paths yet, so it contributes none. + topDown :: [Ref] + topDown = snd (List.foldl' visit (Set.empty, []) o.outlineRootsRev) + + visit :: (Set Ref, [Ref]) -> Ref -> (Set Ref, [Ref]) + visit (seen, done) ref + | ref `Set.member` seen = (seen, done) + | otherwise = + let (seen', done') = List.foldl' visit (Set.insert ref seen, done) (childrenOf ref) + in (seen', ref : done') + + place :: Map Ref [ListedPath] -> Ref -> Map Ref [ListedPath] + place acc ref = case Map.lookup ref o.outlineEntries of + Nothing -> acc + Just e -> + let seg = e.entryShorthand + own = [extend seg (ListedPath 0 False []) | ref `Set.member` roots] + inherited = + [ extend seg p + | parent <- Map.findWithDefault [] ref parents + , p <- Map.findWithDefault [] parent acc + ] + in Map.insert ref (shortest (own <> inherited)) acc + + extend :: Text -> ListedPath -> ListedPath + extend seg p + | not p.listedCapped && width <= cap = ListedPath width False (p.listedSegments <> [seg]) + | otherwise = ListedPath width True (tailWithin (p.listedSegments <> [seg])) + where + width = p.listedWidth + Text.length seg + 1 + + -- the longest tail of these segments rendering in at most @cap@ + -- characters, and at least the last one. + tailWithin :: [Text] -> [Text] + tailWithin segs = case reverse segs of + [] -> [] + (lst : before) -> go [lst] (Text.length lst + 1) before + where + go kept _ [] = kept + go kept w (s : rest) + | w' <= cap = go (s : kept) w' rest + | otherwise = kept + where + w' = w + Text.length s + 1 + + -- the @limit@ shortest of these paths, without repeats. Spelled-out + -- paths compare as the uncapped listing did (length, then segments); + -- capped ones, all longer, by their tail from the node upwards. Capped + -- paths that leave the same tail show the same text whatever their + -- length, so only the shortest of them is kept (and the longer ones' + -- extensions would show one text again, so dropping them here drops + -- nothing a node below would list). + shortest :: [ListedPath] -> [ListedPath] + shortest = take limit . distinctTails Set.empty . Map.elems . Map.fromList . map (\p -> (key p, p)) + + distinctTails :: Set [Text] -> [ListedPath] -> [ListedPath] + distinctTails _ [] = [] + distinctTails seen (p : ps) + | not p.listedCapped = p : distinctTails seen ps + | p.listedSegments `Set.member` seen = distinctTails seen ps + | otherwise = p : distinctTails (Set.insert p.listedSegments seen) ps + + key :: ListedPath -> (Int, Bool, [Text]) + key p = (p.listedWidth, p.listedCapped, if p.listedCapped then reverse p.listedSegments else p.listedSegments) + +------------------------------------------------------------------------------- + +{- | Every node's path (as segments, root-to-node) paired with the 'Ref' found +there. One entry per /occurrence/, like 'pathedNodes'. +-} 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. +{- | Like 'pathedRefs', but also carries each node's 'Salmon.Builtin.Extension.help' text. + +One entry per occurrence in the expanded tree, so its length is exponential +in the number of shared dependencies stacked on one another: a listing for +whoever asked to see every path, never a step towards answering something +else. 'outline' is that step. +-} pathedNodes :: Cofree Graph Op -> [([Text], Ref, Text)] pathedNodes = go [] where @@ -124,9 +449,9 @@ 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) + o = outline cograph + matches pats = Set.unions [matchOutline (parsePattern pat) o | pat <- pats] + allRefs = outlineRefs o selectedBase = if null selectPatterns then allRefs else matches selectPatterns excluded = matches excludePatterns selected = selectedBase `Set.difference` excluded @@ -169,15 +494,15 @@ resolveRewrittenSelectors cograph computed selectPatterns excludePatterns = (selected, excluded) where - entries = pathedRefs cograph - allRefs = Set.fromList (map snd entries) + o = outline cograph + allRefs = outlineRefs o (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.unions [matchOutline (parsePattern pat) o | pat <- pathPats] `Set.union` Set.unions (map matchRefPattern refPats) -- an empty select list still means "everything", exactly as @@ -199,7 +524,7 @@ matchRefPattern pat = declaredHits `Set.union` viaComputed where fragment = Text.drop 1 pat - declaredHits = Set.fromList [ref | (_, ref) <- entries, matchesRefFragment fragment ref] + declaredHits = Set.filter (matchesRefFragment fragment) allRefs computedHits = [cref | cref <- Map.keys (Dag.dagNodes computed.computedDag), matchesRefFragment fragment cref] viaComputed = Set.unions (map (Rewrite.membersOf computed) computedHits) @@ -255,7 +580,7 @@ concatMap render entries where entries - | dedupe = dedupeBy (\(_, ref, _) -> ref) (pathedNodes cograph) + | dedupe = outlineFirstPaths (outline cograph) | otherwise = pathedNodes cograph -- how many (post-dedupe) entries render to this exact path text; >1 means it needs disambiguating. @@ -274,14 +599,6 @@ | 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 ------------------------------------------------------------------------------- diff --git a/src/Salmon/Actions/Serve.hs b/src/Salmon/Actions/Serve.hs --- a/src/Salmon/Actions/Serve.hs +++ b/src/Salmon/Actions/Serve.hs @@ -129,6 +129,9 @@ serveAttributed, serveFollowing, serveObserved, + serveObservedWith, + serveSaying, + serveSayingWith, Followed (..), AppliedDocument (..), Mode (..), @@ -212,6 +215,7 @@ -- imported with their field selectors: OverloadedRecordDot only solves -- HasField for fields that are in scope. import Salmon.Builtin.Extension (Extension (..), Op, Track', evalDeps) +import qualified Salmon.Builtin.NodeLog as NodeLog import Salmon.Op.Actions (Act (..), ShortHand) import Salmon.Op.Concurrency (ConcurrencyLimit) import Salmon.Op.Configure (Configure, gen) @@ -230,6 +234,7 @@ import Salmon.Op.Status (Direction (..)) import qualified Salmon.Op.Status as MachineStatus import Salmon.Op.Supervision (Micros (..)) +import qualified Salmon.Op.Window as Window import Salmon.Op.Track (run) import Salmon.Reporter import qualified Salmon.Actions.Upkeep as Upkeep @@ -292,6 +297,12 @@ -- the next time tending starts, which is what keeps its snapshot -- refreshing across commands too, rather than freezing at whenever it -- first started holding. + , nodeHeld :: !(Maybe (Maybe UTCTime)) + -- ^ held back by the maintenance windows ('serveObservedWith'): the last + -- pass's gate, or the node's machine, found it due while no window was + -- open. The inner value is when the next window opens ('Nothing' if none + -- ever does). Cleared the next time the node is recorded as anything + -- (applied, found in place, failed...). Always 'Nothing' without windows. } deriving (Show) @@ -695,7 +706,7 @@ | -- | 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 + -- shortest 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 @@ -814,6 +825,9 @@ , st.nodeShorthand , renderVerdict st.nodeStatus ] + -- appended rather than a column, so a node that is not held + -- prints exactly what it always did + <> maybe "" (\next -> " [held by maintenance window " <> Window.renderHold next <> "]") st.nodeHeld pathLines = case Map.findWithDefault [] r paths of [] -> [" path: (none — not reached by any live declaration's graph)"] [p] -> [" path: " <> p] @@ -946,6 +960,11 @@ <> unRef dep <> " stopped being up" ] + -- said once per episode, so not filtered like 'NextLook': a node + -- that is due and is not being applied is what an operator wants to + -- see, with when it will be. + Upkeep.Held act next -> + ["serve: " <> act.shorthand <> " held by maintenance window " <> Window.renderHold next] Upkeep.Paused act -> ["serve: " <> act.shorthand <> " paused (its effect is untouched)"] Upkeep.Resumed act -> ["serve: " <> act.shorthand <> " resumed"] Upkeep.Policy act _ ignored -> @@ -1692,18 +1711,100 @@ Maybe Followed -> [Producer] -> IO (World seed directive) -serveObserved observe rewrites limit autoConverge0 rAttributed nodeReporterAttributed parseSeed configure program onFetch producers = do +serveObserved = serveObservedWith Window.noWindows + +{- | 'serveObserved' under maintenance windows (@run serve +--maintenance-window@). A node marked 'Window.disruptive' is brought up only +while a window is open: outside every window a convergence pass skips it +without recording it 'Converged' (so it stays outstanding, and @status@ says +until when it is held: 'nodeHeld'), and its machine, when one tends it, waits +for the next opening before running its @up@ ('Upkeep.startUpkeepWith'). +Nothing wanted down is held, and with 'Window.noWindows' this is +'serveObserved'. +-} +serveObservedWith :: + forall seed directive. + (ToJSON directive, FromJSON directive) => + Window.Windows -> + (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) +serveObservedWith windows 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 + serveLoop windows 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) +{- | 'serveObserved', with a listener for what nodes say while they work +("Salmon.Builtin.NodeLog"), registered for as long as the loop runs and +stamped from the same "line being handled" cell as every report: a line a +node says during the pass a command started belongs to whoever typed the +command, one said while it is being tended between commands to nobody. That +is what lets a socket client be sent the lines of its own commands +("Salmon.Actions.Serve.Socket"). One caveat the cell carries for reports too: +a held action that says something while a command is being handled is +stamped with that command. +-} +serveSaying :: + forall seed directive. + (ToJSON directive, FromJSON directive) => + Reporter (Attributed NodeLog.Line) -> + (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) +serveSaying = serveSayingWith Window.noWindows + +-- | 'serveSaying' under maintenance windows; see 'serveObservedWith'. +serveSayingWith :: + forall seed directive. + (ToJSON directive, FromJSON directive) => + Window.Windows -> + Reporter (Attributed NodeLog.Line) -> + (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) +serveSayingWith windows said observe rewrites limit autoConverge0 rAttributed nodeReporterAttributed parseSeed configure program onFetch producers = do + handling <- newIORef Nothing + NodeLog.withSink (stamp handling said) $ + serveLoop windows 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) => + Window.Windows -> (IO (World seed directive) -> IO ()) -> [Rewrite Extension] -> Maybe ConcurrencyLimit -> @@ -1717,7 +1818,7 @@ Maybe Followed -> [Producer] -> IO (World seed directive) -serveLoop observe rewrites limit autoConverge0 handling r nodeReporter parseSeed configure program onFetch producers = do +serveLoop windows 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 @@ -1830,7 +1931,8 @@ kept <- readIORef (tendingKept tending) forced <- Map.keysSet <$> readIORef (tendingPending tending) sup <- - Upkeep.startUpkeep + Upkeep.startUpkeepWith + windows (tendReporter world computed) kept (tendOf auto forced w computed) @@ -2045,6 +2147,12 @@ Upkeep.Downkeep{} -> pure () Upkeep.NextLook{} -> pure () Upkeep.Untended{} -> pure () + -- recorded for @status@ as well as said; whatever the machine + -- records next about the node clears it ('setConvergence'). + Upkeep.Held act next -> do + forM_ (Set.toList (Rewrite.membersOf computed act.extension.ref)) $ \rf -> + atomicModifyIORef' world (\w -> (setHeld rf next w, ())) + runReporter r (Tended rep) _ -> runReporter r (Tended rep) {- | 'stateWriter', for a driver that tends both directions at once. @@ -2311,13 +2419,16 @@ -- 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. + -- the nodes this pass's gate held back for the maintenance windows, + -- so that their 'UpDown.Skip' is not taken for convergence. + heldNow <- newIORef Map.empty okDown <- if ndown == 0 then pure True else Concurrent.downDagConcurrent - (gateFor world computed TurnDown restriction) - (recorder world computed TurnDown restriction) + (gateFor world computed TurnDown restriction heldNow) + (recorder world computed TurnDown restriction heldNow) Concurrent.noMailboxes limit dag @@ -2326,8 +2437,8 @@ then pure True else Concurrent.upDagConcurrent - (gateFor world computed TurnUp restriction) - (recorder world computed TurnUp restriction) + (gateFor world computed TurnUp restriction heldNow) + (recorder world computed TurnUp restriction heldNow) Concurrent.noMailboxes limit dag @@ -2341,26 +2452,43 @@ {- | 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 + left alone. + + And on the way up, a node the pass would touch but the maintenance + windows hold back ('Window.holdOf'): skipped, filed in @heldNow@ so + 'recorder' does not take the skip for convergence, and marked 'nodeHeld' + for @status@. Asked after everything else, so the clock is read only + for a 'Window.disruptive' node this pass is actually about to apply. -} + gateFor :: IORef (World seed directive) -> Rewritten Extension -> Direction -> Maybe (Set Ref) -> IORef (Map Ref (Maybe UTCTime)) -> UpDown.Gate Extension + gateFor world computed dir restriction heldNow = \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 + let members = Set.toList (Rewrite.membersOf computed act.extension.ref) + let due = + -- 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) members + then Required + else Skippable + case (due, dir) of + (Required, TurnUp) -> do + hold <- Window.holdOf windows act.extension + case hold of + Window.Free -> pure Required + Window.HeldUntil next -> do + atomicModifyIORef' heldNow (\m -> (Map.insert act.extension.ref next m, ())) + forM_ members $ \rf -> atomicModifyIORef' world (\w' -> (setHeld rf next w', ())) + pure Skippable + _ -> pure due where wants :: World seed directive -> Ref -> Bool wants w rf = @@ -2371,8 +2499,18 @@ && 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 + {- | A node 'gateFor' held back for the maintenance windows was skipped, + but is not converged and was not found in place: its 'UpDown.Skip' is + neither recorded nor printed, and the pass says 'Upkeep.Held' instead, + the same report its machine gives when it is the one holding. -} + recorder :: IORef (World seed directive) -> Rewritten Extension -> Direction -> Maybe (Set Ref) -> IORef (Map Ref (Maybe UTCTime)) -> Reporter (UpDown.Report Extension) + recorder world computed dir restriction heldNow = ReporterM $ \rep -> do + held <- case rep of + UpDown.Skip act -> fmap ((,) act) . Map.lookup act.extension.ref <$> readIORef heldNow + _ -> pure Nothing + case held of + Just (act, next) -> runReporter r (Tended (Upkeep.Held act next)) + Nothing -> runReporter (reportBoth (stateWriter world computed dir restriction) nodeReporter) rep {- 'upTree'/'downTree' report an 'Eval' before running a node and, once it returns, exactly one of 'Done' (succeeded) or 'Failed' (threw) — so @@ -2451,9 +2589,16 @@ , 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 + , worldMagma = case decl of + -- a retraction says who no longer wants a node, not what the + -- node is: the magma keeps what it has (what was applied, and + -- what any other live declaration describes), and only gains + -- the nodes it had never heard of, which a `down` of something + -- never declared still has to be able to walk. + Remove -> Map.union w.worldMagma (Dag.dagNodes dag) + -- left-biased: this declaration's representatives win, which is + -- 'Salmon.Op.Dag''s last-writer-wins across declarations. + _ -> 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 @@ -2525,9 +2670,21 @@ 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. + + A retraction redescribes nothing. Without that, retiring the older of + two declarations that describe one node differently -- the way to + replace a declaration without @only@: declare the new one, then retire + the old -- put the retired description back in the magma, marked the + node 'Stale', and had the next pass re-apply it as the declaration that + had just been withdrawn. -} changed :: Set Ref - changed = + changed + | Remove <- decl = Set.empty + | otherwise = redescribed + + redescribed :: Set Ref + redescribed = Set.fromList [ rf | (rf, newAct) <- Map.toList (Dag.dagNodes dag) @@ -2594,7 +2751,7 @@ Just st | st.nodeDirection == dir -> st{nodeShorthand = sh, nodeHelp = hlp} - _ -> NodeState sh hlp dir Pending Nothing + _ -> NodeState sh hlp dir Pending Nothing Nothing {- | Drops what is finished, which is what keeps a long-lived @serve@ bounded. Three rules that have to agree with each other: @@ -2665,7 +2822,7 @@ w{worldNodes = Map.adjust upd r w.worldNodes} where upd st - | st.nodeDirection == dir = st{nodeConvergence = c} + | st.nodeDirection == dir = st{nodeConvergence = c, nodeHeld = Nothing} | otherwise = st {- | 'setConvergence' against whichever direction the node is currently @@ -2682,6 +2839,10 @@ Nothing -> w Just st -> setConvergence st.nodeDirection r c w +-- | Held back by the maintenance windows until then; its convergence is untouched. +setHeld :: Ref -> Maybe UTCTime -> World seed directive -> World seed directive +setHeld r next w = w{worldNodes = Map.adjust (\st -> st{nodeHeld = Just next}) r w.worldNodes} + -- | (nodes wanted up, nodes wanted down) that have not converged yet. pendingCounts :: World seed directive -> (Int, Int) pendingCounts w = @@ -2746,7 +2907,7 @@ 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 +gives a path pattern no way to tell them apart, and printing the paths in 'worldPaths' cannot invent a distinction that was never there. -} resolveWorldSelectors :: World seed directive -> Selection -> (Set Ref, Set Ref) @@ -2756,11 +2917,14 @@ (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] + -- one entry per node and never the list of paths, whose length is + -- exponential in the shared dependencies (see 'Query.Outline'). + outlines = [Query.outline ep.epochGraph | ep <- w.worldEpochs] + allRefs = Set.unions (map Query.outlineRefs outlines) + pathMatches :: [Text] -> Set Ref - pathMatches [] = Set.empty - pathMatches pats = Set.unions [fst (Query.resolveSelectors ep.epochGraph pats []) | ep <- w.worldEpochs] + pathMatches pats = Set.unions [Query.matchOutline (Query.parsePattern pat) o | pat <- pats, o <- outlines] refMatches :: [Text] -> Set Ref refMatches pats = Set.fromList [rf | rf <- Set.toList allRefs, pat <- pats, matchesRefFragment pat rf] @@ -2786,15 +2950,24 @@ activeEpochIds :: World seed directive -> Set EpochId activeEpochIds w = Set.fromList (fmap epochId w.worldEpochs) -{- | Every path (rendered @\/@-separated, root-to-node, exactly the shape +{- | Paths (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 +within one seed's graph, can have more than one path, and any one is a valid +selector. __A path longer than 'Query.pathCap' characters is shown as +@**\/@ and its tail__ ('Query.renderListedPath'), still a pattern that +selects the node (and maybe others), so that a node deep in a long chain +does not cost its depth to list; shorter ones are unchanged, and are sorted +before it by the full path's length, as they always were. +__At most 'Query.pathLimit' are listed__, the shortest: a shared +dependency is a path again under each node standing on it, so the number of +paths doubles with every diamond above a node, and listing them all is what +kept @\/dag@ and @\/status@ from ever answering on a 138-node graph. A +pattern built from a path that is not listed still selects the node. 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 @@ -2802,10 +2975,9 @@ -} worldPaths :: World seed directive -> Map Ref [Text] worldPaths w = - Map.map (nub . sortOn Text.length) $ - Map.fromListWith + Map.map (take Query.pathLimit . nub . map Query.renderListedPath . sortOn (.listedWidth)) $ + Map.unionsWith (++) - [ (ref, [Text.intercalate "/" path]) + [ Query.outlinePaths Query.pathLimit Query.pathCap (Query.outline ep.epochGraph) | ep <- w.worldEpochs - , (path, ref) <- Query.pathedRefs ep.epochGraph ] diff --git a/src/Salmon/Actions/Serve/Events.hs b/src/Salmon/Actions/Serve/Events.hs --- a/src/Salmon/Actions/Serve/Events.hs +++ b/src/Salmon/Actions/Serve/Events.hs @@ -67,6 +67,23 @@ 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@. + += Per-node tails + +Beside the ring, every event about one node ('Tagged.taggedNode') is kept in +that node's own tail, in the same transaction: the newest +'configTailOutput' of its @output@ stream (what a held action wrote, what a +node said while its @up@ ran) and, apart, the newest 'configTailReports' of +the rest (@updown@ and @upkeep@ reports), so a node polled every few seconds +does not push a build's output out with its @next-look@s. The ring is shared +by every node and turns over in minutes on a busy loop; a tail is what a +client opening (or reloading) a view of /one/ node is seeded from, and +@\/dag@ carries it per node ('snapshotTails'). Read with the sequence number +in one transaction, a tail holds exactly the events numbered up to that +number, so a client seeded from it and following @?since=@ that number sees +every line once. At most 'configTailNodes' nodes keep a tail; past that the +one quietest for longest is dropped, which bounds what a long-running loop +whose declarations keep minting new refs holds on to. -} module Salmon.Actions.Serve.Events ( -- * The record @@ -78,6 +95,16 @@ Event (..), Body (..), + -- * Per-node tails + Tails, + emptyTails, + Lane (..), + laneOf, + recordTail, + tailOf, + tailNodes, + snapshotTails, + -- * Feeding it publish, enqueued, @@ -103,11 +130,14 @@ 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 Control.Monad (forM_, 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.List (sortOn) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import Data.Sequence (Seq, (|>)) import qualified Data.Sequence as Seq import Data.Set (Set) @@ -119,7 +149,8 @@ import qualified Salmon.Actions.Serve as Serve import Salmon.Actions.Serve (Attributed (..), Origin) import Salmon.Reporter -import Salmon.Reporter.Tagged (Tagged (..), originValue) +import Salmon.Op.Ref (Ref) +import Salmon.Reporter.Tagged (Tagged (..), originValue, taggedNode) ------------------------------------------------------------------------------- @@ -130,12 +161,28 @@ -- ^ 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 + , configTailOutput :: !Int + -- ^ per node, how many of its @output@-stream events its tail keeps + , configTailReports :: !Int + -- ^ per node, how many of its other events (@updown@, @upkeep@) its + -- tail keeps + , configTailNodes :: !Int + -- ^ how many nodes keep a tail at all; see "Per-node tails" } deriving (Show, Eq) --- | A ring in the low thousands, a keep-alive every fifteen seconds. +-- | A ring in the low thousands, a keep-alive every fifteen seconds, and +-- per node the 256 lines of output a machine's own ring also keeps +-- ("Salmon.Op.Status") with 64 reports beside them. defaultConfig :: Config -defaultConfig = Config{configRing = 2048, configKeepAlive = 15 * 1000000} +defaultConfig = + Config + { configRing = 2048 + , configKeepAlive = 15 * 1000000 + , configTailOutput = 256 + , configTailReports = 64 + , configTailNodes = 4096 + } -- | What an event is about. data Body @@ -164,6 +211,8 @@ , eventsChan :: !(TChan Event) -- ^ broadcast; a subscriber reads a 'dupTChan' of it , eventsSubscribers :: !(TVar Int) + , eventsTails :: !(TVar Tails) + -- ^ per node, the newest events about it; see "Per-node tails" } newEvents :: Config -> IO Events @@ -173,8 +222,87 @@ <*> newTVarIO Seq.empty <*> newBroadcastTChanIO <*> newTVarIO 0 + <*> newTVarIO emptyTails ------------------------------------------------------------------------------- +-- per-node tails + +-- | Which of a node's two bounded queues an event goes to. +data Lane + = -- | the @output@ stream: lines + OutputLane + | -- | everything else about the node: reports + ReportLane + deriving (Show, Eq, Ord) + +-- | The node an event is about and the lane it goes to, if it is about one. +laneOf :: Body -> Maybe (Ref, Lane) +laneOf body = case body of + Reported tagged -> (\r -> (r, if streamOf body == "output" then OutputLane else ReportLane)) <$> taggedNode tagged + Enqueued _ -> Nothing + +data NodeTail = NodeTail + { tailNewest :: !Word64 + -- ^ the number of the newest event kept, which eviction goes by + , tailOutput :: !(Seq Event) + , tailReports :: !(Seq Event) + } + +-- | Every node's tail. Pure, so that it can be checked without a loop. +newtype Tails = Tails (Map Ref NodeTail) + +emptyTails :: Tails +emptyTails = Tails Map.empty + +{- | Keep an event in a node's tail, under the limits a 'Config' sets: the +lane's oldest is dropped past its bound and, a node new to the tails +pushing them past 'configTailNodes', the node whose newest event is the +oldest goes. Events are expected in increasing number, as 'publish' hands +them out. +-} +recordTail :: Config -> Ref -> Lane -> Event -> Tails -> Tails +recordTail cfg r lane e (Tails m) = Tails (evict (Map.alter (Just . add) r m)) + where + add :: Maybe NodeTail -> NodeTail + add prior = + let t = maybe (NodeTail 0 Seq.empty Seq.empty) id prior + in case lane of + OutputLane -> t{tailNewest = e.eventSeq, tailOutput = bounded cfg.configTailOutput (t.tailOutput |> e)} + ReportLane -> t{tailNewest = e.eventSeq, tailReports = bounded cfg.configTailReports (t.tailReports |> e)} + + bounded :: Int -> Seq Event -> Seq Event + bounded k q = Seq.drop (Seq.length q - max 0 k) q + + evict :: Map Ref NodeTail -> Map Ref NodeTail + evict m' + | Map.size m' <= max 1 cfg.configTailNodes = m' + | otherwise = case Map.foldrWithKey quietest Nothing (Map.delete r m') of + Just (victim, _) -> evict (Map.delete victim m') + Nothing -> m' + + quietest :: Ref -> NodeTail -> Maybe (Ref, Word64) -> Maybe (Ref, Word64) + quietest k t acc = case acc of + Just (_, n) | n <= t.tailNewest -> acc + _ -> Just (k, t.tailNewest) + +-- | A node's tail, both lanes, oldest first. +tailOf :: Ref -> Tails -> [Event] +tailOf r (Tails m) = case Map.lookup r m of + Nothing -> [] + Just t -> sortOn (.eventSeq) (toList t.tailOutput <> toList t.tailReports) + +-- | The nodes that have a tail. +tailNodes :: Tails -> [Ref] +tailNodes (Tails m) = Map.keys m + +{- | The last number handed out and every node's tail, read together: the +tails then hold exactly the events numbered up to it, so a client seeded +from them follows @?since=@ that number and sees each event once. +-} +snapshotTails :: Events -> IO (Word64, Tails) +snapshotTails ev = atomically ((,) <$> readTVar ev.eventsLast <*> readTVar ev.eventsTails) + +------------------------------------------------------------------------------- -- feeding {- | Number a body, keep it, broadcast it: one transaction, see the module @@ -188,6 +316,8 @@ modifyTVar' ev.eventsRing $ \ring -> let ring' = ring |> e in if Seq.length ring' > ev.eventsConfig.configRing then Seq.drop 1 ring' else ring' + forM_ (laneOf body) $ \(r, lane) -> + modifyTVar' ev.eventsTails (recordTail ev.eventsConfig r lane e) writeTChan ev.eventsChan e pure n @@ -296,6 +426,7 @@ Reported (FromUpkeep (Upkeep.Output _ _)) -> "output" Reported (FromUpkeep _) -> "upkeep" Reported (FromFollow _) -> "follow" + Reported (FromNode _) -> "output" Enqueued _ -> "server" ------------------------------------------------------------------------------- diff --git a/src/Salmon/Actions/Serve/Http.hs b/src/Salmon/Actions/Serve/Http.hs --- a/src/Salmon/Actions/Serve/Http.hs +++ b/src/Salmon/Actions/Serve/Http.hs @@ -31,6 +31,9 @@ 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 \/access@ — whether this server takes commands at all + (@{"access": "read-write"}@, or @"read-only"@ under + @--http-read-only@, see 'Access'), so the page can hide its buttons. * @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 @@ -147,6 +150,10 @@ withHttpServer, withHttpServerWith, + -- * Spectate-only + Access (..), + withHttpServerAccess, + -- * Over the network Bind (..), TlsBind (..), @@ -173,8 +180,10 @@ -- * Plugging into the loop serverObserver, serverProducer, + awaitLoop, serverReporters, serverFollowReporter, + serverNodeLogReporter, -- * The command body renderStructured, @@ -186,6 +195,7 @@ WorldView (..), viewWorld, dagValue, + dagValueWith, application, ) where @@ -227,7 +237,7 @@ 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 Salmon.Actions.Serve.HttpBind (Bind (..), SessionPolicy (..), TlsBind (..), TokenError (..), defaultSessionPolicy, readTokenFile) import qualified Salmon.Actions.Serve as Serve import Salmon.Actions.Serve (Attributed (..), Declaration, EpochId, Line (..), NodeState (..), Origin (..), Producer (..), World (..)) @@ -236,7 +246,9 @@ import qualified Salmon.Actions.Serve.Socket as Socket import qualified Salmon.Actions.UpDown as UpDown import Salmon.Builtin.Extension (Extension (..)) +import qualified Salmon.Builtin.NodeLog as NodeLog import Salmon.Op.Actions (Act (..)) +import Salmon.Op.CardTemplate (cardTemplateOf) import Salmon.Op.Dag (Dag) import qualified Salmon.Op.Dag as Dag import Salmon.Op.Ref (Ref) @@ -272,8 +284,27 @@ , 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 + , serverAccess :: Access + -- ^ whether @POST \/command@ is taken at all ('ReadOnly': never) } +{- | What the HTTP surface lets a client do. 'ReadWrite' is every version of +@--http@ before the choice existed; 'ReadOnly' (@run serve --http-read-only@) +answers every @POST \/command@ with @403@ whatever the line, before the body +is read or anything is queued, on every listener of the server alike, so no +HTTP request can change what the loop converges towards, its supervision, +or end it. The reads, @\/events@ and the page are unchanged, and the page +asks @GET \/access@ to hide its buttons. The loop's other inputs (stdin, +@--listen@'s socket) are not this server's to restrict: the operator who +started the loop keeps control of it. +-} +data Access = ReadWrite | ReadOnly + deriving (Eq, Show) + +accessName :: Access -> Text +accessName ReadWrite = "read-write" +accessName ReadOnly = "read-only" + -- | The reports a synchronous command has been answered with so far. data Collector = Collector { collectorReports :: TVar [Tagged] @@ -281,33 +312,6 @@ , 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. @@ -338,8 +342,12 @@ 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 +withHttpServerOn :: Events.Config -> [Bind] -> Text -> IO Serve.Mode -> (Server -> IO a) -> IO a +withHttpServerOn cfg = withHttpServerAccess cfg ReadWrite + +-- | 'withHttpServerOn' with the 'Access' chosen ('ReadOnly' for @--http-read-only@). +withHttpServerAccess :: forall a. Events.Config -> Access -> [Bind] -> Text -> IO Serve.Mode -> (Server -> IO a) -> IO a +withHttpServerAccess cfg access binds seedHelp mode act = do server <- Server name <$> newTVarIO [] @@ -351,6 +359,7 @@ <*> Events.newEvents cfg <*> pure mode <*> newTVarIO False + <*> pure access listenOn server binds where name :: String @@ -591,33 +600,6 @@ WrongToken -> "

That is not the token.

" SessionEnded -> "

Your session ended; sign in again.

" -{- | 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. @@ -749,32 +731,6 @@ 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. -} @@ -792,6 +748,26 @@ atomically (writeTVar (serverInbox server) (Just inbox)) atomically retry `finally` atomically (writeTVar (serverInbox server) Nothing) +{- | Block until the loop has installed its read accessor +('serverObserver') and published its inbox ('serverProducer'): from then +on a read answers from the world and a command is queued, where before +either answers @503@ (\"the loop has not started\" / \"the loop is not +taking commands\"). The socket is bound before the loop runs, and the +producer that publishes the inbox is a thread the loop forks, so a client +that connects the moment the server is up can arrive first: that @503@ is +the right answer for that moment, and a caller that must not see it (a +spec driving the loop it just forked) waits here rather than retrying. +Retries in STM, so it costs nothing while it waits; it never returns if +the loop never starts, so bound it with a timeout. +-} +awaitLoop :: Server -> IO () +awaitLoop server = atomically $ do + view <- readTVar (serverView server) + inbox <- readTVar (serverInbox server) + case (view, inbox) of + (Just _, Just _) -> pure () + _ -> retry + {- | 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. @@ -850,6 +826,18 @@ ReporterM $ \rep -> runReporter (Events.eventsReporter (serverEvents server)) (Attributed Nothing (FromFollow rep)) +{- | The reporter that puts a node's own lines ("Salmon.Builtin.NodeLog") on +the event stream, filed on @output@ beside a held action's lines. Like the +fetcher's, they are nobody's command: a line is said by a node whenever it +has something to say, during a pass or while being tended, so the events +carry no @origin@ and no synchronous @POST /command@ collects them (a build's +whole output in a response body is what the tail is there to avoid). +-} +serverNodeLogReporter :: Server -> Reporter NodeLog.Line +serverNodeLogReporter server = + ReporterM $ \line -> + runReporter (Events.eventsReporter (serverEvents server)) (Attributed Nothing (FromNode line)) + ------------------------------------------------------------------------------- -- the read model @@ -890,7 +878,15 @@ guarantees the nodes it is looking at are under. -} dagValue :: Serve.Mode -> WorldView -> Value -dagValue mode v = +dagValue = dagValueWith Events.emptyTails + +{- | 'dagValue' with each node's @tail@ ('Events.tailOf'): the newest events +about it, as @\/events@ sent them, which is what a client opening or +reloading a view of the node is seeded from. Read with the sequence number +('Events.snapshotTails'), so they stop exactly at the answer's @seq@. +-} +dagValueWith :: Events.Tails -> Serve.Mode -> WorldView -> Value +dagValueWith tails mode v = object [ "mode" .= mode , "nodes" @@ -910,11 +906,15 @@ , "dynamics" .= rep.repDynamics , "dependencies" .= fmap refValue (Dag.dependenciesOf dag r) , "dependants" .= fmap refValue (Dag.dependantsOf dag r) + , "tail" .= fmap Events.eventValue (Events.tailOf r tails) ] ++ [ "conflict" .= object ["kept" .= representativeValue c.conflictKept, "replaced" .= representativeValue c.conflictReplaced] | Just col <- [Map.lookup r (viewConflicts v)] , let c = col.collisionConflict ] + -- only on a node that carries one, so every other node's + -- object is what it was ("Salmon.Op.CardTemplate") + ++ ["template" .= t | Just t <- [cardTemplateOf act.extension.dynamics]] where rep = Dag.representative act @@ -924,7 +924,7 @@ stateOf :: Ref -> Act Extension -> NodeState stateOf r act = Map.findWithDefault - (NodeState act.shorthand act.extension.help TurnDown Serve.Pending Nothing) + (NodeState act.shorthand act.extension.help TurnDown Serve.Pending Nothing Nothing) r (viewNodes v) @@ -971,9 +971,9 @@ application :: Server -> Application application server req respond = case (Wai.requestMethod req, Wai.pathInfo req) of - ("GET", ["dag"]) -> withView $ \seqNo v -> do + ("GET", ["dag"]) -> withTailsView $ \seqNo tails v -> do mode <- serverMode server - respond (json HTTP.status200 (withSeq seqNo (dagValue mode v))) + respond (json HTTP.status200 (withSeq seqNo (dagValueWith tails 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)))))) @@ -989,6 +989,7 @@ ] ) ("POST", ["command"]) -> command >>= respond + ("GET", ["access"]) -> respond (json HTTP.status200 (object ["access" .= accessName (serverAccess server)])) ("GET", ["events"]) -> events ("GET", []) -> respond (static "index.html") ("GET", ["openapi.json"]) -> respond (Wai.responseLBS HTTP.status200 [(HTTP.hContentType, "application/json")] (LByteString.fromStrict openApiDocument)) @@ -1004,6 +1005,7 @@ (_, ["history"]) -> respond (methodNotAllowed ["GET"]) (_, ["help", "seed"]) -> respond (methodNotAllowed ["GET"]) (_, ["command"]) -> respond (methodNotAllowed ["POST"]) + (_, ["access"]) -> respond (methodNotAllowed ["GET"]) (_, []) -> respond (methodNotAllowed ["GET"]) (_, "ui" : _) -> respond (methodNotAllowed ["GET"]) _ -> respond (failure HTTP.status404 "no such resource") @@ -1020,6 +1022,17 @@ seqNo <- Events.lastSequence (serverEvents server) readView >>= k seqNo + -- 'withView', with the per-node tails read in the same transaction as + -- the number, so they hold exactly the events up to it. + withTailsView :: (Word64 -> Events.Tails -> WorldView -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived + withTailsView k = do + mread <- readTVarIO (serverView server) + case mread of + Nothing -> respond (failure HTTP.status503 "the loop has not started") + Just readView -> do + (seqNo, tails) <- Events.snapshotTails (serverEvents server) + readView >>= k seqNo tails + withSeq :: Word64 -> Value -> Value withSeq n (Object o) = Object (KeyMap.insert "seq" (toJSON n) o) withSeq n v = object ["report" .= v, "seq" .= n] @@ -1031,7 +1044,15 @@ withElided n v = object ["report" .= v, "elided" .= n] command :: IO Response - command = do + command + | serverAccess server == ReadOnly = + -- refused before the body is read: no line is parsed, numbered + -- or queued, so a refused request leaves no trace on the loop + pure (failure HTTP.status403 "this server is read-only (run serve --http-read-only): it takes no command over HTTP") + | otherwise = command' + + command' :: IO Response + command' = do body <- Wai.strictRequestBody req case commandLine req body of Left err -> pure (failure HTTP.status400 err) diff --git a/src/Salmon/Actions/Serve/HttpBind.hs b/src/Salmon/Actions/Serve/HttpBind.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Actions/Serve/HttpBind.hs @@ -0,0 +1,108 @@ +{- | Where @run serve@'s HTTP surface listens, and the two things a TCP +listener is configured with before anything is bound: its session limits +and its token file. + +Apart from "Salmon.Actions.Serve.Http" so that the command line can parse +and validate @--http@\/@--http-tcp@ in a @salmon-ops@ built without the +@http-server@ flag (no warp, warp-tls or wai): such a build knows what the +flags mean and refuses them, rather than not knowing them at all. +"Salmon.Actions.Serve.Http" re-exports everything here. +-} +module Salmon.Actions.Serve.HttpBind ( + Bind (..), + TlsBind (..), + SessionPolicy (..), + defaultSessionPolicy, + TokenError (..), + readTokenFile, +) where + +import Control.Exception (Exception) +import Data.Bits ((.&.)) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Char8 +import Data.Char (isSpace) +import System.Posix.Files (fileMode, getFileStatus) + +{- | 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) + + +{- | 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) + + +-- | 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) + diff --git a/src/Salmon/Actions/Serve/Socket.hs b/src/Salmon/Actions/Serve/Socket.hs --- a/src/Salmon/Actions/Serve/Socket.hs +++ b/src/Salmon/Actions/Serve/Socket.hs @@ -46,6 +46,7 @@ -- * Plugging into the loop listenerProducer, listenerReporters, + listenerNodeLogReporter, ) where import Control.Concurrent (forkIO, killThread) @@ -67,6 +68,7 @@ import Salmon.Actions.Serve (Attributed (..), Line (..), Origin (..), Producer (..)) import qualified Salmon.Actions.UpDown as UpDown import Salmon.Builtin.Extension (Extension) +import qualified Salmon.Builtin.NodeLog as NodeLog import Salmon.Reporter import Salmon.Reporter.Tagged (Tagged (..), reportJSONLines) @@ -249,30 +251,43 @@ serveR :: Reporter (Attributed Serve.Report) serveR = ReporterM $ \(Attributed origin rep) -> do runReporter own (FromServe rep) - forM_ origin (echo (FromServe rep)) + forM_ origin (echoTo l (FromServe rep)) case rep of - Serve.HungUp gone -> disconnect gone + Serve.HungUp gone -> disconnectClient l gone _ -> pure () updownR :: Reporter (Attributed (UpDown.Report Extension)) updownR = ReporterM $ \(Attributed origin rep) -> do runReporter own (FromUpDown rep) - forM_ origin (echo (FromUpDown rep)) + forM_ origin (echoTo l (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 +{- | What a node said while it worked ("Salmon.Builtin.NodeLog"), sent to the +client whose command the line belongs to, as the @output@\/@log@ object +@--json@ prints: stamped by 'Serve.serveSaying', so a line said during the +pass a client's line started reaches that client, and one said while a node +is tended between commands reaches none. Only the echo: the loop's own +reporter is composed beside this by the caller, as it already prints these +lines. +-} +listenerNodeLogReporter :: Listener -> Reporter (Attributed NodeLog.Line) +listenerNodeLogReporter l = ReporterM $ \(Attributed origin line) -> + forM_ origin (echoTo l (FromNode line)) - 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) +-- | Write one report to the client of an origin, hanging it up if that fails. +echoTo :: Listener -> Tagged -> Origin -> IO () +echoTo l 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 _ -> disconnectClient l origin + +disconnectClient :: Listener -> Origin -> IO () +disconnectClient l 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) diff --git a/src/Salmon/Actions/Serve/StatusSink.hs b/src/Salmon/Actions/Serve/StatusSink.hs --- a/src/Salmon/Actions/Serve/StatusSink.hs +++ b/src/Salmon/Actions/Serve/StatusSink.hs @@ -87,7 +87,7 @@ 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.Exception (SomeAsyncException, SomeException, fromException, throwIO, try) import Control.Monad (forever, unless, when) import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), encode, object, withObject, (.:), (.:?), (.=)) import qualified Data.ByteString.Lazy as LByteString @@ -207,7 +207,10 @@ {- | 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. +casualty, never the document. 'withAsync' waits for the writer to be gone +before returning, uninterruptibly, so the writer must let the cancel +through: 'writeNow' re-throws an asynchronous exception rather than report +it as a failed write. -} withSink :: Config -> Maybe Followed -> Reporter Tagged -> (Sink -> IO a) -> IO a withSink cfg followed own body = do @@ -296,6 +299,12 @@ Nothing -> writeAtomically sink.sinkConfig.configPath (encode doc) case attempt of Right () -> writeIORef sink.sinkComplained False + -- the cancel 'withSink' ends the writer with: caught here, + -- the writer would carry on and 'withAsync''s + -- uninterruptible wait for it would never return, which + -- is the whole loop never returning from @quit@. + Left (ex :: SomeException) + | Just (_ :: SomeAsyncException) <- fromException ex -> throwIO ex Left (ex :: SomeException) -> do complained <- readIORef sink.sinkComplained unless complained $ do diff --git a/src/Salmon/Actions/Upkeep.hs b/src/Salmon/Actions/Upkeep.hs --- a/src/Salmon/Actions/Upkeep.hs +++ b/src/Salmon/Actions/Upkeep.hs @@ -82,6 +82,17 @@ the neighbour wait and the delay both — is a choice against the mailbox, so an instruction is never queued behind a 60s nap. += A guarded node waits for its preconditions, and holds its siblings + +A node carrying a 'Salmon.Op.Guard.Guard' (see "Salmon.Builtin.Guarded") is +an operation that cannot be undone, and gets three things no other node +does. Its check answering 'Salmon.Actions.UpDown.Unknown' on the way in +means "not yet" rather than "go ahead" ('awaiting'). An @up@ that refuses to +start is not counted as a failure. And the nodes it names are paused, and +seen to have stopped, before its @up@ runs ('holdSiblings'), then resumed +when it completes or gives up. Parking after a failure is nothing new: it is +'Salmon.Op.Supervision.supGiveUpAfter', which the guard sets. + = Failure is waited out, not contained This is the sharpest difference from the one-shot drivers and the reason @@ -187,11 +198,13 @@ -- * Running Supervisor, startUpkeep, + startUpkeepWith, stopUpkeep, withUpkeep, supervisorStatuses, supervisorMailboxes, supervisorTending, + supervisorThreads, instruct, -- * Machines that outlive a supervisor @@ -204,12 +217,12 @@ 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 (ThreadId, forkIO, threadDelay) +import Control.Concurrent.Async (Async, async, asyncThreadId, cancel, poll, waitCatch, waitCatchSTM, withAsync) +import Control.Concurrent.MVar (newEmptyMVar, newMVar, putMVar, takeMVar, 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 Control.Exception (SomeAsyncException, SomeException, bracket, finally, fromException, throwIO, try) +import Control.Monad (filterM, forM, forM_, unless, void, when) import Data.Dynamic (Dynamic) import Data.Foldable (traverse_) import Data.Map.Strict (Map) @@ -219,6 +232,7 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text +import Data.Time.Clock (UTCTime) import Data.Word (Word64) import GHC.Clock (getMonotonicTimeNSec) import GHC.Records (HasField, getField) @@ -229,11 +243,13 @@ import Salmon.Op.Actions (Act (..)) import Salmon.Op.Dag (Dag) import qualified Salmon.Op.Dag as Dag +import Salmon.Op.Guard (Guard (..), PreconditionUnmet (..), guardOf) 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.Op.Window (Hold (..), Windows (..), holdOf, noWindows, renderHold) import Salmon.Reporter ------------------------------------------------------------------------------- @@ -371,6 +387,13 @@ -- of the log can tell "checked and found fine" from "never asked, -- just applied again" at a glance. Reapplying !(Act ext) !Micros + | -- | this node is 'Salmon.Op.Window.disruptive', its effect needs + -- applying, and no maintenance window is open: its @up@ waits until + -- the next one opens (the time, when there is one). Said once per + -- episode, not on every wake-up. @run serve@'s convergence pass says + -- it too, through 'Salmon.Actions.Serve.Tended', for a node its gate + -- held back. + Held !(Act ext) !(Maybe UTCTime) | -- | told to stop tending this node; its effect is left exactly as it is Paused !(Act ext) | Resumed !(Act ext) @@ -411,6 +434,10 @@ , machineDirection :: !Direction , machineStatus :: !(TVar Status) , machineMailbox :: !Mailbox + , machinePaused :: !(TVar Bool) + -- ^ whether this machine has read a 'Salmon.Op.Mailbox.Pause' and is + -- standing still on it. What a guarded node waits on before it runs; + -- see 'holdSiblings'. , machineWatchdog :: !(Maybe Micros) , machineHolds :: !Bool -- ^ whether this machine holds a running @@ -460,8 +487,22 @@ -- 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. + , underPeers :: !(Map Ref Peer) + -- ^ how to tell another node of this supervisor to hold still, and how + -- to see that it has. Only nodes wanted up are in here: a teardown is + -- not something a neighbour's operation pauses. + , underClaims :: !(TVar (Map Ref (Set Ref))) + -- ^ which nodes are being held still, and by whom: held node to its + -- holders. Only a node carrying a 'Salmon.Op.Guard.Guard' with a + -- non-empty hold set ever writes here. See 'holdSiblings'. } +-- | The two things one machine needs of another to hold it still. +data Peer = Peer + { peerBox :: !Mailbox + , peerPaused :: !(TVar Bool) + } + {- | 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. @@ -564,6 +605,12 @@ supervisorTending :: Supervisor ext -> Map Ref Direction supervisorTending = fmap machineDirection . supMachines +{- | The thread running each node's machine. For a caller measuring what a +machine costs (its stack, see 'napTimer'); nothing here needs it. +-} +supervisorThreads :: Supervisor ext -> Map Ref ThreadId +supervisorThreads = fmap (asyncThreadId . machineThread) . 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). @@ -603,7 +650,38 @@ (Ref -> Maybe Tend) -> Dag ext -> IO (Supervisor ext) -startUpkeep report (Kept prior) tend dag = do +startUpkeep = startUpkeepWith noWindows + +{- | 'startUpkeep' under maintenance windows: a node marked +'Salmon.Op.Window.disruptive' whose effect needs applying while no window +is open does not run its @up@; it waits for the next opening (see +'Held'). Its check is still asked, so a node whose effect is in place +settles as usual. 'Salmon.Op.Mailbox.Force' goes through regardless — an +operator naming the node is the operator who means it — and nothing wanted +down is held. With 'noWindows' this is 'startUpkeep'. + +An adopted machine keeps the windows of the supervisor that started it: +the windows belong to the invocation, and an invocation does not change +them while it runs. +-} +startUpkeepWith :: + 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] + ) => + Windows -> + Reporter (Report ext) -> + Kept ext -> + (Ref -> Maybe Tend) -> + Dag ext -> + IO (Supervisor ext) +startUpkeepWith windows 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. @@ -648,6 +726,27 @@ <$> forM starting (\(aref, _, t) -> (,) aref <$> newStatus t.tendDirection) let statuses = fmap machineStatus adopted <> fresh + -- made before any machine starts, because every machine is handed the + -- whole table: a guarded node pauses its siblings through it. + claims <- newTVarIO (Map.empty :: Map Ref (Set Ref)) + freshPeers <- + Map.fromList + <$> forM + starting + ( \(aref, _, _) -> do + box <- Mailbox.newMailbox Mailbox.defaultCapacity + still <- newTVarIO False + pure (aref, Peer box still) + ) + let peers = + fmap (\m -> Peer (machineMailbox m) (machinePaused m)) adopted + <> Map.fromList + [ (aref, p) + | (aref, _, t) <- starting + , t.tendDirection == TurnUp + , Just p <- [Map.lookup aref freshPeers] + ] + let under aref = let ds = Dag.dependenciesOf dag aref in Under @@ -665,6 +764,8 @@ , Map.member d statuses , Map.lookup d strategies == Just RestForOne ] + , underPeers = peers + , underClaims = claims } -- an adopted machine came from a supervisor whose maps are now nobody's: @@ -676,7 +777,7 @@ 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 + let Peer box still = freshPeers Map.! aref drops <- newTVarIO 0 under' <- newTVarIO (under aref) let status = statuses Map.! aref @@ -691,6 +792,12 @@ , ctxBox = box , ctxDrops = drops , ctxPolicy = policy + , ctxPaused = still + , -- a node that /is/ a running process has no @up@ for a + -- guard to stand in front of. See "Salmon.Builtin.Guarded". + ctxGuard = if holds then Nothing else guardOf act.extension + , ctxHold = holdOf windows act.extension + , ctxRecheck = windowsRecheck windows } -- 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 @@ -705,6 +812,7 @@ , machineDirection = t.tendDirection , machineStatus = status , machineMailbox = box + , machinePaused = still , machineWatchdog = supWatchdog policy , machineHolds = holds , machineUnder = under' @@ -833,6 +941,17 @@ -- ^ evictions already reported, so a repeated read reports the -- difference rather than the running total. , ctxPolicy :: !Supervision + , ctxPaused :: !(TVar Bool) + -- ^ set while this machine stands still on a 'Pause'. See 'machinePaused'. + , ctxGuard :: !(Maybe Guard) + -- ^ what this node declared about being an operation that cannot be + -- undone, if it did. 'Nothing' for nearly every node. + , ctxHold :: IO Hold + -- ^ whether the maintenance windows let this node's @up@ run now. + -- 'Free' without reading a clock for every node that is not + -- 'Salmon.Op.Window.disruptive', and for all of them under 'noWindows'. + , ctxRecheck :: !Micros + -- ^ the longest a held node sleeps before asking 'ctxHold' again. } {- | What 'upping' is to do about the node's own check before acting. @@ -999,13 +1118,20 @@ Tend -> IO () restarting ctx t = do - outcome <- try @SomeException (machine t ctx) + -- whatever way a machine leaves, the nodes it was holding still are let + -- go: a holder that stopped (or was stopped) can no longer say when its + -- operation is over. + outcome <- try @SomeException (machine t ctx `finally` releaseHolds ctx) case outcome of Right () -> pure () Left e | Just (_ :: SomeAsyncException) <- fromException e -> throwIO e | otherwise -> do ctxSay ctx (Escaped (ctxAct ctx) e) + -- a machine that was standing still on somebody's say comes + -- back standing still: the 'Pause' it had read died with it. + wasPaused <- readTVarIO (ctxPaused ctx) + when wasPaused (void (Mailbox.post (ctxBox ctx) Pause)) u <- readTVarIO (ctxUnder ctx) halted <- readTVarIO (underHalt u) unless halted $ do @@ -1095,40 +1221,150 @@ -- | Decide whether to act, then act in whichever way this node acts. attempt :: [Instruction] -> Intent -> Tally -> IO () - attempt told intent tally + attempt = attemptFrom initialDelay + + {- | 'attempt', carrying how long a guarded node waits before asking + about its preconditions again. Every other node ignores the delay. + + A node carrying a 'Salmon.Op.Guard.Guard' reads + 'Salmon.Actions.UpDown.Unknown' the way the rest of this module already + does once a node is up: "could not tell" is not a reason to act. For + such a node that is the whole point, since its check answers exactly + that while its preconditions are unmet, so it is asked /before/ the node + says it is moving and an unmet precondition never reaches 'Upping' at + all. Every other node keeps today's reading, where a first + 'Salmon.Actions.UpDown.Unknown' on the way in means "go ahead". -} + attemptFrom :: Delay -> [Instruction] -> Intent -> Tally -> IO () + attemptFrom d 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 + -- a 'Force' is the operator meaning it, windows or not. + windowed <- if told `has` Force then pure Free else ctxHold ctx + -- a held node is still asked: an effect already in place has + -- nothing to hold back, and settles as it would have. + early <- case (ctxGuard ctx, intent, told `has` Force, windowed) of + (Just _, Consult, False, _) -> Just <$> runCheck act + (_, Consult, False, HeldUntil _) -> Just <$> runCheck act + _ -> pure Nothing + case (early, windowed) of + (Just Unknown, _) | isJust (ctxGuard ctx) -> awaiting d tally + (_, HeldUntil next) | not (maybe False satisfiedBy early) -> heldBack next d intent tally + _ -> 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 <- maybe (runCheck act) pure early + 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 d 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 + {- | A guarded node whose preconditions are unmet: nothing starts, and it + looks again later. Said as a 'NextLook' carrying + 'Salmon.Actions.UpDown.Unknown', which is exactly what it is. + The node's 'Status' is left as it was (not settled if it has never been + up, so its dependants keep waiting) and its 'Tally' is not touched: not + starting is not failing. The delay doubles toward the cap like any + other; 'Salmon.Op.Mailbox.Recheck' looks now. -} + awaiting :: Delay -> Tally -> IO () + awaiting d tally = do + releaseHolds ctx + touch status + say (NextLook act Unknown (delayMicros d)) + w <- naptime ctx (delayMicros d) + told <- announce ctx w + case w of + Halt -> pure () + Ended _ -> pure () + Demote _ -> awaiting d tally + Rearm{} -> awaiting d tally + Told _ -> paused ctx told (awaiting d tally) (attemptFrom (soonIf told d) told Consult tally) + Elapsed -> attemptFrom (relaxed d) told Consult tally + + {- | A 'Salmon.Op.Window.disruptive' node whose effect needs applying, + outside every maintenance window: its @up@ does not run. Said once as + 'Held', with the next opening; then the machine looks at the windows + again every 'ctxRecheck' (so a node goes ahead within that long of a + window opening, and a clock that jumped is noticed), and goes ahead + with the intent it came with once one is open. + + Like 'awaiting', the node's 'Status' is left as it was — a node that has + never been up stays unsettled, so its dependants keep waiting rather + than coming up on top of a change that has not been made — and its + 'Tally' is not touched: being held is not failing. + 'Salmon.Op.Mailbox.Recheck' asks the windows now and + 'Salmon.Op.Mailbox.Force' goes ahead regardless. -} + heldBack :: Maybe UTCTime -> Delay -> Intent -> Tally -> IO () + heldBack next d intent tally = do + touch status + note status ("held by maintenance window " <> renderHold next) + say (Held act next) + napping next + where + napping opening = do + w <- naptime ctx (ctxRecheck ctx) + told <- announce ctx w + case w of + Halt -> pure () + Ended _ -> pure () + Demote _ -> napping opening + Rearm{} -> napping opening + Told _ -> paused ctx told (napping opening) (attemptFrom d told intent tally) + Elapsed -> do + h <- ctxHold ctx + case h of + Free -> attemptFrom d [] intent tally + HeldUntil until' + | until' == opening -> napping opening + | otherwise -> heldBack until' d intent tally + + {- | An @up@ that returns, leaving something behind that persists. + + For a guarded node with a hold set, the siblings it names are stopped + first ('holdSiblings') and stay stopped until the operation completes + ('reached'), is parked ('gaveUp') or turns out not to be startable + ('awaiting'). A failure that is going to be retried keeps them held + through the backoff: the cluster is mid-operation, which is when a + sibling putting itself back does the most damage. -} + oneShot :: Delay -> Tally -> IO () + oneShot d tally = do + refused <- holdSiblings ctx + case refused of + Just Halt -> pure () + -- told something while its siblings were stopping. Nothing has + -- run, so there is nothing to undo: do as told and come back. + Just w -> do + told <- announce ctx w + paused ctx told (attemptFrom d [] Consult tally) (attemptFrom d told Consult tally) + Nothing -> 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 + -- refused to start, which is not the operation failing: + -- reported, so the operator sees why, and not counted + -- toward giving up. See "Salmon.Builtin.Guarded". + Left e | Just (PreconditionUnmet why) <- fromException e -> do + say (Acted (UpDown.Failed act e)) + note status ("not started: " <> why) + say (Upkeep act WaitUp) + awaiting d 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 @@ -1217,7 +1453,9 @@ -- a teardown. So this parks while still holding. | Just Pause <- tending told -> do say (Paused act) + standingStill ctx True heldPause + standingStill ctx False say (Resumed act) watch running verdict d tally armed -- forcing a node that is already running its own effect @@ -1300,6 +1538,7 @@ -- | The effect is in place. Keep an eye on it. reached :: CheckResult -> Tally -> IO () reached verdict tally = do + releaseHolds ctx now <- getMonotonicTimeNSec markOk ctx settle status verdict @@ -1498,9 +1737,14 @@ 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. -} + tally. + + Whatever this node was holding still is let go here: a parked operation + is not running. A parked node told to 'Pause' stands still like any + other, so a sibling's guarded operation can count on it. -} gaveUp :: CheckResult -> Tally -> IO () gaveUp why tally = do + releaseHolds ctx say (GaveUp act tally.tallyFailures) loop where @@ -1513,11 +1757,16 @@ 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 + Told _ -> + paused ctx told loop $ + if told `has` Force + then attempt told (Regardless why) freshTally + else + if told `has` Recheck + then attempt told Consult freshTally + else case override told of + Just Satisfy -> satisfy + _ -> loop {- | An operator said "treat this as done". Settled without acting, and still tended: the instruction satisfies this attempt, it does not stop @@ -1525,6 +1774,7 @@ does that. -} satisfy :: IO () satisfy = do + releaseHolds ctx say (Acted (UpDown.Skip act)) markOk ctx settle status Skipped @@ -1642,12 +1892,39 @@ broken <- readTVar (underFailed u) if any (`Set.member` broken) watched then retry else pure Elapsed +{- | 'registerDelay', run on a short-lived thread of its own rather than on +the machine's. + +This is about memory, not time. Registering a timeout inserts into the +runtime's timer queue, and that insertion runs on the calling thread and is +deeper the more timeouts are outstanding — with every machine of a large +supervisor napping at once, deep enough to overflow a thread's first stack +chunk (1 KiB). An overflowing thread is moved, frames and all, onto a fresh +chunk of @+RTS -kc@ (32 KiB by default) and stays there once the insertion +has returned, because nothing it does afterwards ever returns past the frames +that moved with it. One such chunk per machine was nearly all of what a +supervisor retained: about 32 KiB a node, so 100 000 tended nodes did not fit +in a 4 GB heap. A thread that only registers and exits takes the deep frames +with it, and the machine keeps the stack it started with. See +@resources\/graph-profiles.md@, finding 6. + +Costs one thread creation per nap. Naps are taken on the delay ladder +('delayFloor' and up), so that is noise next to the nap itself. Whatever +'registerDelay' throws (it refuses to run without @-threaded@) is rethrown +here, on the machine, as it was before. +-} +napTimer :: Micros -> IO (TVar Bool) +napTimer d = do + box <- newEmptyMVar + _ <- forkIO (try @SomeException (registerDelay (unMicros d)) >>= putMVar box) + either throwIO pure =<< takeMVar box + {- | 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) + timer <- napTimer d atomically $ halting HeedHalt ctx $ listen ctx $ do @@ -1659,7 +1936,7 @@ -} napWatching :: Ctx ext -> Armed -> Micros -> IO Wake napWatching ctx armed d = do - timer <- registerDelay (unMicros d) + timer <- napTimer d atomically $ halting HeedHalt ctx $ crossing ctx armed $ @@ -1689,7 +1966,7 @@ -} naptimeHolding :: Ctx ext -> Async ExitCode -> Armed -> Micros -> IO Wake naptimeHolding ctx running armed d = do - timer <- registerDelay (unMicros d) + timer <- napTimer d atomically $ halting IgnoreHalt ctx $ crossing ctx armed $ @@ -1870,13 +2147,14 @@ case tending told of Just Pause -> do ctxSay ctx (Paused (ctxAct ctx)) + standingStill ctx True hold _ -> onwards where hold = do w <- atomically (halting HeedHalt ctx (listen ctx retry)) case w of - Halt -> pure () + Halt -> standingStill ctx False Ended _ -> pure () Demote _ -> hold Rearm{} -> hold @@ -1885,9 +2163,121 @@ _ <- announce ctx (Told ts) case tending ts of Just Resume -> do + standingStill ctx False ctxSay ctx (Resumed (ctxAct ctx)) onResume _ -> hold + +-- | Publish whether this machine is standing still on a 'Pause', for a +-- guarded node waiting on it. See 'holdSiblings'. +standingStill :: Ctx ext -> Bool -> IO () +standingStill ctx = atomically . writeTVar (ctxPaused ctx) + +{- | Stop the nodes this node's 'Salmon.Op.Guard.Guard' names, and wait until +they have all stopped. 'Nothing' once they have (or there was nobody to +stop); otherwise why the wait ended first, with nothing left held. + +The hold is a 'Pause' through each sibling's mailbox, so it means what an +operator's 'Pause' means: the sibling's effect is untouched and its machine +stops tending it. A sibling in the middle of its own @up@ finishes that +first, which is why this waits rather than posting and carrying on. + +Three rules keep it from turning into a deadlock or a surprise: + +* __A node that is itself held does not claim anybody.__ Two guarded nodes + naming each other would otherwise each stop the other and wait forever. + The claim is one transaction over 'underClaims', so exactly one of them + wins and the other hears its 'Pause'. +* __A sibling already standing still on somebody else's say is not + touched__, and so is not resumed on release either: an operator's 'Pause' + outlives a neighbour's operation. One held by another guarded node is + joined instead, and resumes when the last holder lets go. +* __A name nobody here is tending is skipped__, the same call 'standby' + makes about an untended dependency: nothing is going to move it. + +An operator can still say 'Resume' to a held sibling, and is obeyed. +-} +holdSiblings :: Ctx ext -> IO (Maybe Wake) +holdSiblings ctx = + case maybe [] guardHolds (ctxGuard ctx) of + [] -> pure Nothing + wanted -> do + claimed <- atomically (claim wanted) + case claimed of + Left w -> pure (Just w) + Right (fresh, everyone) -> do + forM_ fresh $ \p -> Mailbox.post (peerBox p) Pause + w <- + atomically $ + halting HeedHalt ctx $ + listen ctx $ do + still <- traverse (readTVar . peerPaused) everyone + if and still then pure Elapsed else retry + case w of + Elapsed -> pure Nothing + _ -> releaseHolds ctx >> pure (Just w) + where + me = ctxRef ctx + + -- the siblings to send a 'Pause' to, and the ones to wait for. + claim :: [Ref] -> STM (Either Wake ([Peer], [Peer])) + claim wanted = do + u <- readTVar (ctxUnder ctx) + stop <- readTVar (underHalt u) + if stop + then pure (Left Halt) + else do + told <- Mailbox.takeAll (ctxBox ctx) + claims <- readTVar (underClaims u) + let mine = Map.filter (Set.member me) claims + if not (null told) + then pure (Left (Told told)) + else + if not (Map.null mine) + then -- a retry of an operation still under way + pure (Right ([], [])) + else + if Map.member me claims + then retry + else do + let peers = + [ (r, p) + | r <- Set.toList (Set.fromList wanted) + , r /= me + , Just p <- [Map.lookup r (underPeers u)] + ] + let held = [rp | rp@(r, _) <- peers, Map.member r claims] + free <- + filterM + (\(_, p) -> not <$> readTVar (peerPaused p)) + [rp | rp@(r, _) <- peers, not (Map.member r claims)] + writeTVar (underClaims u) $ + foldr + (\(r, _) -> Map.insertWith Set.union r (Set.singleton me)) + claims + (held <> free) + pure (Right (fmap snd free, fmap snd (held <> free))) + +{- | Let go of every node this one is holding still. A sibling nobody else is +holding is told to 'Resume'; one that another guarded node also holds stays +where it is. Does nothing for a node holding nobody, which is nearly all of +them. +-} +releaseHolds :: Ctx ext -> IO () +releaseHolds ctx = + case ctxGuard ctx of + Nothing -> pure () + Just _ -> do + freed <- atomically $ do + u <- readTVar (ctxUnder ctx) + claims <- readTVar (underClaims u) + let me = ctxRef ctx + let mine = Map.keys (Map.filter (Set.member me) claims) + let letGo hs = let hs' = Set.delete me hs in if Set.null hs' then Nothing else Just hs' + let claims' = foldr (Map.update letGo) claims mine + unless (null mine) (writeTVar (underClaims u) claims') + pure [p | r <- mine, not (Map.member r claims'), Just p <- [Map.lookup r (underPeers u)]] + forM_ freed $ \p -> Mailbox.post (peerBox p) Resume -- | The last 'Pause'/'Resume' said, if either was. tending :: [Instruction] -> Maybe Instruction diff --git a/src/Salmon/Builtin/Cards.hs b/src/Salmon/Builtin/Cards.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Cards.hs @@ -0,0 +1,313 @@ +{- | Web UI card templates for a few builtins (feature 91138a85), built on +"Salmon.Op.CardTemplate": a node carrying one has its card in the page drawn +from it instead of the default sections (contract in +@salmon-ops\/ui\/card-template.js@). + +__Opt-in.__ No builtin attaches its card by itself, so no existing +declaration serves anything new on @\/dag@. A recipe opts in per node: + +> withCard (Cards.fileContents path) (filecontents (FileContents path body)) + +and since a template is left out of the representative, adding one (or +dropping it) restarts nothing. + +What a card shows is public by construction: the values baked into it are +the ones the builtin already makes public in its @ref@ and @help@ (a path, a +unit name, a port, a database name), and the rest is read from the node's +own public @\/dag@ fields at drawing time. A card never takes, and so never +shows, a file's contents, a password or any digest of either. + +Every card links to its builtin's page on the salmon docs site ('cardDocs', +'docsLink'; the pages are @resources\/builtins\/.md@). The link is in the +template only, so like the rest of the card it restarts nothing. +-} +module Salmon.Builtin.Cards ( + -- * Attaching + withCard, + + -- * Cards for builtins + fileContents, + directory, + systemdService, + pgDatabase, + fileContentsCard, + directoryCard, + systemdServiceCard, + pgDatabaseCard, + + -- * The skeleton + Card (..), + Verdicts (..), + Link (..), + renderCard, + allLinks, + + -- * The builtin's page on the docs site + docsBaseUrl, + docsLink, + tramajString, + percentEncode, +) where + +import qualified Data.ByteString as ByteString +import Data.Char (isAsciiLower, isAsciiUpper, isControl, isDigit, ord) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Numeric (showHex) +import Text.Printf (printf) +import System.FilePath (takeDirectory) + +import Salmon.Builtin.Extension (Op, amendNode, withCardTemplate) +import qualified Salmon.Builtin.Nodes.Postgres as Postgres +import qualified Salmon.Builtin.Nodes.Systemd as Systemd + +-- | Give this node (the root only, not its dependencies) this card. +withCard :: Text -> Op -> Op +withCard src = amendNode (withCardTemplate src) + +{- | A card's content, everything but the node's own fields. All the text is +author-written and public: it ends up in the template source, which @\/dag@ +serves. +-} +data Card = Card + { cardFacts :: [(Text, Text)] + -- ^ identity rows, drawn as a small table (label, value) + , cardVerdicts :: Verdicts + , cardUp :: Text + -- ^ what @up@ does + , cardDown :: Text + -- ^ what @down@ does + , cardLinks :: [Link] + -- ^ external links (a cloud console page, say), drawn under the facts; + -- none draws nothing + , cardDocs :: Maybe Text + -- ^ the builtin's page on the salmon docs site, by slug ('docsLink'), + -- drawn after 'cardLinks'; 'Nothing' draws nothing + } + deriving (Eq, Show) + +{- | A link out of the page, to the managed system. Built only from public +node data (a project, a zone, a name: what the node's @ref@ and @help@ +already publish), never from a secret. The page draws only an @https@ URL +without credentials, opens it in a new tab with no referrer, and draws +anything else as plain text (@ui\/card-template.js@). +-} +data Link = Link + { linkLabel :: Text + , linkUrl :: Text + } + deriving (Eq, Show) + +-- | The last check, in the node's own words. +data Verdicts = Verdicts + { verdictInPlace :: Text + -- ^ @success@, @completed@, @skipped@ + , verdictToApply :: Text + -- ^ @failure@ (its reason is drawn under it) + , verdictUnsure :: Text + -- ^ @unknown@ + , verdictNoCheck :: Text + -- ^ @immaterial@: the node has no check + , verdictUnchecked :: Text + -- ^ no check result in what the page has seen (the page's check comes from @\/dag@, so a page loaded before the + -- first check says this until it is reloaded) + } + deriving (Eq, Show) + +{- | A Tramaj string literal for this text: quotes, backslashes and +backticks (which open an interpolation) are escaped, and so is every +control character, so no text can end the literal or reach the program. +-} +tramajString :: Text -> Text +tramajString t = "\"" <> Text.concatMap esc t <> "\"" + where + esc '"' = "\\\"" + esc '\\' = "\\\\" + esc '`' = "\\`" + esc '\n' = "\\n" + esc '\t' = "\\t" + esc '\r' = "\\r" + esc c + | isControl c = Text.pack ("\\u{" <> showHex (ord c) "}") + | otherwise = Text.singleton c + +{- | The template for a card. The layout is the same for every builtin: +the help line, the identity facts, the last check in the node's words (and +its reason), a conflict warning, what @up@ and @down@ do, then the notes, +dynamics and tending output folded away. +-} +renderCard :: Card -> Text +renderCard c = + Text.intercalate "\n" $ + [ "@v = $ctx.check.verdict" + , "@ok = or(eq($v, \"success\"), or(eq($v, \"completed\"), eq($v, \"skipped\")))" + , ".div(" + , " .p(class: \"t-muted\", $ctx.help)," + , " .table(.tbody(" <> Text.intercalate ", " (fmap fact c.cardFacts) <> "))," + ] + <> links + <> [ " .p(class: branch(\"t-muted\", $ok, \"t-ok\", eq($v, \"failure\"), \"t-warn\", eq($v, \"unknown\"), \"t-warn\")," + , " branch(" <> s v.verdictUnchecked <> ", $ok, " <> s v.verdictInPlace <> ", eq($v, \"failure\"), " <> s v.verdictToApply <> ", eq($v, \"unknown\"), " <> s v.verdictUnsure <> ", eq($v, \"immaterial\"), " <> s v.verdictNoCheck <> "))," + , " branch(.p(class: \"t-muted\", $ctx.check.reason), eq($ctx.check.reason, null), \"\")," + , " branch(\"\", $ctx.conflict, .p(class: \"t-err\", \"two live declarations disagree about this node\"))," + , " .h5(\"up\"), .p(" <> s c.cardUp <> ")," + , " .h5(\"down\"), .p(" <> s c.cardDown <> ")," + , " .details(.summary(\"notes (`str(count($ctx.notes))`)\"), .ul(map($ctx.notes, (n) => .li($n))))," + , " .details(.summary(\"dynamics (`str(count($ctx.dynamics))`)\"), .ul(map($ctx.dynamics, (d) => .li(.code($d)))))," + , " .details(.summary(\"output (`str(count($ctx.output))`)\"), .pre(map($ctx.output, (l) => \"`$l`\\n\")))" + , ")" + ] + where + s = tramajString + v = c.cardVerdicts + fact (k, x) = ".tr(.th(" <> s k <> "), .td(.code(" <> s x <> ")))" + -- nothing at all without links, so a card without any renders as before + links = case allLinks c of + [] -> [] + ls -> [" .p(class: \"card-links\", " <> Text.intercalate ", \" · \", " (fmap link ls) <> "),"] + link :: Link -> Text + link l = ".a(href: " <> s l.linkUrl <> ", " <> s l.linkLabel <> ")" + +-- | What a card links to, in drawing order: its 'cardLinks', then its docs page. +allLinks :: Card -> [Link] +allLinks c = c.cardLinks <> maybe [] (\slug -> [docsLink slug]) c.cardDocs + +{- | Where the salmon documentation site is published: the kitchen-sink site +of @website\/@, so this must equal the @publishURL@ and @basePath@ of +@website\/src\/kitchen-sink.json@ (@BuiltinCardsSpec@ checks it). GitHub +Pages serves it from @docs\/@ on @master@ (@website\/README.md@). A +constant, not a setting: +a card's template is fixed when the graph is built, and it is not part of the +representative, so changing this restarts nothing. +-} +docsBaseUrl :: Text +docsBaseUrl = "https://lucasdicioccio.github.io/salmon" + +{- | The link to a builtin's page on the docs site: @builtin-.html@, +the kitchen-sink page made from @resources\/builtins\/.md@ +(@website\/scripts\/sync-repo-docs.sh@ mirrors it to +@website\/src\/builtin-.cmark@, so the page is in the site's search +index and its "Builtin nodes" navigation group). The slug is author-chosen and +fixed per builtin (never a declaration's value), so the URL needs no +encoding beyond what the slug already is. +-} +docsLink :: Text -> Link +docsLink slug = Link "docs" (docsBaseUrl <> "/builtin-" <> slug <> ".html") + +{- | Percent-encodes everything but RFC 3986's unreserved characters, as +UTF-8: for a name put in a URL's path segment or query value. +-} +percentEncode :: Text -> Text +percentEncode = Text.concatMap enc + where + enc c + | isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("-._~" :: String) = Text.singleton c + | otherwise = Text.pack (concatMap (printf "%%%02X") (ByteString.unpack (Text.encodeUtf8 (Text.singleton c)))) + +{- | For 'Salmon.Builtin.Nodes.Filesystem.filecontents' at this path. The +contents are not on the card, nor any digest of them (the builtin's own +@content-hash@ note, when it has one, still shows among the notes). +-} +fileContents :: FilePath -> Text +fileContents path = renderCard (fileContentsCard path) + +-- | 'fileContents' before rendering. +fileContentsCard :: FilePath -> Card +fileContentsCard path = + Card + { cardFacts = [("path", Text.pack path), ("directory", Text.pack (takeDirectory path))] + , cardVerdicts = + Verdicts + { verdictInPlace = "in place, as declared" + , verdictToApply = "missing or different from the declaration: up writes it" + , verdictUnsure = "could not tell whether the file is as declared" + , verdictNoCheck = "the node declares no check" + , verdictUnchecked = "no check result on this page yet" + } + , cardUp = "writes the whole file (no merge with what is there)" + , cardDown = "removes the file (already absent is fine); the directory stays" + , cardLinks = [] + , cardDocs = Just "filesystem-file-contents" + } + +-- | For 'Salmon.Builtin.Nodes.Filesystem.dir' at this path. +directory :: FilePath -> Text +directory path = renderCard (directoryCard path) + +-- | 'directory' before rendering. +directoryCard :: FilePath -> Card +directoryCard path = + Card + { cardFacts = [("path", Text.pack path)] + , cardVerdicts = + Verdicts + { verdictInPlace = "in place" + , verdictToApply = "missing: up creates it" + , verdictUnsure = "could not tell whether the directory is there" + , verdictNoCheck = "no check: asking costs what creating costs, so up re-applies (under serve, on the supervision delay)" + , verdictUnchecked = "no check result on this page yet" + } + , cardUp = "creates the directory and its parents; never touches what is inside" + , cardDown = "removes the directory only when it is empty (a non-empty one fails, on purpose)" + , cardLinks = [] + , cardDocs = Just "filesystem-directory" + } + +{- | For 'Salmon.Builtin.Nodes.Systemd.systemdService' (and its watching +variants) on this config: the unit, its scope and its unit directory, never +the unit file's body. +-} +systemdService :: Systemd.Config -> Text +systemdService cfg = renderCard (systemdServiceCard cfg) + +-- | 'systemdService' before rendering. +systemdServiceCard :: Systemd.Config -> Card +systemdServiceCard cfg = + Card + { cardFacts = + [ ("unit", cfg.config_target) + , ("scope", scope cfg.config_scope) + , ("unit dir", Text.pack cfg.config_unit_dir) + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "active and enabled, as loaded" + , verdictToApply = "not as declared: up reloads, enables and restarts it" + , verdictUnsure = "in transition, or systemctl did not answer: nothing restarts on this" + , verdictNoCheck = "the node declares no check" + , verdictUnchecked = "no check result on this page yet" + } + , cardUp = "systemctl daemon-reload, enable, then restart" + , cardDown = "systemctl stop; the unit file is its own node" + , cardLinks = [] + , cardDocs = Just "systemd-service" + } + where + scope Systemd.System = "system" + scope Systemd.User = "user" + +{- | For 'Salmon.Builtin.Nodes.Postgres.database' on this port: the +database and the port. That builtin has no check, which the card says. +-} +pgDatabase :: Postgres.Port -> Postgres.Database -> Text +pgDatabase port db = renderCard (pgDatabaseCard port db) + +-- | 'pgDatabase' before rendering. +pgDatabaseCard :: Postgres.Port -> Postgres.Database -> Card +pgDatabaseCard port db = + Card + { cardFacts = [("database", db.getDatabase), ("port", Text.pack (show port))] + , cardVerdicts = + Verdicts + { verdictInPlace = "the database is there" + , verdictToApply = "missing: up creates it" + , verdictUnsure = "could not ask the server" + , verdictNoCheck = "no check: run up applies it every time (a no-op when it exists); under serve it parks and nothing watches it" + , verdictUnchecked = "no check result on this page yet" + } + , cardUp = "CREATE DATABASE as the postgres user, on the local server at this port, unless pg_database already has it" + , cardDown = "nothing: a database is never dropped by this node" + , cardLinks = [] + , cardDocs = Just "postgres-database" + } diff --git a/src/Salmon/Builtin/Cards/Gcp.hs b/src/Salmon/Builtin/Cards/Gcp.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Cards/Gcp.hs @@ -0,0 +1,385 @@ +{- | Web UI cards for the GCP builtins ("Salmon.Builtin.Nodes.Gcp"), in the +style of "Salmon.Builtin.Cards" (feature d8a79380), and like those +__opt-in__: a recipe attaches one per node with 'Salmon.Builtin.Cards.withCard'. + +> withCard (GcpCards.instance_ inst) (Compute.gceInstance r gcloud inst) + +Each card takes the builtin's own declaration value and shows only what the +builtin already makes public in its @ref@, @help@ and @notes@: a project, a +zone or region, a name, a machine type, a DNS name and its records. It never +shows instance metadata (a startup script may carry anything), a secret's +value, or any digest of either. + +Each card also links to the resource's page in the Cloud console, built from +that same public data (project, zone or region, name), percent-encoded. __The +links have not been followed against a real project__: they are the console's +documented URL shapes at the time of writing, and where a resource has no +stable page of its own (an address, a record set, a regional balancer) the +link goes to the list it is on. +-} +module Salmon.Builtin.Cards.Gcp ( + -- * Cards + instance_, + address, + firewallRule, + subnet, + managedZone, + recordSet, + bucket, + secret, + secretFile, + applicationLoadBalancer, + + -- * Before rendering + instanceCard, + addressCard, + firewallRuleCard, + subnetCard, + managedZoneCard, + recordSetCard, + bucketCard, + secretCard, + secretFileCard, + applicationLoadBalancerCard, + + -- * Console links + consoleUrl, +) where + +import Data.Text (Text) +import qualified Data.Text as Text + +import Salmon.Builtin.Cards (Card (..), Link (..), Verdicts (..), percentEncode, renderCard) +import qualified Salmon.Builtin.Nodes.Gcp.CloudDns as Dns +import qualified Salmon.Builtin.Nodes.Gcp.Compute as Compute +import Salmon.Builtin.Nodes.Gcp.Core (Project (..), Region (..), Zone (..)) +import qualified Salmon.Builtin.Nodes.Gcp.LoadBalancing as Lb +import qualified Salmon.Builtin.Nodes.Gcp.SecretManager as Secrets +import qualified Salmon.Builtin.Nodes.Gcp.Storage as Storage +import Salmon.Builtin.Nodes.SecretDelivery (Placement (..)) + +{- | A Cloud console page of this project: the path segments, each +percent-encoded, then @?project=@. Only public data goes in. +-} +consoleUrl :: [Text] -> Project -> Text +consoleUrl segments p = + "https://console.cloud.google.com/" + <> Text.intercalate "/" (fmap percentEncode segments) + <> "?project=" + <> percentEncode p.projectId + +console :: Text -> [Text] -> Project -> [Link] +console label segments p = [Link label (consoleUrl segments p)] + +unchecked :: Text +unchecked = "no check result on this page yet" + +noCheck :: Text +noCheck = "the node declares no check" + +-- | For 'Compute.gceInstance'. The metadata (and its files) are not shown. +instance_ :: Compute.Instance -> Text +instance_ = renderCard . instanceCard + +-- | 'instance_' before rendering. +instanceCard :: Compute.Instance -> Card +instanceCard i = + Card + { cardFacts = + [ ("instance", i.instanceName) + , ("project", i.instanceProject.projectId) + , ("zone", i.instanceZone.zoneName) + , ("machine type", Compute.renderMachineType i.instanceMachineType) + , ("declared power", power i.instancePower) + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "there, in the declared power state, machine type and scopes" + , verdictToApply = "absent or not as declared: up creates, starts, stops or resizes it, as permitted (the reason says what differs)" + , verdictUnsure = "could not tell the instance's state" + , verdictNoCheck = noCheck + , verdictUnchecked = unchecked + } + , cardUp = "creates the instance if absent, then starts, resumes or stops it to the declared power; a different machine type is changed only when the declaration permits a stop" + , cardDown = "deletes the instance if it is there, whatever its state" + , cardLinks = console "instance in the Cloud console" ["compute", "instancesDetail", "zones", i.instanceZone.zoneName, "instances", i.instanceName] i.instanceProject + , cardDocs = Just "gcp-compute-instance" + } + where + power Compute.PoweredOn = "on" + power Compute.PoweredOff = "off" + +-- | For 'Compute.address'. +address :: Compute.Address -> Text +address = renderCard . addressCard + +-- | 'address' before rendering. +addressCard :: Compute.Address -> Card +addressCard a = + Card + { cardFacts = + [ ("address", a.addressName) + , ("project", a.addressProject.projectId) + , ("region", a.addressRegion.regionName) + ] + <> kind a.addressKind + , cardVerdicts = + Verdicts + { verdictInPlace = "reserved, as declared" + , verdictToApply = "not reserved, or holding another address than the declared one: up reserves it" + , verdictUnsure = "could not tell whether the address is reserved" + , verdictNoCheck = noCheck + , verdictUnchecked = unchecked + } + , cardUp = "reserves the address (retrying while a freshly enabled API settles)" + , cardDown = "releases the address if it is reserved" + , cardLinks = console "IP addresses in the Cloud console" ["networking", "addresses", "list"] a.addressProject + , cardDocs = Just "gcp-compute-address" + } + where + kind Compute.ExternalAddress = [("kind", "external")] + kind (Compute.InternalAddress sub lit) = [("kind", "internal"), ("subnet", sub)] <> [("literal", l) | Just l <- [lit]] + +-- | For 'Compute.firewallRule'. +firewallRule :: Compute.FirewallRule -> Text +firewallRule = renderCard . firewallRuleCard + +-- | 'firewallRule' before rendering. +firewallRuleCard :: Compute.FirewallRule -> Card +firewallRuleCard fw = + Card + { cardFacts = + [ ("rule", fw.firewallName) + , ("project", fw.firewallProject.projectId) + , ("network", fw.firewallNetwork) + , ("allows", fw.firewallAllow) + , ("from", commas fw.firewallSourceRanges) + , ("to tags", commas fw.firewallTargetTags) + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "the rule is there" + , verdictToApply = "absent: up creates it" + , verdictUnsure = "could not tell whether the rule exists" + , verdictNoCheck = noCheck + , verdictUnchecked = unchecked + } + , cardUp = "creates the ingress rule (an existing rule of that name is not compared or changed)" + , cardDown = "deletes the rule if it is there" + , cardLinks = console "rule in the Cloud console" ["networking", "firewalls", "details", fw.firewallName] fw.firewallProject + , cardDocs = Just "gcp-compute-firewall-rule" + } + +-- | For 'Compute.subnet'. +subnet :: Compute.Subnet -> Text +subnet = renderCard . subnetCard + +-- | 'subnet' before rendering. +subnetCard :: Compute.Subnet -> Card +subnetCard n = + Card + { cardFacts = + [ ("subnet", n.subnetName) + , ("project", n.subnetProject.projectId) + , ("region", n.subnetRegion.regionName) + , ("network", n.subnetNetwork) + , ("range", n.subnetRange) + , ("purpose", Compute.renderSubnetPurpose n.subnetPurpose) + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "the subnet exists, with the declared purpose" + , verdictToApply = "absent (up creates it), or of another purpose (up does not change that; the reason names both)" + , verdictUnsure = "could not tell whether the subnet exists" + , verdictNoCheck = noCheck + , verdictUnchecked = unchecked + } + , cardUp = "creates the subnetwork (the range is not compared with an existing one)" + , cardDown = "deletes the subnetwork if it is there" + , cardLinks = console "subnet in the Cloud console" ["networking", "subnetworks", "details", n.subnetRegion.regionName, n.subnetName] n.subnetProject + , cardDocs = Just "gcp-compute-subnet" + } + +-- | For 'Dns.managedZone'. +managedZone :: Dns.ManagedZone -> Text +managedZone = renderCard . managedZoneCard + +-- | 'managedZone' before rendering. +managedZoneCard :: Dns.ManagedZone -> Card +managedZoneCard z = + Card + { cardFacts = + [ ("zone", z.zoneName) + , ("project", z.zoneProject.projectId) + , ("serves", Dns.fqdn z.zoneDnsName) + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "the zone exists and serves the declared domain" + , verdictToApply = "absent, or a zone of that name serves another domain (then up fails rather than take it over)" + , verdictUnsure = "could not tell whether the zone exists" + , verdictNoCheck = noCheck + , verdictUnchecked = unchecked + } + , cardUp = "creates the public managed zone" + , cardDown = "deletes the zone if it is there and serves the declared domain; Cloud DNS refuses while records other than the apex NS and SOA remain" + , cardLinks = zoneLink z + , cardDocs = Just "gcp-dns-managed-zone" + } + +zoneLink :: Dns.ManagedZone -> [Link] +zoneLink z = console "zone in the Cloud console" ["net-services", "dns", "zones", z.zoneName, "details"] z.zoneProject + +{- | For 'Dns.recordSet' (and 'Dns.resolvedRecordSet', whose declared data +the card shows as "resolved when applied" since the record's data is not +known at graph build: pass 'True' for that one). +-} +recordSet :: Bool -> Dns.RecordSet -> Text +recordSet resolved = renderCard . recordSetCard resolved + +-- | 'recordSet' before rendering. +recordSetCard :: Bool -> Dns.RecordSet -> Card +recordSetCard resolved rs = + Card + { cardFacts = + [ ("name", Dns.fqdn rs.recordName) + , ("type", Dns.renderRecordType rs.recordType) + , ("ttl", Text.pack (show rs.recordTtl) <> "s") + , ("data", if resolved then "resolved when applied" else Text.intercalate " " rs.recordData) + , ("zone", rs.recordZone.zoneName) + , ("project", rs.recordZone.zoneProject.projectId) + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "holds exactly the declared TTL and data" + , verdictToApply = "absent, or holding other data or TTL: up writes the declared set" + , verdictUnsure = "could not tell what the record set holds (or its data is not readable yet)" + , verdictNoCheck = noCheck + , verdictUnchecked = unchecked + } + , cardUp = "creates the record set, or updates it in place: the name and type are the effect site, so one made by hand is taken over" + , cardDown = "deletes the record set at that name and type if there is one, whatever it holds" + , cardLinks = zoneLink rs.recordZone + , cardDocs = Just "gcp-dns-record-set" + } + +-- | For 'Storage.bucket'. +bucket :: Storage.Bucket -> Text +bucket = renderCard . bucketCard + +-- | 'bucket' before rendering. +bucketCard :: Storage.Bucket -> Card +bucketCard b = + Card + { cardFacts = + [ ("bucket", b.bucketName) + , ("project", b.bucketProject.projectId) + , ("location", b.bucketLocation.regionName) + , ("uniform access", if b.bucketUniformBucketLevelAccess then "on" else "off") + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "the bucket is there" + , verdictToApply = "absent: up creates it" + , verdictUnsure = "could not tell whether the bucket exists" + , verdictNoCheck = noCheck + , verdictUnchecked = unchecked + } + , cardUp = "creates the bucket" + , cardDown = "deletes the bucket if it is there" + , cardLinks = console "bucket in the Cloud console" ["storage", "browser", b.bucketName] b.bucketProject + , cardDocs = Just "gcp-storage-bucket" + } + +-- | For 'Secrets.secret': the secret's name, never a version's value. +secret :: Secrets.Secret -> Text +secret = renderCard . secretCard + +-- | 'secret' before rendering. +secretCard :: Secrets.Secret -> Card +secretCard sec = + Card + { cardFacts = + [ ("secret", sec.secretName) + , ("project", sec.secretProject.projectId) + , ("replication", sec.secretReplication) + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "present" + , verdictToApply = "missing: up creates it (empty: versions are their own nodes)" + , verdictUnsure = "could not tell whether the secret exists" + , verdictNoCheck = noCheck + , verdictUnchecked = unchecked + } + , cardUp = "creates the secret, with no version" + , cardDown = "deletes the secret if it is there, and with it every version" + , cardLinks = console "secret in the Cloud console" ["security", "secret-manager", "secret", sec.secretName, "versions"] sec.secretProject + , cardDocs = Just "gcp-secret" + } + +{- | For 'Secrets.secretFile': where the secret is written and from which +secret, and whether it is there. Never the bytes, and never a digest. +-} +secretFile :: Secrets.SecretFile -> Text +secretFile = renderCard . secretFileCard + +-- | 'secretFile' before rendering. +secretFileCard :: Secrets.SecretFile -> Card +secretFileCard f = + Card + { cardFacts = + [ ("path", Text.pack place.placePath) + , ("secret", f.fileSecretName) + , ("version", f.fileVersion) + , ("project", f.fileProject.projectId) + , ("owner", place.placeOwner <> ":" <> place.placeGroup) + , ("mode", place.placeMode) + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "present, as the secret holds it" + , verdictToApply = "missing, different, or the secret is not readable: up writes it" + , verdictUnsure = "could not tell whether the file is in place" + , verdictNoCheck = noCheck + , verdictUnchecked = unchecked + } + , cardUp = "reads the secret version as this machine's identity and writes it to the path, atomically; the bytes are never reported" + , cardDown = "removes the file" + , cardLinks = console "secret in the Cloud console" ["security", "secret-manager", "secret", f.fileSecretName, "versions"] f.fileProject + , cardDocs = Just "gcp-secret-file" + } + where + place = f.filePlacement + +-- | For 'Lb.applicationLoadBalancer' (and its @After@\/@With@ variants): the balancer's root node. +applicationLoadBalancer :: Lb.ApplicationLoadBalancer -> Text +applicationLoadBalancer = renderCard . applicationLoadBalancerCard + +-- | 'applicationLoadBalancer' before rendering. +applicationLoadBalancerCard :: Lb.ApplicationLoadBalancer -> Card +applicationLoadBalancerCard alb = + Card + { cardFacts = + [ ("balancer", alb.albName) + , ("project", alb.albProject.projectId) + , ("region", alb.albRegion.regionName) + , ("https", if null alb.albCertificates then "no" else "yes") + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "every instance-group backend reports healthy" + , verdictToApply = "a backend is not healthy, or the declaration is invalid (the reason says which)" + , verdictUnsure = "could not ask the balancer for its backends' health" + , verdictNoCheck = noCheck + , verdictUnchecked = unchecked + } + , cardUp = "nothing of its own: its parts (address, health check, services, URL map, certificates, proxies, forwarding rules) are its dependencies" + , cardDown = "nothing of its own: each part's node deletes its resource" + , cardLinks = console "load balancers in the Cloud console" ["net-services", "loadbalancing", "list", "loadBalancers"] alb.albProject + , cardDocs = Just "gcp-application-load-balancer" + } + +commas :: [Text] -> Text +commas [] = "(none)" +commas xs = Text.intercalate "," xs diff --git a/src/Salmon/Builtin/Cards/Keys.hs b/src/Salmon/Builtin/Cards/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Cards/Keys.hs @@ -0,0 +1,355 @@ +{- | Web UI cards for the SSH, key and certificate builtins +("Salmon.Builtin.Nodes.Keys", "Salmon.Builtin.Nodes.Certificates", +"Salmon.Builtin.Nodes.WireGuard"'s keys, "Salmon.Builtin.Nodes.Gcp.SshAccess"), +in the style of "Salmon.Builtin.Cards" (feature e593a79b). __Opt-in__, +attached per node with 'Salmon.Builtin.Cards.withCard'. + +__A key card shows a path, never a key.__ What a card takes is the +declaration: a key type, a directory, a name, a certificate's @CN@, a host and +port. It never reads a file, so it cannot show a key's bytes, a fingerprint or +any digest of either; whether the file is there is the node's own check, drawn +as the card's verdict. The one link out (the project metadata page, for the +SSH CA key installed there) is built from the project id alone. +-} +module Salmon.Builtin.Cards.Keys ( + -- * SSH + sshKey, + sshCaSign, + sshAvailable, + metadataSshCa, + + -- * TLS certificates + tlsKey, + signingRequest, + selfSigned, + certificateAuthority, + caSigned, + + -- * Other keys + jwkKey, + wgPrivateKey, + wgPublicKey, + + -- * Before rendering + sshKeyCard, + sshCaSignCard, + sshAvailableCard, + metadataSshCaCard, + tlsKeyCard, + signingRequestCard, + selfSignedCard, + certificateAuthorityCard, + caSignedCard, + jwkKeyCard, + wgPrivateKeyCard, + wgPublicKeyCard, +) where + +import Data.Text (Text) +import qualified Data.Text as Text + +import Salmon.Builtin.Cards (Card (..), Link (..), Verdicts (..), renderCard) +import Salmon.Builtin.Cards.Gcp (consoleUrl) +import qualified Salmon.Builtin.Nodes.Certificates as Certs +import Salmon.Builtin.Nodes.Gcp.Core (Project (..)) +import qualified Salmon.Builtin.Nodes.Gcp.SshAccess as SshAccess +import qualified Salmon.Builtin.Nodes.Keys as Keys + +unchecked :: Text +unchecked = "no check result on this page yet" + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show + +-- | The verdicts of a node whose check is "the file is there". +fileVerdicts :: Text -> Text -> Verdicts +fileVerdicts what toApply = + Verdicts + { verdictInPlace = what <> " is present" + , verdictToApply = what <> " is missing: " <> toApply + , verdictUnsure = "could not tell whether " <> what <> " is there" + , verdictNoCheck = "the node declares no check" + , verdictUnchecked = unchecked + } + +-- | The verdicts of a node whose check is 'Certs.checkCertNotExpiringSoon'. +certVerdicts :: Text -> Verdicts +certVerdicts toApply = + Verdicts + { verdictInPlace = "the certificate is present and valid for more than a day" + , verdictToApply = "missing, expired or expiring within a day: " <> toApply + , verdictUnsure = "could not tell whether the certificate is valid" + , verdictNoCheck = "the node declares no check" + , verdictUnchecked = unchecked + } + +------------------------------------------------------------------------------- +-- SSH + +-- | For 'Keys.sshKey': the key type and the two paths, never the key. +sshKey :: Keys.SSHKeyPair -> Text +sshKey = renderCard . sshKeyCard + +-- | 'sshKey' before rendering. +sshKeyCard :: Keys.SSHKeyPair -> Card +sshKeyCard k = + Card + { cardFacts = + [ ("type", sshKeyType k.sshKeyType) + , ("private key", Text.pack (Keys.privateKeyPath k)) + , ("public key", Text.pack (Keys.publicKeyPath k)) + ] + , cardVerdicts = fileVerdicts "the private key" "up generates the pair" + , cardUp = "ssh-keygen with no passphrase, once: an existing key is never regenerated" + , cardDown = "nothing: keys are kept" + , cardLinks = [] + , cardDocs = Just "ssh-key" + } + +sshKeyType :: Keys.KeyType -> Text +sshKeyType Keys.RSA2048 = "RSA 2048" +sshKeyType Keys.RSA4096 = "RSA 4096" +sshKeyType Keys.ED25519 = "Ed25519" + +{- | For 'Keys.signKey' with this CA, identifier and principals, on this key: +the paths and the names the certificate is for, never a key. +-} +sshCaSign :: Keys.SSHCertificateAuthority -> Keys.KeyIdentifier -> [Keys.Principal] -> Keys.SSHKeyPair -> Text +sshCaSign ca kid ps k = renderCard (sshCaSignCard ca kid ps k) + +-- | 'sshCaSign' before rendering. +sshCaSignCard :: Keys.SSHCertificateAuthority -> Keys.KeyIdentifier -> [Keys.Principal] -> Keys.SSHKeyPair -> Card +sshCaSignCard ca kid ps k = + Card + { cardFacts = + [ ("identifier", kid.getIdentifier) + , ("principals", Text.intercalate ", " (fmap (.getPrincipal) ps)) + , ("certificate", Text.pack (Keys.publicCAKeyPath k)) + , ("signed key", Text.pack (Keys.publicKeyPath k)) + , ("CA key", Text.pack (Keys.privateKeyPath ca.sshcaKey)) + ] + , cardVerdicts = fileVerdicts "the certificate" "up signs the key with the CA" + , cardUp = "ssh-keygen -s with the CA key, once: an existing certificate is not renewed" + , cardDown = "nothing: the certificate is kept" + , cardLinks = [] + , cardDocs = Just "ssh-ca-sign" + } + +-- | For 'SshAccess.sshAvailable' (and 'SshAccess.sshAvailableWithin'): the user, host and port. +sshAvailable :: SshAccess.SshEndpoint -> Text +sshAvailable = renderCard . sshAvailableCard + +-- | 'sshAvailable' before rendering. +sshAvailableCard :: SshAccess.SshEndpoint -> Card +sshAvailableCard e = + Card + { cardFacts = + [ ("host", e.sshHost) + , ("port", tshow e.sshPort) + , ("user", maybe "ssh's default" id e.sshUser) + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "ssh answers" + , verdictToApply = "ssh does not answer: up waits for it, and fails if it never does" + , verdictUnsure = "the probe gave no verdict" + , verdictNoCheck = "the node declares no check" + , verdictUnchecked = unchecked + } + , cardUp = "probes ssh until it answers (a new host key is accepted, a changed one refused)" + , cardDown = "nothing: it only observes" + , cardLinks = [] + , cardDocs = Just "gcp-ssh-available" + } + +{- | For 'SshAccess.installMetadataCaKey': the project and the public key's +path, with a link to the project's metadata page in the Cloud console. +-} +metadataSshCa :: SshAccess.MetadataSshCa -> Text +metadataSshCa = renderCard . metadataSshCaCard + +-- | 'metadataSshCa' before rendering. +metadataSshCaCard :: SshAccess.MetadataSshCa -> Card +metadataSshCaCard c = + Card + { cardFacts = + [ ("project", c.sshCaProject.projectId) + , ("CA public key", Text.pack c.sshCaPublicKey) + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "the CA key is in the project metadata" + , verdictToApply = "not in the project metadata: up adds it" + , verdictUnsure = "could not ask the project" + , verdictNoCheck = "no check: run up adds it every time (gcloud replaces the metadata key); under serve it parks and nothing watches it" + , verdictUnchecked = unchecked + } + , cardUp = "gcloud compute project-info add-metadata, from the public key file" + , cardDown = "nothing: the metadata key stays" + , cardLinks = [Link "metadata in the Cloud console" (consoleUrl ["compute", "metadata"] c.sshCaProject)] + , cardDocs = Just "gcp-metadata-ssh-ca" + } + +------------------------------------------------------------------------------- +-- TLS + +-- | For 'Certs.tlsKey': the key type and path, never the key. +tlsKey :: Certs.Key -> Text +tlsKey = renderCard . tlsKeyCard + +-- | 'tlsKey' before rendering. +tlsKeyCard :: Certs.Key -> Card +tlsKeyCard k = + Card + { cardFacts = [("type", tlsKeyType k.keyType), ("key", Text.pack (Certs.keyPath k))] + , cardVerdicts = fileVerdicts "the key" "up generates it" + , cardUp = "openssl genrsa, once: an existing key is never regenerated" + , cardDown = "nothing: the key stays (its directory is archived, not deleted, on teardown)" + , cardLinks = [] + , cardDocs = Just "tls-key" + } + +tlsKeyType :: Certs.KeyType -> Text +tlsKeyType Certs.RSA2048 = "RSA 2048" +tlsKeyType Certs.RSA4096 = "RSA 4096" + +-- | For 'Certs.signingRequest': the CN and the paths. +signingRequest :: Certs.SigningRequest -> Text +signingRequest = renderCard . signingRequestCard + +-- | 'signingRequest' before rendering. +signingRequestCard :: Certs.SigningRequest -> Card +signingRequestCard req = + Card + { cardFacts = requestFacts req + , cardVerdicts = + Verdicts + { verdictInPlace = "the request is written" + , verdictToApply = "no request yet: up writes it" + , verdictUnsure = "could not tell whether a request is there" + , verdictNoCheck = "no check: run up rewrites the request (PEM and DER) every time; under serve it parks and nothing watches it" + , verdictUnchecked = unchecked + } + , cardUp = "openssl req for this CN with the key, then the same request as DER" + , cardDown = "nothing: the request stays" + , cardLinks = [] + , cardDocs = Just "tls-signing-request" + } + +requestFacts :: Certs.SigningRequest -> [(Text, Text)] +requestFacts req = + [ ("CN", req.certDomain.getDomain) + , ("request", Text.pack (Certs.csrPath req)) + , ("key", Text.pack (Certs.keyPath req.certKey)) + ] + +-- | For 'Certs.selfSign': the certificate's path and CN. +selfSigned :: Certs.SelfSigned -> Text +selfSigned = renderCard . selfSignedCard + +-- | 'selfSigned' before rendering. +selfSignedCard :: Certs.SelfSigned -> Card +selfSignedCard s = + Card + { cardFacts = ("certificate", Text.pack s.selfSignedPEMPath) : requestFacts s.selfSignedRequest + , cardVerdicts = certVerdicts "up signs the request with its own key" + , cardUp = "openssl x509 -req, signed with the request's own key" + , cardDown = "nothing: the certificate stays" + , cardLinks = [] + , cardDocs = Just "tls-self-signed" + } + +-- | For 'Certs.certificateAuthority': its CN, validity and paths. +certificateAuthority :: Certs.CertificateAuthority -> Text +certificateAuthority = renderCard . certificateAuthorityCard + +-- | 'certificateAuthority' before rendering. +certificateAuthorityCard :: Certs.CertificateAuthority -> Card +certificateAuthorityCard ca = + Card + { cardFacts = + [ ("CN", ca.caCommonName.getDomain) + , ("certificate", Text.pack ca.caCertPath) + , ("key", Text.pack (Certs.keyPath ca.caKey)) + , ("validity", tshow ca.caValidityDays <> " days") + ] + , cardVerdicts = certVerdicts "up self-signs a new CA certificate with the same key" + , cardUp = "openssl req -x509 with the CA key, marked as a CA" + , cardDown = "nothing: the CA stays (losing its key means nothing can be issued to the fleet that trusts it)" + , cardLinks = [] + , cardDocs = Just "tls-certificate-authority" + } + +-- | For 'Certs.caSign': the CN, the issuing CA and the paths. +caSigned :: Certs.CaSigned -> Text +caSigned = renderCard . caSignedCard + +-- | 'caSigned' before rendering. +caSignedCard :: Certs.CaSigned -> Card +caSignedCard s = + Card + { cardFacts = + ("certificate", Text.pack s.caSignedPEMPath) + : requestFacts s.caSignedRequest + <> [ ("CA", s.caSignedAuthority.caCommonName.getDomain) + , ("validity", tshow s.caSignedValidityDays <> " days") + ] + , cardVerdicts = certVerdicts "up signs the request with the CA" + , cardUp = "openssl x509 -req, signed with the CA's certificate and key" + , cardDown = "nothing: the certificate stays" + , cardLinks = [] + , cardDocs = Just "tls-ca-signed" + } + +------------------------------------------------------------------------------- +-- Other keys + +-- | For 'Keys.jwkKey': the key type and path, never the key. +jwkKey :: Keys.JWKKeyPair -> Text +jwkKey = renderCard . jwkKeyCard + +-- | 'jwkKey' before rendering. +jwkKeyCard :: Keys.JWKKeyPair -> Card +jwkKeyCard k = + Card + { cardFacts = [("type", sshKeyType k.jwkKeyType), ("key", Text.pack (Keys.jwkfilepath k))] + , cardVerdicts = fileVerdicts "the key" "up generates it" + , cardUp = "generates a JWK and writes it, once: an existing key is never regenerated" + , cardDown = "nothing: keys are kept" + , cardLinks = [] + , cardDocs = Just "jwk-key" + } + +-- | For 'Salmon.Builtin.Nodes.WireGuard.privateKey' at this path: the path, never the key. +wgPrivateKey :: FilePath -> Text +wgPrivateKey = renderCard . wgPrivateKeyCard + +-- | 'wgPrivateKey' before rendering. +wgPrivateKeyCard :: FilePath -> Card +wgPrivateKeyCard path = + Card + { cardFacts = [("private key", Text.pack path)] + , cardVerdicts = fileVerdicts "the private key" "up generates it" + , cardUp = "wg genkey into the file, once: an existing key is never regenerated" + , cardDown = "nothing: the key stays" + , cardLinks = [] + , cardDocs = Just "wireguard-private-key" + } + +{- | For 'Salmon.Builtin.Nodes.WireGuard.publicKey' from this private key, at +this path: the two paths, never a key. +-} +wgPublicKey :: FilePath -> FilePath -> Text +wgPublicKey private path = renderCard (wgPublicKeyCard private path) + +-- | 'wgPublicKey' before rendering. +wgPublicKeyCard :: FilePath -> FilePath -> Card +wgPublicKeyCard private path = + Card + { cardFacts = [("public key", Text.pack path), ("from", Text.pack private)] + , cardVerdicts = fileVerdicts "the public key" "up derives it" + , cardUp = "wg pubkey from the private key, once: a later change of the private key is not followed" + , cardDown = "nothing: the key stays" + , cardLinks = [] + , cardDocs = Just "wireguard-public-key" + } diff --git a/src/Salmon/Builtin/Cards/Patroni.hs b/src/Salmon/Builtin/Cards/Patroni.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Cards/Patroni.hs @@ -0,0 +1,266 @@ +{- | Web UI cards for the Patroni, pgBackRest and HAProxy builtins +("Salmon.Builtin.Nodes.Patroni", "Salmon.Builtin.Nodes.Patroni.PreferredLeader", +"Salmon.Builtin.Nodes.PgBackRest", "Salmon.Builtin.Nodes.Haproxy"), in the +style of "Salmon.Builtin.Cards" (feature e593a79b). __Opt-in__, attached per +node with 'Salmon.Builtin.Cards.withCard'. + +A card takes names, addresses, ports and paths from the declaration. It +never takes a credentials file's contents (Patroni's, the REST API's, or +pgBackRest's fragment, shown by path when there is one), nor an archive's +location beyond its kind: an S3 bucket and endpoint are not on the card. +Like the builtins, no card says which member leads: that is Patroni's, and +its REST API is not linked (it speaks plain HTTP, which the page does not +draw as a link). +-} +module Salmon.Builtin.Cards.Patroni ( + -- * Patroni + patroniMember, + preferredLeader, + + -- * pgBackRest + pgBackRestConfiguration, + pgBackRestStanza, + pgBackRestFirstBackup, + pgBackRestRestore, + + -- * HAProxy + haproxy, + + -- * Before rendering + patroniMemberCard, + preferredLeaderCard, + pgBackRestConfigurationCard, + pgBackRestStanzaCard, + pgBackRestFirstBackupCard, + pgBackRestRestoreCard, + haproxyCard, +) where + +import Data.Text (Text) +import qualified Data.Text as Text + +import Salmon.Builtin.Cards (Card (..), Verdicts (..), renderCard) +import qualified Salmon.Builtin.Nodes.Haproxy as Haproxy +import qualified Salmon.Builtin.Nodes.Patroni as Patroni +import Salmon.Builtin.Nodes.Patroni.PreferredLeader (PreferredLeader (..)) +import qualified Salmon.Builtin.Nodes.PgBackRest as PgBackRest + +unchecked :: Text +unchecked = "no check result on this page yet" + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show + +commas :: [Text] -> Text +commas = Text.intercalate ", " + +------------------------------------------------------------------------------- +-- Patroni + +{- | For 'Patroni.patroniMember': the scope, the member, its addresses and its +configuration directory; never the credentials file's contents, nor a role. +-} +patroniMember :: Patroni.PatroniConfig -> Text +patroniMember = renderCard . patroniMemberCard + +-- | 'patroniMember' before rendering. +patroniMemberCard :: Patroni.PatroniConfig -> Card +patroniMemberCard c = + Card + { cardFacts = + [ ("scope", c.pat_scope) + , ("member", c.pat_name) + , ("REST API", c.pat_rest_connect_address) + , ("Postgres", c.pat_pg_connect_address) + , ("Postgres version", c.pat_pg_version) + , ("etcd", commas c.pat_etcd_hosts) + , ("config dir", Text.pack c.pat_config_dir) + , ("credentials file", Text.pack c.pat_secrets_file) + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "running and healthy, in the declared scope (its role is Patroni's, not judged here)" + , verdictToApply = "not answering, not healthy, or in another scope: up starts it and waits for it" + , verdictUnsure = "starting, or in a state Patroni calls transitional: nothing restarts on this" + , verdictNoCheck = "the node declares no check" + , verdictUnchecked = unchecked + } + , cardUp = "waits for the member to be healthy; under it, patroni.yml, the unit and the masked Debian cluster unit" + , cardDown = "nothing of its own: the unit under it is stopped, and the data directory is left alone" + , cardLinks = [] + , cardDocs = Just "patroni-member" + } + +{- | For 'Salmon.Builtin.Nodes.Patroni.PreferredLeader.preferredLeader': the +scope, the preferred member and its REST address; the credentials file by +path only. +-} +preferredLeader :: PreferredLeader -> Text +preferredLeader = renderCard . preferredLeaderCard + +-- | 'preferredLeader' before rendering. +preferredLeaderCard :: PreferredLeader -> Card +preferredLeaderCard c = + Card + { cardFacts = + [ ("scope", c.pl_scope) + , ("preferred", c.pl_member) + , ("REST API", c.pl_rest_address) + , ("credentials file", maybe "none" Text.pack c.pl_credentials_file) + , ("settle", tshow c.pl_settle_seconds <> " s") + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "the preferred member leads" + , verdictToApply = "another member leads and the preferred one is eligible: up asks Patroni for a switchover" + , verdictUnsure = "waiting: no leader, or the preferred member is not eligible right now" + , verdictNoCheck = "the node declares no check" + , verdictUnchecked = unchecked + } + , cardUp = "POST /switchover to the preferred member, then waits up to the settle time for it to lead" + , cardDown = "nothing: the leader stays where it is" + , cardLinks = [] + , cardDocs = Just "patroni-preferred-leader" + } + +------------------------------------------------------------------------------- +-- pgBackRest + +-- the facts every pgBackRest card shares +pbrFacts :: PgBackRest.PgBackRestConfig -> [(Text, Text)] +pbrFacts c = + [ ("stanza", c.pbr_stanza) + , ("data dir", Text.pack c.pbr_pg_path) + , ("repository", repoKind c.pbr_repo) + , ("config", Text.pack c.pbr_config_file) + ] + where + repoKind (PgBackRest.PosixRepo path) = "directory " <> Text.pack path + repoKind PgBackRest.S3Repo{} = "S3" + +-- | For 'PgBackRest.configuration': the stanza, paths, and the secrets fragment's path. +pgBackRestConfiguration :: PgBackRest.PgBackRestConfig -> Text +pgBackRestConfiguration = renderCard . pgBackRestConfigurationCard + +-- | 'pgBackRestConfiguration' before rendering. +pgBackRestConfigurationCard :: PgBackRest.PgBackRestConfig -> Card +pgBackRestConfigurationCard c = + Card + { cardFacts = pbrFacts c <> [("secrets fragment", maybe "none" Text.pack c.pbr_secrets_file)] + , cardVerdicts = + Verdicts + { verdictInPlace = "everything under it is in place" + , verdictToApply = "something under it is missing: up applies it" + , verdictUnsure = "could not tell what is under it" + , verdictNoCheck = "no check of its own: the binary, pgbackrest.conf, the log and repository directories and the fragment's ownership are the nodes under it" + , verdictUnchecked = unchecked + } + , cardUp = "nothing of its own: under it, the binary, pgbackrest.conf and the directories; a missing secrets fragment fails (writing it is not this node's job)" + , cardDown = "nothing of its own" + , cardLinks = [] + , cardDocs = Just "pgbackrest-configuration" + } + +-- | For 'PgBackRest.stanza'. +pgBackRestStanza :: PgBackRest.PgBackRestConfig -> Text +pgBackRestStanza = renderCard . pgBackRestStanzaCard + +-- | 'pgBackRestStanza' before rendering. +pgBackRestStanzaCard :: PgBackRest.PgBackRestConfig -> Card +pgBackRestStanzaCard c = + Card + { cardFacts = pbrFacts c + , cardVerdicts = + Verdicts + { verdictInPlace = "the repository holds the stanza" + , verdictToApply = "no stanza in the repository: up creates it (only the primary can)" + , verdictUnsure = "could not read the repository" + , verdictNoCheck = "the node declares no check" + , verdictUnchecked = unchecked + } + , cardUp = "pgbackrest stanza-create (idempotent; fails on a member that is not the primary)" + , cardDown = "nothing: the stanza and its archive stay" + , cardLinks = [] + , cardDocs = Just "pgbackrest-stanza" + } + +-- | For 'PgBackRest.firstBackup'. +pgBackRestFirstBackup :: PgBackRest.PgBackRestConfig -> Text +pgBackRestFirstBackup = renderCard . pgBackRestFirstBackupCard + +-- | 'pgBackRestFirstBackup' before rendering. +pgBackRestFirstBackupCard :: PgBackRest.PgBackRestConfig -> Card +pgBackRestFirstBackupCard c = + Card + { cardFacts = pbrFacts c <> [("full backups kept", tshow c.pbr_retention_full)] + , cardVerdicts = + Verdicts + { verdictInPlace = "the repository holds a backup" + , verdictToApply = "no backup yet: up takes a full one (only the primary can)" + , verdictUnsure = "could not read the repository" + , verdictNoCheck = "the node declares no check" + , verdictUnchecked = unchecked + } + , cardUp = "pgbackrest backup --type=full, when the repository holds none; later backups are a schedule's" + , cardDown = "nothing: backups stay" + , cardLinks = [] + , cardDocs = Just "pgbackrest-first-backup" + } + +-- | For 'PgBackRest.restoredCluster' to this target. +pgBackRestRestore :: PgBackRest.PgBackRestConfig -> PgBackRest.RestoreTarget -> Text +pgBackRestRestore c t = renderCard (pgBackRestRestoreCard c t) + +-- | 'pgBackRestRestore' before rendering. +pgBackRestRestoreCard :: PgBackRest.PgBackRestConfig -> PgBackRest.RestoreTarget -> Card +pgBackRestRestoreCard c t = + Card + { cardFacts = pbrFacts c <> [("target", tshow t)] + , cardVerdicts = + Verdicts + { verdictInPlace = "the data directory holds a cluster: it is left alone, whatever it is" + , verdictToApply = "the data directory holds no cluster: up restores into it" + , verdictUnsure = "could not tell whether the data directory holds a cluster" + , verdictNoCheck = "the node declares no check" + , verdictUnchecked = unchecked + } + , cardUp = "pgbackrest restore without --delta or --force, so a directory holding anything is refused; starting the cluster is the next node's" + , cardDown = "nothing: a restored cluster is data" + , cardLinks = [] + , cardDocs = Just "pgbackrest-restore" + } + +------------------------------------------------------------------------------- +-- HAProxy + +{- | For 'Haproxy.setup' (the haproxy service): the listeners, the members and +the configuration file. Which member leads is not on it, as it is not in +the configuration. +-} +haproxy :: Haproxy.HaproxyConfig -> Text +haproxy = renderCard . haproxyCard + +-- | 'haproxy' before rendering. +haproxyCard :: Haproxy.HaproxyConfig -> Card +haproxyCard c = + Card + { cardFacts = + [("config", Text.pack (Haproxy.configPath c))] + <> [ ("listener " <> l.listener_name, l.listener_bind_addr <> ":" <> tshow l.listener_port <> " → " <> Haproxy.checkPath l.listener_role) + | l <- c.haproxy_listeners + ] + <> [("members", commas [m.member_name <> " (" <> m.member_host <> ":" <> tshow m.member_pg_port <> ")" | m <- c.haproxy_members])] + <> [("stats", a <> ":" <> tshow p) | Just (a, p) <- [c.haproxy_stats]] + , cardVerdicts = + Verdicts + { verdictInPlace = "haproxy is active and enabled, as loaded" + , verdictToApply = "not as declared: up reloads, enables and restarts it" + , verdictUnsure = "in transition, or systemctl did not answer: nothing restarts on this" + , verdictNoCheck = "the node declares no check" + , verdictUnchecked = unchecked + } + , cardUp = "the systemd unit, restarted when haproxy.cfg changes (a changed member list drops connections in flight; a failover changes nothing here)" + , cardDown = "systemctl stop; the configuration file stays" + , cardLinks = [] + , cardDocs = Just "haproxy-service" + } diff --git a/src/Salmon/Builtin/Cards/Postgres.hs b/src/Salmon/Builtin/Cards/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Cards/Postgres.hs @@ -0,0 +1,193 @@ +{- | Web UI cards for more of the Postgres builtins +("Salmon.Builtin.Nodes.Postgres"), in the style of "Salmon.Builtin.Cards" +(feature d8a79380; 'Salmon.Builtin.Cards.pgDatabase' is there already). +__Opt-in__, attached per node with 'Salmon.Builtin.Cards.withCard'. + +A card takes only what the builtin already publishes in its @ref@ and +@help@: a role name, a port, a slot, a cluster, a setting, a file's path. +It never takes a password, so it cannot show one or any digest of one; for a +password file or a TLS key it shows the path only. +-} +module Salmon.Builtin.Cards.Postgres ( + -- * Cards + user, + userPassFile, + replicationUser, + replicationSlot, + hbaLine, + alterSystem, + serverTls, + + -- * Before rendering + userCard, + userPassFileCard, + replicationUserCard, + replicationSlotCard, + hbaLineCard, + alterSystemCard, + serverTlsCard, +) where + +import Data.Text (Text) +import qualified Data.Text as Text + +import Salmon.Builtin.Cards (Card (..), Verdicts (..), renderCard) +import qualified Salmon.Builtin.Nodes.Postgres as Postgres + +unchecked :: Text +unchecked = "no check result on this page yet" + +port_ :: Postgres.Port -> (Text, Text) +port_ p = ("port", Text.pack (show p)) + +-- the sentence for a builtin with no check +reapplied :: Text +reapplied = "no check: run up applies it every time (it is idempotent); under serve it parks and nothing watches it" + +-- | For 'Postgres.user' on this port: the role, never the password. +user :: Postgres.Port -> Postgres.User -> Text +user p u = renderCard (userCard p u) + +-- | 'user' before rendering. +userCard :: Postgres.Port -> Postgres.User -> Card +userCard p u = + Card + { cardFacts = [("role", u.userRole), port_ p] + , cardVerdicts = userVerdicts "the declared one" + , cardUp = "creates the login role if missing, then sets its password (either way)" + , cardDown = "nothing: a role is never dropped by this node" + , cardLinks = [] + , cardDocs = Just "postgres-user" + } + +userVerdicts :: Text -> Verdicts +userVerdicts which = + Verdicts + { verdictInPlace = "the role exists, may log in, and its password is " <> which + , verdictToApply = "missing, not allowed to log in, or holding another password: up sets it" + , verdictUnsure = "could not ask the cluster, or read the declared password" + , verdictNoCheck = "the node declares no check" + , verdictUnchecked = unchecked + } + +{- | For 'Postgres.userPassFile' on this port, with the password file at +this path: the role and the path, never the file's contents. +-} +userPassFile :: Postgres.Port -> FilePath -> Postgres.User -> Text +userPassFile p path u = renderCard (userPassFileCard p path u) + +-- | 'userPassFile' before rendering. +userPassFileCard :: Postgres.Port -> FilePath -> Postgres.User -> Card +userPassFileCard p path u = + Card + { cardFacts = [("role", u.userRole), port_ p, ("password file", Text.pack path)] + , cardVerdicts = userVerdicts "the file's" + , cardUp = "creates the login role if missing, then sets its password from the file, read at that moment" + , cardDown = "nothing: a role is never dropped by this node" + , cardLinks = [] + , cardDocs = Just "postgres-user-passfile" + } + +-- | For 'Postgres.replicationUser' on this port: the role, never the password. +replicationUser :: Postgres.Port -> Postgres.User -> Text +replicationUser p u = renderCard (replicationUserCard p u) + +-- | 'replicationUser' before rendering. +replicationUserCard :: Postgres.Port -> Postgres.User -> Card +replicationUserCard p u = + Card + { cardFacts = [("role", u.userRole), port_ p, ("attributes", "REPLICATION LOGIN")] + , cardVerdicts = noCheckVerdicts "the role is there" "missing: up creates it" + , cardUp = "creates the role with REPLICATION LOGIN if missing, then sets its password (either way)" + , cardDown = "nothing: a role is never dropped by this node" + , cardLinks = [] + , cardDocs = Just "postgres-replication-user" + } + +noCheckVerdicts :: Text -> Text -> Verdicts +noCheckVerdicts inPlace toApply = + Verdicts + { verdictInPlace = inPlace + , verdictToApply = toApply + , verdictUnsure = "could not ask the server" + , verdictNoCheck = reapplied + , verdictUnchecked = unchecked + } + +-- | For 'Postgres.replicationSlot' on this port. +replicationSlot :: Postgres.Port -> Postgres.ReplicationSlotName -> Text +replicationSlot p slot = renderCard (replicationSlotCard p slot) + +-- | 'replicationSlot' before rendering. +replicationSlotCard :: Postgres.Port -> Postgres.ReplicationSlotName -> Card +replicationSlotCard p slot = + Card + { cardFacts = [("slot", slot), ("kind", "physical"), port_ p] + , cardVerdicts = noCheckVerdicts "the slot is there" "missing: up creates it" + , cardUp = "creates the physical replication slot unless pg_replication_slots has it" + , cardDown = "nothing: the slot is left (a slot nobody reads from holds WAL back, so drop it by hand when its standby is gone)" + , cardLinks = [] + , cardDocs = Just "postgres-replication-slot" + } + +-- | For 'Postgres.hbaLine' on this cluster. +hbaLine :: Postgres.ClusterName -> Text -> Text +hbaLine cluster line = renderCard (hbaLineCard cluster line) + +-- | 'hbaLine' before rendering. +hbaLineCard :: Postgres.ClusterName -> Text -> Card +hbaLineCard cluster line = + Card + { cardFacts = [("cluster", cluster), ("line", line)] + , cardVerdicts = noCheckVerdicts "the line is in pg_hba.conf" "missing: up appends it" + , cardUp = "appends the line to pg_hba.conf unless it is there verbatim, then reloads the cluster" + , cardDown = "nothing: the line stays (and a changed declaration leaves the old line in place)" + , cardLinks = [] + , cardDocs = Just "postgres-hba-line" + } + +-- | For 'Postgres.alterSystemSet' on this port. +alterSystem :: Postgres.Port -> Text -> Text -> Text +alterSystem p param val = renderCard (alterSystemCard p param val) + +-- | 'alterSystem' before rendering. +alterSystemCard :: Postgres.Port -> Text -> Text -> Card +alterSystemCard p param val = + Card + { cardFacts = [("setting", param), ("value", val), port_ p] + , cardVerdicts = noCheckVerdicts "the setting is written" "not written yet: up writes it" + , cardUp = "ALTER SYSTEM SET, written to postgresql.auto.conf; it takes effect on a reload or, for some settings, a restart" + , cardDown = "nothing: the setting stays" + , cardLinks = [] + , cardDocs = Just "postgres-alter-system" + } + +{- | For 'Postgres.serverTls' (and 'Postgres.serverTlsAfter') on this port: +the three files' paths, never what is in them (the key above all). +-} +serverTls :: Postgres.Port -> Postgres.ServerTls -> Text +serverTls p tls = renderCard (serverTlsCard p tls) + +-- | 'serverTls' before rendering. +serverTlsCard :: Postgres.Port -> Postgres.ServerTls -> Card +serverTlsCard p tls = + Card + { cardFacts = + [ port_ p + , ("certificate", Text.pack tls.tls_certFile) + , ("key", Text.pack tls.tls_keyFile) + , ("client CA", Text.pack tls.tls_caFile) + ] + , cardVerdicts = + Verdicts + { verdictInPlace = "TLS is on, as declared" + , verdictToApply = "TLS is off or not as declared" + , verdictUnsure = "could not ask the server" + , verdictNoCheck = "no check of its own: the settings and the reload under it run on each pass; a broken certificate is not noticed until a client connects" + , verdictUnchecked = unchecked + } + , cardUp = "nothing of its own: under it, ssl and the three file settings are set, then the configuration is reloaded" + , cardDown = "nothing: TLS stays configured" + , cardLinks = [] + , cardDocs = Just "postgres-server-tls" + } diff --git a/src/Salmon/Builtin/CommandLine.hs b/src/Salmon/Builtin/CommandLine.hs --- a/src/Salmon/Builtin/CommandLine.hs +++ b/src/Salmon/Builtin/CommandLine.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} @@ -21,7 +22,7 @@ import qualified Options.Applicative import Options.Generic import System.Exit (exitFailure) -import System.IO (hPutStrLn, stderr, stdin, stdout) +import System.IO (BufferMode (..), hPutStrLn, hSetBuffering, stderr, stdin, stdout) import Salmon.Op.Actions (Act (..)) import qualified Salmon.Op.Concurrency as Concurrency @@ -44,7 +45,12 @@ import qualified Salmon.Actions.Query as Query import qualified Salmon.Actions.Serve as Serve import qualified Salmon.Actions.Serve.Events as Events +#ifdef SALMON_HTTP_SERVER import qualified Salmon.Actions.Serve.Http as Http +#else +-- built with -http-server: the same names, refusing (see 'httpServerAvailable') +import qualified Salmon.Actions.Serve.NoHttp as Http +#endif import qualified Salmon.Actions.Serve.Socket as Socket import qualified Salmon.Actions.Serve.StatusSink as StatusSink -- 'CheckResult' constructors are hidden: 'Success'/'Failure' collide with @@ -54,6 +60,7 @@ import Salmon.Builtin.Extension import qualified Salmon.Op.Window as Window import Salmon.Reporter +import qualified Salmon.Builtin.NodeLog as NodeLog import qualified Salmon.Reporter.Tagged as Tagged data Command seed @@ -115,8 +122,12 @@ -- 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 + -- @--token-file@, all three or nothing. And whether every HTTP + -- listener refuses @POST \/command@ (@--http-read-only@; 'False', the + -- default, is every version before the flag; see 'Http.Access'). + -- Then the maintenance windows and @--override-window@, as for + -- 'RunUp' (see 'Serve.serveObservedWith' for what @serve@ does with them). + RunServe !(Maybe Int) !Bool !ReportFormat !(Maybe FilePath) ![Text] !FollowOptions !(Maybe FilePath) !(Maybe FilePath) !Int !SinkOptions !TcpOptions !Bool ![Text] !Bool deriving (Eq, Ord, Generic, Show) {- | The four flags that put the HTTP surface on a network, as typed. What @@ -143,6 +154,22 @@ instance FromJSON TcpOptions instance ToJSON TcpOptions +{- | Whether this @salmon-ops@ was built with its @http-server@ flag (the +default), i.e. whether @run serve --http@\/@--http-tcp@ can do anything. +Without it the library has no warp, warp-tls or wai in its plan, and the +loop runs over standard input and @--listen@ only. +-} +httpServerAvailable :: Bool +#ifdef SALMON_HTTP_SERVER +httpServerAvailable = True +#else +httpServerAvailable = False +#endif + +-- | What @run serve@ says when given an HTTP flag it was built without. +httpServerUnavailable :: String +httpServerUnavailable = "this binary was built with salmon-ops -http-server: --http and --http-tcp are not available (rebuild with the flag on, its default)" + -- | No network listener at all: the default. noTcp :: TcpOptions noTcp = TcpOptions Nothing Nothing Nothing Nothing Nothing Nothing @@ -433,6 +460,13 @@ ) <*> sinkOptionsP <*> tcpOptionsP + <*> switch + ( long "http-read-only" + <> Options.Applicative.help + "Spectate-only HTTP: --http and --http-tcp serve the page, the reads and /events, and answer every POST /command with 403, so no HTTP request changes the declarations, the wanted nodes or supervision, or ends the loop. Stdin and --listen are unaffected." + ) + <*> maintenanceWindowsP "Nodes marked disruptive are brought up only inside these windows (repeatable): outside them a pass skips them without counting them converged, `status` shows until when they are held, and a tended node waits for the next opening (a `force` still goes through). Teardowns are not held. DAY is Mon..Sun; a start later than the end crosses midnight; the zone is a fixed offset, UTC by default." + <*> overrideWindowP tcpOptionsP = TcpOptions <$> optional @@ -622,18 +656,22 @@ <> 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." + <*> maintenanceWindowsP "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." + <*> overrideWindowP + maintenanceWindowsP helpText = + 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 helpText ) + ) + overrideWindowP = + switch + ( long "override-window" + <> Options.Applicative.help "Run disruptive nodes whatever the maintenance windows say." + ) reportFormatP = Options.Applicative.flag ReportText @@ -748,10 +786,10 @@ 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) + result <- listening fmt $ 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 + result <- listening fmt $ withGraphAndBytes $ \dirBytes op -> do planBytes <- LBysteString.readFile planPath case eitherDecode planBytes of Left err -> do @@ -781,7 +819,7 @@ exitFailure when (result == Just False) exitFailure (Run (RunDown fmt)) -> do - result <- withGraph (runDown (updownFor fmt)) + result <- listening fmt $ withGraph (runDown (updownFor fmt)) when (result == Just False) exitFailure (Run RunTree) -> do -- (R4): the computed 'Dag' is what @run up@ would actually walk @@ -791,9 +829,15 @@ 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 + (Run (RunServe maxConcurrency noAutoConverge fmt followDir labels followOptions listen http eventsRing sinkOptions tcpOptions httpReadOnly wins overrideWins)) -> do + reportByLine limit <- traverse Concurrency.newConcurrencyLimit maxConcurrency let own = taggedFor fmt + -- a build without the HTTP server says so before anything is + -- bound or read, rather than after the socket listener is up + when (not httpServerAvailable && (isJust http || isJust tcpOptions.tcpBind)) $ do + hPutStrLn stderr httpServerUnavailable + exitFailure -- 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 @@ -818,6 +862,12 @@ 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 + -- a flag that would restrict nothing is refused, like the TLS + -- files without --http-tcp, rather than silently a no-op + when (httpReadOnly && null binds) $ do + hPutStrLn stderr "--http-read-only needs --http PATH or --http-tcp HOST:PORT to apply to; there is no HTTP listener without one" + exitFailure + let access = if httpReadOnly then Http.ReadOnly else Http.ReadWrite 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" @@ -911,7 +961,7 @@ -- 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 + withMaybe (nonEmptyList binds) (\bs -> Http.withHttpServerAccess Events.defaultConfig{Events.configRing = eventsRing} access 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 -> @@ -925,8 +975,16 @@ traverse_ (`Http.serverObserver` acc) mserver traverse_ (`StatusSink.sinkObserver` acc) msink more = foldMap (pure . Socket.listenerProducer) mlistener <> foldMap (pure . Http.serverProducer) mserver + -- what a node says while it works: to the loop's own + -- reporter (text or JSON, as `fmt` says), with a + -- server to /events on the `output` stream, and with + -- a socket to the client whose command it belongs to + nodeLogR = maybe id (\srv nr -> reportBoth nr (Http.serverNodeLogReporter srv)) mserver (Tagged.nodeLogStream tagged) + saidR = maybe id (\listener sr -> reportBoth sr (Socket.listenerNodeLogReporter listener)) mlistener (contramap Serve.attributed nodeLogR) void $ - Serve.serveObserved + Serve.serveSayingWith + (if overrideWins then Window.noWindows else Window.windowsAt (rights (map Window.parseWindow wins))) + saidR observe rewrites limit @@ -983,7 +1041,7 @@ 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 + ReportText -> Tagged.reportTexts serveR r silent Follow.reportText (Tagged.reportNodeLogText stdout) ReportJson -> Tagged.reportJSONLines stdout -- | The tagged reporter split contravariantly into the two the drivers take. @@ -992,6 +1050,21 @@ updownFor :: ReportFormat -> Reporter (UpDown.Report Extension) updownFor = snd . reportersOver . taggedFor + + {- | Standard output flushed at every line whatever it is attached to. A + terminal already is; a file or a pipe is block-buffered by default, so + the text reports of a pass redirected to a log arrived in 8k chunks, + long after the nodes they are about. -} + reportByLine :: IO () + reportByLine = hSetBuffering stdout LineBuffering + + {- | A one-shot pass with a listener for what its nodes say while they + work ("Salmon.Builtin.NodeLog"), printed or JSON-encoded like every + other report of the pass. -} + listening :: ReportFormat -> IO a -> IO a + listening fmt act = do + reportByLine + NodeLog.withSink (Tagged.nodeLogStream (taggedFor fmt)) act {- | @run up@: everything in this one directive's graph is wanted up, so that is the rewrites' 'phaseDesired'. @excluded@ (a plan's skipped diff --git a/src/Salmon/Builtin/Extension.hs b/src/Salmon/Builtin/Extension.hs --- a/src/Salmon/Builtin/Extension.hs +++ b/src/Salmon/Builtin/Extension.hs @@ -17,6 +17,7 @@ import Salmon.Actions.Dot (PlaceHolder (..)) import Salmon.Actions.UpDown (CheckResult (..)) import Salmon.Op.Actions +import Salmon.Op.CardTemplate (setCardTemplate) import Salmon.Op.Configure import Salmon.Op.Eval import Salmon.Op.Graph @@ -170,10 +171,34 @@ 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} + -- apply the modifier on Extension on top of a noop + amendNode f (noop short){predecessors = pred} + +{- | Amend this one node's 'Extension', leaving its predecessors exactly as +they were: the way to add a @check@, a note or a different @help@ to a +builtin from outside it. + +An 'fmap' over an 'Op' is not that: 'OpGraph' is a 'Functor' over the whole +graph, so it rewrites every dependency too (two declarations sharing a +directory node then disagree about it and fold as @Conflicting@). This is +the record update 'op' itself does, given a name. + +An 'Actionless' node has no 'Extension' and is returned unchanged. +-} +amendNode :: (Extension -> Extension) -> Op -> Op +amendNode f o = o{node = fmap f o.node} + +{- | Give this node a Tramaj template for its card in the web UI, replacing +any it had. Nothing else about the node changes: the template is left out +of its representative ("Salmon.Op.CardTemplate"), so a running @serve@ +does not see it as a changed node. On a builtin, use it through +'amendNode': @amendNode (withCardTemplate src) builtinOp@. + +The source is public (served on @\/dag@); the contract is +@salmon-ops\/ui\/card-template.js@. +-} +withCardTemplate :: Text -> Extension -> Extension +withCardTemplate src ext = ext{dynamics = setCardTemplate src ext.dynamics} placeholder :: ShortHand -> Text -> Op placeholder short t = op short nodeps $ \actions -> diff --git a/src/Salmon/Builtin/Guarded.hs b/src/Salmon/Builtin/Guarded.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Guarded.hs @@ -0,0 +1,134 @@ +{- | Guarding an operation that cannot be undone: a major upgrade, a restart +of the member everything else follows. + +The pattern is written here once, as a combinator over a node somebody +already wrote, and is three rules: + +1. __It starts only when its preconditions are met.__ They are folded into + the node's @check@: a node whose effect is not in place and whose + preconditions are unmet answers 'Salmon.Actions.UpDown.Unknown' ("ran and + could not tell", the verdict for a transitional state), and + "Salmon.Actions.Upkeep" keeps asking and starts nothing. They are asked + again at the top of @up@, which throws 'PreconditionUnmet' rather than + act, because the one-shot drivers map 'Salmon.Actions.UpDown.Unknown' to + "run @up@": under @run up@ the operation is refused, reported failed, and + its dependants are blocked. +2. __A failure parks it.__ The node's + 'Salmon.Op.Supervision.supGiveUpAfter' is set (to one failure unless + 'guardingAttempts' says otherwise), so "Salmon.Actions.Upkeep" stops + instead of retrying, and only an operator's + 'Salmon.Op.Mailbox.Force' or 'Salmon.Op.Mailbox.Recheck' starts it over. + A refusal to start (rule 1) is not a failure and is not counted. +3. __Its siblings hold still while it runs.__ 'guardingHolds' names them; + "Salmon.Actions.Upkeep" pauses each one, waits until they have all + stopped, runs @up@, and resumes them when the operation completes or is + parked. + +What this does not do, so that nobody assumes it: + +* It does not guard 'Salmon.Builtin.Extension.managed'. A node that /is/ a + running process has no @up@ for a precondition to stand in front of. +* 'Salmon.Op.Mailbox.Force' does not bypass the preconditions: it overrides + the check, and @up@ asks them again. +* Rules 2 and 3 are "Salmon.Actions.Upkeep"'s. A one-shot pass makes one + attempt by construction and pauses nobody; there, only an edge orders two + nodes. +* The park lives in the node's machine, not on disk. See + @resources\/module-notes.md@ on what that means under @run serve@. +-} +module Salmon.Builtin.Guarded ( + guarded, + Guarding (..), + defaultGuarding, + + -- * Re-exported from "Salmon.Op.Guard" + Precondition (..), + PreconditionUnmet (..), + Guard (..), + guardOf, + isGuarded, +) where + +import Control.Exception (SomeAsyncException, SomeException, fromException, throwIO, try) +import Data.Dynamic (Dynamic, fromDynamic, toDyn) +import Data.Maybe (isNothing) +import qualified Data.Text as Text + +import Salmon.Actions.UpDown (CheckResult (..)) +import Salmon.Builtin.Extension (Extension) +import qualified Salmon.Builtin.Extension as Extension +import Salmon.Op.Guard +import Salmon.Op.Ref (Ref) +import Salmon.Op.Supervision (Supervision (..), supervised, supervisionOf) + +-- | How an operation is guarded, beyond its preconditions. +data Guarding = Guarding + { guardingHolds :: [Ref] + -- ^ the nodes to hold still while the operation runs. See 'Guard'. + , guardingAttempts :: Int + -- ^ how many consecutive failures park the node. One, by default: an + -- operation that cannot be undone is not one to retry on a timer. + } + deriving (Show, Eq) + +-- | Holds nobody, parks at the first failure. +defaultGuarding :: Guarding +defaultGuarding = Guarding [] 1 + +{- | Guard a node. Apply it to the one node that is the risky operation, not +to an 'Salmon.Builtin.Extension.Op' through @fmap@ (which reaches its +dependencies too). + +The precondition action is run at @check@ and @up@ time, never at graph +build, and what it returns is public. If it throws, the preconditions count +as unmet: a probe that could not be asked is not a reason to start. + +The node keeps whatever 'Supervision' it declared, with only +'supGiveUpAfter' replaced. +-} +guarded :: Guarding -> IO Precondition -> Extension -> Extension +guarded g preconditions e = + e + { Extension.check = guardedCheck + , Extension.up = guardedUp + , Extension.dynamics = + supervised policy{supGiveUpAfter = Just (max 1 g.guardingAttempts)} + : toDyn (Guard g.guardingHolds) + : filter notSupervision (Extension.dynamics e) + } + where + (policy, _) = supervisionOf e + + notSupervision :: Dynamic -> Bool + notSupervision d = isNothing (fromDynamic d :: Maybe Supervision) + + ask :: IO Precondition + ask = do + answer <- try @SomeException preconditions + case answer of + Right p -> pure p + Left err + | Just (_ :: SomeAsyncException) <- fromException err -> throwIO err + | otherwise -> pure (Unmet ("could not be asked: " <> Text.pack (show err))) + + -- the effect being in place outranks the preconditions: an upgrade that + -- has happened is done whatever the cluster looks like now. + guardedCheck :: IO CheckResult + guardedCheck = do + verdict <- Extension.check e + case verdict of + Success -> pure verdict + Skipped -> pure verdict + Completed -> pure verdict + _ -> do + p <- ask + pure $ case p of + Met -> verdict + Unmet _ -> Unknown + + guardedUp :: IO () + guardedUp = do + p <- ask + case p of + Met -> Extension.up e + Unmet why -> throwIO (PreconditionUnmet why) diff --git a/src/Salmon/Builtin/NodeLog.hs b/src/Salmon/Builtin/NodeLog.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/NodeLog.hs @@ -0,0 +1,125 @@ +{- | A line a node says while it works: the per-node logging event. + +A node's 'Salmon.Builtin.Extension.up' is an @IO ()@. Whatever it has to say +before it returns — the output of the build it is running, "waiting for ssh", +"step 2 of 3" — has no way out through that type, and the drivers that call +it report only that it started and how it ended. This module is the way out: +a 'Line' names the node by its 'Ref', the 'Channel' it was said on and one +line of text, and 'emit' hands it to whoever is listening /now/, while the +node is still running. + += Why the listener is process-wide + +The listener is installed with 'withSink' and found through one process-wide +registry rather than passed to the node. Passing it would mean a new argument +to every @up@ in the tree (or a new 'Salmon.Builtin.Extension.Extension' +field every driver has to thread), for an event most nodes never emit; and a +recipe builds its nodes from a @directive -> Op@ that knows nothing of which +driver will run them. So the driver's side registers ("Salmon.Builtin.CommandLine" +does, for @run up@, @run down@ and @run serve@) and the node's side calls +'emit' or 'say' with nothing in hand but its own 'Ref'. + +Three properties that follow, and are relied on: + +* With no sink registered, 'emit' does nothing. A library user who never + registers one loses nothing they had. +* Several sinks can be registered at once and each sees every line (a test + suite running in one process is the case); a sink that cares about one + node filters by 'lineRef'. +* Lines are handed to the sinks one at a time, under one lock, so a sink + need not be thread-safe against other lines. It is /not/ serialised + against the drivers' own reports, which have their own locks; a sink that + writes to a handle should write each line in one call, as the reporters in + "Salmon.Reporter.Tagged" do. + +What is said here is public in the same sense report text is: it is printed, +sent to @\/events@ and to @--json@. A node must not say a secret, and a +command whose output can hold one must not be streamed (see +"Salmon.Builtin.Nodes.Binary"). +-} +module Salmon.Builtin.NodeLog ( + Channel (..), + renderChannel, + Line (..), + emit, + say, + withSink, +) where + +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Control.Exception (bracket) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import System.IO.Unsafe (unsafePerformIO) + +import Salmon.Op.Ref (Ref) +import Salmon.Reporter + +-- | Where a line came from. +data Channel + = -- | the standard output of a command the node ran + Stdout + | -- | the standard error of a command the node ran + Stderr + | -- | the node's own words (see 'say') + Message + deriving (Eq, Ord, Show) + +-- | @stdout@, @stderr@ or @message@: the spelling on the wire. +renderChannel :: Channel -> Text +renderChannel Stdout = "stdout" +renderChannel Stderr = "stderr" +renderChannel Message = "message" + +-- | One line, about one node. +data Line = Line + { lineRef :: !Ref + , lineChannel :: !Channel + , lineText :: !Text + -- ^ without its line terminator + } + deriving (Eq, Show) + +data Registry = Registry + { registryNext :: !Int + , registrySinks :: !(Map Int (Reporter Line)) + } + +{-# NOINLINE registry #-} +registry :: IORef Registry +registry = unsafePerformIO (newIORef (Registry 0 Map.empty)) + +{-# NOINLINE emitLock #-} +emitLock :: MVar () +emitLock = unsafePerformIO (newMVar ()) + +-- | Hand a line to every sink registered right now. +emit :: Line -> IO () +emit line = do + sinks <- registrySinks <$> readIORef registry + if Map.null sinks + then pure () + else withMVar emitLock $ \_ -> mapM_ (\r -> runReporter r line) (Map.elems sinks) + +{- | A node's own progress message: @say myRef "waiting for ssh"@. One call +is one line; text holding newlines is split so that every 'Line' is one. +-} +say :: Ref -> Text -> IO () +say r txt = mapM_ (emit . Line r Message) (if null ls then [""] else ls) + where + ls = Text.lines txt + +{- | Register a sink for as long as the action runs. Sinks registered by +other callers are left as they are, and this one is removed on the way out +however the action ends. +-} +withSink :: Reporter Line -> IO a -> IO a +withSink sink act = bracket add remove (const act) + where + add = atomicModifyIORef' registry $ \reg -> + (Registry (reg.registryNext + 1) (Map.insert reg.registryNext sink reg.registrySinks), reg.registryNext) + remove k = atomicModifyIORef' registry $ \reg -> + (reg{registrySinks = Map.delete k reg.registrySinks}, ()) diff --git a/src/Salmon/Builtin/Nodes/Binary.hs b/src/Salmon/Builtin/Nodes/Binary.hs --- a/src/Salmon/Builtin/Nodes/Binary.hs +++ b/src/Salmon/Builtin/Nodes/Binary.hs @@ -6,11 +6,32 @@ Command (..), withBinary, withBinaryStdin, + withBinaryStdinAtUp, untrackedExec, untrackedExecOutput, + + -- * Where a command's output goes + Sink (..), + Routing (..), + captured, + streamed, + streamedKeeping, + discarded, + appendedTo, + defaultTailBytes, + withBinaryWith, + withBinaryStdinWith, + LineTap, + plainLines, + withBinaryStdinTapped, + untrackedExecWith, + runRouted, + tailOf, CommandIO (..), withBinaryIO, untrackedExecIO, + detachedStdin, + execDetached, Report (..), pattern CommandSuccess, isCommandSuccessful, @@ -20,23 +41,34 @@ ) where import Salmon.Builtin.Extension +import Salmon.Builtin.NodeLog (Channel (..)) +import qualified Salmon.Builtin.NodeLog as NodeLog import Salmon.Builtin.Nodes.Filesystem +import Salmon.Op.Actions (Act (..)) 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 Control.Concurrent.Async (concurrently) +import Control.Exception (Exception, IOException, onException, throwIO, try) +import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as C8 import Data.ByteString (ByteString) +import Data.Foldable (toList) +import Data.Sequence (Seq, ViewL (..), (|>)) +import qualified Data.Sequence as Seq 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 GHC.TypeLits (Symbol) import GHC.IO.Handle (Handle) -import System.Process (ProcessHandle, createProcess) +import System.IO (IOMode (..), hClose, hIsEOF, openFile) +import qualified System.IO as IO +import System.Process (ProcessHandle, StdStream (..), createProcess, waitForProcess, withCreateProcess) import System.Process.ByteString (readCreateProcessWithExitCode) import System.Process.ListLike (CreateProcess (..), proc) @@ -46,6 +78,10 @@ = CommandStart !CreateProcess | CommandStopped !CreateProcess !ExitCode !ByteString !ByteString | Requested !(Maybe Act') !Report + | -- | One line a command wrote while running, under a 'Stream' sink + -- (see 'Routing'); never emitted by a command whose output is + -- 'captured', which is every command that does not ask otherwise. + CommandOutput !CreateProcess !Channel !ByteString deriving (Show) pattern CommandSuccess out err <- @@ -56,6 +92,7 @@ (CommandStart _) -> False (CommandStopped _ ExitSuccess _ _) -> True (CommandStopped _ _ _ _) -> False + (CommandOutput _ _ _) -> False (Requested _ child) -> isCommandSuccessful child ------------------------------------------------------------------------------- @@ -79,24 +116,99 @@ 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 +withBinary = withBinaryWith captured withBinaryStdin :: Track' (Binary x) -> Command x arg -> arg -> ByteString -> ((Reporter Report -> IO ()) -> Op) -> Op -withBinaryStdin t cmd arg stdin consumeIO = +withBinaryStdin = withBinaryStdinWith captured + +-- | 'withBinary' with a say in where the command's output goes; see 'Routing'. +withBinaryWith :: Routing -> Track' (Binary x) -> Command x arg -> arg -> ((Reporter Report -> IO ()) -> Op) -> Op +withBinaryWith routing t cmd arg consumeIO = + withBinaryStdinWith routing t cmd arg "" consumeIO + +{- | 'withBinaryStdin' with a say in where the command's output goes. + +Under a 'Stream' sink, each line the command writes is a +"Salmon.Builtin.NodeLog" line about the node the command is run by (the +enclosed 'Op'), emitted while the command is still running: that is what a +one-shot @run up@ prints, what @--json@ reports and what @run serve@ puts on +@\/events@. Those lines are /not/ also handed to the caller's 'Reporter', which +still gets 'CommandStart' and a 'CommandStopped' carrying the tail that was +kept: one line has one destination, and a recipe's reporter that prints +would otherwise print every line a second time. +-} +withBinaryStdinWith :: Routing -> Track' (Binary x) -> Command x arg -> arg -> ByteString -> ((Reporter Report -> IO ()) -> Op) -> Op +withBinaryStdinWith routing = withBinaryStdinTapped routing plainLines + +{- | What becomes of one line a streamed command wrote, before it is said +about the node: the channel it was read on and its text, to the lines to say +(none to drop it, several to split it). Pure on purpose: it runs on the two +threads reading the command's streams. + +It exists for a command whose output is another program's report stream +rather than prose -- a salmon run on another machine with @--json@, see +"Salmon.Builtin.Nodes.Self" -- where the line as written is not what a reader +of this node's log wants. It decides what is /said/ and nothing else: the +tail kept for 'CommandStopped' and 'CommandFailed' is the command's own +output, untouched. +-} +type LineTap = Channel -> Text -> [(Channel, Text)] + +-- | Every line said as it was written, on the channel it was written to. +plainLines :: LineTap +plainLines channel line = [(channel, line)] + +{- | 'withBinaryStdinWith' with a 'LineTap' between the command's streamed +lines and the node's log. Without a 'Stream' sink in the 'Routing' there are +no lines and the tap is never called. +-} +withBinaryStdinTapped :: Routing -> LineTap -> Track' (Binary x) -> Command x arg -> arg -> ByteString -> ((Reporter Report -> IO ()) -> Op) -> Op +withBinaryStdinTapped routing tap 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) + let mk a = (untrackedExecWith routing 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) + g r = f (nodeLogTap tap (opAct ret) (contramap (Requested (opAct ret)) r)) in consumeIO g ret = tracking t mk arg fconsume in ret +{- | 'withBinaryStdin' for a command whose stdin can only be made at @up@ +time: the enclosed 'Op' is handed a runner taking the bytes, and the +dependency on the binary is the same as 'withBinaryStdin''s. For bytes that +need fresh randomness on each application (a salted verifier, see +"Salmon.Builtin.Nodes.Postgres"), which a value fixed at graph build cannot +carry. Output is 'captured'. +-} +withBinaryStdinAtUp :: Track' (Binary x) -> Command x arg -> arg -> ((ByteString -> Reporter Report -> IO ()) -> Op) -> Op +withBinaryStdinAtUp t cmd arg consumeIO = + let mk a = (\stdin -> untrackedExecWith captured cmd a stdin, Binary) + fconsume :: (ByteString -> Reporter Report -> IO ()) -> Op + fconsume f = + consumeIO (\stdin r -> f stdin (nodeLogTap plainLines (opAct ret) (contramap (Requested (opAct ret)) r))) + ret = tracking t mk arg fconsume + in ret + +{- | Sends the lines of a streamed command to "Salmon.Builtin.NodeLog" under +the node's 'Ref' and everything else to the given reporter. With no node to +name, everything goes to the reporter. +-} +nodeLogTap :: LineTap -> Maybe Act' -> Reporter Report -> Reporter Report +nodeLogTap tap mact r = ReporterM $ \rep -> + case (mact, rep) of + (Just act, CommandOutput _ channel line) -> + mapM_ + (\(c, l) -> NodeLog.emit (NodeLog.Line act.extension.ref c l)) + (tap channel (decodeLine line)) + _ -> runReporter r rep + +decodeLine :: ByteString -> Text +decodeLine = Text.dropWhileEnd (== '\r') . Text.decodeUtf8With Text.lenientDecode + {- | 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 @@ -105,10 +217,17 @@ had succeeded. -} untrackedExec :: Command x a -> a -> ByteString -> (Reporter Report -> IO ()) -untrackedExec binary arg dat = \r -> do +untrackedExec = untrackedExecWith captured + +{- | 'untrackedExec' with a say in where the command's output goes. A +'Stream'ed line is reported as 'CommandOutput' when it is read; what +'CommandStopped' and 'CommandFailed' carry is what the 'Routing' kept. +-} +untrackedExecWith :: Routing -> Command x a -> a -> ByteString -> (Reporter Report -> IO ()) +untrackedExecWith routing binary arg dat = \r -> do let p = prepare binary arg runReporter r (CommandStart p) - (code, out, err) <- readCreateProcessWithExitCode p dat + (code, out, err) <- runRouted routing (\channel line -> runReporter r (CommandOutput p channel line)) p dat runReporter r (CommandStopped p code out err) case code of ExitSuccess -> pure () @@ -129,6 +248,174 @@ ExitSuccess -> pure out ExitFailure n -> throwIO (CommandFailed p n out err) +------------------------------------------------------------------------------- + +{- | Where one of a command's two output streams goes. + +The choice is the node author's, per command, and there is no global switch, +because the right answer depends on what the command prints: a build wants +to be followed while it runs, and a CLI that prints a token, or a @psql@ +that echoes the statement it failed on, must never be. +-} +data Sink + = {- | Held in memory, whole, until the command exits, and handed to the + final report. What every command did before there was a choice, and + still the default. + -} + Capture + | {- | Reported line by line as the command writes it, /and/ kept for the + final report — but only the last so many bytes of it (see 'tailOf'), + so that a build printing megabytes does not sit in memory until it + ends. Not for a command whose output can hold a secret: a streamed + line is public the moment it is read. + -} + Stream !Int + | -- | Sent to @\/dev\/null@. The final report carries nothing for it. + Discard + | {- | Appended to this file, which is created if missing. The final + report carries nothing for it; the file is the caller's to name, + rotate and protect. + -} + AppendTo !FilePath + deriving (Eq, Ord, Show) + +-- | A 'Sink' for each of the two streams. +data Routing = Routing + { stdoutTo :: !Sink + , stderrTo :: !Sink + } + deriving (Eq, Ord, Show) + +-- | Both streams 'Capture'd: the default, and what 'withBinary' and 'untrackedExec' do. +captured :: Routing +captured = Routing Capture Capture + +-- | Both streams 'Stream'ed, keeping 'defaultTailBytes' of each. +streamed :: Routing +streamed = streamedKeeping defaultTailBytes + +-- | Both streams 'Stream'ed, keeping this many bytes of each for the final report. +streamedKeeping :: Int -> Routing +streamedKeeping n = Routing (Stream n) (Stream n) + +-- | Both streams 'Discard'ed. +discarded :: Routing +discarded = Routing Discard Discard + +-- | Both streams appended to one file, in the order the command wrote them. +appendedTo :: FilePath -> Routing +appendedTo path = Routing (AppendTo path) (AppendTo path) + +-- | 64 KiB: what 'streamed' keeps of each stream. +defaultTailBytes :: Int +defaultTailBytes = 64 * 1024 + +{- | Run a process with its output routed, feeding it @dat@ on standard +input, and hand back its exit code with what each 'Sink' kept. The callback +is called once per line of a 'Stream'ed stream, from the thread reading that +stream, as the line is read; the two streams are read concurrently, so it +may be called from two threads at once. + +'captured' is exactly @readCreateProcessWithExitCode@, as before. Anything +else is run here: both pipes are drained /while/ the process runs (a process +that fills a pipe nobody reads blocks forever), a process that does not read +its standard input is not an error, and an exception — the node's thread +being cancelled — terminates the process on the way out +('withCreateProcess'). As with the captured form, whatever the caller's +'CreateProcess' said about its three standard streams is overridden. +-} +runRouted :: Routing -> (Channel -> ByteString -> IO ()) -> CreateProcess -> ByteString -> IO (ExitCode, ByteString, ByteString) +runRouted routing onLine p dat + | routing == captured = readCreateProcessWithExitCode p dat + | otherwise = + withStreams routing $ \outStream errStream -> + withCreateProcess p{std_in = CreatePipe, std_out = outStream, std_err = errStream} $ \mIn mOut mErr ph -> do + (out, (err, ())) <- + concurrently + (drain routing.stdoutTo Stdout mOut) + (concurrently (drain routing.stderrTo Stderr mErr) (feed mIn)) + code <- waitForProcess ph + pure (code, out, err) + where + -- a process that exits, or closes its standard input, without reading + -- all of it is not a failure of the command: its exit code is + feed :: Maybe Handle -> IO () + feed Nothing = pure () + feed (Just h) = do + _ <- try (ByteString.hPut h dat >> hClose h) :: IO (Either IOException ()) + _ <- try (hClose h) :: IO (Either IOException ()) + pure () + + drain :: Sink -> Channel -> Maybe Handle -> IO ByteString + drain _ _ Nothing = pure "" + drain sink channel (Just h) = case sink of + Stream keep -> streamLines keep channel h + _ -> ByteString.hGetContents h + + streamLines :: Int -> Channel -> Handle -> IO ByteString + streamLines keep channel h = go emptyTail + where + go acc = do + eof <- hIsEOF h + if eof + then pure (renderTail acc) + else do + line <- C8.hGetLine h + onLine channel line + go (pushTail keep line acc) + +-- | The 'StdStream' each sink asks of the process, with whatever file it +-- needs open for as long as the process runs. +withStreams :: Routing -> (StdStream -> StdStream -> IO a) -> IO a +withStreams routing k = + case (routing.stdoutTo, routing.stderrTo) of + -- one file, one handle: two handles on one path would be refused by + -- the runtime's own file locking, and would interleave badly anyway + (AppendTo a, AppendTo b) + | a == b -> IO.withFile a AppendMode $ \h -> k (UseHandle h) (UseHandle h) + (o, e) -> withStream o $ \outStream -> withStream e $ \errStream -> k outStream errStream + where + withStream :: Sink -> (StdStream -> IO a) -> IO a + withStream sink f = case sink of + Capture -> f CreatePipe + Stream _ -> f CreatePipe + Discard -> IO.withFile "/dev/null" WriteMode (f . UseHandle) + AppendTo path -> IO.withFile path AppendMode (f . UseHandle) + +-- | The last lines of a stream, and how many bytes they are. +data Tail = Tail !Int !(Seq ByteString) + +emptyTail :: Tail +emptyTail = Tail 0 Seq.empty + +{- | Add a line, then forget lines from the front until what is kept fits in +@keep@ bytes (each line counted with its newline). The newest line is never +forgotten whole: one longer than @keep@ is cut down to its last bytes. +-} +pushTail :: Int -> ByteString -> Tail -> Tail +pushTail keep line (Tail size ls) = trim (Tail (size + cost line) (ls |> line)) + where + cost l = ByteString.length l + 1 + trim t@(Tail n kept) + | n <= keep = t + | otherwise = case Seq.viewl kept of + EmptyL -> t + l :< rest + | Seq.null rest -> + let cut = ByteString.drop (ByteString.length l - max 0 (keep - 1)) l + in Tail (cost cut) (Seq.singleton cut) + | otherwise -> trim (Tail (n - cost l) rest) + +renderTail :: Tail -> ByteString +renderTail (Tail _ ls) = C8.unlines (toList ls) + +{- | What a 'Stream' sink keeping @keep@ bytes hands to the final report for +a stream made of these lines: the longest run of whole trailing lines that +fits, each ended by a newline. Pure, and what 'runRouted' does line by line. +-} +tailOf :: Int -> [ByteString] -> ByteString +tailOf keep = renderTail . foldl (flip (pushTail keep)) emptyTail + -- | Thrown by 'untrackedExec' (and so, transitively, by every node built on 'withBinary') on a non-zero exit. data CommandFailed = CommandFailed @@ -186,7 +473,54 @@ let mk a = (untrackedExecIO cmd a, Binary) in tracking t mk arg consumeIO +{- | Starts the command. A command that says nothing about its standard +input gets @\/dev\/null@, not this process's own (see 'detachedStdin'); one +that names a handle or asks for a pipe gets what it asked for. +-} untrackedExecIO :: CommandIO x a ioarg -> a -> (ioarg -> IO RunningCommand) untrackedExecIO binary arg = \ioarg -> do p <- prepareIO binary arg ioarg - createProcess p + detachedStdin p createProcess + +{- | Runs a process-starting action on the given 'CreateProcess' with its +standard input detached from this process's: where the process would +/inherit/ it ('Inherit', the default of 'proc'), it reads @\/dev\/null@ +instead. A 'CreateProcess' that names its own input ('UseHandle', +'CreatePipe', 'NoStream') is passed through untouched. + +No process started for a node may inherit the standard input of the pass +that runs it. Under @run serve@ that input is the command channel (a +terminal, a script, a fifo), so a child that prompts — a @gcloud@ asking +whether to enable an API, an @ssh@ asking about a host key — blocks the pass +with nothing in the reports saying a node is waiting on input, and competes +with the loop's own reader for the bytes: it can eat a @quit@, and a line +meant for the loop can answer its prompt. With @\/dev\/null@ a prompt reads +end-of-file at once and the command fails or takes its default. + +It is @\/dev\/null@ rather than a closed descriptor ('NoStream') because a +child whose descriptor 0 is closed hands that number to the next file it +opens. 'untrackedExec' and friends need none of this: they give the child a +pipe holding exactly the bytes the node passed, then close it. +-} +detachedStdin :: CreateProcess -> (CreateProcess -> IO a) -> IO a +detachedStdin p start = case std_in p of + Inherit -> do + devnull <- openFile "/dev/null" ReadMode + -- 'createProcess' closes a 'UseHandle' handle in this process once + -- the child has it; closing twice is harmless. + (start p{std_in = UseHandle devnull} <* hClose devnull) `onException` hClose devnull + _ -> start p + +{- | Runs a command the way salmon runs its own — an empty standard input +that is closed at once, a non-zero exit thrown as 'CommandFailed' — and hands +back its standard output. For an @up@ or a @check@ written outside this +library that would otherwise reach for 'System.Process.callProcess', which +inherits the pass's standard input (see 'detachedStdin' for why that must +not happen). +-} +execDetached :: CreateProcess -> IO ByteString +execDetached p = do + (code, out, err) <- readCreateProcessWithExitCode p "" + case code of + ExitSuccess -> pure out + ExitFailure n -> throwIO (CommandFailed p n out err) diff --git a/src/Salmon/Builtin/Nodes/ClipCpp.hs b/src/Salmon/Builtin/Nodes/ClipCpp.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/ClipCpp.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | @clip.cpp@ (a ggml port of CLIP), so that __text and images__ are turned +into vectors of the same space and of one @vector(N)@ column +("Salmon.Builtin.Nodes.PgVector"): searching images by a sentence, or by +another image, is then a distance query. The text-only counterpart, with a +server, is "Salmon.Builtin.Nodes.LlamaServer". + +Nodes, in dependency order: 'clipBuild' (a pinned commit, compiled), the +model ('clipModel', a GGUF file with a pinned sha256), and 'clipCpp' on top, +which is satisfied when the two together produce vectors of the declared +width. There is no server: clip.cpp is a command per input, and 'embed' is +the function a loader calls. + +__Nothing here was compiled or run.__ What follows was read from the +upstream sources at 'knownCommit', and the code is shaped by it: + +* There is no release binary. The build is @git clone --recurse-submodules@, + @cmake -DCLIP_NATIVE=ON@, @make@, with the binaries in @build\/bin@. The + ggml submodule is recorded in the commit, so pinning the commit pins it. +* The binary that writes vectors is @extract@. Its arguments are + @-m \@, @-t \@, @-v \@ and any number of + @--text \@ and @--image \@. It has no @--version@. +* It does not print a vector: it writes @.\/text_vec_\.npy@ and + @.\/img_vec_\.npy@ __into its current directory__, as NumPy 1.0 + files holding a @(1, N)@ array of little-endian 32-bit floats. +* __It exits 0 when it could not read an image or tokenize a text__ (it + prints and moves to the next input). So 'embed' never trusts the exit code: + it runs @extract@ in a directory of its own with one input and wants the + one file. +* The vectors are not normalised (@extract@ asks for none). Use a cosine + distance (@\<=\>@, @vector_cosine_ops@), or normalise before storing. +* The README still says images are resized by linear interpolation; since + June 2025 the source resamples bicubically and crops the centre. An + embedding is therefore only comparable with ones made by the same commit + and the same model, which is why both are pinned and why the build's + 'ClipSource' is part of 'ClipCpp'. +* @-DCLIP_NATIVE=ON@ is @-march=native@: the binary is for the machine that + built it. Turning it off still leaves upstream's default @-mavx2@, @-mfma@ + and @-mf16c@ on x86. + += The checks + +'clipBuild' cannot ask the binary which commit it is, so it leaves a stamp +next to it once the build has succeeded, naming the commit, the remote and +the options, and its @check@ compares that. A changed pin is a changed +stamp, and the build directory is removed before building again. + +'clipCpp' embeds a fixed string, and an image when one is given (upstream +ships @tests\/white.jpg@), and compares both lengths with 'ccDimension', the +way the llama-server node does: a model of another width would make every +later insert fail. + += What is public + +The text given to 'embed' is on @extract@'s command line, where any user of +the machine can read it. Do not embed a secret. +-} +module Salmon.Builtin.Nodes.ClipCpp ( + Report (..), + + -- * The build + ClipSource (..), + upstreamRemote, + knownCommit, + clipSourceAt, + ClipTools (..), + debianTools, + clipBuild, + clipBuildCheck, + clipExtractBinary, + + -- * The model + ModelFile (..), + clipModel, + laionViTB32, + + -- * Vectors + ClipCpp (..), + defaultClipCpp, + clipCpp, + clipCheck, + Input (..), + embed, + pgvectorLiteral, + + -- * Pieces, exposed for tests + validCommit, + fetchArgs, + configureArgs, + compileArgs, + buildStamp, + stampPath, + extractArgs, + outputName, + parseNpy, + interpretVectors, +) where + +import Control.Exception (bracket) +import Control.Monad (forM_, unless, when) +import Data.Bits (shiftL, (.|.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import Data.Char (isHexDigit) +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.Word (Word32) +import GHC.Float (castWord32ToFloat) +import GHC.IO.Exception (ExitCode (..)) +import System.Directory ( + doesDirectoryExist, + doesFileExist, + getTemporaryDirectory, + makeAbsolute, + removeDirectoryRecursive, + renameFile, + ) +import System.FilePath (takeFileName, ()) +import System.Posix.Temp (mkdtemp) +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) +import qualified Salmon.Builtin.Nodes.Binary as Binary +import qualified Salmon.Builtin.Nodes.Debian.Package as Debian +import Salmon.Builtin.Nodes.Filesystem (Directory (..), dir) +import Salmon.Builtin.Nodes.LlamaServer (ModelFile (..), dimensionNote, ggufModel) +import Salmon.Op.Ref +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- + +data Report + = Fetching !ClipSource !Binary.Report + | Building !ClipSource !Binary.Report + deriving (Show) + +------------------------------------------------------------------------------- + +{- | What is built, and where. 'clipDir' gets a @src@ (the checkout) and a +@build@ directory, both this node's own. +-} +data ClipSource = ClipSource + { clipRemote :: Text + , clipCommit :: Text + -- ^ a full object name (40 or 64 hex digits). A branch or a tag is not a + -- pin and is refused. + , clipDir :: FilePath + , clipNative :: Bool + -- ^ @-DCLIP_NATIVE@, i.e. @-march=native@ (upstream's default is on) + , clipJobs :: Maybe Int + -- ^ parallel compile jobs; one at a time when 'Nothing' + } + deriving (Eq, Show) + +upstreamRemote :: Text +upstreamRemote = "https://github.com/monatis/clip.cpp.git" + +{- | The commit whose sources this module was written against (the tip of +upstream's @main@ in October 2026). Read, not built. +-} +knownCommit :: Text +knownCommit = "913458d5d1c9238380a0b0826cd1e71c8828a82d" + +-- | 'knownCommit' from upstream, native, one job, in this directory. +clipSourceAt :: FilePath -> ClipSource +clipSourceAt d = ClipSource upstreamRemote knownCommit d True Nothing + +{- | Where the tools come from. The compiler and @make@ are found by @cmake@ +on its own, so they are a plain node and not a binary anything here calls. +-} +data ClipTools = ClipTools + { toolGit :: Track' (Binary "git") + , toolCmake :: Track' (Binary "cmake") + , toolCompiler :: Op + } + +-- | @git@, @cmake@ and @build-essential@ from Debian's packages. +debianTools :: ClipTools +debianTools = + ClipTools + (Track $ \_ -> Debian.deb (Debian.Package "git")) + (Track $ \_ -> Debian.deb (Debian.Package "cmake")) + (Debian.deb (Debian.Package "build-essential")) + +-- | Where @extract@ is after 'clipBuild'. +clipExtractBinary :: ClipSource -> FilePath +clipExtractBinary src = buildDir src "bin" "extract" + +sourceDir, buildDir, stampPath :: ClipSource -> FilePath +sourceDir src = src.clipDir "src" +buildDir src = src.clipDir "build" +stampPath src = buildDir src "salmon-clip-cpp.stamp" + +-- | A full object name: nothing a remote can move. +validCommit :: Text -> Bool +validCommit c = Text.length c `elem` [40, 64] && Text.all isHexDigit c + +{- | The @git@ arguments that put the pinned commit, and the submodules it +records, in 'clipDir'@\/src@. Every step can be run again: @init@ on an +existing repository changes nothing, and the checkout is forced because the +directory is nobody's to edit. The commit is fetched by name with no history; +the submodules are fetched whole, since a shallow clone of one may not hold +the commit the superproject wants. +-} +fetchArgs :: ClipSource -> [[String]] +fetchArgs src = + [ ["init", "--quiet", sourceDir src] + , inSrc ["fetch", "--depth", "1", Text.unpack src.clipRemote, commit] + , inSrc ["checkout", "--quiet", "--detach", "--force", commit] + , inSrc ["submodule", "update", "--init", "--recursive", "--force"] + ] + where + commit = Text.unpack src.clipCommit + inSrc args = ["-C", sourceDir src] <> args + +{- | @cmake@'s configure step. Upstream's tests (a benchmark over an image +set) are left out; the examples, where @extract@ is, are on by default. +-} +configureArgs :: ClipSource -> [String] +configureArgs src = + [ "-S" + , sourceDir src + , "-B" + , buildDir src + , "-DCLIP_NATIVE=" <> (if src.clipNative then "ON" else "OFF") + , "-DCLIP_BUILD_TESTS=OFF" + ] + +-- | Only the @extract@ target and what it needs. +compileArgs :: ClipSource -> [String] +compileArgs src = + ["--build", buildDir src, "--target", "extract"] + <> maybe [] (\n -> ["--parallel", show n]) src.clipJobs + +-- | What the build leaves behind once it has succeeded, and what @check@ wants to find. +buildStamp :: ClipSource -> Text +buildStamp src = + Text.unlines + [ "clip.cpp " <> src.clipCommit + , "from " <> src.clipRemote + , Text.unwords (Text.pack <$> drop 4 (configureArgs src)) + ] + +{- | Fetch the pinned commit and compile @extract@, as one node: the steps in +between are nobody's to depend on. @down@ removes the checkout and the build +directory, and leaves 'clipDir'. +-} +clipBuild :: Reporter Report -> ClipTools -> ClipSource -> Op +clipBuild r tools src = + op "clip-cpp-build" (deps [dir (Directory src.clipDir), Binary.justInstall tools.toolGit, Binary.justInstall tools.toolCmake, tools.toolCompiler]) $ \actions -> + actions + { help = "builds clip.cpp " <> Text.take 12 src.clipCommit <> " in " <> Text.pack src.clipDir + , notes = ["pinned commit: " <> src.clipCommit, "from " <> src.clipRemote] <> ["built for this machine's CPU (-march=native)" | src.clipNative] + , ref = mkRef "clip-cpp-build" src.clipDir + , check = clipBuildCheck src + , up = do + unless (validCommit src.clipCommit) $ + ioError (userError ("clip.cpp must be pinned to a full commit id, not " <> show src.clipCommit)) + stamp <- readStamp src + when (stamp /= Just (buildStamp src)) $ removeIfThere (buildDir src) + forM_ (fetchArgs src) $ \args -> + Binary.untrackedExec gitCommand args "" (contramap (Fetching src) r) + forM_ [configureArgs src, compileArgs src] $ \args -> + Binary.untrackedExecWith Binary.streamed cmakeCommand args "" (contramap (Building src) r) + built <- doesFileExist (clipExtractBinary src) + unless built $ + ioError (userError ("the build succeeded and left no " <> clipExtractBinary src)) + let part = stampPath src <> ".part" + ByteString.writeFile part (Text.encodeUtf8 (buildStamp src)) + renameFile part (stampPath src) + , down = removeIfThere (buildDir src) >> removeIfThere (sourceDir src) + } + where + removeIfThere d = do + there <- doesDirectoryExist d + when there (removeDirectoryRecursive d) + +-- | The stamp is the one this declaration would leave, and the binary is there. +clipBuildCheck :: ClipSource -> IO CheckResult +clipBuildCheck src = do + stamp <- readStamp src + there <- doesFileExist (clipExtractBinary src) + pure $ case (stamp, there) of + (Nothing, _) -> Failure ("no build of clip.cpp in " <> Text.pack src.clipDir) + (Just s, _) | s /= buildStamp src -> Failure "the build is of another commit or of other options" + (_, False) -> Failure ("no binary at " <> Text.pack (clipExtractBinary src)) + _ -> Success + +readStamp :: ClipSource -> IO (Maybe Text) +readStamp src = do + there <- doesFileExist (stampPath src) + if there then Just . decode <$> ByteString.readFile (stampPath src) else pure Nothing + +gitCommand :: Binary.Command "git" [String] +gitCommand = Binary.Command (proc "git") + +cmakeCommand :: Binary.Command "cmake" [String] +cmakeCommand = Binary.Command (proc "cmake") + +------------------------------------------------------------------------------- + +{- | A GGUF model with a pinned sha256: "Salmon.Builtin.Nodes.LlamaServer"'s +model node under a kind of its own. For text and images together it has to be +a two-tower file, not one of the @text-model@ or @vision-model@ ones. +-} +clipModel :: ModelFile -> Op +clipModel = ggufModel "clip-model" + +{- | LAION's CLIP ViT-B\/32, 16-bit floats, two towers, as converted for +clip.cpp by the Hugging Face repository @mys\/ggml_CLIP-ViT-B-32-laion2B-s34B-b79K@ +(tagged @clip-cpp-gguf@), at that repository's revision @26ebd3e1@. The +sha256 is the one the hub lists for the file (304 MB); __the file was never +downloaded, hashed or loaded here__, and that a file converted in September +2023 loads with 'knownCommit' is not verified. ViT-B\/32 projects to 512 +dimensions. +-} +laionViTB32 :: FilePath -> ModelFile +laionViTB32 path = + ModelFile + path + "8140b294ed52b960e4fe6c1f17dfc25bd36086b2744eaa242fd42ed98a4f6499" + (Just "https://huggingface.co/mys/ggml_CLIP-ViT-B-32-laion2B-s34B-b79K/resolve/26ebd3e1648320e965df9e69ca01963d144cb380/CLIP-ViT-B-32-laion2B-s34B-b79K_ggml-model-f16.gguf") + +------------------------------------------------------------------------------- + +-- | A build and a model, and the width of what they produce together. +data ClipCpp = ClipCpp + { ccSource :: ClipSource + , ccModel :: ModelFile + , ccDimension :: Int + -- ^ what the model must produce, i.e. the @vector(N)@ it feeds + , ccThreads :: Maybe Int + -- ^ @-t@; upstream's default (4) when 'Nothing' + , ccProbeImage :: Maybe FilePath + -- ^ an image the check embeds, so the vision tower is checked too + } + deriving (Eq, Show) + +-- | Upstream's thread count, and upstream's own @tests\/white.jpg@ as the image the check embeds. +defaultClipCpp :: ClipSource -> ModelFile -> Int -> ClipCpp +defaultClipCpp src model dim = + ClipCpp src model dim Nothing (Just (sourceDir src "tests" "white.jpg")) + +{- | The build and the model, producing vectors of the declared width: depend +on this to depend on something 'embed' can be called on. It applies nothing +of its own, so its @up@ is the check again, failing with what it found. +-} +clipCpp :: Reporter Report -> ClipTools -> ClipCpp -> Op +clipCpp r tools c = + op "clip-cpp" (deps [clipBuild r tools c.ccSource, clipModel c.ccModel]) $ \actions -> + actions + { help = "clip.cpp produces " <> tshow c.ccDimension <> "-dimensional vectors for text and images" + , notes = maybe [] pure (dimensionNote c.ccDimension) + , ref = mkRef "clip-cpp" (c.ccSource.clipDir, c.ccModel.modelPath) + , check = clipCheck c + , up = do + verdict <- clipCheck c + case verdict of + Success -> pure () + Failure why -> ioError (userError ("clip.cpp is not producing the declared vectors: " <> Text.unpack why)) + _ -> ioError (userError "clip.cpp could not be checked") + } + +-- | Embed a fixed string, and the probe image if there is one, and compare the lengths with the declared one. +clipCheck :: ClipCpp -> IO CheckResult +clipCheck c = do + text <- embed c (EmbedText "salmon") + image <- traverse (embed c . EmbedImage) c.ccProbeImage + pure (interpretVectors c.ccDimension text image) + +{- | The verdict from the two probes. Either tower failing, or either having +another width than declared, is a 'Failure' naming it. +-} +interpretVectors :: Int -> Either Text [Float] -> Maybe (Either Text [Float]) -> CheckResult +interpretVectors dim text image = + case (width "text" text, maybe (Right ()) (width "image") image) of + (Left why, _) -> Failure why + (_, Left why) -> Failure why + _ -> Success + where + width what (Left why) = Left (what <> ": " <> why) + width what (Right v) + | length v == dim = Right () + | otherwise = Left ("the model produces " <> tshow (length v) <> " dimensions for " <> what <> ", " <> tshow dim <> " declared") + +------------------------------------------------------------------------------- + +data Input + = -- | on the command line, hence public + EmbedText Text + | -- | jpg, png or gif, by path + EmbedImage FilePath + deriving (Eq, Show) + +-- | The arguments after the binary, for one input. +extractArgs :: ClipCpp -> Input -> [String] +extractArgs c input = + mconcat + [ ["-m", c.ccModel.modelPath, "-v", "0"] + , maybe [] (\n -> ["-t", show n]) c.ccThreads + , case input of + EmbedText t -> ["--text", Text.unpack t] + EmbedImage p -> ["--image", p] + ] + +-- | The file @extract@ writes in its current directory for this input, given alone. +outputName :: Input -> FilePath +outputName (EmbedText _) = "text_vec_0.npy" +outputName (EmbedImage p) = "img_vec_" <> takeFileName p <> ".npy" + +{- | The vector of one text or one image, or why there is none. @extract@ is +run in a fresh directory that is removed afterwards, with nothing on its +standard input, and the file it leaves there is the answer: a zero exit code +with no file is a failure. One process, and one load of the model, per call. +-} +embed :: ClipCpp -> Input -> IO (Either Text [Float]) +embed c input0 = do + input <- case input0 of + EmbedImage p -> EmbedImage <$> makeAbsolute p + t -> pure t + binaryThere <- doesFileExist binary + modelThere <- doesFileExist c.ccModel.modelPath + case (binaryThere, modelThere) of + (False, _) -> pure (Left ("no binary at " <> Text.pack binary)) + (_, False) -> pure (Left ("no model at " <> Text.pack c.ccModel.modelPath)) + _ -> do + tmp <- getTemporaryDirectory + bracket (mkdtemp (tmp "salmon-clip-cpp-")) removeDirectoryRecursive $ \scratch -> do + (code, out, err) <- readCreateProcessWithExitCode ((proc binary (extractArgs c input)){cwd = Just scratch}) "" + let said = Text.takeEnd 500 (Text.strip (decode out <> "\n" <> decode err)) + vector = scratch outputName input + written <- doesFileExist vector + case code of + ExitFailure n -> pure (Left ("extract exited with " <> tshow n <> ": " <> said)) + ExitSuccess + | not written -> pure (Left ("extract wrote no vector: " <> said)) + | otherwise -> parseNpy <$> ByteString.readFile vector + where + binary = clipExtractBinary c.ccSource + +{- | The one row of a NumPy 1.0 file as @extract@ writes it: the magic, the +version, a 16-bit header length, a header saying @\ Either Text [Float] +parseNpy bytes = do + unless (ByteString.take 6 bytes == "\x93NUMPY") (Left "not a NumPy file") + unless (ByteString.length bytes >= 10) (Left "the NumPy header is cut short") + unless (ByteString.index bytes 6 == 1 && ByteString.index bytes 7 == 0) (Left "not a version 1.0 NumPy file") + let headerLen = fromIntegral (ByteString.index bytes 8) + 256 * fromIntegral (ByteString.index bytes 9) + header = decode (ByteString.take headerLen (ByteString.drop 10 bytes)) + payload = ByteString.drop (10 + headerLen) bytes + unless ("'descr': ' 0 -> + Right k + _ -> Left "not a (1, N) array" + unless (ByteString.length payload == 4 * n) $ + Left ("the header announces " <> tshow n <> " floats and " <> tshow (ByteString.length payload) <> " bytes follow") + let values = float <$> chunks payload + unless (all finite values) (Left "the vector holds a value that is not finite") + pure values + where + chunks b + | ByteString.null b = [] + | otherwise = ByteString.take 4 b : chunks (ByteString.drop 4 b) + float b = castWord32ToFloat (ByteString.foldr (\byte acc -> (acc `shiftL` 8) .|. fromIntegral byte) (0 :: Word32) b) + finite x = not (isNaN x || isInfinite x) + +-- | A vector as pgvector reads one: @[0.25,-1.0e-2]@. +pgvectorLiteral :: [Float] -> Text +pgvectorLiteral v = "[" <> Text.intercalate "," (tshow <$> v) <> "]" + +------------------------------------------------------------------------------- + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show + +decode :: ByteString -> Text +decode = Text.decodeUtf8With TextError.lenientDecode diff --git a/src/Salmon/Builtin/Nodes/Daemon.hs b/src/Salmon/Builtin/Nodes/Daemon.hs --- a/src/Salmon/Builtin/Nodes/Daemon.hs +++ b/src/Salmon/Builtin/Nodes/Daemon.hs @@ -99,6 +99,7 @@ import System.Process (CreateProcess (..), Pid, ProcessHandle, StdStream (..), createProcess, getPid, getProcessExitCode, waitForProcess) import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.Binary as Binary import Salmon.Op.Ref (Ref, mkRef) import Salmon.Op.Supervision (Micros (..), millis, seconds) import Salmon.Reporter @@ -220,7 +221,9 @@ spawn :: IO (Maybe Handle, Maybe Handle, ProcessHandle, Maybe Pid) spawn = do - (_, mout, merr, ph) <- createProcess cp + -- never the supervisor's own standard input: under @serve@ that is + -- the command channel, and a service reading it would eat commands. + (_, mout, merr, ph) <- Binary.detachedStdin cp createProcess pid <- getPid ph runReporter r (Spawned name pid) pure (mout, merr, ph, pid) diff --git a/src/Salmon/Builtin/Nodes/Debian/AptRepository.hs b/src/Salmon/Builtin/Nodes/Debian/AptRepository.hs --- a/src/Salmon/Builtin/Nodes/Debian/AptRepository.hs +++ b/src/Salmon/Builtin/Nodes/Debian/AptRepository.hs @@ -90,6 +90,7 @@ import Salmon.Builtin.Extension import Salmon.Builtin.Nodes.Filesystem (FileContents (..), checkFileContents, removeFileIfPresent) import qualified Salmon.Builtin.Nodes.Binary as Binary +import Salmon.Builtin.Nodes.Debian.Package (recordingAptIndexRefresh) import Salmon.Op.Ref import Salmon.Op.Track (Track (..)) @@ -410,8 +411,11 @@ where filterExisting = fmap concat . traverse (\p -> (\e -> [p | e]) <$> doesFileExist p) +-- Under the lock "Salmon.Builtin.Nodes.Debian.Package"'s index node takes: +-- a @deb@ installed from this repository depends on both nodes, in no order, +-- and two @apt-get update@s at once fail each other on apt's lists lock. runAptUpdate :: IO () -runAptUpdate = do +runAptUpdate = recordingAptIndexRefresh $ do (code, _out, err) <- readCreateProcessWithExitCode (proc "apt-get" ["update", "-q"]) "" case code of ExitSuccess -> pure () diff --git a/src/Salmon/Builtin/Nodes/Debian/Package.hs b/src/Salmon/Builtin/Nodes/Debian/Package.hs --- a/src/Salmon/Builtin/Nodes/Debian/Package.hs +++ b/src/Salmon/Builtin/Nodes/Debian/Package.hs @@ -11,6 +11,7 @@ import qualified Salmon.Op.Rewrite as Rewrite import Salmon.Reporter +import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar) import Data.Dynamic (toDyn) import Data.Foldable (toList) import qualified Data.List as List @@ -20,8 +21,10 @@ import Data.Set (Set) import Data.Text (Text) import qualified Data.Text as Text +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) import GHC.IO.Exception (ExitCode (..)) import System.Environment (getEnvironment) +import System.IO.Unsafe (unsafePerformIO) import System.Process.ByteString (readCreateProcessWithExitCode) import System.Process.ListLike (CreateProcess, env, proc) import qualified Data.Text.Encoding as Text @@ -36,6 +39,8 @@ -- | 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) + | -- | the index refresh, on behalf of these packages + AptUpdate !(NEList.NonEmpty Package) | AptRemove !(NEList.NonEmpty Package) deriving (Show) @@ -51,7 +56,7 @@ -- | 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 -> + op "deb" (deps [aptIndexWith r pkgs]) $ \actions -> actions { help = "installs " <> pkg.pkgName , ref = mkRef "debian-deb" pkg.pkgName @@ -78,7 +83,7 @@ -- | 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 -> + op "debs" (deps [aptIndexWith r dedupedPkgs]) $ \actions -> actions { help = "installs " <> Text.pack (show (length pkgset)) <> " packages" , notes = pkgName <$> toList pkgset @@ -103,6 +108,194 @@ downAction = Binary.untrackedExec aptUninstallCommand dedupedPkgs "" (contramap (RunAptGet (AptRemove dedupedPkgs)) r) +------------------------------------------------------------------------------- + +{- | What an 'aptIndex' node carries on @dynamics@: the packages it makes sure +apt has heard of. 'batchPackages' collects these the way it collects +'Package's, so a batched graph refreshes the index once. +-} +newtype AptIndexFor = AptIndexFor [Package] + deriving (Eq, Ord, Show) + +{- | The apt index knowing how to install these packages: the node 'deb' and +'debs' depend on, and the reason they work on a machine whose index has never +been refreshed. + +A fresh cloud image boots with whatever index the image was built with -- +often none, or @main@ without @universe@ -- and @apt-get install@ then fails +with "has no installation candidate" for some packages and succeeds for +others, on one machine in one state. So before any install, this node asks +whether apt has a /candidate/ for each package and runs @apt-get update@ when +it does not. + += When it does nothing + +The check ('checkAptIndex') is satisfied, and @apt-get update@ is not run, +when either holds: + +* every package is __already installed__ ('checkPackagesInstalled') -- an + index is only needed to install something, and this is what keeps a graph + naming packages it already has runnable as an ordinary user; +* @apt-cache policy@ reports a __candidate__ for every one of them. That is + the case on any machine whose index is in ordinary use, so there an install + costs one @apt-cache@ call more than it did and no refresh. + +Note what it is /not/: a freshness guarantee. An index that knows an old +version of a package is good enough to install that package, and "track the +latest" is no more this node's job than it is 'deb''s. + += Virtual names and names nobody has + +@apt-cache policy@ says @Candidate: (none)@ for a purely virtual package +(@ssh-client@) even on a fresh index, and nothing at all for a name it has +never heard of. Neither can be told from "the index is stale", so both cost +one refresh -- after which this node has done all it can, and whether the +name installs is 'deb''s to report, with apt's own message. To keep a +supervisor from re-running @apt-get update@ at its delay floor over such a +name, a refresh this process ran less than 'aptIndexFreshFor' ago satisfies +the check whatever @apt-cache@ says. + += Concurrency + +Refreshes are serialised inside the process, and the question is asked again +under the lock: of twenty of these becoming ready at once on a fresh machine +(which @run serve@ does, without 'batchPackages'), one runs @apt-get update@ +and nineteen find their candidates. Another /process/ holding apt's lists +lock still fails the command, and the node with it. + += Beside an external repository + +A @deb@ given a "Salmon.Builtin.Nodes.Debian.AptRepository" has that node and +this one as two dependencies with no order between them. The repository's own +@apt-get update@ goes through 'recordingAptIndexRefresh', so the two never run +at once and a refresh by either answers for both. Where this node happens to +go first for a package only the repository carries, it runs one refresh that +finds nothing -- once, on the pass that adds the repository. + += down + +Nothing. A refreshed index is not something to take back. +-} +aptIndex :: NEList.NonEmpty Package -> Op +aptIndex = aptIndexWith silent + +-- | Like 'aptIndex', but takes a 'Reporter' to observe the @apt-get update@. +aptIndexWith :: Reporter Report -> NEList.NonEmpty Package -> Op +aptIndexWith r pkgs = + op "apt-index" nodeps $ \actions -> + actions + { help = "refreshes apt's package lists unless they already offer " <> describe names + , notes = names + , ref = mkRef "debian-apt-index" names + , up = refreshAptIndex r dedupedPkgs + , check = checkAptIndex dedupedPkgs + , dynamics = [toDyn (AptIndexFor (toList dedupedPkgs))] + } + where + dedupedPkgs :: NEList.NonEmpty Package + dedupedPkgs = NEList.fromList (Set.toList (Set.fromList (toList pkgs))) + names :: [Text] + names = pkgName <$> toList dedupedPkgs + describe [one] = one + describe many = Text.pack (show (length many)) <> " packages" + +-- | How long a refresh run by this process answers for: see 'aptIndex'. +aptIndexFreshFor :: NominalDiffTime +aptIndexFreshFor = 3600 + +{- | When this process last ran @apt-get update@ successfully, and the lock +that serialises doing so. Process-global because the thing it guards is: there +is one apt index per machine, however many nodes and graphs ask after it. +-} +aptIndexRefreshed :: MVar (Maybe UTCTime) +aptIndexRefreshed = unsafePerformIO (newMVar Nothing) +{-# NOINLINE aptIndexRefreshed #-} + +{- | Run something that refreshes the apt index -- an @apt-get update@ -- with +no other such refresh of this process running, and remember that it happened. +For any node that refreshes the index on its own account. +-} +recordingAptIndexRefresh :: IO () -> IO () +recordingAptIndexRefresh act = + modifyMVar_ aptIndexRefreshed $ \_ -> act >> (Just <$> getCurrentTime) + +refreshedRecently :: Maybe UTCTime -> IO Bool +refreshedRecently Nothing = pure False +refreshedRecently (Just at) = do + now <- getCurrentTime + pure (diffUTCTime now at < aptIndexFreshFor) + +checkAptIndex :: NEList.NonEmpty Package -> IO CheckResult +checkAptIndex pkgs = do + recent <- refreshedRecently =<< readMVar aptIndexRefreshed + checkAptIndexGiven recent pkgs + +checkAptIndexGiven :: Bool -> NEList.NonEmpty Package -> IO CheckResult +checkAptIndexGiven recent pkgs = do + installed <- checkPackagesInstalled pkgs + case installed of + Success -> pure Success + _ -> do + baseEnv <- getEnvironment + -- LC_ALL=C: "Candidate:" is a translated string. + (code, out, _err) <- + readCreateProcessWithExitCode + (proc "apt-cache" ("policy" : names)){env = Just (("LC_ALL", "C") : filter ((/= "LC_ALL") . fst) baseEnv)} + "" + pure $ interpretAptPolicy recent (fmap Text.pack names) code (Text.decodeUtf8 out) + where + names = [Text.unpack pkg.pkgName | pkg <- toList pkgs] + +{- | The verdict drawn from @apt-cache policy NAME...@, split out for +testability. The first argument is whether this process refreshed the index +recently, in which case there is nothing more a refresh could do. + +@apt-cache policy@ and not @apt-cache show@: the latter succeeds for a name +another package merely refers to. A name with no stanza at all, or one whose +stanza says @Candidate: (none)@, has no candidate. +-} +interpretAptPolicy :: Bool -> [Text] -> ExitCode -> Text -> CheckResult +interpretAptPolicy _ _ (ExitFailure _) _ = + -- could not ask; not evidence either way. + Unknown +interpretAptPolicy recent wanted ExitSuccess out = + case filter (not . (`Set.member` candidates)) wanted of + [] -> Success + missing + | recent -> Success + | otherwise -> Failure ("no installation candidate in the apt index for: " <> Text.intercalate ", " missing) + where + candidates :: Set Text + candidates = Set.fromList (go Nothing (Text.lines out)) + + go :: Maybe Text -> [Text] -> [Text] + go _ [] = [] + go current (line : rest) + -- a stanza opens with "name:" at column 0; everything under it is indented + | Just name <- Text.stripSuffix ":" line + , not (Text.null name) + , not (Text.isPrefixOf " " line) = + go (Just name) rest + | Just name <- current + , Just value <- Text.stripPrefix "Candidate:" (Text.strip line) + , Text.strip value /= "(none)" + , not (Text.null (Text.strip value)) = + name : go Nothing rest + | otherwise = go current rest + +refreshAptIndex :: Reporter Report -> NEList.NonEmpty Package -> IO () +refreshAptIndex r pkgs = + modifyMVar_ aptIndexRefreshed $ \lastRefresh -> do + -- asked again under the lock: whoever held it may have just done this. + recent <- refreshedRecently lastRefresh + verdict <- checkAptIndexGiven recent pkgs + case verdict of + Success -> pure lastRefresh + _ -> do + baseEnv <- getEnvironment + Binary.untrackedExec (aptUpdateCommand baseEnv) () "" (contramap (RunAptGet (AptUpdate pkgs)) r) + Just <$> getCurrentTime + {- | 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 @@ -136,6 +329,12 @@ 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. +The 'aptIndex' nodes those @deb@ nodes depend on are collected the same way, +into one node asking after every wanted package at once, which the install +batch then depends on (it inherits its members' dependencies). Only the +wanted ones: an index node has nothing to do on the way down, so the rest are +left as declared. + 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 @@ -143,8 +342,27 @@ -} batchPackages :: Reporter Report -> Rewrite Extension batchPackages r phase computed = - edge . batchOf "installs" installRef wanted . batchOf "removes" removeRef unwanted $ computed + edge . batchOf "installs" installRef wanted . batchOf "removes" removeRef unwanted . batchIndex $ computed where + -- the index nodes of whatever is wanted up, as one node. + batchIndex :: Rewritten Extension -> Rewritten Extension + batchIndex c + | Just pkgs <- NEList.nonEmpty (Set.toList (Set.fromList (concat [ps | (_, fors) <- indexes, AptIndexFor ps <- fors]))) + , Just act <- opAct (aptIndexWith r pkgs) = + Rewrite.introduce + act{extension = act.extension{ref = mkRef "debian-apt-index-batch" (pkgName <$> toList pkgs)}} + (Set.fromList (fmap fst indexes)) + c + | otherwise = c + + indexes :: [(Ref, [AptIndexFor])] + indexes = + [ (aref, fors) + | (aref, fors) <- Rewrite.collectDynamic computed + , not (Set.member aref phase.phaseIgnored) + , Set.member aref phase.phaseDesired + ] + -- (ref, the packages that node declares) for every deb node this -- traversal is allowed to touch. declared :: [(Ref, [Package])] @@ -313,6 +531,10 @@ where args :: [String] args = ["install", "-y", "-q"] <> [Text.unpack pkg.pkgName | pkg <- toList pkgs] + +aptUpdateCommand :: [(String, String)] -> Binary.Command "apt-get" () +aptUpdateCommand baseEnv = + Binary.Command $ \() -> (proc "apt-get" ["update", "-q"]){env = Just (("DEBIAN_FRONTEND", "noninteractive") : baseEnv)} aptUninstallCommand :: Binary.Command "apt-get" (NEList.NonEmpty Package) aptUninstallCommand = Binary.Command aptUninstallProcess diff --git a/src/Salmon/Builtin/Nodes/Deferred.hs b/src/Salmon/Builtin/Nodes/Deferred.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/Deferred.hs @@ -0,0 +1,131 @@ +{- | A sub-graph that can only be built once a value is known, where the +value is something another node's @up@ produces. + +An 'Op' is built before any @up@ runs. So when what a node needs is picked by +somebody else during the pass -- the address GCP hands out when a reservation +is created, the name servers of a zone, a port a service chose -- there is no +value to build the node from at declaration, and the usual answer is two +passes with a driver carrying the value across. + +'deferred' is the other answer: the node that is declared holds a /read/ and +a /recipe/, and its @up@ does the read, builds the sub-graph from what it +found, and runs that as a nested walk. Put it after the node that produces +the value (with 'Salmon.Op.OpGraph.inject') and one pass does both. + +It is the shape "SreBox.PostgresTemplate" and "SreBox.PostgresMigrations" +already use for a build that must not be an ordinary dependency, with the +graph a function of something read first. What it costs is the same, and +worth knowing before reaching for it: + +* __The sub-graph is opaque.__ @run tree@, @run dag@, @query@, a + 'Salmon.Op.Rewrite.Rewrite', @run serve@'s per-node state and the status + sink all see one node. Its nodes are not deduplicated against the outer + graph's and take no part in its ordering or failure containment beyond + this node failing as a whole. +* __Put only what needs the value in it.__ @down@ tears the whole sub-graph + down, so a node that is also declared outside it (a project, an API, the + very node that produces the value) would be taken down here, under + everything else still standing on it. Declare those outside and 'inject' + them into this node instead. +* __The read runs on every @up@ and every @down@__, never at declaration. +* __No @check@.__ The node answers 'Salmon.Actions.UpDown.Immaterial': its + @up@ always runs the nested walk, which asks each inner node's own + @check@, so a converged sub-graph costs its checks and nothing else. Under + @run serve@ that means the node parks after its pass and the inner nodes + are not tended. +-} +module Salmon.Builtin.Nodes.Deferred ( + Deferred (..), + deferred, + Report (..), + Unresolved (..), + NestedWalkFailed (..), +) where + +import Control.Exception (Exception, throwIO) +import Control.Monad (unless) +import Control.Monad.Identity (runIdentity) +import Data.Dynamic (toDyn) +import Data.Text (Text) +import qualified Data.Text as Text + +import qualified Salmon.Actions.Dot as Dot +import qualified Salmon.Actions.UpDown as UpDown +import Salmon.Builtin.Extension +import Salmon.Op.Ref (mkRef) +import Salmon.Reporter + +data Report + = -- | the read answered; the sub-graph is about to be walked up. + ResolvedUp !Text + | -- | the read answered; the sub-graph is about to be walked down. + ResolvedDown !Text + | -- | a @down@ whose read found nothing: there is nothing this node can + -- name, so nothing is torn down. + NothingToTearDown !Text + | Nested !Text !(UpDown.Report Extension) + deriving (Show) + +-- | The read found nothing when the sub-graph was to be brought up. +newtype Unresolved = Unresolved Text + deriving (Show) + +instance Exception Unresolved + +-- | The nested walk reported a failure; the outer one learns it from this. +data NestedWalkFailed = NestedWalkFailed !Text !Text + deriving (Show) + +instance Exception NestedWalkFailed + +data Deferred a = Deferred + { deferredName :: Text + -- ^ identifies the declaration: the 'Salmon.Op.Ref.Ref' key. + , deferredHelp :: Text + -- ^ what the sub-graph does, for @run tree@ (which cannot look inside). + , deferredRead :: IO (Maybe a) + -- ^ the value, read when the node runs. 'Nothing' when it is not there + -- (yet): an @up@ then fails, naming 'deferredName', rather than build a + -- graph from a guess; a @down@ does nothing. + , deferredGraph :: a -> Op + -- ^ everything that needs the value, and nothing that does not. + } + +{- | The node. It has no dependencies of its own: 'Salmon.Op.OpGraph.inject' +the node whose @up@ makes 'deferredRead' answer, and whatever else the +sub-graph stands on. + +A @down@ whose read finds nothing is a no-op that says so +('NothingToTearDown'), not a failure. The common case is tearing down a +graph that never came up, where there is indeed nothing; the uncommon one is +a value removed behind salmon's back, and then nothing here could name what +to remove anyway. Either way a failure would only block the teardown of the +nodes underneath. +-} +deferred :: Reporter Report -> Deferred a -> Op +deferred r d = + op "deferred" nodeps $ \actions -> + actions + { help = d.deferredHelp + , notes = ["built and walked at up, from a value read then"] + , ref = mkRef "deferred" d.deferredName + , up = do + found <- d.deferredRead + case found of + Nothing -> throwIO (Unresolved d.deferredName) + Just a -> do + runReporter r (ResolvedUp d.deferredName) + ok <- UpDown.upTree nested (pure . runIdentity) (d.deferredGraph a) + unless ok (throwIO (NestedWalkFailed d.deferredName "up")) + , down = do + found <- d.deferredRead + case found of + Nothing -> runReporter r (NothingToTearDown d.deferredName) + Just a -> do + runReporter r (ResolvedDown d.deferredName) + ok <- UpDown.downTree nested (pure . runIdentity) (d.deferredGraph a) + unless ok (throwIO (NestedWalkFailed d.deferredName "down")) + , dynamics = [toDyn (Dot.OpaqueNode ("deferred " <> Text.take 40 d.deferredName))] + } + where + nested = contramap (Nested d.deferredName) r diff --git a/src/Salmon/Builtin/Nodes/Detached.hs b/src/Salmon/Builtin/Nodes/Detached.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/Detached.hs @@ -0,0 +1,547 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | A process that outlives the @run up@ that started it. + +__You rarely need this node.__ The preferred way to keep a process running +is @run serve@ with a @managed@ node ("Salmon.Builtin.Nodes.Daemon"): salmon +then owns the process, notices when it exits, and restarts it under its +supervision policy. Failing that, a unit manager ("Salmon.Builtin.Nodes.Systemd") +does the same job. Reach for 'detached' only in the rare situation where +neither is available and a one-shot @run up@ must leave a process behind; +nothing watches it once that @run up@ has exited. + +"Salmon.Builtin.Nodes.Daemon" owns its process from a thread that never +returns, so only @run serve@ can hold one, and its @up@ throws +'Salmon.Builtin.Nodes.Daemon.NeedsSupervisor' on purpose. +"Salmon.Builtin.Nodes.Systemd" hands the problem to systemd. This is for +the case with neither: a developer's rig, a test bench, a machine without +a unit manager, where a one-shot @run up@ starts a server and exits and a +later @run down@ (another process) stops it. + += What @up@ does + +Starts the command in a __new session__ (so it leads its own process group +and has no controlling terminal), with standard input from @\/dev\/null@ +(never the pass's own, see 'Binary.detachedStdin'), standard output and +error appended to 'detached_logFile', every other descriptor closed +(@close_fds@), an optional working directory and an environment overlay. +Then it writes 'detached_pidFile'. salmon does not wait for the process; +when the starting binary exits, init (or the nearest subreaper) adopts it. +Under @run serve@ the process stays salmon's child, and a thread reaps it +when it exits so no zombie piles up. + +Readiness is not this node's business: put a +'Salmon.Builtin.Nodes.Readiness.waitUntil' after it. + += Identity, not a pid + +@specs\/per-node-state-machines.md@ lists the pidfile convention as a +non-goal because a pidfile plus @kill -0@ cannot survive pid reuse. This +node does not trust the pid on its own. The pid file records, next to the +pid, three facts taken when the process was started: + +* its start time, in clock ticks since boot (@\/proc\/PID\/stat@ field 22), + which a later process reusing the pid cannot share; +* the boot id (@\/proc\/sys\/kernel\/random\/boot_id@), so a pid file that + survived a reboot proves nothing; +* the argv salmon started it with, which must equal @\/proc\/PID\/cmdline@. + +A process is __ours__ only when all three still hold and it is not a +zombie. Nothing is ever signalled otherwise: a pid file naming a process +that is not ours is /forgotten/ (removed, reported 'Forgot'), never acted +upon. The cost is that a program that rewrites its own argv (a process +title, as @postgres@ or @nginx@ workers do) is never recognised as ours; +such a program is not for this node. + += @check@ + +'Success' when the pid file names a process that is ours and was started +with the declared argv and working directory (and, with +'detached_restartOnReplacedBinary', whose executable has not been replaced +on disk). 'Failure' otherwise, with the reason: no pid file, not ours any +more, or ours but declared differently. + += Stopping + +The configured signal (@SIGTERM@ by default) to the process group, a grace +period, then @SIGKILL@ and a second grace period, checking identity again +before each signal. @down@ throws if the process is still there after +that. @down@ removes the pid file in every case it does not throw. + += Linux only + +It reads @\/proc@. +-} +module Salmon.Builtin.Nodes.Detached ( + -- * The node + Detached (..), + defaultDetached, + detached, + detachedRef, + + -- * How it stops (shared with "Salmon.Builtin.Nodes.Daemon") + Stop (..), + defaultStop, + + -- * Observing + Report (..), + StillRunning (..), + + -- * The parts, for tests and nodes building on this one + PidRecord (..), + readPidFile, + renderPidFile, + parsePidFile, + Identity (..), + identify, + Verdict (..), + judge, + parseStat, + stopRecorded, +) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (Exception, SomeException, throwIO, try) +import Control.Monad (void) +import Data.Aeson ((.:), (.:?), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson (parseMaybe) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import GHC.Clock (getMonotonicTimeNSec) +import System.Directory (doesFileExist, removeFile, renameFile) +import System.Environment (getEnvironment) +import System.FilePath (takeDirectory, takeFileName, ()) +import System.IO (IOMode (..), hClose, openFile) +import System.Posix.Files (readSymbolicLink) +import System.Posix.Signals (Signal, sigKILL, signalProcess, signalProcessGroup) +import System.Posix.Types (CPid (..)) +import System.Process (CreateProcess (..), StdStream (..), createProcess, getPid, proc, waitForProcess) +import Text.Read (readMaybe) + +import Salmon.Actions.UpDown (CheckResult (..)) +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.Binary as Binary +import Salmon.Builtin.Nodes.Daemon (Stop (..), defaultStop) +import Salmon.Op.Ref (Ref, mkRef) +import Salmon.Op.Supervision (Micros (..), millis) +import Salmon.Reporter + +------------------------------------------------------------------------------- + +data Detached = Detached + { detached_name :: !Text + -- ^ names it in reports, and is its 'Ref' key. + , detached_command :: !FilePath + -- ^ the executable, as argv[0]: identity compares argv as given, so a + -- bare name found on @PATH@ is fine as long as it stays the same. + , detached_args :: ![String] + , detached_cwd :: !(Maybe FilePath) + , detached_env :: ![(String, String)] + -- ^ added to (and overriding) salmon's own environment, read at @up@ + -- time. Values never appear in @help@, @notes@ or the pid file; only + -- names do (in @notes@). + , detached_pidFile :: !FilePath + -- ^ its directory must exist (a directory is its own node). + , detached_logFile :: !FilePath + -- ^ standard output and error, appended. Its directory must exist. + , detached_stop :: !Stop + , detached_restartOnReplacedBinary :: !Bool + -- ^ 'check' also fails when @\/proc\/PID\/exe@ reads @(deleted)@: the + -- executable was rebuilt or upgraded under the running process, and + -- @up@ then replaces it. + } + +-- | No cwd, no env overlay, 'defaultStop', replaced binaries tolerated. +defaultDetached :: Text -> FilePath -> [String] -> FilePath -> FilePath -> Detached +defaultDetached name cmd args pidFile logFile = + Detached + { detached_name = name + , detached_command = cmd + , detached_args = args + , detached_cwd = Nothing + , detached_env = [] + , detached_pidFile = pidFile + , detached_logFile = logFile + , detached_stop = defaultStop + , detached_restartOnReplacedBinary = False + } + +detachedRef :: Detached -> Ref +detachedRef d = mkRef "detached" d.detached_name + +argvOf :: Detached -> [String] +argvOf d = d.detached_command : d.detached_args + +data Report + = Started !Text !Int + | -- | a pid file named a process that is not ours: removed, nothing signalled + Forgot !Text !Text + | -- | ours, but declared differently (or replaced on disk): stopping it to start anew + Replacing !Text !Text + | Signalling !Text !Int !Signal + | Killing !Text !Int + | Stopped !Text !Int + | -- | the pid file was there, its process gone on its own + AlreadyGone !Text !Int + deriving (Show) + +-- | Thrown by @down@ (and by @up@ when replacing) when the process survived @SIGKILL@. +data StillRunning = StillRunning !Text !Int + deriving (Show) + +instance Exception StillRunning + +------------------------------------------------------------------------------- + +-- | What the pid file says. +data PidRecord = PidRecord + { pr_pid :: !Int + , pr_start :: !Integer + -- ^ @\/proc\/PID\/stat@ field 22 when started + , pr_boot :: !Text + , pr_argv :: ![String] + , pr_cwd :: !(Maybe FilePath) + } + deriving (Show, Eq) + +{- | Line one is the pid alone, so @kill $(head -1 FILE)@ habits keep working +(and stay as unsafe as they always were). Line two is a JSON object with the +rest. +-} +renderPidFile :: PidRecord -> BS.ByteString +renderPidFile r = + BS8.pack (show r.pr_pid) + <> "\n" + <> LBS.toStrict + ( Aeson.encode $ + Aeson.object + [ "start" .= r.pr_start + , "boot" .= r.pr_boot + , "argv" .= r.pr_argv + , "cwd" .= r.pr_cwd + ] + ) + <> "\n" + +{- | 'Nothing' for anything this module did not write, including a bare pid: +a pid alone proves nothing, so it is never signalled. +-} +parsePidFile :: BS.ByteString -> Maybe PidRecord +parsePidFile bs = case BS8.lines bs of + (pidLine : jsonLine : _) -> do + pid <- readMaybe (BS8.unpack pidLine) + (start, boot, argv, cwd) <- + Aeson.decodeStrict jsonLine + >>= Aeson.parseMaybe + ( Aeson.withObject "pid record" $ \o -> + (,,,) <$> o .: "start" <*> o .: "boot" <*> o .: "argv" <*> o .:? "cwd" + ) + pure (PidRecord pid start boot argv cwd) + _ -> Nothing + +-- | 'Nothing' when there is no pid file; @Just Nothing@ when it is not ours to read. +readPidFile :: FilePath -> IO (Maybe (Maybe PidRecord)) +readPidFile path = do + exists <- doesFileExist path + if not exists + then pure Nothing + else do + r <- try @SomeException (BS.readFile path) + pure (Just (either (const Nothing) parsePidFile r)) + +writePidFile :: FilePath -> PidRecord -> IO () +writePidFile path r = do + let tmp = takeDirectory path ("." <> takeFileName path <> ".tmp") + BS.writeFile tmp (renderPidFile r) + renameFile tmp path + +forget :: FilePath -> IO () +forget path = void (try @SomeException (removeFile path)) + +------------------------------------------------------------------------------- + +-- | What @\/proc@ says about a pid now. +data Identity = Identity + { id_start :: !Integer + , id_pgrp :: !Int + , id_zombie :: !Bool + , id_argv :: ![String] + , id_boot :: !Text + , id_exeDeleted :: !Bool + } + deriving (Show, Eq) + +-- | 'Nothing' when there is no such process (or @\/proc@ will not say). +identify :: Int -> IO (Maybe Identity) +identify pid = do + r <- try @SomeException $ do + stat <- BS.readFile (procDir "stat") + cmdline <- BS.readFile (procDir "cmdline") + boot <- readBootId + exe <- try @SomeException (readSymbolicLink (procDir "exe")) + pure (stat, cmdline, boot, exe) + pure $ case r of + Left _ -> Nothing + Right (stat, cmdline, boot, exe) -> do + (state, pgrp, start) <- parseStat stat + pure + Identity + { id_start = start + , id_pgrp = pgrp + , id_zombie = state == 'Z' || state == 'X' + , id_argv = splitCmdline cmdline + , id_boot = boot + , id_exeDeleted = either (const False) (" (deleted)" `Text.isSuffixOf`) (Text.pack <$> exe) + } + where + procDir = "/proc" show pid + +readBootId :: IO Text +readBootId = Text.strip . Text.decodeUtf8 <$> BS.readFile "/proc/sys/kernel/random/boot_id" + +{- | State, process group and start time. The command name (field 2) is in +parentheses and may hold spaces and parentheses itself, so split after the +/last/ closing one. +-} +parseStat :: BS.ByteString -> Maybe (Char, Int, Integer) +parseStat bs = do + let (_, rest) = BS8.breakEnd (== ')') bs + -- fields from 3 on: index 0 is field 3. + let fields = BS8.words rest + state <- case fields of + (s : _) | not (BS.null s) -> Just (BS8.head s) + _ -> Nothing + pgrp <- at 2 fields >>= readMaybe . BS8.unpack + start <- at 19 fields >>= readMaybe . BS8.unpack + pure (state, pgrp, start) + where + at n xs = case drop n xs of + (x : _) -> Just x + [] -> Nothing + +splitCmdline :: BS.ByteString -> [String] +splitCmdline bs = + map (Text.unpack . Text.decodeUtf8Lenient) $ + case BS.split 0 bs of + -- the trailing NUL leaves one empty piece + xs | not (null xs) && BS.null (last xs) -> init xs + xs -> xs + +------------------------------------------------------------------------------- + +data Verdict + = -- | no pid file + NoRecord + | -- | the pid file names nothing we can prove we started + NotOurs !Text + | -- | ours, as declared + Running !PidRecord + | -- | ours, but not as declared now (argv, cwd, or a replaced executable) + Drifted !PidRecord !Text + deriving (Show, Eq) + +-- | Read the pid file and @\/proc@, and say what is there. Signals nothing. +judge :: Detached -> IO Verdict +judge d = do + mrec <- readPidFile d.detached_pidFile + case mrec of + Nothing -> pure NoRecord + Just Nothing -> pure (NotOurs "the pid file is not one this node wrote") + Just (Just rec) -> do + ours <- isOurs rec + case ours of + Left why -> pure (NotOurs why) + Right ident + | rec.pr_argv /= argvOf d -> pure (Drifted rec "started with another command line") + | rec.pr_cwd /= d.detached_cwd -> pure (Drifted rec "started in another directory") + | d.detached_restartOnReplacedBinary && ident.id_exeDeleted -> + pure (Drifted rec "its executable was replaced on disk") + | otherwise -> pure (Running rec) + +-- | The identity check: every fact recorded at start still holds. +isOurs :: PidRecord -> IO (Either Text Identity) +isOurs rec = do + mident <- identify rec.pr_pid + pure $ case mident of + Nothing -> Left ("no process " <> pidText) + Just ident + | ident.id_zombie -> Left ("process " <> pidText <> " has exited") + | ident.id_boot /= rec.pr_boot -> Left "the pid file is from an earlier boot" + | ident.id_start /= rec.pr_start -> Left ("process " <> pidText <> " is another process (start time differs)") + | ident.id_argv /= rec.pr_argv -> Left ("process " <> pidText <> " is another process (command line differs)") + | otherwise -> Right ident + where + pidText = Text.pack (show rec.pr_pid) + +------------------------------------------------------------------------------- + +{- | A detached process, for the rare case with no @run serve@ and no unit +manager. Prefer a @managed@ node under @run serve@ +("Salmon.Builtin.Nodes.Daemon") to keep a process running; see the module +header. +-} +detached :: Reporter Report -> Detached -> Op +detached r d = + op "detached" nodeps $ \actions -> + actions + { help = "keeps " <> d.detached_name <> " running, detached" + , notes = + [ "rarely needed: prefer `run serve` with a managed node (Daemon) to keep a process running" + , "argv: " <> Text.pack (show (argvOf d)) + , "cwd: " <> maybe "(inherited)" Text.pack d.detached_cwd + , "env names: " <> Text.pack (show (map fst d.detached_env)) + , "pid file: " <> Text.pack d.detached_pidFile + , "log file: " <> Text.pack d.detached_logFile + ] + <> ["restarts when its executable is replaced on disk" | d.detached_restartOnReplacedBinary] + , ref = detachedRef d + , check = do + v <- judge d + pure $ case v of + Running _ -> Success + NoRecord -> Failure "no pid file" + NotOurs why -> Failure why + Drifted _ why -> Failure why + , up = upDetached r d + , down = downDetached r d + } + +upDetached :: Reporter Report -> Detached -> IO () +upDetached r d = do + v <- judge d + case v of + Running _ -> pure () + NoRecord -> start + NotOurs why -> do + runReporter r (Forgot d.detached_name why) + forget d.detached_pidFile + start + Drifted rec why -> do + runReporter r (Replacing d.detached_name why) + stopRecorded r d.detached_name d.detached_stop rec + forget d.detached_pidFile + start + where + start = do + overlayEnv <- + if null d.detached_env + then pure Nothing + else do + current <- getEnvironment + let names = map fst d.detached_env + pure (Just (d.detached_env <> filter ((`notElem` names) . fst) current)) + logH <- openFile d.detached_logFile AppendMode + let cp = + (proc d.detached_command d.detached_args) + { cwd = d.detached_cwd + , env = overlayEnv + , std_out = UseHandle logH + , std_err = UseHandle logH + , new_session = True + , close_fds = True + } + -- createProcess closes the UseHandle in this process; a second close + -- is harmless. + (_, _, _, ph) <- Binary.detachedStdin cp createProcess + hClose logH + mpid <- getPid ph + -- Under `serve` this process lives on and the child stays its own: + -- reap it when it exits, or it lingers as a zombie (which identity + -- already reads as gone). + _ <- forkIO (void (try @SomeException (waitForProcess ph))) + case mpid of + Nothing -> fail ("detached: " <> Text.unpack d.detached_name <> " exited before its pid could be read") + Just (CPid p) -> do + let pid = fromIntegral p + mident <- identify pid + boot <- readBootId + case mident of + Nothing -> fail ("detached: " <> Text.unpack d.detached_name <> " exited at once; see " <> d.detached_logFile) + Just ident -> + writePidFile d.detached_pidFile $ + PidRecord + { pr_pid = pid + , pr_start = ident.id_start + , pr_boot = boot + , pr_argv = argvOf d + , pr_cwd = d.detached_cwd + } + runReporter r (Started d.detached_name pid) + +downDetached :: Reporter Report -> Detached -> IO () +downDetached r d = do + mrec <- readPidFile d.detached_pidFile + case mrec of + Nothing -> pure () + Just Nothing -> do + runReporter r (Forgot d.detached_name "the pid file is not one this node wrote") + forget d.detached_pidFile + Just (Just rec) -> do + ours <- isOurs rec + case ours of + Left why -> do + runReporter r (Forgot d.detached_name why) + forget d.detached_pidFile + Right _ -> do + stopRecorded r d.detached_name d.detached_stop rec + forget d.detached_pidFile + +{- | Stop the process a pid record names, re-proving identity before each +signal. Returns once it is gone (or was never ours); throws 'StillRunning' +if it survives @SIGKILL@ and the second grace period. +-} +stopRecorded :: Reporter Report -> Text -> Stop -> PidRecord -> IO () +stopRecorded r name stop rec = do + sent <- signalIfOurs stop.stop_signal + if not sent + then runReporter r (AlreadyGone name pid) + else do + runReporter r (Signalling name pid stop.stop_signal) + gone <- waitGone stop.stop_grace + if gone + then runReporter r (Stopped name pid) + else do + runReporter r (Killing name pid) + _ <- signalIfOurs sigKILL + gone' <- waitGone stop.stop_grace + if gone' + then runReporter r (Stopped name pid) + else throwIO (StillRunning name pid) + where + pid = rec.pr_pid + cpid = CPid (fromIntegral pid) + + signalIfOurs :: Signal -> IO Bool + signalIfOurs sig = do + ours <- isOurs rec + case ours of + Left _ -> pure False + Right ident -> do + -- the group, when it still leads the one it was started + -- with (new_session), so the workers it forked go too. + void . try @SomeException $ + if ident.id_pgrp == pid + then signalProcessGroup sig cpid + else signalProcess sig cpid + pure True + + waitGone :: Micros -> IO Bool + waitGone grace = do + deadline <- (+ toNanos grace) <$> getMonotonicTimeNSec + let go = do + ours <- isOurs rec + case ours of + Left _ -> pure True + Right _ -> do + now <- getMonotonicTimeNSec + if now >= deadline + then pure False + else threadDelay (unMicros (millis 20)) >> go + go + toNanos (Micros n) = fromIntegral n * 1000 diff --git a/src/Salmon/Builtin/Nodes/Etcd.hs b/src/Salmon/Builtin/Nodes/Etcd.hs --- a/src/Salmon/Builtin/Nodes/Etcd.hs +++ b/src/Salmon/Builtin/Nodes/Etcd.hs @@ -17,7 +17,9 @@ 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. +start with @existing@) is the /join/ phase, 'etcdJoinMember': 'joinGuard' +asks the running members, adds this one to the list if it is not there yet, +and the config it writes says @initial-cluster-state: existing@. 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 @@ -92,12 +94,24 @@ ------------------------------------------------------------------------------- -{- | The config file etcd reads with @--config-file@. Always the seed phase: +-- | Which phase of a cluster's life a member is started in. +data Phase = Seed | Join + deriving (Eq, Show) + +phaseState :: Phase -> Text +phaseState Seed = "new" +phaseState Join = "existing" + +{- | The config file etcd reads with @--config-file@, in 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 = +renderConfig = renderConfigFor Seed + +-- | The config for a phase; only @initial-cluster-state@ differs. +renderConfigFor :: Phase -> EtcdConfig -> Text +renderConfigFor phase cfg = Text.unlines [ "name: " <> self.member_name , "data-dir: " <> Text.pack cfg.etcd_data_dir @@ -106,7 +120,7 @@ , "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-state: " <> phaseState phase , "initial-cluster-token: " <> cfg.etcd_cluster_token , "client-transport-security:" , " trusted-ca-file: " <> Text.pack cfg.etcd_client_tls.tls_ca @@ -150,6 +164,8 @@ data EtcdctlCall = EndpointHealth TlsFiles Text | MemberList TlsFiles Text + | MemberAdd TlsFiles Text Member + -- ^ against this endpoint, add this member deriving (Show) etcdctl :: Command "etcdctl" EtcdctlCall @@ -157,6 +173,8 @@ 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"]) + go (MemberAdd tls ep m) = + proc "etcdctl" (common tls ep <> ["member", "add", Text.unpack m.member_name, "--peer-urls=" <> Text.unpack m.member_peer_url]) common :: TlsFiles -> Text -> [String] common tls ep = [ "--endpoints=" <> Text.unpack ep @@ -280,19 +298,82 @@ bootstrapped <- isBootstrapped cfg pure (if bootstrapped then Success else Failure "data directory holds no member yet") , up = do - answers <- mapM ask others + answers <- mapM (askOther cfg) 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)) +------------------------------------------------------------------------------- + +-- | Thrown when a join finds no running member to join. +newtype NoClusterToJoin = NoClusterToJoin Text + deriving (Eq) + +instance Show NoClusterToJoin where + show (NoClusterToJoin who) = + "etcd: no other member answered, so there is no running cluster for " + <> Text.unpack who + <> " to join; seed the cluster first (starting it with existing would never elect anyone)" + +instance Exception NoClusterToJoin + +-- | What the join phase does next, given what the other members said. +data JoinStep + = -- | already in the member list (added earlier, perhaps never started): just start + AlreadyListed + | -- | ask this member to add us + AddVia Member + deriving (Eq, Show) + +{- | The join decision, pure. Nobody answering is refused (nothing to join). +Somebody answering and listing us means the add was already done; the first +answerer not listing us is the one to add through. +-} +joinDecision :: Member -> [(Member, Maybe [Listed])] -> Either NoClusterToJoin JoinStep +joinDecision self answers = + case [(m, ls) | (m, Just ls) <- answers] of + [] -> Left (NoClusterToJoin self.member_name) + ((m, ls) : _) + | self.member_peer_url `elem` concatMap (.listed_peer_urls) ls -> Right AlreadyListed + | otherwise -> Right (AddVia m) + +{- | Guards and performs the join: @etcdctl member add@ through a running +member, idempotently. Satisfied when the data directory already holds a member +(a restart), or when the cluster already lists this member's peer URL. Throws +'NoClusterToJoin' when no other member answers, and lets a failing @member +add@ throw (the unit must not start on a failed add). +-} +joinGuard :: Track' (Binary "etcdctl") -> EtcdConfig -> Op +joinGuard etcdctlBin cfg = + op "etcd-join-guard" (deps [justInstall etcdctlBin]) $ \actions -> + actions + { help = "adds this member to the running cluster (member add) before it starts with existing" + , notes = ["skipped when the data directory already holds a member"] + , ref = mkRef "etcd-join-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 (askOther cfg) others + step <- either throwIO pure (joinDecision cfg.etcd_self answers) + case step of + AlreadyListed -> pure () + AddVia m -> + Binary.untrackedExec etcdctl (MemberAdd cfg.etcd_client_tls m.member_client_url cfg.etcd_self) "" silent + , down = pure () + } + where + others = filter (/= cfg.etcd_self) cfg.etcd_cluster + +askOther :: EtcdConfig -> Member -> IO (Member, Maybe [Listed]) +askOther cfg 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") @@ -314,11 +395,35 @@ Track' (Binary "etcdctl") -> EtcdConfig -> Op -etcdMember r systemctl etcdBin etcdctlBin cfg = +etcdMember = etcdMemberIn Seed + +{- | A member joining a running cluster: the same node as 'etcdMember' with the +join guard (@member add@) in place of the seed guard and +@initial-cluster-state: existing@ in the config. @etcdctl@ is run against the +other declared members, so at least one must be up. +-} +etcdJoinMember :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Track' (Binary "etcd") -> + Track' (Binary "etcdctl") -> + EtcdConfig -> + Op +etcdJoinMember = etcdMemberIn Join + +etcdMemberIn :: + Phase -> + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Track' (Binary "etcd") -> + Track' (Binary "etcdctl") -> + EtcdConfig -> + Op +etcdMemberIn phase 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"] + , notes = ["v3 API only", "phase: " <> phaseState phase] , ref = mkRef "etcd-member" cfg.etcd_self.member_peer_url , check = checkMember cfg , up = waitHealthy cfg @@ -332,11 +437,15 @@ prereqs = op "etcd-setup" - (deps [justInstall etcdBin, justInstall etcdctlBin, datadir, configFile, seedGuard etcdctlBin cfg]) + (deps [justInstall etcdBin, justInstall etcdctlBin, datadir, configFile, guard]) id + guard = case phase of + Seed -> seedGuard etcdctlBin cfg + Join -> joinGuard etcdctlBin cfg + datadir = FS.dir (FS.Directory cfg.etcd_data_dir) - configFile = FS.filecontents (FS.FileContents cfg.etcd_config_file (renderConfig cfg)) + configFile = FS.filecontents (FS.FileContents cfg.etcd_config_file (renderConfigFor phase cfg)) -- | Polls until the member's check passes; throws 'NotHealthy' (with the last reason) at the deadline. waitHealthy :: EtcdConfig -> IO () diff --git a/src/Salmon/Builtin/Nodes/Filesystem.hs b/src/Salmon/Builtin/Nodes/Filesystem.hs --- a/src/Salmon/Builtin/Nodes/Filesystem.hs +++ b/src/Salmon/Builtin/Nodes/Filesystem.hs @@ -15,7 +15,10 @@ import qualified Data.Text.Encoding as Text import qualified Crypto.Hash.SHA256 as SHA256 import Data.Bits ((.&.)) +import Control.Exception (IOException, try) import Control.Monad (when) +import Data.List (isPrefixOf) +import System.IO.Error (isDoesNotExistError) import Data.Time (defaultTimeLocale, formatTime, getCurrentTime) import Numeric (showOct) import qualified System.Posix.Files as Posix @@ -23,7 +26,7 @@ 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.OpGraph (OpGraph (..), inject) import Salmon.Op.Supervision (defaultSupervision, supReapply, supervised) import Salmon.Op.Track import System.Directory @@ -94,6 +97,240 @@ where path :: FilePath path = directory.directoryPath + +{- | A directory that is not salmon's alone: a system directory a package +ships and fills (@\/etc\/haproxy@, @\/etc\/sudoers.d@, @\/etc\/pgbouncer@, +an nginx @conf.d@), or one something else also writes into (a +pre-provisioned credentials file next to a rendered config). Created if +missing, like 'dir'; left alone by @down@. + +'dir''s @down@ refuses a non-empty directory on purpose, so a file declared +in such a directory through 'filecontents' was removed cleanly and then its +directory reported @Failed@, which also blocks the teardown of whatever was +declared under it. Removing the directory would be wrong anyway: salmon +cannot prove it made it. + +Its own kind (@"shared-directory"@, keyed on the path), so it never collides +with a 'dir' of the same path; reapplies under supervision, as 'dir' does. +The systemd and quadlet unit directories have nodes of the same shape +('Salmon.Builtin.Nodes.Systemd.unitDirectory' and the quadlet's +@unitDirNode@), which predate this one and keep their own refs. +-} +sharedDir :: Directory -> Op +sharedDir directory = + op "shared-directory" nodeps $ \actions -> + actions + { help = Text.pack $ "ensures " <> path <> " exists, including subdirs" + , notes = + [ "create dir recursively" + , "shared with what salmon does not declare: down leaves it" + , "reapplies rather than parking under supervision; see supReapply" + ] + , ref = mkRef "shared-directory" path + , up = createDirectoryIfMissing True path + , dynamics = [supervised defaultSupervision{supReapply = True}] + } + where + path :: FilePath + path = directory.directoryPath + +{- | 'filecontents' standing on a 'sharedDir' of its enclosing directory +instead of a 'dir'. The file node itself is exactly what 'filecontents' +renders (same 'ref', @help@, @notes@, @check@, @up@ and @down@); only its +predecessor differs. For a file in a directory holding things salmon does +not declare, where 'dir''s @down@ would fail on what is left. +-} +filecontentsInSharedDir :: (EncodeFileContents a) => FileContents a -> Op +filecontentsInSharedDir fcontents = + file{predecessors = deps [sharedDir (Directory (takeDirectory fcontents.filePath))]} + where + file :: Op + file = filecontents fcontents + +{- | A scratch directory salmon owns outright: 'down' removes it /and +everything in it/. Opt-in, for a directory whose contents cannot be declared +(logs written by child processes, pid files, a transient dump) and whose +teardown must leave nothing behind. 'dir' would refuse to remove it (non-empty) +and 'retainedDir' would leave a timestamped copy behind on every @down@. + +A recursive delete destroys data, so it is guarded by the directory's +__identity__, not by its path: + +* @up@ creates the leaf itself (never adopts one that is already there) and + then writes, inside it, an ownership claim ('scratchClaimFile') naming the + declared path and the directory's own device and inode numbers. +* @down@ removes the tree only when the path is still /that/ directory: a + real directory (not a symlink), whose device and inode match the claim + inside it. A claim copied into another directory, a directory recreated by + someone else at the same path, or one mounted over it does not match, and + @down@ throws without deleting anything. +* @down@ also refuses a tree that crosses into another filesystem (a mount + point or bind mount somewhere underneath): it walks the tree first, never + following a symlink, and compares every directory's device. Symlinks inside + the tree are removed themselves, never their targets. +* Some paths are refused outright, at @up@ as at @down@: a relative path, one + with @.@ or @..@ components, @/@ and any top-level directory (@/tmp@, + @/var@), and the user's home or any of its ancestors ('scratchPathRefusal'). + +@up@ also throws when the path exists without a matching claim: salmon never +takes over a directory it cannot prove it made. A crash between the +@mkdir@ and the claim write leaves exactly that state; recovering it is a +manual @rmdir@, deliberately. + +A @down@ of an absent directory succeeds, as for 'dir', so a second @down@ is +a no-op. The @check@ answers 'Success' when the directory is there with a +matching claim, so a directory removed behind salmon's back is noticed (and +put back) under @run serve@. + +Two things a caller should know. The claim file lives inside the directory, +so whatever writes there must not delete it (if it does, @down@ refuses and +says why). And nodes declared /inside/ a scratch directory should not stand +on 'dir' of the same path (as 'filecontents' does through its enclosing +directory): that is a second, differently-keyed node for the same path whose +own @down@ fails on a non-empty directory. +-} +scratchDir :: Directory -> Op +scratchDir directory = + op "scratch-directory" nodeps $ \actions -> + actions + { help = Text.pack $ "ensures " <> path <> " exists as a salmon-owned scratch directory" + , notes = + [ "create the directory and an ownership claim inside it" + , "down removes the whole tree, only if the claim matches the directory's device and inode" + , "never adopts a directory it did not create" + ] + , ref = mkRef "scratch-directory" path + , check = checkScratchDir path + , up = createScratchDir path + , down = removeScratchDir path + } + where + path :: FilePath + path = directory.directoryPath + +-- | The ownership claim 'scratchDir' writes inside the directory it creates. +scratchClaimFile :: FilePath +scratchClaimFile = ".salmon-scratch-dir" + +{- | Why a path may never be a 'scratchDir', if it may not. Pure part of the +guard; 'scratchPathRefusalIO' adds the home directory. +-} +scratchPathRefusal :: FilePath -> Maybe String +scratchPathRefusal path + | not (isAbsolute path) = Just "not an absolute path" + | any (`elem` [".", ".."]) components = Just "has . or .. components" + | length components < 3 = Just "is / or a top-level directory" + | otherwise = Nothing + where + -- splitDirectories "/a/b" == ["/", "a", "b"] + components = splitDirectories path + +scratchPathRefusalIO :: FilePath -> IO (Maybe String) +scratchPathRefusalIO path = case scratchPathRefusal path of + Just r -> pure (Just r) + Nothing -> do + home <- either (const Nothing) Just <$> (try getHomeDirectory :: IO (Either IOException FilePath)) + pure $ case home of + Just h + | isAbsolute h + , splitDirectories path `isPrefixOf` splitDirectories h -> + Just "is the home directory or one of its ancestors" + _ -> Nothing + +-- | The claim's text: a fixed header, the declared path, device and inode. +renderScratchClaim :: FilePath -> Posix.DeviceID -> Posix.FileID -> String +renderScratchClaim path dev ino = + unlines + [ "salmon-scratch-dir v1" + , "path " <> path + , "device " <> show (toInteger dev) + , "inode " <> show (toInteger ino) + ] + +-- | What the path holds, as far as 'scratchDir' is concerned. +data ScratchState + = ScratchAbsent + | ScratchOwned + | ScratchForeign String + deriving (Eq, Show) + +scratchState :: FilePath -> IO ScratchState +scratchState path = do + refusal <- scratchPathRefusalIO path + case refusal of + Just r -> pure (ScratchForeign r) + Nothing -> do + -- lstat, so a dangling symlink is not mistaken for absence + lstat <- try (Posix.getSymbolicLinkStatus path) :: IO (Either IOException Posix.FileStatus) + case lstat of + Left e + | isDoesNotExistError e -> pure ScratchAbsent + | otherwise -> pure (ScratchForeign "cannot be inspected") + Right st + | Posix.isSymbolicLink st -> pure (ScratchForeign "is a symbolic link") + | not (Posix.isDirectory st) -> pure (ScratchForeign "is not a directory") + | otherwise -> do + let claim = path scratchClaimFile + claimStat <- try (Posix.getSymbolicLinkStatus claim) :: IO (Either IOException Posix.FileStatus) + case claimStat of + Right cst | Posix.isRegularFile cst -> do + there <- C8.unpack <$> ByteString.readFile claim + pure $ + if there == renderScratchClaim path (Posix.deviceID st) (Posix.fileID st) + then ScratchOwned + else ScratchForeign "its ownership claim does not match this directory" + _ -> pure (ScratchForeign "has no salmon ownership claim") + +checkScratchDir :: FilePath -> IO CheckResult +checkScratchDir path = do + s <- scratchState path + pure $ case s of + ScratchOwned -> Success + ScratchAbsent -> Failure ("missing: " <> Text.pack path) + ScratchForeign why -> Failure (Text.pack $ path <> " " <> why) + +createScratchDir :: FilePath -> IO () +createScratchDir path = do + s <- scratchState path + case s of + ScratchOwned -> pure () + ScratchForeign why -> ioError (userError $ "refusing scratch directory " <> path <> ": " <> why) + ScratchAbsent -> do + createDirectoryIfMissing True (takeDirectory path) + -- not createDirectoryIfMissing: the leaf must be ours. + createDirectory path + st <- Posix.getSymbolicLinkStatus path + writeFile (path scratchClaimFile) (renderScratchClaim path (Posix.deviceID st) (Posix.fileID st)) + +removeScratchDir :: FilePath -> IO () +removeScratchDir path = do + s <- scratchState path + case s of + ScratchAbsent -> pure () + ScratchForeign why -> ioError (userError $ "refusing to remove " <> path <> ": " <> why) + ScratchOwned -> do + st <- Posix.getSymbolicLinkStatus path + crossing <- firstOtherDevice (Posix.deviceID st) path + case crossing of + Just p -> ioError (userError $ "refusing to remove " <> path <> ": " <> p <> " is on another filesystem") + Nothing -> removeDirectoryRecursive path + +-- | The first directory under @root@ whose device differs, never following +-- a symlink. +firstOtherDevice :: Posix.DeviceID -> FilePath -> IO (Maybe FilePath) +firstOtherDevice dev root = listDirectory root >>= go . map (root ) + where + go [] = pure Nothing + go (p : ps) = do + st <- Posix.getSymbolicLinkStatus p + if Posix.isDirectory st + then + if Posix.deviceID st /= dev + then pure (Just p) + else do + below <- firstOtherDevice dev p + maybe (go ps) (pure . Just) below + else go ps -- | Renames @path@ to @path@ suffixed with the current UTC timestamp. A -- no-op if @path@ is already gone. diff --git a/src/Salmon/Builtin/Nodes/Gcp/ArtifactRegistry.hs b/src/Salmon/Builtin/Nodes/Gcp/ArtifactRegistry.hs --- a/src/Salmon/Builtin/Nodes/Gcp/ArtifactRegistry.hs +++ b/src/Salmon/Builtin/Nodes/Gcp/ArtifactRegistry.hs @@ -9,11 +9,30 @@ Report (..), ArtifactRegistryCommand (..), artifactRegistryCommand, + + -- * Pulling from a GCE instance + dockerRegistry, + instanceLogin, + instanceLoginWith, + InstanceToken (..), + parseInstanceToken, + instanceToken, + tokenStampPath, + interpretTokenStamp, + refreshMargin, + MetadataError (..), ) where +import Control.Exception (Exception, throwIO) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson (parseEither) +import qualified Data.ByteString.Lazy as LByteString import Data.Text (Text) import qualified Data.Text as Text +import Data.Time.Clock (NominalDiffTime, UTCTime) import GHC.IO.Exception (ExitCode (..)) +import qualified Network.HTTP.Client as Http +import qualified Network.HTTP.Types.Status as Http import System.Process.ByteString (readCreateProcessWithExitCode) import System.Process.ListLike (proc) @@ -22,6 +41,7 @@ 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.Podman as Podman import qualified Salmon.Builtin.Nodes.Gcp.Core as Core import Salmon.Op.Ref import Salmon.Op.Track @@ -106,6 +126,110 @@ dockerHost :: Region -> Text dockerHost rgn = rgn.regionName <> "-docker.pkg.dev" + +------------------------------------------------------------------------------- + +-- | The docker-format registry of a region, as a podman 'Podman.Registry'. +dockerRegistry :: Region -> Podman.Registry +dockerRegistry region = Podman.Registry (region.regionName <> "-docker.pkg.dev") + +{- | A GCE instance logging podman in to its region's registry /as the +instance's own service account/. + +'configureDockerAuth' is the workstation's road: it needs @gcloud@ and +somebody's credentials. A VM has neither and needs neither -- the metadata +server hands any process on the instance an access token for the service +account the instance runs as, and Artifact Registry takes that token as the +password of the user @oauth2accesstoken@. So this is 'Podman.login' with the +metadata server as the password, and no secret is shipped to the machine. + +What it adds to 'Podman.login' is a @check@. That node has none, which is +right for a credential nobody can ask after; this one can be asked after, +because the metadata server says when the token expires. The expiry is +written beside the auth file ('tokenStampPath') after a successful login, and +'interpretTokenStamp' answers 'Success' while more than 'refreshMargin' of it +is left. A one-shot @run up@ therefore logs in again only when it has to, and +under @run serve@ the credential is /tended/: without the check the node +would be parked, the token would lapse within the hour, and the next image +change would fail its pull with credentials that look present. + +The margin is under the five minutes before expiry at which the metadata +server starts handing out a new token, so a login the check asked for gets a +token that outlives the margin, and the check does not fail again at once. + +Needs, on the GCP side and declared elsewhere: +@roles\/artifactregistry.reader@ on the repository for the instance's service +account, and an instance whose access scopes allow it (@cloud-platform@, or +the read-only storage scope). +-} +instanceLogin :: Reporter Podman.Report -> Track' (Binary "podman") -> Podman.AuthFile -> Region -> Op +instanceLogin = instanceLoginWith instanceToken + +{- | 'instanceLogin' with the token's source as an argument, so that a test +can stand in for the metadata server. + +The check and the expiry stamp are 'Podman.loginExpiring''s, which this is: +they began here and moved there once a second caller needed them. See +'Podman.expiring' for why they sit on the login node alone. +-} +instanceLoginWith :: IO InstanceToken -> Reporter Podman.Report -> Track' (Binary "podman") -> Podman.AuthFile -> Region -> Op +instanceLoginWith getToken r podman authfile region = + Podman.loginExpiring r podman authfile (dockerRegistry region) (Podman.Username "oauth2accesstoken") (credential <$> getToken) + where + credential :: InstanceToken -> Podman.Credential + credential token = Podman.Credential token.tokenValue token.tokenLifetime + +-- | Where the expiry of the token in an auth file is recorded. +tokenStampPath :: Podman.AuthFile -> FilePath +tokenStampPath = Podman.loginStampPath + +-- | How much of a token's life must be left for it to be left alone. +refreshMargin :: NominalDiffTime +refreshMargin = Podman.loginRefreshMargin + +{- | Is the recorded login still good for a pull? The stamp is the expiry in +seconds since the epoch; 'Nothing' is no stamp, or no auth file to go with it. +-} +interpretTokenStamp :: UTCTime -> Maybe Text -> CheckResult +interpretTokenStamp = Podman.interpretLoginStamp + +-- | An access token and how long it is good for from when it was handed out. +data InstanceToken + = InstanceToken + { tokenValue :: !Text + , tokenLifetime :: !NominalDiffTime + } + +data MetadataError + = MetadataStatus !Int + | MetadataUnreadable !String + deriving (Show) + +instance Exception MetadataError + +-- | The metadata server's answer: @{"access_token": .., "expires_in": .., "token_type": ..}@. +parseInstanceToken :: LByteString.ByteString -> Either String InstanceToken +parseInstanceToken body = do + value <- Aeson.eitherDecode body + flip Aeson.parseEither value $ Aeson.withObject "token" $ \o -> do + token <- o Aeson..: "access_token" + seconds <- o Aeson..: "expires_in" + if Text.null token + then fail "empty access_token" + else pure (InstanceToken token (fromInteger seconds)) + +{- | The instance's default service account's token, from the metadata +server. Only answers on a GCE instance; anywhere else the name does not +resolve and this throws, which fails the node that asked. +-} +instanceToken :: IO InstanceToken +instanceToken = do + manager <- Http.newManager Http.defaultManagerSettings{Http.managerResponseTimeout = Http.responseTimeoutMicro 10000000} + request <- Http.parseRequest "http://metadata.google.internal/computeMetadata/v1/instance/service-accounts/default/token" + response <- Http.httpLbs request{Http.requestHeaders = [("Metadata-Flavor", "Google")]} manager + case Http.statusCode (Http.responseStatus response) of + 200 -> either (throwIO . MetadataUnreadable) pure (parseInstanceToken (Http.responseBody response)) + other -> throwIO (MetadataStatus other) ------------------------------------------------------------------------------- diff --git a/src/Salmon/Builtin/Nodes/Gcp/CloudDns.hs b/src/Salmon/Builtin/Nodes/Gcp/CloudDns.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/Gcp/CloudDns.hs @@ -0,0 +1,628 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Cloud DNS: a managed zone, a read of the name servers Cloud DNS assigned +to it, and the record sets that go in it ('recordSet'). + +The zone is split from the records that go in it because two things need it +before any record exists. The assigned name servers are what an operator +enters at the registrar to delegate the domain, and until that is done +nothing in the zone is visible to the world -- delegation takes time to +propagate, so it is worth starting early. And a check that compares the +delegation the parent servers hand out with what the zone was assigned needs +exactly this set. + +Like an external "Salmon.Builtin.Nodes.Gcp.Compute".@Address@, the name +servers cannot be known when the graph is /declared/: Cloud DNS picks them +(one of several shards, @ns-cloud-a1@ … @ns-cloud-e4@) at creation. So they +are an out-of-graph read, 'readNameServers', for a driver to use after the +pass that created the zone. + +Enabling the API ('dnsApi') is the caller's dependency to declare, as with +every other node under "Salmon.Builtin.Nodes.Gcp". +-} +module Salmon.Builtin.Nodes.Gcp.CloudDns ( + dnsApi, + ManagedZone (..), + managedZone, + readNameServers, + ZoneDescription (..), + parseZoneDescribe, + interpretZoneDescribe, + fqdn, + + -- * record sets + RecordType (..), + renderRecordType, + RecordSet (..), + recordSet, + resolvedRecordSet, + recordSetProblems, + RecordDescription (..), + parseRecordDescribe, + interpretRecordDescribe, + recordUpCommand, + renderRrdatas, + txtRdata, + txtContent, + + -- * mail exchangers + MailExchanger (..), + mxDatum, + mxRecordSet, + parseMxDatum, + Report (..), + CloudDnsCommand (..), + cloudDnsCommand, +) where + +import Control.Exception (throwIO) +import Data.Aeson (FromJSON (..), eitherDecodeStrict', withObject, (.!=), (.:), (.:?)) +import Data.ByteString (ByteString) +import Data.Char (isDigit, isSpace) +import Data.List (sort) +import Data.Text (Text) +import qualified Data.Text 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 qualified Salmon.Builtin.Nodes.Gcp.Core as Core +import Salmon.Op.Ref +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- + +data Report + = RunCloudDnsCommand !CloudDnsCommand !Binary.Report + deriving (Show) + +-- | The API a project needs enabled before any zone can be created. +dnsApi :: Text +dnsApi = "dns.googleapis.com" + +------------------------------------------------------------------------------- + +{- | A public Cloud DNS managed zone. + +'zoneName' is the resource's name within the project (what every later +@gcloud dns@ command addresses); 'zoneDnsName' is the domain it is +authoritative for, with or without the trailing dot. +-} +data ManagedZone = ManagedZone + { zoneName :: Text + , zoneProject :: Project + , zoneDnsName :: Text + , zoneDescription :: Text + -- ^ @gcloud dns managed-zones create@ requires one + } + deriving (Eq, Show) + +-- | A DNS name as Cloud DNS spells it: lower-case, with the trailing dot. +fqdn :: Text -> Text +fqdn name = Text.dropWhileEnd (== '.') (Text.toLower (Text.strip name)) <> "." + +{- | Idempotently creates a public managed zone. + +* 'check': describes the zone; 'Success' if it exists /for the declared DNS + name/. A zone of that name serving another domain is a 'Failure' naming + both, and @up@ then fails on gcloud's "already exists" rather than taking + the zone over: a zone's DNS name cannot be changed, and deleting somebody + else's zone to make room is not this node's call. +* 'up': creates the zone. +* 'down': deletes it, if it is there. Cloud DNS refuses to delete a zone + that still holds records other than its own apex @NS@ and @SOA@, so record + nodes declared on top of the zone have to go down first -- which is what + depending on this node gets them. + +The 'ref' is keyed on the project and the zone's name, not on the DNS name: +that pair is the effect site. +-} +managedZone :: Reporter Report -> Track' (Binary "gcloud") -> ManagedZone -> Op +managedZone r gcloudTrack zone = + withBinary gcloudTrack cloudDnsCommand (ZonesCreate zone) $ \create -> + withBinary gcloudTrack cloudDnsCommand (ZonesDelete zone) $ \delete -> + op "gcp-dns-zone" nodeps $ \actions -> + actions + { help = Text.unwords ["creates Cloud DNS zone", zone.zoneName, "for", fqdn zone.zoneDnsName] + , ref = mkRef "gcp-dns-zone" (zone.zoneProject.projectId, zone.zoneName) + , up = Core.retryingIO Core.afterEnableRetries Core.afterEnableDelay (create (rFor (ZonesCreate zone))) + , -- a zone of that name serving another domain reads + -- 'Failure' here too, so it is left alone + down = Core.downIfPresent checkZone (delete (rFor (ZonesDelete zone))) + , check = checkZone + } + where + rFor cmd = contramap (RunCloudDnsCommand cmd) r + + checkZone :: IO CheckResult + checkZone = do + (code, out) <- describeZone zone + pure $ interpretZoneDescribe zone code out + +describeZone :: ManagedZone -> IO (ExitCode, ByteString) +describeZone zone = do + (code, out, _err) <- + readCreateProcessWithExitCode (prepare cloudDnsCommand (ZonesDescribe zone)) "" + pure (code, out) + +{- | The name servers Cloud DNS assigned to the zone, in the order it lists +them and with their trailing dots. 'Nothing' when the zone does not exist +(or its description could not be read). + +Out of graph, like "Salmon.Builtin.Nodes.Gcp.Compute".@readAddress@: these +are what goes to the registrar, and what a delegation check compares against. +-} +readNameServers :: ManagedZone -> IO (Maybe [Text]) +readNameServers zone = do + (code, out) <- describeZone zone + pure $ case (code, parseZoneDescribe out) of + (ExitSuccess, Right desc) | not (null desc.describedNameServers) -> Just desc.describedNameServers + _ -> Nothing + +------------------------------------------------------------------------------- + +-- | What this module reads of @gcloud dns managed-zones describe --format json@. +data ZoneDescription = ZoneDescription + { describedDnsName :: Text + , describedNameServers :: [Text] + } + deriving (Eq, Show) + +instance FromJSON ZoneDescription where + parseJSON = withObject "ManagedZone" $ \o -> + ZoneDescription <$> o .: "dnsName" <*> o .:? "nameServers" .!= [] + +parseZoneDescribe :: ByteString -> Either String ZoneDescription +parseZoneDescribe = eitherDecodeStrict' + +{- | The verdict drawn from @gcloud dns managed-zones describe@'s exit code +and JSON output, split out for testability. +-} +interpretZoneDescribe :: ManagedZone -> ExitCode -> ByteString -> CheckResult +interpretZoneDescribe zone (ExitFailure _) _ = + Failure ("DNS zone not found: " <> zone.zoneName) +interpretZoneDescribe zone ExitSuccess out = + case parseZoneDescribe out of + -- it answered, and what it said could not be read: cannot tell + Left _ -> Unknown + Right desc + | fqdn desc.describedDnsName == fqdn zone.zoneDnsName -> Success + | otherwise -> + Failure + ( Text.unwords + [ "DNS zone" + , zone.zoneName + , "exists for" + , fqdn desc.describedDnsName <> "," + , "not for" + , fqdn zone.zoneDnsName + ] + ) + +------------------------------------------------------------------------------- +-- Record sets + +-- | The record types this module writes. +data RecordType = A | AAAA | CNAME | TXT | MX + deriving (Eq, Ord, Show) + +renderRecordType :: RecordType -> Text +renderRecordType = Text.pack . show + +{- | A record set: every record of one type at one name. + +'recordName' is the full name (@www.example.org@, with or without the +trailing dot), not a label relative to the zone. 'recordData' is one entry +per record, in the type's own terms: + +* 'A', 'AAAA': an address literal; +* 'CNAME': the one target name (the trailing dot is added); +* 'TXT': the text itself, /unquoted/ -- quoting, escaping and the split into + 255-character strings that the wire format wants are 'txtRdata''s job; +* 'MX': a preference and a mail server's name, @"10 mail.example.org"@ (the + trailing dot is added). 'mxDatum' writes one from a 'MailExchanger', and + 'mxRecordSet' a whole record set from a list of them. +-} +data RecordSet = RecordSet + { recordZone :: ManagedZone + , recordName :: Text + , recordType :: RecordType + , recordTtl :: Int + -- ^ seconds + , recordData :: [Text] + } + deriving (Eq, Show) + +{- | Idempotently makes a record set hold exactly the declared data. + +* 'check': describes the record set and compares its TTL and data with what + is declared (as a set: Cloud DNS does not promise an order). Absent, or + holding anything else, is a 'Failure' saying which; a declaration that + cannot be written ('recordSetProblems') is a 'Failure' too. +* 'up': creates the record set, or updates it in place when one already + exists at that name and type -- so a changed address is a rewrite of this + node, and a record made by hand is taken over. That is deliberate, and the + opposite of what 'managedZone' does with a zone it did not make: the name + and type are the effect site and can hold only one set, so "declared" has + to mean "this is what it holds". +* 'down': deletes the record set at that name and type if there is one, + whatever it holds, for the same reason (and because the zone under it + cannot be deleted while it is there). + +The node has no dependencies of its own: the zone may be one this graph +declares ('managedZone', which the caller then puts underneath with +@inject@ -- and must, for @down@ to be ordered) or one that already exists. + +The 'ref' is keyed on project, zone, name and type; TTL and data ride in +'notes', so a re-declaration with another address is a changed node under +@run serve@. +-} +recordSet :: Reporter Report -> Track' (Binary "gcloud") -> RecordSet -> Op +recordSet r gcloudTrack rs = + recordSetNode r gcloudTrack rs (pure (Just rs.recordData)) $ + [ "ttl " <> Text.pack (show rs.recordTtl) + , Text.unwords (sort (map (normalizeDatum rs.recordType) rs.recordData)) + ] + +{- | 'recordSet' for data that cannot be known when the graph is declared -- +the address GCP picked for a balancer or a reserved IP, which exists only +after the node that makes it has run. The data is read by the given action +each time the node is checked or brought up; 'recordData' of the argument is +not read. + +'Nothing' means "not readable yet": the 'check' then answers 'Unknown' and +@up@ throws. Put the node that makes the value underneath this one. + +What the 'notes' cannot say here is the data, so under @run serve@ a change +of the resolved value is noticed by this node's 'check', not by a +re-declaration. +-} +resolvedRecordSet :: Reporter Report -> Track' (Binary "gcloud") -> RecordSet -> IO (Maybe [Text]) -> Op +resolvedRecordSet r gcloudTrack rs resolve = + recordSetNode r gcloudTrack rs resolve ["ttl " <> Text.pack (show rs.recordTtl), "data resolved when applied"] + +recordSetNode :: Reporter Report -> Track' (Binary "gcloud") -> RecordSet -> IO (Maybe [Text]) -> [Text] -> Op +recordSetNode r gcloudTrack rs0 resolve noteLines = + withBinary gcloudTrack cloudDnsCommand (RecordSetsDelete rs0) $ \delete -> + op "gcp-dns-record" nodeps $ \actions -> + actions + { help = Text.unwords ["sets DNS record", renderRecordType rs0.recordType, fqdn rs0.recordName, "in zone", rs0.recordZone.zoneName] + , notes = noteLines + , ref = + mkRef + "gcp-dns-record" + ( rs0.recordZone.zoneProject.projectId + , rs0.recordZone.zoneName + , fqdn rs0.recordName + , renderRecordType rs0.recordType + ) + , up = bringUp + , down = do + (code, _out) <- describeRecord rs0 + case code of + ExitSuccess -> delete (rFor (RecordSetsDelete rs0)) + ExitFailure _ -> pure () + , check = checkRecord + } + where + rFor cmd = contramap (RunCloudDnsCommand cmd) r + + resolved :: IO (Maybe RecordSet) + resolved = fmap (\ds -> rs0{recordData = ds}) <$> resolve + + checkRecord :: IO CheckResult + checkRecord = do + mrs <- resolved + case mrs of + Nothing -> pure Unknown + Just rs -> do + (code, out) <- describeRecord rs + pure $ interpretRecordDescribe rs code out + + bringUp :: IO () + bringUp = do + mrs <- resolved + rs <- case mrs of + Nothing -> throwIO (userError ("the data for DNS record " <> Text.unpack (fqdn rs0.recordName) <> " could not be read")) + Just rs -> pure rs + case recordSetProblems rs of + [] -> pure () + problems -> throwIO (userError (Text.unpack (problemText rs problems))) + Core.retryingIO Core.afterEnableRetries Core.afterEnableDelay $ do + (code, _out) <- describeRecord rs + let cmd = recordUpCommand rs code + Binary.untrackedExec cloudDnsCommand cmd "" (rFor cmd) + +describeRecord :: RecordSet -> IO (ExitCode, ByteString) +describeRecord rs = do + (code, out, _err) <- + readCreateProcessWithExitCode (prepare cloudDnsCommand (RecordSetsDescribe rs)) "" + pure (code, out) + +{- | What @up@ runs, given whether @describe@ found a record set at that name +and type: there is no "set" verb, @create@ fails on one that exists and +@update@ on one that does not. +-} +recordUpCommand :: RecordSet -> ExitCode -> CloudDnsCommand +recordUpCommand rs ExitSuccess = RecordSetsUpdate rs +recordUpCommand rs (ExitFailure _) = RecordSetsCreate rs + +{- | Why a declared record set cannot be written, if it cannot. Checked +before anything is sent, since Cloud DNS's own refusals come back after the +retries and say less. +-} +recordSetProblems :: RecordSet -> [Text] +recordSetProblems rs = + ["it has no data" | null rs.recordData] + <> ["a CNAME has exactly one target" | rs.recordType == CNAME, length rs.recordData /= 1] + <> ["a CNAME cannot sit at the zone's apex" | rs.recordType == CNAME, name == apex] + <> [name <> " is not in " <> apex | name /= apex, not (("." <> apex) `Text.isSuffixOf` name)] + <> ["the TTL is negative" | rs.recordTtl < 0] + <> (if rs.recordType == MX then mxProblems rs.recordData else []) + where + name = fqdn rs.recordName + apex = fqdn rs.recordZone.zoneDnsName + +{- | A mail exchanger: the preference (lower is tried first) and the name of +the server. An MX record set holds several, at the zone's apex or at a +subdomain alike. + +The server is a name, never an address, and what it names must have an +address record of its own: neither is checked here, since the name is usually +in somebody else's zone. A lone @MailExchanger 0 "."@ is the "null MX" of RFC +7505, a domain declaring that it takes no mail. +-} +data MailExchanger = MailExchanger + { mxPreference :: Int + , mxHost :: Text + } + deriving (Eq, Ord, Show) + +-- | A mail exchanger as one entry of 'recordData'. +mxDatum :: MailExchanger -> Text +mxDatum mx = Text.pack (show mx.mxPreference) <> " " <> fqdn mx.mxHost + +-- | The MX record set of a name: its mail exchangers, in any order. +mxRecordSet :: ManagedZone -> Text -> Int -> [MailExchanger] -> RecordSet +mxRecordSet zone name ttl exchangers = RecordSet zone name MX ttl (map mxDatum exchangers) + +{- | Reads one entry of an MX record set, declared or as Cloud DNS reports +it: a preference in decimal, whitespace, one name. The name comes back with +its trailing dot and in lower case, so two spellings of one exchanger are +equal. 'Nothing' for anything else. +-} +parseMxDatum :: Text -> Maybe MailExchanger +parseMxDatum datum = case Text.words datum of + [preference, host] + | not (Text.null preference) + , Text.all isDigit preference + , Text.length preference <= 5 -> + Just (MailExchanger (read (Text.unpack preference)) (fqdn host)) + _ -> Nothing + +mxProblems :: [Text] -> [Text] +mxProblems datums = + concatMap problem datums + <> [ "the same mail server is listed twice: " <> h + | h <- duplicates [mx.mxHost | Just mx <- parsed] + ] + <> [ "a null MX (\".\") must be the only one, with preference 0" + | any (\mx -> mx.mxHost == ".") exchangers + , exchangers /= [MailExchanger 0 "."] + ] + where + parsed = map parseMxDatum datums + exchangers = [mx | Just mx <- parsed] + duplicates xs = [x | (x, n) <- counted (sort xs), n > (1 :: Int)] + counted [] = [] + counted (x : xs) = (x, 1 + length (takeWhile (== x) xs)) : counted (dropWhile (== x) xs) + problem datum = case parseMxDatum datum of + Nothing -> ["an MX is a preference and a server name (\"10 mail.example.org\"), not \"" <> Text.strip datum <> "\""] + Just mx -> + ["the MX preference " <> Text.pack (show mx.mxPreference) <> " is above 65535" | mx.mxPreference > 65535] + <> [ "an MX names a server, not an address: " <> mx.mxHost + | looksLikeAddress mx.mxHost + ] + -- an IPv4 literal, or anything with a colon: neither is a host name + looksLikeAddress h = + Text.any (== ':') h + || (h /= "." && Text.all (\c -> isDigit c || c == '.') h) + +problemText :: RecordSet -> [Text] -> Text +problemText rs problems = + Text.unwords ["DNS record", renderRecordType rs.recordType, fqdn rs.recordName, "cannot be written:"] + <> " " + <> Text.intercalate "; " problems + +-- | What this module reads of @gcloud dns record-sets describe --format json@. +data RecordDescription = RecordDescription + { describedTtl :: Int + , describedRrdatas :: [Text] + } + deriving (Eq, Show) + +instance FromJSON RecordDescription where + parseJSON = withObject "ResourceRecordSet" $ \o -> + RecordDescription <$> o .: "ttl" <*> o .:? "rrdatas" .!= [] + +parseRecordDescribe :: ByteString -> Either String RecordDescription +parseRecordDescribe = eitherDecodeStrict' + +{- | The verdict drawn from @gcloud dns record-sets describe@'s exit code and +JSON output, split out for testability. + +The reasons quote the record's data: DNS records are public. +-} +interpretRecordDescribe :: RecordSet -> ExitCode -> ByteString -> CheckResult +interpretRecordDescribe rs code out + | problems@(_ : _) <- recordSetProblems rs = Failure (problemText rs problems) + | ExitFailure _ <- code = Failure (Text.unwords ["DNS record not found:", label]) + | otherwise = case parseRecordDescribe out of + -- it answered, and what it said could not be read: cannot tell + Left _ -> Unknown + Right desc + | live desc /= wanted -> + Failure (Text.unwords ["DNS record", label, "holds", shown (live desc) <> ",", "not", shown wanted]) + | desc.describedTtl /= rs.recordTtl -> + Failure + ( Text.unwords + ["DNS record", label, "has TTL", Text.pack (show desc.describedTtl) <> ",", "not", Text.pack (show rs.recordTtl)] + ) + | otherwise -> Success + where + label = Text.unwords [renderRecordType rs.recordType, fqdn rs.recordName] + wanted = sort (map (normalizeDatum rs.recordType) rs.recordData) + live :: RecordDescription -> [Text] + live desc = sort (map (normalizeRdata rs.recordType) desc.describedRrdatas) + shown = Text.intercalate ", " + +-- | A declared datum, in the form two equal records compare equal in. +normalizeDatum :: RecordType -> Text -> Text +normalizeDatum A = Text.strip +normalizeDatum AAAA = Text.toLower . Text.strip +normalizeDatum CNAME = fqdn +normalizeDatum TXT = id +-- what does not read as an MX is kept (and refused by 'recordSetProblems') +normalizeDatum MX = \d -> maybe (Text.unwords (Text.split isSpace (Text.strip d))) mxDatum (parseMxDatum d) + +-- | The same form, from what Cloud DNS reports (a TXT comes back quoted). +normalizeRdata :: RecordType -> Text -> Text +normalizeRdata TXT = txtContent +normalizeRdata t = normalizeDatum t + +-- | A declared datum as it is handed to gcloud. +datumRdata :: RecordType -> Text -> Text +datumRdata TXT = txtRdata +datumRdata t = normalizeDatum t + +{- | A TXT record's text as record data: double-quoted, with @\\@ and @"@ +escaped, and split into strings of at most 255 characters (the limit is in +bytes on the wire, so this is exact for ASCII only). Unquoted, gcloud would +split the text into one string per space. +-} +txtRdata :: Text -> Text +txtRdata t = Text.unwords (map quote (chunks t)) + where + chunks x + | Text.length x <= 255 = [x] + | otherwise = Text.take 255 x : chunks (Text.drop 255 x) + quote x = "\"" <> Text.concatMap escape x <> "\"" + escape '"' = "\\\"" + escape '\\' = "\\\\" + escape c = Text.singleton c + +{- | The text a TXT record's data stands for: its quoted strings unescaped +and concatenated, which is what a resolver's client reads. Inverse of +'txtRdata'; data that is not quoted at all is taken as it is. +-} +txtContent :: Text -> Text +txtContent = Text.pack . outside . Text.unpack . Text.strip + where + outside [] = [] + outside ('"' : rest) = inside rest + outside (c : rest) + | c == ' ' && startsQuoted rest = outside rest + | otherwise = c : outside rest + inside [] = [] + inside ('\\' : c : rest) = c : inside rest + inside ('"' : rest) = outside rest + inside (c : rest) = c : inside rest + startsQuoted rest = case dropWhile (== ' ') rest of + ('"' : _) -> True + _ -> False + +{- | The value of @--rrdatas@, which gcloud reads as a list. Its separator is +a comma unless the value starts with @^DELIM^@ (see @gcloud topic escaping@), +so a datum holding a comma -- an SPF or DKIM TXT, typically -- moves the +whole list to the first separator none of the data contains. +-} +renderRrdatas :: [Text] -> Text +renderRrdatas rdatas + | sep == "," = Text.intercalate sep rdatas + | otherwise = "^" <> sep <> "^" <> Text.intercalate sep rdatas + where + free d = not (any (d `Text.isInfixOf`) rdatas) + singles = [",", ";", "|", "#", "~", "%", "@", "!"] + -- total: only finitely many runs of "|" can occur in the data + sep = case filter free singles of + d : _ -> d + [] -> until free (<> "|") "||" + +------------------------------------------------------------------------------- + +data CloudDnsCommand + = ZonesCreate ManagedZone + | ZonesDescribe ManagedZone + | ZonesDelete ManagedZone + | RecordSetsCreate RecordSet + | RecordSetsUpdate RecordSet + | RecordSetsDescribe RecordSet + | RecordSetsDelete RecordSet + deriving (Show) + +cloudDnsCommand :: Command "gcloud" CloudDnsCommand +cloudDnsCommand = Command $ \cmd -> case cmd of + ZonesCreate z -> + gcloudProc $ + withProject z.zoneProject + [ "dns" + , "managed-zones" + , "create" + , Text.unpack z.zoneName + , "--dns-name" + , Text.unpack (fqdn z.zoneDnsName) + , "--description" + , Text.unpack z.zoneDescription + , "--visibility" + , "public" + ] + ZonesDescribe z -> + gcloudProc $ + withProject z.zoneProject + [ "dns" + , "managed-zones" + , "describe" + , Text.unpack z.zoneName + , "--format" + , "json" + ] + ZonesDelete z -> + gcloudProc $ + withProject z.zoneProject + [ "dns" + , "managed-zones" + , "delete" + , Text.unpack z.zoneName + , "--quiet" + ] + RecordSetsCreate rs -> gcloudProc (writeRecord "create" rs) + RecordSetsUpdate rs -> gcloudProc (writeRecord "update" rs) + RecordSetsDescribe rs -> gcloudProc (addressRecord "describe" rs <> ["--format", "json"]) + RecordSetsDelete rs -> gcloudProc (addressRecord "delete" rs) + where + writeRecord :: String -> RecordSet -> [String] + writeRecord verb rs = + addressRecord verb rs + <> [ "--ttl" + , show rs.recordTtl + , -- one argument with "=": a TXT's data starts with a quote and + -- may hold anything, and must not be read as a flag + "--rrdatas=" <> Text.unpack (renderRrdatas (map (datumRdata rs.recordType) rs.recordData)) + ] + addressRecord :: String -> RecordSet -> [String] + addressRecord verb rs = + withProject rs.recordZone.zoneProject + [ "dns" + , "record-sets" + , verb + , Text.unpack (fqdn rs.recordName) + , "--zone" + , Text.unpack rs.recordZone.zoneName + , "--type" + , Text.unpack (renderRecordType rs.recordType) + ] diff --git a/src/Salmon/Builtin/Nodes/Gcp/CloudRun.hs b/src/Salmon/Builtin/Nodes/Gcp/CloudRun.hs --- a/src/Salmon/Builtin/Nodes/Gcp/CloudRun.hs +++ b/src/Salmon/Builtin/Nodes/Gcp/CloudRun.hs @@ -6,6 +6,10 @@ renderSecretBinding, CloudRunOptions (..), defaultCloudRunOptions, + OwnerLabel (..), + renderOwnerLabel, + Ownership (..), + interpretOwnership, CloudRunService (..), cloudRunService, interpretServiceDescribe, @@ -15,6 +19,7 @@ cloudRunCommand, ) where +import Control.Exception (throwIO) import Data.Aeson (Value (..), eitherDecodeStrict) import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap @@ -25,6 +30,7 @@ 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.Process.ByteString (readCreateProcessWithExitCode) import System.Process.ListLike (proc) @@ -111,9 +117,70 @@ -- 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. + , croMinInstances :: Maybe Int + -- ^ @--min-instances@: how many instances stay up with no traffic. + -- 'Nothing' (the default) leaves the deploy alone, which for a new + -- service is Cloud Run's scale-to-zero. A service with a background loop + -- (a scheduler tick, a lease) needs at least one, and needs + -- 'croCpuAlwaysAllocated' with it: an idle instance is otherwise kept + -- but given no CPU outside a request. Unsetting it does not put a + -- service back to zero; say @Just 0@. + , croCpuAlwaysAllocated :: Bool + -- ^ @--no-cpu-throttling@: CPU is allocated for the instance's whole + -- life rather than only while it handles a request ("instance-based + -- billing"). 'False' (the default) leaves the deploy alone rather than + -- passing @--cpu-throttling@, so turning this off again is not something + -- a redeploy does. + , croOwner :: Maybe OwnerLabel + -- ^ a label that says this declaration made the service. 'Nothing' (the + -- default) is the node this module always made: the name is the whole + -- identity, a deploy lands on whatever service has it and @down@ deletes + -- it. With a label, see 'OwnerLabel'. } deriving (Eq, Show) +{- | A label proving who made a service: @key=value@ among the service's own +labels, written by the deploy that creates it (@--update-labels@, so the +labels somebody else put there are left alone). + +A node declared with one treats the service's name as an address rather than +as proof: + +* a service of that name __without__ the label is somebody else's. The + @check@ says so, @up@ refuses to deploy over it, and @down@ leaves it + where it is; +* a service __with__ it is deployed to and deleted as usual; +* when the listing that answers the question fails, @up@ and @down@ both + throw rather than guess. + +The key and the value are label text, so GCP's rules apply to both +(lowercase letters, digits, @-@ and @_@, at most 63 characters, the key +starting with a letter); the caller validates, this module does not. The +label ends up in argv, in the node's notes and in the service's metadata: it +is a name, never a credential. +-} +data OwnerLabel = OwnerLabel + { ownerKey :: Text + , ownerValue :: Text + } + deriving (Eq, Show) + +-- | @key=value@, as @--update-labels@ takes it. +renderOwnerLabel :: OwnerLabel -> Text +renderOwnerLabel o = o.ownerKey <> "=" <> o.ownerValue + +-- | Whose a service of the declared name is, as far as its labels say. +data Ownership + = -- | no service has the name + Absent + | -- | the service carries the label + Ours + | -- | a service has the name and not the label + Foreign + | -- | the listing failed or was not what this module reads + Undetermined Text + deriving (Eq, Show) + -- | Nothing set: the same deploy this module made before these knobs existed. defaultCloudRunOptions :: CloudRunOptions defaultCloudRunOptions = @@ -126,6 +193,9 @@ , croPort = Nothing , croAllowUnauthenticated = False , croInvokerIamCheckDisabled = False + , croMinInstances = Nothing + , croCpuAlwaysAllocated = False + , croOwner = Nothing } -- | A CloudRun service. @@ -151,18 +221,67 @@ op "gcp-cloudrun-service" nodeps $ \actions -> actions { help = Text.unwords ["deploys CloudRun service", svc.crsName] + , notes = + [ "owned through the label " <> renderOwnerLabel owner <> ": a service of this name without it is neither deployed over nor deleted" + | Just owner <- [svc.crsOptions.croOwner] + ] , ref = mkRef "gcp-cloudrun-service" (svc.crsProject.projectId, svc.crsRegion.regionName, svc.crsName) - , up = Core.retryingIO Core.afterEnableRetries Core.afterEnableDelay (deploy r') + , up = refusingForeign >> 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') + down = case svc.crsOptions.croOwner of + Nothing -> Core.downIfPresent (uncurry interpretServicePresence <$> describeService) (delete r') + Just owner -> deletingOurs owner (delete r') , check = checkService } where r' = contramap (RunCloudRunCommand (RunDeploy svc)) r + -- Asked through a listing, not @describe@: a listing that finds nothing + -- exits 0 with an empty array, where a failed @describe@ cannot be told + -- from a service that is not there. + readOwnership :: OwnerLabel -> IO Ownership + readOwnership owner = do + (code, out, _err) <- + readCreateProcessWithExitCode + (prepare cloudRunCommand (RunListNamed svc)) + "" + pure (interpretOwnership owner svc.crsName code (Text.decodeUtf8With TextError.lenientDecode out)) + + refusingForeign :: IO () + refusingForeign = case svc.crsOptions.croOwner of + Nothing -> pure () + Just owner -> do + ownership <- readOwnership owner + case ownership of + Absent -> pure () + Ours -> pure () + Foreign -> + throwIO . userError . Text.unpack $ + "a CloudRun service named " + <> svc.crsName + <> " exists without the label " + <> renderOwnerLabel owner + <> "; refusing to deploy over a service this declaration did not make" + Undetermined why -> + throwIO . userError . Text.unpack $ + "could not establish whose CloudRun service " <> svc.crsName <> " is (" <> why <> "); not deploying" + + deletingOurs :: OwnerLabel -> IO () -> IO () + deletingOurs owner act = do + ownership <- readOwnership owner + case ownership of + Ours -> act + Absent -> pure () + -- somebody else's: not this node's to remove, and nothing of + -- this node's is left standing + Foreign -> pure () + Undetermined why -> + throwIO . userError . Text.unpack $ + "could not establish whose CloudRun service " <> svc.crsName <> " is (" <> why <> "); not deleting" + describeService :: IO (ExitCode, Text) describeService = do (code, out, _err) <- @@ -178,7 +297,7 @@ 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 +four 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 @@ -190,6 +309,11 @@ a different value or is missing. Variables bound from Secret Manager ('croSecrets') have no @value@ and are the secrets' business, not compared here. +* __the scaling knobs, when declared__: 'croMinInstances' against the + template's @autoscaling.knative.dev/minScale@ annotation (absent reads as + 0) and 'croCpuAlwaysAllocated' against @run.googleapis.com/cpu-throttling@ + being @false@. An undeclared knob is not compared, the same way it is not + passed to the deploy, so whatever the service has is left alone. 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 @@ -205,21 +329,59 @@ 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) + Just tmpl + | Just owner <- svc.crsOptions.croOwner + , Map.lookup owner.ownerKey (labelsOf v) /= Just owner.ownerValue -> + Failure ("CloudRun service found without the label " <> renderOwnerLabel owner <> ": not made by this declaration") + | otherwise -> case drifts svc tmpl of + [] -> Success + ds -> Failure ("CloudRun service found but differs from what is declared: " <> Text.intercalate "; " ds) +-- | A service's own labels (@metadata.labels@), GCP's included. +labelsOf :: Value -> Map Text Text +labelsOf v = case objectField "metadata" v >>= objectField "labels" of + Just (Object o) -> Map.fromList [(Key.toText k, t) | (k, String t) <- KeyMap.toList o] + _ -> Map.empty + +objectField :: Text -> Value -> Maybe Value +objectField k (Object o) = KeyMap.lookup (Key.fromText k) o +objectField _ _ = Nothing + +{- | The verdict drawn from @gcloud run services list --filter +metadata.name=NAME --format=json@: its exit code and output, the declared +label and the declared name. + +The filter is not trusted to be exact: only the entries whose +@metadata.name@ /is/ the name count, so a listing that matched more (a +substring, a prefix) does not make somebody else's service ours, nor ours +somebody else's. +-} +interpretOwnership :: OwnerLabel -> Text -> ExitCode -> Text -> Ownership +interpretOwnership _ _ (ExitFailure n) _ = Undetermined ("listing exited " <> Text.pack (show n)) +interpretOwnership owner name ExitSuccess outText = + case eitherDecodeStrict (Text.encodeUtf8 outText) of + Right (Array entries) -> + case [e | e <- toList entries, (objectField "metadata" e >>= objectField "name") == Just (String name)] of + [] -> Absent + named + | all ((== Just owner.ownerValue) . Map.lookup owner.ownerKey . labelsOf) named -> Ours + | otherwise -> Foreign + _ -> Undetermined "the listing is not a JSON array" + -- | 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 + , tmplAnnotations :: Map Text Text + -- ^ the template's @metadata.annotations@, where the scaling knobs live } templateOf :: Value -> Maybe Template templateOf v = do - spec <- field "spec" v >>= field "template" >>= field "spec" + tmpl <- field "spec" v >>= field "template" + spec <- field "spec" tmpl let container = case field "containers" spec of Just (Array cs) | (c : _) <- toList cs -> Just c _ -> Nothing @@ -234,6 +396,9 @@ { tmplImage = textOf =<< (container >>= field "image") , tmplServiceAccount = textOf =<< field "serviceAccountName" spec , tmplEnv = Map.fromList (mapMaybe plain envEntries) + , tmplAnnotations = case field "metadata" tmpl >>= field "annotations" of + Just (Object o) -> Map.fromList [(Key.toText k, t) | (k, String t) <- KeyMap.toList o] + _ -> Map.empty } where field k (Object o) = KeyMap.lookup (Key.fromText k) o @@ -255,6 +420,15 @@ , [ "environment variable " <> k <> " is " <> why | (k, why) <- envDrift ] + , [ "min instances is " <> got <> ", not " <> Text.pack (show n) + | Just n <- [svc.crsOptions.croMinInstances] + , let got = Map.findWithDefault "0" "autoscaling.knative.dev/minScale" t.tmplAnnotations + , got /= Text.pack (show n) + ] + , [ "CPU is throttled outside requests, not always allocated" + | svc.crsOptions.croCpuAlwaysAllocated + , Map.lookup "run.googleapis.com/cpu-throttling" t.tmplAnnotations /= Just "false" + ] ] where shown = maybe "unset" id @@ -274,6 +448,8 @@ = RunDeploy CloudRunService | RunDescribe CloudRunService | RunDelete CloudRunService + | -- | the services of the region that have this one's name: none, or one + RunListNamed CloudRunService deriving (Show) {- | The @--set-secrets@ family. One flag carrying every binding, not one @@ -294,6 +470,9 @@ , maybe [] (\v -> ["--port", show v]) opts.croPort , ["--allow-unauthenticated" | opts.croAllowUnauthenticated] , ["--no-invoker-iam-check" | opts.croInvokerIamCheckDisabled] + , maybe [] (\v -> ["--min-instances", show v]) opts.croMinInstances + , ["--no-cpu-throttling" | opts.croCpuAlwaysAllocated] + , maybe [] (\o -> ["--update-labels", Text.unpack (renderOwnerLabel o)]) opts.croOwner ] cloudRunCommand :: Command "gcloud" CloudRunCommand @@ -337,5 +516,17 @@ , "delete" , Text.unpack svc.crsName , "--quiet" + ] + ) + RunListNamed svc -> + gcloudProc $ + withProject svc.crsProject + ( withRegion svc.crsRegion + [ "run" + , "services" + , "list" + , "--filter" + , "metadata.name=" <> Text.unpack svc.crsName + , "--format=json" ] ) diff --git a/src/Salmon/Builtin/Nodes/Gcp/Compute.hs b/src/Salmon/Builtin/Nodes/Gcp/Compute.hs --- a/src/Salmon/Builtin/Nodes/Gcp/Compute.hs +++ b/src/Salmon/Builtin/Nodes/Gcp/Compute.hs @@ -2,641 +2,1606 @@ 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 - ] + renderMachineType, + MachineTypeChange (..), + MachineTypeVerdict (..), + machineTypeName, + parseLiveMachineType, + compareMachineType, + interpretInstanceMachineType, + InstanceStep (..), + instanceUpSteps, + planExistingInstance, + planAbsentInstance, + RunLimit (..), + LiveRunLimit (..), + RunLimitVerdict (..), + runLimitGrace, + runLimitProblems, + runLimitArgs, + renderRunLimit, + renderDeadline, + parseLiveRunLimit, + judgeRunLimit, + interpretInstanceRun, + BootDisk (..), + Instance (..), + InstancePower (..), + ExternalAddress (..), + InternalAddress (..), + AccessScopes (..), + scopeAliases, + scopeUris, + scopeProblems, + declaredScopeUris, + parseLiveScopes, + interpretInstanceScopes, + gceInstance, + Address (..), + AddressKind (..), + address, + readAddress, + interpretAddressDescribe, + interpretAddress, + FirewallRule (..), + firewallRule, + interpretFirewallDescribe, + SubnetPurpose (..), + renderSubnetPurpose, + Subnet (..), + subnet, + interpretSubnetDescribe, + InstanceGroup (..), + instanceGroup, + interpretInstanceGroupDescribe, + instanceGroupMember, + interpretGroupMembership, + interpretInstanceStatus, + interpretInstancePresence, + InstanceUpPlan (..), + planInstanceUp, + Report (..), + ComputeCommand (..), + computeCommand, +) where + +import Control.Applicative ((<|>)) +import Control.Exception (throwIO) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Map (Map) +import qualified Data.Map 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.Encoding as Text +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Time.Format.ISO8601 (iso8601ParseM) +import Data.Time.LocalTime (zonedTimeToUTC) +import Text.Read (readMaybe) +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 + +{- | What 'gceInstance' may do about an existing instance whose machine type +is not the declared one. GCP only changes a machine type on a stopped +instance, so reconciling one means an outage (about two minutes from stop to +serving, on the one resize this was written after), and that is the +declaration's to permit, never the node's to decide. + +'RefuseMachineTypeChange' is what every declaration should start from: the +difference is a 'Failure' for the check and a throw for @up@, both naming +the running and the declared type, and nothing is stopped, started or +re-created. The remedy is then the operator's: stop it, @gcloud compute +instances set-machine-type NAME --machine-type T@, start it; or declare +'MayStopToResize'. + +'MayStopToResize' lets @up@ do exactly that: stop the instance if it runs, +set the type, and start it again when the declaration is 'PoweredOn' (a +'PoweredOff' one stays stopped). It is a standing permission, not a one-off: +while it is declared, any later change of 'instanceMachineType' stops the +machine again, under @run serve@ as soon as the check notices. +-} +data MachineTypeChange + = -- | fail the node, naming both types; never stop anything + RefuseMachineTypeChange + | -- | stop, @set-machine-type@, start + MayStopToResize + deriving (Eq, Show) + +{- | The name a machine type goes by, whether it was written as a bare name +or as the URL (or partial path) GCP describes it with: +@.../zones/Z/machineTypes/e2-medium@ is @e2-medium@. +-} +machineTypeName :: Text -> Text +machineTypeName = Text.takeWhileEnd (/= '/') . Text.strip + +{- | The machine type in the output of @describe +--format=value(machineType.basename())@: one word, read by its last path +segment so that the full URL (should the projection ever not apply) is the +same answer. Anything else -- no word, several, or one that does not look +like a machine type name -- is a 'Left' saying so, because under +'MayStopToResize' a misread output must never be taken for a difference +worth stopping a machine over. +-} +parseLiveMachineType :: Text -> Either Text Text +parseLiveMachineType out = + case Text.words out of + [word] + | name <- machineTypeName word + , not (Text.null name) + , Text.all isNameChar name -> + Right name + _ -> Left ("no machine type could be read in " <> Text.pack (show out)) + where + isNameChar c = (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') || c == '-' + +-- | An existing instance's machine type against the declared one. +data MachineTypeVerdict + = MachineTypeAsDeclared + | -- | the running one, then the declared one + MachineTypeDiffers Text Text + | -- | the describe failed or could not be read: nothing is known, so nothing is changed + MachineTypeUndetermined Text + deriving (Eq, Show) + +-- | Compares names exactly: GCP has no two spellings of one machine type. +compareMachineType :: MachineType -> ExitCode -> Text -> MachineTypeVerdict +compareMachineType _ (ExitFailure n) _ = + MachineTypeUndetermined ("could not describe the machine type (exit " <> Text.pack (show n) <> ")") +compareMachineType declared ExitSuccess out = + case parseLiveMachineType out of + Left why -> MachineTypeUndetermined why + Right live + | live == wanted -> MachineTypeAsDeclared + | otherwise -> MachineTypeDiffers live wanted + where + wanted = machineTypeName (renderMachineType declared) + +{- | Why an instance is not as declared, worded to follow @instance NAME@: +the check and @up@ say the same thing. Both types are named in every case. +-} +machineTypeReason :: MachineTypeChange -> Text -> Text -> Text +machineTypeReason change live wanted = + "runs machine type " <> live <> ", declared " <> wanted <> "; " <> case change of + RefuseMachineTypeChange -> + "a machine type only changes on a stopped instance and this declaration does not permit stopping it:" + <> " stop it and run gcloud compute instances set-machine-type, or declare MayStopToResize" + MayStopToResize -> "the declaration permits stopping it to resize" + +{- | The check's verdict on an existing instance's machine type: 'Success' +when it is the declared one, a 'Failure' naming both otherwise, and a +'Failure' too when it could not be read. Under 'RefuseMachineTypeChange' the +node never repairs that failure; under 'MayStopToResize' its @up@ does. +-} +interpretInstanceMachineType :: MachineTypeChange -> MachineType -> ExitCode -> Text -> CheckResult +interpretInstanceMachineType change declared code out = + case compareMachineType declared code out of + MachineTypeAsDeclared -> Success + MachineTypeDiffers live wanted -> Failure ("instance " <> machineTypeReason change live wanted) + MachineTypeUndetermined why -> Failure why + +{- | How long an instance may run before GCP turns it off by itself (the +termination action is always @STOP@: the instance, its disks and its +addresses stay, and only what a stopped instance bills for is billed). + +'NoRunLimit' passes nothing and asks nothing: it is what every instance was +before this type existed. + +'MaxRunDuration' is a number of seconds counted by GCP from each start +(@--max-run-duration@; GCP accepts 30 seconds to 120 days, see +'runLimitProblems'). 'RunUntil' is one date for the life of the instance +(@--termination-time@), compared and rendered to the second. + +With a limit declared, 'gceInstance' reads it back from an instance that +exists ('judgeRunLimit') and, once the deadline has passed, an instance that +is @TERMINATED@ /is/ the declared state of a 'PoweredOn' declaration: the +check is satisfied and @up@ does not start it. See 'RunLimitVerdict' for +every case, and 'planExistingInstance' for what @up@ then does. + +__Starting an expired instance again is a new declaration__: another +duration or a later date, which @up@ sets on the stopped instance before +starting it. For a duration, starting it by hand does the same, since the +deadline is counted from the last start. A forced @up@ of an unchanged +declaration starts nothing. +-} +data RunLimit + = -- | say nothing: the instance runs until something stops it + NoRunLimit + | -- | this many seconds after each start + MaxRunDuration Integer + | -- | until this date + RunUntil UTCTime + deriving (Eq, Show) + +-- | Everything wrong with a run limit declaration; empty for 'NoRunLimit'. +runLimitProblems :: RunLimit -> [Text] +runLimitProblems limit = case limit of + MaxRunDuration seconds + | seconds < 30 || seconds > 120 * 86400 -> + ["a maximum run duration of " <> Text.pack (show seconds) <> "s (GCP accepts 30s to 120 days)"] + _ -> [] + +-- | A date the way it is given to gcloud and written in reports: UTC, to the second. +renderDeadline :: UTCTime -> Text +renderDeadline = Text.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" + +-- | A declared limit in words, for the notes and the reasons. +renderRunLimit :: RunLimit -> Text +renderRunLimit limit = case limit of + NoRunLimit -> "none" + MaxRunDuration seconds -> Text.pack (show seconds) <> "s after each start, then stopped by GCP" + RunUntil date -> "until " <> renderDeadline date <> ", then stopped by GCP" + +{- | The flags a declared limit is at @create@, and at @set-scheduling@ too +(with the other kind of limit cleared there, see 'computeCommand'). Nothing +for 'NoRunLimit'. +-} +runLimitArgs :: RunLimit -> [String] +runLimitArgs limit = case limit of + NoRunLimit -> [] + MaxRunDuration seconds -> ["--max-run-duration", show seconds <> "s", "--instance-termination-action", "STOP"] + RunUntil date -> ["--termination-time", Text.unpack (renderDeadline date), "--instance-termination-action", "STOP"] + +{- | What an instance says of its own run limit, from @describe +--format=json(lastStartTimestamp,scheduling.maxRunDuration.seconds,scheduling.terminationTime,scheduling.instanceTerminationAction)@. +Every field may be absent. + +The deadline GCP computes (@terminationTimestamp@) is deliberately not +read: gcloud's help says it is removed whenever the instance is stopped, +which is exactly when the check needs it, and the v1 API this command speaks +does not carry it. A duration's deadline is 'liveLastStart' plus the +duration instead. +-} +data LiveRunLimit = LiveRunLimit + { liveMaxRunSeconds :: Maybe Integer + , liveTerminationTime :: Maybe UTCTime + , liveTerminationAction :: Maybe Text + , liveLastStart :: Maybe UTCTime + } + deriving (Eq, Show) + +{- | Reads that describe. An output that is not a JSON object, or a field +that is there and cannot be read (a duration that is not a number, a date +that is not RFC 3339), is a 'Left' saying so: a misread limit must never be +taken for an expired one, nor for one worth setting again. +-} +parseLiveRunLimit :: Text -> Either Text LiveRunLimit +parseLiveRunLimit out = + case Aeson.decodeStrict (Text.encodeUtf8 out) of + Just (Aeson.Object top) -> do + let scheduling = case KeyMap.lookup "scheduling" top of + Just (Aeson.Object o) -> o + _ -> KeyMap.empty + seconds <- case KeyMap.lookup "maxRunDuration" scheduling of + Nothing -> Right Nothing + Just Aeson.Null -> Right Nothing + Just (Aeson.Object o) -> optional "scheduling.maxRunDuration.seconds" readSeconds (KeyMap.lookup "seconds" o) + Just other -> unreadable "scheduling.maxRunDuration" other + terminationTime <- optional "scheduling.terminationTime" readDate (KeyMap.lookup "terminationTime" scheduling) + action <- optional "scheduling.instanceTerminationAction" readText (KeyMap.lookup "instanceTerminationAction" scheduling) + lastStart <- optional "lastStartTimestamp" readDate (KeyMap.lookup "lastStartTimestamp" top) + Right (LiveRunLimit seconds terminationTime action lastStart) + _ -> Left ("no run limit could be read in " <> Text.pack (show out)) + where + optional :: Text -> (Aeson.Value -> Maybe a) -> Maybe Aeson.Value -> Either Text (Maybe a) + optional _ _ Nothing = Right Nothing + optional _ _ (Just Aeson.Null) = Right Nothing + optional field readValue (Just value) = maybe (unreadable field value) (Right . Just) (readValue value) + unreadable :: Text -> Aeson.Value -> Either Text a + unreadable field value = Left ("could not read " <> field <> " in " <> Text.pack (show (Aeson.encode value))) + -- an int64 is a string in the API's JSON; a number is accepted as well + readSeconds :: Aeson.Value -> Maybe Integer + readSeconds value = case value of + Aeson.String t -> readMaybe (Text.unpack t) + Aeson.Number n | n == fromInteger (round n) -> Just (round n) + _ -> Nothing + readText value = case value of + Aeson.String t -> Just t + _ -> Nothing + readDate value = case value of + Aeson.String t -> + let s = Text.unpack t + in (iso8601ParseM s :: Maybe UTCTime) <|> (zonedTimeToUTC <$> iso8601ParseM s) + _ -> Nothing + +{- | An existing instance against its declared 'RunLimit', at a given time. + +A deadline is, for 'RunUntil', the declared date; for 'MaxRunDuration', the +instance's last start plus the duration, and only when the instance holds +the declared duration (otherwise no run of it was under this limit). +-} +data RunLimitVerdict + = -- | nothing is declared, so nothing was asked + RunUnlimited + | -- | the instance holds the declared limit and its deadline, this one, is ahead + RunWithin UTCTime + | -- | the deadline passed less than 'runLimitGrace' ago: GCP is stopping + -- the instance, or just did + RunEnding UTCTime + | -- | the deadline passed + RunExpired UTCTime + | -- | the instance holds another limit (or none), and no declared date + -- has passed: what it holds, then what is declared + RunLimitDiffers Text Text + | -- | the describe failed or could not be read: nothing is known, so + -- nothing is started, stopped or set + RunLimitUndetermined Text + deriving (Eq, Show) + +{- | For how long after a deadline a @RUNNING@ instance is still GCP's to +stop rather than a failure. GCP's documentation says the stop may come up to +30 seconds late, and a duration's deadline is computed here from the start +/request/, a little earlier than the moment GCP counts from. +-} +runLimitGrace :: NominalDiffTime +runLimitGrace = 300 + +{- | The verdict, from the declared limit, the current time and the describe +'parseLiveRunLimit' reads. Split out of 'gceInstance' for testability: no +clock is read here. + +A declared date that has passed is 'RunEnding'/'RunExpired' whatever limit +the instance holds: nothing may start it any more, and GCP itself refuses to. +-} +judgeRunLimit :: RunLimit -> UTCTime -> ExitCode -> Text -> RunLimitVerdict +judgeRunLimit NoRunLimit _ _ _ = RunUnlimited +judgeRunLimit _ _ (ExitFailure n) _ = + RunLimitUndetermined ("could not describe the run limit (exit " <> Text.pack (show n) <> ")") +judgeRunLimit limit now ExitSuccess out = + case parseLiveRunLimit out of + Left why -> RunLimitUndetermined why + Right live -> case limit of + NoRunLimit -> RunUnlimited + RunUntil date + | now >= date -> passed date + | holds live && (seconds <$> live.liveTerminationTime) == Just (seconds date) && live.liveMaxRunSeconds == Nothing -> RunWithin date + | otherwise -> differs live + MaxRunDuration duration + | holds live && live.liveMaxRunSeconds == Just duration && live.liveTerminationTime == Nothing -> + case live.liveLastStart of + Nothing -> RunLimitUndetermined "the instance holds the declared run limit and says nothing of its last start" + Just started + | now < deadline -> RunWithin deadline + | otherwise -> passed deadline + where + deadline = addUTCTime (fromInteger duration) started + | otherwise -> differs live + where + seconds :: UTCTime -> Integer + seconds = floor . utcTimeToPOSIXSeconds + holds :: LiveRunLimit -> Bool + holds live = live.liveTerminationAction == Just "STOP" + passed deadline + | now < addUTCTime runLimitGrace deadline = RunEnding deadline + | otherwise = RunExpired deadline + differs :: LiveRunLimit -> RunLimitVerdict + differs live = RunLimitDiffers (renderLive live) (renderRunLimit limit) + renderLive :: LiveRunLimit -> Text + renderLive live = + case (live.liveMaxRunSeconds, live.liveTerminationTime) of + (Nothing, Nothing) -> "none" + (duration, date) -> + Text.intercalate + " and " + ( [Text.pack (show d) <> "s after each start" | Just d <- [duration]] + <> ["until " <> renderDeadline t | Just t <- [date]] + ) + <> ", then " + <> maybe "no declared action" id live.liveTerminationAction + +{- | Why an instance's run limit is not the declared one, worded to follow +@instance NAME@: the check and @up@ say the same thing. +-} +runLimitReason :: Text -> Text -> Text +runLimitReason live wanted = + "holds run limit " + <> live + <> ", declared " + <> wanted + <> "; a run limit is only set on a stopped instance and this node does not stop one for it:" + <> " stop it (the next up sets the limit and starts it), or run gcloud compute instances set-scheduling" + +-- | 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) + +{- | The external (public) address of an instance's one network interface. + +'NoExternalAddress' is a machine nothing outside the VPC can reach and that +cannot reach out either, unless the network has a Cloud NAT: no package +mirror, no container registry. It is the right choice for a machine only its +peers talk to (a database member), and it is fixed at create time like the +rest of the interface. +-} +data ExternalAddress + = -- | one GCP picks at create time and takes back with the instance + EphemeralExternal + | -- | a reserved external 'Address', by name + ReservedExternal Text + | -- | none at all (@--no-address@) + NoExternalAddress + deriving (Eq, Show) + +{- | The internal address of an instance's one network interface. + +'PinnedInternal' is what lets a graph /name/ a machine before it exists: the +address is the caller's choice (it must lie in 'instanceSubnet''s range and +be free), so unlike an external one it is known when the graph is declared +and can go into a peer's @pg_hba.conf@ or a config file in the same pass. +GCP keeps such an address for the life of the instance, across stops and +starts, but hands it to anyone once the instance is deleted; reserving it as +well (an 'Address' of kind 'InternalAddress' carrying the same literal, which +the instance should then depend on) is what keeps it across a re-creation. +-} +data InternalAddress + = -- | whatever GCP picks in the subnet + EphemeralInternal + | -- | this literal (@--private-network-ip@) + PinnedInternal Text + deriving (Eq, Show) + +{- | The access scopes of an instance: the ceiling on what its service +account's tokens, as handed out by the metadata server, may be used for. IAM +decides what the account /may/ do; the scopes decide how much of that a +process on the machine gets, so an account allowed to write to a bucket +still cannot from an instance holding gcloud's default scopes (storage +read-only). + +'DefaultScopes' passes nothing and is what every instance was before this +type existed. 'DeclaredScopes' lists them, each either one of gcloud's +aliases ('scopeAliases': @storage-rw@, @cloud-platform@, ...) or a full +@https://www.googleapis.com/auth/...@ URI; the empty list is no scope at all +(@--no-scopes@). + +__Scopes are read at create time and never changed by this node.__ GCP only +lets them change on a stopped instance, so on an existing instance holding +other scopes than the declared ones the check is a 'Failure' naming both +sets and @up@ throws the same words without starting, stopping or +re-creating anything: stopping a machine is an operator's decision. The +remedy is theirs too -- stop it, @gcloud compute instances +set-service-account NAME --scopes ...@, start it; or take the node down and +up again, which deletes the instance. +-} +data AccessScopes + = -- | say nothing: gcloud's defaults for the service account + DefaultScopes + | -- | exactly these, aliases or URIs (@[]@ is @--no-scopes@) + DeclaredScopes [Text] + deriving (Eq, Show) + +{- | gcloud's scope aliases and the URIs they stand for, as documented for +@gcloud compute instances create --scopes@. The instance is described back +with URIs only, so the check needs this table to compare; the create command +is given the declared spelling, so if gcloud and this table ever disagree +about an alias the check says so (a 'Failure' naming both sets) rather than +an instance quietly holding something else. +-} +scopeAliases :: Map Text [Text] +scopeAliases = + Map.fromList + [ ("bigquery", [auth "bigquery"]) + , ("cloud-platform", [auth "cloud-platform"]) + , ("cloud-source-repos", [auth "source.full_control"]) + , ("cloud-source-repos-ro", [auth "source.read_only"]) + , ("compute-ro", [auth "compute.readonly"]) + , ("compute-rw", [auth "compute"]) + , ("datastore", [auth "datastore"]) + , + ( "default" + , map + auth + [ "devstorage.read_only" + , "logging.write" + , "monitoring.write" + , "pubsub" + , "service.management.readonly" + , "servicecontrol" + , "trace.append" + ] + ) + , ("logging-write", [auth "logging.write"]) + , ("monitoring", [auth "monitoring"]) + , ("monitoring-read", [auth "monitoring.read"]) + , ("monitoring-write", [auth "monitoring.write"]) + , ("pubsub", [auth "pubsub"]) + , ("service-control", [auth "servicecontrol"]) + , ("service-management", [auth "service.management.readonly"]) + , ("sql-admin", [auth "sqlservice.admin"]) + , ("storage-full", [auth "devstorage.full_control"]) + , ("storage-ro", [auth "devstorage.read_only"]) + , ("storage-rw", [auth "devstorage.read_write"]) + , ("taskqueue", [auth "taskqueue"]) + , ("trace", [auth "trace.append"]) + , ("userinfo-email", [auth "userinfo.email"]) + ] + where + auth t = "https://www.googleapis.com/auth/" <> t + +{- | The URIs one declared scope stands for, or why it cannot be declared: a +full @https://@ URI is itself, an alias is looked up, anything else is +refused here rather than by gcloud half-way through a pass. +-} +scopeUris :: Text -> Either Text [Text] +scopeUris scope + | Text.null scope = Left "an empty scope" + | Text.any (`elem` separators) scope = Left ("scope " <> Text.pack (show scope) <> " holds a separator") + | "https://" `Text.isPrefixOf` scope = Right [scope] + | otherwise = + maybe + (Left ("unknown scope alias " <> scope <> " (spell it as a full https://www.googleapis.com/auth/... URI)")) + Right + (Map.lookup scope scopeAliases) + where + separators = ", ;\t\n" :: String + +-- | Everything wrong with a scope declaration; empty for 'DefaultScopes'. +scopeProblems :: AccessScopes -> [Text] +scopeProblems DefaultScopes = [] +scopeProblems (DeclaredScopes scopes) = [problem | Left problem <- map scopeUris scopes] + +{- | The set of URIs a declaration asks for; 'Nothing' when nothing is +declared (nothing to compare) or the declaration has 'scopeProblems'. +-} +declaredScopeUris :: AccessScopes -> Maybe (Set Text) +declaredScopeUris DefaultScopes = Nothing +declaredScopeUris (DeclaredScopes scopes) = Set.fromList . concat <$> traverse (either (const Nothing) Just . scopeUris) scopes + +{- | The scope URIs in the output of @describe +--format=value(serviceAccounts[].scopes)@. Only the @https://@ words are +kept, whatever separates them, because how gcloud flattens a list of lists +has not been observed; an instance with no service account yields none. +-} +parseLiveScopes :: Text -> Set Text +parseLiveScopes = + Set.fromList + . filter ("https://" `Text.isPrefixOf`) + . Text.split (`elem` (",; \t\r\n'\"[]" :: String)) + +{- | The verdict on an existing instance's scopes against the declared ones: +'Success' when nothing is declared or the two sets are equal, a 'Failure' +naming both otherwise. Never a reason to act: see 'AccessScopes'. +-} +interpretInstanceScopes :: AccessScopes -> ExitCode -> Text -> CheckResult +interpretInstanceScopes DefaultScopes _ _ = Success +interpretInstanceScopes scopes@(DeclaredScopes _) code out = + case (declaredScopeUris scopes, code) of + (Nothing, _) -> Failure ("scopes cannot be declared: " <> Text.intercalate "; " (scopeProblems scopes)) + (_, ExitFailure n) -> Failure ("could not describe instance scopes (exit " <> Text.pack (show n) <> ")") + (Just wanted, ExitSuccess) + | wanted == live -> Success + | otherwise -> + Failure + ( "instance holds scopes " + <> renderSet live + <> ", declared " + <> renderSet wanted + <> "; scopes only change on a stopped instance and this node does not stop one:" + <> " stop it and run gcloud compute instances set-service-account, or re-create it" + ) + where + live = parseLiveScopes out + where + renderSet s + | Set.null s = "(none)" + | otherwise = Text.intercalate "," (Set.toList s) + +-- | 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 + -- ^ compared, by name, with what an existing instance runs: a difference + -- is never left silently, see 'instanceMachineTypeChange' + , 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. + , instanceExternalAddress :: ExternalAddress + -- ^ reserved by name (see 'address'), ephemeral, or none + , instanceInternalAddress :: InternalAddress + -- ^ pinned to a declared literal, or left to GCP. Like the rest of the + -- interface it is only read at create time: 'gceInstance''s check looks + -- at the instance's status, so an existing instance holding another + -- address is not noticed and not changed. + , instanceTags :: [Text] + , instanceScopes :: AccessScopes + -- ^ the access scopes, or gcloud's defaults. Create-time only, and + -- unlike the addresses a difference on an existing instance /is/ + -- noticed, as a 'Failure' the node never repairs: see 'AccessScopes'. + , instanceMachineTypeChange :: MachineTypeChange + -- ^ whether @up@ may stop an existing instance to give it the declared + -- machine type, or fails naming both types ('RefuseMachineTypeChange', + -- which renders nothing) + , instanceRunLimit :: RunLimit + -- ^ how long the instance may run before GCP stops it; once that + -- deadline has passed a stopped instance is the declared state and is + -- not started ('NoRunLimit' renders nothing and asks nothing) + } + 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, +-- runs the declared machine type and, when 'instanceScopes' declares +-- some, holds exactly those. +-- +-- An existing instance running another machine type than the declared one is +-- a 'Failure' naming both. What @up@ does then is 'instanceMachineTypeChange': +-- it throws the same words without touching the machine, or, permitted to, +-- stops it, sets the type and starts it again ('planExistingInstance'). +-- +-- Declared scopes that differ from an existing instance's are a 'Failure' +-- for the check and a throw for @up@, before it starts or stops anything; +-- undeclarable ones ('scopeProblems') are the same before any call. +-- +-- With an 'instanceRunLimit', GCP stops the instance at its deadline and the +-- node accepts that: after the deadline a @TERMINATED@ instance satisfies a +-- 'PoweredOn' declaration and @up@ starts nothing ('interpretInstanceRun', +-- 'planExistingInstance'). A limit that differs on an existing instance is +-- set when the instance is stopped and is a 'Failure' naming both otherwise. +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 (InstancesSetMachineType inst) $ \setType -> + withBinary gcloudTrack computeCommand (InstancesSetScheduling inst) $ \setScheduling -> + withBinary gcloudTrack computeCommand (InstancesDelete inst) $ \delete -> + op "gcp-instance" nodeps $ \actions -> + actions + { help = Text.unwords [verb, "GCE instance", inst.instanceName] + , notes = actions.notes <> scopeNotes <> resizeNotes <> runLimitNotes + , ref = mkRef "gcp-instance" (inst.instanceProject.projectId, inst.instanceZone.zoneName, inst.instanceName) + , up = bringUp create start resume stop setType setScheduling + , -- presence, not state: a stopped instance is still there to delete + down = Core.downIfPresent (uncurry interpretInstancePresence <$> describeStatus) (delete (contramap (RunComputeCommand (InstancesDelete inst)) r)) + , check = checkInstance + } + where + rFor cmd = contramap (RunComputeCommand cmd) r + + -- in the notes so that a re-declaration with other scopes is a changed + -- node under @run serve@; nothing at all when none is declared + scopeNotes = case inst.instanceScopes of + DefaultScopes -> [] + DeclaredScopes [] -> ["scopes: none"] + DeclaredScopes scopes -> ["scopes: " <> Text.intercalate "," scopes] + + -- only with the permission, so that a declaration without it has the + -- notes it had; with it, a re-declared type is a changed node under + -- @run serve@ + resizeNotes = case inst.instanceMachineTypeChange of + RefuseMachineTypeChange -> [] + MayStopToResize -> ["machine type: " <> machineTypeName (renderMachineType inst.instanceMachineType) <> " (may stop to resize)"] + + -- in the notes so that a re-declared limit is a changed node under + -- @run serve@; nothing at all when none is declared + runLimitNotes = case inst.instanceRunLimit of + NoRunLimit -> [] + limit -> ["run limit: " <> renderRunLimit limit] + + declarationProblems :: [Text] + declarationProblems = + ["scopes cannot be declared: " <> Text.intercalate "; " problems | problems@(_ : _) <- [scopeProblems inst.instanceScopes]] + <> ["run limit cannot be declared: " <> Text.intercalate "; " problems | problems@(_ : _) <- [runLimitProblems inst.instanceRunLimit]] + + -- the clock is read here and nowhere else; with no limit declared + -- neither it nor the instance is asked anything + judgeRun :: IO RunLimitVerdict + judgeRun = case inst.instanceRunLimit of + NoRunLimit -> pure RunUnlimited + limit -> do + (code, out, _err) <- + readCreateProcessWithExitCode + (prepare computeCommand (InstancesDescribeRunLimit inst)) + "" + now <- getCurrentTime + pure (judgeRunLimit limit now code (Text.decodeUtf8 out)) + + -- the status first, as before; the scopes, the machine type and the run + -- limit are only asked of an instance that is there: the scopes and the + -- limit when declared, the machine type always (one more describe each) + checkInstance = case declarationProblems of + problems@(_ : _) -> pure (Failure (Text.intercalate "; " problems)) + [] -> do + (code, status) <- describeStatus + case code of + ExitFailure _ -> pure (interpretInstanceStatus inst.instancePower code status) + ExitSuccess -> do + scopes <- case inst.instanceScopes of + DeclaredScopes _ -> describeScopes + DefaultScopes -> pure Success + case scopes of + Success -> do + (typeCode, typeOut) <- describeMachineType + case interpretInstanceMachineType inst.instanceMachineTypeChange inst.instanceMachineType typeCode typeOut of + Success -> do + run <- judgeRun + pure (interpretInstanceRun inst.instancePower run code status) + differing -> pure differing + differing -> pure differing + + describeMachineType :: IO (ExitCode, Text) + describeMachineType = do + (code, out, _err) <- + readCreateProcessWithExitCode + (prepare computeCommand (InstancesDescribeMachineType inst)) + "" + pure (code, Text.decodeUtf8 out) + + describeScopes :: IO CheckResult + describeScopes = do + (code, out, _err) <- + readCreateProcessWithExitCode + (prepare computeCommand (InstancesDescribeScopes inst)) + "" + pure (interpretInstanceScopes inst.instanceScopes code (Text.decodeUtf8 out)) + + refuse reason = throwIO (userError ("instance " <> Text.unpack inst.instanceName <> ": " <> Text.unpack reason)) + + 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 setType setScheduling = do + case declarationProblems of + [] -> pure () + problems -> refuse (Text.intercalate "; " problems) + (code, status) <- describeStatus + let plan = planInstanceUp inst.instancePower code status + -- an instance that exists with other scopes is left exactly as it + -- is: no start, no stop, and certainly no re-creation + case (plan, inst.instanceScopes) of + (CreateInstance, _) -> pure () + (_, DefaultScopes) -> pure () + (_, DeclaredScopes _) -> do + scopes <- describeScopes + case scopes of + Failure reason -> refuse reason + _ -> pure () + -- the machine type is only asked of an instance that is there, and + -- the whole sequence is decided before its first step: a refusal + -- leaves the machine exactly as it is + steps <- case plan of + CreateInstance -> planAbsentInstance inst.instanceRunLimit inst.instancePower <$> getCurrentTime + _ -> do + typeVerdict <- uncurry (compareMachineType inst.instanceMachineType) <$> describeMachineType + planExistingInstance inst.instanceMachineTypeChange inst.instancePower status typeVerdict <$> judgeRun + case steps of + Left reason -> throwIO (userError ("instance " <> Text.unpack inst.instanceName <> " " <> Text.unpack reason)) + Right todo -> mapM_ runStep todo + where + runStep step = case step of + CreateStep -> create (rFor (InstancesCreate inst)) + StartStep -> start (rFor (InstancesStart inst)) + ResumeStep -> resume (rFor (InstancesResume inst)) + StopStep -> stop (rFor (InstancesStop inst)) + SetMachineTypeStep -> setType (rFor (InstancesSetMachineType inst)) + SetSchedulingStep -> setScheduling (rFor (InstancesSetScheduling inst)) + +-- | 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) + +{- | The check's verdict on an existing instance's status given the verdict +on its run limit: 'interpretInstanceStatus' with the deadline taken into +account. Split out of 'gceInstance' for testability. + +* Nothing declared, or the limit in place with its deadline ahead: exactly + 'interpretInstanceStatus'. +* The deadline has passed and the declaration is 'PoweredOn': @TERMINATED@ + is 'Success' (the instance ran its allotted time); @RUNNING@ is 'Unknown' + for 'runLimitGrace' (GCP is stopping it) and then a 'Failure' naming the + deadline; any other status is what 'interpretInstanceStatus' says. +* A 'PoweredOff' declaration is not changed by a deadline. +* The instance holds another limit: a 'Failure' naming both (a transitional + status stays 'Unknown'). +* The limit could not be read: a 'Failure' saying so, never a pass. +-} +interpretInstanceRun :: InstancePower -> RunLimitVerdict -> ExitCode -> Text -> CheckResult +interpretInstanceRun power run code status = case (code, run) of + (ExitFailure _, _) -> asBefore + (_, RunUnlimited) -> asBefore + (_, RunWithin _) -> asBefore + (_, RunLimitUndetermined why) -> Failure why + (_, RunLimitDiffers live wanted) -> case asBefore of + Unknown -> Unknown + _ -> Failure ("instance " <> runLimitReason live wanted) + (_, RunEnding deadline) -> after deadline True + (_, RunExpired deadline) -> after deadline False + where + asBefore = interpretInstanceStatus power code status + after deadline ending = case (power, status) of + (PoweredOn, "TERMINATED") -> Success + (PoweredOn, "RUNNING") + | ending -> Unknown + | otherwise -> Failure ("instance is RUNNING past its run limit (deadline " <> renderDeadline deadline <> ")") + _ -> asBefore + +-- | 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 + +-- | One gcloud call of 'gceInstance'\'s @up@. +data InstanceStep + = CreateStep + | StartStep + | ResumeStep + | StopStep + | SetMachineTypeStep + | -- | @set-scheduling@ with the declared 'RunLimit'; only on a stopped instance + SetSchedulingStep + deriving (Eq, Show) + +{- | The calls a plan stands for, or why none is made (worded to follow +@instance NAME@). A created instance runs, so a stopped declaration stops it +right after. +-} +instanceUpSteps :: InstancePower -> InstanceUpPlan -> Either Text [InstanceStep] +instanceUpSteps power plan = case plan of + CreateInstance -> Right (CreateStep : [StopStep | power == PoweredOff]) + StartInstance -> Right [StartStep] + ResumeInstance -> Right [ResumeStep] + StopInstance -> Right [StopStep] + AlreadyThere -> Right [] + CannotActYet status -> Left ("is " <> status <> "; retry once it settles") + +{- | What @up@ does when there is no instance: create it, unless its +declared date has already passed (GCP refuses a termination time in the +past, and a machine that may no longer run is not one to create). +-} +planAbsentInstance :: RunLimit -> InstancePower -> UTCTime -> Either Text [InstanceStep] +planAbsentInstance limit power now = case limit of + RunUntil date + | now >= date -> Left ("is absent and its declared deadline " <> renderDeadline date <> " has passed: it is not created") + _ -> instanceUpSteps power CreateInstance + +{- | What @up@ does to an instance that exists, in the given status, given +the verdicts on its machine type and on its run limit. Split out of +'gceInstance' for testability; this is the one place a resize, a start past +a deadline and a change of limit are decided. + +The machine type first, as if there were no limit: + +* The type is as declared: exactly what 'planInstanceUp' says, whatever the + permission. +* It could not be read: nothing, and a reason. Not knowing is never a reason + to stop a machine, nor to report it converged. +* It differs and the declaration is 'RefuseMachineTypeChange': nothing, and + a reason naming both types, even when the instance happens to be stopped + (the declaration did not ask for its type to be changed). +* It differs and the declaration is 'MayStopToResize': stop it if @RUNNING@, + set the type, start it if the declaration is 'PoweredOn'. Any other status + (transitional, or @SUSPENDED@, which GCP does not resize) is a reason and + no call. + +If a step fails the ones after it are not run: a failed @set-machine-type@ +leaves the instance stopped, and the next pass, finding it @TERMINATED@ with +the old type, sets the type and starts it. + +Then the run limit decides what of that is kept: + +* None declared ('RunUnlimited'), or in place with its deadline ahead + ('RunWithin'): all of it, unchanged. +* It could not be read: nothing, and a reason. +* The deadline has passed and the declaration is 'PoweredOn': __nothing + starts, resumes or stops the instance__. A @TERMINATED@ one gets the plan + without its start, so a permitted resize still sets the type and leaves + the machine off; any other status is a reason and no call (GCP stops a + @RUNNING@ one itself; this node never stops a machine declared running). + A 'PoweredOff' declaration never starts anything and is not changed. +* The instance holds another limit: @set-scheduling@ is added where the plan + has the machine stopped -- first on a @TERMINATED@ instance, right after + the stop when the plan (a 'PoweredOff' declaration, a permitted resize) + already stops a @RUNNING@ one. A machine is never stopped for its limit: + otherwise a reason naming both limits and no call. + +A failed start after a successful @set-scheduling@ leaves a stopped instance +holding the declared limit: for a duration, if its previous start is more +than that duration ago, the next pass reads it as expired and leaves it off +(start it by hand, or declare another duration). +-} +planExistingInstance :: MachineTypeChange -> InstancePower -> Text -> MachineTypeVerdict -> RunLimitVerdict -> Either Text [InstanceStep] +planExistingInstance change power status verdict run = case run of + RunUnlimited -> typed + RunWithin _ -> typed + RunLimitUndetermined why -> Left ("is left as it is: " <> why) + RunLimitDiffers live wanted -> case (status, typed) of + (_, Left why) -> Left why + ("TERMINATED", Right steps) -> Right (SetSchedulingStep : steps) + ("RUNNING", Right (StopStep : steps)) -> Right (StopStep : SetSchedulingStep : steps) + _ -> Left (runLimitReason live wanted) + RunEnding deadline -> after deadline True + RunExpired deadline -> after deadline False + where + after deadline ending = case (power, status) of + (PoweredOff, _) -> typed + (PoweredOn, "TERMINATED") -> filter (/= StartStep) <$> typed + (PoweredOn, "RUNNING") + | ending -> Left ("is RUNNING at its deadline " <> renderDeadline deadline <> ", when GCP stops it: retry once it settles") + | otherwise -> + Left + ( "is RUNNING past its run limit (deadline " + <> renderDeadline deadline + <> "); this node does not stop a machine declared running: stop it, or declare a later limit" + ) + (PoweredOn, _) -> Left ("is " <> status <> " past its deadline " <> renderDeadline deadline <> ": it is not started") + typed = case verdict of + MachineTypeAsDeclared -> instanceUpSteps power (planInstanceUp power ExitSuccess status) + MachineTypeUndetermined why -> Left ("is left as it is: " <> why) + MachineTypeDiffers live wanted -> case change of + RefuseMachineTypeChange -> Left (machineTypeReason change live wanted) + MayStopToResize -> case status of + "RUNNING" -> Right ([StopStep, SetMachineTypeStep] <> restart) + "TERMINATED" -> Right (SetMachineTypeStep : restart) + _ -> + Left + ( "is " + <> status + <> " and runs machine type " + <> live + <> ", declared " + <> wanted + <> "; the type is only set on an instance that is RUNNING (stopped first) or TERMINATED: retry once it settles" + ) + restart = [StartStep | power == PoweredOn] + +------------------------------------------------------------------------------- + +{- | A reserved regional IP, external or internal. + +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. + +An external one 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, or for a +"Salmon.Builtin.Nodes.Deferred" node to use within one. An internal one can: +see 'InternalAddress'. +-} +data Address = Address + { addressName :: Text + , addressProject :: Project + , addressRegion :: Region + , addressKind :: AddressKind + } + deriving (Eq, Show) + +-- | Which side of the VPC's edge a reserved 'Address' is on. +data AddressKind + = ExternalAddress + | {- | In this subnet (by name, in the address's region), at this literal + if one is given and wherever GCP picks in the subnet's range otherwise. + Give the literal when an instance is to be pinned to it + ('PinnedInternal' takes the same one): the check then also compares + what was reserved with what was declared. + -} + InternalAddress Text (Maybe Text) + deriving (Eq, Show) + +-- | Idempotently reserves a regional 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", kindWord, "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 + + kindWord = case addr.addressKind of + ExternalAddress -> "external" + InternalAddress _ Nothing -> "internal" + InternalAddress _ (Just ip) -> "internal (" <> ip <> ")" + + checkAddress :: IO CheckResult + checkAddress = do + (code, out, _err) <- + readCreateProcessWithExitCode (prepare computeCommand (AddressesDescribe addr)) "" + pure $ interpretAddress addr 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 + +{- | 'interpretAddressDescribe', and for an internal address declared with a +literal, that the reservation holds /that/ literal. A reservation of the +same name on another address is a 'Failure' @up@ cannot repair (@create@ +refuses an existing name), which is the point: the instance pinned to the +declared literal would otherwise be created on an address nothing reserved. +-} +interpretAddress :: Address -> ExitCode -> Text -> CheckResult +interpretAddress addr code out = + case (interpretAddressDescribe addr.addressName code out, addr.addressKind) of + (Success, InternalAddress _ (Just wanted)) + | out /= wanted -> + Failure ("address " <> addr.addressName <> " is reserved as " <> out <> ", declared " <> wanted) + (verdict, _) -> verdict + +{- | 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. Either a driver converges once, calls this, and +declares the rest, or the part that needs the IP is built at @up@ from this +read ("Salmon.Builtin.Nodes.Deferred"; @SreBox.Gcp.VmProvision@'s +@provisionedVmReadingHost@ is that for an ssh host) -- @salmon-apps@'s +@GcpToy@ tier 2 does the second and its driver script the first. '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 + | InstancesDescribeScopes Instance + | InstancesDescribeMachineType Instance + | InstancesSetMachineType Instance + | InstancesDescribeRunLimit Instance + | InstancesSetScheduling 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) + <> ( case inst.instanceExternalAddress of + EphemeralExternal -> [] + ReservedExternal addr -> ["--address", Text.unpack addr] + NoExternalAddress -> ["--no-address"] + ) + <> ( case inst.instanceInternalAddress of + EphemeralInternal -> [] + PinnedInternal ip -> ["--private-network-ip", Text.unpack ip] + ) + <> (if null inst.instanceTags then [] else ["--tags", Text.unpack (Text.intercalate "," inst.instanceTags)]) + <> ( case inst.instanceScopes of + DefaultScopes -> [] + DeclaredScopes [] -> ["--no-scopes"] + DeclaredScopes scopes -> ["--scopes", Text.unpack (Text.intercalate "," scopes)] + ) + <> runLimitArgs inst.instanceRunLimit + 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)" + ] + ) + InstancesDescribeScopes inst -> + gcloudProc $ + withProject inst.instanceProject + ( withZone inst.instanceZone + [ "compute" + , "instances" + , "describe" + , Text.unpack inst.instanceName + , "--format=value(serviceAccounts[].scopes)" + ] + ) + InstancesDescribeMachineType inst -> + gcloudProc $ + withProject inst.instanceProject + ( withZone inst.instanceZone + [ "compute" + , "instances" + , "describe" + , Text.unpack inst.instanceName + , "--format=value(machineType.basename())" + ] + ) + InstancesSetMachineType inst -> + gcloudProc $ + withProject inst.instanceProject + ( withZone inst.instanceZone + [ "compute" + , "instances" + , "set-machine-type" + , Text.unpack inst.instanceName + , "--machine-type" + , Text.unpack (renderMachineType inst.instanceMachineType) + ] + ) + InstancesDescribeRunLimit inst -> + gcloudProc $ + withProject inst.instanceProject + ( withZone inst.instanceZone + [ "compute" + , "instances" + , "describe" + , Text.unpack inst.instanceName + , "--format=json(lastStartTimestamp,scheduling.maxRunDuration.seconds,scheduling.terminationTime,scheduling.instanceTerminationAction)" + ] + ) + -- the declared limit, and the other kind of limit cleared so that the + -- instance holds exactly what is declared + InstancesSetScheduling inst -> + gcloudProc $ + withProject inst.instanceProject + ( withZone inst.instanceZone + ( [ "compute" + , "instances" + , "set-scheduling" + , Text.unpack inst.instanceName + ] + <> runLimitArgs inst.instanceRunLimit + <> ( case inst.instanceRunLimit of + NoRunLimit -> ["--clear-max-run-duration", "--clear-termination-time"] + MaxRunDuration _ -> ["--clear-termination-time"] + RunUntil _ -> ["--clear-max-run-duration"] + ) + ) + ) + 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 + ] + -- gcloud has no "internal" switch: naming a subnet is what + -- makes the reservation an internal one. + <> case addr.addressKind of + ExternalAddress -> [] + InternalAddress sub ip -> + ["--subnet", Text.unpack sub] <> maybe [] (\lit -> ["--addresses", Text.unpack lit]) ip AddressesDescribe addr -> gcloudProc $ withProject addr.addressProject diff --git a/src/Salmon/Builtin/Nodes/Gcp/Core.hs b/src/Salmon/Builtin/Nodes/Gcp/Core.hs --- a/src/Salmon/Builtin/Nodes/Gcp/Core.hs +++ b/src/Salmon/Builtin/Nodes/Gcp/Core.hs @@ -9,6 +9,14 @@ -- * gcloud binary gcloud, + -- * The account gcloud acts as + Account (..), + declaredAccount, + interpretAccount, + activeAccountArgs, + readActiveAccount, + withAccount, + -- * Application Default Credentials applicationDefaultCredentials, interpretAdc, @@ -27,6 +35,8 @@ -- * CLI helpers gcloudProc, + quietly, + disablePromptsLine, withProject, withZone, withRegion, @@ -34,6 +44,7 @@ import Control.Concurrent (threadDelay) import Control.Exception (SomeException, throwIO, try) +import Data.ByteString (ByteString) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -75,6 +86,7 @@ -- | The various gcloud invocations that 'Core' knows how to run. data GcloudCommand = AdcPrintAccessToken + | ConfigGetAccount deriving (Show) -- | Builds a 'CreateProcess' for a gcloud invocation. @@ -82,6 +94,8 @@ gcloudCommand = Command $ \cmd -> case cmd of AdcPrintAccessToken -> gcloudProc ["auth", "application-default", "print-access-token"] + ConfigGetAccount -> + gcloudProc activeAccountArgs -- | 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. @@ -93,8 +107,15 @@ , ref = mkRef "gcloud" ("gcloud" :: Text) } --- | Validates Application Default Credentials. Almost every other GCP op --- should depend on this node. +{- | Validates Application Default Credentials. + +Mind what this does /not/ say: every @gcloud@ invocation in this tree, and +'printAccessToken', acts as gcloud's /active account/, which is a separate +credential from the application-default one and may belong to somebody else. +This node passing says a client library could authenticate; it says nothing +about who the other GCP nodes will act as. 'declaredAccount' is the node +that does. +-} applicationDefaultCredentials :: Reporter Report -> Track' (Binary "gcloud") -> Op applicationDefaultCredentials r gcloudTrack = withBinary gcloudTrack gcloudCommand AdcPrintAccessToken $ \up -> @@ -122,9 +143,95 @@ 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). +------------------------------------------------------------------------------- +-- The active account +-- | The account (a user's or a service account's email) gcloud should act as. +newtype Account = Account {accountEmail :: Text} + deriving (Eq, Ord, Show) + +{- | The arguments reading the account gcloud will act as. It is the +@core/account@ property, so it honours @CLOUDSDK_CORE_ACCOUNT@ and the active +configuration alike, which is exactly what every other invocation does. +-} +activeAccountArgs :: [String] +activeAccountArgs = ["config", "get-value", "account"] + +-- | Append @--account@ to a gcloud argument list. +withAccount :: Account -> [String] -> [String] +withAccount a args = args <> ["--account", Text.unpack a.accountEmail] + +{- | Asserts that gcloud's active account is the declared one, and refuses +otherwise. + +Every GCP node shells out to @gcloud@, which acts as whichever account is +active on the machine; with several Google accounts logged in, a graph would +otherwise silently run as the wrong one. A recipe that knows who it means to +be puts this node under its other GCP nodes (where 'applicationDefaultCredentials' +used to stand alone), so a mismatch fails this node and blocks the rest +before anything is created. + +It never /changes/ the active account: that is the operator's machine +configuration, shared with everything else on it. Its @up@ re-reads and +throws on anything but a match, saying what to run. Nothing is done on +@down@. +-} +declaredAccount :: Reporter Report -> Track' (Binary "gcloud") -> Account -> Op +declaredAccount _r gcloudTrack acct = + withBinary gcloudTrack gcloudCommand ConfigGetAccount $ \_run -> + op "gcp-account" nodeps $ \actions -> + actions + { help = "asserts the account gcloud acts as" + , notes = ["declared account: " <> acct.accountEmail] + , ref = mkRef "gcp-account" acct.accountEmail + , up = refuseUnlessDeclared + , check = checkAccount + } + where + checkAccount :: IO CheckResult + checkAccount = uncurry (interpretAccount acct) <$> readActiveAccount + + refuseUnlessDeclared :: IO () + refuseUnlessDeclared = do + result <- checkAccount + case result of + Success -> pure () + Failure why -> + throwIO . userError . Text.unpack $ + why + <> "; refusing to act as another identity (gcloud config set account " + <> acct.accountEmail + <> ", or export CLOUDSDK_CORE_ACCOUNT)" + other -> throwIO (userError ("could not establish gcloud's active account: " <> show other)) + +-- | Runs @gcloud config get-value account@: its exit code and stdout. +readActiveAccount :: IO (ExitCode, ByteString) +readActiveAccount = do + (code, out, _err) <- readCreateProcessWithExitCode (gcloudProc activeAccountArgs) "" + pure (code, out) + +{- | The verdict drawn from @gcloud config get-value account@. + +With no account set, gcloud exits 0 and prints @(unset)@ on stderr, leaving +stdout empty (older releases printed it on stdout), so both spellings count +as none. Addresses are compared without regard to case, as Google does. +-} +interpretAccount :: Account -> ExitCode -> ByteString -> CheckResult +interpretAccount _ (ExitFailure n) _ = + Failure ("could not read gcloud's active account (exit " <> Text.pack (show n) <> ")") +interpretAccount acct ExitSuccess out + | Text.null active || active == "(unset)" = + Failure ("gcloud has no active account, declared " <> acct.accountEmail) + | Text.toCaseFold active == Text.toCaseFold (Text.strip acct.accountEmail) = Success + | otherwise = + Failure ("gcloud's active account is " <> active <> ", declared " <> acct.accountEmail) + where + active = Text.strip (Text.decodeUtf8With TextError.lenientDecode out) + +{- | Fetches a fresh OAuth2 access token for gcloud's /active account/ (not +the application-default credentials; see 'declaredAccount' for pinning who +that is). + 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 @@ -211,9 +318,34 @@ ------------------------------------------------------------------------------- -- CLI helpers --- | A bare @gcloud@ process with the given sub-command arguments. +{- | A @gcloud@ process with the given sub-command arguments, and @--quiet@. + +Every invocation is non-interactive on purpose. No process a node starts +reads the pass's standard input (see "Salmon.Builtin.Nodes.Binary".'Binary.detachedStdin'), +so a prompt could never be answered anyway: without @--quiet@ gcloud prints +it, reads end-of-file, and the node fails with the prompt's text (\"Would you +like to enable and retry?\") for an error. With it, gcloud takes the default +or says plainly that input was required. +-} gcloudProc :: [String] -> CreateProcess -gcloudProc args = proc "gcloud" args +gcloudProc args = proc "gcloud" (quietly args) + +{- | Append @--quiet@ to a gcloud argument list unless it is already there. +It goes among gcloud's own flags: before a @--@, after which the words are +somebody else's (the remote command of a @gcloud compute ssh@). +-} +quietly :: [String] -> [String] +quietly args + | "--quiet" `elem` flags = args + | otherwise = flags <> ["--quiet"] <> rest + where + (flags, rest) = break (== "--") args + +{- | The same for a script of @gcloud@ calls run by a shell, which +'gcloudProc' never sees: the line to put first. +-} +disablePromptsLine :: Text +disablePromptsLine = "export CLOUDSDK_CORE_DISABLE_PROMPTS=1" -- | Append @--project@ to a gcloud argument list. withProject :: Project -> [String] -> [String] diff --git a/src/Salmon/Builtin/Nodes/Gcp/LoadBalancing.hs b/src/Salmon/Builtin/Nodes/Gcp/LoadBalancing.hs --- a/src/Salmon/Builtin/Nodes/Gcp/LoadBalancing.hs +++ b/src/Salmon/Builtin/Nodes/Gcp/LoadBalancing.hs @@ -5,353 +5,2567 @@ 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")] + BackendService (..), + ServiceRef (..), + BackendBucket (..), + BucketRoutes (..), + Redirect (..), + RedirectCode (..), + redirectToHost, + HttpListener (..), + HostRule (..), + PathRule (..), + PathRewrite (..), + Certificate (..), + certificateResource, + domainSetTag, + ApplicationLoadBalancer (..), + httpLoadBalancer, + applicationLoadBalancer, + applicationLoadBalancerAfter, + applicationLoadBalancerPart, + applicationLoadBalancerWith, + applicationLoadBalancerPartWith, + backendBucketPart, + afterStorageBuckets, + Part (..), + PartSpec (..), + lbParts, + InvalidLoadBalancer (..), + albProblems, + certificateManagerApi, + readAddress, + DnsAuthorizationRecord (..), + dnsAuthorizations, + readDnsAuthorizationRecord, + parseDnsAuthorizationRecord, + bucketResource, + renderUrlMap, + urlMapStamp, + ownershipMarker, + renderHttpRedirectUrlMap, + interpretLbDescribe, + interpretLbCheck, + renderLbCheckScript, + renderLbHealthScript, + renderPartUpScript, + renderPartCheckScript, + renderPartDownScript, + shellQuote, + Report (..), + LoadBalancingCommand (..), + loadBalancingCommand, +) where + +import Control.Exception (Exception, throwIO) +import Control.Monad (unless) +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.Aeson.Types as Aeson (Pair) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LByteString +import Data.Function (on) +import Data.List (nub, nubBy, sort, (\\)) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as TextErr +import GHC.IO.Exception (ExitCode (..)) +import Numeric (showHex) +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.Builtin.Nodes.Gcp.Core (Project (..), Region (..), disablePromptsLine, 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, Ord, Show) + +{- | Backend kinds supported by the high-level recipe. + +An instance group's ports are the ones the backend service naming it sends +to: the first is where the service's traffic goes, under a named port that +is the service's own (its resource name; any further port is that name with +@-1@, @-2@, ...). Several backend services may name one group, each with its +own port -- a VM backs a balancer through one group only, however many +services it runs. With no port at all the group is left alone and the +service keeps GCP's default port name, @http@, which is then the caller's to +have set. +-} +data Backend + = InstanceGroupBackend Text InstanceGroupLocation [Int] + | CloudRunBackend Text + deriving (Eq, Show) + +{- | One more backend service beside the balancer's default one, reachable +only through a 'HostRule' or 'PathRule' that names it. Its resource is +@\-\-backend@. + +A backend service cannot mix instance groups and serverless NEGs, which is +one reason to have several rather than a longer 'albBackends'. +-} +data BackendService = BackendService + { backendServiceName :: Text + , backendServiceBackends :: [Backend] + , backendServiceHealthCheck :: Maybe HealthCheck + , backendServiceTimeoutSec :: Maybe Int + -- ^ how long the balancer waits for a response; GCP's default is 30 + -- seconds, which a long-poll or an event stream outlives + } + deriving (Eq, Show) + +{- | A backend bucket: a Cloud Storage bucket the balancer serves objects +from, reachable only through a 'HostRule' or 'PathRule' that names it +('NamedBucket'). Its resource is @\-\-bucket@, a /regional/ +backend bucket (@EXTERNAL_MANAGED@), which is what a regional balancer's URL +map can name. + +The Cloud Storage bucket is the caller's, and is neither created nor removed +here. GCP's documented limits for this kind are the caller's to meet too: a +bucket in the balancer's region, readable by @allUsers@, no Cloud CDN, @GET@ +only. + +__A rule that routes to one is refused by default__ ('albProblems', see +'BucketRoutes' for what was observed). The bucket declared with no rule +naming it is not: the resource alone serves nothing and was not seen to harm +anything, and keeping it declared is what lets a declaration drop the rule +alone. +-} +data BackendBucket = BackendBucket + { backendBucketName :: Text + , backendBucketGcsBucket :: Text + -- ^ the Cloud Storage bucket's name, without @gs:\/\/@ + } + deriving (Eq, Show) + +{- | Whether a rule may route to a backend bucket ('NamedBucket'). + +'RefuseBucketRoutes' is the default, after an outage. What was observed, on +one live regional external Application Load Balancer (@europe-west1@, +2026-10-05): with a single path matcher on a regional backend bucket in the +URL map, every matcher on a backend service answered 503 +(@failed_to_pick_backend@) while the backends were @HEALTHY@ and the bucket's +own host served. Importing the same map without that host rule and its +matcher brought the service hosts back in 80 seconds; a matcher that only +redirects stayed in the map and the services serve with it. The service +rules are rendered identically with and without the bucket ('renderUrlMap'), +so the difference is not in what this module writes about them. Why the +platform does this is not known, and neither is whether a /global/ balancer +(which this module does not make) does the same: nobody here has run one. + +The URL map's default service is always a backend service, so any bucket +route on this balancer is such a mixed map. + +'AllowBucketRoutesKnownToHaveBrokenALiveBalancer' is for proving the +contrary on a balancer that serves nothing that matters. +-} +data BucketRoutes + = RefuseBucketRoutes + | AllowBucketRoutesKnownToHaveBrokenALiveBalancer + deriving (Eq, Show) + +{- | Where a rule sends: a backend service, a backend bucket, or nowhere -- +a redirect the balancer answers itself. +-} +data ServiceRef + = DefaultService + | NamedService Text + | -- | a 'BackendBucket' of 'albBuckets', by its name; refused unless + -- 'albBucketRoutes' says otherwise + NamedBucket Text + | RedirectTo Redirect + deriving (Eq, Show) + +{- | A redirect answered by the balancer (the URL map's @urlRedirect@). What +is 'Nothing' is kept from the request: the host, the path. The query string +is always kept. +-} +data Redirect = Redirect + { redirectHost :: Maybe Text + , redirectPath :: Maybe Text + -- ^ the whole path of the answer, starting with @\/@ + , redirectHttps :: Bool + -- ^ answer with @https:\/\/@ whatever the request came in on; 'False' + -- keeps the request's scheme + , redirectCode :: RedirectCode + } + deriving (Eq, Show) + +data RedirectCode + = -- | 301 + MovedPermanently + | -- | 302 + Found + | -- | 303 + SeeOther + | -- | 307, the method kept + TemporaryRedirect + | -- | 308, the method kept + PermanentRedirect + deriving (Eq, Show) + +-- | A permanent redirect to another host over HTTPS, path kept: an apex to its @www@. +redirectToHost :: Text -> Redirect +redirectToHost h = Redirect (Just h) Nothing True MovedPermanently + +{- | What the balancer does on port 80. + +'HttpCreatedOnce' is what this module always did and is the default: an HTTP +proxy and a @:80@ rule, the proxy __created__ pointing at the balancer's URL +map and never set again, so a proxy somebody repointed (at a redirect-only +map of their own, say) stays where they put it. The other three are +declarations about the listener, and make this module the writer of the +proxy's URL map: + +* 'ServeHttp': the proxy is on the balancer's URL map, and is put back on it + when it is found on another; +* 'RedirectToHttps': the proxy is on a second, redirect-only URL map + (@\-http-redirect-url-map@, see 'renderHttpRedirectUrlMap'), so + every request on port 80 is answered with a redirect to HTTPS; +* 'NoHttp': no HTTP proxy and no @:80@ rule, and the ones a previous + declaration made are removed. + +The last two need a certificate, or the balancer serves nothing. +-} +data HttpListener + = HttpCreatedOnce + | ServeHttp + | RedirectToHttps RedirectCode + | NoHttp + deriving (Eq, Show) + +-- | Requests whose path matches one of these patterns (@\/api\/*@) go there. +data PathRule = PathRule + { pathRulePaths :: [Text] + , pathRuleService :: ServiceRef + -- ^ a service, a bucket or a redirect + , pathRuleRewrite :: PathRewrite + -- ^ what the backend is asked for; 'KeepPath' for the request's own path + } + deriving (Eq, Show) + +{- | What a 'PathRule' does to the path before the request reaches the +backend (the URL map's @routeAction.urlRewrite@, beside the rule's +@service@). The client sees nothing of it: this is not a redirect. + +'RewritePrefix' is GCP's @pathPrefixRewrite@: the part of the path the rule +/matched/ is replaced by the text given, and the rest is kept. By GCP's +documentation, a pattern ending in @\/*@ matches up to and including that +slash, so @\/static\/*@ with @RewritePrefix \"\/\"@ asks the backend for +@\/a.css@ when the request was for @\/static\/a.css@; and an exact pattern +matches the whole path, so @\/@ with @RewritePrefix \"\/index.html\"@ asks for +@\/index.html@ -- the case this exists for, a backend bucket that serves +nothing for @\/@. Neither reading has been checked against a live balancer. + +A rule that redirects has a path of its own ('redirectPath') and cannot +rewrite ('albProblems'). +-} +data PathRewrite + = KeepPath + | -- | starting with @\/@ + RewritePrefix Text + deriving (Eq, Show) + +{- | Requests for one of these host names go to 'hostRuleService', except +those matching a 'PathRule'. A request for a host no rule names goes to the +balancer's default backend service. +-} +data HostRule = HostRule + { hostRuleHosts :: [Text] + , hostRuleService :: ServiceRef + , hostRulePaths :: [PathRule] + } + deriving (Eq, Show) + +{- | A certificate for the HTTPS proxy. + +A /regional/ Application Load Balancer cannot use the classic +Google-managed @compute ssl-certificates@ (those are global only, and are +the ones that provision "once DNS points at the balancer"). What it can use +is a regional __Certificate Manager__ certificate, which Google issues +against a /DNS authorization/: a @CNAME@ the domain's zone has to carry, +whose content GCP picks. 'ManagedCertificate' creates one authorization per +domain and the certificate over them; publishing the records is the +caller's (see 'readDnsAuthorizationRecord'), and until they resolve the +certificate stays @PROVISIONING@ and the node's check says 'Unknown'. + +A Certificate Manager certificate's names are __immutable__: nothing edits +the domain list of one that exists. So a 'ManagedCertificate', whose +resource is named exactly as declared, cannot follow a changed list -- its +node says so (a @PROBLEM@ line in the check, a failing @up@) instead of +reporting a certificate that silently covers other names than the declared +ones. + +'DomainSetCertificate' is the one that can change on a live balancer. Its +resource is named after its /domain set/ (@\-\@, see +'certificateResource'), so a changed set is a new certificate beside the one +in service: it is created, the HTTPS proxy keeps the old one until the new +one is @ACTIVE@ and is only then updated to it, and the superseded +certificates of that base are deleted after (see 'lbParts'). Its DNS +authorizations are named after the base and the domain, not the set, so the +names both sets cover reuse the authorization (and the published record) +they already have. + +'ComputeCertificate' names a regional @compute ssl-certificates@ resource +somebody else made (a self-managed one). It does not mix with the other two +kinds on one proxy. +-} +data Certificate + = ManagedCertificate Text [Text] + | -- | a base name and the domains; the resource is 'certificateResource' + DomainSetCertificate Text [Text] + | ComputeCertificate Text + deriving (Eq, Show) + +{- | The name of the resource a certificate is: the declared name, except for +a 'DomainSetCertificate', which is its base name and 'domainSetTag' of its +domains. +-} +certificateResource :: Certificate -> Text +certificateResource = \case + ManagedCertificate n _ -> n + DomainSetCertificate base ds -> base <> "-" <> domainSetTag ds + ComputeCertificate n -> n + +{- | Eight hex digits naming a set of domains: of the SHA-256 of the names, +lower-cased, sorted and without duplicates. Order and case do not make a new +certificate; one more name, or one fewer, does. +-} +domainSetTag :: [Text] -> Text +domainSetTag ds = + Text.pack + . concatMap hex + . ByteString.unpack + . ByteString.take 4 + . SHA256.hash + . Text.encodeUtf8 + $ Text.intercalate "," (normalDomains ds) + where + hex w = let h = showHex w "" in if length h < 2 then '0' : h else h + +-- | A domain list as a set: what two certificates are compared by. +normalDomains :: [Text] -> [Text] +normalDomains = sort . nub . map Text.toLower + +-- | The Certificate Manager certificates of a declaration: (resource, authorization base, domains). +managedCertificates :: ApplicationLoadBalancer -> [(Text, Text, [Text])] +managedCertificates alb = + concatMap + ( \c -> case c of + ManagedCertificate n ds -> [(n, n, ds)] + DomainSetCertificate base ds -> [(certificateResource c, base, ds)] + ComputeCertificate _ -> [] + ) + alb.albCertificates + +-- | A high-level HTTP(S) load balancer. +data ApplicationLoadBalancer = ApplicationLoadBalancer + { albName :: Text + , albProject :: Project + , albRegion :: Region + , albNetwork :: Maybe Text + , albBackends :: [Backend] + -- ^ the default backend service's (@\-backend@) + , albHealthCheck :: Maybe HealthCheck + , albTimeoutSec :: Maybe Int + -- ^ the default backend service's response timeout + , albServices :: [BackendService] + , albHostRules :: [HostRule] + , albCertificates :: [Certificate] + -- ^ non-empty: also serve HTTPS on :443, with both forwarding rules on + -- one reserved address (@\-ip@) + , albBuckets :: [BackendBucket] + , albBucketRoutes :: BucketRoutes + -- ^ 'RefuseBucketRoutes' unless the outage it names is the thing to test + , albHttp :: HttpListener + -- ^ 'HttpCreatedOnce' unless something else is wanted of port 80 + } + deriving (Eq, Show) + +{- | A plain-HTTP balancer with one backend service and no rules: what this +module made before it knew about the rest. Record-update it for more. +-} +httpLoadBalancer :: Text -> Project -> Region -> [Backend] -> Maybe HealthCheck -> ApplicationLoadBalancer +httpLoadBalancer name project region backends hc = + ApplicationLoadBalancer + { albName = name + , albProject = project + , albRegion = region + , albNetwork = Nothing + , albBackends = backends + , albHealthCheck = hc + , albTimeoutSec = Nothing + , albServices = [] + , albHostRules = [] + , albCertificates = [] + , albBuckets = [] + , albBucketRoutes = RefuseBucketRoutes + , albHttp = HttpCreatedOnce + } + +-- | The API a 'ManagedCertificate' needs enabled (the caller's dependency). +certificateManagerApi :: Text +certificateManagerApi = "certificatemanager.googleapis.com" + +-- | A declaration no gcloud call could satisfy, refused before any is made. +newtype InvalidLoadBalancer = InvalidLoadBalancer [Text] + deriving (Show) + +instance Exception InvalidLoadBalancer + +{- | What is wrong with a declaration, all of it rather than the first: a +rule naming a service or a bucket nobody declared, a rule routing to a +backend bucket at all ('BucketRoutes'), two services or two +buckets under one name, a redirect that redirects to the request itself, a +path rule that redirects and rewrites, a rewrite that is no path, an +HTTP listener option that leaves no listener, a host in two rules, a rule with no host or no path, the two certificate kinds +mixed, a managed certificate with no domain, a timeout that is not positive, +one backend service sending to two different ports of one instance group. +-} +albProblems :: ApplicationLoadBalancer -> [Text] +albProblems alb = + [ "backend service declared twice: " <> n + | n <- nub (names \\ nub names) + ] + <> [ "rule names an undeclared backend service: " <> n + | NamedService n <- nub refs + , n `notElem` names + ] + <> ["a host rule names no host" | any (null . hostRuleHosts) alb.albHostRules] + <> ["a path rule names no path" | any (null . pathRulePaths) (concatMap hostRulePaths alb.albHostRules)] + <> [ "host named by two rules: " <> h + | h <- nub (hosts \\ nub hosts) + ] + <> [ "Certificate Manager and compute certificates cannot share a proxy" + | not (null (managedCertificates alb)) + , not (null [() | ComputeCertificate{} <- alb.albCertificates]) + ] + <> [ "managed certificate " <> base <> " names no domain" + | (_, base, []) <- managedCertificates alb + ] + -- a base is a lineage the balancer deletes superseded certificates + -- of, and names its authorizations after: one declaration each + <> [ "certificate declared twice: " <> n + | n <- nub (certNames \\ nub certNames) + ] + <> [ "instance group " <> ig <> ": named port " <> n <> " declared on several ports: " <> Text.unwords (map (Text.pack . show) ps) + | ((ig, _), named) <- groupNamedPorts alb + , n <- nub (map fst named) + , let ps = nub [p | (n', p) <- named, n' == n] + , length ps > 1 + ] + <> [ "timeout must be positive: " <> Text.pack (show t) + | Just t <- alb.albTimeoutSec : map backendServiceTimeoutSec alb.albServices + , t <= 0 + ] + <> [ "backend bucket declared twice: " <> n + | n <- nub (buckets \\ nub buckets) + ] + <> [ "backend bucket " <> b.backendBucketName <> " names no Cloud Storage bucket" + | b <- alb.albBuckets + , Text.null b.backendBucketGcsBucket + ] + <> [ "rule names an undeclared backend bucket: " <> n + | NamedBucket n <- nub refs + , n `notElem` buckets + ] + <> [ bucketRouteRefusal alb routed + | alb.albBucketRoutes == RefuseBucketRoutes + , let routed = bucketRoutes alb + , not (null routed) + ] + -- one that changes nothing answers every request with itself + <> [ "a redirect names neither a host, a path nor HTTPS" + | RedirectTo (Redirect Nothing Nothing False _) <- nub refs + ] + <> [ "a redirect's path must start with /: " <> path + | RedirectTo Redirect{redirectPath = Just path} <- nub refs + , not ("/" `Text.isPrefixOf` path) + ] + <> [ "a redirect names an empty host" + | RedirectTo Redirect{redirectHost = Just ""} <- nub refs + ] + -- a URL map's rule is a redirect or a route with its action, not both + <> [ "a path rule both redirects and rewrites its path (" <> Text.unwords p.pathRulePaths <> "): a redirect names its own path" + | p <- pathRules + , RedirectTo _ <- [p.pathRuleService] + , p.pathRuleRewrite /= KeepPath + ] + <> [ "a path rewrite must start with /: " <> prefix + | RewritePrefix prefix <- nub (map pathRuleRewrite pathRules) + , not ("/" `Text.isPrefixOf` prefix) + ] + <> [ what <> " needs a certificate: without one the balancer serves nothing" + | null alb.albCertificates + , what <- case alb.albHttp of + RedirectToHttps _ -> ["redirecting HTTP to HTTPS"] + NoHttp -> ["no HTTP listener"] + _ -> [] + ] + where + names = map backendServiceName alb.albServices + buckets = map backendBucketName alb.albBuckets + certNames = + [base | (_, base, _) <- managedCertificates alb] + <> [n | ComputeCertificate n <- alb.albCertificates] + hosts = concatMap hostRuleHosts alb.albHostRules + pathRules = concatMap hostRulePaths alb.albHostRules + refs = + concat + [ r.hostRuleService : map pathRuleService r.hostRulePaths + | r <- alb.albHostRules + ] + +{- | The rules of a declaration that route to a backend bucket, as (what the +rule matches, the bucket's name in 'albBuckets'). +-} +bucketRoutes :: ApplicationLoadBalancer -> [(Text, Text)] +bucketRoutes alb = + concat + [ [("hosts " <> hosts, n) | NamedBucket n <- [r.hostRuleService]] + <> [ ("paths " <> Text.unwords p.pathRulePaths <> " of hosts " <> hosts, n) + | p <- r.hostRulePaths + , NamedBucket n <- [p.pathRuleService] + ] + | r <- alb.albHostRules + , let hosts = Text.unwords r.hostRuleHosts + ] + +{- | Why a bucket route is refused, and what to do about a balancer that +already has one: the text of the 'albProblems' entry. +-} +bucketRouteRefusal :: ApplicationLoadBalancer -> [(Text, Text)] -> Text +bucketRouteRefusal alb routed = + "a rule routes to a backend bucket (" + <> Text.intercalate ", " [what <> " to " <> bucketResource alb n | (what, n) <- routed] + <> "), which is refused on this regional load balancer: on a live one, a URL map with one" + <> " matcher on a regional backend bucket made every host on a backend service answer 503" + <> " (failed_to_pick_backend) while its backends were HEALTHY and the bucket's own host served." + <> " Nothing was changed by this pass. If the live URL map already has such a rule, drop the" + <> " rule from the declaration (its albBuckets entry may stay) and run a pass: the URL map is" + <> " re-imported without it, which is what restored the service hosts." + <> " albBucketRoutes = AllowBucketRoutesKnownToHaveBrokenALiveBalancer declares it anyway" + +{- | The balancer, declared once and unfolded into a node per resource. + +The node returned is the one callers depend on (same @ref@ as when the +balancer was a single node running one script): a root over a node per +health check, per instance group's named ports, per backend service, per +serverless NEG, per backend attachment, the URL map, a node per DNS +authorization, per certificate, the address, the proxies and the forwarding +rules. See 'lbParts' for the edges between them. Each has its own @check@ +(its own @describe@), @up@ and @down@, so progress, concurrency, failure and +retry are per resource, and teardown is the edges read backwards. + +The root's own @up@ creates nothing; its @check@ asks the backend services +for their backends' health ('Unknown' while some are not @HEALTHY@), which +is a statement about the balancer as a whole and not about any one resource. + +Nothing here runs before the resources' prerequisites unless they are named: +a dependency @inject@ed into the returned node is a dependency of the /root/, +and the resource nodes are the root's dependencies too, so they would not +wait for it. Use 'applicationLoadBalancerAfter' for what has to exist first +(the APIs, the proxy-only subnet, the instance groups). + +The DNS record of a certificate's authorization goes on that authorization's +own node ('applicationLoadBalancerPart' with a 'DnsAuthorizationPart'), __never +on the returned root__. The root comes after the certificates, the proxies and +the forwarding rules, so a record waiting for it is published last, behind +everything that can fail on the way; and since a certificate is only issued +once its records resolve, a record behind a root that waits for the +certificate is a cycle no pass gets out of. A pending certificate swap no +longer blocks the root (see 'lbParts'), but a failed backend, a @FAILED@ +certificate or a refused declaration still would. +-} +applicationLoadBalancer :: Reporter Report -> Track' (Binary "gcloud") -> ApplicationLoadBalancer -> Op +applicationLoadBalancer = applicationLoadBalancerAfter [] + +{- | 'applicationLoadBalancer' with prerequisites: nodes every resource node +of the balancer depends on. +-} +applicationLoadBalancerAfter :: [Op] -> Reporter Report -> Track' (Binary "gcloud") -> ApplicationLoadBalancer -> Op +applicationLoadBalancerAfter = applicationLoadBalancerWith (const []) + +{- | 'applicationLoadBalancerAfter' with prerequisites of single resources +too: for each resource node, the nodes that one alone depends on, beside the +ones every resource does. It is how a backend bucket is ordered after the +Cloud Storage bucket it serves ('afterStorageBuckets') without the health +checks and the certificates waiting for that bucket as well. + +The function is asked about every 'Part' of the declaration and answers @[]@ +for the ones it has nothing to say about. 'applicationLoadBalancerPartWith' +has to be given the same one to hand back the same nodes. +-} +applicationLoadBalancerWith :: (Part -> [Op]) -> [Op] -> Reporter Report -> Track' (Binary "gcloud") -> ApplicationLoadBalancer -> Op +applicationLoadBalancerWith partPrereqs prereqs r gcloudTrack alb = + op "gcp-application-lb" (deps (prereqs <> ordered)) $ \actions -> + actions + { help = Text.unwords ["application load balancer", alb.albName] + , notes = albNotes alb + , ref = mkRef "gcp-application-lb" (alb.albProject.projectId, alb.albRegion.regionName, alb.albName) + , up = unless (null problems) $ throwIO (InvalidLoadBalancer problems) + , check = checkHealth + } + where + nodes = partOps partPrereqs prereqs r gcloudTrack alb + ordered = mapMaybe ((`Map.lookup` nodes) . partId) (lbParts alb) + problems = albProblems alb + + checkHealth :: IO CheckResult + checkHealth + | not (null problems) = pure (invalid problems) + | otherwise = runCheck (LbHealth alb) + +{- | One resource node of the balancer, to hang something on that needs that +resource and not the whole balancer -- the DNS record of one authorization, +say ('DnsAuthorizationPart', named as 'dnsAuthorizations' names it). +'Nothing' when the declaration has no such resource. + +Given the prerequisites, reporter and declaration the balancer itself was +made with, this is the very node the balancer's root depends on. +-} +applicationLoadBalancerPart :: [Op] -> Reporter Report -> Track' (Binary "gcloud") -> ApplicationLoadBalancer -> Part -> Maybe Op +applicationLoadBalancerPart = applicationLoadBalancerPartWith (const []) + +-- | 'applicationLoadBalancerPart' for a balancer made by 'applicationLoadBalancerWith'. +applicationLoadBalancerPartWith :: (Part -> [Op]) -> [Op] -> Reporter Report -> Track' (Binary "gcloud") -> ApplicationLoadBalancer -> Part -> Maybe Op +applicationLoadBalancerPartWith partPrereqs prereqs r gcloudTrack alb part = + Map.lookup part (partOps partPrereqs prereqs r gcloudTrack alb) + +{- | The resource node of one of 'albBuckets', by the name it is declared +under ('backendBucketName'): what 'applicationLoadBalancerPart' is asked for +that backend bucket's node, and what an 'applicationLoadBalancerWith' +function is asked about. +-} +backendBucketPart :: ApplicationLoadBalancer -> Text -> Part +backendBucketPart alb n = BackendBucketPart (bucketResource alb n) + +{- | Prerequisites for 'applicationLoadBalancerWith' that put each backend +bucket after what its Cloud Storage bucket needs -- the node that makes the +bucket, the one that makes it readable -- and say nothing about any other +resource: + +> applicationLoadBalancerWith (afterStorageBuckets alb (\b -> [storageBucket b.backendBucketGcsBucket])) prereqs ... + +A backend bucket is created whether or not the Cloud Storage bucket it names +exists, so this is an ordering for the caller's sake (the backend bucket +never points at nothing, and a teardown removes it first), not something a +@create@ would otherwise fail on. +-} +afterStorageBuckets :: ApplicationLoadBalancer -> (BackendBucket -> [Op]) -> Part -> [Op] +afterStorageBuckets alb needs part = + concat [needs b | b <- alb.albBuckets, backendBucketPart alb b.backendBucketName == part] + +partOps :: (Part -> [Op]) -> [Op] -> Reporter Report -> Track' (Binary "gcloud") -> ApplicationLoadBalancer -> Map.Map Part Op +partOps partPrereqs prereqs r gcloudTrack alb = nodes + where + problems = albProblems alb + + -- lazily: a node's dependencies are looked up in the map being built + nodes :: Map.Map Part Op + nodes = Map.fromList [(s.partId, mk s) | s <- lbParts alb] + + mk :: PartSpec -> Op + mk s = + withBinary gcloudTrack loadBalancingCommand (LbPartUp alb s) $ \create -> + withBinary gcloudTrack loadBalancingCommand (LbPartDown alb s) $ \delete -> + op (partKind s.partId) (deps (prereqs <> partPrereqs s.partId <> mapMaybe (`Map.lookup` nodes) s.partDeps)) $ \actions -> + actions + { help = s.partHelp + , notes = s.partNotes + , ref = partRef alb s.partId + , up = do + -- the declaration's refusals, before anything runs + unless (null problems) $ throwIO (InvalidLoadBalancer problems) + create (contramap (RunLoadBalancingCommand (LbPartUp alb s)) r) + , down = + unless (null s.partDown) $ + delete (contramap (RunLoadBalancingCommand (LbPartDown alb s)) r) + , check = + if null problems + then runCheck (LbPartCheck alb s) + else pure (invalid problems) + } + +invalid :: [Text] -> CheckResult +invalid problems = Failure ("invalid load balancer: " <> Text.intercalate "; " problems) + +runCheck :: LoadBalancingCommand -> IO CheckResult +runCheck cmd = do + (code, out, _err) <- readCreateProcessWithExitCode (prepare loadBalancingCommand cmd) "" + pure $ interpretLbCheck code (Text.decodeUtf8With TextErr.lenientDecode out) + +-- | The kind tag of a resource node: its shorthand and its @ref@'s. +partKind :: Part -> Text +partKind = \case + HealthCheckPart _ -> "gcp-lb-health-check" + NamedPortsPart _ _ -> "gcp-lb-named-ports" + BackendServicePart _ -> "gcp-lb-backend-service" + NetworkEndpointGroupPart _ -> "gcp-lb-neg" + BackendPart _ _ -> "gcp-lb-backend" + BackendBucketPart _ -> "gcp-lb-backend-bucket" + UrlMapPart -> "gcp-lb-url-map" + HttpRedirectUrlMapPart -> "gcp-lb-http-redirect-url-map" + NoHttpPart -> "gcp-lb-no-http" + DnsAuthorizationPart _ -> "gcp-lb-dns-authorization" + CertificatePart _ -> "gcp-lb-certificate" + SupersededCertificatesPart _ -> "gcp-lb-superseded-certificates" + AddressPart -> "gcp-lb-address" + HttpProxyPart -> "gcp-lb-http-proxy" + HttpsProxyPart -> "gcp-lb-https-proxy" + ForwardingRulePart -> "gcp-lb-forwarding-rule" + HttpsForwardingRulePart -> "gcp-lb-https-forwarding-rule" + LeftoversPart -> "gcp-lb-leftovers" + +{- | The effect site of a resource node: the resource's own name where it has +one that is not the balancer's (a health check, a certificate), the +balancer's where the resource is named after it. An instance group's named +ports are keyed on the balancer /and/ the group, since each balancer sets +only its own names there. +-} +partRef :: ApplicationLoadBalancer -> Part -> Ref +partRef alb part = mkRef (partKind part) (alb.albProject.projectId, alb.albRegion.regionName, key) + where + key :: [Text] + key = case part of + HealthCheckPart n -> [n] + NamedPortsPart ig loc -> [alb.albName, ig, Text.pack (show loc)] + BackendServicePart n -> [n] + NetworkEndpointGroupPart n -> [n] + BackendPart svc g -> [svc, g] + BackendBucketPart n -> [n] + DnsAuthorizationPart n -> [n] + CertificatePart n -> [n] + SupersededCertificatesPart base -> [base] + _ -> [alb.albName] + +{- | What a re-declaration can be seen to change: the hosts served, the +named services, the timeouts, the port each service sends to, the +certificates. Empty for a balancer with none of those. +-} +albNotes :: ApplicationLoadBalancer -> [Text] +albNotes alb = + [ "hosts " <> Text.unwords r.hostRuleHosts + | r <- alb.albHostRules + ] + <> [ "service " <> svc.svcResource <> maybe "" (\t -> " timeout " <> Text.pack (show t) <> "s") svc.svcTimeout + | svc <- services alb + , svc.svcLabel /= "backend" || svc.svcTimeout /= Nothing + ] + <> [ "named port " <> n <> ":" <> Text.pack (show p) <> " on " <> ig + | ((ig, _), named) <- groupNamedPorts alb + , (n, p) <- nub named + ] + <> map certNote alb.albCertificates + <> [ "backend bucket " <> bucketResource alb b.backendBucketName <> " on " <> b.backendBucketGcsBucket + | b <- alb.albBuckets + ] + <> [ "hosts " <> Text.unwords r.hostRuleHosts <> ": " <> targetText alb r.hostRuleService + | r <- alb.albHostRules + , isRedirect r.hostRuleService + ] + <> [ "bucket routes allowed (known to have broken a live balancer)" + | alb.albBucketRoutes == AllowBucketRoutesKnownToHaveBrokenALiveBalancer + ] + <> case alb.albHttp of + HttpCreatedOnce -> [] + ServeHttp -> ["http served"] + RedirectToHttps code -> ["http redirects to https (" <> redirectCodeText code <> ")"] + NoHttp -> ["no http listener"] + where + isRedirect = \case + RedirectTo _ -> True + _ -> False + certNote = \case + ManagedCertificate n ds -> "managed certificate " <> n <> " for " <> Text.unwords ds + c@(DomainSetCertificate _ ds) -> "managed certificate " <> certificateResource c <> " for " <> Text.unwords ds + ComputeCertificate n -> "certificate " <> n + +{- | The address GCP gave the balancer's forwarding rule. 'Nothing' when the +rule does not exist yet. + +Out of graph, like "Salmon.Builtin.Nodes.Gcp.Compute".@readAddress@: the +address is picked at creation, so nothing can name it when the graph is +declared. It is what a DNS record pointing at the balancer resolves at @up@ +(see "Salmon.Builtin.Nodes.Gcp.CloudDns".@resolvedRecordSet@). +-} +readAddress :: ApplicationLoadBalancer -> IO (Maybe Text) +readAddress alb = do + (code, out, _err) <- + readCreateProcessWithExitCode (prepare loadBalancingCommand (LbAddressDescribe alb)) "" + let ip = Text.strip (Text.decodeUtf8With TextErr.lenientDecode out) + pure $ case code of + ExitSuccess | not (Text.null ip) -> Just ip + _ -> Nothing + +-- | The record a DNS authorization asks the domain's zone to carry. +data DnsAuthorizationRecord = DnsAuthorizationRecord + { authorizationRecordName :: Text + , authorizationRecordType :: Text + , authorizationRecordData :: Text + } + deriving (Eq, Show) + +{- | The DNS authorizations a balancer's managed certificates need, as +@(domain, authorization name)@. The name is derived from the certificate's +(a 'DomainSetCertificate''s base, so it does not move with the set) and the +domain's, so the node that creates one and the reader that asks for its +record compute the same thing. +-} +dnsAuthorizations :: ApplicationLoadBalancer -> [(Text, Text)] +dnsAuthorizations alb = + [ (d, authorizationName base d) + | (_, base, ds) <- managedCertificates alb + , d <- ds + ] + +authorizationName :: Text -> Text -> Text +authorizationName cert domain = + cert <> "-" <> Text.map (\c -> if c == '.' || c == '*' then '-' else c) (Text.toLower domain) + +{- | The record GCP wants published for one authorization (by its name, see +'dnsAuthorizations'). 'Nothing' until the authorization exists, i.e. until +the balancer's @up@ has run -- out of graph for the reason 'readAddress' is. +-} +readDnsAuthorizationRecord :: ApplicationLoadBalancer -> Text -> IO (Maybe DnsAuthorizationRecord) +readDnsAuthorizationRecord alb authz = do + (code, out, _err) <- + readCreateProcessWithExitCode (prepare loadBalancingCommand (LbDnsAuthorizationDescribe alb authz)) "" + pure $ case code of + ExitSuccess -> parseDnsAuthorizationRecord (Text.decodeUtf8With TextErr.lenientDecode out) + _ -> Nothing + +{- | Reads @describe --format=value(dnsResourceRecord.name, +dnsResourceRecord.type,dnsResourceRecord.data)@: three tab-separated +fields on one line. +-} +parseDnsAuthorizationRecord :: Text -> Maybe DnsAuthorizationRecord +parseDnsAuthorizationRecord out = + case filter (not . Text.null) (map Text.strip (Text.lines out)) of + [l] -> case filter (not . Text.null) (map Text.strip (Text.splitOn "\t" l)) of + [n, t, d] -> Just (DnsAuthorizationRecord n t d) + _ -> Nothing + _ -> Nothing + +-- | The verdict drawn from @gcloud compute url-maps describe@'s exit code. +-- This only tells us the URL map exists; 'interpretLbCheck' is what the node +-- itself uses and looks at every sub-resource and the backends' health. +interpretLbDescribe :: ExitCode -> CheckResult +interpretLbDescribe ExitSuccess = Success +interpretLbDescribe (ExitFailure n) = Failure ("load balancer not found (exit " <> Text.pack (show n) <> ")") + +{- | The verdict drawn from 'renderLbCheckScript''s exit code and stdout. + +The script prints @MISSING @ for each absent sub-resource, unattached +backend, unrouted host, wrong timeout, wrong port name or named port absent +from its instance group, @HEALTH @ per +backend instance of an instance-group backend, @CERT @ per +managed certificate, and @PROBLEM @ for what is there and wrong in a +way no create fixes (a certificate covering other names than the declared +ones, one whose renewal failed, an expired one). A missing piece is a +'Failure' (the node's @up@ is idempotent and will create it), and so is a +problem and a certificate GCP reports @FAILED@. Backends that are not (yet) @HEALTHY@ are 'Unknown': a freshly +brought-up balancer reports @UNHEALTHY@ for roughly two minutes, and +re-running @up@ would not shorten that; a certificate still @PROVISIONING@ +is 'Unknown' for the same reason, and so is @WAITING @, something no +@up@ would do yet (a superseded certificate the proxy has not moved off). A +Cloud Run (NEG) backend has no health to +ask for, so its presence and attachment is the whole check. +-} +interpretLbCheck :: ExitCode -> Text -> CheckResult +interpretLbCheck (ExitFailure n) _ = Failure ("load balancer check failed (exit " <> Text.pack (show n) <> ")") +interpretLbCheck ExitSuccess out + | not (null missing) = Failure ("load balancer incomplete: missing " <> Text.intercalate ", " missing) + | not (null problems) = Failure ("load balancer: " <> Text.intercalate "; " problems) + | not (null failedCerts) = Failure ("certificate provisioning failed: " <> Text.intercalate ", " failedCerts) + | not (null unhealthy) || not (null pendingCerts) || waiting = Unknown + | otherwise = Success + where + ls = map Text.words (Text.lines out) + waiting = not (null [() | ("WAITING" : _) <- ls]) + missing = [Text.unwords rest | ("MISSING" : rest) <- ls] + problems = [Text.unwords rest | ("PROBLEM" : rest) <- ls] + unhealthy = [st | ["HEALTH", _, st] <- ls, st /= "HEALTHY"] + failedCerts = [n | ["CERT", n, "FAILED"] <- ls] + pendingCerts = [n | ["CERT", n, st] <- ls, st /= "ACTIVE", st /= "FAILED"] + +------------------------------------------------------------------------------- + +data LoadBalancingCommand + = LbCreate ApplicationLoadBalancer + | LbCheck ApplicationLoadBalancer + | LbHealth ApplicationLoadBalancer + | LbPartUp ApplicationLoadBalancer PartSpec + | LbPartCheck ApplicationLoadBalancer PartSpec + | LbPartDown ApplicationLoadBalancer PartSpec + | LbDescribe ApplicationLoadBalancer + | LbDelete ApplicationLoadBalancer + | LbAddressDescribe ApplicationLoadBalancer + | LbDnsAuthorizationDescribe ApplicationLoadBalancer Text + deriving (Show) + +{- | A script of @gcloud@ calls, run by @bash@ with gcloud's prompts turned +off: these calls do not go through 'gcloudProc', which is where every other +invocation gets its @--quiet@. +-} +bashScript :: Text -> CreateProcess +bashScript script = proc "bash" ["-c", Text.unpack (disablePromptsLine <> "\n" <> script)] + +loadBalancingCommand :: Command "gcloud" LoadBalancingCommand +loadBalancingCommand = Command $ \cmd -> case cmd of + LbCreate alb -> + -- One bash script of guarded gcloud calls. It 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@. + bashScript (renderLbScript alb) + LbDescribe alb -> + gcloudProc $ + withProject alb.albProject + ( withRegion alb.albRegion + [ "compute" + , "url-maps" + , "describe" + , Text.unpack (alb.albName <> "-url-map") + ] + ) + LbCheck alb -> + bashScript (renderLbCheckScript alb) + LbHealth alb -> + bashScript (renderLbHealthScript alb) + LbPartUp alb part -> + bashScript (renderPartUpScript alb part) + LbPartCheck alb part -> + bashScript (renderPartCheckScript alb part) + LbPartDown alb part -> + bashScript (renderPartDownScript alb part) + LbAddressDescribe alb -> + gcloudProc $ + withProject alb.albProject + ( withRegion alb.albRegion + [ "compute" + , "forwarding-rules" + , "describe" + , -- with HTTPS on, both rules sit on one reserved + -- address, and the HTTPS one is the one that matters + Text.unpack (alb.albName <> if serveHttps alb then "-https-fw" else "-fw") + , "--format" + , "value(IPAddress)" + ] + ) + LbDnsAuthorizationDescribe alb authz -> + gcloudProc $ + withProject + alb.albProject + [ "certificate-manager" + , "dns-authorizations" + , "describe" + , Text.unpack authz + , "--format" + , "value(dnsResourceRecord.name,dnsResourceRecord.type,dnsResourceRecord.data)" + , "--location" + , Text.unpack alb.albRegion.regionName + ] + LbDelete alb -> + bashScript (renderLbDeleteScript alb) + +serveHttps :: ApplicationLoadBalancer -> Bool +serveHttps = not . null . albCertificates + +{- | A backend service as the scripts see it: the default one and the named +ones, under their resource names. +-} +data Svc = Svc + { svcLabel :: Text + -- ^ what a @HEALTH@ line calls it + , svcResource :: Text + , svcNeg :: Text + , svcBackends :: [Backend] + , svcHealthCheck :: Maybe HealthCheck + , svcTimeout :: Maybe Int + } + +services :: ApplicationLoadBalancer -> [Svc] +services alb = + Svc "backend" (alb.albName <> "-backend") (alb.albName <> "-neg") alb.albBackends alb.albHealthCheck alb.albTimeoutSec + : map named alb.albServices + where + named :: BackendService -> Svc + named s = + Svc + s.backendServiceName + (serviceResource alb (NamedService s.backendServiceName)) + (alb.albName <> "-" <> s.backendServiceName <> "-neg") + s.backendServiceBackends + s.backendServiceHealthCheck + s.backendServiceTimeoutSec + +{- | The resource a rule's target is: a backend service's name, a backend +bucket's. A redirect is no resource, and is described instead. +-} +serviceResource :: ApplicationLoadBalancer -> ServiceRef -> Text +serviceResource alb = \case + DefaultService -> alb.albName <> "-backend" + NamedService n -> alb.albName <> "-" <> n <> "-backend" + NamedBucket n -> bucketResource alb n + RedirectTo r -> redirectText r + +bucketResource :: ApplicationLoadBalancer -> Text -> Text +bucketResource alb n = alb.albName <> "-" <> n <> "-bucket" + +-- | A rule's target as a note says it: a backend service by its bare name, as before. +targetText :: ApplicationLoadBalancer -> ServiceRef -> Text +targetText alb = \case + NamedBucket n -> "backend bucket " <> bucketResource alb n + sref -> serviceResource alb sref + +-- | The resource node a rule's target needs first, when it is a resource. +targetPart :: ApplicationLoadBalancer -> ServiceRef -> Maybe Part +targetPart alb = \case + RedirectTo _ -> Nothing + NamedBucket n -> Just (BackendBucketPart (bucketResource alb n)) + sref -> Just (BackendServicePart (serviceResource alb sref)) + +-- | Every target a declaration's rules name, the default service first. +targets :: ApplicationLoadBalancer -> [ServiceRef] +targets alb = + DefaultService : concat [r.hostRuleService : map pathRuleService r.hostRulePaths | r <- alb.albHostRules] + +-- | A rewrite as a note says it, after the rule's target; nothing for 'KeepPath'. +rewriteText :: PathRewrite -> Text +rewriteText = \case + KeepPath -> "" + RewritePrefix prefix -> " with the matched prefix rewritten to " <> prefix + +redirectCodeText :: RedirectCode -> Text +redirectCodeText = \case + MovedPermanently -> "MOVED_PERMANENTLY_DEFAULT" + Found -> "FOUND" + SeeOther -> "SEE_OTHER" + TemporaryRedirect -> "TEMPORARY_REDIRECT" + PermanentRedirect -> "PERMANENT_REDIRECT" + +redirectText :: Redirect -> Text +redirectText r = + Text.unwords + [ "redirect" + , redirectCodeText r.redirectCode + , (if r.redirectHttps then "https://" else "") + <> fromMaybe "{host}" r.redirectHost + <> fromMaybe "{path}" r.redirectPath + ] + +-- | A redirect as a URL map's @urlRedirect@. +renderRedirect :: Redirect -> Aeson.Value +renderRedirect r = + Aeson.object $ + ["hostRedirect" Aeson..= h | Just h <- [r.redirectHost]] + <> ["pathRedirect" Aeson..= path | Just path <- [r.redirectPath]] + <> [ "httpsRedirect" Aeson..= r.redirectHttps + , "redirectResponseCode" Aeson..= redirectCodeText r.redirectCode + , "stripQuery" Aeson..= False + ] + +healthChecks :: ApplicationLoadBalancer -> [HealthCheck] +healthChecks alb = nub [hc | Just hc <- map svcHealthCheck (services alb)] + +{- | The named port a backend service sends to, when it has an instance +group to send to and a port declared on it: the service's own resource name. + +It used to be GCP's default, @http@, for every service -- so two services on +one instance group both sent to whichever port @http@ was last set to, with +healthy backends and no error anywhere. A name per service is what lets one +group carry a port for each. +-} +svcPortName :: Svc -> Maybe Text +svcPortName svc + | null [() | InstanceGroupBackend _ _ (_ : _) <- svc.svcBackends] = Nothing + | otherwise = Just svc.svcResource + +{- | The named ports this balancer wants on each instance group: the union +over every backend service naming the group, in declaration order. One entry +per group, because @set-named-ports@ replaces a group's whole set and so +cannot be called once per service. +-} +groupNamedPorts :: ApplicationLoadBalancer -> [((Text, InstanceGroupLocation), [(Text, Int)])] +groupNamedPorts alb = + [ (g, concat [named | (g', named) <- perBackend, g' == g]) + | g <- nub (map fst perBackend) + ] + where + perBackend = + [ ((ig, loc), zipWith (portName svc.svcResource) [0 :: Int ..] ports) + | svc <- services alb + , InstanceGroupBackend ig loc ports@(_ : _) <- svc.svcBackends + ] + portName base 0 p = (base, p) + portName base i p = (base <> "-" <> Text.pack (show i), p) + +isInstanceGroup :: Backend -> Bool +isInstanceGroup = \case + InstanceGroupBackend{} -> True + CloudRunBackend _ -> False + +{- | The URL map as the resource @gcloud compute url-maps import@ reads. +JSON, which is YAML: one path matcher per host rule, named by position. + +A map with host rules carries a @description@: a fingerprint of the rest of +it ('urlMapStamp'), which is how the check tells the map that is there from +the declared one beyond its hosts. A map with no rule has none, and neither +@hostRules@ nor @pathMatchers@: it is what @url-maps create +--default-service@ makes, and is imported only to take rules off a map that +has some (see 'lbParts'). +-} +renderUrlMap :: ApplicationLoadBalancer -> Aeson.Value +renderUrlMap alb = + Aeson.object (urlMapFields alb <> ["description" Aeson..= stamp | Just stamp <- [urlMapStamp alb]]) + +{- | The fingerprint a URL map with host rules is stamped with (its +@description@), 'Nothing' for a map with none. + +It is the /declaration's/ fingerprint: a map edited by hand that kept its +description still reads as the declared one. How much the check leans on it +depends on what the map names, see 'urlMapStampIsRequired'. +-} +urlMapStamp :: ApplicationLoadBalancer -> Maybe Text +urlMapStamp alb + | null alb.albHostRules = Nothing + | otherwise = Just (stampOf (Aeson.object (urlMapFields alb))) + +{- | Whether the check /requires/ the live map to carry the declared +fingerprint, or only refuses a different one. + +Required for a map naming a backend bucket or a redirect, or rewriting a +path, as it has been since those exist: there, the same hosts can be a +different map (a redirect sent elsewhere, another path asked of the backend). A map of backend services only was written without a +description until it got one, and such a map is live under balancers that +are up: requiring the stamp would re-import every one of them on the first +pass, and would never settle if @url-maps import@ turned out not to keep a +@description@ (which nobody has verified on a real project). So for those the +stamp only ever speaks against a map: a live description that is a +@salmon:@ fingerprint other than the declared one is a map salmon wrote for +another declaration, and one with no such description is judged on its host +set alone. +-} +urlMapStampIsRequired :: ApplicationLoadBalancer -> Bool +urlMapStampIsRequired alb = + any novel (targets alb) + || any ((/= KeepPath) . pathRuleRewrite) (concatMap hostRulePaths alb.albHostRules) + where + novel = \case + NamedBucket _ -> True + RedirectTo _ -> True + _ -> False + +stampOf :: Aeson.Value -> Text +stampOf v = + "salmon:" + <> Text.pack (concatMap hex (ByteString.unpack (ByteString.take 8 (SHA256.hash (LByteString.toStrict (Aeson.encode v)))))) + where + hex w = let h = showHex w "" in if length h < 2 then '0' : h else h + +{- | What this balancer writes in the @description@ of the backend buckets, +Certificate Manager certificates and DNS authorizations it declares, and the +only thing that makes one of them, once it is no longer declared, this +balancer's to delete (see 'lbParts'). It names the balancer, because a name +alone does not: @web-eu-assets-bucket@ is balancer @web@'s by its shape and +balancer @web-eu@'s in fact. +-} +ownershipMarker :: ApplicationLoadBalancer -> Text +ownershipMarker alb = "salmon:lb:" <> alb.albName + +httpRedirectUrlMapName :: ApplicationLoadBalancer -> Text +httpRedirectUrlMapName alb = alb.albName <> "-http-redirect-url-map" + +{- | The second URL map of 'RedirectToHttps': no host rule, no service, every +request answered with a redirect to the same host and path over HTTPS. It +carries its own fingerprint as @description@, like a stamped 'renderUrlMap'. +-} +renderHttpRedirectUrlMap :: ApplicationLoadBalancer -> RedirectCode -> Aeson.Value +renderHttpRedirectUrlMap alb code = + Aeson.object (fields <> ["description" Aeson..= stampOf (Aeson.object fields)]) + where + fields = + [ "name" Aeson..= httpRedirectUrlMapName alb + , "defaultUrlRedirect" Aeson..= renderRedirect (Redirect Nothing Nothing True code) + ] + +{- | Every @description@ a redirect-only map of this balancer can carry: the +fingerprint 'renderHttpRedirectUrlMap' writes, for each code there is. A map +under that name with one of these is one this module wrote. +-} +httpRedirectUrlMapStamps :: ApplicationLoadBalancer -> [Text] +httpRedirectUrlMapStamps alb = + [ stamp + | code <- [MovedPermanently, Found, SeeOther, TemporaryRedirect, PermanentRedirect] + , Aeson.Object o <- [renderHttpRedirectUrlMap alb code] + , Just (Aeson.String stamp) <- [KeyMap.lookup "description" o] + ] + +urlMapFields :: ApplicationLoadBalancer -> [Aeson.Pair] +urlMapFields alb = + [ "name" Aeson..= (alb.albName <> "-url-map") + , "defaultService" Aeson..= serviceUrl DefaultService + ] + <> concat + [ [ "hostRules" Aeson..= map hostRule rules + , "pathMatchers" Aeson..= map pathMatcher rules + ] + | not (null rules) + ] + where + rules = zip [0 :: Int ..] alb.albHostRules + matcher :: Int -> Text + matcher i = "m" <> Text.pack (show i) + hostRule :: (Int, HostRule) -> Aeson.Value + hostRule (i, r) = + Aeson.object ["hosts" Aeson..= r.hostRuleHosts, "pathMatcher" Aeson..= matcher i] + pathMatcher :: (Int, HostRule) -> Aeson.Value + pathMatcher (i, r) = + Aeson.object $ + [ "name" Aeson..= matcher i + , target "defaultService" "defaultUrlRedirect" r.hostRuleService + ] + <> ["pathRules" Aeson..= map pathRule r.hostRulePaths | not (null r.hostRulePaths)] + pathRule :: PathRule -> Aeson.Value + pathRule p = + Aeson.object $ + ["paths" Aeson..= p.pathRulePaths, target "service" "urlRedirect" p.pathRuleService] + -- absent, not empty, without a rewrite: the map (and its + -- fingerprint) of a declaration with none is what it was + <> [ "routeAction" Aeson..= Aeson.object ["urlRewrite" Aeson..= Aeson.object ["pathPrefixRewrite" Aeson..= prefix]] + | RewritePrefix prefix <- [p.pathRuleRewrite] + ] + -- a backend bucket goes where a backend service does; a redirect has a key of its own + target :: Aeson.Key -> Aeson.Key -> ServiceRef -> Aeson.Pair + target serviceKey redirectKey = \case + RedirectTo r -> redirectKey Aeson..= renderRedirect r + sref -> serviceKey Aeson..= serviceUrl sref + serviceUrl :: ServiceRef -> Text + serviceUrl sref = + "https://www.googleapis.com/compute/v1/projects/" + <> alb.albProject.projectId + <> "/regions/" + <> alb.albRegion.regionName + <> collection + <> serviceResource alb sref + where + collection = case sref of + NamedBucket _ -> "/backendBuckets/" + _ -> "/backendServices/" + +{- | 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 <> "'" + +-- | One resource of a balancer, as 'lbParts' and the node graph name it. +data Part + = HealthCheckPart Text + | -- | the named ports this balancer wants on one instance group + NamedPortsPart Text InstanceGroupLocation + | -- | by resource name (@\-backend@, @\-\-backend@) + BackendServicePart Text + | NetworkEndpointGroupPart Text + | -- | a backend service's resource name, and the instance group or NEG attached to it + BackendPart Text Text + | -- | by resource name (@\-\-bucket@) + BackendBucketPart Text + | UrlMapPart + | -- | the redirect-only URL map of 'RedirectToHttps' + HttpRedirectUrlMapPart + | -- | 'NoHttp': the removal of the HTTP proxy and the @:80@ rule + NoHttpPart + | -- | by authorization name, see 'dnsAuthorizations' + DnsAuthorizationPart Text + | -- | by resource name, see 'certificateResource' + CertificatePart Text + | -- | by a 'DomainSetCertificate''s base name: the deletion of the + -- certificates of that base the proxy no longer serves + SupersededCertificatesPart Text + | AddressPart + | HttpProxyPart + | HttpsProxyPart + | ForwardingRulePart + | HttpsForwardingRulePart + | -- | the removal of what this balancer made and no longer declares: backend + -- buckets, Certificate Manager certificates, DNS authorizations and the + -- redirect-only URL map (see 'lbParts') + LeftoversPart + deriving (Eq, Ord, Show) + +{- | A resource, the resources it needs first, and the lines of bash that +create it, ask after it and remove it. The lines read @$PROJECT@ and +@$REGION@ and the helpers the scripts' headers define, so they only run +inside 'renderPartUpScript' and friends (or the whole-balancer scripts, +which are these lines concatenated). +-} +data PartSpec = PartSpec + { partId :: Part + , partDeps :: [Part] + , partHelp :: Text + , partNotes :: [Text] + -- ^ what a re-declaration can be seen to change about this resource + , partUp :: [Text] + , partCheck :: [Text] + -- ^ read-only; findings are @MISSING@\/@CERT@ lines, see 'interpretLbCheck' + , partDown :: [Text] + -- ^ empty for what this recipe sets but does not own (a group's named ports) + } + deriving (Eq, Show) + +{- | The balancer as resources, in an order in which every resource comes +after the ones it depends on. + +The edges: + +* a backend service depends on its health check; +* a backend attachment depends on its backend service, on the NEG or on the + instance group's named ports it sends to, and on the attachment declared + before it on the same service -- two @add-backend@ calls on one backend + service must not run at once, and an edge is the only thing that says so; +* the URL map depends on every backend service and backend bucket it names; +* a managed certificate depends on its DNS authorizations; +* the HTTP proxy depends on the URL map (on the redirect-only one under + 'RedirectToHttps'), the HTTPS one on the certificates too; +* a forwarding rule depends on its proxy, and on the reserved address when + there is one. + +Some things are /set/ on every @up@ of their node rather than guarded, +because they are declarations that can change under a resource that already +exists: a backend service's timeout and port name (@update --timeout@, +@update --port-name@), an instance group's named ports and, when there are +host rules, the whole URL map (@url-maps import@, which replaces it). A URL +map with no host rule is created once, and imported only when the map that is +there has host rules (the last rule of a declaration taken away). + +The URL map's check compares hosts as a set: a declared host the map lacks, +and a host of the map that no rule declares, are both findings, so a rule +removed from the declaration is imported away. The map is this balancer's by +its name, and that makes a host rule added to it by hand one the next @up@ +removes (it already did whenever anything else made the map's @up@ run). +Which service a host is sent to, and its path rules, are seen only through +the fingerprint in the map's @description@: required of a map naming a +bucket or a redirect, and for a map of backend services only a finding just +when the live fingerprint is another declaration's -- a map written before +maps of services were stamped has none and is left alone until something +else imports it ('urlMapStampIsRequired'). +Everything else is guarded by a @describe@ (or, for an attachment, a look at +the backend service's current backends) and never suffixed with @|| true@: +a failing create fails its node. + +An instance group's named ports are set once per group, the union over the +services naming it, and /merged/ with what the group already carries: +@set-named-ports@ replaces the whole set, and the group is the caller's -- +another balancer, or the caller, may have named ports on it. Only the names +this balancer declares are overwritten. Nothing removes a name: one this +balancer stopped declaring stays on the group, where it does no harm, and so +does everything on @down@. + +The HTTPS proxy's certificate list is the one declaration that is neither +created once nor set on every @up@: it is compared, and updated +(@target-https-proxies update@) only when it differs /and/ every declared +managed certificate is @ACTIVE@. Until then the proxy serves what it served +and its check reads 'Unknown' (the certificate's state) rather than a +'Failure' no @up@ would fix. What its @up@ does in the meantime depends on +the declaration. With a 'DomainSetCertificate' in it, a certificate still +being issued is the expected middle of a swap, which takes minutes to an +hour: @up@ names the certificate on stderr, prints a @PENDING certificate +swap@ line, touches nothing and /succeeds/, so the pass exits 0 with TLS +served on the old certificate and neither the root nor anything hung on it is +'Blocked'; a later pass (or the tending loop, whose check turns to a +'Failure' once the certificate is @ACTIVE@) makes the move. A certificate +that is @FAILED@ or absent will never be @ACTIVE@ and still fails the node. +Without a 'DomainSetCertificate' (a certificate added or renamed under a +'ManagedCertificate') @up@ fails as it always did, naming the certificate +that is not @ACTIVE@. That, with a 'DomainSetCertificate' being a new resource whenever its +domain set changes, is how a certificate is replaced on a live balancer: +create beside, wait, move the proxy, and only then delete -- the last by a +node of its own per base ('SupersededCertificatesPart'), which depends on the +proxy, lists the base's certificates, and deletes those that are not the +declared one and that the proxy does not serve; one the proxy still serves is +left and said (not a failure of @up@, and @WAITING@, so 'Unknown', for the +check) until the swap is made. A managed certificate's own +@down@ refuses the same way while the proxy still lists it, so a retired +declaration's teardown cannot pull a certificate out from under a proxy that +has not moved yet. The proxy's URL map is named at creation and never set +again. + +The HTTP proxy's URL map is the same by default ('HttpCreatedOnce'): named +at creation, never set again. Under 'ServeHttp' and 'RedirectToHttps' it is +compared and updated when it differs. 'NoHttp' is a node whose @up@ removes +the @:80@ rule and the HTTP proxy. + +Nothing in a declaration remembers what it used to name, so what a balancer +made and no longer declares is found on GCP, by the last node +('LeftoversPart'), which comes after the URL map, the proxies and the +superseded certificates. It deletes four kinds of resource and no other, each +under a proof that this balancer made it, and never one still in use: + +* a backend bucket named @\-\-bucket@ whose @description@ is + 'ownershipMarker', once no URL map of the project names it; +* a Certificate Manager certificate whose @description@ is the marker, once + no HTTPS proxy of the project serves it (so not the old certificate of a + swap still pending, nor one the proxy of a failed pass is still on); +* a DNS authorization whose @description@ is the marker, once no certificate + of the location uses it (the record published for it is the caller's); +* the redirect-only map @\-http-redirect-url-map@, when the + declaration is no longer 'RedirectToHttps', its @description@ is one of the + fingerprints this module writes for it and no proxy of the project is on + it. Under 'HttpCreatedOnce' the HTTP proxy is never moved off it, so there + it stays for as long as that proxy does. + +The marker is written by that same node, on the declared resources that +exist and have no description (@update --description@), so the scripts of the +resources themselves are what they were. A resource that is no longer +declared and was never marked -- one dropped from the declaration before the +marker existed -- is therefore __not__ deleted, and neither is one carrying +somebody's description: both are left for a command by hand. A listing only +enumerates candidates; what is deleted is what carries the marker. + +What is still in use is said (@WAITING@, so 'Unknown', for the check; a line +on stderr for @up@) and left. A delete or a marking that fails fails that +node, and so the pass and the balancer's root: it is the last node, so every +resource that serves traffic was applied before it. A listing that fails (the +Certificate Manager API of a balancer that never had a certificate) is said +and is nothing to clean. + +Not done: none of this runs at teardown, where a leftover is left behind (as +is a superseded certificate of a swap that never completed); a backend +service, a health check, a NEG, the HTTPS proxy, its rule and the address of +a declaration that no longer names them are not removed. + +On the way down an attachment is /detached/ (@remove-backend@) rather than +left to the backend service's deletion, because a NEG still attached cannot +be deleted and the NEG's node knows nothing of the service's. An instance +group is never deleted (it is the caller's), nor is a 'ComputeCertificate'. + +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. Nothing here creates one -- see +"Salmon.Builtin.Nodes.Gcp.Compute".@subnet@ with +'Salmon.Builtin.Nodes.Gcp.Compute.RegionalManagedProxy', which is a +prerequisite to hand 'applicationLoadBalancerAfter'. +-} +lbParts :: ApplicationLoadBalancer -> [PartSpec] +lbParts alb = + nubBy ((==) `on` partId) $ + map healthCheckPart (healthChecks alb) + <> map namedPortsPart groups + <> concatMap serviceParts (services alb) + <> map bucketPart alb.albBuckets + <> [urlMapPart] + <> concatMap certificateParts alb.albCertificates + <> [addressPart | https] + <> [httpRedirectUrlMapPart code | RedirectToHttps code <- [alb.albHttp]] + <> [httpProxyPart | http] + <> [httpsProxyPart | https] + <> [supersededPart base (certificateResource c) | c@(DomainSetCertificate base _) <- alb.albCertificates] + <> [forwardingRulePart | http] + <> [httpsForwardingRulePart | https] + <> [noHttpPart | not http] + <> [leftoversPart] + where + https = serveHttps alb + http = alb.albHttp /= NoHttp + -- whether a certificate here is replaced by a swap (see 'httpsProxyPart') + domainSets = not (null [() | DomainSetCertificate _ _ <- alb.albCertificates]) + groups = groupNamedPorts alb + + resourceName :: Text -> Text + resourceName suffix = shellQuote (alb.albName <> suffix) + + ensure :: Text -> Text -> Text + ensure describeCmd createCmd = + "exists " <> describeCmd <> " || " <> createCmd + + need :: Text -> Text -> Text + need what describeCmd = "need " <> shellQuote what <> " " <> describeCmd + + describeCompute :: Text -> Text -> Text + describeCompute coll name = "gcloud compute " <> coll <> " describe " <> shellQuote name <> regional + + deleteCompute :: Text -> Text -> Text + deleteCompute coll name = + "if exists " <> describeCompute coll name + <> "; then gcloud compute " <> coll <> " delete " <> shellQuote name + <> regional <> " --quiet; fi" + + describeLocated :: Text -> Text -> Text + describeLocated coll name = "gcloud certificate-manager " <> coll <> " describe " <> shellQuote name <> located + + deleteLocated :: Text -> Text -> Text + deleteLocated coll name = + "if exists " <> describeLocated coll name + <> "; then gcloud certificate-manager " <> coll <> " delete " <> shellQuote name + <> located <> " --quiet; fi" + + -- A resource that is created once and has nothing to set afterwards. + simple :: Part -> [Part] -> Text -> Text -> Text -> Text -> PartSpec + simple part needs what coll name createFlags = + PartSpec + { partId = part + , partDeps = needs + , partHelp = Text.unwords [what, name] + , partNotes = [] + , partUp = + [ ensure + (describeCompute coll name) + ("gcloud compute " <> coll <> " create " <> shellQuote name <> regional <> createFlags) + ] + , partCheck = [need (coll <> " " <> name) (describeCompute coll name)] + , partDown = [deleteCompute coll name] + } + + healthCheckPart :: HealthCheck -> PartSpec + healthCheckPart hc = + ( simple + (HealthCheckPart hc.healthCheckName) + [] + "health check" + "health-checks" + hc.healthCheckName + "" + ) + { partNotes = ["tcp port " <> Text.pack (show hc.healthCheckPort)] + , partUp = + [ ensure + (describeCompute "health-checks" hc.healthCheckName) + ( "gcloud compute health-checks create tcp " <> shellQuote hc.healthCheckName + <> regional + <> " --port=" + <> Text.pack (show hc.healthCheckPort) + ) + ] + } + + -- set-named-ports replaces the whole set, so: one call per group, + -- carrying every port of every service naming it, after whatever the + -- group already has under names that are not ours. The read is an + -- assignment on a line of its own so that its failing fails the script + -- (a command substitution inside an argument would not). + namedPortsPart :: ((Text, InstanceGroupLocation), [(Text, Int)]) -> PartSpec + namedPortsPart ((ig, loc), named) = + PartSpec + { partId = NamedPortsPart ig loc + , partDeps = [] + , partHelp = Text.unwords ["named ports of load balancer", alb.albName, "on instance group", ig] + , partNotes = [n <> ":" <> Text.pack (show p) | (n, p) <- nub named] + , partUp = + [ "keep=$(gcloud compute instance-groups get-named-ports " <> shellQuote ig + <> groupLocation loc + <> " --format='value(name,port)' | awk -v ours=" + <> shellQuote (Text.unwords (map fst named)) + <> " " + <> shellQuote "BEGIN{n=split(ours,x,\" \");for(i=1;i<=n;i++)o[x[i]]=1} NF==2&&!($1 in o){printf \"%s:%s,\",$1,$2}" + <> ")" + , "gcloud compute instance-groups set-named-ports " <> shellQuote ig + <> groupLocation loc + <> " --named-ports=\"${keep}\"" + <> shellQuote (Text.intercalate "," [n <> ":" <> Text.pack (show p) | (n, p) <- nub named]) + ] + , partCheck = + [ "gcloud compute instance-groups get-named-ports " <> shellQuote ig <> groupLocation loc + <> " --format='value(name,port)' 2>/dev/null | awk -v n=" + <> shellQuote n + <> " -v p=" + <> shellQuote (Text.pack (show p)) + <> " " + <> shellQuote "$1==n&&$2==p{f=1} END{exit !f}" + <> " || echo " + <> shellQuote ("MISSING named-port " <> n <> ":" <> Text.pack (show p) <> " on instance-group " <> ig) + | (n, p) <- nub named + ] + , partDown = [] + } + + instanceGroupHealthCheck :: Svc -> Maybe HealthCheck + instanceGroupHealthCheck svc = + if any isInstanceGroup svc.svcBackends then svc.svcHealthCheck else Nothing + + serviceParts :: Svc -> [PartSpec] + serviceParts svc = servicePart svc : attachments Nothing backends + where + -- one attachment per group or NEG, whatever number of times it is listed + backends = nubBy ((==) `on` backendKey svc) svc.svcBackends + attachments _ [] = [] + attachments previous (b : bs) = + let (neg, attachment) = backendParts svc previous b + in neg <> [attachment] <> attachments (Just attachment.partId) bs + + servicePart :: Svc -> PartSpec + servicePart svc = + PartSpec + { partId = BackendServicePart svc.svcResource + , partDeps = [HealthCheckPart hc.healthCheckName | Just hc <- [instanceGroupHealthCheck svc]] + , partHelp = Text.unwords ["backend service", svc.svcResource] + , partNotes = + ["timeout " <> Text.pack (show t) <> "s" | Just t <- [svc.svcTimeout]] + <> ["port name " <> n | Just n <- [svcPortName svc]] + <> ["health check " <> hc.healthCheckName | Just hc <- [instanceGroupHealthCheck svc]] + , partUp = + [ ensure + (describeCompute "backend-services" svc.svcResource) + ( "gcloud compute backend-services create " <> shellQuote svc.svcResource + <> regional + <> " --protocol=HTTP" + <> maybe "" ((" --port-name=" <>) . shellQuote) (svcPortName svc) + <> " --load-balancing-scheme=EXTERNAL_MANAGED" + <> maybe "" (\hc -> " --health-checks=" <> shellQuote hc.healthCheckName <> " --health-checks-region=\"$REGION\"") (instanceGroupHealthCheck svc) + ) + ] + -- a set: a backend service made before it had a port + -- name of its own is still on @http@ + <> [ "gcloud compute backend-services update " <> shellQuote svc.svcResource + <> regional + <> " --port-name=" + <> shellQuote n + | Just n <- [svcPortName svc] + ] + -- a set, not a create flag: the declared timeout has to + -- reach a backend service that already exists too + <> [ "gcloud compute backend-services update " <> shellQuote svc.svcResource + <> regional + <> " --timeout=" + <> Text.pack (show t) + | Just t <- [svc.svcTimeout] + ] + , partCheck = + [need ("backend-services " <> svc.svcResource) (describeCompute "backend-services" svc.svcResource)] + <> [ "[ \"$(" <> describeCompute "backend-services" svc.svcResource + <> " --format='value(timeoutSec)' 2>/dev/null)\" = " + <> shellQuote (Text.pack (show t)) + <> " ] || echo " + <> shellQuote ("MISSING timeout " <> Text.pack (show t) <> "s on " <> svc.svcResource) + | Just t <- [svc.svcTimeout] + ] + -- a service on another port name sends to another port, or to none + <> [ "[ \"$(" <> describeCompute "backend-services" svc.svcResource + <> " --format='value(portName)' 2>/dev/null)\" = " + <> shellQuote n + <> " ] || echo " + <> shellQuote ("MISSING port-name " <> n <> " on " <> svc.svcResource) + | Just n <- [svcPortName svc] + ] + , partDown = [deleteCompute "backend-services" svc.svcResource] + } + + -- what a backend service's @backends[].group@ ends with for this backend + attachedTo :: Svc -> Text -> Text + attachedTo svc groupPathSuffix = + describeCompute "backend-services" svc.svcResource + <> " --format='value(backends[].group)' 2>/dev/null | tr ';' '\\n' | grep -q -- " + <> shellQuote (groupPathSuffix <> "$") + + -- The NEG a Cloud Run backend needs (if any), and the attachment. + -- Attaching the same backend twice is an error, so look first. + backendParts :: Svc -> Maybe Part -> Backend -> ([PartSpec], PartSpec) + backendParts svc previous backend = case backend of + InstanceGroupBackend ig loc _ -> + ( [] + , attachment + ig + [NamedPortsPart ig loc | (ig, loc) `elem` map fst groups] + ("instance group " <> ig) + ("/instanceGroups/" <> ig) + (" --instance-group=" <> shellQuote ig <> groupBackendFlag loc) + [ need ("instance-group " <> ig) ("gcloud compute instance-groups describe " <> shellQuote ig <> groupLocation loc) + ] + ("instance-group " <> ig) + ) + CloudRunBackend cr -> + ( [ simple + (NetworkEndpointGroupPart svc.svcNeg) + [] + "serverless network endpoint group" + "network-endpoint-groups" + svc.svcNeg + (" --network-endpoint-type=serverless --cloud-run-service=" <> shellQuote cr) + ] + , attachment + svc.svcNeg + [NetworkEndpointGroupPart svc.svcNeg] + ("network endpoint group " <> svc.svcNeg) + ("/networkEndpointGroups/" <> svc.svcNeg) + (" --network-endpoint-group=" <> shellQuote svc.svcNeg <> " --network-endpoint-group-region=\"$REGION\"") + [] + ("neg " <> svc.svcNeg) + ) + where + attachment key needs what suffix flags checks missing = + PartSpec + { partId = BackendPart svc.svcResource key + , partDeps = BackendServicePart svc.svcResource : needs <> maybe [] pure previous + , partHelp = Text.unwords ["attaches", what, "to backend service", svc.svcResource] + , partNotes = [] + , partUp = + [ attachedTo svc suffix + <> " || gcloud compute backend-services add-backend " <> shellQuote svc.svcResource + <> regional + <> flags + ] + , partCheck = + checks + <> [attachedTo svc suffix <> " || echo " <> shellQuote ("MISSING backend " <> missing)] + , partDown = + [ "if " <> attachedTo svc suffix + <> "; then gcloud compute backend-services remove-backend " <> shellQuote svc.svcResource + <> regional + <> flags + <> " --quiet; fi" + ] + } + + -- With rules the map is imported whole on every run: `import` creates + -- or replaces, which is the only "set" verb a URL map has + -- (`add-path-matcher` appends, and fails the second time). Without + -- rules it is created once with its default service, and imported + -- (as that same rule-less map) only when the one that is there has + -- host rules: a declaration whose last rule was taken away. + -- + -- The check compares the hosts as a set, both ways: a declared host + -- the map lacks, and a host of the map no rule declares. Which + -- service a host goes to, and its paths, are only seen through the + -- fingerprint (see 'urlMapStampIsRequired'). + urlMapPart :: PartSpec + urlMapPart = + PartSpec + { partId = UrlMapPart + , partDeps = nub (mapMaybe (targetPart alb) (targets alb)) + , partHelp = Text.unwords ["URL map", urlMap] + , partNotes = + concat + [ ("hosts " <> Text.unwords r.hostRuleHosts <> " to " <> targetText alb r.hostRuleService) + : [ "paths " <> Text.unwords p.pathRulePaths <> " to " <> targetText alb p.pathRuleService <> rewriteText p.pathRuleRewrite + | p <- r.hostRulePaths + ] + | r <- alb.albHostRules + ] + , partUp = + if null alb.albHostRules + then + [ ensure + (describeCompute "url-maps" urlMap) + ( "gcloud compute url-maps create " <> shellQuote urlMap + <> regional + <> " --default-service=" <> resourceName "-backend" + ) + , "ruled=$(" <> liveHosts <> ")" + , "if [ -n \"$ruled\" ]; then " <> importMap urlMap (renderUrlMap alb) <> "; fi" + ] + else + [importMap urlMap (renderUrlMap alb)] + , partCheck = + need ("url-maps " <> urlMap) (describeCompute "url-maps" urlMap) + : [ liveHosts + <> " 2>/dev/null | grep -qxF -- " + <> shellQuote h + <> " || echo " + <> shellQuote ("MISSING host-rule " <> h) + | h <- declaredHosts + ] + <> [ liveHosts + <> " 2>/dev/null | while read -r h; do case " + <> shellQuote (" " <> Text.unwords declaredHosts <> " ") + <> " in *\" $h \"*) ;; *) echo \"MISSING removal of undeclared host-rule $h\";; esac; done; true" + ] + <> [ (if urlMapStampIsRequired alb then stampCheck else staleStampCheck) urlMap stamp + | Just stamp <- [urlMapStamp alb] + ] + , partDown = [deleteCompute "url-maps" urlMap] + } + where + urlMap = alb.albName <> "-url-map" + declaredHosts = concatMap hostRuleHosts alb.albHostRules + -- every host of every rule of the map that is there, one per + -- line, whatever separators gcloud flattens the nested lists with + liveHosts = + "{ " <> describeCompute "url-maps" urlMap + <> " --format='value(hostRules[].hosts)' | tr \";,[]' \\t\" '\\n' | sed '/^$/d'; }" + + -- whether the map that is there is the declared one, by its description + stampCheck :: Text -> Text -> Text + stampCheck urlMap stamp = + "[ \"$(" <> describeCompute "url-maps" urlMap + <> " --format='value(description)' 2>/dev/null)\" = " + <> shellQuote stamp + <> " ] || echo " + <> shellQuote ("MISSING declared rules on " <> urlMap <> " (" <> stamp <> ")") + + -- the same, for a map that may have been written before it was + -- stamped: only a fingerprint of another declaration speaks against it + staleStampCheck :: Text -> Text -> Text + staleStampCheck urlMap stamp = + "case \"$(" <> describeCompute "url-maps" urlMap + <> " --format='value(description)' 2>/dev/null)\" in " + <> shellQuote stamp + <> ") ;; salmon:*) echo " + <> shellQuote ("MISSING declared rules on " <> urlMap <> " (" <> stamp <> ")") + <> ";; esac" + + importMap :: Text -> Aeson.Value -> Text + importMap urlMap v = + "printf '%s\\n' " <> shellQuote (jsonText v) + <> " | gcloud compute url-maps import " <> shellQuote urlMap + <> regional + <> " --quiet" + + -- The Cloud Storage bucket is a declaration that can change under a + -- backend bucket that exists: compared, and updated when it differs. + bucketPart :: BackendBucket -> PartSpec + bucketPart b = + PartSpec + { partId = BackendBucketPart res + , partDeps = [] + , partHelp = Text.unwords ["backend bucket", res] + , partNotes = ["bucket " <> gcs] + , partUp = + [ ensure + (describeCompute "backend-buckets" res) + ( "gcloud compute backend-buckets create " <> shellQuote res + <> regional + <> " --gcs-bucket-name=" <> shellQuote gcs + <> " --load-balancing-scheme=EXTERNAL_MANAGED" + ) + , "have=$(" <> describeCompute "backend-buckets" res <> " --format='value(bucketName)')" + , "[ \"$have\" = " <> shellQuote gcs <> " ] || gcloud compute backend-buckets update " <> shellQuote res + <> regional + <> " --gcs-bucket-name=" <> shellQuote gcs + ] + , partCheck = + [ need ("backend-buckets " <> res) (describeCompute "backend-buckets" res) + , "[ \"$(" <> describeCompute "backend-buckets" res + <> " --format='value(bucketName)' 2>/dev/null)\" = " + <> shellQuote gcs + <> " ] || echo " + <> shellQuote ("MISSING gcs-bucket " <> gcs <> " on " <> res) + ] + , partDown = [deleteCompute "backend-buckets" res] + } + where + res = bucketResource alb b.backendBucketName + gcs = b.backendBucketGcsBucket + + -- Imported whole on every run, like the balancer's own map with rules. + httpRedirectUrlMapPart :: RedirectCode -> PartSpec + httpRedirectUrlMapPart code = + PartSpec + { partId = HttpRedirectUrlMapPart + , partDeps = [] + , partHelp = Text.unwords ["URL map", urlMap, "(HTTP to HTTPS)"] + , partNotes = [redirectText (Redirect Nothing Nothing True code)] + , partUp = [importMap urlMap rendered] + , partCheck = + need ("url-maps " <> urlMap) (describeCompute "url-maps" urlMap) + : [stampCheck urlMap stamp | Just (Aeson.String stamp) <- [description rendered]] + , partDown = [deleteCompute "url-maps" urlMap] + } + where + urlMap = httpRedirectUrlMapName alb + rendered = renderHttpRedirectUrlMap alb code + description = \case + Aeson.Object o -> KeyMap.lookup "description" o + _ -> Nothing + + -- 'NoHttp': what an earlier declaration made for port 80 goes, the rule + -- before the proxy it points at. Nothing to do on the way down. + noHttpPart :: PartSpec + noHttpPart = + PartSpec + { partId = NoHttpPart + , partDeps = [] + , partHelp = Text.unwords ["no HTTP listener on load balancer", alb.albName] + , partNotes = [] + , partUp = [deleteCompute coll name | (coll, name) <- listener] + , partCheck = + [ "if exists " <> describeCompute coll name <> "; then echo " + <> shellQuote ("MISSING removal of " <> coll <> " " <> name) + <> "; fi" + | (coll, name) <- listener + ] + , partDown = [] + } + where + listener = [("forwarding-rules", alb.albName <> "-fw"), ("target-http-proxies", alb.albName <> "-proxy")] + + certificateParts :: Certificate -> [PartSpec] + certificateParts = \case + -- Somebody else's: asked after, never created or deleted. Its @up@ + -- fails when it is not there, so that the failure names the + -- certificate rather than the proxy that could not find it. + ComputeCertificate n -> + [ PartSpec + { partId = CertificatePart n + , partDeps = [] + , partHelp = Text.unwords ["certificate", n, "(not managed here)"] + , partNotes = [] + , partUp = + [ "exists " <> describeCompute "ssl-certificates" n + <> " || { echo " + <> shellQuote ("certificate " <> n <> " does not exist, and is not this balancer's to create") + <> " >&2; exit 1; }" + ] + , partCheck = [need ("ssl-certificates " <> n) (describeCompute "ssl-certificates" n)] + , partDown = [] + } + ] + c@(ManagedCertificate n ds) -> managedParts (certificateResource c) n ds + c@(DomainSetCertificate base ds) -> managedParts (certificateResource c) base ds + + -- One line per name, lower-cased and sorted, then joined with a space + -- after each: how a list read back from gcloud is compared with a + -- declared one, whatever separators @value()@ flattened it with. + asSet :: Text + asSet = " | tr \";,[]' \\t\" '\\n' | sed -e 's|.*/||' -e '/^$/d' | tr 'A-Z' 'a-z' | LC_ALL=C sort -u | tr '\\n' ' '" + + setText :: [Text] -> Text + setText = Text.concat . map (<> " ") . normalDomains + + httpsProxy :: Text + httpsProxy = alb.albName <> "-https-proxy" + + -- The names of the certificates the HTTPS proxy serves now, 'asSet'. + -- A Certificate Manager certificate is listed there by its full + -- resource path, a compute one by its URL: the last segment either way. + proxyCertificates :: Text + proxyCertificates = + describeCompute "target-https-proxies" httpsProxy + <> " --format='value(sslCertificates)' 2>/dev/null" + <> asSet + + -- The DNS authorizations (named after @base@) and the certificate + -- @cert@ over them. + managedParts :: Text -> Text -> [Text] -> [PartSpec] + managedParts cert base ds = + [ PartSpec + { partId = DnsAuthorizationPart authz + , partDeps = [] + , partHelp = Text.unwords ["DNS authorization", authz, "for", d] + , partNotes = [] + , partUp = + [ ensure + (describeLocated "dns-authorizations" authz) + ( "gcloud certificate-manager dns-authorizations create " <> shellQuote authz + <> located + <> " --domain=" <> shellQuote d + <> " --type=PER_PROJECT_RECORD" + ) + ] + , partCheck = [need ("dns-authorization " <> authz) (describeLocated "dns-authorizations" authz)] + , partDown = [deleteLocated "dns-authorizations" authz] + } + | d <- ds + , let authz = authorizationName base d + ] + <> [ PartSpec + { partId = CertificatePart cert + , -- and, going down, the certificate first: an + -- authorization in use cannot be deleted + partDeps = map (DnsAuthorizationPart . authorizationName base) ds + , partHelp = Text.unwords ["managed certificate", cert] + , partNotes = ["for " <> Text.unwords ds] + , partUp = + [ ensure + (describeLocated "certificates" cert) + ( "gcloud certificate-manager certificates create " <> shellQuote cert + <> located + <> " --domains=" <> shellQuote (Text.intercalate "," ds) + <> " --dns-authorizations=" <> shellQuote (Text.intercalate "," (map (authorizationName base) ds)) + ) + , -- a certificate's names cannot be edited: one that + -- covers other names than the declared ones is not + -- this declaration's, and saying nothing is how a + -- host added to the list never got a certificate + "got=$(" <> describeLocated "certificates" cert <> " --format='value(managed.domains)'" <> asSet <> ")" + , "[ -z \"$got\" ] || [ \"$got\" = " <> shellQuote (setText ds) <> " ] || { echo " + <> shellQuote ("certificate " <> cert <> " exists and covers other names than the declared ones (" <> Text.unwords (normalDomains ds) <> "):") + <> "\" $got\"" + <> shellQuote "-- a certificate's names cannot be edited; declare it as a DomainSetCertificate, or under a new name" + <> " >&2; exit 1; }" + ] + , partCheck = + [ need ("certificate " <> cert) (describeLocated "certificates" cert) + , "st=$(" <> describeLocated "certificates" cert + <> " --format='value(managed.state)' 2>/dev/null); [ -n \"$st\" ] && echo " + <> shellQuote ("CERT " <> cert) + <> "\" $st\"; true" + , "got=$(" <> describeLocated "certificates" cert <> " --format='value(managed.domains)' 2>/dev/null" <> asSet <> ")" + , "[ -z \"$got\" ] || [ \"$got\" = " <> shellQuote (setText ds) <> " ] || echo " + <> shellQuote ("PROBLEM certificate " <> cert <> " covers other names than the declared ones (immutable): has") + <> "\" $got\"" + , -- a certificate whose renewal failed stays ACTIVE, + -- until the day it expires + "if [ \"$st\" = ACTIVE ]; then" + , " if " <> describeLocated "certificates" cert + <> " --format='value(managed.authorizationAttemptInfo[].state)' 2>/dev/null | tr \";,[]' \\t\" '\\n' | grep -qxF FAILED; then echo " + <> shellQuote ("PROBLEM certificate " <> cert <> " is ACTIVE but an authorization attempt FAILED (it will not renew)") + <> "; fi" + , " exp=$(" <> describeLocated "certificates" cert <> " --format='value(expireTime)' 2>/dev/null)" + , " if [ -n \"$exp\" ] && t=$(date -d \"$exp\" +%s 2>/dev/null) && [ \"$t\" -le \"$(date +%s)\" ]; then echo " + <> shellQuote ("PROBLEM certificate " <> cert <> " expired") + <> "\" $exp\"; fi" + , "fi" + ] + , -- never from under the proxy: a certificate the HTTPS + -- proxy still serves is left, and its node fails, until + -- the proxy is gone or has been moved off it + partDown = + [ "if exists " <> describeLocated "certificates" cert <> "; then" + , " if " <> servedByProxy (shellQuote cert) <> "; then echo " + <> shellQuote ("certificate " <> cert <> " is still served by " <> httpsProxy <> ": not deleted") + <> " >&2; exit 1; fi" + , " gcloud certificate-manager certificates delete " <> shellQuote cert <> located <> " --quiet" + , "fi" + ] + } + ] + + -- whether the HTTPS proxy lists a certificate (a shell word naming it) + servedByProxy :: Text -> Text + servedByProxy word = + describeCompute "target-https-proxies" httpsProxy + <> " --format='value(sslCertificates)' 2>/dev/null | tr \";,[]' \\t\" '\\n' | sed 's|.*/||' | grep -qxF -- " + <> word + + -- The certificates of one base that are not the declared one: the bare + -- base name (what a 'ManagedCertificate' of that name was) and the base + -- with another set's tag. Asked of Certificate Manager, since nothing in + -- a declaration remembers the sets it used to name. + supersededPart :: Text -> Text -> PartSpec + supersededPart base current = + PartSpec + { partId = SupersededCertificatesPart base + , -- after the proxy: it is the proxy's update that supersedes + partDeps = [HttpsProxyPart, CertificatePart current] + , partHelp = Text.unwords ["superseded certificates of", base] + , partNotes = ["keeps " <> current] + , partUp = + [ "stale=$(" <> listSuperseded <> ")" + , "for c in $stale; do" + , -- one the proxy still serves is the swap not made yet (see + -- 'httpsProxyPart'): left, said, and not a failure + " if " <> servedByProxy "\"$c\"" <> "; then echo \"certificate $c is still served by \"" + <> shellQuote httpsProxy + <> "\": not deleted\" >&2; continue; fi" + , " gcloud certificate-manager certificates delete \"$c\"" <> located <> " --quiet" + , "done" + ] + , partCheck = + [ listSuperseded <> " 2>/dev/null | while read -r c; do if " <> servedByProxy "\"$c\"" + <> "; then echo \"WAITING removal of superseded certificate $c, still served by \"" + <> shellQuote httpsProxy + <> "; else echo \"MISSING removal of superseded certificate $c\"; fi; done; true" + ] + , -- the declared certificate's own node removes it; a superseded + -- one still around at teardown is left (see 'lbParts') + partDown = [] + } + where + listSuperseded = + "gcloud certificate-manager certificates list" <> located <> " --format='value(name)'" + <> " | awk -v b=" <> shellQuote base + <> " -v cur=" <> shellQuote current + <> " " + <> shellQuote "{n=$0; sub(/.*\\//,\"\",n); t=substr(n,length(b)+2)} n!=cur && (n==b || (index(n,b\"-\")==1 && length(t)==8 && t ~ /^[0-9a-f]+$/)) {print n}" + + -- What this balancer made and no longer declares. Each @plan_*@ function + -- prints one line per finding and changes nothing: @MARK coll name@ (a + -- declared resource with no description), @DELETE coll name@ (ours, not + -- declared, not in use), @KEEP coll name why@ (ours, not declared, in + -- use) and @NOTE coll name why@ (said by @up@, nothing for the check). + -- The check and @up@ read the same lines. + -- + -- A reference is looked for with a here-string, never @printf | grep + -- -q@: under @pipefail@ a @grep -q@ that stops reading early can fail + -- the pipeline, which here would read as "not in use". + leftoversPart :: PartSpec + leftoversPart = + PartSpec + { partId = LeftoversPart + , partDeps = + nub $ + [UrlMapPart] + <> [BackendBucketPart n | n <- declaredBuckets] + <> [CertificatePart n | n <- declaredCertificates] + <> [HttpProxyPart | http] + <> [NoHttpPart | not http] + <> [HttpsProxyPart | https] + <> [SupersededCertificatesPart base | DomainSetCertificate base _ <- alb.albCertificates] + , partHelp = Text.unwords ["leftovers of load balancer", alb.albName] + , partNotes = [] + , partUp = + plans + <> [ "mark() { case \"$1\" in backend-buckets) gcloud compute \"$1\" update \"$2\"" <> regional + <> " --description=\"$marker\" ;; *) gcloud certificate-manager \"$1\" update \"$2\"" + <> located + <> " --description=\"$marker\" ;; esac; }" + , "remove() { case \"$1\" in backend-buckets|url-maps) gcloud compute \"$1\" delete \"$2\"" <> regional + <> " --quiet ;; *) gcloud certificate-manager \"$1\" delete \"$2\"" + <> located + <> " --quiet ;; esac; }" + , "apply() {" + , " local plan what coll n rest" + , " plan=$(\"$1\")" + , " while read -r what coll n rest; do" + , " case \"$what\" in" + , " MARK) mark \"$coll\" \"$n\" shellQuote alb.albName <> "\", no longer declared\" >&2; remove \"$coll\" \"$n\" &2 ;;" + , " esac" + , " done <<< \"$plan\"" + , "}" + ] + -- certificates before the authorizations they use + <> map ("apply " <>) planNames + , partCheck = + plans + <> [ "{ " <> Text.concat (map (<> "; ") planNames) <> "} | while read -r what coll n rest; do case \"$what\" in" + <> " MARK) echo \"MISSING ownership mark on $coll $n\";;" + <> " DELETE) echo \"MISSING removal of undeclared $coll $n\";;" + <> " KEEP) echo \"WAITING removal of undeclared $coll $n, $rest\";;" + <> " esac; done; true" + ] + , -- a leftover still there at teardown is left (see 'lbParts') + partDown = [] + } + where + declaredBuckets = map (bucketResource alb . backendBucketName) alb.albBuckets + declaredCertificates = [n | (n, _, _) <- managedCertificates alb] + declaredAuthorizations = map snd (dnsAuthorizations alb) + redirectMap = httpRedirectUrlMapName alb + redirecting = case alb.albHttp of + RedirectToHttps _ -> True + _ -> False + planNames = + ["plan_buckets", "plan_certificates", "plan_authorizations"] + <> ["plan_redirect_map" | not redirecting] + declared = shellQuote . Text.unwords + unlisted coll = "{ echo " <> shellQuote ("NOTE " <> coll <> " - could not be listed") <> "; return 0; }" + -- the last path segment of every name of a flattened list, one per line + names = " | tr \";,[]' \\t\" '\\n' | sed 's|.*/||'" + plans = + [ "marker=" <> shellQuote (ownershipMarker alb) + , -- reads a 'value(name,description)' listing; $1 is the declared names + "classify() { awk -F'\\t' -v m=\"$marker\" -v declared=\" $1 \" " + <> shellQuote "{n=$1; sub(/.*\\//,\"\",n)} n==\"\"{next} index(declared,\" \" n \" \"){if($2==\"\")print \"MARK:\" n; next} $2==m{print \"OURS:\" n}" + <> "; }" + , "plan_buckets() {" + , " local all maps listed line n d" + , " all=$(gcloud compute backend-buckets list --project=\"$PROJECT\" --format='value(name,description)' 2>/dev/null) || " <> unlisted "backend-buckets" + , " maps=''; listed=''" + , " for line in $(printf '%s\\n' \"$all\" | classify " <> declared declaredBuckets <> "); do" + , " n=${line#*:}" + , -- the listing is the project's: only a bucket of this region, read again, counts + " d=$(gcloud compute backend-buckets describe \"$n\"" <> regional <> " --format='value(description)' 2>/dev/null) || continue" + , " case \"$line\" in" + , " MARK:*) [ -n \"$d\" ] || echo \"MARK backend-buckets $n\" ;;" + , " OURS:*)" + , " case \"$n\" in " <> shellQuote (alb.albName <> "-") <> "*-bucket) ;; *) continue ;; esac" + , " [ \"$d\" = \"$marker\" ] || continue" + , " if [ -z \"$listed\" ]; then maps=$(gcloud compute url-maps list --project=\"$PROJECT\" --format=json 2>/dev/null) || { echo \"KEEP backend-buckets $n the URL maps could not be listed\"; continue; }; listed=1; fi" + , " if grep -qF -- \"/regions/$REGION/backendBuckets/$n\\\"\" <<< \"$maps\"; then echo \"KEEP backend-buckets $n a URL map still names it\"; else echo \"DELETE backend-buckets $n\"; fi ;;" + , " esac" + , " done" + , "}" + , "plan_certificates() {" + , " local all served listed line n" + , " all=$(gcloud certificate-manager certificates list" <> located <> " --format='value(name,description)' 2>/dev/null) || " <> unlisted "certificates" + , " served=''; listed=''" + , " for line in $(printf '%s\\n' \"$all\" | classify " <> declared declaredCertificates <> "); do" + , " n=${line#*:}" + , " case \"$line\" in" + , " MARK:*) echo \"MARK certificates $n\" ;;" + , " OURS:*)" + , " if [ -z \"$listed\" ]; then served=$(gcloud compute target-https-proxies list --project=\"$PROJECT\" --format='value(sslCertificates,certificateManagerCertificates)' 2>/dev/null" + <> names + <> ") || { echo \"KEEP certificates $n the HTTPS proxies could not be listed\"; continue; }; listed=1; fi" + , " if grep -qxF -- \"$n\" <<< \"$served\"; then echo \"KEEP certificates $n an HTTPS proxy still serves it\"; else echo \"DELETE certificates $n\"; fi ;;" + , " esac" + , " done" + , "}" + , "plan_authorizations() {" + , " local all used listed line n" + , " all=$(gcloud certificate-manager dns-authorizations list" <> located <> " --format='value(name,description)' 2>/dev/null) || " <> unlisted "dns-authorizations" + , " used=''; listed=''" + , " for line in $(printf '%s\\n' \"$all\" | classify " <> declared declaredAuthorizations <> "); do" + , " n=${line#*:}" + , " case \"$line\" in" + , " MARK:*) echo \"MARK dns-authorizations $n\" ;;" + , " OURS:*)" + , " if [ -z \"$listed\" ]; then used=$(gcloud certificate-manager certificates list" <> located <> " --format='value(managed.dnsAuthorizations)' 2>/dev/null" + <> names + <> ") || { echo \"KEEP dns-authorizations $n the certificates could not be listed\"; continue; }; listed=1; fi" + , " if grep -qxF -- \"$n\" <<< \"$used\"; then echo \"KEEP dns-authorizations $n a certificate still uses it\"; else echo \"DELETE dns-authorizations $n\"; fi ;;" + , " esac" + , " done" + , "}" + ] + <> if redirecting + then [] + else + [ "plan_redirect_map() {" + , " local d http https" + , " d=$(" <> describeCompute "url-maps" redirectMap <> " --format='value(description)' 2>/dev/null) || return 0" + , -- only a map this module wrote: its description is the fingerprint of its content + " case \"$d\" in " <> Text.intercalate "|" (map shellQuote (httpRedirectUrlMapStamps alb)) <> ") ;; *) return 0 ;; esac" + , " http=$(gcloud compute target-http-proxies list --project=\"$PROJECT\" --format='value(urlMap)' 2>/dev/null) && https=$(gcloud compute target-https-proxies list --project=\"$PROJECT\" --format='value(urlMap)' 2>/dev/null) || { echo " + <> shellQuote ("KEEP url-maps " <> redirectMap <> " the proxies could not be listed") + <> "; return 0; }" + , " if grep -qE -- \"/regions/$REGION/urlMaps/\"" <> shellQuote redirectMap <> "'[[:space:]]*$' <<< \"$http\"$'\\n'\"$https\"; then echo " + <> shellQuote + ( -- by default the HTTP proxy is never moved, so a map it is on is not waiting for anything + (if alb.albHttp == HttpCreatedOnce then "NOTE" else "KEEP") + <> " url-maps " + <> redirectMap + <> " a proxy is still on it" + ) + <> "; else echo " + <> shellQuote ("DELETE url-maps " <> redirectMap) + <> "; fi" + , "}" + ] + + -- Two forwarding rules can only share an address that is reserved. + addressPart :: PartSpec + addressPart = simple AddressPart [] "reserved address" "addresses" (alb.albName <> "-ip") "" + + addressFlag + | https = " --address=" <> resourceName "-ip" <> " --address-region=\"$REGION\"" + | otherwise = "" + + -- Created once with its URL map, which by default is never set again: + -- somebody may have repointed it, and a second writer of one proxy's map + -- is a fight every pass. Only a declaration about the listener + -- ('ServeHttp', 'RedirectToHttps') makes the map something this node + -- sets, and then it is compared and updated when it differs. + httpProxyPart :: PartSpec + httpProxyPart = case alb.albHttp of + ServeHttp -> onMap UrlMapPart (alb.albName <> "-url-map") + RedirectToHttps _ -> onMap HttpRedirectUrlMapPart (httpRedirectUrlMapName alb) + _ -> createdOnce + where + proxy = alb.albName <> "-proxy" + mapFlags urlMap = " --url-map=" <> shellQuote urlMap <> " --url-map-region=\"$REGION\"" + createdOnce = + simple + HttpProxyPart + [UrlMapPart] + "HTTP proxy" + "target-http-proxies" + proxy + (mapFlags (alb.albName <> "-url-map")) + -- the proxy's map is listed by URL: the last segment is its name + currentMap = describeCompute "target-http-proxies" proxy <> " --format='value(urlMap)'" + onMap mapPart urlMap = + createdOnce + { partDeps = [mapPart] + , partNotes = ["on URL map " <> urlMap] + , partUp = + [ "if exists " <> describeCompute "target-http-proxies" proxy <> "; then" + , " have=$(" <> currentMap <> " | sed 's|.*/||')" + , " [ \"$have\" = " <> shellQuote urlMap <> " ] || gcloud compute target-http-proxies update " <> shellQuote proxy + <> regional + <> mapFlags urlMap + , "else" + , " gcloud compute target-http-proxies create " <> shellQuote proxy <> regional <> mapFlags urlMap + , "fi" + ] + , partCheck = + [ need ("target-http-proxies " <> proxy) (describeCompute "target-http-proxies" proxy) + , "[ \"$(" <> currentMap <> " 2>/dev/null | sed 's|.*/||')\" = " + <> shellQuote urlMap + <> " ] || echo " + <> shellQuote ("MISSING url-map " <> urlMap <> " on " <> proxy) + ] + } + + -- Created once with its URL map, which is never set again (somebody may + -- have repointed it). Its certificate list is a declaration that can + -- change under it, and the one thing here that must not be set as soon + -- as it differs: a managed certificate is issued over minutes to an + -- hour, and a proxy moved onto one that is not ACTIVE serves no + -- certificate at all for its names. So the list is updated only once + -- every declared managed certificate is ACTIVE; until then @up@ says + -- which is not and the proxy keeps serving what it has (see 'lbParts' + -- for when that is a failed @up@ and when a pending swap). + httpsProxyPart :: PartSpec + httpsProxyPart = + PartSpec + { partId = HttpsProxyPart + , partDeps = UrlMapPart : map CertificatePart declared + , partHelp = Text.unwords ["HTTPS proxy", httpsProxy] + , partNotes = ["certificates " <> Text.unwords declared] + , partUp = + [ "if exists " <> describeCompute "target-https-proxies" httpsProxy <> "; then" + , " have=$(" <> proxyCertificates <> ")" + , " if [ \"$have\" != " <> shellQuote (setText declared) <> " ]; then" + ] + <> swap + <> [ " fi" + , "else" + , " gcloud compute target-https-proxies create " <> shellQuote httpsProxy + <> regional + <> " --url-map=" <> resourceName "-url-map" <> " --url-map-region=\"$REGION\"" + <> certificateFlags + , "fi" + ] + , partCheck = + [ need ("target-https-proxies " <> httpsProxy) (describeCompute "target-https-proxies" httpsProxy) + , "have=$(" <> proxyCertificates <> ")" + , "if exists " <> describeCompute "target-https-proxies" httpsProxy + <> " && [ \"$have\" != " <> shellQuote (setText declared) <> " ]; then" + , " waiting=''" + ] + -- not yet swappable is not something up would fix: the + -- certificate's state, which reads as Unknown + <> concat + [ [ " st=$(" <> describeLocated "certificates" n <> " --format='value(managed.state)' 2>/dev/null) || st=''" + , " [ \"$st\" = ACTIVE ] || { echo " <> shellQuote ("CERT " <> n) <> "\" ${st:-ABSENT}\"; waiting=1; }" + ] + | n <- managed + ] + <> [ " [ -n \"$waiting\" ] || echo " + <> shellQuote ("MISSING certificates " <> Text.unwords declared <> " on " <> httpsProxy <> ": it serves") + <> "\" $have\"" + , "fi" + ] + , partDown = [deleteCompute "target-https-proxies" httpsProxy] + } + where + managed = [n | (n, _, _) <- managedCertificates alb] + compute = [n | ComputeCertificate n <- alb.albCertificates] + declared = managed <> compute + update = "gcloud compute target-https-proxies update " <> shellQuote httpsProxy <> regional <> certificateFlags + notActive n = + "echo " + <> shellQuote ("certificate " <> n <> " is not ACTIVE yet:") + <> "\" ${st:-absent}\"" + <> shellQuote ("; " <> httpsProxy <> " keeps the certificates it serves until it is. Run again then.") + <> " >&2" + stateOf n = " st=$(" <> describeLocated "certificates" n <> " --format='value(managed.state)' 2>/dev/null) || st=''" + -- The move onto the declared certificates, inside "the proxy exists + -- and serves another list". Under a 'DomainSetCertificate' a + -- certificate still being issued is the expected middle of a swap: + -- said on stderr, the proxy left alone, and the node's up /done/ -- + -- no line here may @exit 0@, the lines also run inside + -- 'renderLbScript'. One that is FAILED or absent will never be + -- ACTIVE, and fails as before. + swap + | domainSets = + [" pending=''"] + <> concat + [ [ stateOf n + , " case \"$st\" in" + , " ACTIVE) ;;" + , " ''|FAILED) " <> notActive n <> "; exit 1 ;;" + , " *) " <> notActive n <> "; pending=1 ;;" + , " esac" + ] + | n <- managed + ] + <> [ " if [ -z \"$pending\" ]; then" + , " " <> update + , " else" + , " echo " + <> shellQuote ("PENDING certificate swap on " <> httpsProxy <> ": it serves") + <> "\" $have\" >&2" + , " fi" + ] + | otherwise = + concat + [ [ stateOf n + , " [ \"$st\" = ACTIVE ] || { " <> notActive n <> "; exit 1; }" + ] + | n <- managed + ] + <> [" " <> update] + certificateFlags = case managed of + (_ : _) -> " --certificate-manager-certificates=" <> shellQuote (Text.intercalate "," managed) + [] -> " --ssl-certificates=" <> shellQuote (Text.intercalate "," compute) <> " --ssl-certificates-region=\"$REGION\"" + + forwardingRulePart :: PartSpec + forwardingRulePart = + simple + ForwardingRulePart + (HttpProxyPart : [AddressPart | https]) + "forwarding rule" + "forwarding-rules" + (alb.albName <> "-fw") + ( " --load-balancing-scheme=EXTERNAL_MANAGED" + <> maybe "" ((" --network=" <>) . shellQuote) alb.albNetwork + <> addressFlag + <> " --target-http-proxy=" <> resourceName "-proxy" + <> " --target-http-proxy-region=\"$REGION\"" + <> " --ports=80" + ) + + httpsForwardingRulePart :: PartSpec + httpsForwardingRulePart = + simple + HttpsForwardingRulePart + [HttpsProxyPart, AddressPart] + "HTTPS forwarding rule" + "forwarding-rules" + (alb.albName <> "-https-fw") + ( " --load-balancing-scheme=EXTERNAL_MANAGED" + <> maybe "" ((" --network=" <>) . shellQuote) alb.albNetwork + <> addressFlag + <> " --target-https-proxy=" <> resourceName "-https-proxy" + <> " --target-https-proxy-region=\"$REGION\"" + <> " --ports=443" + ) + +-- | What identifies a backend among one service's: its group, or the service's NEG. +backendKey :: Svc -> Backend -> Text +backendKey svc = \case + InstanceGroupBackend ig _ _ -> ig + CloudRunBackend _ -> svc.svcNeg + +jsonText :: Aeson.Value -> Text +jsonText = Text.decodeUtf8With TextErr.lenientDecode . LByteString.toStrict . Aeson.encode + +{- | What every creating or deleting script starts with. @exists@ is a bare +predicate: every caller appends its own location flags, because not every +resource named here is regional (an unmanaged instance group is zonal). +-} +mutatingHeader :: ApplicationLoadBalancer -> [Text] +mutatingHeader alb = + [ "set -euo pipefail" + , "PROJECT=" <> shellQuote alb.albProject.projectId + , "REGION=" <> shellQuote alb.albRegion.regionName + , "exists() { \"$@\" >/dev/null 2>&1; }" + ] + +-- | What every read-only script starts with: no @-e@, findings are lines. +checkHeader :: ApplicationLoadBalancer -> [Text] +checkHeader alb = + [ "set -uo pipefail" + , "PROJECT=" <> shellQuote alb.albProject.projectId + , "REGION=" <> shellQuote alb.albRegion.regionName + , "exists() { \"$@\" >/dev/null 2>&1; }" + , "need() { local what=\"$1\"; shift; exists \"$@\" || echo \"MISSING $what\"; }" + ] + +-- | The script one resource node's @up@ runs. +renderPartUpScript :: ApplicationLoadBalancer -> PartSpec -> Text +renderPartUpScript alb part = Text.unlines (mutatingHeader alb <> part.partUp) + +{- | The script one resource node's @check@ runs, read by 'interpretLbCheck': +it always exits 0 unless the script itself breaks. +-} +renderPartCheckScript :: ApplicationLoadBalancer -> PartSpec -> Text +renderPartCheckScript alb part = Text.unlines (checkHeader alb <> part.partCheck) + +{- | The script one resource node's @down@ runs: a resource that is already +gone is skipped, one that exists and fails to delete fails the script. +-} +renderPartDownScript :: ApplicationLoadBalancer -> PartSpec -> Text +renderPartDownScript alb part = Text.unlines (mutatingHeader alb <> part.partDown) + +{- | Every resource's @up@ in one script, in 'lbParts'' order: what the +balancer's node ran when it was a single node. No node runs it any more; it +is the same lines, kept for running a balancer up by hand and for tests that +exercise the lines together. +-} +renderLbScript :: ApplicationLoadBalancer -> Text +renderLbScript alb = Text.unlines (mutatingHeader alb <> concatMap partUp (lbParts alb)) + +{- | Every resource's check in one read-only script, then the backends' +health ('renderLbHealthScript''s lines). Findings are lines on stdout (see +'interpretLbCheck'). + +What it sees of the URL map: its hosts, as a set (a declared host that is +absent, a host no rule declares), and the fingerprint in its @description@ +('urlMapStamp', 'urlMapStampIsRequired'), which is what covers a path rule +and which service a host is sent to -- always in a map naming a backend +bucket or a redirect, and in a map of backend services only once salmon has +imported it with one. Which port a +service reaches it does see: the service's port name, and that name on each +instance group it sends to. +-} +renderLbCheckScript :: ApplicationLoadBalancer -> Text +renderLbCheckScript alb = + Text.unlines (checkHeader alb <> concatMap partCheck (lbParts alb) <> healthLines alb) + +{- | What the balancer's root node checks: the health of each instance-group +backend, one @HEALTH \ \@ line per backend instance. A +Cloud Run (NEG) backend has no health to ask for. +-} +renderLbHealthScript :: ApplicationLoadBalancer -> Text +renderLbHealthScript alb = Text.unlines (checkHeader alb <> healthLines alb) + +-- one state per backend instance; ';' separates a backend's instances +healthLines :: ApplicationLoadBalancer -> [Text] +healthLines alb = + [ "gcloud compute backend-services get-health " <> shellQuote svc.svcResource <> regional + <> " --format='value(status.healthStatus[].healthState)' 2>/dev/null" + <> " | tr ';' '\\n' | while read -r st; do [ -n \"$st\" ] && echo " + <> shellQuote ("HEALTH " <> svc.svcLabel) + <> "\" $st\"; done; true" + | svc <- services alb + , any isInstanceGroup svc.svcBackends + ] + +{- | Every resource's @down@ in one script, dependants first ('lbParts'' +order reversed). +-} +renderLbDeleteScript :: ApplicationLoadBalancer -> Text +renderLbDeleteScript alb = Text.unlines (mutatingHeader alb <> concatMap partDown (reverse (lbParts alb))) + +-- | 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\"" + +-- | The same for Certificate Manager, which says @--location@. +located :: Text +located = " --project=\"$PROJECT\" --location=\"$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 diff --git a/src/Salmon/Builtin/Nodes/Gcp/Monitoring.hs b/src/Salmon/Builtin/Nodes/Gcp/Monitoring.hs --- a/src/Salmon/Builtin/Nodes/Gcp/Monitoring.hs +++ b/src/Salmon/Builtin/Nodes/Gcp/Monitoring.hs @@ -52,6 +52,7 @@ CloudRunCondition (..), AlertPolicy (..), alertPolicy, + alertPolicyAfter, renderCondition, renderPolicy, policyFingerprint, @@ -90,6 +91,7 @@ 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.OpGraph (inject) import Salmon.Op.Ref import Salmon.Op.Track import Salmon.Reporter @@ -279,8 +281,18 @@ 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 -> +alertPolicy = alertPolicyAfter [] + +{- | 'alertPolicy', with nodes the policy and each of its channels wait for +(@monitoring.googleapis.com@ enabled, typically). + +A node @inject@ed onto the policy waits before the policy only: its channels +are its dependencies, and siblings of what was injected. These go under the +channels as well. With @[]@ the graph is 'alertPolicy''s, unchanged. +-} +alertPolicyAfter :: [Op] -> Reporter Report -> Track' (Binary "gcloud") -> AlertPolicy -> Op +alertPolicyAfter prerequisites r gcloudTrack policy = + after $ 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] @@ -294,7 +306,8 @@ , check = checkPolicy } where - channelNodes = map (notificationChannel r gcloudTrack) policy.apChannels + after o = foldl inject o prerequisites + channelNodes = map (after . notificationChannel r gcloudTrack) policy.apChannels run :: MonitoringCommand -> IO () run cmd = untrackedExec monitoringCommand cmd "" (contramap (RunMonitoringCommand cmd) r) diff --git a/src/Salmon/Builtin/Nodes/Gcp/SecretManager.hs b/src/Salmon/Builtin/Nodes/Gcp/SecretManager.hs --- a/src/Salmon/Builtin/Nodes/Gcp/SecretManager.hs +++ b/src/Salmon/Builtin/Nodes/Gcp/SecretManager.hs @@ -24,14 +24,20 @@ SecretVersion (..), secretVersion, interpretSecretContents, + SecretFile (..), + secretFile, + SecretFetchFailed (..), Report (..), SecretManagerCommand (..), secretManagerCommand, ) where +import Control.Exception (Exception, throwIO) import qualified Data.ByteString as ByteString 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 (doesFileExist) import System.Process.ByteString (readCreateProcessWithExitCode) @@ -42,6 +48,7 @@ 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.Builtin.Nodes.SecretDelivery (Placement (..), checkInstalledSecret, installSecretBytes, removeInstalledSecret) import Salmon.Op.Ref import Salmon.Op.Track import Salmon.Reporter @@ -50,6 +57,9 @@ data Report = RunSecretManagerCommand !SecretManagerCommand !Binary.Report + | -- | a secret was read for a file: which one, and how @gcloud@ exited. + -- Never the 'Binary.Report' of that read, whose stdout is the secret. + FetchedSecretFile !SecretFile !ExitCode deriving (Show) ------------------------------------------------------------------------------- @@ -164,12 +174,93 @@ ------------------------------------------------------------------------------- +{- | A Secret Manager secret, as a file on the machine this graph runs on. + +The other direction from 'secretVersion': that one runs on the controlling +machine and puts bytes /into/ Secret Manager, this one runs on an instance +and takes them out, authenticating as whatever @gcloud@ finds there -- on a +GCE instance, its service account, through the metadata server. Nothing is +shipped to the machine but the secret's name, so the directive that declares +this node can be printed, piped and reported like any other. +-} +data SecretFile = SecretFile + { fileProject :: Project + , fileSecretName :: Text + , fileVersion :: Text + -- ^ @latest@, or a version number. With @latest@ a rotation is picked up + -- by the next pass (or by the tending loop under @run serve@). + , filePlacement :: Placement + } + deriving (Eq, Show) + +-- | Thrown when the secret cannot be read. Names the secret; @gcloud@'s +-- stderr on a failed read is a diagnosis, not a payload. +data SecretFetchFailed = SecretFetchFailed Text Int Text + +instance Show SecretFetchFailed where + show (SecretFetchFailed name n err) = + "could not read secret " <> Text.unpack name <> " (gcloud exit " <> show n <> "): " <> Text.unpack err + +instance Exception SecretFetchFailed + +{- | Ensures the file holds the secret version's bytes, with the declared +owner and mode. + +What it takes for this to work is not declared here and cannot be, since it +is the /other/ side's business: the instance needs a service account with +@roles\/secretmanager.secretAccessor@ on the secret (see +"Salmon.Builtin.Nodes.Gcp.Iam"), the @cloud-platform@ access scope, and a +@gcloud@ on its @PATH@. + +The read happens in this process: the bytes are @gcloud@'s standard output, +captured, and written with +'Salmon.Builtin.Nodes.SecretDelivery.installSecretBytes'. They are in no +argv, no report and no failure text. Like 'secretVersion', the @check@ is +itself a read of the secret, so the instance's identity shows in the audit +log once per pass. + +The enclosing directory must already exist; @down@ removes the file. +-} +secretFile :: Reporter Report -> Track' (Binary "gcloud") -> SecretFile -> Op +secretFile r gcloudTrack file = + -- the tracked runner is dropped on purpose: it reports the command's + -- stdout, which here is the secret. + withBinary gcloudTrack secretManagerCommand access $ \_reportingRun -> + op "gcp-secret-file" nodeps $ \actions -> + actions + { help = Text.unwords ["writes secret", file.fileSecretName, "to", Text.pack place.placePath] + , notes = + [ "version " <> file.fileVersion <> ", owner " <> place.placeOwner <> ":" <> place.placeGroup <> ", mode " <> place.placeMode + , "read as this machine's own identity; the contents are never reported" + ] + , ref = mkRef "secret-file" place.placePath + , check = fetch >>= either (\(n, _) -> pure (Failure ("no readable version of secret: " <> file.fileSecretName <> " (gcloud exit " <> Text.pack (show n) <> ")"))) (checkInstalledSecret place) + , up = fetch >>= either (\(n, err) -> throwIO (SecretFetchFailed file.fileSecretName n err)) (installSecretBytes place) + , down = removeInstalledSecret place + } + where + place = file.filePlacement + access = VersionsAccess file.fileProject file.fileSecretName file.fileVersion + + fetch :: IO (Either (Int, Text) ByteString.ByteString) + fetch = do + (code, out, err) <- readCreateProcessWithExitCode (prepare secretManagerCommand access) "" + runReporter r (FetchedSecretFile file code) + pure $ case code of + ExitSuccess -> Right out + ExitFailure n -> Left (n, Text.take 400 (Text.strip (Text.decodeUtf8With TextError.lenientDecode err))) + +------------------------------------------------------------------------------- + data SecretManagerCommand = SecretsCreate Secret | SecretsDescribe Secret | SecretsDelete Secret | VersionsAdd SecretVersion | VersionsAccessLatest Secret + | -- | project, secret name, version: a read that needs no 'Secret' value + -- (and so no replication policy, which a reader has no opinion on). + VersionsAccess Project Text Text deriving (Show) secretManagerCommand :: Command "gcloud" SecretManagerCommand @@ -211,4 +302,14 @@ , "latest" , "--secret" , Text.unpack sec.secretName + ] + VersionsAccess prj name version -> + gcloudProc $ + withProject prj + [ "secrets" + , "versions" + , "access" + , Text.unpack version + , "--secret" + , Text.unpack name ] diff --git a/src/Salmon/Builtin/Nodes/Gcp/Storage.hs b/src/Salmon/Builtin/Nodes/Gcp/Storage.hs --- a/src/Salmon/Builtin/Nodes/Gcp/Storage.hs +++ b/src/Salmon/Builtin/Nodes/Gcp/Storage.hs @@ -4,16 +4,74 @@ Bucket (..), bucket, interpretBucketDescribe, + + -- * Access: a bucket-level IAM binding + Member (..), + renderMember, + BucketIamBinding (..), + bucketIamBinding, + bindingProblems, + interpretBucketPolicy, + + -- * Lifecycle rules + LifecycleRule (..), + LifecycleAction (..), + LifecycleCondition (..), + noCondition, + expireAfterDays, + BucketLifecycle (..), + bucketLifecycle, + lifecycleProblems, + renderLifecycle, + interpretLifecycleDescribe, + + -- * Website settings + BucketWebsite (..), + bucketWebsite, + websiteProblems, + interpretWebsiteDescribe, + + -- * Contents: a local directory published to a bucket + CacheRule (..), + OnDown (..), + BucketContents (..), + bucketContents, + contentsProblems, + contentsDestination, + RsyncPass (..), + contentsPasses, + globRegex, + Rsync (..), + contentsRsync, + emptyingRsync, + Planned (..), + parseDryRun, + interpretContentsDryRun, Report (..), StorageCommand (..), storageCommand, ) where +import Control.Exception (bracket, throwIO) +import Data.Aeson (Value (..), eitherDecodeStrict', encode, object, (.=)) +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.Char (isAlphaNum, isAscii, isControl) +import Data.List (inits, nub, sort, (\\)) +import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as TextError import GHC.IO.Exception (ExitCode (..)) +import System.Directory (createDirectory, doesDirectoryExist, getTemporaryDirectory, listDirectory, removeDirectory, removeFile) +import System.IO (hClose, openTempFile) import System.Process.ByteString (readCreateProcessWithExitCode) -import System.Process.ListLike (proc) +import System.Process.ListLike (CreateProcess, proc) import Salmon.Actions.UpDown (CheckResult (..)) import Salmon.Builtin.Extension @@ -77,11 +135,832 @@ interpretBucketDescribe name (ExitFailure _) = Failure ("bucket not found: " <> name) ------------------------------------------------------------------------------- +-- Access +{- | Who a bucket-level binding grants a role to. 'AllUsers' is the public: +with @roles\/storage.legacyObjectReader@ it is "anyone may read an object +whose name they know" without the listing that @roles\/storage.objectViewer@ +also grants, which is what a static site's bucket wants. +-} +data Member + = AllUsers + | AllAuthenticatedUsers + | ServiceAccountMember Text + | UserMember Text + | GroupMember Text + | -- | Any other member, spelled as IAM spells it (@domain:example.org@). + OtherMember Text + deriving (Eq, Ord, Show) + +-- | A member as @--member@ and a policy's @members@ spell it. +renderMember :: Member -> Text +renderMember AllUsers = "allUsers" +renderMember AllAuthenticatedUsers = "allAuthenticatedUsers" +renderMember (ServiceAccountMember email) = "serviceAccount:" <> Text.strip email +renderMember (UserMember email) = "user:" <> Text.strip email +renderMember (GroupMember email) = "group:" <> Text.strip email +renderMember (OtherMember raw) = Text.strip raw + +-- | One role granted to one member on one bucket. +data BucketIamBinding = BucketIamBinding + { bindingBucket :: Bucket + , bindingRole :: Text + , bindingMember :: Member + } + deriving (Eq, Show) + +{- | One unconditional IAM binding on a bucket's own policy. + +* 'check': reads @get-iam-policy --format json@ and looks for the member + under the role ('interpretBucketPolicy'). +* 'up': @add-iam-policy-binding@, which is a set insert and so idempotent; + retried like any grant that may name a service account made a moment ago. +* 'down': @remove-iam-policy-binding@, only when the check finds the binding. + +The node has no dependency of its own: the caller puts the bucket (and the +service account, if one is named) underneath. Granting to 'AllUsers' is +refused by GCP on a bucket or organisation enforcing public access +prevention; that refusal is @up@ failing, nothing here anticipates it. +-} +bucketIamBinding :: Reporter Report -> Track' (Binary "gcloud") -> BucketIamBinding -> Op +bucketIamBinding r gcloudTrack b = + withBinary gcloudTrack storageCommand (BucketsAddIamBinding b) $ \add -> + withBinary gcloudTrack storageCommand (BucketsRemoveIamBinding b) $ \remove -> + op "gcp-bucket-iam-binding" nodeps $ \actions -> + actions + { help = Text.unwords ["grants", b.bindingRole, "on GCS bucket", b.bindingBucket.bucketName, "to", member] + , ref = mkRef "gcp-bucket-iam-binding" (b.bindingBucket.bucketName, Text.strip b.bindingRole, member) + , up = do + refuse what (bindingProblems b) + Core.retryingIO Core.afterEnableRetries Core.afterEnableDelay (add (rFor (BucketsAddIamBinding b))) + , down = Core.downIfPresent checkBinding (remove (rFor (BucketsRemoveIamBinding b))) + , check = checkBinding + } + where + member = renderMember b.bindingMember + what = "binding on bucket " <> b.bindingBucket.bucketName + rFor cmd = contramap (RunStorageCommand cmd) r + + checkBinding :: IO CheckResult + checkBinding = uncurry (interpretBucketPolicy b) <$> readStorage (BucketsGetIamPolicy b.bindingBucket) + +-- | Why a declared binding cannot be granted, if it cannot. +bindingProblems :: BucketIamBinding -> [Text] +bindingProblems b = + ["it names no role" | Text.null (Text.strip b.bindingRole)] + <> ["it names no member" | Text.null member || Text.isSuffixOf ":" member] + where + member = renderMember b.bindingMember + +{- | The verdict drawn from @gcloud storage buckets get-iam-policy --format +json@. A binding carrying a @condition@ is not this node's: only an +unconditional one counts. Members are compared as IAM spells them, without +regard to case. +-} +interpretBucketPolicy :: BucketIamBinding -> ExitCode -> ByteString -> CheckResult +interpretBucketPolicy b code out + | problems@(_ : _) <- bindingProblems b = Failure (problemText ("binding on bucket " <> name) problems) + | ExitFailure n <- code = + Failure ("could not read the IAM policy of bucket " <> name <> " (exit " <> Text.pack (show n) <> ")") + | otherwise = case eitherDecodeStrict' out of + Right (Object policy) + | any grants (arrayAt "bindings" policy) -> Success + | otherwise -> Failure (Text.unwords ["bucket", name, "does not grant", b.bindingRole, "to", member]) + -- it answered, and what it said is not a policy: cannot tell + _ -> Unknown + where + name = b.bindingBucket.bucketName + member = renderMember b.bindingMember + grants (Object binding) = + KeyMap.lookup "role" binding == Just (String (Text.strip b.bindingRole)) + && unconditional binding + && any sameMember (arrayAt "members" binding) + grants _ = False + unconditional binding = case KeyMap.lookup "condition" binding of + Nothing -> True + Just Null -> True + Just _ -> False + sameMember (String m) = Text.toCaseFold m == Text.toCaseFold member + sameMember _ = False + +------------------------------------------------------------------------------- +-- Lifecycle + +-- | What a lifecycle rule does to the objects its condition matches. +data LifecycleAction + = Delete + | SetStorageClass Text + | AbortIncompleteMultipartUpload + deriving (Eq, Ord, Show) + +{- | Which objects a rule matches; every field set must hold. The fields are +the storage API's own (@age@ in days, @createdBefore@ a @YYYY-MM-DD@ date). +-} +data LifecycleCondition = LifecycleCondition + { conditionAge :: Maybe Int + , conditionCreatedBefore :: Maybe Text + , conditionIsLive :: Maybe Bool + , conditionNumNewerVersions :: Maybe Int + , conditionDaysSinceNoncurrentTime :: Maybe Int + , conditionMatchesStorageClass :: [Text] + , conditionMatchesPrefix :: [Text] + , conditionMatchesSuffix :: [Text] + } + deriving (Eq, Ord, Show) + +-- | The condition with nothing set, to fill in with record update. +noCondition :: LifecycleCondition +noCondition = LifecycleCondition Nothing Nothing Nothing Nothing Nothing [] [] [] + +data LifecycleRule = LifecycleRule + { ruleAction :: LifecycleAction + , ruleCondition :: LifecycleCondition + } + deriving (Eq, Ord, Show) + +-- | Delete objects older than this many days: a backups bucket's usual rule. +expireAfterDays :: Int -> LifecycleRule +expireAfterDays days = LifecycleRule Delete noCondition{conditionAge = Just days} + +-- | The whole lifecycle configuration of a bucket: these rules and no other. +data BucketLifecycle = BucketLifecycle + { lifecycleBucket :: Bucket + , lifecycleRules :: [LifecycleRule] + } + deriving (Eq, Show) + +{- | A bucket's lifecycle rules, as data. + +A bucket has one lifecycle configuration, so the node is keyed on the bucket +and the declared rules /replace/ whatever is there, rules made by hand +included; an empty list is "no rule". + +* 'check': reads @describe --format json@ and compares the rule sets, order + aside ('interpretLifecycleDescribe'). +* 'up': writes 'renderLifecycle' to a temporary file and runs @update + --lifecycle-file@ (@--clear-lifecycle@ for no rule). A "set" verb. +* 'down': @--clear-lifecycle@, only when the check finds the declared rules. + +The node has no dependency of its own: the caller puts the bucket underneath. +-} +bucketLifecycle :: Reporter Report -> Track' (Binary "gcloud") -> BucketLifecycle -> Op +bucketLifecycle r gcloudTrack lc = + withBinary gcloudTrack storageCommand (BucketsClearLifecycle bkt) $ \clear -> + op "gcp-bucket-lifecycle" nodeps $ \actions -> + actions + { help = Text.unwords ["sets the lifecycle rules of GCS bucket", bkt.bucketName] + , notes = ["lifecycle " <> decodeLenient (renderLifecycle lc.lifecycleRules)] + , ref = mkRef "gcp-bucket-lifecycle" bkt.bucketName + , up = bringUp + , down = Core.downIfPresent checkLifecycle (clear (rFor (BucketsClearLifecycle bkt))) + , check = checkLifecycle + } + where + bkt = lc.lifecycleBucket + rFor cmd = contramap (RunStorageCommand cmd) r + + checkLifecycle :: IO CheckResult + checkLifecycle = uncurry (interpretLifecycleDescribe lc) <$> readStorage (BucketsDescribeJson bkt) + + bringUp :: IO () + bringUp = do + refuse ("lifecycle of bucket " <> bkt.bucketName) (lifecycleProblems lc) + case lc.lifecycleRules of + [] -> run (BucketsClearLifecycle bkt) + rules -> withLifecycleFile rules $ \path -> run (BucketsSetLifecycle bkt path) + + run cmd = Binary.untrackedExec storageCommand cmd "" (rFor cmd) + +-- | The rules in a file @--lifecycle-file@ can read, removed afterwards. +withLifecycleFile :: [LifecycleRule] -> (FilePath -> IO a) -> IO a +withLifecycleFile rules act = do + tmp <- getTemporaryDirectory + bracket + ( do + (path, h) <- openTempFile tmp "salmon-lifecycle.json" + ByteString.hPut h (renderLifecycle rules) + hClose h + pure path + ) + removeFile + act + +-- | Why declared rules cannot be set, if they cannot. +lifecycleProblems :: BucketLifecycle -> [Text] +lifecycleProblems lc = concat (zipWith ruleProblems [1 :: Int ..] lc.lifecycleRules) + where + ruleProblems :: Int -> LifecycleRule -> [Text] + ruleProblems n rule = + map + (\why -> "rule " <> Text.pack (show n) <> " " <> why) + ( ["has no condition, and would apply to every object" | rule.ruleCondition == noCondition] + <> ["has a negative " <> name | (name, Just v) <- counts rule.ruleCondition, v < 0] + <> ["sets no storage class" | SetStorageClass c <- [rule.ruleAction], Text.null (Text.strip c)] + ) + counts :: LifecycleCondition -> [(Text, Maybe Int)] + counts c = + [ ("age", c.conditionAge) + , ("numNewerVersions", c.conditionNumNewerVersions) + , ("daysSinceNoncurrentTime", c.conditionDaysSinceNoncurrentTime) + ] + +-- | The rules as the storage API's lifecycle document: @{"rule": [...]}@. +renderLifecycle :: [LifecycleRule] -> ByteString +renderLifecycle rules = LByteString.toStrict (encode (object ["rule" .= map ruleValue rules])) + +ruleValue :: LifecycleRule -> Value +ruleValue rule = object ["action" .= action, "condition" .= condition] + where + action = case rule.ruleAction of + Delete -> object ["type" .= ("Delete" :: Text)] + SetStorageClass cls -> object ["type" .= ("SetStorageClass" :: Text), "storageClass" .= Text.strip cls] + AbortIncompleteMultipartUpload -> object ["type" .= ("AbortIncompleteMultipartUpload" :: Text)] + c = rule.ruleCondition + condition = + object . catMaybes $ + [ ("age" .=) <$> c.conditionAge + , ("createdBefore" .=) <$> c.conditionCreatedBefore + , ("isLive" .=) <$> c.conditionIsLive + , ("numNewerVersions" .=) <$> c.conditionNumNewerVersions + , ("daysSinceNoncurrentTime" .=) <$> c.conditionDaysSinceNoncurrentTime + , list "matchesStorageClass" c.conditionMatchesStorageClass + , list "matchesPrefix" c.conditionMatchesPrefix + , list "matchesSuffix" c.conditionMatchesSuffix + ] + list _ [] = Nothing + list k vs = Just (k .= vs) + +{- | The verdict drawn from @gcloud storage buckets describe --format json@. + +The live rules are compared with the declared ones as JSON values, null +members and empty lists dropped and order aside, so a live rule using a +condition this module has no field for is a difference rather than something +overlooked. The configuration is looked for under @lifecycle@ (the API's +name, what @--raw@ prints) and @lifecycle_config@ (gcloud's own). +-} +interpretLifecycleDescribe :: BucketLifecycle -> ExitCode -> ByteString -> CheckResult +interpretLifecycleDescribe lc code out + | problems@(_ : _) <- lifecycleProblems lc = Failure (problemText ("lifecycle of bucket " <> name) problems) + | ExitFailure _ <- code = Failure ("bucket not found: " <> name) + | otherwise = case eitherDecodeStrict' out of + Right (Object described) + | live described == wanted -> Success + | otherwise -> + Failure + ( Text.unwords + ["bucket", name, "has", count (live described), "lifecycle rule(s), which are not the", count wanted, "declared"] + ) + _ -> Unknown + where + name = lc.lifecycleBucket.bucketName + wanted = canonical (map ruleValue lc.lifecycleRules) + live described = canonical $ case firstOf ["lifecycle", "lifecycle_config"] described of + Just (Object config) -> arrayAt "rule" config + _ -> [] + canonical = sort . map (encode . pruned) + count = Text.pack . show . length + +-- | A JSON value without its null members and empty lists, at any depth. +pruned :: Value -> Value +pruned (Object o) = Object (KeyMap.filter (not . vacant) (KeyMap.map pruned o)) + where + vacant Null = True + vacant (Array a) = null a + vacant _ = False +pruned (Array a) = Array (fmap pruned a) +pruned v = v + +------------------------------------------------------------------------------- +-- Website + +{- | A bucket's website settings: the object served for a directory-like +path, and the one served for a missing object. They are what a bucket's +website endpoint needs, and what a load balancer's backend bucket honours. +'Nothing' is "not set". +-} +data BucketWebsite = BucketWebsite + { websiteBucket :: Bucket + , websiteMainPageSuffix :: Maybe Text + , websiteNotFoundPage :: Maybe Text + } + deriving (Eq, Show) + +{- | A bucket's website settings, keyed on the bucket: both are set to what +is declared, a 'Nothing' clearing what is there. + +* 'check': reads @describe --format json@ ('interpretWebsiteDescribe'). +* 'up': @update --web-main-page-suffix@ \/ @--web-error-page@ (or their + @--clear-@ forms). A "set" verb. +* 'down': clears both, only when the check finds the declared settings. + +The node has no dependency of its own: the caller puts the bucket underneath. +-} +bucketWebsite :: Reporter Report -> Track' (Binary "gcloud") -> BucketWebsite -> Op +bucketWebsite r gcloudTrack w = + withBinary gcloudTrack storageCommand (BucketsSetWebsite w) $ \set -> + withBinary gcloudTrack storageCommand (BucketsSetWebsite cleared) $ \clear -> + op "gcp-bucket-website" nodeps $ \actions -> + actions + { help = Text.unwords ["sets the website settings of GCS bucket", bkt.bucketName] + , notes = + [ "main page suffix: " <> fromMaybe "(none)" (setting w.websiteMainPageSuffix) + , "not-found page: " <> fromMaybe "(none)" (setting w.websiteNotFoundPage) + ] + , ref = mkRef "gcp-bucket-website" bkt.bucketName + , up = do + refuse ("website settings of bucket " <> bkt.bucketName) (websiteProblems w) + set (rFor (BucketsSetWebsite w)) + , down = Core.downIfPresent checkWebsite (clear (rFor (BucketsSetWebsite cleared))) + , check = checkWebsite + } + where + bkt = w.websiteBucket + cleared = BucketWebsite bkt Nothing Nothing + rFor cmd = contramap (RunStorageCommand cmd) r + + checkWebsite :: IO CheckResult + checkWebsite = uncurry (interpretWebsiteDescribe w) <$> readStorage (BucketsDescribeJson bkt) + +-- | A declared setting, an empty one being none. +setting :: Maybe Text -> Maybe Text +setting m = case Text.strip <$> m of + Just t | not (Text.null t) -> Just t + _ -> Nothing + +-- | Why declared website settings cannot be set, if they cannot. +websiteProblems :: BucketWebsite -> [Text] +websiteProblems w = + [ "the main page suffix is the last part of an object's name, and cannot contain a slash" + | Just s <- [setting w.websiteMainPageSuffix] + , Text.isInfixOf "/" s + ] + +{- | The verdict drawn from @gcloud storage buckets describe --format json@, +the settings being looked for under @website@ (the API's name, what @--raw@ +prints) and @website_config@ (gcloud's own). +-} +interpretWebsiteDescribe :: BucketWebsite -> ExitCode -> ByteString -> CheckResult +interpretWebsiteDescribe w code out + | problems@(_ : _) <- websiteProblems w = Failure (problemText ("website settings of bucket " <> name) problems) + | ExitFailure _ <- code = Failure ("bucket not found: " <> name) + | otherwise = case eitherDecodeStrict' out of + Right (Object described) -> + let config = case firstOf ["website", "website_config"] described of + Just (Object o) -> o + _ -> KeyMap.empty + differences = + catMaybes + [ differs "main page suffix" (setting w.websiteMainPageSuffix) (textAt "mainPageSuffix" config) + , differs "not-found page" (setting w.websiteNotFoundPage) (textAt "notFoundPage" config) + ] + in case differences of + [] -> Success + ds -> Failure (Text.unwords ["bucket", name, "has", Text.intercalate ", " ds]) + _ -> Unknown + where + name = w.websiteBucket.bucketName + differs :: Text -> Maybe Text -> Maybe Text -> Maybe Text + differs label wanted live + | wanted == live = Nothing + | otherwise = Just (Text.unwords [label, shown live <> ",", "not", shown wanted]) + shown = fromMaybe "(none)" + textAt k o = case KeyMap.lookup k o of + Just (String t) -> setting (Just t) + _ -> Nothing + +------------------------------------------------------------------------------- +-- Contents + +{- | A @Cache-Control@ value for the objects whose path matches a glob. + +The glob is matched against an object's path relative to the published +directory: @*@ and @?@ stay within one path segment, @**@ crosses segments, +anything else is literal. A glob with no slash matches a file name at any +depth (@*.html@ is every HTML file); one with a slash is anchored at the +directory's root (@assets\/**@, @\/index.html@). +-} +data CacheRule = CacheRule + { cacheGlob :: Text + , cacheControl :: Text + } + deriving (Eq, Ord, Show) + +-- | What the node's @down@ does to what it published. +data OnDown + = {- | Nothing. The objects stay, and so a bucket node underneath cannot be + deleted by the same pass: GCS refuses to delete a bucket holding objects. + -} + LeaveObjects + | -- | Removes every object under the destination, whoever put it there. + EmptyDestination + deriving (Eq, Ord, Show) + +-- | A local directory published under a bucket (or a prefix of one). +data BucketContents = BucketContents + { contentsBucket :: Bucket + , contentsPrefix :: Text + -- ^ Where in the bucket, without a leading slash; empty for its root. + , contentsSource :: FilePath + -- ^ The directory, read when the node is checked or applied. + , contentsCacheRules :: [CacheRule] + -- ^ The first rule whose glob matches an object decides its header. + , contentsDefaultCacheControl :: Maybe Text + -- ^ For objects no rule matches; 'Nothing' leaves the header unset. + , contentsDeleteExtraneous :: Bool + -- ^ Whether objects under the destination that the directory does not + -- hold are removed. + , contentsOnDown :: OnDown + } + deriving (Eq, Show) + +{- | Publishes a local directory to a bucket with @gcloud storage rsync@, +each object carrying the @Cache-Control@ its path calls for. + +@rsync@ takes one @--cache-control@ per invocation and narrows what it looks +at with an @--exclude@ regex only, so the directory is published in +'contentsPasses': one pass per rule, restricted to the objects that rule is +the first to match, and a last one for the rest. An excluded destination +object is not removed by @--delete-unmatched-destination-objects@, so each +pass removes the extraneous objects of its own share and the passes together +those of the whole destination. + +* 'check': the same passes with @--dry-run@, read by + 'interpretContentsDryRun'. The comparison is by checksum + (@--checksums-only@), and a planned mtime update is not a difference, so a + fresh checkout of unchanged files is satisfied. +* 'up': the passes, in rule order. A failing pass throws. +* 'down': per 'contentsOnDown'. 'EmptyDestination' syncs an empty directory + over the destination, and does nothing if the bucket is already gone. + +The directory is read by gcloud when the node is checked or applied, never +when the graph is built. A missing or empty directory is a 'Failure' for the +check and a throw for @up@: publishing nothing over a site is what a build +that failed would ask for. + +The node is keyed on the destination and has no dependency of its own: the +caller puts the bucket, and whatever builds the directory, underneath. + +What the check cannot see: a @Cache-Control@ declared differently for bytes +already published. The dry-run compares content, so the new header reaches an +object only when its content next changes. +-} +bucketContents :: Reporter Report -> Track' (Binary "gcloud") -> BucketContents -> Op +bucketContents r gcloudTrack c = + withBinary gcloudTrack storageCommand (BucketsDescribe bkt) $ \_describe -> + op "gcp-bucket-contents" nodeps $ \actions -> + actions + { help = Text.unwords ["publishes directory", Text.pack c.contentsSource, "to", contentsDestination c] + , notes = + [ "source: " <> Text.pack c.contentsSource + , "extraneous objects: " <> (if c.contentsDeleteExtraneous then "removed" else "left") + , "on down: " <> onDown + ] + <> [ "cache-control " <> p.passLabel <> ": " <> fromMaybe "(unset)" p.passCacheControl + | p <- contentsPasses c + ] + , ref = mkRef "gcp-bucket-contents" (bkt.bucketName, prefixOf c) + , up = bringUp + , down = bringDown + , check = checkContents + } + where + bkt = c.contentsBucket + what = "contents of " <> contentsDestination c + onDown :: Text + onDown = case c.contentsOnDown of + LeaveObjects -> "objects left" + EmptyDestination -> "destination emptied" + rFor cmd = contramap (RunStorageCommand cmd) r + run cmd = Binary.untrackedExec storageCommand cmd "" (rFor cmd) + + -- Why the directory cannot be published right now, if it cannot. + sourceProblems :: IO [Text] + sourceProblems = do + exists <- doesDirectoryExist c.contentsSource + if not exists + then pure ["the directory " <> Text.pack c.contentsSource <> " does not exist"] + else do + entries <- listDirectory c.contentsSource + pure ["the directory " <> Text.pack c.contentsSource <> " is empty" | null entries] + + checkContents :: IO CheckResult + checkContents = case contentsProblems c of + problems@(_ : _) -> pure (Failure (problemText what problems)) + [] -> do + missing <- sourceProblems + case missing of + _ : _ -> pure (Failure (problemText what missing)) + [] -> interpretContentsDryRun c <$> traverse dryRun (contentsPasses c) + + -- gcloud says what it would do on stderr, and exits 0 either way. + dryRun :: RsyncPass -> IO (ExitCode, ByteString) + dryRun p = do + (code, _out, err) <- + readCreateProcessWithExitCode + (prepare storageCommand (BucketsRsync (contentsRsync c p){rsyncDryRun = True})) + "" + pure (code, err) + + bringUp :: IO () + bringUp = do + refuse what (contentsProblems c) + refuse what =<< sourceProblems + mapM_ (run . BucketsRsync . contentsRsync c) (contentsPasses c) + + bringDown :: IO () + bringDown = case c.contentsOnDown of + LeaveObjects -> pure () + EmptyDestination -> do + refuse what (contentsProblems c) + (code, _out, _err) <- readCreateProcessWithExitCode (prepare storageCommand (BucketsDescribe bkt)) "" + case code of + -- no bucket, no objects + ExitFailure _ -> pure () + ExitSuccess -> withEmptyDirectory $ \empty -> run (BucketsRsync (emptyingRsync c empty)) + +-- | An empty directory, removed afterwards. +withEmptyDirectory :: (FilePath -> IO a) -> IO a +withEmptyDirectory act = do + tmp <- getTemporaryDirectory + bracket + ( do + -- a unique name from a file, then a directory beside it + (path, h) <- openTempFile tmp "salmon-empty" + hClose h + let dir = path <> ".d" + createDirectory dir + pure (path, dir) + ) + (\(path, dir) -> removeDirectory dir >> removeFile path) + (act . snd) + +-- | The prefix without the slashes around it. +prefixOf :: BucketContents -> Text +prefixOf c = Text.dropAround (== '/') (Text.strip c.contentsPrefix) + +-- | Where the directory is published: @gs:\/\/BUCKET@ or @gs:\/\/BUCKET\/PREFIX@. +contentsDestination :: BucketContents -> Text +contentsDestination c = case prefixOf c of + "" -> "gs://" <> c.contentsBucket.bucketName + prefix -> "gs://" <> c.contentsBucket.bucketName <> "/" <> prefix + +-- | Why a declared publication cannot be made, if it cannot. +contentsProblems :: BucketContents -> [Text] +contentsProblems c = + ["it names no directory" | null c.contentsSource] + <> ["the prefix " <> prefixOf c <> " has an empty or dotted segment" | any badSegment (segments (prefixOf c))] + <> ["a rule has an empty glob" | any Text.null globs] + <> ["the glob " <> g <> " is in two rules" | g <- nub (globs \\ nub globs), not (Text.null g)] + <> [ "the Cache-Control for " <> label <> " is empty or holds a control character" + | (label, value) <- headers + , Text.null (Text.strip value) || Text.any isControl value + ] + where + segments "" = [] + segments p = Text.splitOn "/" p + badSegment s = s `elem` ["", ".", ".."] + globs = map (\rule -> Text.strip rule.cacheGlob) c.contentsCacheRules + headers = + [(Text.strip rule.cacheGlob, rule.cacheControl) | rule <- c.contentsCacheRules] + <> [("the other objects", v) | Just v <- [c.contentsDefaultCacheControl]] + +-- | One @rsync@ invocation's share of the directory. +data RsyncPass = RsyncPass + { passLabel :: Text + -- ^ The glob, or what stands for "the rest". + , passExclude :: Maybe Text + -- ^ The regex of everything that is /not/ this pass's. + , passCacheControl :: Maybe Text + } + deriving (Eq, Show) + +{- | The passes that publish a directory: one per rule, each restricted to +the paths its glob matches and no earlier rule's does, then one for the +paths no rule matches. With no rule it is a single unrestricted pass. Every +path belongs to exactly one pass. +-} +contentsPasses :: BucketContents -> [RsyncPass] +contentsPasses c = + [ RsyncPass + { passLabel = Text.strip rule.cacheGlob + , passExclude = Just (onlyRegex (globRegex rule.cacheGlob) (map regexOf earlier)) + , passCacheControl = Just (Text.strip rule.cacheControl) + } + | (earlier, rule) <- zip (inits rules) rules + ] + <> [ RsyncPass + { passLabel = if null rules then "(every object)" else "(other objects)" + , passExclude = if null rules then Nothing else Just ("^(?:" <> alternatives (map regexOf rules) <> ")$") + , passCacheControl = Text.strip <$> c.contentsDefaultCacheControl + } + ] + where + rules = c.contentsCacheRules + regexOf :: CacheRule -> Text + regexOf rule = globRegex rule.cacheGlob + alternatives = Text.intercalate "|" + -- everything but what matches this one and none of the earlier ones + onlyRegex :: Text -> [Text] -> Text + onlyRegex mine [] = "^(?!" <> mine <> "$).*$" + onlyRegex mine earlier = "^(?!(?=" <> mine <> "$)(?!(?:" <> alternatives earlier <> ")$)).*$" + +{- | A glob as an unanchored Python regular expression over a relative path, +which is what @--exclude@ takes. See 'CacheRule' for the glob's meaning. A +comma is spelled @\\x2c@, since gcloud splits the flag's value on commas. +-} +globRegex :: Text -> Text +globRegex raw + | Just rooted <- Text.stripPrefix "/" glob = "(?:" <> go rooted <> ")" + | Text.isInfixOf "/" glob = "(?:" <> go glob <> ")" + | otherwise = "(?:(?:.*/)?" <> go glob <> ")" + where + glob = Text.strip raw + go :: Text -> Text + go t + | Just rest <- Text.stripPrefix "**/" t = "(?:.*/)?" <> go rest + | Just rest <- Text.stripPrefix "**" t = ".*" <> go rest + | Just (ch, rest) <- Text.uncons t = one ch <> go rest + | otherwise = "" + one :: Char -> Text + one '*' = "[^/]*" + one '?' = "[^/]" + one ',' = "\\x2c" + one ch + | isAscii ch && not (isAlphaNum ch) && ch `notElem` ("/_-" :: String) = Text.pack ['\\', ch] + | otherwise = Text.singleton ch + +-- | One @gcloud storage rsync@ from a local directory to a destination. +data Rsync = Rsync + { rsyncProject :: Project + , rsyncSource :: FilePath + , rsyncDestination :: Text + , rsyncDeleteUnmatched :: Bool + , rsyncCacheControl :: Maybe Text + , rsyncExclude :: Maybe Text + , rsyncDryRun :: Bool + } + deriving (Eq, Show) + +-- | The invocation that publishes one pass of a directory. +contentsRsync :: BucketContents -> RsyncPass -> Rsync +contentsRsync c p = + Rsync + { rsyncProject = c.contentsBucket.bucketProject + , rsyncSource = c.contentsSource + , rsyncDestination = contentsDestination c + , rsyncDeleteUnmatched = c.contentsDeleteExtraneous + , rsyncCacheControl = p.passCacheControl + , rsyncExclude = p.passExclude + , rsyncDryRun = False + } + +{- | The invocation that empties a destination: this (empty) directory +synced over it, everything unmatched removed. +-} +emptyingRsync :: BucketContents -> FilePath -> Rsync +emptyingRsync c empty = + Rsync + { rsyncProject = c.contentsBucket.bucketProject + , rsyncSource = empty + , rsyncDestination = contentsDestination c + , rsyncDeleteUnmatched = True + , rsyncCacheControl = Nothing + , rsyncExclude = Nothing + , rsyncDryRun = False + } + +-- | One thing a dry-run says it would do. +data Planned + = -- | Source, destination. + WouldCopy Text Text + | WouldRemove Text + | WouldSetMtime Text + | -- | A @Would ...@ line this module does not know, whole. + WouldOther Text + deriving (Eq, Show) + +{- | What @gcloud storage rsync --dry-run@ says it would do, read off its +standard error (its standard output is empty). The listing progress lines and +the blank one are dropped; a destination loses the @#generation@ an existing +object carries. +-} +parseDryRun :: ByteString -> [Planned] +parseDryRun = concatMap planned . Text.lines . decodeLenient + where + planned :: Text -> [Planned] + planned line0 + | Just rest <- Text.stripPrefix "Would copy " line + , (src, dst) <- Text.breakOnEnd " to " rest + , Just src' <- Text.stripSuffix " to " src = + [WouldCopy src' (ungenerated dst)] + | Just dst <- Text.stripPrefix "Would remove " line = [WouldRemove (ungenerated dst)] + | Just dst <- Text.stripPrefix "Would set mtime for " line = [WouldSetMtime (ungenerated dst)] + | Text.isPrefixOf "Would " line = [WouldOther line] + | otherwise = [] + where + line = Text.strip line0 + ungenerated :: Text -> Text + ungenerated url = case Text.breakOnEnd "#" url of + (before, generation) + | not (Text.null before) && not (Text.null generation) && Text.all (`elem` ['0' .. '9']) generation -> + Text.dropEnd 1 before + _ -> url + +{- | The verdict drawn from the dry-runs of a publication's passes, each an +exit code and what the command wrote on standard error. + +gcloud exits 0 whether or not anything differs, so the verdict is in the +lines: a copy or a removal is a difference, an mtime update is not (with +@--checksums-only@ it is all a file with the same bytes and a newer mtime +gives), and a @Would@ line of another kind cannot be judged. A non-zero exit +is an error (no bucket, no directory), reported with gcloud's own @ERROR@ +line. +-} +interpretContentsDryRun :: BucketContents -> [(ExitCode, ByteString)] -> CheckResult +interpretContentsDryRun c results + | problems@(_ : _) <- contentsProblems c = Failure (problemText what problems) + | (n, err) : _ <- [(n, err) | (ExitFailure n, err) <- results] = + Failure ("could not compare the " <> what <> " (exit " <> Text.pack (show n) <> ")" <> errorLine err) + | not (null copies && null removals) = + Failure + ( Text.unwords + [ "the" + , what + , "differ from" + , Text.pack c.contentsSource <> ":" + , Text.intercalate ", " (described "to copy" copies <> described "to remove" removals) + ] + ) + | (_ : _) <- [() | WouldOther _ <- plans] = Unknown + | otherwise = Success + where + what = "contents of " <> contentsDestination c + plans = concatMap (parseDryRun . snd) results + copies = [dst | WouldCopy _ dst <- plans] + removals = [dst | WouldRemove dst <- plans] + described :: Text -> [Text] -> [Text] + described _ [] = [] + described label objects = + [ Text.pack (show (length objects)) + <> " " + <> label + <> " (" + <> Text.unwords (map relative (take 3 objects)) + <> (if length objects > 3 then " ..." else "") + <> ")" + ] + relative url = fromMaybe url (Text.stripPrefix (contentsDestination c <> "/") url) + errorLine err = case [l | l <- Text.lines (decodeLenient err), Text.isPrefixOf "ERROR:" l] of + l : _ -> ": " <> Text.strip (Text.drop 6 l) + [] -> "" + +------------------------------------------------------------------------------- +-- Shared by the settings nodes + +-- | Runs a read-only storage command: its exit code and stdout. +readStorage :: StorageCommand -> IO (ExitCode, ByteString) +readStorage cmd = do + (code, out, _err) <- readCreateProcessWithExitCode (prepare storageCommand cmd) "" + pure (code, out) + +refuse :: Text -> [Text] -> IO () +refuse _ [] = pure () +refuse what problems = throwIO (userError (Text.unpack (problemText what problems))) + +problemText :: Text -> [Text] -> Text +problemText what problems = "the " <> what <> " cannot be applied: " <> Text.intercalate "; " problems + +arrayAt :: Text -> KeyMap.KeyMap Value -> [Value] +arrayAt k o = case KeyMap.lookup (Key.fromText k) o of + Just (Array a) -> toList a + _ -> [] + +-- | The first of these members that is there and not null. +firstOf :: [Text] -> KeyMap.KeyMap Value -> Maybe Value +firstOf ks o = case [v | k <- ks, Just v <- [KeyMap.lookup (Key.fromText k) o], v /= Null] of + v : _ -> Just v + [] -> Nothing + +decodeLenient :: ByteString -> Text +decodeLenient = Text.decodeUtf8With TextError.lenientDecode + +------------------------------------------------------------------------------- + data StorageCommand = BucketsCreate Bucket | BucketsDescribe Bucket | BucketsDelete Bucket + | -- | @describe --raw --format json@: the bucket as the storage API spells it. + BucketsDescribeJson Bucket + | BucketsGetIamPolicy Bucket + | BucketsAddIamBinding BucketIamBinding + | BucketsRemoveIamBinding BucketIamBinding + | -- | The path is a file holding 'renderLifecycle''s output. + BucketsSetLifecycle Bucket FilePath + | BucketsClearLifecycle Bucket + | BucketsSetWebsite BucketWebsite + | -- | @gcloud storage rsync@, a local directory to a bucket. + BucketsRsync Rsync deriving (Show) storageCommand :: Command "gcloud" StorageCommand @@ -113,4 +992,45 @@ , "delete" , "gs://" <> Text.unpack b.bucketName , "--quiet" + ] + BucketsDescribeJson b -> + gcloudProc $ withProject b.bucketProject ["storage", "buckets", "describe", url b, "--raw", "--format", "json"] + BucketsGetIamPolicy b -> + gcloudProc $ withProject b.bucketProject ["storage", "buckets", "get-iam-policy", url b, "--format", "json"] + BucketsAddIamBinding b -> bindingProc "add-iam-policy-binding" b + BucketsRemoveIamBinding b -> bindingProc "remove-iam-policy-binding" b + BucketsSetLifecycle b path -> + gcloudProc $ withProject b.bucketProject ["storage", "buckets", "update", url b, "--lifecycle-file", path] + BucketsClearLifecycle b -> + gcloudProc $ withProject b.bucketProject ["storage", "buckets", "update", url b, "--clear-lifecycle"] + BucketsSetWebsite w -> + gcloudProc $ + withProject w.websiteBucket.bucketProject $ + ["storage", "buckets", "update", url w.websiteBucket] + <> maybe ["--clear-web-main-page-suffix"] (\s -> ["--web-main-page-suffix", Text.unpack s]) (setting w.websiteMainPageSuffix) + <> maybe ["--clear-web-error-page"] (\s -> ["--web-error-page", Text.unpack s]) (setting w.websiteNotFoundPage) + BucketsRsync rs -> + gcloudProc $ + withProject rs.rsyncProject $ + ["storage", "rsync", rs.rsyncSource, Text.unpack rs.rsyncDestination, "--recursive"] + <> ["--delete-unmatched-destination-objects" | rs.rsyncDeleteUnmatched] + <> ["--checksums-only"] + <> ["--cache-control=" <> Text.unpack v | Just v <- [rs.rsyncCacheControl]] + <> ["--exclude=" <> Text.unpack re | Just re <- [rs.rsyncExclude]] + <> ["--dry-run" | rs.rsyncDryRun] + where + url :: Bucket -> String + url b = "gs://" <> Text.unpack b.bucketName + bindingProc :: String -> BucketIamBinding -> CreateProcess + bindingProc verb b = + gcloudProc $ + withProject b.bindingBucket.bucketProject + [ "storage" + , "buckets" + , verb + , url b.bindingBucket + , "--member" + , Text.unpack (renderMember b.bindingMember) + , "--role" + , Text.unpack (Text.strip b.bindingRole) ] diff --git a/src/Salmon/Builtin/Nodes/Haproxy.hs b/src/Salmon/Builtin/Nodes/Haproxy.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/Haproxy.hs @@ -0,0 +1,332 @@ +{- | HAProxy as a TCP router in front of a Patroni cluster: one port that +reaches whichever member is the leader right now, one that spreads over the +replicas (@specs\/pg-patroni.md@, "Routing to the leader", option 3). + +The shape is "Salmon.Builtin.Nodes.Nginx"'s -- a config value, a pure +renderer, a systemd unit -- and the rule is "Salmon.Builtin.Nodes.Patroni"'s: +__nothing here names a primary__. The configuration lists the /members/, all +of them, under every listener, and what tells them apart is an HTTP health +check against each member's Patroni REST API: @GET \/primary@ answers 200 on +the leader and 503 everywhere else, @GET \/replica@ the other way round. So a +failover is HAProxy's checks moving the traffic, with no reload, no rewrite +and no pass of salmon involved; rerunning @run up@ after one changes nothing +(the spec's T3), because nothing this module writes depended on who led. + +Deliberately decoupled from the Patroni module, like +"Salmon.Builtin.Nodes.PgBouncer" is from Postgres: a 'Member' is a name, an +address and two ports, since the router usually runs on a machine that is not +a member at all. + +What a change to the configuration does is a __restart__ (the file is one of +'Systemd.systemdServiceWatching'\'s watched files), which drops the +connections in flight. That is the price of adding or removing a member, and +only of that: the leader moving is never a configuration change. +-} +module Salmon.Builtin.Nodes.Haproxy 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.Ref (mkRef) +import Salmon.Op.Track +import Salmon.Reporter + +import Control.Exception (Exception, throwIO) +import qualified Data.Char as Char +import Data.List (group, sort) +import Data.Text (Text) +import qualified Data.Text as Text + +import System.FilePath (()) + +------------------------------------------------------------------------------- + +{- | A machine that may be the leader or a replica at any given moment. Which +it is appears nowhere in this value. +-} +data Member + = Member + { member_name :: Text + -- ^ HAProxy's server name: letters, digits, @_ - . :@ + , member_host :: Text + , member_pg_port :: Int + -- ^ where traffic is sent: Postgres, or a PgBouncer in front of it + , member_rest_port :: Int + -- ^ where the member is asked what it is: Patroni's REST API, 8008 by default + } + deriving (Show, Eq) + +{- | What a listener asks each member. The constructors are Patroni's own +endpoints; each answers 200 when the member is what the name says and 503 +otherwise. +-} +data Role + = -- | @GET \/primary@: the member holding the leader lock + Primary + | -- | @GET \/replica@: a running replica not tagged @noloadbalance@ + Replica + | -- | @GET \/replica?lag=BYTES@: a replica at most that far behind + ReplicaWithin Int + | -- | @GET \/read-only@: any member that can serve reads, the leader included + ReadOnly + deriving (Show, Eq) + +checkPath :: Role -> Text +checkPath Primary = "/primary" +checkPath Replica = "/replica" +checkPath (ReplicaWithin bytes) = "/replica?lag=" <> tshow bytes +checkPath ReadOnly = "/read-only" + +-- | One client-facing port, and the question that decides who is behind it. +data Listener + = Listener + { listener_name :: Text + , listener_bind_addr :: Text + -- ^ @*@ for every address + , listener_port :: Int + , listener_role :: Role + } + deriving (Show, Eq) + +-- | How often a member is asked, and how many answers change HAProxy's mind. +data Checks + = Checks + { checks_interval_seconds :: Int + , checks_fall :: Int + -- ^ consecutive failures before a member is taken out + , checks_rise :: Int + -- ^ consecutive successes before it is put back + , checks_timeout_seconds :: Int + } + deriving (Show, Eq) + +{- | Three seconds, three failures, two successes: what Patroni's own +documentation ships. The time from a leader losing its lock to HAProxy +closing its sessions is @interval * fall@, and it should stay under Patroni's +@ttl@ (30s by default) so that the router is never the slower of the two. +-} +defaultChecks :: Checks +defaultChecks = Checks 3 3 2 5 + +data HaproxyConfig + = HaproxyConfig + { haproxy_config_dir :: FilePath + -- ^ e.g. \/etc\/haproxy + , haproxy_listeners :: [Listener] + , haproxy_members :: [Member] + -- ^ every member, behind every listener; the checks do the sorting + , haproxy_checks :: Checks + , haproxy_maxconn :: Int + -- ^ process-wide and per member; keep it under what the members accept + , haproxy_connect_timeout_seconds :: Int + , haproxy_idle_timeout_seconds :: Int + -- ^ how long a silent client or server is kept; a pooled connection is + -- silent for long stretches, so this is minutes, not seconds + , haproxy_stats :: Maybe (Text, Int) + -- ^ bind address and port of the read-only status page, if wanted + , haproxy_user :: Text + -- ^ who the process runs as. The Debian package creates @haproxy@; a + -- listener on a port below 1024 needs somebody who may bind it. + , haproxy_group :: Text + } + deriving (Show, Eq) + +configPath :: HaproxyConfig -> FilePath +configPath cfg = cfg.haproxy_config_dir "haproxy.cfg" + +{- | The usual pair: a leader port and a replica port over the same members, +in Debian's layout. 5000 and 5001 are the ports Patroni's documentation uses. +-} +patroniRouter :: [Member] -> HaproxyConfig +patroniRouter members = + HaproxyConfig + { haproxy_config_dir = "/etc/haproxy" + , haproxy_listeners = + [ Listener "primary" "*" 5000 Primary + , Listener "replicas" "*" 5001 Replica + ] + , haproxy_members = members + , haproxy_checks = defaultChecks + , haproxy_maxconn = 100 + , haproxy_connect_timeout_seconds = 4 + , haproxy_idle_timeout_seconds = 1800 + , haproxy_stats = Nothing + , haproxy_user = "haproxy" + , haproxy_group = "haproxy" + } + +------------------------------------------------------------------------------- + +{- | Everything HAProxy would refuse to start on, or would start on and route +wrongly, collected rather than first-found. Empty means renderable. +-} +validate :: HaproxyConfig -> [Text] +validate cfg = + mconcat + [ ["no listeners" | null cfg.haproxy_listeners] + , ["no members" | null cfg.haproxy_members] + , ["listener name " <> quoted n <> " is not a valid proxy name" | n <- listenerNames, not (validName n)] + , ["member name " <> quoted n <> " is not a valid server name" | n <- memberNames, not (validName n)] + , ["listener name " <> quoted n <> " is declared more than once" | n <- duplicates listenerNames] + , ["listener name \"stats\" is taken by the status page" | Just _ <- [cfg.haproxy_stats], "stats" `elem` listenerNames] + , ["member name " <> quoted n <> " is declared more than once" | n <- duplicates memberNames] + , ["port " <> tshow p <> " is bound more than once" | p <- duplicates boundPorts] + , ["port " <> tshow p <> " is not a port" | p <- boundPorts <> memberPorts, p < 1 || p > 65535] + , ["bind address " <> quoted a <> " is not one word" | a <- bindAddrs, not (oneWord a)] + , ["member " <> quoted m.member_name <> " has host " <> quoted m.member_host <> ", which is not one word" | m <- cfg.haproxy_members, not (oneWord m.member_host)] + , ["a lag bound cannot be negative" | l <- cfg.haproxy_listeners, ReplicaWithin b <- [l.listener_role], b < 0] + , ["checks need a positive interval, fall, rise and timeout" | any (< 1) [k.checks_interval_seconds, k.checks_fall, k.checks_rise, k.checks_timeout_seconds]] + , ["maxconn and the timeouts must be positive" | any (< 1) [cfg.haproxy_maxconn, cfg.haproxy_connect_timeout_seconds, cfg.haproxy_idle_timeout_seconds]] + ] + where + k = cfg.haproxy_checks + listenerNames = fmap (.listener_name) cfg.haproxy_listeners + memberNames = fmap (.member_name) cfg.haproxy_members + boundPorts = fmap (.listener_port) cfg.haproxy_listeners <> maybe [] (\(_, p) -> [p]) cfg.haproxy_stats + memberPorts = concat [[m.member_pg_port, m.member_rest_port] | m <- cfg.haproxy_members] + bindAddrs = fmap (.listener_bind_addr) cfg.haproxy_listeners <> maybe [] (\(a, _) -> [a]) cfg.haproxy_stats + quoted t = "\"" <> t <> "\"" + duplicates :: (Ord a) => [a] -> [a] + duplicates xs = [x | (x : _ : _) <- group (sort xs)] + validName n = not (Text.null n) && Text.all (\c -> Char.isAscii c && (Char.isAlphaNum c || c `elem` ("_-.:" :: String))) n + oneWord t = not (Text.null t) && not (Text.any (\c -> Char.isSpace c || c == '#') t) + +newtype InvalidConfig = InvalidConfig [Text] + deriving (Show) + +instance Exception InvalidConfig + +{- | @haproxy.cfg@. Pure, and a function of the member /set/ only: the same +text before and after any number of failovers. +-} +renderConfig :: HaproxyConfig -> Text +renderConfig cfg = + Text.unlines $ + mconcat + [ + [ "# written by salmon (Salmon.Builtin.Nodes.Haproxy); edits are overwritten" + , "global" + , " maxconn " <> tshow cfg.haproxy_maxconn + , " log stdout format short daemon" + , "" + , "defaults" + , " log global" + , " mode tcp" + , " retries 2" + , " timeout connect " <> tshow cfg.haproxy_connect_timeout_seconds <> "s" + , " timeout client " <> tshow cfg.haproxy_idle_timeout_seconds <> "s" + , " timeout server " <> tshow cfg.haproxy_idle_timeout_seconds <> "s" + , " timeout check " <> tshow k.checks_timeout_seconds <> "s" + ] + , maybe [] renderStats cfg.haproxy_stats + , concatMap renderListener cfg.haproxy_listeners + ] + where + k = cfg.haproxy_checks + + renderStats :: (Text, Int) -> [Text] + renderStats (addr, port) = + [ "" + , "listen stats" + , " mode http" + , " bind " <> addr <> ":" <> tshow port + , " stats enable" + , " stats uri /" + ] + + renderListener :: Listener -> [Text] + renderListener l = + [ "" + , "listen " <> l.listener_name + , " bind " <> l.listener_bind_addr <> ":" <> tshow l.listener_port + , " option httpchk GET " <> checkPath l.listener_role + , " http-check expect status 200" + , -- shutdown-sessions is what makes a demoted leader's clients + -- reconnect (and land on the new one) rather than keep writing + -- into a server that now refuses them. + " default-server inter " + <> tshow k.checks_interval_seconds + <> "s fall " + <> tshow k.checks_fall + <> " rise " + <> tshow k.checks_rise + <> " on-marked-down shutdown-sessions" + ] + <> balance l.listener_role + <> fmap renderMember cfg.haproxy_members + + -- one leader at most, so there is nothing to balance behind 'Primary' + balance :: Role -> [Text] + balance Primary = [] + balance _ = [" balance leastconn"] + + renderMember :: Member -> Text + renderMember m = + mconcat + [ " server " + , m.member_name + , " " + , m.member_host + , ":" + , tshow m.member_pg_port + , " maxconn " + , tshow cfg.haproxy_maxconn + , " check port " + , tshow m.member_rest_port + ] + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show + +------------------------------------------------------------------------------- + +{- | Renders @haproxy.cfg@. A configuration 'validate' objects to is not +written: the node throws every objection instead, since a file HAProxy +refuses is a router that stays down at its next restart. +-} +configFiles :: HaproxyConfig -> Op +configFiles cfg = case validate cfg of + [] -> op "haproxy-config" (deps [cfgFile]) id + problems -> + op "haproxy-config" nodeps $ \actions -> + actions + { help = "refuses an invalid haproxy configuration" + , notes = problems + , ref = mkRef "haproxy-invalid-config" (configPath cfg) + , up = throwIO (InvalidConfig problems) + } + where + cfgFile = FS.filecontentsInSharedDir $ FS.FileContents (configPath cfg) (renderConfig cfg) + +{- | Installs haproxy, renders its config, and runs it as a systemd service. + +The unit is salmon's own, written to @\/etc\/systemd\/system@ where it takes +precedence over the one the Debian package ships, for the same reason +'Salmon.Builtin.Nodes.PgBouncer.setup' writes one: the config file is a +watched file of 'Systemd.systemdServiceWatching', so a changed member list +reaches the running process (by a restart) instead of sitting on disk. The +process runs in the foreground in master-worker mode (@-W -db@) as +'haproxy_user', with no chroot and no privilege drop of its own. +-} +setup :: Reporter Systemd.Report -> Track' (Binary "systemctl") -> Track' (Binary "haproxy") -> HaproxyConfig -> Op +setup r systemctl haproxyBin cfg = + Systemd.systemdServiceWatching [configPath cfg] r systemctl trackConfig systemdCfg + where + trackConfig :: Track' Systemd.Config + trackConfig = Track $ \_ -> op "haproxy-setup" (deps [configFiles cfg, justInstall haproxyBin]) id + + systemdCfg :: Systemd.Config + systemdCfg = Systemd.Config Systemd.System "/etc/systemd/system" "haproxy.service" unit svc install + + unit :: Systemd.Unit + unit = Systemd.Unit "HAProxy (from Salmon)" "network-online.target" + + svc :: Systemd.Service + svc = Systemd.Service Systemd.Simple cfg.haproxy_user cfg.haproxy_group "0022" start Systemd.OnFailure Systemd.Process cfg.haproxy_config_dir + + start :: Systemd.Start + start = Systemd.Start "/usr/sbin/haproxy" ["-W", "-db", "-f", Text.pack (configPath cfg)] + + install :: Systemd.Install + install = Systemd.Install "multi-user.target" diff --git a/src/Salmon/Builtin/Nodes/LlamaServer.hs b/src/Salmon/Builtin/Nodes/LlamaServer.hs --- a/src/Salmon/Builtin/Nodes/LlamaServer.hs +++ b/src/Salmon/Builtin/Nodes/LlamaServer.hs @@ -52,6 +52,7 @@ llamaBinary, ModelFile (..), llamaModel, + ggufModel, Pooling (..), Listen (..), LlamaServer (..), @@ -61,10 +62,13 @@ llamaServerSystemd, llamaReady, llamaCheck, + llamaEmbed, -- * Pieces, exposed for tests interpretHealth, interpretEmbedding, + embeddingRequest, + parseEmbedding, dimensionNote, curlConfig, curlBase, @@ -170,12 +174,20 @@ not something this node made unless it fetched it. -} llamaModel :: ModelFile -> Op -llamaModel m = - op "llama-model" nodeps $ \actions -> +llamaModel = ggufModel "llama-model" + +{- | 'llamaModel' under another kind of 'Ref', for the other builtins that +take a pinned GGUF file ("Salmon.Builtin.Nodes.ClipCpp"). The kind is the +node's name and its 'Ref' tag, so one path declared for two tools is two +nodes. +-} +ggufModel :: Text -> ModelFile -> Op +ggufModel kind m = + op kind 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 + , ref = mkRef kind m.modelPath , check = do there <- doesFileExist m.modelPath if not there @@ -366,6 +378,45 @@ where readKey f = Text.strip . Text.takeWhile (/= '\n') . decode <$> ByteString.readFile f curl cfg = readCreateProcessWithExitCode (proc "curl" curlBase) (Text.encodeUtf8 cfg) + +{- | The vector of one text, from a running server, or why there is none: what +a loader calls (the counterpart of "Salmon.Builtin.Nodes.ClipCpp"'s @embed@). +The text is in the request body, which goes to @curl@ on stdin with the key, +so neither is on a command line. A vector of another width than +'lsDimension' is refused here rather than at the insert. +-} +llamaEmbed :: LlamaServer -> Text -> IO (Either Text [Double]) +llamaEmbed s text = do + key <- traverse readKey s.lsApiKeyFile + (code, out, err) <- readCreateProcessWithExitCode (proc "curl" curlBase) (Text.encodeUtf8 (curlConfig s.lsListen "/v1/embeddings" (Just (embeddingRequest text)) key)) + pure $ case code of + ExitFailure n -> Left ("curl exited with " <> tshow n <> ": " <> Text.take 300 (Text.strip (decode err))) + ExitSuccess -> case splitStatus (decode out) of + (body, 200) -> parseEmbedding s.lsDimension body + (_, status) -> Left ("llama-server answered " <> tshow status) + where + readKey f = Text.strip . Text.takeWhile (/= '\n') . decode <$> ByteString.readFile f + +-- | The JSON body of @POST \/v1\/embeddings@ for one input. +embeddingRequest :: Text -> Text +embeddingRequest text = Text.decodeUtf8 (LByteString.toStrict (Aeson.encode (Aeson.object ["input" Aeson..= text]))) + +-- | @data[0].embedding@, which must have the declared width. +parseEmbedding :: Int -> Text -> Either Text [Double] +parseEmbedding dim body = + 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 + , Just xs <- traverse number (foldr (:) [] v) -> + if length xs == dim + then Right xs + else Left ("the model produces " <> tshow (length xs) <> " dimensions, " <> tshow dim <> " declared") + _ -> Left "not an embeddings answer" + where + number (Aeson.Number n) = Just (realToFrac n) + number _ = Nothing -- | @curl@'s own arguments: everything else, the key included, is on stdin. curlBase :: [String] diff --git a/src/Salmon/Builtin/Nodes/Netbird.hs b/src/Salmon/Builtin/Nodes/Netbird.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/Netbird.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | A machine enrolled as a NetBird peer. + +"SreBox.WireGuardMesh" covers machines with stable endpoints and +deliberately does not rebuild NAT traversal. For a roaming or NAT-bound +device the complement is NetBird's own client: this module enrols a machine +against a management server with a setup key and answers \"is it enrolled +and connected\" from the client's own status report. It does not provision +the management server, and it does not manage what the management server +decides (groups, policies, routes, the peer's address). + += The pieces + +* 'peer' is the enrolment: @netbird up --setup-key-file FILE@ against the + declared management URL, with a 'check' read from @netbird status --json@. +* 'netbirdRepository' and 'package' are the upstream apt repository and the + @netbird@ package, for a caller that wants salmon to install the client. + The package's own post-install script installs and starts the daemon's + system service (@netbird service install@, @netbird service start@), so + nothing here writes a unit file. A caller with another source for the + binary passes its own @'Track'' ('Binary' \"netbird\")@ and makes sure the + daemon runs. + += The setup key + +The setup key is a bearer credential: whoever holds it can add a machine to +the network. It is a pre-provisioned file (how it got there is the caller's +business, and the caller's 'Track'), it is named on the command line as a +path and never as a value, and it is read when the node runs, never when the +graph is built. The client reads the file itself and hands the key to the +daemon over its local socket. Because the client's error text is not under +this module's control, whatever a failed @netbird up@ printed has the key's +bytes replaced before it reaches a report or an exception ('redact'). + +A setup key is only spent on a peer that is not enrolled yet: on an enrolled +and connected peer @netbird up@ answers @Already connected@ and reads +nothing, so the file may be removed, or the key may expire, without the +node failing afterwards. + += What the node refuses + +__Moving a connected peer to another management server.__ A peer that is +connected to a management URL other than the declared one was enrolled by +somebody, into some other network; @netbird up@ would not move it anyway +(it answers @Already connected@), and taking it down to re-enrol it is a +decision this node does not take. 'up' throws 'EnrolledElsewhere' and the +operator runs @netbird down@ (or deregisters the peer) on purpose. + += down + +@netbird down@: the peer disconnects and its interface goes away. The peer +__stays registered__ on the management server, and its local state stays on +disk: removing it there needs the management API and a credential this +module does not hold. + += What was verified, and what was not + +The flags (@--setup-key-file@, @--management-url@, @--hostname@, +@status --json@), the JSON field names, the @daemonStatus@ values and the +package's post-install behaviour were read in the upstream repository's +client sources and the repository's install documentation (the release +current at the time was v0.80.0). __Nothing here has been run against a +NetBird daemon or a management server__: the fixtures in the tests are +written by hand from the upstream structs, not captured. In particular the +exact spelling of @management.url@ in the status output (with or without +scheme and port) was not observed, which is why 'sameManagement' compares +leniently, and the release that introduced @--setup-key-file@ and the +@daemonStatus@ field was not looked up ('interpretStatus' tolerates a +missing @daemonStatus@). +-} +module Salmon.Builtin.Nodes.Netbird ( + Report (..), + Enrolment (..), + enrolment, + peer, + EnrolledElsewhere (..), + MissingSetupKey (..), + + -- * Installing the client + netbirdRepository, + package, + + -- * Pieces, exposed for tests + NetbirdCommand (..), + netbirdcommand, + Status (..), + parseStatus, + interpretStatus, + connectedElsewhere, + sameManagement, + normalizeManagementUrl, + redact, + runRedacted, +) where + +import Control.Exception (Exception, throwIO) +import Control.Monad (when) +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as C8 +import qualified Data.List.NonEmpty as NEList +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.IO.Exception (ExitCode (..)) +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 (..), CommandFailed (..), justInstall, untrackedExec) +import qualified Salmon.Builtin.Nodes.Binary as Binary +import Salmon.Builtin.Nodes.Debian.AptRepository (AptRepository (..), Pinning (..), Suite (..)) +import Salmon.Builtin.Nodes.Debian.Package (Package (..), deb) +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- +data Report + = RunNetbird !NetbirdCommand !Binary.Report + deriving (Show) + +------------------------------------------------------------------------------- + +-- | What a machine declares about its enrolment. +data Enrolment = Enrolment + { enrolSetupKeyFile :: FilePath + -- ^ Pre-provisioned file holding the setup key (surrounding whitespace + -- is ignored, by the client as by this module). + , enrolManagementUrl :: Maybe Text + -- ^ @https://netbird.example.org@ for a self-hosted management server; + -- 'Nothing' leaves the client's default (the vendor's hosted service) + -- and then no URL is compared. + , enrolHostname :: Maybe Text + -- ^ The name the peer registers under; 'Nothing' leaves the machine's + -- host name. Only read by the management server at enrolment: a + -- changed value does not rename an enrolled peer and is not checked. + } + deriving (Eq, Show) + +-- | An enrolment from a setup-key file, against the client's default +-- management server and under the machine's own name. +enrolment :: FilePath -> Enrolment +enrolment keyFile = Enrolment keyFile Nothing Nothing + +-- | Thrown by 'peer''s @up@ when the daemon is connected to a management +-- server other than the declared one. Both URLs are public. +data EnrolledElsewhere = EnrolledElsewhere + { elsewhereDeclared :: Text + , elsewhereFound :: Text + } + +instance Show EnrolledElsewhere where + show e = + "netbird is connected to another management server (" + <> Text.unpack e.elsewhereFound + <> ", declared " + <> Text.unpack e.elsewhereDeclared + <> "); not re-enrolling it. Run `netbird down` on purpose first." + +instance Exception EnrolledElsewhere + +-- | Thrown by 'peer''s @up@ before anything is run when the setup-key file +-- is empty: without a key the client falls back to an interactive login, +-- which nothing would ever answer. +newtype MissingSetupKey = MissingSetupKey FilePath + +instance Show MissingSetupKey where + show (MissingSetupKey path) = "netbird setup-key file is empty: " <> path + +instance Exception MissingSetupKey + +{- | The machine's NetBird daemon, enrolled and connected. + +There is one daemon per machine (the client's default daemon address), so +that is the effect site: two declarations with different management URLs +collide and are reported, rather than fighting over the daemon. + +* 'check' is 'interpretStatus' over @netbird status --json@. A daemon that + cannot be reached is a 'Failure' (the following @up@ then fails with the + client's own message, which names the service to start). +* 'up' reads the status first, refuses a peer connected elsewhere + ('EnrolledElsewhere'), refuses an empty key file ('MissingSetupKey'), and + runs @netbird up@. It throws on a non-zero exit, with the key redacted + from the output it quotes. +* 'down' is @netbird down@; see the module header for what that leaves. + +The second argument provisions the binary ('package', or the caller's own); +the third provisions the setup-key file (@ignoreTrack@ when it is already +on the machine). +-} +peer :: + Reporter Report -> + Track' (Binary "netbird") -> + Track' FilePath -> + Enrolment -> + Op +peer r netbird key enrol = + op "netbird-peer" (deps [justInstall netbird, run key enrol.enrolSetupKeyFile]) $ \actions -> + actions + { help = "netbird peer enrolled against " <> fromMaybe "the default management server" enrol.enrolManagementUrl + , notes = + [ "setup key read from: " <> Text.pack enrol.enrolSetupKeyFile + , "registers as: " <> fromMaybe "the machine's host name" enrol.enrolHostname + ] + , ref = mkRef "netbird-peer" ("default-daemon" :: Text) + , check = either id (interpretStatus enrol) <$> readStatus + , up = do + current <- readStatus + case current of + Right st | Just found <- connectedElsewhere enrol st -> + throwIO (EnrolledElsewhere (fromMaybe "" enrol.enrolManagementUrl) found) + _ -> pure () + secret <- C8.strip <$> ByteString.readFile enrol.enrolSetupKeyFile + when (ByteString.null secret) $ throwIO (MissingSetupKey enrol.enrolSetupKeyFile) + let cmd = Up enrol + runRedacted secret (prepare netbirdcommand cmd) (r' cmd) + , down = untrackedExec netbirdcommand Down "" (r' Down) + } + where + r' cmd = contramap (RunNetbird cmd) r + +-- | @netbird status --json@, parsed. 'Left' is the verdict when there is +-- nothing to interpret. +readStatus :: IO (Either CheckResult Status) +readStatus = do + (code, out, _) <- readCreateProcessWithExitCode (prepare netbirdcommand StatusJson) "" + pure $ case code of + ExitFailure _ -> Left (Failure "netbird daemon not reachable") + ExitSuccess -> maybe (Left Unknown) Right (parseStatus out) + +{- | 'Binary.untrackedExec' for a command whose output may quote a secret: +same reports, same 'CommandFailed' on a non-zero exit, with every occurrence +of the secret replaced in both streams first. The output stays captured +(never streamed) for the same reason. +-} +runRedacted :: ByteString -> CreateProcess -> Reporter Binary.Report -> IO () +runRedacted secret p r = do + runReporter r (Binary.CommandStart p) + (code, out0, err0) <- readCreateProcessWithExitCode p "" + let out = redact secret out0 + err = redact secret err0 + runReporter r (Binary.CommandStopped p code out err) + case code of + ExitSuccess -> pure () + ExitFailure n -> throwIO (CommandFailed p n out err) + +{- | Replace every occurrence of the secret with @[redacted]@. An empty +secret redacts nothing (it would match everywhere). +-} +redact :: ByteString -> ByteString -> ByteString +redact secret + | ByteString.null secret = id + | otherwise = go + where + go hay = + let (before, rest) = ByteString.breakSubstring secret hay + in if ByteString.null rest + then before + else before <> "[redacted]" <> go (ByteString.drop (ByteString.length secret) rest) + +------------------------------------------------------------------------------- + +-- | The part of @netbird status --json@ the check reads. +data Status = Status + { statusDaemon :: Maybe Text + -- ^ @daemonStatus@: @Idle@, @Connecting@, @Connected@, @NeedsLogin@, + -- @LoginFailed@, @SessionExpired@. Absent from clients that predate the + -- field. + , statusManagementUrl :: Text + , statusManagementConnected :: Bool + } + deriving (Eq, Show) + +instance Aeson.FromJSON Status where + parseJSON = Aeson.withObject "netbird status" $ \o -> do + management <- o .: "management" + Status + <$> o .:? "daemonStatus" + <*> (fromMaybe "" <$> management .:? "url") + <*> management .: "connected" + +parseStatus :: ByteString -> Maybe Status +parseStatus = Aeson.decodeStrict + +{- | The verdict on an enrolment from the daemon's status. + +* Connected to the management server, and to the declared one when a URL is + declared: 'Success'. +* Connected to another management server: 'Failure' (and 'peer''s @up@ will + refuse, see 'EnrolledElsewhere'). +* @Connecting@: 'Unknown', a transitional state that an @up@ would not help. +* Anything else (@NeedsLogin@, @LoginFailed@, @SessionExpired@, @Idle@, a + daemon that says @Connected@ while the management connection is down, or + an older client reporting only that the management connection is down): + 'Failure' naming the state. + +The reasons quote the daemon's state and the two URLs, nothing else from +the report. +-} +interpretStatus :: Enrolment -> Status -> CheckResult +interpretStatus enrol st = + case st.statusDaemon of + Just "Connecting" -> Unknown + Just "Connected" -> whenConnected + Just other -> Failure ("netbird daemon is " <> other) + Nothing -> whenConnected + where + whenConnected + | not st.statusManagementConnected = Failure "not connected to the management server" + | Just found <- connectedElsewhere enrol st = Failure ("connected to another management server: " <> found) + | otherwise = Success + +-- | The management URL the daemon is connected to, when a URL is declared +-- and it is not that one. +connectedElsewhere :: Enrolment -> Status -> Maybe Text +connectedElsewhere enrol st = do + declared <- enrol.enrolManagementUrl + if st.statusManagementConnected && not (Text.null st.statusManagementUrl) && not (sameManagement declared st.statusManagementUrl) + then Just st.statusManagementUrl + else Nothing + +-- | Whether two management URLs name the same server; see +-- 'normalizeManagementUrl'. +sameManagement :: Text -> Text -> Bool +sameManagement a b = normalizeManagementUrl a == normalizeManagementUrl b + +{- | Scheme, host and port of a management URL, lower-cased, with the path +dropped, a missing scheme read as @https@ and a missing port filled in from +the scheme (443, or 80 for @http@). Lenient on purpose: how the client spells +the URL in its status report was not observed. +-} +normalizeManagementUrl :: Text -> (Text, Text, Text) +normalizeManagementUrl url = (scheme, host, port) + where + lowered = Text.toLower (Text.strip url) + (scheme, rest) = case Text.breakOn "://" lowered of + (s, r) | not (Text.null r) -> (s, Text.drop 3 r) + _ -> ("https", lowered) + authority = Text.takeWhile (/= '/') rest + (host, port) = case Text.breakOnEnd ":" authority of + (h, p) + | not (Text.null h) && not (Text.null p) && Text.all (`elem` ("0123456789" :: String)) p -> + (Text.dropEnd 1 h, p) + _ -> (authority, if scheme == "http" then "80" else "443") + +------------------------------------------------------------------------------- + +data NetbirdCommand + = Up Enrolment + | Down + | StatusJson + deriving (Show) + +-- | The setup key is only ever named by its file. +netbirdcommand :: Command "netbird" NetbirdCommand +netbirdcommand = Command $ \cmd -> case cmd of + Up enrol -> + netbird $ + mconcat + [ ["up", "--setup-key-file", enrol.enrolSetupKeyFile] + , maybe [] (\u -> ["--management-url", Text.unpack u]) enrol.enrolManagementUrl + , maybe [] (\h -> ["--hostname", Text.unpack h]) enrol.enrolHostname + ] + Down -> netbird ["down"] + StatusJson -> netbird ["status", "--json"] + where + netbird :: [String] -> CreateProcess + netbird = proc "netbird" + +------------------------------------------------------------------------------- + +{- | The upstream apt repository (@pkgs.netbird.io@), pinned to the +@netbird@ package only. The signing key is a file the caller provisioned and +its fingerprint is the caller's to declare, as for every +'Salmon.Builtin.Nodes.Debian.AptRepository.AptRepository'. +-} +netbirdRepository :: FilePath -> Text -> AptRepository +netbirdRepository keyFile fingerprint = + AptRepository + { repoName = "netbird" + , repoUris = "https://pkgs.netbird.io/debian" + , repoSuite = FixedSuite "stable" + , repoComponents = ["main"] + , repoKeyFile = keyFile + , repoKeyFingerprint = fingerprint + , repoPin = OnlyPackages ("netbird" NEList.:| []) + , repoAptDir = "/etc/apt" + , repoListsDir = "/var/lib/apt/lists" + } + +{- | The @netbird@ package, as a provider of the binary. The argument makes +the package installable: 'Salmon.Builtin.Nodes.Debian.AptRepository.viaRepository' +of a 'netbirdRepository', or @ignoreTrack@ when it already is. + +Installing the package starts the daemon (its post-install script installs +and starts the system service). The daemon does nothing on the network until +a peer is enrolled. +-} +package :: Track' () -> Track' (Binary "netbird") +package source = Track $ \_ -> deb (Package "netbird") `inject` run source () diff --git a/src/Salmon/Builtin/Nodes/Nginx.hs b/src/Salmon/Builtin/Nodes/Nginx.hs --- a/src/Salmon/Builtin/Nodes/Nginx.hs +++ b/src/Salmon/Builtin/Nodes/Nginx.hs @@ -62,7 +62,7 @@ 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) + vhostFile v = FS.filecontentsInSharedDir $ FS.FileContents (cfg.nginx_sites_dir vhostFileName v) (renderVHost v) renderVHost :: VHost -> Text renderVHost v = diff --git a/src/Salmon/Builtin/Nodes/Patroni.hs b/src/Salmon/Builtin/Nodes/Patroni.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/Patroni.hs @@ -0,0 +1,488 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Patroni, as one member of a cluster: its config, its systemd unit, Debian's +own per-cluster Postgres units masked out of its way, and a check that asks +Patroni's REST API rather than the disk (@specs\/pg-patroni.md@). + +__Patroni owns Postgres here.__ Nothing in this module starts, stops, promotes +or configures a Postgres cluster, and nothing in it names a primary: no node's +@ref@, @help@ or @notes@ says which member leads, because that is Patroni's +decision and a declaration that disagreed with it would be fighting its owner. +Which member is the leader is reported by the check (in a failure's text, +never as a verdict) and nothing more. +The one, opt-in, exception is a /preference/ an operator declares on purpose: +"Salmon.Builtin.Nodes.Patroni.PreferredLeader", a separate node that nothing +here pulls in. + +__Layout.__ Postgresql-common's, as decided for this builtin: the data +directory is @\/var\/lib\/postgresql\/V\/CLUSTER@, the configuration lives in +@\/etc\/postgresql\/V\/CLUSTER@ (Patroni writes @postgresql.conf@ and +@pg_hba.conf@ there and starts the server with that file), binaries are +@\/usr\/lib\/postgresql\/V\/bin@. What this module does /not/ do is +@pg_createcluster@: the data directory must be absent so that Patroni can +@initdb@ (or clone) it. The @postgresql\@V-CLUSTER@ unit that Debian ships for +that name is __masked__ ('maskedUnit'), since it would otherwise start the same +data directory behind Patroni's back at boot. + +__Configuration is a directory.__ Patroni is started on 'pat_config_dir' and +loads every @*.yml@ in it. @patroni.yml@ is rendered here, as a 'Text' (so its +content fingerprint reaches @notes@ and a re-declaration is @Stale@ under +@run serve@). The credentials are __not__ in it: they live in a +pre-provisioned file in the same directory ('pat_secrets_file', a YAML +fragment carrying @restapi.authentication@ and @postgresql.authentication@), +which this builtin only /owns/ (@chown@ to the service user, mode @0600@) and +/watches/ (a change restarts the service), never writes -- a recipe must not +bake a secret transport into a builtin. Etcd is the v3 API only, with its TLS +files as pre-provisioned paths. + +__The check__ is @GET \/patroni@ and @GET \/health@ on the member's own REST +address ('interpretMember'): @running@ with a healthy @\/health@ is satisfied, +a transitional state (@starting@, @restarting@, ...) or an uninitialised member +is @Unknown@ (not yet gone, so nothing should be bounced), anything else, or +an API that does not answer, is a failure. The role is reported and never +judged: a replica is as healthy as a leader. @pending_restart@ is likewise +parsed and /not/ judged -- whether a pending restart is the member's problem is +the cluster-wide config node's question, not this one's. The REST API is +spoken over plain HTTP; the unauthenticated @GET@s are all this needs. +-} +module Salmon.Builtin.Nodes.Patroni where + +import Control.Concurrent (threadDelay) +import Control.Exception (Exception, SomeException, throwIO, try) +import Control.Monad (when) +import Data.Char (isAlphaNum) +import Data.Aeson (FromJSON (..), eitherDecodeStrict, encode, withObject, (.!=), (.:?)) +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 Network.HTTP.Client ( + HttpException, + defaultManagerSettings, + httpLbs, + managerResponseTimeout, + newManager, + parseRequest, + responseBody, + responseStatus, + responseTimeoutMicro, + ) +import Network.HTTP.Types.Status (statusCode) +import System.Directory (doesFileExist) +import System.FilePath (()) +import qualified System.Posix.Types as Posix + +import Salmon.Actions.UpDown (CheckResult (..)) +import Salmon.Builtin.Extension +import Salmon.Builtin.Nodes.Binary (Binary, justInstall) +import Salmon.Builtin.Nodes.Etcd (TlsFiles (..)) +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Systemd as Systemd +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- + +data PatroniConfig + = PatroniConfig + { pat_scope :: Text + -- ^ the cluster's name, shared by every member + , pat_namespace :: Text + -- ^ the DCS key prefix, e.g. @\/service\/@ + , pat_name :: Text + -- ^ this member's name, unique in the scope + , pat_etcd_hosts :: [Text] + -- ^ @host:port@ of the etcd members (v3 API only) + , pat_etcd_tls :: Maybe TlsFiles + -- ^ client CA, certificate and key, as pre-provisioned paths; 'Nothing' speaks plain HTTP + , pat_rest_listen :: Text + -- ^ @host:port@ the REST API binds, e.g. @0.0.0.0:8008@ + , pat_rest_connect_address :: Text + -- ^ @host:port@ other members and this node's own check reach it by + , pat_pg_version :: Text + -- ^ the Debian major version, e.g. @16@ + , pat_pg_cluster :: Text + -- ^ the postgresql-common cluster name, e.g. @main@ + , pat_pg_listen :: Text + -- ^ @host:port@ Postgres binds + , pat_pg_connect_address :: Text + -- ^ @host:port@ clients and other members reach this Postgres by + , pat_pg_hba :: [Text] + -- ^ @pg_hba.conf@ lines, the whole file, written by Patroni on every member + , pat_bootstrap_parameters :: [(Text, Text)] + -- ^ @postgresql.parameters@ at /bootstrap/ only; afterwards the DCS is + -- owned by whoever patches @\/config@ + , pat_config_dir :: FilePath + -- ^ the directory Patroni is started on, e.g. @\/etc\/patroni@ + , pat_secrets_file :: FilePath + -- ^ the pre-provisioned credentials fragment; must be inside 'pat_config_dir' + , pat_user :: Text + -- ^ the system user the unit runs as, normally @postgres@ + , pat_binary :: FilePath + , pat_ready_timeout_seconds :: Int + -- ^ how long @up@ waits for the check to pass + , pat_archive :: Maybe Archive + -- ^ a continuous archive to build replicas from and to archive WAL into; 'Nothing' is base backups from the leader only + } + deriving (Show) + +{- | A continuous WAL archive, as far as Patroni is concerned: commands, as one +shell string each. Which tool they belong to is not this module's business +("Salmon.Builtin.Nodes.PgBackRest" makes one with @patroniArchive@), and no +credential is in them. +-} +data Archive + = Archive + { arc_methods :: [ReplicaMethod] + -- ^ @create_replica_methods@, tried in order + , arc_basebackup_fallback :: Bool + -- ^ end the list with Patroni's own @basebackup@, for an archive that holds no backup yet + , arc_archive_command :: Text + , arc_restore_command :: Text + , arc_bootstrap :: Maybe BootstrapMethod + -- ^ make a /new/ cluster's first member from the archive instead of @initdb@ + } + deriving (Eq, Show) + +data ReplicaMethod + = ReplicaMethod + { rm_name :: Text + , rm_command :: Text + , rm_keep_data :: Bool + -- ^ Patroni leaves the data directory in place for the command (a delta restore reuses it) + , rm_no_params :: Bool + -- ^ Patroni appends no @--scope@, @--datadir@, ... of its own + } + deriving (Eq, Show) + +-- | A custom bootstrap: the command leaves a data directory with its own recovery settings, which Patroni keeps. +data BootstrapMethod + = BootstrapMethod + { bm_name :: Text + , bm_command :: Text + } + deriving (Eq, Show) + +-- | @wal_log_hints@ is restart-only and what @pg_rewind@ needs, so it has to be set before there is data to lose. +defaultBootstrapParameters :: [(Text, Text)] +defaultBootstrapParameters = [("wal_log_hints", "on")] + +pgDataDir, pgConfigDir, pgBinDir :: PatroniConfig -> FilePath +pgDataDir c = "/var/lib/postgresql" Text.unpack c.pat_pg_version Text.unpack c.pat_pg_cluster +pgConfigDir c = "/etc/postgresql" Text.unpack c.pat_pg_version Text.unpack c.pat_pg_cluster +pgBinDir c = "/usr/lib/postgresql" Text.unpack c.pat_pg_version "bin" + +patroniFile :: PatroniConfig -> FilePath +patroniFile c = c.pat_config_dir "patroni.yml" + +-- | Debian's per-cluster unit for the cluster Patroni manages; the one to keep out of the way. +debianClusterUnit :: PatroniConfig -> Text +debianClusterUnit c = "postgresql@" <> c.pat_pg_version <> "-" <> c.pat_pg_cluster <> ".service" + +------------------------------------------------------------------------------- + +-- | A tiny YAML tree: ordered maps, so a render is stable and readable (JSON-quoted scalars are valid YAML). +data Y = YS Text | YI Int | YB Bool | YM [(Text, Y)] | YL [Y] + +renderYaml :: Y -> Text +renderYaml y = Text.unlines (case y of YM kvs -> block 0 kvs; _ -> [scalar y]) + +block :: Int -> [(Text, Y)] -> [Text] +block n = concatMap entry + where + pad = Text.replicate n " " + entry (k, v) = case v of + YM [] -> [pad <> key k <> ": {}"] + YL [] -> [pad <> key k <> ": []"] + YM kvs -> (pad <> key k <> ":") : block (n + 2) kvs + YL xs -> (pad <> key k <> ":") : [pad <> " - " <> scalar x | x <- xs] + _ -> [pad <> key k <> ": " <> scalar v] + key k + | Text.all (\ch -> ch `elem` ("_-" :: String) || isAlphaNum ch) k = k + | otherwise = scalar (YS k) + +scalar :: Y -> Text +scalar (YS t) = Text.decodeUtf8 (LByteString.toStrict (encode t)) +scalar (YI i) = Text.pack (show i) +scalar (YB b) = if b then "true" else "false" +scalar (YM _) = "{}" +scalar (YL _) = "[]" + +-- | @patroni.yml@, without any credential. Nothing in it names a primary. +renderPatroni :: PatroniConfig -> Text +renderPatroni c = + renderYaml . YM $ + [ ("scope", YS c.pat_scope) + , ("namespace", YS c.pat_namespace) + , ("name", YS c.pat_name) + , + ( "restapi" + , YM [("listen", YS c.pat_rest_listen), ("connect_address", YS c.pat_rest_connect_address)] + ) + , ("etcd3", YM etcd) + , + ( "bootstrap" + , YM $ + [ + ( "dcs" + , YM + [ ("ttl", YI 30) + , ("loop_wait", YI 10) + , ("retry_timeout", YI 10) + , ("maximum_lag_on_failover", YI 1048576) + , + ( "postgresql" + , YM + [ ("use_pg_rewind", YB True) + , ("use_slots", YB True) + , ("parameters", YM [(k, YS v) | (k, v) <- c.pat_bootstrap_parameters]) + ] + ) + ] + ) + , ("initdb", YL [YS "data-checksums"]) + ] + <> bootstrapMethod + ) + , + ( "postgresql" + , YM $ + [ ("listen", YS c.pat_pg_listen) + , ("connect_address", YS c.pat_pg_connect_address) + , ("data_dir", YS (Text.pack (pgDataDir c))) + , ("config_dir", YS (Text.pack (pgConfigDir c))) + , ("bin_dir", YS (Text.pack (pgBinDir c))) + , ("use_unix_socket", YB True) + , -- local, not bootstrap: a replica never runs the bootstrap section, and with the + -- configuration outside the data directory nothing else would give it a pg_hba.conf + ("pg_hba", YL (fmap YS c.pat_pg_hba)) + ] + <> maybe [] archive c.pat_archive + ) + ] + where + -- local parameters, not the DCS's: they hold on a cluster bootstrapped + -- before the archive was declared, and archive_mode (restart-only) then + -- shows as pending_restart, which is the cluster config node's to act on + archive :: Archive -> [(Text, Y)] + archive a = + [ ("create_replica_methods", YL (fmap (YS . rm_name) a.arc_methods <> [YS "basebackup" | a.arc_basebackup_fallback])) + ] + <> [ (m.rm_name, YM [("command", YS m.rm_command), ("keep_data", YB m.rm_keep_data), ("no_params", YB m.rm_no_params)]) + | m <- a.arc_methods + ] + <> [ ("recovery_conf", YM [("restore_command", YS a.arc_restore_command)]) + , ("parameters", YM [("archive_mode", YS "on"), ("archive_command", YS a.arc_archive_command)]) + ] + bootstrapMethod = case c.pat_archive >>= arc_bootstrap of + Nothing -> [] + Just b -> + [ ("method", YS b.bm_name) + , + ( b.bm_name + , YM + [ ("command", YS b.bm_command) + , ("keep_existing_recovery_conf", YB True) + , ("no_params", YB True) + ] + ) + ] + etcd = + [("hosts", YS (Text.intercalate "," c.pat_etcd_hosts))] + <> maybe + [] + ( \t -> + [ ("protocol", YS "https") + , ("cacert", YS (Text.pack t.tls_ca)) + , ("cert", YS (Text.pack t.tls_cert)) + , ("key", YS (Text.pack t.tls_key)) + ] + ) + c.pat_etcd_tls + +unitConfig :: PatroniConfig -> Systemd.Config +unitConfig c = + Systemd.Config Systemd.System "/etc/systemd/system" "patroni.service" unit svc install + where + unit = Systemd.Unit "Patroni (from Salmon)" "network-online.target" + svc = + Systemd.Service + Systemd.Simple + c.pat_user + c.pat_user + "0022" + (Systemd.Start c.pat_binary [Text.pack c.pat_config_dir]) + Systemd.OnFailure + -- Process: restarting Patroni must not take Postgres down with it + Systemd.Process + "/var/lib/postgresql" + install = Systemd.Install "multi-user.target" + +------------------------------------------------------------------------------- + +-- | What @GET \/patroni@ says, as far as this module reads it. +data PatroniStatus + = PatroniStatus + { ps_state :: Maybe Text + , ps_role :: Maybe Text + , ps_scope :: Maybe Text + , ps_pending_restart :: Bool + } + deriving (Eq, Show) + +instance FromJSON PatroniStatus where + parseJSON = withObject "patroni status" $ \o -> do + pat <- o .:? "patroni" + scope <- maybe (pure Nothing) (withObject "patroni" (.:? "scope")) pat + PatroniStatus <$> o .:? "state" <*> o .:? "role" <*> pure scope <*> o .:? "pending_restart" .!= False + +parseStatus :: ByteString.ByteString -> Either Text PatroniStatus +parseStatus = either (Left . Text.pack) Right . eitherDecodeStrict + +transitional :: [Text] +transitional = + [ "starting" + , "restarting" + , "stopping" + , "creating replica" + , "initializing new cluster" + , "running custom bootstrap script" + , "starting after custom bootstrap" + ] + +{- | The verdict, pure: the scope this member is declared in, the HTTP status +of @GET \/health@ and the @GET \/patroni@ body. + +Role is never an input to the verdict (@uninitialised@ aside, which says +Patroni has not made this member part of a cluster yet). +-} +interpretMember :: Text -> Int -> ByteString.ByteString -> CheckResult +interpretMember scope health body = case parseStatus body of + Left e -> Failure ("GET /patroni not understood: " <> Text.take 120 e) + Right st + | Just s <- st.ps_scope, s /= scope -> Failure ("member reports scope " <> s <> ", declared " <> scope) + | st.ps_role == Just "uninitialized" -> Unknown + | otherwise -> case st.ps_state of + Nothing -> Failure "GET /patroni carries no state" + Just "running" + | health == 200 -> Success + | otherwise -> Failure ("state is running but GET /health answers " <> Text.pack (show health)) + Just s + | s `elem` transitional -> Unknown + | otherwise -> Failure ("state is " <> s) + +-- | Asks the member's own REST API; an API that does not answer is a failure, and says so. +checkMember :: PatroniConfig -> IO CheckResult +checkMember c = do + r <- try $ do + mgr <- newManager defaultManagerSettings{managerResponseTimeout = responseTimeoutMicro 5000000} + let get path = parseRequest (Text.unpack ("http://" <> c.pat_rest_connect_address <> path)) + -- /health is 503 when Postgres is down, which httpLbs reports as a status, not an exception + hReq <- get "/health" + h <- httpLbs hReq mgr + pReq <- get "/patroni" + p <- httpLbs pReq mgr + pure (statusCode (responseStatus h), LByteString.toStrict (responseBody p)) + pure $ case r of + Left (e :: HttpException) -> Failure ("REST API not answering: " <> Text.take 150 (Text.pack (show e))) + Right (health, body) -> interpretMember c.pat_scope health body + +-- | Thrown when the member does not become healthy in time. +newtype NotRunning = NotRunning Text + +instance Show NotRunning where + show (NotRunning why) = "patroni: member did not become healthy: " <> Text.unpack why + +instance Exception NotRunning + +-- | Polls until the check passes; throws 'NotRunning' with the last reason at the deadline. +waitReady :: PatroniConfig -> IO () +waitReady c = go (max 1 c.pat_ready_timeout_seconds) + where + go :: Int -> IO () + go left = do + v <- checkMember c + case v of + Success -> pure () + Failure why | left <= 1 -> throwIO (NotRunning why) + _ -> do + when (left <= 1) $ throwIO (NotRunning "no verdict") + threadDelay 1000000 + go (left - 1) + +------------------------------------------------------------------------------- + +{- | One Patroni member: the binary, the configuration directory, @patroni.yml@, +the credentials file's ownership, Debian's cluster unit masked, the unit, and +on top a node whose @check@ is 'checkMember'. + +@down@ stops the service (through the unit node) and leaves Postgres' data +directory alone: it is the member's memory, and whether to destroy it is not a +teardown's decision. +-} +patroniMember :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Track' (Binary "patroni") -> + PatroniConfig -> + Op +patroniMember r systemctl patroniBin c = + op "patroni-member" (deps [service]) $ \actions -> + actions + { help = "a Patroni cluster member, answering on its REST API" + , notes = ["role is reported, never judged", "etcd v3 only", "Postgres layout: postgresql-common"] + , ref = mkRef "patroni-member" (c.pat_scope, c.pat_name) + , check = checkMember c + , up = waitReady c + , down = pure () + } + where + service :: Op + service = Systemd.systemdServiceWatching [c.pat_secrets_file] r systemctl (Track $ \_ -> prereqs) (unitConfig c) + + prereqs :: Op + prereqs = + op + "patroni-setup" + (deps [justInstall patroniBin, configFile, secrets, mask, pgConfSeed c]) + id + + configFile = FS.filecontentsInSharedDir (FS.FileContents (patroniFile c) (renderPatroni c)) + + -- the credentials file is somebody else's to write; failing when it is missing is this node's job + secrets = FS.ownedFile (FS.FileOwnership c.pat_secrets_file (Just c.pat_user) Nothing (0o600 :: Posix.FileMode)) + + mask = Systemd.maskedUnit r systemctl Systemd.System (debianClusterUnit c) + +{- | Postgres' configuration directory, the service user's, holding a +@postgresql.conf@ for Patroni to build on. + +With the configuration outside the data directory, Patroni does not create +the file it then renames to @postgresql.base.conf@: a bootstrap dies on the +rename, having already run @initdb@, and a new replica likewise. Debian's own +integration gets the file from @pg_createcluster@, which this builtin does not +run. So an empty one is laid down, once: afterwards the file is Patroni's +(either name counts as present) and is never rewritten here. +-} +pgConfSeed :: PatroniConfig -> Op +pgConfSeed c = + op "patroni-pg-conf-seed" (deps [ownedDir]) $ \actions -> + actions + { help = "a postgresql.conf for Patroni to build on, in " <> Text.pack (pgConfigDir c) + , notes = ["written once, empty; Patroni owns it afterwards"] + , ref = mkRef "patroni-pg-conf-seed" (pgConfigDir c) + , check = do + present <- or <$> traverse (doesFileExist . (pgConfigDir c )) ["postgresql.conf", "postgresql.base.conf"] + pure (if present then Success else Failure "no postgresql.conf for Patroni to build on") + , up = do + ByteString.writeFile seed "" + FS.applyOwnership (FS.FileOwnership seed (Just c.pat_user) Nothing (0o644 :: Posix.FileMode)) + } + where + seed = pgConfigDir c "postgresql.conf" + ownedDir = + FS.ownedFile (FS.FileOwnership (pgConfigDir c) (Just c.pat_user) Nothing (0o755 :: Posix.FileMode)) + `inject` FS.dir (FS.Directory (pgConfigDir c)) diff --git a/src/Salmon/Builtin/Nodes/Patroni/PreferredLeader.hs b/src/Salmon/Builtin/Nodes/Patroni/PreferredLeader.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/Patroni/PreferredLeader.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | An opt-in __preferred leader__ for a Patroni cluster +(@specs\/pg-patroni.md@, "Switchover, under Patroni"). + +__Opt-in, and never the default.__ "Salmon.Builtin.Nodes.Patroni" names no +leader anywhere; this node is the one place a declaration says which member it +/prefers/, and only when an operator declares it. With it declared and +supervision on, salmon moves the leader back after every automatic failover as +soon as the preferred member is eligible again: sometimes wanted (a preferred +site, a bigger machine), sometimes a flap. That is why it is a separate node +nobody gets without asking. + +It does not decide that a machine is dead and it never fails over: a +switchover is a request to Patroni to move a /healthy/ leader to a /healthy/ +candidate, which Patroni itself refuses when it disagrees. With no leader at all +the node waits; electing one is Patroni's business. + +* @check@: @GET \/leader@ on the preferred member's REST API answers 200. When + it does not, the cluster is read (@GET \/cluster@, @GET \/config@) and the + decision ('decide') turns into a 'Failure' (a switchover is due) or 'Unknown' + (the preferred member is not an eligible target yet: nothing is applied and, + under @run serve@, nothing is restarted). +* @up@: re-reads the cluster (the state a pass acts on is re-derived each time, + never remembered), and when the preferred member is eligible sends + @POST \/switchover@ with @leader@ and @candidate@, then waits for + @GET \/leader@ to answer 200. When it is not eligible, @up@ sends nothing and + throws 'SwitchoverSkipped', so the pass reports the preference as unmet and + the next pass tries again with the leader left alone. +* @down@: nothing. Retracting a preference does not move the leader anywhere. + +__Eligibility__ ('eligible', 'switchoverCandidates', after the Zalando +operator's @getSwitchoverCandidate@): with @synchronous_mode@ on (@true@ or +@quorum@ in @\/config@), only a synchronous standby is a target and salmon +__waits for one rather than falling back__ to an asynchronous member, which may +lack acknowledged writes; otherwise a member whose state is @running@, +@streaming@ or @in archive recovery@. A member tagged @nofailover@ is never a +target. 'switchoverCandidate' (the lowest-lag eligible member) is exported for +the operations that pick a target themselves; this node's target is the +declared member, so it only asks whether that member is eligible. + +__Credentials.__ @POST \/switchover@ is an unsafe endpoint, authenticated when +@restapi.authentication@ is set. 'pl_credentials_file' is a pre-provisioned +file holding @user:password@ on one line, read at @up@ time and sent as HTTP +basic auth; it never reaches @help@, @notes@, an error or a log. The REST API +is spoken over plain HTTP, as in "Salmon.Builtin.Nodes.Patroni". +-} +module Salmon.Builtin.Nodes.Patroni.PreferredLeader ( + PreferredLeader (..), + defaultSettleSeconds, + preferredLeader, + + -- * The cluster as @GET \/cluster@ and @GET \/config@ show it + Member (..), + ClusterView (..), + parseCluster, + parseSynchronousMode, + + -- * Pure decisions + Decision (..), + decide, + decisionVerdict, + leaderOf, + leaderRoles, + syncRoles, + healthyStates, + eligible, + switchoverCandidates, + switchoverCandidate, + + -- * The request + switchoverBody, + parseCredentials, + + -- * Errors + SwitchoverSkipped (..), + SwitchoverRefused (..), +) where + +import Control.Concurrent (threadDelay) +import Control.Exception (Exception, throwIO, try) +import Data.Aeson (FromJSON (..), Value (..), eitherDecodeStrict, encode, object, withObject, (.!=), (.:), (.:?), (.=)) +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString.Lazy as LByteString +import Data.List (sortOn) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import Network.HTTP.Client ( + HttpException, + Manager, + RequestBody (..), + applyBasicAuth, + defaultManagerSettings, + httpLbs, + managerResponseTimeout, + method, + newManager, + parseRequest, + requestBody, + requestHeaders, + responseBody, + responseStatus, + responseTimeoutMicro, + ) +import Network.HTTP.Types.Status (statusCode) + +import Salmon.Actions.UpDown (CheckResult (..)) +import Salmon.Builtin.Extension +import Salmon.Op.Ref + +------------------------------------------------------------------------------- + +data PreferredLeader + = PreferredLeader + { pl_scope :: Text + -- ^ the Patroni scope (cluster name) + , pl_member :: Text + -- ^ the member preferred as leader, by its Patroni @name@ + , pl_rest_address :: Text + -- ^ @host:port@ of that member's REST API, where the node asks and requests + , pl_credentials_file :: Maybe FilePath + -- ^ a pre-provisioned @user:password@ file for @restapi.authentication@; 'Nothing' sends no credential + , pl_settle_seconds :: Int + -- ^ how long @up@ waits, after Patroni accepted the switchover, for the member to lead + } + deriving (Eq, Show) + +defaultSettleSeconds :: Int +defaultSettleSeconds = 60 + +{- | The node. Its @ref@ is the scope alone, so two declarations preferring +different members of one cluster collide (and are reported @Conflicting@) +instead of taking turns. The preferred member is in @help@ and @notes@, which is +how a changed preference shows as a changed representative. +-} +preferredLeader :: PreferredLeader -> Op +preferredLeader c = + op "patroni-preferred-leader" nodeps $ \actions -> + actions + { help = "Patroni scope " <> c.pl_scope <> " prefers " <> c.pl_member <> " as leader" + , notes = + [ "opt-in: moves the leader back to " <> c.pl_member <> " after a failover" + , "switchover only to an eligible member; with synchronous_mode, only to a sync standby" + , "down leaves the leader where it is" + ] + , ref = mkRef "patroni-preferred-leader" c.pl_scope + , check = checkPreferred c + , up = switchToPreferred c + , down = pure () + } + +------------------------------------------------------------------------------- + +-- | One entry of @GET \/cluster@'s @members@, as far as this module reads it. +data Member + = Member + { m_name :: Text + , m_role :: Text + , m_state :: Maybe Text + , m_lag :: Maybe Integer + -- ^ bytes behind the leader; 'Nothing' when Patroni says @unknown@ or nothing + , m_nofailover :: Bool + } + deriving (Eq, Show) + +instance FromJSON Member where + parseJSON = withObject "member" $ \o -> do + tags <- o .:? "tags" .!= Aeson.emptyObject + nofailover <- withObject "tags" (\t -> t .:? "nofailover" .!= False) tags + Member + <$> o .: "name" + <*> o .: "role" + <*> o .:? "state" + <*> (lag <$> o .:? "lag") + <*> pure nofailover + where + lag :: Maybe Value -> Maybe Integer + lag (Just v@(Number _)) = Aeson.parseMaybe parseJSON v + lag _ = Nothing + +data ClusterView + = ClusterView + { cv_scope :: Maybe Text + , cv_members :: [Member] + , cv_synchronous :: Bool + -- ^ from @GET \/config@, not @\/cluster@: with no sync standby, @\/cluster@ alone cannot tell + } + deriving (Eq, Show) + +-- | @GET \/cluster@'s body; 'cv_synchronous' is left 'False' for 'parseSynchronousMode' to set. +parseCluster :: ByteString.ByteString -> Either Text ClusterView +parseCluster bs = case eitherDecodeStrict bs of + Left e -> Left (Text.pack e) + Right v -> either (Left . Text.pack) Right (Aeson.parseEither p v) + where + p = withObject "cluster" $ \o -> + ClusterView <$> o .:? "scope" <*> o .:? "members" .!= [] <*> pure False + +{- | @GET \/config@'s @synchronous_mode@: @true@, or a string Patroni accepts as +on (@quorum@ included). Absent is off. Anything not understood is an error, +not \"off\": guessing asynchronous where it is synchronous is the unsafe way. +-} +parseSynchronousMode :: ByteString.ByteString -> Either Text Bool +parseSynchronousMode bs = case eitherDecodeStrict bs of + Left e -> Left (Text.pack e) + Right v -> either (Left . Text.pack) Right (Aeson.parseEither p v) + where + p = withObject "config" $ \o -> do + m <- o .:? "synchronous_mode" + case m of + Nothing -> pure False + Just Null -> pure False + Just (Bool b) -> pure b + Just (String s) + | Text.toLower s `elem` ["on", "true", "yes", "quorum"] -> pure True + | Text.toLower s `elem` ["off", "false", "no"] -> pure False + Just other -> fail ("synchronous_mode not understood: " <> take 40 (show other)) + +------------------------------------------------------------------------------- + +leaderRoles, syncRoles, healthyStates :: [Text] +leaderRoles = ["leader", "master", "primary"] +syncRoles = ["sync_standby", "quorum_standby"] +healthyStates = ["running", "streaming", "in archive recovery"] + +leaderOf :: ClusterView -> Maybe Member +leaderOf cv = listToMaybe [m | m <- cv.cv_members, m.m_role `elem` leaderRoles] + +-- | Can this member be a switchover's target, in this cluster? Never the leader. +eligible :: ClusterView -> Member -> Bool +eligible cv m = + m.m_role `notElem` leaderRoles + && not m.m_nofailover + && maybe False (`elem` healthyStates) m.m_state + && (not cv.cv_synchronous || m.m_role `elem` syncRoles) + +-- | The eligible members, lowest lag first (an unknown lag last). +switchoverCandidates :: ClusterView -> [Member] +switchoverCandidates cv = sortOn key (filter (eligible cv) cv.cv_members) + where + key :: Member -> (Int, Integer, Text) + key m = (maybe 1 (const 0) m.m_lag, fromMaybe 0 m.m_lag, m.m_name) + +-- | The operator's choice when nobody declared one: the lowest-lag eligible member. +switchoverCandidate :: ClusterView -> Maybe Member +switchoverCandidate = listToMaybe . switchoverCandidates + +data Decision + = -- | the preferred member leads + AlreadyLeads + | -- | ask Patroni to move the leader from the first name to the second + SwitchOver Text Text + | -- | leave the leader alone this pass, and why + Wait Text + deriving (Eq, Show) + +-- | Given the declared scope and preferred member, what this pass should do. +decide :: Text -> Text -> ClusterView -> Decision +decide scope preferred cv + | Just s <- cv.cv_scope, s /= scope = Wait ("cluster reports scope " <> s <> ", declared " <> scope) + | otherwise = case leaderOf cv of + Nothing -> Wait "no leader: electing one is Patroni's, not a switchover" + Just l + | l.m_name == preferred -> AlreadyLeads + | otherwise -> case [m | m <- cv.cv_members, m.m_name == preferred] of + [] -> Wait (preferred <> " is not a member of the cluster") + (m : _) + | eligible cv m -> SwitchOver l.m_name preferred + | m.m_nofailover -> Wait (preferred <> " is tagged nofailover") + | cv.cv_synchronous && m.m_role `notElem` syncRoles -> + Wait (preferred <> " is not a synchronous standby (role " <> m.m_role <> "); waiting rather than falling back") + | otherwise -> Wait (preferred <> " is not eligible (state " <> fromMaybe "unknown" m.m_state <> ")") + +-- | The decision as a check's answer. +decisionVerdict :: Decision -> CheckResult +decisionVerdict AlreadyLeads = Success +decisionVerdict (SwitchOver from to) = Failure ("leader is " <> from <> ", " <> to <> " is preferred and eligible") +decisionVerdict (Wait _) = Unknown + +------------------------------------------------------------------------------- + +-- | The @POST \/switchover@ body. +switchoverBody :: Text -> Text -> LByteString.ByteString +switchoverBody from to = encode (object ["leader" .= from, "candidate" .= to]) + +{- | @user:password@ on the first line, split on the first colon. The error +never quotes the file: it may hold the password. +-} +parseCredentials :: ByteString.ByteString -> Either Text (ByteString.ByteString, ByteString.ByteString) +parseCredentials bs = + let line = Char8.takeWhile (\ch -> ch /= '\n' && ch /= '\r') bs + (user, rest) = Char8.break (== ':') line + in if ByteString.null user || ByteString.null rest + then Left "credentials file is not user:password on its first line" + else Right (user, ByteString.drop 1 rest) + +------------------------------------------------------------------------------- + +-- | Thrown by @up@ when the preferred member is not a target this pass; nothing was sent. +newtype SwitchoverSkipped = SwitchoverSkipped Text + +instance Show SwitchoverSkipped where + show (SwitchoverSkipped why) = "patroni: switchover skipped, leader left alone: " <> Text.unpack why + +instance Exception SwitchoverSkipped + +-- | Thrown by @up@ when Patroni refused, or the member did not take over in time. +newtype SwitchoverRefused = SwitchoverRefused Text + +instance Show SwitchoverRefused where + show (SwitchoverRefused why) = "patroni: switchover not done: " <> Text.unpack why + +instance Exception SwitchoverRefused + +newManager' :: IO Manager +newManager' = newManager defaultManagerSettings{managerResponseTimeout = responseTimeoutMicro 10000000} + +url :: PreferredLeader -> Text -> String +url c path = Text.unpack ("http://" <> c.pl_rest_address <> path) + +getStatus :: Manager -> PreferredLeader -> Text -> IO (Int, ByteString.ByteString) +getStatus mgr c path = do + req <- parseRequest (url c path) + rsp <- httpLbs req mgr + pure (statusCode (responseStatus rsp), LByteString.toStrict (responseBody rsp)) + +-- | @\/cluster@ then @\/config@; 'Left' says why the cluster could not be read. +readCluster :: Manager -> PreferredLeader -> IO (Either Text ClusterView) +readCluster mgr c = do + r <- try $ do + (cs, cb) <- getStatus mgr c "/cluster" + (fs, fb) <- getStatus mgr c "/config" + pure (cs, cb, fs, fb) + pure $ case r of + Left (e :: HttpException) -> Left ("REST API not answering: " <> Text.take 150 (Text.pack (show e))) + Right (cs, cb, fs, fb) + | cs /= 200 -> Left ("GET /cluster answers " <> Text.pack (show cs)) + | fs /= 200 -> Left ("GET /config answers " <> Text.pack (show fs)) + | otherwise -> do + cv <- either (Left . ("GET /cluster not understood: " <>) . Text.take 120) Right (parseCluster cb) + sync <- either (Left . ("GET /config not understood: " <>) . Text.take 120) Right (parseSynchronousMode fb) + pure cv{cv_synchronous = sync} + +leads :: Manager -> PreferredLeader -> IO (Either Text Bool) +leads mgr c = do + r <- try (getStatus mgr c "/leader") + pure $ case r of + Left (e :: HttpException) -> Left ("REST API not answering: " <> Text.take 150 (Text.pack (show e))) + Right (s, _) -> Right (s == 200) + +checkPreferred :: PreferredLeader -> IO CheckResult +checkPreferred c = do + mgr <- newManager' + l <- leads mgr c + case l of + Left why -> pure (Failure why) + Right True -> pure Success + Right False -> either Failure (decisionVerdict . decide c.pl_scope c.pl_member) <$> readCluster mgr c + +switchToPreferred :: PreferredLeader -> IO () +switchToPreferred c = do + mgr <- newManager' + cv <- readCluster mgr c >>= either (throwIO . SwitchoverSkipped) pure + case decide c.pl_scope c.pl_member cv of + AlreadyLeads -> pure () + Wait why -> throwIO (SwitchoverSkipped why) + SwitchOver from to -> do + auth <- case c.pl_credentials_file of + Nothing -> pure id + Just path -> do + bs <- ByteString.readFile path + either (throwIO . SwitchoverRefused) (pure . uncurry applyBasicAuth) (parseCredentials bs) + req0 <- parseRequest (url c "/switchover") + let req = + auth + req0 + { method = "POST" + , requestHeaders = [("Content-Type", "application/json")] + , requestBody = RequestBodyLBS (switchoverBody from to) + } + r <- try (httpLbs req mgr) + case r of + Left (e :: HttpException) -> throwIO (SwitchoverRefused ("REST API not answering: " <> Text.take 150 (Text.pack (show e)))) + Right rsp -> do + let s = statusCode (responseStatus rsp) + -- Patroni's answer is its own message (no credential is echoed) + if s >= 200 && s < 300 + then settle mgr (max 1 c.pl_settle_seconds) + else throwIO (SwitchoverRefused ("POST /switchover answers " <> Text.pack (show s) <> ": " <> Text.take 200 (lenientUtf8 (LByteString.toStrict (responseBody rsp))))) + where + settle :: Manager -> Int -> IO () + settle mgr left = do + l <- leads mgr c + case l of + Right True -> pure () + _ + | left <= 1 -> throwIO (SwitchoverRefused (c.pl_member <> " accepted but does not lead yet")) + | otherwise -> threadDelay 1000000 >> settle mgr (left - 1) + + lenientUtf8 = Text.pack . Char8.unpack diff --git a/src/Salmon/Builtin/Nodes/Patroni/RollingMaintenance.hs b/src/Salmon/Builtin/Nodes/Patroni/RollingMaintenance.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/Patroni/RollingMaintenance.hs @@ -0,0 +1,443 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | __Rolling maintenance__ of a Patroni cluster's members +(@specs\/pg-patroni.md@, "Rolling maintenance of members"): restart every +member that needs it (a @pending_restart@, or a running server older than the +declared version after a package update), in the order that is the safety: + +1. the replicas, one at a time, each waited for until it is healthy again; +2. a switchover of the leader to a safe candidate; +3. the old leader, which is a replica by then, so step 1 again. + +It is two nodes, so that the owner's decision (2026-09-26: replicas first, the +leader behind a maintenance window) is an ordinary edge and an ordinary gate: + +* @patroni-rolling-replicas@ does step 1 only. Not 'Window.disruptive': a + replica restart is not an outage. +* @patroni-rolling-leader@ depends on it and does all three steps; it is + marked 'Window.disruptive', so with @--maintenance-window@ the switchover and + the old leader's restart wait for the window, the replicas do not. + +Neither node names a leader: which member leads is read from @GET \/cluster@ +on every turn, never declared and never remembered. __Nothing decides a +machine is dead__: a member that does not answer, is not healthy, or is +declared but missing from @\/cluster@ holds everything ('Hold'), it is not +skipped. With no safe candidate the leader is left alone (the Zalando +operator's @recreatePods@ does the same); the candidate policy is +"Salmon.Builtin.Nodes.Patroni.PreferredLeader"'s ('switchoverCandidates'): the +synchronous standby under @synchronous_mode@, waited for rather than fallen +back from, else the lowest-lag healthy member, never a @nofailover@ one. + +__One step per observation.__ 'step' is pure over what @\/cluster@, +@\/config@ and each member's @\/patroni@ say now. @up@ observes, takes the +step, and observes again, until 'Finished'. Nothing is written down between +steps, so a controller killed halfway is finished by the next pass from +whatever the cluster then shows (the property @PostgresPair@ protects). + +* @check@: 'Finished' is 'Success'; a due restart or switchover is 'Failure'; + 'Hold' (a member transitioning or unreachable, no leader, no candidate) and + an unreadable cluster are 'Unknown', so under @run serve@ nothing restarts + on it. +* @up@: a 'Hold' before anything was done this pass throws + 'MaintenanceHeld' with nothing sent. After a restart or a switchover, a + 'Hold' or the same step again is the cluster settling, and is re-observed + each second for 'rm_settle_seconds' before @up@ gives up + ('MaintenanceStuck'). +* @down@: nothing. + +__Requests.__ A restart is @POST \/restart {\"role\": \"replica\"}@ on that +member's REST API: Patroni itself refuses it if the member leads by then, so +a leader is never restarted in place, whatever this module believes. A +switchover is @POST \/switchover {leader, candidate}@ on the leader's API. +Both are unsafe endpoints; 'rm_credentials_file' is the same pre-provisioned +@user:password@ file as the preferred-leader node's, read at @up@ time and +never shown. + +__The two signals.__ @pending_restart@ and @server_version@, both from the +member's own @GET \/patroni@. @server_version@ is the /running/ server, so +after the package is upgraded on disk the member reports the old number until +it is restarted, which is what 'rm_server_version' compares against. A Patroni +package upgrade is not seen: restarting Postgres does not restart Patroni. +-} +module Salmon.Builtin.Nodes.Patroni.RollingMaintenance ( + RollingMaintenance (..), + defaultSettleSeconds, + rollingMaintenance, + rollingReplicas, + + -- * What is observed + MemberStatus (..), + parseMemberStatus, + Observation (..), + stale, + + -- * Pure decision + Phase (..), + Step (..), + step, + stepVerdict, + + -- * Requests + restartBody, + + -- * Errors + MaintenanceHeld (..), + MaintenanceStuck (..), +) where + +import Control.Concurrent (threadDelay) +import Control.Exception (Exception, throwIO, try) +import Data.Aeson (eitherDecodeStrict, encode, object, withObject, (.!=), (.:?), (.=)) +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString.Lazy as LByteString +import Data.List (sort) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import Network.HTTP.Client ( + HttpException, + Manager, + Request, + RequestBody (..), + applyBasicAuth, + defaultManagerSettings, + httpLbs, + managerResponseTimeout, + method, + newManager, + parseRequest, + requestBody, + requestHeaders, + responseBody, + responseStatus, + responseTimeoutMicro, + ) +import Network.HTTP.Types.Status (statusCode) + +import Salmon.Actions.UpDown (CheckResult (..)) +import Salmon.Builtin.Extension +import Salmon.Builtin.Nodes.Patroni.PreferredLeader ( + ClusterView (..), + Member (..), + healthyStates, + leaderOf, + parseCluster, + parseCredentials, + parseSynchronousMode, + switchoverBody, + switchoverCandidates, + ) +import Salmon.Op.Ref +import qualified Salmon.Op.Window as Window + +------------------------------------------------------------------------------- + +data RollingMaintenance + = RollingMaintenance + { rm_scope :: Text + -- ^ the Patroni scope (cluster name) + , rm_members :: [(Text, Text)] + -- ^ every member, by its Patroni @name@, with the @host:port@ of its REST API + , rm_server_version :: Maybe Int + -- ^ a member whose running @server_version@ (e.g. @170006@) is below this needs a restart; 'Nothing' looks at @pending_restart@ alone + , rm_credentials_file :: Maybe FilePath + -- ^ a pre-provisioned @user:password@ file for @restapi.authentication@; 'Nothing' sends no credential + , rm_settle_seconds :: Int + -- ^ how long @up@ waits, after each restart or switchover, for the cluster to settle + } + deriving (Eq, Show) + +-- | Long enough for a replica restart and catch-up on a small cluster. +defaultSettleSeconds :: Int +defaultSettleSeconds = 120 + +{- | Both nodes: @patroni-rolling-leader@ (disruptive) depending on +@patroni-rolling-replicas@. The @ref@s are the scope alone; the members, their +addresses and the target version are in @notes@, so a changed declaration is a +changed representative. +-} +rollingMaintenance :: RollingMaintenance -> Op +rollingMaintenance c = + op "patroni-rolling-leader" (deps [rollingReplicas c]) $ \actions -> + Window.disruptive + actions + { help = "Patroni scope " <> c.rm_scope <> ": switch the leader over to a safe candidate and restart it, after the replicas" + , notes = + phaseNotes c + <> [ "leader left alone when no candidate is safe; with synchronous_mode, only a sync standby" + , "disruptive: held outside the maintenance windows" + ] + , ref = mkRef "patroni-rolling-leader" c.rm_scope + , check = checkPhase AllMembers c + , up = runPhase AllMembers c + , down = pure () + } + +-- | Step 1 alone: the replicas, one at a time. 'rollingMaintenance' depends on it. +rollingReplicas :: RollingMaintenance -> Op +rollingReplicas c = + op "patroni-rolling-replicas" nodeps $ \actions -> + actions + { help = "Patroni scope " <> c.rm_scope <> ": restart the replicas that need it, one at a time" + , notes = phaseNotes c <> ["never restarts the member that leads"] + , ref = mkRef "patroni-rolling-replicas" c.rm_scope + , check = checkPhase ReplicasOnly c + , up = runPhase ReplicasOnly c + , down = pure () + } + +phaseNotes :: RollingMaintenance -> [Text] +phaseNotes c = + [ "members: " <> Text.intercalate ", " [n <> " at " <> a | (n, a) <- c.rm_members] + , "needs a restart: pending_restart" <> maybe "" (\v -> ", or server_version below " <> Text.pack (show v)) c.rm_server_version + ] + +------------------------------------------------------------------------------- + +-- | A member's own @GET \/patroni@, as far as this module reads it. +data MemberStatus + = MemberStatus + { ms_name :: Maybe Text + -- ^ @patroni.name@: who answers at the declared address + , ms_scope :: Maybe Text + , ms_server_version :: Maybe Int + , ms_pending_restart :: Bool + } + deriving (Eq, Show) + +parseMemberStatus :: ByteString.ByteString -> Either Text MemberStatus +parseMemberStatus bs = case eitherDecodeStrict bs of + Left e -> Left (Text.pack e) + Right v -> either (Left . Text.pack) Right (Aeson.parseEither p v) + where + p = withObject "patroni" $ \o -> do + pat <- o .:? "patroni" .!= Aeson.emptyObject + (name, scope) <- withObject "patroni.patroni" (\q -> (,) <$> q .:? "name" <*> q .:? "scope") pat + MemberStatus name scope <$> o .:? "server_version" <*> o .:? "pending_restart" .!= False + +-- | Everything one turn decides on. +data Observation + = Observation + { ob_cluster :: ClusterView + , ob_members :: [(Text, Either Text MemberStatus)] + -- ^ each declared member's @\/patroni@, or why it could not be read + } + deriving (Eq, Show) + +-- | Does this member need a restart? 'Left' when it cannot be told. +stale :: Maybe Int -> MemberStatus -> Either Text Bool +stale target s + | s.ms_pending_restart = Right True + | otherwise = case target of + Nothing -> Right False + Just t -> maybe (Left "server_version not reported") (Right . (< t)) s.ms_server_version + +data Phase + = -- | the replicas only + ReplicasOnly + | -- | replicas, then the leader by a switchover + AllMembers + deriving (Eq, Show) + +data Step + = -- | @POST \/restart@ on this member, which is a replica + Restart Text + | -- | ask Patroni to move the leader from the first name to the second + SwitchOverTo Text Text + | -- | nothing left to do + Finished + | -- | do nothing this turn, and why + Hold Text + deriving (Eq, Show) + +{- | The next step, given the declared scope, the target version and what is +observed now. In order: anything unsure holds; then the stale replicas by +name; then (for 'AllMembers') a stale leader is switched away from, or held +when no candidate is safe. +-} +step :: Phase -> Text -> Maybe Int -> Observation -> Step +step phase scope target ob + | Just s <- cv.cv_scope, s /= scope = Hold ("cluster reports scope " <> s <> ", declared " <> scope) + | (why : _) <- unsure = Hold why + | otherwise = case leaderOf cv of + Nothing -> Hold "no leader: electing one is Patroni's" + Just l -> case sort [m.m_name | m <- cv.cv_members, m.m_name /= l.m_name, isStale m] of + (r : _) -> Restart r + [] + | phase == ReplicasOnly -> Finished + | not (isStale l) -> Finished + | otherwise -> case filter (not . isStale) (switchoverCandidates cv) of + (cand : _) -> SwitchOverTo l.m_name cand.m_name + [] + | cv.cv_synchronous -> Hold ("leader " <> l.m_name <> " needs a restart and no synchronous standby is eligible; waiting rather than falling back, leader left alone") + | otherwise -> Hold ("leader " <> l.m_name <> " needs a restart and no member is a safe candidate; leader left alone") + where + cv = ob.ob_cluster + statusOf n = lookup n ob.ob_members + isStale :: Member -> Bool + isStale m = case statusOf m.m_name of + Just (Right s) -> stale target s == Right True + _ -> False + unsure = + concatMap memberDoubt cv.cv_members + <> [n <> " is declared but not a member of the cluster" | (n, _) <- ob.ob_members, n `notElem` fmap (.m_name) cv.cv_members] + <> [m.m_name <> " is " <> m.m_role <> ": a standby cluster is not handled" | m <- cv.cv_members, m.m_role == "standby_leader"] + memberDoubt :: Member -> [Text] + memberDoubt m = case statusOf m.m_name of + Nothing -> [m.m_name <> " has no declared REST address"] + Just (Left why) -> [m.m_name <> ": " <> why] + Just (Right s) + | Just n <- s.ms_name, n /= m.m_name -> [m.m_name <> "'s address answers as " <> n] + | Just sc <- s.ms_scope, sc /= scope -> [m.m_name <> " reports scope " <> sc] + | Left why <- stale target s -> [m.m_name <> ": " <> why] + | maybe True (`notElem` healthyStates) m.m_state -> + [m.m_name <> " is " <> fromMaybe "in no reported state" m.m_state <> "; waiting for it"] + | otherwise -> [] + +-- | The step as a check's answer. +stepVerdict :: Step -> CheckResult +stepVerdict Finished = Success +stepVerdict (Restart m) = Failure (m <> " needs a restart") +stepVerdict (SwitchOverTo from to) = Failure ("leader " <> from <> " needs a restart; switch over to " <> to <> " first") +stepVerdict (Hold _) = Unknown + +-- | The @POST \/restart@ body: Patroni restarts only if the member is a replica. +restartBody :: LByteString.ByteString +restartBody = encode (object ["role" .= ("replica" :: Text)]) + +------------------------------------------------------------------------------- + +-- | Thrown by @up@ when the first step of a pass is a 'Hold'; nothing was sent. +newtype MaintenanceHeld = MaintenanceHeld Text + +instance Show MaintenanceHeld where + show (MaintenanceHeld why) = "patroni: rolling maintenance held, nothing restarted: " <> Text.unpack why + +instance Exception MaintenanceHeld + +-- | Thrown by @up@ when Patroni refused a request, or the cluster did not settle after one. +newtype MaintenanceStuck = MaintenanceStuck Text + +instance Show MaintenanceStuck where + show (MaintenanceStuck why) = "patroni: rolling maintenance stopped: " <> Text.unpack why + +instance Exception MaintenanceStuck + +newManager' :: IO Manager +newManager' = newManager defaultManagerSettings{managerResponseTimeout = responseTimeoutMicro 30000000} + +getStatus :: Manager -> Text -> Text -> IO (Int, ByteString.ByteString) +getStatus mgr addr path = do + req <- parseRequest (Text.unpack ("http://" <> addr <> path)) + rsp <- httpLbs req mgr + pure (statusCode (responseStatus rsp), LByteString.toStrict (responseBody rsp)) + +httpError :: HttpException -> Text +httpError e = "REST API not answering: " <> Text.take 150 (Text.pack (show e)) + +-- | @\/cluster@ and @\/config@ from the first declared member that answers both, and every member's @\/patroni@. +observe :: Manager -> RollingMaintenance -> IO (Either Text Observation) +observe mgr c = do + cv <- firstCluster c.rm_members [] + statuses <- traverse (\(n, a) -> (,) n <$> memberStatus a) c.rm_members + pure (fmap (\v -> Observation v statuses) cv) + where + firstCluster [] errs = pure (Left ("cluster not readable from any member: " <> Text.intercalate "; " (reverse errs))) + firstCluster ((n, a) : rest) errs = do + r <- clusterAt a + case r of + Right v -> pure (Right v) + Left why -> firstCluster rest ((n <> ": " <> why) : errs) + clusterAt a = do + r <- try ((,) <$> getStatus mgr a "/cluster" <*> getStatus mgr a "/config") + pure $ case r of + Left e -> Left (httpError e) + Right ((cs, cb), (fs, fb)) + | cs /= 200 -> Left ("GET /cluster answers " <> Text.pack (show cs)) + | fs /= 200 -> Left ("GET /config answers " <> Text.pack (show fs)) + | otherwise -> do + v <- either (Left . ("GET /cluster not understood: " <>) . Text.take 120) Right (parseCluster cb) + sync <- either (Left . ("GET /config not understood: " <>) . Text.take 120) Right (parseSynchronousMode fb) + pure v{cv_synchronous = sync} + memberStatus a = do + r <- try (getStatus mgr a "/patroni") + pure $ case r of + Left e -> Left (httpError e) + Right (s, b) + -- 503 is a member that is not running: its body still says why, but that is a Hold either way + | s /= 200 -> Left ("GET /patroni answers " <> Text.pack (show s)) + | otherwise -> either (Left . ("GET /patroni not understood: " <>) . Text.take 120) Right (parseMemberStatus b) + +checkPhase :: Phase -> RollingMaintenance -> IO CheckResult +checkPhase phase c = do + mgr <- newManager' + either (const Unknown) (stepVerdict . step phase c.rm_scope c.rm_server_version) <$> observe mgr c + +runPhase :: Phase -> RollingMaintenance -> IO () +runPhase phase c = do + mgr <- newManager' + loop mgr Nothing + where + -- @lastDone@: the step taken last this pass and the seconds left for the cluster to settle after it + loop :: Manager -> Maybe (Step, Int) -> IO () + loop mgr lastDone = do + ob <- observe mgr c + let s = either Hold (step phase c.rm_scope c.rm_server_version) ob + case (s, lastDone) of + (Finished, _) -> pure () + (Hold why, Nothing) -> throwIO (MaintenanceHeld why) + (_, Just (prev, left)) + | isHold s || s == prev -> + if left <= 0 + then throwIO (MaintenanceStuck ("after " <> describe prev <> ", the cluster did not settle: " <> describe s)) + else threadDelay 1000000 >> loop mgr (Just (prev, left - 1)) + _ -> do + act mgr s + loop mgr (Just (s, max 1 c.rm_settle_seconds)) + + isHold (Hold _) = True + isHold _ = False + + describe (Restart m) = "restarting " <> m + describe (SwitchOverTo from to) = "a switchover from " <> from <> " to " <> to + describe Finished = "finished" + describe (Hold why) = why + + act mgr (Restart m) = case lookup m c.rm_members of + Nothing -> throwIO (MaintenanceStuck (m <> " has no declared REST address")) + Just a -> post mgr a "/restart" restartBody + act mgr (SwitchOverTo from to) = case lookup from c.rm_members of + Nothing -> throwIO (MaintenanceStuck (from <> " has no declared REST address")) + Just a -> post mgr a "/switchover" (switchoverBody from to) + act _ _ = pure () + + post :: Manager -> Text -> Text -> LByteString.ByteString -> IO () + post mgr addr path body = do + auth <- credentials + req0 <- parseRequest (Text.unpack ("http://" <> addr <> path)) + let req = + auth + req0 + { method = "POST" + , requestHeaders = [("Content-Type", "application/json")] + , requestBody = RequestBodyLBS body + } + r <- try (httpLbs req mgr) + case r of + Left e -> throwIO (MaintenanceStuck ("POST " <> path <> ": " <> httpError e)) + Right rsp -> do + let s = statusCode (responseStatus rsp) + -- Patroni's answer is its own message (no credential is echoed) + if s >= 200 && s < 300 + then pure () + else throwIO (MaintenanceStuck ("POST " <> path <> " on " <> addr <> " answers " <> Text.pack (show s) <> ": " <> Text.take 200 (Text.pack (Char8.unpack (LByteString.toStrict (responseBody rsp)))))) + + credentials :: IO (Request -> Request) + credentials = case c.rm_credentials_file of + Nothing -> pure id + Just path -> do + bs <- ByteString.readFile path + either (throwIO . MaintenanceStuck) (pure . uncurry applyBasicAuth) (parseCredentials bs) + diff --git a/src/Salmon/Builtin/Nodes/PgBackRest.hs b/src/Salmon/Builtin/Nodes/PgBackRest.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/PgBackRest.hs @@ -0,0 +1,460 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | pgBackRest: a continuous WAL archive plus base backups of one Postgres +cluster, which is what point-in-time recovery needs and what +"SreBox.PostgresBackup" (@pg_dump@) cannot give (@specs\/pg-patroni.md@, +"Nodes that must run on exactly one member"). + +It earns its place twice: as the disaster recovery story ('restoredCluster', +'restoreArgs'), and as Patroni's @create_replica_methods@ ('patroniArchive'), +which builds a replica out of the archive instead of loading the leader with a +base backup. + +__The repository is shared or it is useless.__ A replica can only be built +from an archive it can read, and a restore after the machine is lost can only +read an archive that was somewhere else. A 'PosixRepo' is therefore a mount +every member sees (NFS, or one machine in a test), and 'S3Repo' is the usual +answer. + +__Credentials are not rendered.__ @pgbackrest.conf@ is written here, as a +'Text' (so its fingerprint reaches @notes@). Bucket keys and the repository +cipher passphrase live in a pre-provisioned @*.conf@ fragment +('pbr_secrets_file') that this module only /owns/ (@chown@, mode @0600@) and +never writes; pgBackRest loads every @*.conf@ of that file's directory +(@--config-include-path@). Every command this module renders names both the +configuration file and that directory explicitly, so nothing depends on +pgBackRest's defaults and nothing else on the machine is read by accident. + +__What runs where.__ @stanza-create@ and @backup@ need the /primary/: with one +@pg1-path@ configured, pgBackRest refuses both on a standby. Under Patroni the +primary is not known when the directive is written, so 'stanza' and +'firstBackup' answer from the repository (@info@, readable from any member) +and their @up@ only succeeds on the member that leads at that moment; on the +others it fails until the leader has done it, after which their checks pass. +Nothing here names a primary. 'backupScript' gates itself on Patroni's REST +API for the same reason. + +__The restore is guarded by pgBackRest itself.__ 'restoredCluster' never passes +@--delta@ or @--force@, so a data directory that holds anything is refused by +the tool, and its check leaves a directory that already holds a cluster alone. +The only command here that overwrites a data directory is +'replicaCreateCommand', and that one is handed to Patroni, which owns the +directory and decides when a member is to be rebuilt. +-} +module Salmon.Builtin.Nodes.PgBackRest where + +import Data.Aeson (FromJSON (..), eitherDecodeStrict, withObject, (.!=), (.:), (.:?)) +import qualified Data.ByteString as ByteString +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import System.Directory (doesFileExist) +import System.Exit (ExitCode (..)) +import System.FilePath (takeDirectory, ()) +import qualified System.Posix.Types as Posix +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 (..), Report, justInstall, withBinary) +import qualified Salmon.Builtin.Nodes.CronTask as Cron +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Patroni as Patroni +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- + +-- | Where the archive lives. Keys and passphrases are never part of it. +data Repo + = -- | a directory every member can read and write + PosixRepo FilePath + | S3Repo + { s3_bucket :: Text + , s3_endpoint :: Text + , s3_region :: Text + , s3_path :: FilePath + -- ^ the prefix inside the bucket, e.g. @\/pgbackrest@ + , s3_path_style :: Bool + -- ^ @repo1-s3-uri-style=path@, which most non-AWS stores need + } + deriving (Eq, Show) + +data PgBackRestConfig + = PgBackRestConfig + { pbr_stanza :: Text + -- ^ the archive's name for this cluster; under Patroni, the scope + , pbr_pg_path :: FilePath + -- ^ the data directory + , pbr_pg_port :: Int + , pbr_repo :: Repo + , pbr_retention_full :: Int + -- ^ how many full backups to keep; WAL older than the oldest kept one expires with it + , pbr_global :: [(Text, Text)] + -- ^ further @[global]@ options, verbatim (@compress-type@, @process-max@, ...) + , pbr_stanza_options :: [(Text, Text)] + -- ^ further stanza options, verbatim (@pg1-socket-path@, ...) + , pbr_config_file :: FilePath + -- ^ e.g. @\/etc\/pgbackrest\/pgbackrest.conf@ + , pbr_secrets_file :: Maybe FilePath + -- ^ the pre-provisioned fragment; every @*.conf@ beside it is loaded too + , pbr_log_path :: FilePath + , pbr_user :: Text + -- ^ the system user that owns the cluster, normally @postgres@ + , pbr_run_as :: Maybe Text + -- ^ @sudo -u@ this user for the commands the nodes run; 'Nothing' when salmon already is that user + , pbr_binary :: FilePath + -- ^ as Postgres and Patroni will call it, e.g. @\/usr\/bin\/pgbackrest@ + } + deriving (Eq, Show) + +-- | The directory @--config-include-path@ names, when a secrets fragment is declared. +includeDir :: PgBackRestConfig -> Maybe FilePath +includeDir c = takeDirectory <$> c.pbr_secrets_file + +-- | @pgbackrest.conf@, without any credential. +renderConf :: PgBackRestConfig -> Text +renderConf c = + Text.unlines $ + ["[global]"] + <> fmap kv (repo <> [("repo1-retention-full", tshow c.pbr_retention_full), ("log-path", Text.pack c.pbr_log_path)] <> c.pbr_global) + <> ["", "[" <> c.pbr_stanza <> "]"] + <> fmap kv ([("pg1-path", Text.pack c.pbr_pg_path), ("pg1-port", tshow c.pbr_pg_port)] <> c.pbr_stanza_options) + where + kv (k, v) = k <> "=" <> v + repo = case c.pbr_repo of + PosixRepo path -> [("repo1-type", "posix"), ("repo1-path", Text.pack path)] + S3Repo bucket endpoint region path pathStyle -> + [ ("repo1-type", "s3") + , ("repo1-path", Text.pack path) + , ("repo1-s3-bucket", bucket) + , ("repo1-s3-endpoint", endpoint) + , ("repo1-s3-region", region) + ] + <> [("repo1-s3-uri-style", "path") | pathStyle] + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show + +------------------------------------------------------------------------------- +-- Commands, pure: the same words whether a node runs them, Postgres does +-- (archive_command), Patroni does (create_replica_methods) or an operator does. + +-- | The options every invocation carries: which configuration, which stanza. +commonArgs :: PgBackRestConfig -> [Text] +commonArgs c = + ["--config=" <> Text.pack c.pbr_config_file] + <> maybe [] (\d -> ["--config-include-path=" <> Text.pack d]) (includeDir c) + <> ["--stanza=" <> c.pbr_stanza] + +data BackupType = Full | Differential | Incremental + deriving (Eq, Show) + +backupTypeName :: BackupType -> Text +backupTypeName Full = "full" +backupTypeName Differential = "diff" +backupTypeName Incremental = "incr" + +stanzaCreateArgs, infoArgs :: PgBackRestConfig -> [Text] +stanzaCreateArgs c = commonArgs c <> ["stanza-create"] +infoArgs c = commonArgs c <> ["--output=json", "info"] + +backupArgs :: PgBackRestConfig -> BackupType -> [Text] +backupArgs c ty = commonArgs c <> ["--type=" <> backupTypeName ty, "backup"] + +-- | Where recovery stops. +data RestoreTarget + = -- | replay everything the archive holds + Latest + | -- | stop as soon as the backup is consistent + Immediate + | -- | a timestamp Postgres parses, e.g. @2026-10-02 14:03:00+00@ + AtTime Text + | AtLsn Text + | AtXid Text + | -- | a @pg_create_restore_point@ name + AtName Text + deriving (Eq, Show) + +{- | @pgbackrest restore@ to a target, promoting once it is reached. + +No @--delta@, no @--force@: a data directory that is not empty is refused by +pgBackRest, which is the guard. The timeline is left to Postgres' default +(@latest@), which is wrong for one case worth knowing: after an /earlier/ +recovery forked a timeline, a target that lies before that fork is never +reached unless @target-timeline@ is set (through 'pbr_global'). +-} +restoreArgs :: PgBackRestConfig -> RestoreTarget -> [Text] +restoreArgs c target = commonArgs c <> ty <> ["restore"] + where + targeted name v = ["--type=" <> name, "--target=" <> v, "--target-action=promote"] + ty = case target of + Latest -> [] + Immediate -> ["--type=immediate", "--target-action=promote"] + AtTime t -> targeted "time" t + AtLsn l -> targeted "lsn" l + AtXid x -> targeted "xid" x + AtName n -> targeted "name" n + +-- | A command line for a shell: Postgres and Patroni both take one string. +commandLine :: PgBackRestConfig -> [Text] -> Text +commandLine c args = Text.unwords (Text.pack c.pbr_binary : fmap shellWord args) + +-- | Single-quoted when it has to be; @%p@ and @%f@ are left for Postgres to substitute. +shellWord :: Text -> Text +shellWord w + | Text.null w = "''" + | Text.all safe w = w + | otherwise = "'" <> Text.replace "'" "'\\''" w <> "'" + where + safe ch = ch `elem` ("-_=/.:,+%@" :: String) || ch `elem` ['a' .. 'z'] || ch `elem` ['A' .. 'Z'] || ch `elem` ['0' .. '9'] + +-- | Postgres's @archive_command@. +archiveCommand :: PgBackRestConfig -> Text +archiveCommand c = commandLine c (commonArgs c <> ["archive-push", "%p"]) + +-- | Postgres's @restore_command@. +restoreCommand :: PgBackRestConfig -> Text +restoreCommand c = commandLine c (commonArgs c <> ["archive-get", "%f"]) <> " \"%p\"" + +{- | What Patroni runs to make a replica: a delta restore into the member's +data directory. Patroni then writes the recovery configuration itself. +-} +replicaCreateCommand :: PgBackRestConfig -> Text +replicaCreateCommand c = commandLine c (commonArgs c <> ["--delta", "restore"]) + +-- | The settings a cluster /not/ under Patroni needs to archive; @archive_mode@ is restart-only. +archiveParameters :: PgBackRestConfig -> [(Text, Text)] +archiveParameters c = [("archive_mode", "on"), ("archive_command", archiveCommand c)] + +{- | The archive, as Patroni needs it declared ('Patroni.pat_archive'): +replicas are made from it, with a base backup from the leader as the fallback +for when it holds no backup yet, and every member archives and restores WAL +through it. +-} +patroniArchive :: PgBackRestConfig -> Patroni.Archive +patroniArchive c = + Patroni.Archive + { Patroni.arc_methods = [Patroni.ReplicaMethod "pgbackrest" (replicaCreateCommand c) True True] + , Patroni.arc_basebackup_fallback = True + , Patroni.arc_archive_command = archiveCommand c + , Patroni.arc_restore_command = restoreCommand c + , Patroni.arc_bootstrap = Nothing + } + +{- | The same, for a /new/ Patroni cluster whose first member is restored from +the archive to a target instead of @initdb@-ed: point-in-time recovery of a +whole cluster. It only has an effect while the scope has never been +initialised in the DCS; give the recovered cluster a new scope (and so a new +stanza to archive into) rather than reusing the lost one's. +-} +patroniArchiveRecovering :: PgBackRestConfig -> RestoreTarget -> Patroni.Archive +patroniArchiveRecovering c target = + (patroniArchive c){Patroni.arc_bootstrap = Just (Patroni.BootstrapMethod "pgbackrest" (commandLine c (restoreArgs c target)))} + +------------------------------------------------------------------------------- +-- What @pgbackrest info --output=json@ says, as far as this module reads it. + +data StanzaInfo + = StanzaInfo + { si_name :: Text + , si_status_code :: Int + , si_status_message :: Text + , si_backups :: [BackupInfo] + } + deriving (Eq, Show) + +data BackupInfo + = BackupInfo + { bi_label :: Text + , bi_type :: Text + , bi_stop :: Maybe Integer + -- ^ epoch seconds at which the backup ended; a recovery target must be later + } + deriving (Eq, Show) + +instance FromJSON StanzaInfo where + parseJSON = withObject "stanza" $ \o -> do + st <- o .: "status" + (code, msg) <- withObject "status" (\s -> (,) <$> s .: "code" <*> s .:? "message" .!= "") st + StanzaInfo <$> o .: "name" <*> pure code <*> pure msg <*> o .:? "backup" .!= [] + +instance FromJSON BackupInfo where + parseJSON = withObject "backup" $ \o -> do + ts <- o .:? "timestamp" + stop <- maybe (pure Nothing) (withObject "timestamp" (.:? "stop")) ts + BackupInfo <$> o .: "label" <*> o .:? "type" .!= "" <*> pure stop + +parseInfo :: ByteString.ByteString -> Either Text [StanzaInfo] +parseInfo = either (Left . Text.pack) Right . eitherDecodeStrict + +{- | Does the repository hold this stanza? pgBackRest's status codes: 0 is ok, +2 is "no valid backups" (the stanza exists, which is all this asks), 1 and 3 +are a missing stanza path or data. Anything else is reported as it reads. +-} +interpretStanza :: Text -> ByteString.ByteString -> CheckResult +interpretStanza stanzaName out = withStanza stanzaName out $ \si -> + if si.si_status_code `elem` [0, 2] + then Success + else Failure ("stanza " <> stanzaName <> ": " <> describe si) + +-- | Does the repository hold at least one backup of this stanza? +interpretHasBackup :: Text -> ByteString.ByteString -> CheckResult +interpretHasBackup stanzaName out = withStanza stanzaName out $ \si -> + case (si.si_status_code, si.si_backups) of + (0, _ : _) -> Success + (0, []) -> Failure ("stanza " <> stanzaName <> " lists no backup") + _ -> Failure ("stanza " <> stanzaName <> ": " <> describe si) + +describe :: StanzaInfo -> Text +describe si = si.si_status_message <> " (status " <> tshow si.si_status_code <> ")" + +withStanza :: Text -> ByteString.ByteString -> (StanzaInfo -> CheckResult) -> CheckResult +withStanza stanzaName out f = case parseInfo out of + Left e -> Failure ("pgbackrest info not understood: " <> Text.take 120 e) + Right infos -> case filter ((== stanzaName) . si_name) infos of + [] -> Failure ("the repository has no stanza " <> stanzaName) + (si : _) -> f si + +------------------------------------------------------------------------------- + +newtype Invocation = Invocation [Text] + +pgbackrestRun :: PgBackRestConfig -> Command "pgbackrest" Invocation +pgbackrestRun c = Command (\(Invocation args) -> process c args) + +process :: PgBackRestConfig -> [Text] -> CreateProcess +process c args = case c.pbr_run_as of + Nothing -> proc c.pbr_binary (fmap Text.unpack args) + Just u -> proc "sudo" (["-u", Text.unpack u, c.pbr_binary] <> fmap Text.unpack args) + +-- | Asks the repository; a command that fails could not tell, which is 'Unknown' and lets @up@ say why. +checkInfo :: PgBackRestConfig -> (Text -> ByteString.ByteString -> CheckResult) -> IO CheckResult +checkInfo c interpret = do + (code, out, _) <- readCreateProcessWithExitCode (process c (infoArgs c)) "" + pure $ case code of + ExitSuccess -> interpret c.pbr_stanza out + ExitFailure _ -> Unknown + +{- | The binary, @pgbackrest.conf@, the log directory, a posix repository's +directory, and the secrets fragment's ownership. A missing fragment is a +failure: writing it is somebody else's job. +-} +configuration :: Track' (Binary "pgbackrest") -> PgBackRestConfig -> Op +configuration bin c = + op "pgbackrest-config" (deps ([justInstall bin, conf, owned c.pbr_log_path] <> repoDir <> secrets)) $ \actions -> + actions + { help = "pgBackRest configured for stanza " <> c.pbr_stanza + , notes = ["credentials are a pre-provisioned fragment, never rendered"] + , ref = mkRef "pgbackrest-config" c.pbr_config_file + } + where + conf = FS.filecontentsInSharedDir (FS.FileContents c.pbr_config_file (renderConf c)) + owned path = + FS.ownedFile (FS.FileOwnership path (Just c.pbr_user) Nothing (0o750 :: Posix.FileMode)) + `inject` FS.dir (FS.Directory path) + repoDir = case c.pbr_repo of + PosixRepo path -> [owned path] + S3Repo{} -> [] + secrets = + [ FS.ownedFile (FS.FileOwnership f (Just c.pbr_user) Nothing (0o600 :: Posix.FileMode)) + | Just f <- [c.pbr_secrets_file] + ] + +{- | The stanza exists in the repository. @stanza-create@ is idempotent, and +needs the cluster running and this member to be the primary (see the module +header for what that means under Patroni). +-} +stanza :: Reporter Report -> Track' (Binary "pgbackrest") -> PgBackRestConfig -> Op +stanza r bin c = + withBinary bin (pgbackrestRun c) (Invocation (stanzaCreateArgs c)) $ \run -> + op "pgbackrest-stanza" (deps [configuration bin c]) $ \actions -> + actions + { help = "the archive holds stanza " <> c.pbr_stanza + , notes = ["checked in the repository; created from the primary only"] + , ref = mkRef "pgbackrest-stanza" c.pbr_stanza + , check = checkInfo c interpretStanza + , up = run r + } + +{- | The archive holds at least one backup, without which it can restore +nothing and build no replica. Takes a full one when there is none; later +backups are a schedule's ('scheduledBackup'), not a state. +-} +firstBackup :: Reporter Report -> Track' (Binary "pgbackrest") -> PgBackRestConfig -> Op +firstBackup r bin c = + withBinary bin (pgbackrestRun c) (Invocation (backupArgs c Full)) $ \run -> + op "pgbackrest-first-backup" (deps [stanza r bin c]) $ \actions -> + actions + { help = "the archive holds a backup of stanza " <> c.pbr_stanza + , ref = mkRef "pgbackrest-first-backup" c.pbr_stanza + , check = checkInfo c interpretHasBackup + , up = run r + } + +{- | A data directory restored from the archive, to a target. For disaster +recovery of a cluster salmon runs itself; __not__ for a Patroni member, whose +data directory is Patroni's (see 'patroniArchiveRecovering'). + +The check is whether the directory already holds a cluster (@PG_VERSION@): one +that does is left alone, whatever it is. The @up@ restores without @--delta@, +so pgBackRest refuses a directory holding anything else. Starting the cluster +afterwards, which is what replays the WAL up to the target, is the caller's +next node. @down@ does nothing: a restored cluster is data. +-} +restoredCluster :: Reporter Report -> Track' (Binary "pgbackrest") -> PgBackRestConfig -> RestoreTarget -> Op +restoredCluster r bin c target = + withBinary bin (pgbackrestRun c) (Invocation (restoreArgs c target)) $ \run -> + op "pgbackrest-restore" (deps [configuration bin c]) $ \actions -> + actions + { help = "the data directory " <> Text.pack c.pbr_pg_path <> " restored from stanza " <> c.pbr_stanza + , notes = ["target: " <> tshow target, "a directory already holding a cluster is left alone"] + , ref = mkRef "pgbackrest-restore" c.pbr_pg_path + , check = checkHoldsCluster c.pbr_pg_path + , up = run r + } + +checkHoldsCluster :: FilePath -> IO CheckResult +checkHoldsCluster path = do + present <- doesFileExist (path "PG_VERSION") + pure (if present then Success else Failure (Text.pack path <> " holds no cluster")) + +------------------------------------------------------------------------------- + +data BackupSchedule + = BackupSchedule + { bs_name :: Text + -- ^ names the cron entry and the script + , bs_type :: BackupType + , bs_schedule :: Cron.Schedule + , bs_script :: FilePath + , bs_gate_url :: Maybe Text + -- ^ run only when this URL answers 2xx, e.g. @http:\/\/127.0.0.1:8008\/primary@ + } + +{- | The scheduled command. With a gate, a member that is not what the URL +asks for exits 0 without doing anything, so the same schedule can be declared +on every member and one of them acts. + +The gate to use with this module's configuration is Patroni's @\/primary@: +a backup taken /from/ a standby (the spec's preference) needs pgBackRest's +@backup-standby@ and a second @pg@ host reached over ssh or TLS, which is not +rendered here. +-} +backupScript :: PgBackRestConfig -> BackupSchedule -> Text +backupScript c s = + Text.unlines $ + ["#!/bin/bash", "set -euo pipefail"] + <> maybe [] (\u -> ["curl -sf -o /dev/null " <> shellWord u <> " || exit 0"]) s.bs_gate_url + <> ["exec " <> commandLine c (backupArgs c s.bs_type)] + +-- | The script and a cron entry running it as 'pbr_user'. +scheduledBackup :: Track' (Binary "pgbackrest") -> PgBackRestConfig -> BackupSchedule -> Op +scheduledBackup bin c s = + Cron.crontask (Track $ const script) task + where + script = FS.filecontents (FS.FileContents s.bs_script (backupScript c s)) `inject` configuration bin c + task = Cron.CronTask ("pgbackrest-" <> s.bs_name) c.pbr_user s.bs_schedule "/bin/bash" [Text.pack s.bs_script] diff --git a/src/Salmon/Builtin/Nodes/PgBouncer.hs b/src/Salmon/Builtin/Nodes/PgBouncer.hs --- a/src/Salmon/Builtin/Nodes/PgBouncer.hs +++ b/src/Salmon/Builtin/Nodes/PgBouncer.hs @@ -106,8 +106,8 @@ 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) + iniFile = FS.filecontentsInSharedDir $ FS.FileContents (configPath cfg) (renderIni cfg) + userlistFile = FS.filecontentsInSharedDir $ FS.FileContents (userlistPath cfg) (renderUserlist cfg.bouncer_users) renderIni :: BouncerConfig -> Text renderIni cfg = diff --git a/src/Salmon/Builtin/Nodes/PgTextSearch.hs b/src/Salmon/Builtin/Nodes/PgTextSearch.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/PgTextSearch.hs @@ -0,0 +1,889 @@ +{-# LANGUAGE DeriveGeneric #-} + +{- | @pg_textsearch@ (): a +PostgreSQL extension adding a @bm25@ index access method, for full-text +search ranked with BM25. + +'pgTextSearch' makes one cluster able to build and use such indexes. In +order: a gate on the server's major version, the release's files, the +library in @shared_preload_libraries@ (keeping whatever else is listed), +a restart if the declaration asks for one, a gate on the library being the +one loaded, the @pg_textsearch.*@ settings, and @CREATE EXTENSION@ in each +declared database. Creating the indexes is schema, and is a migration's job. + +What was read upstream, at release @v1.5.1@ (2026-10), and shaped this +module. Re-read it before trusting any of it against a later release: + +* __PostgreSQL 17 and 18 only__ (the README; 19 is \"best-effort\" and has no + published binary). 'supportedMajors'. +* __A release zip is not a tree of files.__ @pg-textsearch-v1.5.1-pg17-amd64.zip@ + holds one entry, a Debian package + @pg-textsearch-postgresql-17_1.5.1-1_amd64.deb@, whose content is + @usr\/lib\/postgresql\/17\/lib\/pg_textsearch.so@, + @usr\/share\/postgresql\/17\/extension\/pg_textsearch.control@ and the + @pg_textsearch--*.sql@ scripts next to it. 'releaseFiles' takes the + package out of the zip and unpacks it in a temporary directory + (@dpkg-deb -x@: nothing is registered with @dpkg@ and no maintainer script + runs), then copies those files where the server's own @pg_config@ says + libraries and extension files go. +* __The library must be preloaded__: its @_PG_init@ raises + @pg_textsearch must be loaded via shared_preload_libraries@ otherwise. + That setting only changes at a restart. +* __The loaded library says which version it is__, in the read-only setting + @pg_textsearch.library_version@, which is the control file's + @default_version@. 'loadedGate' asks it, because replacing the files of a + running server changes nothing the server reports as pending. +* __The settings__ are the ten of the README's table, registered in + @src\/mod.c@ under those names: @memory_limit@ with context @sighup@, + @default_limit@, @compress_segments@ and @memtable_cache_enabled@ with + @user@, the others with @superuser@. None needs a restart. The settings + node does not rely on that: it reads @pg_settings.context@ and + @pending_restart@ and says so when a value it wrote is not in effect. + +The pinned sha256 is the digest of a public release artifact (GitHub shows +it next to the asset). It is not a secret, and it is in the node's notes. + +Out of scope: BM25 indexes (schema: migrations), managed background +compaction (it needs @pg_durable@ preloaded and granted), building from +source, and choosing how the zip reaches the machine: it is a path, and +somebody else's to provision. +-} +module Salmon.Builtin.Nodes.PgTextSearch ( + -- * Declaration + PgTextSearch (..), + pgTextSearchOn, + Release (..), + releaseZipName, + Restart (..), + Settings (..), + defaultSettings, + debianPgConfig, + + -- * Nodes + pgTextSearch, + versionGate, + releaseFiles, + loadedGate, + settingsNode, + libraryName, + + -- * Pure parts + supportedMajors, + gateVerdict, + releaseProblems, + DebName (..), + renderDebName, + parseDebName, + selectDeb, + InstallDirs (..), + Install (..), + planInstall, + isExtensionFile, + parseControlVersion, + dpkgListFile, + loadedVersionSql, + interpretLoaded, + Setting (..), + settings, + settingNotes, + problems, + inspectSettingsSql, + applySettingsSql, + resetSettingsSql, + settingDiffs, + interpretSettings, + PgTextSearchError (..), +) where + +import Control.Concurrent (threadDelay) +import Control.Exception (Exception, IOException, bracket, throwIO, try) +import Control.Monad (filterM, forM, forM_, unless, when) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as ByteString +import Data.Char (isAsciiLower, isDigit) +import Data.List (sort) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as TextError +import GHC.Generics (Generic) +import System.Directory ( + copyFile, + doesDirectoryExist, + doesFileExist, + getTemporaryDirectory, + listDirectory, + pathIsSymbolicLink, + removeDirectoryRecursive, + renameFile, + ) +import System.Exit (ExitCode (..)) +import System.FilePath (takeFileName, ()) +import System.Posix.Files (setFileMode) +import System.Posix.Temp (mkdtemp) +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, justInstall) +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import Salmon.Builtin.Nodes.LlamaServer (sha256File) +import Salmon.Builtin.Nodes.Postgres (ClusterName, 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 + +------------------------------------------------------------------------------- + +-- | The name the library is preloaded under, the extension's name, and the prefix of its settings and files. +libraryName :: Text +libraryName = "pg_textsearch" + +-- | The majors a release is published for. +supportedMajors :: [Int] +supportedMajors = [17, 18] + +{- | One published release, as a file somebody put on the target machine. + +The three fields say the same thing three times on purpose: the version is +what the installed control file is compared to (so a check needs neither the +zip nor a hash of three megabytes), the sha256 is what the zip must be before +anything is taken out of it, and the path is where it is. +-} +data Release = Release + { releaseVersion :: Text + -- ^ @1.5.1@: the extension's version, which is the package's without its @-1@ revision + , releaseZip :: FilePath + -- ^ the zip for the cluster's major and the machine's architecture; see 'releaseZipName' + , releaseSha256 :: Text + -- ^ of the zip, 64 hex digits. Public: GitHub lists it as the asset's digest. + } + deriving (Eq, Show) + +-- | @pg-textsearch-v1.5.1-pg17-amd64.zip@ for @"1.5.1"@, @17@, @"amd64"@: the asset's name upstream. +releaseZipName :: Text -> Int -> Text -> FilePath +releaseZipName version major arch = + Text.unpack ("pg-textsearch-v" <> version <> "-pg" <> tshow major <> "-" <> arch <> ".zip") + +{- | Who restarts the cluster once the library is in +@shared_preload_libraries@. There is no default: a restart of a server +somebody is using is a thing to declare. +-} +data Restart + = -- | This declaration does, with 'Postgres.restartClusterIfPending': + -- a real restart of the whole named cluster, the first time and + -- whenever anything else left a restart pending. + RestartWhenPending ClusterName + | -- | Somebody else does (an operator, or a cluster manager that + -- restarts replicas first). Until then 'loadedGate' fails, and with + -- it the settings and the extension, saying a restart is awaited. + RestartLeftToOperator + deriving (Eq, Show) + +-- | @pg_textsearch.*@. A 'Nothing' leaves the server's value alone; all of them 'Nothing' declares no settings node at all. +data Settings = Settings + { setDefaultLimit :: Maybe Int + -- ^ 1..100000 (default 1000): the initial scoring batch of a query with no @LIMIT@ + , setCompressSegments :: Maybe Bool + , setSegmentsPerLevel :: Maybe Int + -- ^ 2..64 (default 8) + , setMaxSegmentSizeMb :: Maybe Int + -- ^ megabytes, 1..4095 (default 4095) + , setBackgroundCompactionSchedule :: Maybe Text + -- ^ a cron schedule. Only a default for indexes entering managed + -- background compaction, which this module does not set up. + , setBulkLoadThreshold :: Maybe Int + -- ^ terms per transaction before a spill; 0 disables + , setMemtablePagesThreshold :: Maybe Int + -- ^ chain pages before a spill; 0 disables + , setAllowRls :: Maybe Bool + -- ^ whether BM25 indexes are allowed on tables with row-level security. + -- On by default upstream, which accepts a documented term-frequency leak. + , setMemtableCacheEnabled :: Maybe Bool + , setMemoryLimitKb :: Maybe Int + -- ^ kilobytes (default 2GB); 0 is no limit + } + deriving (Eq, Show) + +-- | Sets nothing. +defaultSettings :: Settings +defaultSettings = Settings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +data PgTextSearch = PgTextSearch + { ptsMajor :: Int + -- ^ the cluster's major version, declared rather than discovered so the + -- graph does not depend on a running server. 'versionGate' refuses a + -- server that is of another one. + , ptsPort :: Port + , ptsRelease :: Release + , ptsPgConfig :: FilePath + -- ^ that server's own @pg_config@ ('debianPgConfig'). Not the one on + -- @PATH@, which on Debian comes with @libpq-dev@ and may be of another major. + , ptsRestart :: Restart + , ptsDatabases :: [DatabaseName] + -- ^ databases to @CREATE EXTENSION@ in. Empty on a standby, which + -- receives the catalog rows from its primary and needs the files and + -- the preload only. + , ptsUpgrade :: Bool + -- ^ also @ALTER EXTENSION pg_textsearch UPDATE@ when the files are newer (see 'extUpgrade') + , ptsSettings :: Settings + } + deriving (Eq, Show) + +-- | @\/usr\/lib\/postgresql\/N\/bin\/pg_config@, where Debian's server package puts it. +debianPgConfig :: Int -> FilePath +debianPgConfig major = "/usr/lib/postgresql" show major "bin/pg_config" + +-- | A declaration on Debian's layout, with no database, no setting and no upgrade. +pgTextSearchOn :: Int -> Port -> Restart -> Release -> PgTextSearch +pgTextSearchOn major port restart release = + PgTextSearch + { ptsMajor = major + , ptsPort = port + , ptsRelease = release + , ptsPgConfig = debianPgConfig major + , ptsRestart = restart + , ptsDatabases = [] + , ptsUpgrade = False + , ptsSettings = defaultSettings + } + +newtype PgTextSearchError = PgTextSearchError Text + deriving (Show) + +instance Exception PgTextSearchError + +refuse :: Text -> IO a +refuse = throwIO . PgTextSearchError + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show + +------------------------------------------------------------------------------- +-- version gate + +{- | Whether a server answering @SHOW server_version_num@ with this text is +one the declared release can be installed on. The message names the version. +-} +gateVerdict :: Int -> Text -> Either Text () +gateVerdict declared out = + case Text.unpack (Text.strip out) of + ds + | not (null ds) + , all isDigit ds + , length ds <= 9 -> + let num = read ds :: Int + major = num `div` 10000 + in if major `notElem` supportedMajors + then Left (libraryName <> " supports PostgreSQL " <> majors <> " only, this server is PostgreSQL " <> tshow major <> " (server_version_num " <> Text.pack ds <> ")") + else + if major /= declared + then Left ("this server is PostgreSQL " <> tshow major <> " (server_version_num " <> Text.pack ds <> "), the declaration is for " <> tshow declared) + else Right () + _ -> Left ("cannot read server_version_num from " <> tshow (Text.take 80 out)) + where + majors = Text.intercalate " and " (fmap tshow supportedMajors) + +{- | Refuses, at @up@, a server that is not of a supported major or not of +the declared one. Everything else depends on it, so a wrong-major package +is never copied and the cluster is never restarted with it preloaded. + +An unreachable server is 'Unknown' for @check@ and a failure for @up@: +nothing here should proceed on a server nobody could ask. +-} +versionGate :: Int -> Port -> Op +versionGate major port = + op "pg-textsearch-version-gate" nodeps $ \actions -> + actions + { ref = mkRef "pg-textsearch-version-gate" port + , help = Text.unwords [libraryName, "supports the PostgreSQL major of the cluster on port", tshow port] + , notes = ["declared major: " <> tshow major, "supported: " <> Text.intercalate ", " (fmap tshow supportedMajors)] + , check = either (const Unknown) (either Failure (const Success) . gateVerdict major) <$> ask + , up = do + out <- either (\err -> refuse ("cannot read server_version_num on port " <> tshow port <> ": " <> Text.strip err)) pure =<< ask + either refuse pure (gateVerdict major out) + } + where + ask = Postgres.psqlQuery_Sudo port "SHOW server_version_num" + +------------------------------------------------------------------------------- +-- the release's files + +-- | What is wrong with a release as declared, before anything is read. +releaseProblems :: Int -> Release -> [Text] +releaseProblems major rel = + concat + [ [libraryName <> " supports PostgreSQL " <> Text.intercalate " and " (fmap tshow supportedMajors) <> " only, the declaration is for " <> tshow major | major `notElem` supportedMajors] + , ["the release version " <> tshow rel.releaseVersion <> " is not digits and dots" | not (validVersion rel.releaseVersion)] + , ["the pinned sha256 is not 64 hex digits" | not (validSha rel.releaseSha256)] + ] + where + validSha s = Text.length s == 64 && Text.all (`elem` (['0' .. '9'] <> ['a' .. 'f'] <> ['A' .. 'F'])) s + +validVersion :: Text -> Bool +validVersion v = not (Text.null v) && all part (Text.splitOn "." v) + where + part p = not (Text.null p) && Text.all isDigit p + +-- | The name of the package inside a release zip, taken apart. +data DebName = DebName + { debMajor :: Int + , debVersion :: Text + -- ^ @1.5.1@ + , debRevision :: Int + -- ^ the Debian revision, @1@ in every release seen + , debArch :: Text + -- ^ @amd64@, @arm64@ + } + deriving (Eq, Show) + +-- | @pg-textsearch-postgresql-17_1.5.1-1_amd64.deb@ +renderDebName :: DebName -> Text +renderDebName d = + "pg-textsearch-postgresql-" <> tshow d.debMajor <> "_" <> d.debVersion <> "-" <> tshow d.debRevision <> "_" <> d.debArch <> ".deb" + +{- | The inverse of 'renderDebName', and strict: anything it accepts renders +back to the same text, and holds no character a shell or an archive tool +reads as a pattern or a path. +-} +parseDebName :: Text -> Maybe DebName +parseDebName t = do + body <- Text.stripPrefix "pg-textsearch-postgresql-" t >>= Text.stripSuffix ".deb" + (majorT, versionT, revisionT, arch) <- case Text.splitOn "_" body of + [m, vr, a] -> case Text.splitOn "-" vr of + [v, r] -> Just (m, v, r, a) + _ -> Nothing + _ -> Nothing + major <- number majorT + revision <- number revisionT + if validVersion versionT && not (Text.null arch) && Text.all (\c -> isAsciiLower c || isDigit c) arch + then Just (DebName major versionT revision arch) + else Nothing + where + -- no sign, no leading zero, and small enough to be an Int anywhere + number s + | Text.null s || not (Text.all isDigit s) || Text.length s > 9 = Nothing + | Text.length s > 1 && Text.head s == '0' = Nothing + | otherwise = Just (read (Text.unpack s)) + +{- | The one package a zip must hold, given its listing: for the declared +major, the declared version and the machine's architecture. A zip with +anything else in it is refused rather than searched. +-} +selectDeb :: Int -> Text -> Text -> [Text] -> Either Text DebName +selectDeb major version arch entries = + case filter (not . Text.null) entries of + [entry] -> case parseDebName entry of + Nothing -> Left ("the zip holds " <> tshow entry <> ", which is not a pg-textsearch-postgresql-MAJOR_VERSION-REV_ARCH.deb") + Just d + | d.debMajor /= major -> Left ("the zip holds a package for PostgreSQL " <> tshow d.debMajor <> ", the declaration is for " <> tshow major) + | d.debVersion /= version -> Left ("the zip holds version " <> d.debVersion <> ", the declaration is for " <> version) + | d.debArch /= arch -> Left ("the zip holds a package for " <> d.debArch <> ", this machine is " <> arch) + | otherwise -> Right d + es -> Left ("the zip holds " <> tshow (length es) <> " entries, expected one Debian package") + +-- | Where a server looks for libraries and extension files (@pg_config --pkglibdir@, and @extension@ under @--sharedir@). +data InstallDirs = InstallDirs + { pkgLibDir :: FilePath + , extensionDir :: FilePath + } + deriving (Eq, Show) + +-- | One file of the package and where it goes. +data Install = Install + { installFrom :: FilePath + -- ^ relative to the unpacked package + , installTo :: FilePath + , installExecutable :: Bool + } + deriving (Eq, Show) + +-- | @pg_textsearch.control@ or a @pg_textsearch--*.sql@ script: the names this module writes into, and removes from, the extension directory. +isExtensionFile :: FilePath -> Bool +isExtensionFile name = + name == lib <> ".control" + || (Text.isPrefixOf (Text.pack lib <> "--") (Text.pack name) && Text.isSuffixOf ".sql" (Text.pack name) && '/' `notElem` name) + where + lib = Text.unpack libraryName + +{- | What to copy where, given the regular files of an unpacked package +(relative paths). The library first and the control file last: the control +file is what 'releaseFiles' checks, so an install that stops half-way is +seen as not done. + +Refused: a package without the library, the control file or the script of +the declared version for this major (which is what a package built for +another major looks like), and a package holding any file this module has +no place for. The second is strict on purpose: a later release that ships +something more should be read by a person before it is copied as root. +-} +planInstall :: Int -> Text -> InstallDirs -> [FilePath] -> Either Text [Install] +planInstall major version dirs files + | libRel `notElem` files = Left ("the package has no " <> Text.pack libRel <> ": it is not built for PostgreSQL " <> tshow major) + | control `notElem` extNames = Left ("the package has no " <> Text.pack (extRel control)) + | script `notElem` extNames = Left ("the package has no " <> Text.pack (extRel script) <> ": it is not version " <> version) + | not (null strangers) = Left ("the package holds files this node has no place for: " <> Text.intercalate ", " (fmap Text.pack strangers)) + | otherwise = + Right $ + [Install libRel (dirs.pkgLibDir takeFileName libRel) True] + <> [Install (extRel n) (dirs.extensionDir n) False | n <- sort extNames, n /= control] + <> [Install (extRel control) (dirs.extensionDir control) False] + where + lib = Text.unpack libraryName + libRel = "usr/lib/postgresql" show major "lib" lib <> ".so" + extRel = "usr/share/postgresql" show major "extension" + control = lib <> ".control" + script = lib <> "--" <> Text.unpack version <> ".sql" + inExt f = [n | Just n <- [stripDir extRel f], isExtensionFile n] + extNames = concatMap inExt files + strangers = sort [f | f <- files, f /= libRel, null (inExt f)] + stripDir d f = Text.unpack <$> Text.stripPrefix (Text.pack d <> "/") (Text.pack f) + +{- | The @default_version@ of a control file. Comment lines and other keys +are skipped; the value is read with or without its quotes. +-} +parseControlVersion :: Text -> Maybe Text +parseControlVersion content = + listToMaybe + [ v + | line <- Text.lines content + , let (key, rest) = Text.breakOn "=" (Text.strip line) + , Text.strip key == "default_version" + , Just raw <- [Text.stripPrefix "=" rest] + , let v = value (Text.strip raw) + , not (Text.null v) + ] + where + value raw = case Text.stripPrefix "'" raw of + Just quoted -> Text.takeWhile (/= '\'') quoted + Nothing -> Text.takeWhile (\c -> c /= '#' && c /= ' ' && c /= '\t') raw + +{- | The file @dpkg@ keeps for the package the zip holds, when somebody +installed that package the Debian way. Its presence means the files are +@dpkg@'s: this module then neither replaces nor removes them. +-} +dpkgListFile :: Int -> FilePath +dpkgListFile major = "/var/lib/dpkg/info/pg-textsearch-postgresql-" <> show major <> ".list" + +runTool :: FilePath -> [String] -> IO Text +runTool cmd args = do + r <- try (readCreateProcessWithExitCode (proc cmd args) "") + case r of + Left (e :: IOException) -> refuse ("cannot run " <> Text.pack cmd <> ": " <> tshow e) + Right (ExitSuccess, out, _) -> pure (decode out) + Right (ExitFailure n, _, err) -> + refuse (Text.pack cmd <> " exited " <> tshow n <> ": " <> Text.take 500 (Text.strip (decode err))) + where + decode = Text.decodeUtf8With TextError.lenientDecode + +installDirs :: FilePath -> IO InstallDirs +installDirs pgConfig = do + lib <- Text.unpack . Text.strip <$> runTool pgConfig ["--pkglibdir"] + share <- Text.unpack . Text.strip <$> runTool pgConfig ["--sharedir"] + when (null lib || null share) $ refuse (Text.pack pgConfig <> " named no directory") + pure (InstallDirs lib (share "extension")) + +-- | The regular files under a directory, relative to it. A symbolic link is refused: nothing in a release is one. +regularFiles :: FilePath -> IO [FilePath] +regularFiles root = go "" + where + go rel = do + names <- listDirectory (root rel) + fmap concat . forM (sort names) $ \n -> do + let r = if null rel then n else rel n + link <- pathIsSymbolicLink (root r) + when link $ refuse ("the package holds a symbolic link: " <> Text.pack r) + isDir <- doesDirectoryExist (root r) + if isDir then go r else pure [r] + +{- | The release's files, where the server of that major looks for them. + +@check@ reads the installed control file's @default_version@ and looks for +the library and that version's script. It needs neither the zip nor a +running server, so it also answers on a standby and after the zip was +cleaned away. @up@ verifies the zip against the pinned sha256 before +listing it, refuses anything in it that is not the one expected package, +and replaces each file with a rename, so a server that has the library +mapped keeps the one it loaded. + +A replaced library is only loaded at the next restart, and PostgreSQL does +not report that as pending: 'loadedGate' is what notices. + +@down@ removes @pg_textsearch.so@, @pg_textsearch.control@ and the +@pg_textsearch--*.sql@ scripts, whoever put them there, except when the +Debian package of that name is installed: then they are @dpkg@'s, and @up@ +refuses to replace them for the same reason. +-} +releaseFiles :: Int -> FilePath -> Release -> Op +releaseFiles major pgConfig rel = + op "pg-textsearch-files" nodeps $ \actions -> + actions + { ref = mkRef "pg-textsearch-files" pgConfig + , help = Text.unwords [libraryName, rel.releaseVersion, "files for postgresql", tshow major] + , notes = + [ "from " <> Text.pack rel.releaseZip + , "pinned sha256 of the release zip (a public artifact, not a secret): " <> Text.toLower rel.releaseSha256 + , "directories from " <> Text.pack pgConfig + , "a replaced library is loaded at the next restart, which this node does not force" + ] + , check = chk + , up = install + , down = uninstall + } + where + lib = Text.unpack libraryName + chk = case releaseProblems major rel of + ps@(_ : _) -> pure (Failure (Text.intercalate "; " ps)) + [] -> do + dirs <- try (installDirs pgConfig) + case dirs of + Left (PgTextSearchError e) -> pure (Failure e) + Right d -> do + let control = d.extensionDir lib <> ".control" + wanted = [d.pkgLibDir lib <> ".so", d.extensionDir lib <> "--" <> Text.unpack rel.releaseVersion <> ".sql"] + haveControl <- doesFileExist control + if not haveControl + then pure (Failure (Text.pack control <> " is missing")) + else do + installed <- parseControlVersion . Text.decodeUtf8With TextError.lenientDecode <$> ByteString.readFile control + missing <- filterM (fmap not . doesFileExist) wanted + pure $ case (installed, missing) of + (Just v, _) | v /= rel.releaseVersion -> Failure (Text.pack control <> " is version " <> v <> ", declared " <> rel.releaseVersion) + (Nothing, _) -> Failure (Text.pack control <> " has no default_version") + (_, m : _) -> Failure (Text.pack m <> " is missing") + _ -> Success + install = do + let ps = releaseProblems major rel + unless (null ps) $ refuse (Text.intercalate "; " ps) + owned <- doesFileExist (dpkgListFile major) + when owned $ refuse ("the Debian package pg-textsearch-postgresql-" <> tshow major <> " is installed: its files are dpkg's, and this node does not replace them") + haveZip <- doesFileExist rel.releaseZip + unless haveZip $ refuse (Text.pack rel.releaseZip <> " is missing: providing the release zip is the caller's job") + actual <- sha256File rel.releaseZip + when (actual /= Text.toLower rel.releaseSha256) $ + refuse (Text.pack rel.releaseZip <> " has sha256 " <> actual <> ", the pinned one is " <> Text.toLower rel.releaseSha256) + dirs <- installDirs pgConfig + forM_ [dirs.pkgLibDir, dirs.extensionDir] $ \d -> do + there <- doesDirectoryExist d + unless there $ refuse (Text.pack d <> " does not exist: is postgresql " <> tshow major <> " installed?") + arch <- Text.strip <$> runTool "dpkg" ["--print-architecture"] + entries <- Text.lines <$> runTool "unzip" ["-Z1", rel.releaseZip] + deb <- either refuse pure (selectDeb major rel.releaseVersion arch entries) + withScratch $ \tmp -> do + let debName = Text.unpack (renderDebName deb) + _ <- runTool "unzip" ["-q", "-j", rel.releaseZip, debName, "-d", tmp "zip"] + _ <- runTool "dpkg-deb" ["-x", tmp "zip" debName, tmp "pkg"] + files <- regularFiles (tmp "pkg") + plan <- either refuse pure (planInstall major rel.releaseVersion dirs files) + forM_ plan $ \i -> do + let part = i.installTo <> ".salmon-part" + copyFile (tmp "pkg" i.installFrom) part + setFileMode part (if i.installExecutable then 0o755 else 0o644) + renameFile part i.installTo + withScratch act = do + base <- getTemporaryDirectory + bracket (mkdtemp (base "salmon-pg-textsearch-")) removeDirectoryRecursive act + uninstall = do + owned <- doesFileExist (dpkgListFile major) + havePgConfig <- doesFileExist pgConfig + -- no pg_config: that PostgreSQL is gone, and its directories with it + when (not owned && havePgConfig) $ do + dirs <- installDirs pgConfig + FS.removeFileIfPresent (dirs.pkgLibDir lib <> ".so") + haveExt <- doesDirectoryExist dirs.extensionDir + when haveExt $ do + names <- listDirectory dirs.extensionDir + forM_ (filter isExtensionFile names) $ \n -> FS.removeFileIfPresent (dirs.extensionDir n) + +------------------------------------------------------------------------------- +-- the library is loaded + +-- | The version of the library the running server has loaded, empty when it has none. +loadedVersionSql :: Text +loadedVersionSql = "SELECT coalesce(current_setting('pg_textsearch.library_version', true), '')" + +-- | The verdict from 'loadedVersionSql''s output, given the declared version. +interpretLoaded :: Text -> Text -> CheckResult +interpretLoaded version out = + case Text.strip out of + "" -> Failure (libraryName <> " is not loaded in the running server: the cluster has to be restarted") + v + | v == version -> Success + | otherwise -> Failure ("the running server has " <> libraryName <> " " <> v <> " loaded, the declared release is " <> version <> ": the cluster has to be restarted") + +{- | The running server has the declared version of the library loaded. + +This node changes nothing: it is the edge between \"the files and the +setting are in place\" and everything that needs the library in the server +(its settings, @CREATE EXTENSION@). Its @up@ asks again and throws, so that +under 'RestartLeftToOperator' the dependants wait for the restart instead of +failing one by one with PostgreSQL's less direct messages. + +It is also the only node that sees a library replaced under a running +server, which no restart node does: @pending_restart@ stays false. +-} +loadedGate :: Port -> Text -> Op +loadedGate port version = + op "pg-textsearch-loaded" nodeps $ \actions -> + actions + { ref = mkRef "pg-textsearch-loaded" port + , help = Text.unwords [libraryName, version, "is loaded in the cluster on port", tshow port] + , notes = ["changes nothing: it fails until the cluster has been restarted with the library preloaded"] + , check = either (const Unknown) (interpretLoaded version) <$> ask + , up = do + out <- either (\err -> refuse ("cannot ask the cluster on port " <> tshow port <> " which library it has loaded: " <> Text.strip err)) pure =<< ask + case interpretLoaded version out of + Failure why -> refuse why + _ -> pure () + } + where + ask = Postgres.psqlQuery_Sudo port loadedVersionSql + +------------------------------------------------------------------------------- +-- settings + +-- | One declared setting. +data Setting = Setting + { settingName :: Text + , settingValue :: Text + -- ^ as @pg_settings.setting@ reports it: a bare number in the setting's unit, @on@\/@off@, or the text + , settingSql :: Text + -- ^ what @ALTER SYSTEM SET@ is given, unit included + } + deriving (Eq, Show) + +{- | The declared settings, in a stable order. Only these are written, +compared and (on the way down) reset; a @pg_textsearch.*@ setting that is +not declared is left as it is. +-} +settings :: Settings -> [Setting] +settings s = + catMaybes + [ int "default_limit" "" s.setDefaultLimit + , bool "compress_segments" s.setCompressSegments + , int "segments_per_level" "" s.setSegmentsPerLevel + , int "max_segment_size" "MB" s.setMaxSegmentSizeMb + , text "background_compaction_schedule" s.setBackgroundCompactionSchedule + , int "bulk_load_threshold" "" s.setBulkLoadThreshold + , int "memtable_pages_threshold" "" s.setMemtablePagesThreshold + , bool "allow_rls" s.setAllowRls + , bool "memtable_cache_enabled" s.setMemtableCacheEnabled + , int "memory_limit" "kB" s.setMemoryLimitKb + ] + where + name k = libraryName <> "." <> k + int k unit = fmap (\n -> Setting (name k) (tshow n) (tshow n <> unit)) + bool k = fmap (\b -> let v = if b then "on" else "off" in Setting (name k) v v) + text k = fmap (\t -> Setting (name k) t t) + +-- | One line per setting for the node's notes. +settingNotes :: Settings -> [Text] +settingNotes = fmap (\s -> s.settingName <> " = " <> s.settingSql) . settings + +{- | Reasons a declaration is refused, all of them. The ranges are the ones +the extension registers at v1.5.1; a server refuses the same values, later +and for one setting at a time. +-} +problems :: Settings -> [Text] +problems s = + concat + [ range "default_limit" 1 100000 s.setDefaultLimit + , range "segments_per_level" 2 64 s.setSegmentsPerLevel + , range "max_segment_size" 1 4095 s.setMaxSegmentSizeMb + , range "bulk_load_threshold" 0 maxInt32 s.setBulkLoadThreshold + , range "memtable_pages_threshold" 0 maxInt32 s.setMemtablePagesThreshold + , range "memory_limit" 0 maxInt32 s.setMemoryLimitKb + , [ "background_compaction_schedule is empty or has a line break in it" + | Just t <- [s.setBackgroundCompactionSchedule] + , Text.null (Text.strip t) || Text.any (`elem` ['\n', '\r']) t + ] + ] + where + maxInt32 = 2147483647 + range :: Text -> Int -> Int -> Maybe Int -> [Text] + range k lo hi mv = + [ k <> " is " <> tshow v <> ", outside " <> tshow lo <> ".." <> tshow hi + | Just v <- [mv] + , v < lo || v > hi + ] + +-- | What the running server says about one setting. +data Live = Live + { setting :: Text + , context :: Text + , pending_restart :: Bool + } + deriving (Eq, Show, Generic) + +instance Aeson.FromJSON Live + +{- | One row, one JSON object keyed by setting name. @pg_settings@ rather +than @current_setting@: it gives the value in the setting's own unit, and +the @context@ and @pending_restart@ columns this module reads instead of +assuming what a change takes. A setting whose library is not loaded has no +row. +-} +inspectSettingsSql :: [Text] -> Text +inspectSettingsSql names = + "SELECT coalesce(json_object_agg(name, json_build_object('setting', setting, 'context', context, 'pending_restart', pending_restart)), '{}') FROM pg_settings WHERE name IN (" + <> Text.intercalate ", " (fmap Postgres.quoteLiteral names) + <> ")" + +-- | The batch that sets every declared setting and reloads. +applySettingsSql :: [Setting] -> Text +applySettingsSql ss = + Text.unlines $ + ["ALTER SYSTEM SET " <> s.settingName <> " = " <> Postgres.quoteLiteral s.settingSql <> ";" | s <- ss] + <> ["SELECT pg_reload_conf();"] + +resetSettingsSql :: [Text] -> Text +resetSettingsSql names = + Text.unlines $ + ["ALTER SYSTEM RESET " <> k <> ";" | k <- names] + <> ["SELECT pg_reload_conf();"] + +{- | What differs between the declaration and the running server, one line +per setting. A value that is written and waits for a restart is said to be +so, from what PostgreSQL reports about it and not from a list kept here. +-} +settingDiffs :: [Setting] -> Map Text Live -> [Text] +settingDiffs wanted got = concatMap one wanted + where + one :: Setting -> [Text] + one s = case Map.lookup s.settingName got of + Nothing -> [s.settingName <> " is not a setting of the running server (is " <> libraryName <> " loaded, and is it this release?)"] + Just l + | l.setting == s.settingValue -> [] + | l.pending_restart || l.context == "postmaster" -> + [s.settingName <> " is " <> tshow l.setting <> ", declared " <> tshow s.settingValue <> ": it only changes at a restart (context " <> l.context <> "), which this node does not do"] + | l.context == "internal" -> [s.settingName <> " is " <> tshow l.setting <> " and cannot be set (context internal)"] + | otherwise -> [s.settingName <> " is " <> tshow l.setting <> ", declared " <> tshow s.settingValue] + +decodeLive :: Text -> Maybe (Map Text Live) +decodeLive = Aeson.decodeStrict . Text.encodeUtf8 . Text.strip + +-- | The verdict from 'inspectSettingsSql''s output. Output that is not the expected JSON is 'Unknown'. +interpretSettings :: [Setting] -> Text -> CheckResult +interpretSettings wanted out = + case decodeLive out of + Nothing -> Unknown + Just got -> case settingDiffs wanted got of + [] -> Success + diffs -> Failure (Text.intercalate "; " diffs) + +{- | The declared @pg_textsearch.*@ settings, written with @ALTER SYSTEM@ +and applied with a reload. It has no dependency of its own: the library has +to be loaded first (a server without it refuses the names), which is +'loadedGate' in 'pgTextSearch'. + +@up@ reads the values back and fails if one is not in effect, naming the +ones PostgreSQL says wait for a restart. Going down resets the declared +settings to the server's defaults, and does nothing on a server that does +not have the library loaded. +-} +settingsNode :: Track' (Binary "psql") -> Port -> Settings -> Op +settingsNode psql port s = + op "pg-textsearch-settings" (deps [justInstall psql]) $ \actions -> + actions + { ref = mkRef "pg-textsearch-settings" port + , help = Text.unwords [libraryName, "settings of the cluster on port", tshow port] + , notes = settingNotes s + , check = chk + , up = up + , down = down + } + where + declared = settings s + names = fmap (.settingName) declared + ask = Postgres.psqlQuery_Sudo port (inspectSettingsSql names) + chk = case problems s of + ps@(_ : _) -> pure (Failure (Text.intercalate "; " ps)) + [] -> either (const Unknown) (interpretSettings declared) <$> ask + up = do + let ps = problems s + unless (null ps) $ refuse (Text.intercalate "; " ps) + Postgres.psqlBatchOrThrow_Sudo port (applySettingsSql declared) + settle (20 :: Int) + -- A reload is a signal: a new session may ask before the postmaster + -- has read the files. Up to two seconds, then whatever still differs. + settle n = do + out <- either (\err -> refuse ("cannot read the settings back: " <> Text.strip err)) pure =<< ask + case interpretSettings declared out of + Success -> pure () + verdict + | n > 0 -> threadDelay 100000 >> settle (n - 1) + | otherwise -> refuse $ case verdict of + Failure why -> why + _ -> "cannot read the settings back: " <> Text.take 200 out + down = do + loaded <- Postgres.psqlQuery_Sudo port loadedVersionSql + case loaded of + Left err -> refuse ("cannot ask the cluster on port " <> tshow port <> " which library it has loaded: " <> Text.strip err) + Right v -> unless (Text.null (Text.strip v)) $ Postgres.psqlBatchOrThrow_Sudo port (resetSettingsSql names) + +------------------------------------------------------------------------------- + +{- | A cluster on which BM25 indexes can be built and used. + +In order: 'versionGate', 'releaseFiles', 'Postgres.preloadLibrary', the +restart ('Restart'), 'loadedGate', then 'settingsNode' (if anything is +declared) and one 'Postgres.extension' per database. The files come before +the preload entry, and the entry before any restart: a server asked to +preload a library it cannot find does not start. + +Under 'RestartWhenPending' the restart is a real one, of the whole cluster, +the first time and whenever anything else left a restart pending. This node +does not know whether the cluster is a primary somebody is using; declaring +it is the decision. A release replaced by a newer one is not restarted for +(PostgreSQL does not report it as pending): 'loadedGate' then fails until +somebody restarts. + +On a pair or a Patroni cluster every member needs the files and the +preload, standbys included. Declare this with no database on a standby; a +cluster-wide configuration (Patroni's) that owns @shared_preload_libraries@ +conflicts with 'Postgres.preloadLibrary' and is not handled here. + +Going down drops the extension from each database without @CASCADE@ (a +database with a BM25 index refuses, and that stops the rest), resets the +declared settings, takes the library out of the list and removes the files. +It restarts nothing: the library stays in the running server until its next +restart. A BM25 index in a database that was not declared is not seen, and +is unusable once the library is gone. +-} +pgTextSearch :: + Reporter Postgres.Report -> + Track' (Binary "psql") -> + Track' (Binary "pg_ctlcluster") -> + -- | how the databases of 'ptsDatabases' come to exist + Track' DatabaseName -> + PgTextSearch -> + Op +pgTextSearch r psql pgctl mkdb cfg = + op "pg-textsearch" (deps (configured : extensions)) $ \actions -> + actions + { ref = mkRef "pg-textsearch" cfg.ptsPort + , help = + Text.unwords + [libraryName, cfg.ptsRelease.releaseVersion, "on the postgresql", tshow cfg.ptsMajor, "cluster on port", tshow cfg.ptsPort, "in", tshow (length cfg.ptsDatabases), "database(s)"] + } + where + gate = versionGate cfg.ptsMajor cfg.ptsPort + files = releaseFiles cfg.ptsMajor cfg.ptsPgConfig cfg.ptsRelease `inject` gate + preload = Postgres.preloadLibrary psql cfg.ptsPort libraryName `inject` files + restarted = case cfg.ptsRestart of + RestartWhenPending cluster -> Postgres.restartClusterIfPending r pgctl cfg.ptsPort cluster `inject` preload + RestartLeftToOperator -> preload + loaded = loadedGate cfg.ptsPort cfg.ptsRelease.releaseVersion `inject` restarted + configured + | null (settings cfg.ptsSettings) = loaded + | otherwise = settingsNode psql cfg.ptsPort cfg.ptsSettings `inject` loaded + extensions = + [ Postgres.extension r psql cfg.ptsPort mkdb (PgExtension libraryName db (Just 170000) cfg.ptsUpgrade) `inject` loaded + | db <- cfg.ptsDatabases + ] diff --git a/src/Salmon/Builtin/Nodes/Plakar.hs b/src/Salmon/Builtin/Nodes/Plakar.hs --- a/src/Salmon/Builtin/Nodes/Plakar.hs +++ b/src/Salmon/Builtin/Nodes/Plakar.hs @@ -28,8 +28,17 @@ 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. +A local store needs nothing more. Remote stores (S3-compatible, GCS) are Plakar +integrations installed per user with @plakar pkg add@: 'plakarIntegration' +installs one, 'gcsStore' declares a GCS store under a name and 'remoteKloset' +creates the Kloset in it ('plakarJobOn' then backs up into it, addressing it as +@\@name@). S3-compatible is not done. + +__Unverified against a real plakar__ (none was available when this was +written): the output format of @pkg list@ ('interpretPkgList' is deliberately +tolerant), and the option name the GCS integration reads its credentials file +from ('gcsCredentialsOption'). Both are one-line fixes in pure functions with +tests. -} module Salmon.Builtin.Nodes.Plakar ( PlakarRelease (..), @@ -42,7 +51,20 @@ pruneArgs, PlakarJob (..), plakarJob, + plakarJobOn, + -- * Integrations and remote stores + IntegrationVersion (..), + Integration (..), + plakarIntegration, + interpretPkgList, + pkgAddArg, + GcsStore (..), + gcsStore, + gcsStoreAddArgs, + interpretStoreShow, + remoteKloset, + -- * Pieces, exposed for tests interpretVersion, interpretSnapshotList, @@ -68,7 +90,7 @@ 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 System.Process.ListLike (CreateProcess, proc) import Text.Printf (printf) import Salmon.Actions.UpDown (CheckResult (..)) @@ -236,7 +258,14 @@ 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 +plakarJob plakar job = plakarJobOn (kloset plakar job.jobStore) job + +{- | 'plakarJob' over a store node the caller supplies ('remoteKloset', say) +instead of the local 'kloset'. 'jobStore''s path is what is given to @at@, so +for a named remote store it is @\@name@. +-} +plakarJobOn :: Op -> PlakarJob -> Op +plakarJobOn storeOp job = case pruneArgs job.jobKeep of Left why -> op "plakar-job" nodeps $ \actions -> actions @@ -248,7 +277,7 @@ 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 -> + in op "plakar-job" (deps [storeOp, 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"] @@ -314,7 +343,164 @@ ------------------------------------------------------------------------------- -decode :: ByteString.ByteString -> Text +-- | Which release of an integration to install. No default: a directive always says. +data IntegrationVersion + = Pinned Text + | -- | Whatever is newest at first install. The check cannot tell newest + -- from installed, so an installed integration is never upgraded. + Latest + deriving (Eq, Show) + +-- | A Plakar integration (@gcs@, @s3@, ...), installed for one user. +data Integration = Integration + { integrationName :: Text + , integrationVersion :: IntegrationVersion + , integrationUser :: Maybe Text + -- ^ whose plugin directory it goes in: the user that runs the backup + } + deriving (Eq, Show) + +-- | The argument @pkg add@ takes: @name@ or @name\@version@. +pkgAddArg :: Integration -> Text +pkgAddArg i = case i.integrationVersion of + Latest -> i.integrationName + Pinned v -> i.integrationName <> "@" <> v + +{- | Installs an integration with @plakar pkg add@, checked against @plakar pkg +list@; @down@ is @pkg rm@. Whether @pkg add@ on an installed package is +harmless is unverified, which is why @up@ only runs when the check fails. +-} +plakarIntegration :: Track' (Binary "plakar") -> Integration -> Op +plakarIntegration plakar i = + op "plakar-integration" (deps [justInstall plakar]) $ \actions -> + actions + { help = "installs plakar integration " <> pkgAddArg i + , notes = + [ "installed for " <> maybe "the user running salmon" id i.integrationUser + , "latest means newest at first install: an installed integration is never upgraded" + ] + , ref = mkRef "plakar-integration" (i.integrationName, i.integrationUser) + , check = do + (code, out, _) <- readCreateProcessWithExitCode (asUser i.integrationUser ["plakar", "pkg", "list"]) "" + pure (interpretPkgList i code (decode out)) + , up = () <$ runAs i.integrationUser ["plakar", "pkg", "add", Text.unpack (pkgAddArg i)] + , down = () <$ runAs i.integrationUser ["plakar", "pkg", "rm", Text.unpack i.integrationName] + } + +{- | Is the integration in a @pkg list@ output? Tolerant of the format: some +line has the name as a word (or before an @\@@) and, when pinned, mentions the +version. +-} +interpretPkgList :: Integration -> ExitCode -> Text -> CheckResult +interpretPkgList _ (ExitFailure _) _ = Unknown +interpretPkgList i ExitSuccess out + | any matches (Text.lines out) = Success + | otherwise = Failure ("integration " <> pkgAddArg i <> " is not installed") + where + matches l = + let ws = concatMap (Text.splitOn "@") (Text.words l) + versioned = case i.integrationVersion of + Latest -> True + Pinned v -> v `Text.isInfixOf` l + in i.integrationName `elem` ws && versioned + +-- | A GCS store, named in plakar's per-user store configuration. +data GcsStore = GcsStore + { gcsStoreName :: Text + , gcsBucket :: Text + , gcsPrefix :: Text + -- ^ path inside the bucket, may be empty + , gcsCredentialsFile :: FilePath + -- ^ a service-account key, provisioned by somebody else; only its path is ever an argument + , gcsCredentialsOption :: Text + -- ^ the integration's option name for it (unverified: @application_credentials@ is a guess) + , gcsStoreUser :: Maybe Text + } + deriving (Eq, Show) + +-- | The arguments after @plakar store add@: name, location, credentials option. +gcsStoreAddArgs :: GcsStore -> [Text] +gcsStoreAddArgs s = + [ s.gcsStoreName + , "gcs://" <> s.gcsBucket <> (if Text.null s.gcsPrefix then "" else "/" <> Text.dropWhile (== '/') s.gcsPrefix) + , s.gcsCredentialsOption <> "=" <> Text.pack s.gcsCredentialsFile + ] + +{- | Declares the store with @plakar store add@, once the integration is +installed. @down@ is @store rm@: the configuration entry only, the bucket's +contents are not touched. Refuses at @up@ a credentials file that is missing, +empty or readable by others. +-} +gcsStore :: Op -> GcsStore -> Op +gcsStore integration s = + op "plakar-gcs-store" (deps [integration]) $ \actions -> + actions + { help = "plakar store " <> s.gcsStoreName <> " on gs://" <> s.gcsBucket + , notes = ["credentials from " <> Text.pack s.gcsCredentialsFile <> ", never copied by salmon"] + , ref = mkRef "plakar-gcs-store" (s.gcsStoreName, s.gcsStoreUser) + , check = do + (code, out, _) <- readCreateProcessWithExitCode (asUser s.gcsStoreUser ["plakar", "store", "show"]) "" + pure (interpretStoreShow s code (decode out)) + , up = do + problem <- keyfileStatus s.gcsCredentialsFile + maybe (pure ()) (\p -> ioError (userError ("credentials " <> s.gcsCredentialsFile <> ": " <> Text.unpack p))) problem + () <$ runAs s.gcsStoreUser (["plakar", "store", "add"] <> map Text.unpack (gcsStoreAddArgs s)) + , down = () <$ runAs s.gcsStoreUser ["plakar", "store", "rm", Text.unpack s.gcsStoreName] + } + +-- | The store is declared when @store show@ names it and its location. +interpretStoreShow :: GcsStore -> ExitCode -> Text -> CheckResult +interpretStoreShow _ (ExitFailure _) _ = Unknown +interpretStoreShow s ExitSuccess out + | s.gcsStoreName `Text.isInfixOf` out && ("gcs://" <> s.gcsBucket) `Text.isInfixOf` out = Success + | otherwise = Failure ("no store " <> s.gcsStoreName <> " on gs://" <> s.gcsBucket) + +{- | Creates the Kloset inside a named remote store (@plakar at \@name create@). +The check is a listing: success with nothing on stderr, since the exit code is +@0@ even when plakar could not start its cache process. +-} +remoteKloset :: Op -> Maybe Text -> Text -> FilePath -> Op +remoteKloset storeOp user name keyfile = + op "plakar-remote-kloset" (deps [storeOp]) $ \actions -> + actions + { help = "kloset in remote store @" <> name + , notes = ["passphrase from " <> Text.pack keyfile, "down does not delete the store"] + , ref = mkRef "plakar-remote-kloset" (name, user) + , check = existsNow + , up = do + problem <- keyfileStatus keyfile + maybe (pure ()) (\p -> ioError (userError ("keyfile " <> keyfile <> ": " <> Text.unpack p))) problem + _ <- runAs user ["plakar", "-keyfile", keyfile, "at", "@" <> Text.unpack name, "create"] + r <- existsNow + case r of + Success -> pure () + _ -> ioError (userError ("plakar create left no usable store @" <> Text.unpack name)) + , down = pure () + } + where + existsNow = do + (code, _, err) <- readCreateProcessWithExitCode (asUser user ["plakar", "-keyfile", keyfile, "at", "@" <> Text.unpack name, "ls", "-latest"]) "" + pure $ case code of + ExitSuccess | Text.null (Text.strip (decode err)) -> Success + ExitSuccess -> Failure ("store @" <> name <> " said: " <> Text.take 200 (decode err)) + ExitFailure _ -> Failure ("store @" <> name <> " is not usable") + +-- | @sudo -H -u USER cmd@, or the command itself. +asUser :: Maybe Text -> [String] -> CreateProcess +asUser Nothing (c : args) = proc c args +asUser Nothing [] = proc "true" [] +asUser (Just u) argv = proc "sudo" (["-H", "-u", Text.unpack u] <> argv) + +runAs :: Maybe Text -> [String] -> IO Text +runAs u argv = do + (code, out, err) <- readCreateProcessWithExitCode (asUser u argv) "" + case code of + ExitSuccess -> pure (decode out) + ExitFailure n -> throwIO (Binary.CommandFailedSimple (unwords (take 3 argv) <> ": " <> take 500 (Text.unpack (decode err))) n) + +------------------------------------------------------------------------------- + +decode ::ByteString.ByteString -> Text decode = Text.decodeUtf8With TextError.lenientDecode -- | Runs a command, throwing on a non-zero exit; returns its stdout. diff --git a/src/Salmon/Builtin/Nodes/Podman.hs b/src/Salmon/Builtin/Nodes/Podman.hs --- a/src/Salmon/Builtin/Nodes/Podman.hs +++ b/src/Salmon/Builtin/Nodes/Podman.hs @@ -16,12 +16,17 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import System.IO.Error (catchIOError) +import Text.Read (readMaybe) +import Control.Exception (Exception, throwIO) 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 (ProcessHandle, StdStream (CreatePipe), waitForProcess) import System.Process.ByteString (readCreateProcessWithExitCode) import System.Process.ListLike (CreateProcess (..), proc) @@ -146,13 +151,58 @@ r' = contramap (PullImage reg img) r r'' = contramap (RemoveImage reg img) r +{- | How @podman build@ is told what to build, beyond the Containerfile and +the tag. 'defaultBuildOptions' is what 'buildImage' has always done. + +* 'buildContext': the build context directory, i.e. what @COPY@\/@ADD@ paths + are relative to. 'Nothing' is the Containerfile's own directory (the build + runs /in/ that directory, with no context argument). A repository whose + Containerfiles live in a subdirectory but are written for the repository + root as context sets this to the root. +* 'buildTarget': the stage of a multi-stage Containerfile to stop at + (@--target@). 'Nothing' builds the last stage. Several images built from + one file are several nodes, one 'TagName' each. +* 'buildOutput': where the build's output goes while it runs (see + 'Binary.Routing'). 'Binary.captured', the default, holds it until the build + ends, as before; 'Binary.streamed' reports it line by line under the node, + which is what makes a long build something to follow. It changes nothing + about the command, so it is not part of the node's description. +-} +data BuildOptions + = BuildOptions + { buildContext :: Maybe FilePath + , buildTarget :: Maybe Text + , buildOutput :: Binary.Routing + } + deriving (Eq, Ord, Show) + +defaultBuildOptions :: BuildOptions +defaultBuildOptions = BuildOptions Nothing Nothing Binary.captured + +{- | Builds an image from a Containerfile, with that file's own directory as +the build context and no @--target@: 'buildImageWith' 'defaultBuildOptions'. +-} buildImage :: Reporter Report -> Track' (Binary "podman") -> FS.File "containerfile" -> TagName -> Op -buildImage r podman containerfile tagname = +buildImage r podman = buildImageWith r podman defaultBuildOptions + +{- | 'buildImage' with an explicit build context and\/or a @--target@ stage +(see 'BuildOptions'). + +The 'ref' is the tag alone, as for 'buildImage': a tag is one effect site +whatever it was built from, so two declarations building the same tag from +different contexts or stages are a collision, not two nodes. The options +are spelled in 'notes' when they are not the default, which is what lets +such a collision -- or a re-declaration that only moves the target -- be +seen as a differing representative. +-} +buildImageWith :: Reporter Report -> Track' (Binary "podman") -> BuildOptions -> FS.File "containerfile" -> TagName -> Op +buildImageWith r podman opts containerfile tagname = FS.withFile containerfile $ \containerfilepath -> - withBinary podman podmanCommand (Build containerfilepath tagname) $ \build -> + Binary.withBinaryWith opts.buildOutput podman podmanCommand (BuildWith opts containerfilepath tagname) $ \build -> op "podman-build" (deps []) $ \actions -> actions { help = "builds a podman image in container path and tag it" + , notes = buildNotes opts , ref = mkRef "podman-build" tagname , up = build (r' containerfilepath) , down = Binary.untrackedExec podmanCommand (RmiTag tagname) "" r'' @@ -161,6 +211,13 @@ r' containerfilepath = contramap (BuildImage containerfilepath tagname) r r'' = contramap (RemoveBuiltImage tagname) r +-- | Nothing for 'defaultBuildOptions', so a plain 'buildImage' node is +-- described exactly as it was before the options existed. +buildNotes :: BuildOptions -> [Text] +buildNotes opts = + maybe [] (\c -> ["build context: " <> Text.pack c]) opts.buildContext + <> maybe [] (\t -> ["target stage: " <> t]) opts.buildTarget + {- | 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). @@ -177,48 +234,184 @@ (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 +'up'. That is once per pass, and once per @run serve@ session: a token that +lasts an hour is not renewed by this node. 'loginExpiring' is the node for a +credential that says how long it lasts, and 'pushLoggingIn' the push that +does not rely on a login made earlier in the pass. '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 = + loginNode r podman authfile reg user $ \authenticate ext -> + ext{up = getPassword >>= authenticate} + +{- | The node 'login' and 'loginExpiring' share: one effect site (the 'Ref' +is the auth file, the registry and the username), one @down@. The +continuation is handed the action that runs @podman login@ with a password +on its stdin and fills in what differs, which is when to run it. +-} +loginNode :: + Reporter Report -> + Track' (Binary "podman") -> + AuthFile -> + Registry -> + Username -> + ((Text -> IO ()) -> Extension -> Extension) -> + Op +loginNode r podman authfile reg user fill = 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) - } + fill + (authenticateWith r mkProc authfile reg user) + actions + { help = Text.unwords ["logs in to", getRegistry reg, "via", Text.pack (getAuthFile authfile)] + , ref = mkRef "podman-login" (getAuthFile authfile, getRegistry reg, getUsername user) + , 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))) +-- | @podman login@ with the password on its stdin; throws if it is refused. +authenticateWith :: + Reporter Report -> + (() -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)) -> + AuthFile -> + Registry -> + Username -> + Text -> + IO () +authenticateWith r mkProc authfile reg user pw = do + runReporter r (LoginRegistry authfile reg user) + (mStdin, _, _, ph) <- mkProc () + case mStdin of + Just hin -> Text.hPutStr hin pw >> hClose hin + Nothing -> pure () + waitForProcess ph >>= checkExitCode "podman login" + +-- | A password and how long it is good for from when it was handed out. +data Credential + = Credential + { credentialSecret :: !Text + , credentialLifetime :: !NominalDiffTime + } + +{- | 'login' for a credential that says when it expires (an OAuth access +token: an hour, typically), which is what makes a @check@ possible. + +'login' has none, so it runs once per pass and, under @run serve@, once per +session: its verdict is 'Salmon.Actions.UpDown.Immaterial', the node is +parked, the token lapses, and whatever next reads the auth file fails with +credentials that look present. Here the expiry is written beside the auth +file after a login that worked ('loginStampPath'), and 'interpretLoginStamp' +answers 'Success' while more than 'loginRefreshMargin' of it is left. So a +@run up@ logs in again only when it has to, and under @run serve@ the +credential is /tended/: the check starts failing two minutes before the +expiry and the loop logs in again. + +What this does not do is renew anything /inside/ one pass: a node is +applied once, so a push that starts an hour after the login of the same +pass still reads a lapsed credential. 'pushLoggingIn' is for that. + +A credential whose lifetime is not above the margin cannot be tended (the +check would fail the moment the login succeeded) and @up@ refuses it, +'CredentialTooShort'; use 'login' for one of those. + +The same effect site as 'login', so the same 'Ref'. +-} +loginExpiring :: Reporter Report -> Track' (Binary "podman") -> AuthFile -> Registry -> Username -> IO Credential -> Op +loginExpiring r podman authfile reg user getCredential = + loginNode r podman authfile reg user (expiring authfile getCredential) + +{- | What 'loginExpiring' adds to the login node, given the action that +authenticates with a password. Exposed for tests, which have no registry to +log in to. + +It goes on the login node /alone/. An 'fmap' over the 'Op' reaches every +node of its graph, the enclosing directory of the auth file included, and +that directory is a predecessor: carrying the stamp's check and the stamp's +write, it went first, found the stamp expired, and wrote a fresh one without +logging in -- after which the login's own check read the fresh stamp and the +login was skipped, leaving expired credentials in the auth file under a +stamp vouching for them. +-} +expiring :: AuthFile -> IO Credential -> (Text -> IO ()) -> Extension -> Extension +expiring authfile getCredential authenticate ext = + ext + { notes = ext.notes <> ["renewed before the credential's recorded expiry"] + , check = do + now <- getCurrentTime + present <- doesFileExist (getAuthFile authfile) + recorded <- if present then readStamp else pure Nothing + pure (interpretLoginStamp now recorded) + , up = do + -- read before the credential is asked for: its lifetime counts + -- from when it was handed out, so this errs on the early side + asked <- getCurrentTime + credential <- getCredential + when (credential.credentialLifetime <= loginRefreshMargin) $ + throwIO (CredentialTooShort credential.credentialLifetime) + authenticate credential.credentialSecret + -- only ever written after a login that worked: 'authenticate' + -- throws otherwise + writeFile stamp (renderLoginStamp (addUTCTime credential.credentialLifetime asked)) + , down = FS.removeFileIfPresent stamp >> ext.down + } + where + stamp = loginStampPath authfile + + readStamp :: IO (Maybe Text) + readStamp = (Just <$> Text.readFile stamp) `catchIOError` const (pure Nothing) + +data LoginError + = -- | the credential's lifetime, which 'loginRefreshMargin' already covers + CredentialTooShort !NominalDiffTime + deriving (Show) + +instance Exception LoginError + +-- | Where the expiry of the credential in an auth file is recorded. +loginStampPath :: AuthFile -> FilePath +loginStampPath authfile = getAuthFile authfile <> ".expires" + +-- | The stamp: the expiry in whole seconds since the epoch. +renderLoginStamp :: UTCTime -> String +renderLoginStamp expiry = show (floor (utcTimeToPOSIXSeconds expiry) :: Integer) <> "\n" + +-- | How much of a credential's life must be left for it to be left alone. +loginRefreshMargin :: NominalDiffTime +loginRefreshMargin = 120 + +{- | Is the recorded login still good? 'Nothing' is no stamp, or no auth file +to go with it. +-} +interpretLoginStamp :: UTCTime -> Maybe Text -> CheckResult +interpretLoginStamp _ Nothing = Failure "not logged in to the registry" +interpretLoginStamp now (Just recorded) = + case readMaybe (Text.unpack (Text.strip recorded)) :: Maybe Integer of + Nothing -> Failure "the recorded token expiry is unreadable" + Just seconds + | diffUTCTime (posixSecondsToUTCTime (fromInteger seconds)) now > loginRefreshMargin -> Success + | otherwise -> Failure "the registry token has expired, or is about to" + {- | Pushes a locally-tagged image to whatever registry its tag names. Deliberately takes only the one 'TagName' rather than a separate @@ -250,8 +443,62 @@ 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. +{- | 'push' that logs in again first, in the same @up@. + +A node is applied once per pass, so a 'login' the push depends on ran when +the pass reached it -- before the build, if the push also depends on one -- +and an hour-long token can have lapsed by the time the push starts +(@unauthorized@, with credentials that look present). Nothing about the +login node can fix that from where it stands, whatever its check says: the +pass is past it. So the credential is asked for and the registry logged in to +right before the bytes go, which costs one @podman login@ beside a push. + +It does not replace the login node: declare one on the same 'AuthFile' and +make this depend on it, as with 'push'. That node is what logs out and +removes the file on the way down; this one's @down@ is a no-op like +'push''s. Same effect site as @'push' (Just authfile)@, so the same 'Ref'. + +Beside a 'loginExpiring' node the stamp is left as it was: it then +understates the credential in the file, which is the safe direction. +-} +pushLoggingIn :: Reporter Report -> Track' (Binary "podman") -> AuthFile -> Registry -> Username -> IO Text -> TagName -> Op +pushLoggingIn r podman authfile reg user getPassword tagname = + withBinaryIO podman logincommand (LoginCmd authfile reg user) $ \mkProc -> + withBinary podman podmanCommand (Push (Just authfile) tagname) $ \doPush -> + op "podman-push" (deps []) $ \actions -> + actions + { help = "pushes " <> tagname <> " to its registry" + , notes = ["logs in to " <> getRegistry reg <> " again before pushing"] + , ref = mkRef "podman-push" (tagname, Just (getAuthFile authfile)) + , up = loggingInThen (getPassword >>= authenticateWith r mkProc authfile reg user) (doPush r') + } + where + r' = contramap (PushImage (Just authfile) tagname) r + +{- | Log in, then act; a login that fails is the failure, and the action is +not attempted with whatever the auth file held before. +-} +loggingInThen :: IO () -> IO () -> IO () +loggingInThen authenticate act = authenticate >> act + +{- | Runs a detached container under a caller-chosen 'ContainerName' (so +'down' has a stable target to remove), with the given ports/env/volumes/network. + +The name is the effect site, as for 'down' (which removes whatever runs under +it). The @check@ asks podman for the container's state under that name +('probeContainer', 'interpretContainerState'): @running@ is in place and +skipped, no container (or a leftover that is not running) is to apply, and a +state podman is moving through (@paused@, @stopping@, @removing@) or a podman +that cannot answer is 'Unknown'. Only the name is compared: a running +container started from another image or with other options under the same +name reads as in place. + +@up@ clears a leftover first: a container under the name that is not running +(@created@ by a run that failed at start, @exited@, @stopped@) is removed with +@podman rm@ (no @-f@, so one that started meanwhile is refused, not killed), +then @podman run@ as before. A running or paused container is left alone and +the run fails on the name, as it always did. +-} 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 -> @@ -259,13 +506,78 @@ actions { help = "runs a podman container" , ref = mkRef "podman-run" (getContainerName cname) - , up = run r' + , check = interpretContainerState cname <$> probeContainer cname + , up = do + st <- probeContainer cname + when (isRemovableLeftover st) $ + Binary.untrackedExec podmanCommand (RmStopped cname) "" r'' + run r' , down = Binary.untrackedExec podmanCommand (Rm cname) "" r'' } where r' = contramap (RunContainer reg img cname opts) r r'' = contramap (RemoveContainer cname) r +-- | What podman says is under a container name. +data ContainerState + = -- | @podman container exists@ said no (exit 1). + ContainerAbsent + | -- | @.State.Status@ as @podman container inspect@ printed it, stripped. + ContainerStatus !Text + | -- | podman did not answer either question (an exit other than 0\/1, a broken store). + ContainerUnanswered + deriving (Eq, Show) + +{- | @podman container exists NAME@, then, if it does, +@podman container inspect --format {{.State.Status}} NAME@. +-} +probeContainer :: ContainerName -> IO ContainerState +probeContainer cname = do + (existsCode, _, _) <- readCreateProcessWithExitCode (proc "podman" (containerExistsArgs cname)) "" + case existsCode of + ExitSuccess -> do + (code, out, _) <- readCreateProcessWithExitCode (proc "podman" (containerStatusArgs cname)) "" + pure (containerStateFrom existsCode (Just (code, Text.pack (ByteString.unpack out)))) + _ -> pure (containerStateFrom existsCode Nothing) + +containerExistsArgs :: ContainerName -> [String] +containerExistsArgs cname = ["container", "exists", Text.unpack (getContainerName cname)] + +containerStatusArgs :: ContainerName -> [String] +containerStatusArgs cname = ["container", "inspect", "--format", "{{.State.Status}}", Text.unpack (getContainerName cname)] + +{- | The state from the two commands' answers: @exists@'s exit code, and +@inspect@'s exit code and output when it was asked (only after @exists@ said 0). +-} +containerStateFrom :: ExitCode -> Maybe (ExitCode, Text) -> ContainerState +containerStateFrom (ExitFailure 1) _ = ContainerAbsent +containerStateFrom ExitSuccess (Just (ExitSuccess, out)) + | Text.null status = ContainerUnanswered + | otherwise = ContainerStatus status + where + status = Text.toLower (Text.strip out) +containerStateFrom _ _ = ContainerUnanswered + +-- | States of a container that is not running and is not going anywhere: what a failed or ended run leaves behind. +leftoverStatuses :: [Text] +leftoverStatuses = ["configured", "created", "initialized", "exited", "stopped"] + +-- | A container 'runContainer''s @up@ removes before running: there, and not running. +isRemovableLeftover :: ContainerState -> Bool +isRemovableLeftover (ContainerStatus s) = s `elem` leftoverStatuses +isRemovableLeftover _ = False + +interpretContainerState :: ContainerName -> ContainerState -> CheckResult +interpretContainerState cname st = case st of + ContainerAbsent -> Failure ("no podman container named " <> n) + ContainerStatus "running" -> Success + ContainerStatus s + | s `elem` leftoverStatuses -> Failure ("the podman container " <> n <> " is " <> s <> ", not running") + | otherwise -> Unknown + ContainerUnanswered -> Unknown + where + n = getContainerName cname + -- | 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). @@ -295,13 +607,17 @@ data PodmanCommand = Pull !Registry !Image | Run !Registry !Image !ContainerName !RunOptions - | Build !FilePath !TagName + | -- | 'BuildWith' 'defaultBuildOptions'. + Build !FilePath !TagName + | BuildWith !BuildOptions !FilePath !TagName | Push !(Maybe AuthFile) !TagName | Logout !AuthFile !Registry | CreateNetworkCmd !NetworkName | Rmi !Registry !Image | RmiTag !TagName | Rm !ContainerName + | -- | @podman rm@ without @-f@: refused for a running container. + RmStopped !ContainerName | RemoveNetworkCmd !NetworkName podmanCommand :: Command "podman" PodmanCommand @@ -312,18 +628,8 @@ [ "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 - } + (Build fullpath tagname) -> buildProc defaultBuildOptions fullpath tagname + (BuildWith opts fullpath tagname) -> buildProc opts fullpath tagname (Push mAuthFile tagname) -> proc "podman" $ -- --authfile is a flag of `podman push`, not a global option: @@ -383,8 +689,32 @@ proc "podman" ["rmi", "--ignore", Text.unpack tagname] (Rm cname) -> proc "podman" ["rm", "-f", Text.unpack (getContainerName cname)] + (RmStopped cname) -> + proc "podman" ["rm", Text.unpack (getContainerName cname)] (RemoveNetworkCmd name) -> proc "podman" ["network", "rm", Text.unpack (getNetworkName name)] + +{- | @podman build@, in one of two shapes. + +With no explicit context the build runs /in/ the Containerfile's directory, +naming the file by its basename and giving no context argument (podman then +takes the working directory) -- the shape this module always rendered. + +With one, the working directory is left alone and both paths are passed as +given: @-f@ the Containerfile, the context as the positional argument. A +relative path is then relative to wherever the salmon process runs, for +both alike. +-} +buildProc :: BuildOptions -> FilePath -> TagName -> CreateProcess +buildProc opts fullpath tagname = case opts.buildContext of + Nothing -> + (proc "podman" (["build", "-t", Text.unpack tagname, "-f", takeFileName fullpath] <> target)) + { cwd = Just $ takeDirectory fullpath + } + Just context -> + proc "podman" (["build", "-t", Text.unpack tagname, "-f", fullpath] <> target <> [context]) + where + target = maybe [] (\t -> ["--target", Text.unpack t]) opts.buildTarget ------------------------------------------------------------------------------- diff --git a/src/Salmon/Builtin/Nodes/Podman/Quadlet.hs b/src/Salmon/Builtin/Nodes/Podman/Quadlet.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/Podman/Quadlet.hs @@ -0,0 +1,1551 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | A container as a systemd service, declared as a podman /quadlet/. + +"Salmon.Builtin.Nodes.Podman" can pull an image and @podman run@ a container, +and "Salmon.Builtin.Nodes.Systemd" can author a unit, but neither says "this +image runs as a service on this machine": a @podman run -d@ container is +gone at the next reboot, and a hand-written unit around @podman run@ has to +get the cid file, the @--replace@, the notify socket and the stop command +right. Quadlet is podman's own answer: a @NAME.container@ file in a +directory a systemd generator reads, turned into @NAME.service@ on every +@daemon-reload@. + +'quadletContainer' is 'Salmon.Builtin.Nodes.Systemd.systemdService' for that +file, and reuses its mechanism rather than adding one: + +* the file is written through 'Salmon.Builtin.Nodes.Filesystem.filecontents', + so identical bytes leave its mtime alone; +* the @check@ starts with the same @systemctl show@, because systemd answers + @NeedDaemonReload=yes@ for a generated unit whose /source/ file changed + (the generator writes @SourcePath=@) -- so a new image reference is a + changed file, a stale unit, and a reload and restart; +* and then asks the /running container/ which quadlet it was started from + (see 'quadletLabel'), because @daemon-reload@ is machine-wide: once + anything else has run one, systemd no longer remembers that this file + changed, and a unit still running the old container reads as current; +* the env file (and anything else the caller names in 'containerWatched') is + hashed into a trailing comment, as + 'Salmon.Builtin.Nodes.Systemd.systemdServiceWatching' does, so a changed + env file is a changed quadlet too. Unlike there, the hash is /keyed/ (see + "The watched files' digest" below). + +Three differences from an authored unit, each of which was a surprise first. +A generated unit's @UnitFileState@ is @generated@ and it cannot be +@systemctl enable@d: the @[Install]@ section is honoured by the generator +itself, so @up@ is reload and restart, with no enable. Removing the file does +not remove the unit until the next reload, so the file node's @down@ reloads +after removing. And an image that is not on the machine is pulled /by the +service's start/ -- which, on a restart, is after the old container was +stopped. So 'quadletContainer' pulls it first, as a node of its own that the +file stands on ('imageNode'): an image that cannot be pulled fails there, +with the old file, the old unit and the old container untouched. + +What "changed" means is "the declaration or a watched file changed". An image reference that stays +the same while the registry moves what it points at (@:latest@) is not a +change this node can see; name images by a tag that moves with the content, +or by digest. + += The watched files' digest + +The quadlet file is world-readable, the unit generated from it +(@\/run\/systemd\/generator@) is too, and @systemctl show@ prints its +@ExecStart=@, label included, to any local user. The env file is usually +@0600@ and holds secrets. A plain hash of it in any of those places lets +whoever reads them check guesses at its contents offline, which is all it +takes when the only unknown in the file is a short or human-chosen value. It +is the reason "Salmon.Builtin.Nodes.SecretDelivery" puts no digest of a +secret anywhere. + +So the trailing comment is an HMAC-SHA256 of the watched files under a key +only the owner of the quadlet directory can read ('watchKeyPath', made once +by 'watchKeyNode', 32 random bytes, @0600@), and 'quadletFingerprint', which +hashes that comment in, says nothing either without the key. The change +detection is what it was: same files, same key, same line. The key never +leaves the machine and is never removed by @down@, since a new key is a new +fingerprint for every quadlet in the directory. A declaration that watches +nothing has no secret to digest, needs no key, and is the file and the nodes +it always was. + +Containers started before the key existed carry a label made from the plain +hash ('unkeyedFingerprint'). They are not restarted for it: the check accepts +that label as long as it is the one the /current/ declaration and files would +have had, and @up@, finding the file rewritten for the key alone, reloads +without restarting ('interpretAdoptable'). The old label stays on that +container, where only its owner's @podman inspect@ reads it, until its next +restart for a reason of its own. + += Jobs + +A container can also be a /job/: a command run in the image to completion +('containerExec', 'containerLifetime', and 'containerJob' to start from). +Its service is @Type=oneshot@, for which the generator runs the container in +the foreground, so starting the unit returns when the command has exited and +fails if it failed. 'quadletJob' is the node for it and differs from +'quadletContainer' as 'Salmon.Builtin.Nodes.Systemd.Job.jobService' differs +from a service: it installs the unit and starts nothing. A +'Salmon.Builtin.Nodes.Systemd.Job.timerUnit' naming 'serviceTarget' schedules +it, a 'Salmon.Builtin.Nodes.Systemd.Job.runJob' runs it now. + +Whether its last run /succeeded/ is +'Salmon.Builtin.Nodes.Systemd.Job.completedRun''s question, asked of +'containerCompletion'; 'completedQuadletJob' is the two together. systemd +forgets a successful run of a unit nothing keeps loaded, a generated one +included, so a container job with no timer waiting on it is only skipped by +the next pass when it leaves a stamp ('containerStamp'). + += Readiness + +The generated service is @Type=notify@ over @podman run --sdnotify=conmon@: +systemd is told "started" when the container /exists/, not when what is in it +works. So @systemctl restart@ returns 0 for a container whose entrypoint +exits a moment later, and a pass reported such a node done while systemd was +still restarting it into @failed@. 'containerReady' is the opt-in answer, and +it lives in @up@ alone: after the restart, 'awaitReady' waits for a 'Probe' +to succeed (if one is declared) and then for the unit to stay @active@ with +no restart for 'readyHold' seconds, and @up@ throws 'NotReady' otherwise. +Nothing of it is rendered, so declaring it (or not) leaves the file, the +fingerprint and the running container alone. + += Bind volumes + +'containerVolumes' renders a @Volume=@ line and nothing else: the host path +is the caller's, existing before the start, and whoever the image makes its +owner owns it afterwards. 'containerBinds' is the declaration that says more +('Bind', 'bind' to start from): the options podman takes after the access +mode (@:U@, @:z@, @:Z@), and a host /directory/ this module creates +('hostDirNode') ahead of the quadlet file, with an owner and a mode if any +are stated. @down@ never removes such a directory: it holds what the +container wrote. A declaration with no binds is the file, the fingerprint and +the nodes it always was. + += Whose files they are + +Rootless, the container's uids are the operator's subordinate ones: what a +server running as uid 70 writes into a bind belongs, on the host, to something +like uid 100069, and the operator can neither list nor back up the directory +without @podman unshare@. @:U@ ('bindChown') does not change that; it chowns +to that same subordinate uid. 'containerKeepId' does: @UserNS=keep-id@ maps +the operator to one uid /inside/ the container (their own, or the one the +image runs as, 'keepIdAs'), and the container's process runs as it, so what it +writes is the operator's on the host. It is a user-scope option, refused for +'Systemd.System' (rootful podman refuses it too), and 'Nothing' renders +nothing. + +Needs podman 4.4 or later (quadlet's first release). Only keys that 4.9 +understands are rendered -- the registry credentials go through +@PodmanArgs=--authfile=@ rather than the @AuthFile=@ key, which 4.9's +generator refuses as unsupported. +-} +module Salmon.Builtin.Nodes.Podman.Quadlet ( + Container (..), + Bind (..), + Relabel (..), + KeepId (..), + keepId, + keepIdAs, + renderKeepId, + keepIdProblems, + HostDir (..), + bind, + hostDir, + renderBind, + bindProblems, + hostDirNode, + hostDirNodes, + chownArgs, + interpretHostDir, + HostDirFailed (..), + RestartPolicy (..), + Lifetime (..), + Readiness (..), + Probe (..), + stillUp, + readyWhen, + describeReadiness, + UnitSample (..), + parseSample, + sampleArgs, + interpretStanding, + Waiting (..), + awaitReady, + NotReady (..), + container, + containerJob, + quadletContainer, + quadletJob, + containerCompletion, + completedQuadletJob, + serviceTarget, + quadletPath, + systemQuadletDir, + renderContainer, + renderContainerWatching, + renderQuadlet, + quadletFingerprint, + unkeyedFingerprint, + quadletLabel, + watchKeyPath, + watchKeyNode, + ensureWatchKey, + interpretWatchKey, + keyedWatchLine, + Systemd.WatchKeyUnusable (..), + watchedFiles, + containerProblems, + interpretShow, + interpretRunning, + interpretStarted, + interpretAdoptable, + checkJobInstalled, + interpretGenerated, + imageNode, + imagePresentArgs, + imagePullArgs, + interpretImagePresent, + ImageUnavailable (..), + checkContainer, + InvalidContainer (..), +) where + +import Control.Concurrent (threadDelay) +import Control.Exception (Exception, SomeException, bracket, onException, throwIO, try) +import Control.Monad (unless, when) +import qualified Data.ByteString as ByteString +import Data.Char (isOctDigit, isSpace) +import Data.List (find) +import Data.Maybe (maybeToList) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import GHC.Clock (getMonotonicTimeNSec) +import Numeric (readOct) +import qualified Network.Socket as Net +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist, removeDirectory, removeFile) +import System.Exit (ExitCode (..)) +import System.FilePath (isAbsolute, ()) +import System.Posix.Files (setFileMode) +import System.Posix.Types (FileMode) +import System.Process (proc, readCreateProcessWithExitCode) +import Text.Read (readMaybe) + +import Salmon.Actions.UpDown (CheckResult (..)) +import Salmon.Builtin.Extension +import Salmon.Builtin.Nodes.Binary (Binary, withBinary) +import qualified Salmon.Builtin.Nodes.Binary as Binary +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Podman as Podman +import Salmon.Builtin.Nodes.Readiness (Probe (..), describeProbe, runProbe) +import qualified Salmon.Builtin.Nodes.Systemd as Systemd +import qualified Salmon.Builtin.Nodes.Systemd.Job as Job +import Salmon.Op.OpGraph (OpGraph (..), inject) +import Salmon.Op.Ref +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- + +-- | The @Restart=@ systemd applies to the generated service. +data RestartPolicy + = RestartNo + | RestartOnFailure + | RestartAlways + deriving (Eq, Ord, Show) + +-- | Whether the container is expected to stay or to finish. +data Lifetime + = -- | a service: started, kept running + LongRunning + | -- | a job: @Type=oneshot@, the unit is done when the command exits + RunToCompletion + deriving (Eq, Ord, Show) + +{- | What 'quadletContainer''s @up@ waits for after the restart, before it +calls the container up. See 'awaitReady' for the order of things. +-} +data Readiness + = Readiness + { readyProbe :: Maybe Probe + , readyTimeout :: Int + -- ^ seconds the probe has to succeed for the first time, counted from + -- the restart returning. Unused without a probe. + , readyHold :: Int + -- ^ seconds the unit must then stay @active@ with no restart by + -- systemd. A container that dies at boot is restarted within a second + -- or so under @Restart=on-failure@; a few seconds sees it. + } + deriving (Eq, Ord, Show) + +-- | No probe: the unit stays @active@, unrestarted, for this many seconds. +stillUp :: Int -> Readiness +stillUp hold = Readiness{readyProbe = Nothing, readyTimeout = 0, readyHold = hold} + +{- | This probe succeeds within the timeout (seconds), and the unit is still +standing, unrestarted, three seconds later. +-} +readyWhen :: Probe -> Int -> Readiness +readyWhen probe seconds = Readiness{readyProbe = Just probe, readyTimeout = seconds, readyHold = 3} + +-- | One line for the node's @notes@, and the wording of a failed wait. +describeReadiness :: Readiness -> Text +describeReadiness rd = + Text.intercalate ", then " $ + [describeProbe p <> " within " <> seconds rd.readyTimeout | p <- maybeToList rd.readyProbe] + <> ["active with no restart for " <> seconds rd.readyHold] + where + seconds n = Text.pack (show n) <> "s" + +-- | The SELinux relabelling podman does on a bind's host path. +data Relabel + = -- | @:z@, a label several containers can share + RelabelShared + | -- | @:Z@, a label private to this container + RelabelPrivate + deriving (Eq, Ord, Show) + +{- | A host directory this module creates for a 'Bind'. Owner and mode are +the directory's /at creation/: one that already exists is left exactly as it +is, whoever owns it. An image's entrypoint commonly takes its data directory +for its own user at first start (postgres does), and a pass that set the +declared owner back would pull the directory from under a running server. +-} +data HostDir + = HostDir + { hostDirOwner :: Maybe Text + -- ^ what @chown@ is given: @USER@, @USER:GROUP@, or the numeric forms. + -- Naming anyone but oneself needs root, so in 'Systemd.User' scope it + -- fails the node, and the directory is not left behind half-made. + , hostDirMode :: Maybe Text + -- ^ octal, three or four digits (@0750@). 'Nothing' is whatever the + -- umask of the salmon process gives. + } + deriving (Eq, Ord, Show) + +-- | A directory created with no owner and no mode stated. +hostDir :: HostDir +hostDir = HostDir{hostDirOwner = Nothing, hostDirMode = Nothing} + +{- | A host directory mounted in the container, with what 'Podman.VolumeMount' +cannot say. Rendered as one more @Volume=@ line, after 'containerVolumes'. +-} +data Bind + = Bind + { bindHostPath :: FilePath + , bindGuestPath :: FilePath + , bindMode :: Podman.VolumeMode + , bindChown :: Bool + -- ^ @:U@: podman chowns the host path, recursively, to the container's + -- user at /every start/. Rootless, that is a subordinate uid of the + -- operator's, so the operator can neither list nor remove the directory + -- without @podman unshare@. It says who owns the data; it does not make + -- it readable from the host. + , bindRelabel :: Maybe Relabel + , bindCreate :: Maybe HostDir + -- ^ 'Nothing': the directory is the caller's, as for 'containerVolumes' + } + deriving (Eq, Ord, Show) + +{- | A read-write bind of this host directory at this path in the container, +the directory created if it is missing, with no owner, mode or option stated. +-} +bind :: FilePath -> FilePath -> Bind +bind host guest = + Bind + { bindHostPath = host + , bindGuestPath = guest + , bindMode = Podman.ReadWrite + , bindChown = False + , bindRelabel = Nothing + , bindCreate = Just hostDir + } + +-- | The value of a 'Bind''s @Volume=@ line: @HOST:GUEST:rw[,U][,z|,Z]@. +renderBind :: Bind -> Text +renderBind b = + mconcat + [ Text.pack b.bindHostPath + , ":" + , Text.pack b.bindGuestPath + , ":" + , Text.intercalate "," $ + mconcat + [ [volumeModeWord b.bindMode] + , ["U" | b.bindChown] + , ["z" | b.bindRelabel == Just RelabelShared] + , ["Z" | b.bindRelabel == Just RelabelPrivate] + ] + ] + +volumeModeWord :: Podman.VolumeMode -> Text +volumeModeWord Podman.ReadOnly = "ro" +volumeModeWord Podman.ReadWrite = "rw" + +{- | Why this bind cannot be declared, if it cannot. A path with a colon in +it would be read by podman as another field of the @Volume=@ value, and a +relative host path as the name of a volume, which is no directory to create. +-} +bindProblems :: Bind -> [Text] +bindProblems b = + mconcat + [ ["the bind's host path is not an absolute path: " <> host | not (isAbsolute b.bindHostPath)] + , ["the bind's guest path is not an absolute path: " <> guest | not (isAbsolute b.bindGuestPath)] + , ["a colon in the bind's " <> what <> ": " <> value | (what, value) <- [("host path", host), ("guest path", guest)], Text.any (== ':') value] + , [ "the bind of " <> host <> " states an owner and :U, which says another at every start" + | Just HostDir{hostDirOwner = Just _} <- [b.bindCreate] + , b.bindChown + ] + , [ "the owner of " <> host <> " is not what chown takes: " <> o + | Just HostDir{hostDirOwner = Just o} <- [b.bindCreate] + , Text.null o || "-" `Text.isPrefixOf` o || Text.any isSpace o + ] + , [ "the mode of " <> host <> " is not three or four octal digits: " <> m + | Just HostDir{hostDirMode = Just m} <- [b.bindCreate] + , Text.length m `notElem` [3, 4] || not (Text.all isOctDigit m) + ] + ] + where + host = Text.pack b.bindHostPath + guest = Text.pack b.bindGuestPath + +{- | @UserNS=keep-id@: the user namespace of a rootless container, with the +user running podman mapped to one uid and gid inside it instead of to the +container's root, and the container's process run as that uid and gid. + +Without the fields, the uid and gid inside are the user's own on the host +(1000 is 1000): right for an image that runs as whoever it is started as. +With them, they are the stated ones: 'keepIdAs' 70 70 for an image whose +server is uid 70, which then finds its data directory its own while the host +sees the operator's files. Either way the process no longer starts as the +container's root, so an entrypoint that needs root to prepare something +(chown its data directory, bind a port under 1024) does not get to. + +A directory the container already wrote under the default mapping belongs to +a subordinate uid, which the new mapping reads as some other user's: the +container cannot open its own data. 'bindChown' on that bind (@:U@) is the +migration: podman chowns the path to the container's user at start, which +under @keep-id@ is the operator. +-} +data KeepId + = KeepId + { keepIdUid :: Maybe Int + -- ^ @uid=@: the uid inside the container the user is mapped to + , keepIdGid :: Maybe Int + -- ^ @gid=@, likewise. Stating the uid alone leaves the gid the user's own. + } + deriving (Eq, Ord, Show) + +-- | @keep-id@: the user is the same uid and gid inside as outside. +keepId :: KeepId +keepId = KeepId{keepIdUid = Nothing, keepIdGid = Nothing} + +-- | @keep-id:uid=UID,gid=GID@: the user is this uid and gid inside. +keepIdAs :: Int -> Int -> KeepId +keepIdAs uid gid = KeepId{keepIdUid = Just uid, keepIdGid = Just gid} + +-- | The value of the @UserNS=@ line. +renderKeepId :: KeepId -> Text +renderKeepId k = case options of + [] -> "keep-id" + _ -> "keep-id:" <> Text.intercalate "," options + where + options = + [ key <> "=" <> Text.pack (show n) + | (key, Just n) <- [("uid" :: Text, k.keepIdUid), ("gid", k.keepIdGid)] + ] + +{- | Why this mapping cannot be declared in this scope, if it cannot. Rootful +podman answers that keep-id is only supported in rootless mode, at the start, +which is after the old container was stopped; it is said here instead. +-} +keepIdProblems :: Systemd.Scope -> KeepId -> [Text] +keepIdProblems scope k = + mconcat + [ [ "keep-id maps the user running a rootless container, and a system-scope container is root's: state the owner with the bind instead" + | Systemd.System <- [scope] + ] + , [ "the keep-id " <> what <> " is not an id: " <> Text.pack (show n) + | (what, Just n) <- [("uid" :: Text, k.keepIdUid), ("gid", k.keepIdGid)] + , n < 0 || n > 65535 + ] + ] + +{- | One container run as a service. 'container' is the starting point; set +the rest with record update. +-} +data Container + = Container + { containerScope :: Systemd.Scope + , containerUnitDir :: FilePath + -- ^ where the generator looks: 'systemQuadletDir' for 'Systemd.System', a + -- caller-resolved @~\/.config\/containers\/systemd@ for 'Systemd.User' + -- (the same "resolve before constructing" rule as + -- 'Systemd.config_unit_dir') + , containerName :: Podman.ContainerName + -- ^ names the file (@NAME.container@), the unit (@NAME.service@) and the + -- container itself + , containerImage :: Text + -- ^ the full reference, registry included + -- (@europe-west1-docker.pkg.dev\/project\/repo\/app:v3@); podman does not + -- guess a registry for a short name under systemd + , containerExec :: [Text] + -- ^ the command run in the container, as an argv; empty is the image's + -- own. Each word reaches the container as written + -- ('Systemd.literalArg'). + , containerLifetime :: Lifetime + , containerDescription :: Text + , containerAfter :: [Systemd.UnitTarget] + , containerEnvFile :: Maybe FilePath + -- ^ an @EnvironmentFile=@, read by podman on the host at every start; it + -- is pre-provisioned by something else and only watched here + , containerPorts :: [Podman.PortMapping] + , containerVolumes :: [Podman.VolumeMount] + , containerBinds :: [Bind] + -- ^ host directories mounted with options, and created by this module + -- when the bind says so ('hostDirNode'). Rendered after + -- 'containerVolumes'; empty renders nothing and adds no node, so a + -- declaration without any is the file it always was. + , containerKeepId :: Maybe KeepId + -- ^ @UserNS=keep-id@, for 'Systemd.User' scope only (refused otherwise): + -- what the container writes into a bind is the operator's on the host. + -- 'Nothing' renders nothing, so a declaration without it is the file it + -- always was; setting it on a running container is a changed quadlet, + -- and so one restart. + , containerNetwork :: Maybe Text + , containerAuthFile :: Maybe Podman.AuthFile + -- ^ the credentials the start's pull uses, the file 'Podman.login' wrote + , containerRestart :: RestartPolicy + , containerStartTimeout :: Maybe Int + -- ^ @TimeoutStartSec=@, in seconds. The start includes the pull when the + -- image is not on the machine yet, and systemd's default (90s) is short + -- for a large image on a small machine. 'quadletContainer' pulls ahead + -- of the start ('imageNode'), outside this timeout; a job's first run + -- ('quadletJob') and a start at boot after the image was removed do not. + , containerWantedBy :: Maybe Systemd.UnitTarget + -- ^ what starts it at boot; 'Nothing' for a service that is only ever + -- started by hand or by salmon + , containerWatched :: [FilePath] + -- ^ other host files the container reads at start (a bind-mounted + -- config), a change to which should restart it + , containerStamp :: Maybe FilePath + -- ^ for a job only ('RunToCompletion'; refused otherwise): a file on the + -- /host/ the unit keeps as the record of its last successful run, as + -- 'Job.jobStamp' does and with the same two lines in @[Service]@. Each + -- run touches @STAMP.running@ before the container starts and renames it + -- to @STAMP@ once the container's command exited 0. The directory is the + -- caller's: existing, and writable by whoever the unit runs as (root in + -- 'Systemd.System', the user in 'Systemd.User'). 'Nothing' renders + -- nothing, so a declaration without it is the file it always was. + , containerReady :: Maybe Readiness + -- ^ for a service only ('LongRunning'; refused otherwise): what @up@ + -- waits for after the restart ('awaitReady'), failing if it does not + -- come. 'Nothing' is @up@ as it always was: done when @systemctl + -- restart@ returns, which for a container means "it exists". Never + -- rendered: the file, its fingerprint and the label are the same with + -- and without it. + } + deriving (Eq, Show) + +-- | The directory the system generator reads for administrator-written units. +systemQuadletDir :: FilePath +systemQuadletDir = "/etc/containers/systemd" + +{- | A system-scope container restarted on failure and started at boot, with +nothing published and nothing mounted. +-} +container :: Podman.ContainerName -> Text -> Container +container name image = + Container + { containerScope = Systemd.System + , containerUnitDir = systemQuadletDir + , containerName = name + , containerImage = image + , containerExec = [] + , containerLifetime = LongRunning + , containerDescription = "container " <> Podman.getContainerName name <> " (salmon)" + , containerAfter = [] + , containerEnvFile = Nothing + , containerPorts = [] + , containerVolumes = [] + , containerBinds = [] + , containerKeepId = Nothing + , containerNetwork = Nothing + , containerAuthFile = Nothing + , containerRestart = RestartOnFailure + , containerStartTimeout = Nothing + , containerWantedBy = Just "multi-user.target" + , containerWatched = [] + , containerStamp = Nothing + , containerReady = Nothing + } + +{- | A system-scope job: this command, run in this image to completion. +Never restarted and not started at boot; something schedules or runs it. +-} +containerJob :: Podman.ContainerName -> Text -> [Text] -> Container +containerJob name image command = + (container name image) + { containerExec = command + , containerLifetime = RunToCompletion + , containerDescription = "job " <> Podman.getContainerName name <> " (salmon)" + , containerRestart = RestartNo + , containerWantedBy = Nothing + } + +-- | The unit the generator makes out of this container's file. +serviceTarget :: Container -> Systemd.UnitTarget +serviceTarget c = Podman.getContainerName c.containerName <> ".service" + +quadletPath :: Container -> FilePath +quadletPath c = c.containerUnitDir Text.unpack (Podman.getContainerName c.containerName) <> ".container" + +-- | The files whose contents are folded into the quadlet: the env file first. +watchedFiles :: Container -> [FilePath] +watchedFiles c = maybeToList c.containerEnvFile <> c.containerWatched + +------------------------------------------------------------------------------- + +{- | The @.container@ file, without the watched files' fingerprint: everything +the declaration alone decides. +-} +renderContainer :: Container -> Text +renderContainer = renderLabelled Nothing + +-- | 'renderContainer', with a @Label=@ line when there is a fingerprint to carry. +renderLabelled :: Maybe Text -> Container -> Text +renderLabelled fingerprint c = + Text.unlines $ + mconcat + [ ["[Unit]", "Description=" <> c.containerDescription] + , ["After=" <> Text.unwords c.containerAfter | not (null c.containerAfter)] + , ["", "[Container]"] + , ["ContainerName=" <> Podman.getContainerName c.containerName] + , ["Image=" <> c.containerImage] + , ["Exec=" <> Text.unwords (map Systemd.literalArg c.containerExec) | not (null c.containerExec)] + , ["Label=" <> quadletLabel <> "=" <> f | f <- maybeToList fingerprint] + , ["EnvironmentFile=" <> Text.pack f | f <- maybeToList c.containerEnvFile] + , ["PublishPort=" <> port p | p <- c.containerPorts] + , ["Volume=" <> volume v | v <- c.containerVolumes] + , ["Volume=" <> renderBind b | b <- c.containerBinds] + , ["UserNS=" <> renderKeepId k | k <- maybeToList c.containerKeepId] + , ["Network=" <> n | n <- maybeToList c.containerNetwork] + , ["PodmanArgs=--authfile=" <> Text.pack (Podman.getAuthFile a) | a <- maybeToList c.containerAuthFile] + , ["", "[Service]"] + , ["Type=oneshot" | c.containerLifetime == RunToCompletion] + , ["Restart=" <> restart c.containerRestart] + , ["TimeoutStartSec=" <> Text.pack (show t) | t <- maybeToList c.containerStartTimeout] + , -- systemd runs these on the host, around the generator's own + -- ExecStart=; the second only when that one exited 0 + concat + [ [ "ExecStartPre=" <> hostCommand ["touch", Text.pack (Job.stampRunning s)] + , "ExecStartPost=" <> hostCommand ["mv", "-f", Text.pack (Job.stampRunning s), Text.pack s] + ] + | s <- maybeToList c.containerStamp + ] + , concat [["", "[Install]", "WantedBy=" <> w] | w <- maybeToList c.containerWantedBy] + ] + where + hostCommand :: [Text] -> Text + hostCommand = Text.unwords . map Systemd.literalArg + + port :: Podman.PortMapping -> Text + port p = + mconcat + [ p.portOnHost + , ":" + , p.portInGuest + , "/" + , case p.portProtocol of + Podman.TCPPort -> "tcp" + Podman.UDPPort -> "udp" + ] + + volume :: Podman.VolumeMount -> Text + volume v = + mconcat + [ Text.pack v.volumeHostPath + , ":" + , Text.pack v.volumeGuestPath + , ":" + , volumeModeWord v.volumeMode + ] + + restart :: RestartPolicy -> Text + restart RestartNo = "no" + restart RestartOnFailure = "on-failure" + restart RestartAlways = "always" + +{- | 'renderContainer' plus the keyed digest of the watched files: everything +that decides what the container should be. With nothing watched it is +'renderContainer' exactly, and no key is read. + +Throws 'WatchKeyUnusable' when something is watched and the key cannot be +read: there is no fallback to a plain hash, which is the thing the key is +there to avoid. In a graph the key is a node the file stands on +('watchKeyNode'); outside one, 'ensureWatchKey' first. +-} +renderContainerWatching :: Container -> IO Text +renderContainerWatching = renderWatching Nothing + +renderWatching :: Maybe Text -> Container -> IO Text +renderWatching fingerprint c = case watchedFiles c of + [] -> pure (renderLabelled fingerprint c) + files -> do + key <- readWatchKey c + frames <- Systemd.watchedFrames files + pure (renderLabelled fingerprint c <> keyedWatchLine key frames) + +{- | The trailing comment: @# salmon-watches: hmac-sha256:BASE64@, the +HMAC-SHA256 under the key of what 'Systemd.watchedFrames' read. Pure, and +the whole of what the watched files leave in the quadlet. +It is 'Systemd.keyedWatchLine', which 'Systemd.systemdServiceWatchingKeyed' +writes into authored units too. +-} +keyedWatchLine :: ByteString.ByteString -> [ByteString.ByteString] -> Text +keyedWatchLine = Systemd.keyedWatchLine + +{- | Where the key of this container's directory is: beside the quadlets, so +it has the directory's owner (root for 'systemQuadletDir', the user for a +user's) and its lifetime. The generator reads only the extensions it knows +and leaves this file alone. +-} +watchKeyPath :: Container -> FilePath +watchKeyPath c = Systemd.watchKeyFile c.containerUnitDir + +readWatchKey :: Container -> IO ByteString.ByteString +readWatchKey c = Systemd.readWatchKeyAt (watchKeyPath c) + +{- | Makes the key if there is none, and makes it owner-only whatever it was. + +A key that exists is never replaced: a new key is a new fingerprint, and so a +restart, for every quadlet in the directory. It is written to a temporary +file created @0600@ and put in place with @link(2)@, which refuses an +existing name, so of two processes making it at once one wins and both read +the winner's ('Systemd.ensureWatchKeyAt'). +-} +ensureWatchKey :: Container -> IO () +ensureWatchKey c = Systemd.ensureWatchKeyAt (watchKeyPath c) + +{- | The verdict on the key file's mode and size, 'Nothing' for no file. A +key others can read is a 'Failure' ('ensureWatchKey' then closes it; it does +not make a new one, see there). +-} +interpretWatchKey :: FilePath -> Maybe (FileMode, Integer) -> CheckResult +interpretWatchKey = Systemd.interpretWatchKey + +{- | The key of 'containerUnitDir', one node for every quadlet there that +watches a file. It stands on the directory and, like it, is never removed. +-} +watchKeyNode :: Container -> Op +watchKeyNode c = + op "podman-quadlet-key" (deps [unitDirNode c]) $ \actions -> + actions + { help = "ensures " <> Text.pack path <> " exists, readable by its owner alone" + , notes = ["keys the digest of the files the quadlets watch, shared by every quadlet there: down leaves it"] + , ref = mkRef "podman-quadlet-key" path + , check = Systemd.checkWatchKeyAt path + , up = ensureWatchKey c + } + where + path = watchKeyPath c + +-- | The generator's directory: created if missing, never removed. +unitDirNode :: Container -> Op +unitDirNode c = + op "podman-quadlet-dir" nodeps $ \actions -> + actions + { help = "ensures " <> Text.pack c.containerUnitDir <> " exists" + , notes = ["the generator's directory, shared by every quadlet: down leaves it"] + , ref = mkRef "podman-quadlet-dir" c.containerUnitDir + , up = createDirectoryIfMissing True c.containerUnitDir + } + +{- | The container label that says which quadlet a container was started +from: its value is 'quadletFingerprint' at the time the file was written. +-} +quadletLabel :: Text +quadletLabel = "salmon.quadlet" + +{- | A hash of 'renderContainerWatching': the declaration and the watched +files' keyed digest, and nothing that depends on when it is asked. Without +the key it says nothing about the watched files. +-} +quadletFingerprint :: Container -> IO Text +quadletFingerprint c = FS.hashBytes . Text.encodeUtf8 <$> renderContainerWatching c + +{- | What 'quadletFingerprint' was before the digest was keyed: the label of +a container started from a file written then. It is computed to be compared +with a running container's label and for nothing else: never written, never +reported. With nothing watched it is 'quadletFingerprint'. +-} +unkeyedFingerprint :: Container -> IO Text +unkeyedFingerprint c = + FS.hashBytes . Text.encodeUtf8 <$> case watchedFiles c of + [] -> pure (renderContainer c) + files -> Systemd.withWatchedFingerprint files (renderContainer c) + +{- | The file as written: 'renderContainerWatching' with one more line, +@Label=salmon.quadlet=FINGERPRINT@, so that a container started from this +file says so and 'checkContainer' can ask it. +-} +renderQuadlet :: Container -> IO Text +renderQuadlet c = do + fingerprint <- quadletFingerprint c + renderWatching (Just fingerprint) c + +{- | Why this container cannot be written, if it cannot. + +Every value lands on a line of its own in a file systemd parses, so a line +break inside one is another key: an image reference read from somewhere that +ends in a newline would otherwise write a quadlet that says something the +declaration does not. The name is also a file and a unit name. +-} +containerProblems :: Container -> [Text] +containerProblems c = + mconcat + [ ["the container has no name" | Text.null name] + , ["the container name is not a unit name: " <> name | Text.any (`elem` ("/ \t" :: String)) name] + , ["the container has no image" | Text.null (Text.strip c.containerImage)] + , [ "a job cannot be restarted always: systemd refuses it for a oneshot unit" + | c.containerLifetime == RunToCompletion + , c.containerRestart == RestartAlways + ] + , [ "a stamp records a run that finished, and this container is not a job" + | Just _ <- [c.containerStamp] + , c.containerLifetime /= RunToCompletion + ] + , ["the stamp is not an absolute path: " <> Text.pack s | s <- maybeToList c.containerStamp, not (isAbsolute s)] + , [ "readiness is a service's: a job is done when its command exits" + | Just _ <- [c.containerReady] + , c.containerLifetime /= LongRunning + ] + , concat [readinessProblems rd | rd <- maybeToList c.containerReady] + , concatMap bindProblems c.containerBinds + , [ "two binds create " <> Text.pack a.bindHostPath <> " differently" + | (i, a) <- created + , (j, b) <- created + , i < j + , a.bindHostPath == b.bindHostPath + , a.bindCreate /= b.bindCreate + ] + , concat [keepIdProblems c.containerScope k | k <- maybeToList c.containerKeepId] + , ["a line break in the " <> what | (what, value) <- fields, Text.any (`elem` ("\n\r" :: String)) value] + ] + where + name = Podman.getContainerName c.containerName + created :: [(Int, Bind)] + created = [(i, b) | (i, b@Bind{bindCreate = Just _}) <- zip [0 ..] c.containerBinds] + fields :: [(Text, Text)] + fields = + mconcat + [ [("name", name), ("image", c.containerImage), ("description", c.containerDescription)] + , [("command", w) | w <- c.containerExec] + , [("after", a) | a <- c.containerAfter] + , [("env file", Text.pack f) | f <- maybeToList c.containerEnvFile] + , [("published port", p.portOnHost <> p.portInGuest) | p <- c.containerPorts] + , [("volume", Text.pack (v.volumeHostPath <> v.volumeGuestPath)) | v <- c.containerVolumes] + , [("bind", Text.pack (b.bindHostPath <> b.bindGuestPath)) | b <- c.containerBinds] + , [("network", n) | n <- maybeToList c.containerNetwork] + , [("auth file", Text.pack (Podman.getAuthFile a)) | a <- maybeToList c.containerAuthFile] + , [("wanted-by", w) | w <- maybeToList c.containerWantedBy] + , [("stamp", Text.pack s) | s <- maybeToList c.containerStamp] + ] + +readinessProblems :: Readiness -> [Text] +readinessProblems rd = + mconcat + [ ["the readiness hold is negative" | rd.readyHold < 0] + , ["a readiness probe needs a timeout of at least a second" | Just _ <- [rd.readyProbe], rd.readyTimeout < 1] + , ["the readiness probe's port is not a port: " <> Text.pack (show p) | Just (ProbeTcp _ p) <- [rd.readyProbe], p < 1 || p > 65535] + , ["the readiness probe has no host" | Just (ProbeTcp h _) <- [rd.readyProbe], Text.null (Text.strip h)] + , ["the readiness probe has no command" | Just (ProbeCommand cmd _) <- [rd.readyProbe], null cmd] + ] + +data InvalidContainer = InvalidContainer !FilePath ![Text] + deriving (Show) + +instance Exception InvalidContainer + +------------------------------------------------------------------------------- + +{- | Installs the quadlet and keeps its service running as written. + +The 'Track'' is where the caller says what the container stands on: podman +itself, the 'Podman.login' whose 'Podman.AuthFile' the pull reads, whatever +delivers the env file, a migration the new image needs. They are applied +before the file is written: the file node depends on them, so one that fails +leaves the file @Blocked@ as well as this node, and the machine keeps the +quadlet its running container was started from. (As siblings of the file, +which they once were, a failed one still let the new image be written under +the old container.) + +That holds for the 'Track'' only. 'Salmon.Op.OpGraph.inject' on the 'Op' +returned here adds a predecessor of /this/ node, beside the file and in no +order with it; a precondition of the new declaration belongs in the track. + +@up@ is @daemon-reload@ then @restart@, which returns once the container is +running (the generated service is @Type=notify@). The one case with no +restart is a container started before the watched files' digest was keyed +and otherwise current ('interpretAdoptable'): the reload is all it needs. The restart stops the old +container before the start would pull the new image, so the image is pulled +before any of that, by 'imageNode', which the quadlet file depends on: a pull +that fails is that node's failed @up@, the file and this node are @Blocked@, +and whatever was running keeps running from the file it was started from. + +"Running" there means the container exists, not that it works. With +'containerReady' declared, @up@ goes on to 'awaitReady' and throws 'NotReady' +when the container dies, is restarted by systemd, or does not answer its +probe in time. The failing unit is left as it is (systemd keeps restarting or +has given up; either is what the operator needs to see), and nothing is +rolled back: the old container was stopped by the restart. The node's +@check@ is unchanged by it, so a later pass that happens to sample a +crash-looping unit while it is @active@ still reads it as satisfied. + +@down@ +stops the service, which removes the container, and the file's own @down@ +removes the file and reloads so that the generated unit goes with it. The +image is left on the machine, and so is 'containerUnitDir': the node creates +it if it is missing but never removes it, since every quadlet on the machine +lives there. So is every directory of 'containerBinds' ('hostDirNode'), which +holds the container's data. +-} +quadletContainer :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Track' Container -> + Container -> + Op +quadletContainer r systemctl t c = + withCommand r systemctl (Systemd.DaemonReload c.containerScope) $ \reload -> + withCommand r systemctl (Systemd.Up c.containerScope target) $ \restart -> + withCommand r systemctl (Systemd.Stop c.containerScope target) $ \stop -> + op "podman-quadlet" (deps [quadletFile r ([imageNode c `inject` run t c, run t c] <> hostDirNodes c) c, run t c]) $ \actions -> + actions + { help = "runs " <> c.containerImage <> " as " <> target + , notes = + [ "image: " <> c.containerImage + , "quadlet: " <> declaredFingerprint c + ] + <> ["ready: " <> describeReadiness rd | rd <- maybeToList c.containerReady] + , ref = mkRef "systemd-unit" target + , check = checkContainer c + , up = do + reload + -- a container started from this declaration and + -- these files, before the digest was keyed: the + -- file changed and what should run did not + adopted <- startedUnkeyed c + unless adopted $ do + restart + case c.containerReady of + Nothing -> pure () + Just rd -> do + verdict <- awaitReady (systemWaiting c) rd + either (throwIO . NotReady target) pure verdict + , down = stop + } + where + target = serviceTarget c + +{- | Installs the quadlet of a job and starts nothing: 'quadletContainer' for +a container that runs to completion ('containerJob'). + +The check is 'checkJobInstalled': systemd holds the generated service, its +source file has not changed since, and the unit was generated from this +declaration. There is no running container to ask, and none is wanted. @up@ is @daemon-reload@, after which a unit systemd +still does not hold is thrown: the generator drops a file it cannot read +without failing the reload, so that is the only place a refused quadlet +shows. @down@ stops a run under way if there is one; the file's @down@ +removes the file and reloads. As for 'quadletContainer', what the 'Track'' +declares is applied before the file is written. + +The image is pulled by the first /run/, not here. A job whose first run +must not wait for a pull stands on a 'Podman.pullImage'. +-} +quadletJob :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Track' Container -> + Container -> + Op +quadletJob r systemctl t c = + withCommand r systemctl (Systemd.DaemonReload c.containerScope) $ \reload -> + withCommand r systemctl (Systemd.Stop c.containerScope target) $ \stop -> + op "podman-quadlet-job" (deps [quadletFile r (run t c : hostDirNodes c) c, run t c]) $ \actions -> + actions + { help = "installs the job " <> target <> " running " <> c.containerImage <> ", without running it" + , notes = + [ "image: " <> c.containerImage + , "quadlet: " <> declaredFingerprint c + ] + , ref = mkRef "systemd-unit" target + , check = checkJobInstalled c + , up = Job.reloadAndRequireLoaded c.containerScope target reload + , down = Job.stopIfKnown c.containerScope target stop + } + where + target = serviceTarget c + +{- | Does systemd hold the job's service, /generated from this declaration/? + +'Systemd.checkLoaded' is asked first and anything but 'Success' is the +answer. It is not enough for a generated unit, though. A job at rest that +nothing refers to is unloaded by systemd as its run ends, and asking about +it loads it again from the generator's /last output/: the unit then reads +@loaded@ with @NeedDaemonReload=no@ although the quadlet was rewritten since +that output was made, and a run of it is a run of the old command (seen on +systemd 255 with podman 4.9: a job re-declared from @exit 0@ to @exit 3@ +kept succeeding). An authored unit has no such gap, its file being what +systemd reads. + +So the unit is asked what it would run. The written file carries +'quadletLabel' ('renderQuadlet'), the generator turns it into a @--label@ of +the unit's @ExecStart=@, and 'interpretGenerated' looks for the declared +'quadletFingerprint' there. A @systemctl@ that cannot answer is 'Unknown'. +-} +checkJobInstalled :: Container -> IO CheckResult +checkJobInstalled c = do + loaded <- Systemd.checkLoaded c.containerScope (serviceTarget c) + case loaded of + Success -> do + declared <- quadletFingerprint c + (code, out, _err) <- + readCreateProcessWithExitCode + ( proc + "systemctl" + ( Systemd.scopeArgs c.containerScope + <> ["show", Text.unpack (serviceTarget c), "--property=ExecStart", "--value"] + ) + ) + "" + pure $ case code of + ExitSuccess -> interpretGenerated declared (Text.pack out) + ExitFailure _ -> Unknown + other -> pure other + +{- | The verdict on a generated unit's @ExecStart=@ (as @systemctl show@ +prints it) against the declared 'quadletFingerprint': the unit was generated +from this declaration when its command labels the container with it. +-} +interpretGenerated :: Text -> Text -> CheckResult +interpretGenerated declared execStart + | (quadletLabel <> "=" <> declared) `Text.isInfixOf` execStart = Success + | otherwise = Failure ("the generated unit was not made from the declared quadlet " <> declared) + +{- | What 'Job.completedRun' asks about a container job: a run of its +generated service newer than the quadlet file and than every file the +container reads at start ('watchedFiles': the env file and +'containerWatched'), read from 'containerStamp' if it has one. + +The quadlet file is written through 'FS.filecontents', which leaves +identical bytes alone, so its time is when the declaration (or a watched +file's content) last changed. A watched file is counted by its own time as +well: one rewritten with the same content is a reason to run again here, +though not a changed quadlet. + +The image is not in the list: a tag moved at the registry is not a change +this can see, as for 'quadletContainer'. +-} +containerCompletion :: Container -> Job.Completion +containerCompletion c = + Job.Completion + { Job.completionScope = c.containerScope + , Job.completionUnit = serviceTarget c + , Job.completionWritten = quadletPath c : watchedFiles c + , Job.completionStamp = c.containerStamp + } + +{- | A container job that has run: 'Job.completedRun' over +'containerCompletion', standing on its 'quadletJob'. A pass runs the job +when no run has succeeded since the quadlet or a watched file was last +written, skips it otherwise, and fails when the run fails. + +Keyed like a 'Job.runJob' of the same service. As for any +'Job.completedRun', what remembers a successful run is either something +keeping the unit loaded (a 'Job.timerUnit' triggering it, which the caller +declares and injects) or 'containerStamp'; with neither, the job runs at +every pass. The 'Track'' is the job's. +-} +completedQuadletJob :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Track' Container -> + Container -> + Op +completedQuadletJob r systemctl t c = + Job.completedRun r systemctl (containerCompletion c) `inject` quadletJob r systemctl t c + +withCommand :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Systemd.SystemCtlCall -> + (IO () -> Op) -> + Op +withCommand r systemctl cmd f = + let + g :: (Reporter Binary.Report -> IO ()) -> Op + g callbin = f (callbin (contramap (Systemd.CallSystemCtl cmd) r)) + in + withBinary systemctl Systemd.callSystemctl cmd g + +{- | What the declaration alone says the file is. The file node's own +contents are an @IO Text@ once anything is watched, which has no content +fingerprint, so without this a re-declaration under @serve@ that only changes +the image would leave both nodes looking unchanged. +-} +declaredFingerprint :: Container -> Text +declaredFingerprint c = FS.hashBytes (Text.encodeUtf8 (renderContainer c)) + +{- | The quadlet file's node: 'FS.filecontents' with two changes, both to +what it stands on rather than to the file. 'ownFile' is applied to the file +node alone: an 'fmap' over the 'Op' reaches every node of its graph, and once +reached the enclosing directory, which then carried this container's notes +(two quadlets sharing the directory were a 'Conflicting' pair) and its +reload. And the directory is 'unitDirNode', not 'FS.dir', whose @down@ refuses a +non-empty directory: the generator's directory holds every quadlet on the +machine, so tearing one down failed whenever another was there. A quadlet +that watches a file also stands on 'watchKeyNode', since its contents cannot +be rendered without the key. +-} +quadletFile :: Reporter Systemd.Report -> [Op] -> Container -> Op +quadletFile r before c = + let file = FS.filecontents (FS.FileContents path (renderQuadlet c)) + in file{node = fmap ownFile file.node, predecessors = deps (unitDirNode c : key <> before)} + where + path = quadletPath c + + -- only a quadlet that watches something digests anything + key :: [Op] + key = [watchKeyNode c | not (null (watchedFiles c))] + + ownFile :: Extension -> Extension + ownFile ext = + ext + { notes = ext.notes <> ["quadlet: " <> declaredFingerprint c] + , up = do + let problems = containerProblems c + unless (null problems) $ throwIO (InvalidContainer path problems) + ext.up + , -- the generated unit outlives its source file until the next + -- reload, and nothing else in this graph would run one. + down = do + ext.down + Binary.untrackedExec + Systemd.callSystemctl + (Systemd.DaemonReload c.containerScope) + "" + (contramap (Systemd.CallSystemCtl (Systemd.DaemonReload c.containerScope)) r) + } + +------------------------------------------------------------------------------- + +-- | The 'hostDirNode' of every bind that creates its directory, one per path. +hostDirNodes :: Container -> [Op] +hostDirNodes c = go [] c.containerBinds + where + go _ [] = [] + go seen (b : rest) = case b.bindCreate of + Just d | b.bindHostPath `notElem` seen -> hostDirNode c b d : go (b.bindHostPath : seen) rest + _ -> go seen rest + +{- | A bind's host directory, on the machine before the quadlet is written +(the file stands on it), so that the start does not fail on a path podman +will not make. + +The @check@ is "a directory is there" and nothing more: 'Success' leaves an +existing directory alone whoever owns it and whatever its mode (see +'HostDir' for why), and a path that holds something else is a 'Failure' that +@up@ then throws on. @up@ creates the directory and its missing parents, +then applies the stated mode and owner /only to a directory it has just +made/; if either fails, the directory just made is removed again, so the next +pass does not find it there and call the declaration satisfied. + +@down@ is nothing. The directory holds what the container wrote, and +'FS.dir''s @down@, which refuses a non-empty directory, would block the +teardown of the quadlet file standing on it. Removing the data is the +operator's. + +Keyed on the path and described by the owner and mode alone, so two +containers binding one directory the same way share the node, and two +stating different owners are a @Conflicting@ pair. +-} +hostDirNode :: Container -> Bind -> HostDir -> Op +hostDirNode c b d = + op "podman-quadlet-bind-dir" nodeps $ \actions -> + actions + { help = "creates " <> Text.pack path <> " unless it is there" + , notes = + mconcat + [ ["owner at creation: " <> o | o <- maybeToList d.hostDirOwner] + , ["mode at creation: " <> m | m <- maybeToList d.hostDirMode] + , ["an existing directory is left as it is; down leaves it, with what is in it"] + ] + , ref = mkRef "podman-quadlet-bind-dir" path + , check = interpretHostDir path <$> doesDirectoryExist path <*> doesPathExist path + , up = do + let problems = containerProblems c + unless (null problems) $ throwIO (InvalidContainer (quadletPath c) problems) + isDir <- doesDirectoryExist path + unless isDir $ do + createDirectoryIfMissing True path + (setMode >> setOwner) `onException` removeDirectory path + } + where + path = b.bindHostPath + + setMode :: IO () + setMode = case d.hostDirMode of + Nothing -> pure () + Just m -> case readOct (Text.unpack m) of + [(bits, "")] -> setFileMode path bits + _ -> throwIO (HostDirFailed path ("not an octal mode: " <> m)) + + setOwner :: IO () + setOwner = case d.hostDirOwner of + Nothing -> pure () + Just o -> do + (code, _out, err) <- readCreateProcessWithExitCode (proc "chown" (chownArgs o path)) "" + when (code /= ExitSuccess) $ + throwIO (HostDirFailed path ("chown " <> o <> ": " <> Text.strip (Text.pack err))) + +-- | @chown -- OWNER PATH@, on the directory alone. +chownArgs :: Text -> FilePath -> [String] +chownArgs owner path = ["--", Text.unpack owner, path] + +-- | The verdict on a bind's host path: is a directory there, is anything there. +interpretHostDir :: FilePath -> Bool -> Bool -> CheckResult +interpretHostDir path isDir exists + | isDir = Success + | exists = Failure (Text.pack path <> " is there and is not a directory") + | otherwise = Failure ("the directory " <> Text.pack path <> " is missing") + +-- | A bind's directory that was made and could not be given its mode or owner. +data HostDirFailed = HostDirFailed !FilePath !Text + deriving (Show) + +instance Exception HostDirFailed + +{- | The container's image, on the machine before its quadlet is written. + +Left to itself the image is pulled by the service's start, and on a restart +the start comes after the stop: a reference that cannot be pulled (a typo, a +registry that does not answer, a credential that expired) then takes a +healthy container down and leaves the unit failing to start. With this node +ahead of the file, such a pass fails here instead and changes nothing: the +file still says the old image, so a reboot or a crash restarts the old +container too. + +The @check@ is @podman image exists@, so an image already on the machine -- +every unchanged declaration, and a locally built or tagged image -- is a +skip and never reaches a registry; the @up@ is @podman pull@ with the +container's 'containerAuthFile', which throws 'ImageUnavailable' when it +fails. Like the check on the running container, podman is run as whoever +runs salmon, whose store is the service's in both scopes. @down@ is nothing: +the image is left on the machine. + +Keyed on the reference and the auth file, and described by nothing else, so +several containers of one image share the node. It has no dependencies of +its own; 'quadletContainer' injects what the caller's 'Track'' declares (the +login the pull reads). + +What it does not cover: a tag that moved at the registry (the image exists, +nothing is pulled), and an image removed from the machine after the pass. +-} +imageNode :: Container -> Op +imageNode c = + op "podman-quadlet-image" nodeps $ \actions -> + actions + { help = "pulls " <> c.containerImage <> " unless it is on the machine" + , notes = ["auth file: " <> Text.pack (Podman.getAuthFile a) | a <- maybeToList c.containerAuthFile] + , ref = mkRef "podman-quadlet-image" (c.containerImage, fmap Podman.getAuthFile c.containerAuthFile) + , check = do + (code, _out, _err) <- readCreateProcessWithExitCode (proc "podman" (imagePresentArgs c)) "" + pure (interpretImagePresent c.containerImage code) + , up = do + let problems = containerProblems c + unless (null problems) $ throwIO (InvalidContainer (quadletPath c) problems) + (code, _out, err) <- readCreateProcessWithExitCode (proc "podman" (imagePullArgs c)) "" + case code of + ExitSuccess -> pure () + ExitFailure n -> throwIO (ImageUnavailable c.containerImage n (Text.strip (Text.pack err))) + } + +-- | @podman image exists IMAGE@: exits 0 when the local store has it, 1 when not. +imagePresentArgs :: Container -> [String] +imagePresentArgs c = ["image", "exists", Text.unpack c.containerImage] + +-- | @podman pull [--authfile FILE] IMAGE@, the credentials being the ones the start would use. +imagePullArgs :: Container -> [String] +imagePullArgs c = + mconcat + [ ["pull", "--quiet"] + , ["--authfile=" <> Podman.getAuthFile a | a <- maybeToList c.containerAuthFile] + , [Text.unpack c.containerImage] + ] + +{- | The verdict on @podman image exists@'s exit code. Anything but 0 and 1 +is podman failing to answer (125, a broken store), which is 'Unknown' and +not "missing": under @serve@ that must not read as an effect that went away. +-} +interpretImagePresent :: Text -> ExitCode -> CheckResult +interpretImagePresent _ ExitSuccess = Success +interpretImagePresent image (ExitFailure 1) = Failure ("the image " <> image <> " is not on the machine") +interpretImagePresent _ (ExitFailure _) = Unknown + +-- | A pull that failed: the reference, podman's exit code and what it said. +data ImageUnavailable = ImageUnavailable !Text !Int !Text + deriving (Show) + +instance Exception ImageUnavailable + +{- | 'Systemd.interpretShow' for a generated unit: @generated@ is the only +install state such a unit ever has. Everything else -- a changed source file, +a transition being 'Unknown', a stopped unit -- reads as it does there. +-} +interpretShow :: [Text] -> CheckResult +interpretShow = Systemd.interpretShowAccepting ("generated" : Systemd.installedStates) + +{- | Is the service running, as written, /the container this declaration +describes/? + +The unit is asked first ('interpretShow'), and anything but 'Success' is the +answer. But systemd only knows whether it has re-read its files, and +@daemon-reload@ is machine-wide: with two quadlets changed and one of them +brought up, the other's unit reads @NeedDaemonReload=no@ while still running +the container it was started with -- which is how a pass interrupted between +writing the files and restarting the services was followed by one that +skipped them, converged, and left the old image running. So the running +container is asked for its 'quadletLabel' and that is compared with +'quadletFingerprint' ('interpretStarted'). A @podman@ that cannot answer is +'Unknown', as a @systemctl@ that cannot is in 'Systemd.checkUnit'. + +@podman@ is run as whoever runs salmon, which is the store the service's +container is in for both scopes: root for 'Systemd.System', the user for +'Systemd.User'. +-} +checkContainer :: Container -> IO CheckResult +checkContainer c = do + unit <- Systemd.checkUnit interpretShow c.containerScope (serviceTarget c) + case unit of + Success -> do + declared <- quadletFingerprint c + unkeyed <- unkeyedFingerprint c + maybe Unknown (interpretStarted declared unkeyed) <$> runningLabel c + other -> pure other + +-- | The running container's 'quadletLabel' as podman prints it, if podman answers. +runningLabel :: Container -> IO (Maybe Text) +runningLabel c = do + (code, out, _err) <- + readCreateProcessWithExitCode + ( proc + "podman" + [ "container" + , "inspect" + , "--format" + , "{{index .Config.Labels \"" <> Text.unpack quadletLabel <> "\"}}" + , Text.unpack (Podman.getContainerName c.containerName) + ] + ) + "" + pure $ case code of + ExitSuccess -> Just (Text.pack out) + ExitFailure _ -> Nothing + +{- | 'interpretRunning', also satisfied by a container whose label is the +'unkeyedFingerprint' of the declaration: one started before the digest was +keyed, from this declaration and these watched files. That fingerprint moves +with the declaration and the files exactly as the keyed one does, so a +container started before an env file was rotated is still not satisfied. +-} +interpretStarted :: Text -> Text -> Text -> CheckResult +interpretStarted declared unkeyed printed + | Text.strip printed == unkeyed = Success + | otherwise = interpretRunning declared printed + +{- | Is this unit's container one a file rewritten for the key alone leaves +as it is? Asked by @up@ after its reload, of the unit and of the running +container's label: yes when the unit is @active@ and the label is the +'unkeyedFingerprint' of the declaration, which is not the declared one (so +something is watched). Anything not known is no, and the restart happens. +-} +interpretAdoptable :: Text -> Text -> Maybe UnitSample -> Maybe Text -> Bool +interpretAdoptable declared unkeyed (Just s) (Just printed) = + s.sampleActive == "active" && unkeyed /= declared && Text.strip printed == unkeyed +interpretAdoptable _ _ _ _ = False + +startedUnkeyed :: Container -> IO Bool +startedUnkeyed c + | null (watchedFiles c) = pure False + | otherwise = do + declared <- quadletFingerprint c + unkeyed <- unkeyedFingerprint c + interpretAdoptable declared unkeyed <$> sampleUnit c <*> runningLabel c + +{- | The verdict on a running container's 'quadletLabel' (as @podman +container inspect@ printed it) against the declared 'quadletFingerprint'. +A container with no such label was started from a file written before the +label existed, or by something else under this name: either way not from +this declaration. +-} +interpretRunning :: Text -> Text -> CheckResult +interpretRunning declared printed + | running == declared = Success + | Text.null running || running == "" = + Failure "the running container does not say which quadlet it was started from" + | otherwise = + -- the running label is not quoted: it may date from before the + -- digest was keyed, and failure text goes into reports + Failure ("the running container was not started from the declared quadlet " <> declared) + where + running = Text.strip printed + +------------------------------------------------------------------------------- + +-- | What @systemctl show@ says about a unit at one instant, as far as standing goes. +data UnitSample + = UnitSample + { sampleActive :: Text + , sampleSub :: Text + , sampleRestarts :: Maybe Int + -- ^ @NRestarts@: how many times systemd restarted it by itself + , sampleResult :: Text + } + deriving (Eq, Show) + +-- | @systemctl [--user] show UNIT@ for the four properties of a 'UnitSample'. +sampleArgs :: Container -> [String] +sampleArgs c = + Systemd.scopeArgs c.containerScope + <> ["show", Text.unpack (serviceTarget c), "--property=ActiveState,SubState,NRestarts,Result"] + +-- | The @KEY=VALUE@ lines of 'sampleArgs', in any order; a missing key is empty. +parseSample :: [Text] -> UnitSample +parseSample ls = + UnitSample + { sampleActive = value "ActiveState" + , sampleSub = value "SubState" + , sampleRestarts = readMaybe (Text.unpack (value "NRestarts")) + , sampleResult = value "Result" + } + where + value key = maybe "" (Text.strip . Text.drop (Text.length key + 1)) (find ((key <> "=") `Text.isPrefixOf`) ls) + +sampleUnit :: Container -> IO (Maybe UnitSample) +sampleUnit c = do + (code, out, _err) <- readCreateProcessWithExitCode (proc "systemctl" (sampleArgs c)) "" + pure $ case code of + ExitSuccess -> Just (parseSample (Text.lines (Text.pack out))) + ExitFailure _ -> Nothing + +{- | Is a unit that @systemctl restart@ just reported started still the +process that was started? Given the @NRestarts@ values that mean "systemd has +not restarted it since" (none: do not judge by the counter). + +After a successful restart the unit was @active@, so anything else -- +@activating@ included, which is systemd's @auto-restart@ -- is it having gone +down. The reason names the states and never the container's output. +-} +interpretStanding :: [Int] -> UnitSample -> Either Text () +interpretStanding allowed s + | s.sampleActive /= "active" = + Left ("the unit is " <> s.sampleActive <> " (" <> s.sampleSub <> ", result: " <> s.sampleResult <> ")") + | Just n <- s.sampleRestarts + , not (null allowed) + , n `notElem` allowed = + Left ("systemd has restarted it since it was started (NRestarts=" <> Text.pack (show n) <> ")") + | otherwise = Right () + +{- | What 'awaitReady' needs of the world, so that the order of things can be +tested without a systemd, a socket or a clock. +-} +data Waiting + = Waiting + { waitSample :: IO (Maybe UnitSample) + -- ^ 'Nothing' when systemd could not be asked + , waitProbe :: Probe -> IO Bool + , waitSleep :: Int -> IO () + -- ^ milliseconds + , waitNow :: IO Int + -- ^ milliseconds, monotonic + } + +{- | Waits for a just-restarted unit to be ready, or says why it is not. + +The unit is looked at first, then at every step, and the wait ends at the +first look that finds it down or restarted ('interpretStanding'): a +container that dies at boot fails the pass in about a second, not after the +probe's whole timeout. With a probe, it is asked every half second until it +answers yes, for at most 'readyTimeout' seconds (one attempt is itself cut +at five). Then the unit must stay standing for 'readyHold' seconds. + +The restart count every later look is held to is the /first look's/, not 0 +and not a reading from before the restart: @systemctl restart@ does not +reset @NRestarts@ on a unit systemd was restarting (seen on this tree's +development machine), and a count read before the restart can move before +the restart does, which would fail a container that came up fine. The price +is a container that died and came back between the restart returning and +the first look: that one restart is the baseline, and it is the next one, +inside the hold, that is seen. A hold shorter than the unit's own restart +delay can therefore miss a crash loop; the default delay is 100ms. +-} +awaitReady :: Waiting -> Readiness -> IO (Either Text ()) +awaitReady w rd = do + start <- w.waitNow + first <- look [] + case first of + Left why -> pure (Left why) + Right s -> probing start (maybeToList s.sampleRestarts) + where + poll :: Int + poll = 500 + + look :: [Int] -> IO (Either Text UnitSample) + look allowed = do + sample <- w.waitSample + pure $ case sample of + Nothing -> Left "systemctl could not say how the unit is doing" + Just s -> s <$ interpretStanding allowed s + + probing :: Int -> [Int] -> IO (Either Text ()) + probing start allowed = case rd.readyProbe of + Nothing -> holding allowed =<< w.waitNow + Just p -> do + ok <- w.waitProbe p + now <- w.waitNow + if ok + then holding allowed now + else + if now - start >= rd.readyTimeout * 1000 + then pure (Left ("not ready after " <> Text.pack (show rd.readyTimeout) <> "s: " <> describeProbe p <> " never held")) + else do + w.waitSleep poll + standing <- look allowed + either (pure . Left) (const (probing start allowed)) standing + + holding :: [Int] -> Int -> IO (Either Text ()) + holding allowed since = do + standing <- look allowed + case standing of + Left why -> pure (Left why) + Right _ -> do + now <- w.waitNow + let remaining = rd.readyHold * 1000 - (now - since) + if remaining <= 0 + then pure (Right ()) + else w.waitSleep (min poll remaining) >> holding allowed since + +-- | 'Waiting' against this machine's systemd, network and clock. +systemWaiting :: Container -> Waiting +systemWaiting c = + Waiting + { waitSample = sampleUnit c + , waitProbe = runProbe + , waitSleep = \ms -> threadDelay (ms * 1000) + , waitNow = (\ns -> fromIntegral (ns `div` 1000000)) <$> getMonotonicTimeNSec + } + +-- | A container that was restarted and is not ready: its unit, and why. +data NotReady = NotReady !Systemd.UnitTarget !Text + deriving (Show) + +instance Exception NotReady diff --git a/src/Salmon/Builtin/Nodes/PortMapping.hs b/src/Salmon/Builtin/Nodes/PortMapping.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/PortMapping.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Ask the LAN's gateway (UPnP-IGD, through @upnpc@ from @miniupnpc@) to +forward an external port to this host, and keep it that way. + +There is no "set" verb, so this is the 'Salmon.Builtin.Nodes.Netfilter.rule' +case: 'check' lists the gateway's mappings and 'up' adds one only if the +listing does not already say it is in place. Routers forget mappings on reboot +and a timed lease expires; the 'check' notices, and under @run serve@ the +tending loop re-asserts it. + +Things worth knowing: + +* __The mapping is the gateway's, not ours__: it is identified by + (protocol, external port), which is also this node's 'Ref'. A mapping on that + port pointing at /another/ host is refused, never taken over. +* __'down' deletes only a mapping carrying our marker__ (@salmon:NAME@ in the + description); anything else on the router is not ours. +* __No gateway__ (nothing answered, or a device that is not an IGD) is + 'Unknown' for 'check': a rebooting or reconfigured router is what fixes it, + and a loop that keeps looking is the right reaction. 'up' and 'down' throw. +* __Double NAT__: if the gateway's own external address is private or CGNAT, a + mapping cannot be reached from the Internet. 'check' says so as a 'Failure' + and 'up' refuses, rather than reporting success for a mapping nobody can use. +* __Security__: UPnP has no authentication on the LAN side and opens a hole to + the Internet. This is opt-in per node, one port per node, and no recipe + should add it by default. + +'up' and 'down' verify their own effect by listing again, because @upnpc@'s +exit status is not trusted to reflect a gateway's refusal. + +Only @upnpc@ is implemented. NAT-PMP\/PCP (@natpmpc@) is a follow-up. +-} +module Salmon.Builtin.Nodes.PortMapping ( + PortMap (..), + Report (..), + portMapping, + marker, + Plan (..), + planFor, + checkOf, + TeardownPlan (..), + teardownFor, + PortMappingRefused (..), + UpnpcCommand (..), + upnpcCommand, + gatewayExternalAddress, + module Salmon.Builtin.Nodes.PortMapping.Upnpc, +) where + +import Control.Exception (Exception, throwIO) +import Control.Monad (when) +import Data.Dynamic (toDyn) +import Data.Maybe (listToMaybe) +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.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.PortMapping.Upnpc +import Salmon.Op.Ref +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- + +data Report + = RunUpnpc !UpnpcCommand !Binary.Report + deriving (Show) + +-- | One mapping to keep on the gateway. +data PortMap = PortMap + { portMapName :: Text + -- ^ identifies us in the description (@salmon:NAME@) + , portMapInternalAddress :: Text + -- ^ this host's LAN address (not detected: the author states it) + , portMapInternalPort :: Int + , portMapExternalPort :: Int + , portMapProtocol :: Proto + , portMapLeaseSeconds :: Int + -- ^ must be positive: a permanent lease is not portable across routers + } + deriving (Show) + +-- | The text a mapping we made carries as its description. +marker :: PortMap -> Text +marker pm = "salmon:" <> pm.portMapName + +------------------------------------------------------------------------------- + +data UpnpcCommand + = Add PortMap + | Delete PortMap + deriving (Show) + +upnpcCommand :: Command "upnpc" UpnpcCommand +upnpcCommand = Command $ \cmd -> case cmd of + Add pm -> + proc "upnpc" $ + [ "-e" + , Text.unpack (marker pm) + , "-a" + , Text.unpack pm.portMapInternalAddress + , show pm.portMapInternalPort + , show pm.portMapExternalPort + , Text.unpack (protoText pm.portMapProtocol) + , show pm.portMapLeaseSeconds + ] + Delete pm -> + proc + "upnpc" + [ "-d" + , show pm.portMapExternalPort + , Text.unpack (protoText pm.portMapProtocol) + ] + +------------------------------------------------------------------------------- + +-- | What the gateway's listing says about what 'up' has to do. +data Plan + = -- | in place, with enough lease left + InPlace + | -- | absent, stale or about to expire: (re-)add it + NeedsAdd Text + | -- | somebody else's mapping holds the external port + Taken Text + | -- | the gateway is itself behind a NAT + DoubleNat Text + | -- | no Internet Gateway Device + NoGateway Text + deriving (Eq, Show) + +-- | Pure: the listing (@upnpc -l@, stdout and stderr together) read against a declared mapping. +planFor :: PortMap -> Text -> Plan +planFor pm out = case parseGateway out of + NoDevice -> NoGateway "no Internet Gateway Device answered; the router may be rebooting or UPnP may be unreachable" + NotIgd -> NoGateway "a UPnP device answered but it is not an Internet Gateway Device; UPnP may be disabled on the router" + Igd ext _ -> case classified ext of + Just reason -> DoubleNat reason + _ -> case existing of + Nothing -> NeedsAdd (describe "is not mapped") + Just m + | m.mapInternalAddress /= pm.portMapInternalAddress || m.mapInternalPort /= pm.portMapInternalPort -> + if m.mapDescription == marker pm + then NeedsAdd (describe ("points at " <> target m <> " instead")) + else Taken (describe ("is already mapped to " <> target m <> " by " <> quoted m.mapDescription)) + | expiring m -> NeedsAdd (describe "is about to expire") + | otherwise -> InPlace + where + describe what = Text.unwords [protoText pm.portMapProtocol, Text.pack (show pm.portMapExternalPort), what] + target :: Mapping -> Text + target m = m.mapInternalAddress <> ":" <> Text.pack (show m.mapInternalPort) + quoted d = if Text.null d then "an unnamed mapping" else "'" <> d <> "'" + existing = + listToMaybe + [ m + | m <- parseMappings out + , m.mapProto == pm.portMapProtocol + , m.mapExternalPort == pm.portMapExternalPort + ] + -- remaining (or original) lease at or under a quarter of the declared one + expiring :: Mapping -> Bool + expiring m = m.mapLease /= 0 && m.mapLease * 4 <= pm.portMapLeaseSeconds + classified ext = case classifyAddress <$> ext of + Just Private -> Just ("the gateway's external address is private (" <> shown ext <> "): behind another NAT, the mapping cannot be reached from the Internet") + Just CGNAT -> Just ("the gateway's external address is carrier-grade NAT (" <> shown ext <> "): the mapping cannot be reached from the Internet") + _ -> Nothing + shown = maybe "?" id + +-- | The verdict a 'Plan' is for 'check'. +checkOf :: Plan -> CheckResult +checkOf InPlace = Success +checkOf (NeedsAdd r) = Failure r +checkOf (Taken r) = Failure r +checkOf (DoubleNat r) = Failure r +checkOf (NoGateway _) = Unknown + +-- | What 'down' has to do. +data TeardownPlan + = AlreadyGone + | DeleteIt + | NotOurs Text + | CannotTell Text + deriving (Eq, Show) + +teardownFor :: PortMap -> Text -> TeardownPlan +teardownFor pm out = case parseGateway out of + NoDevice -> CannotTell "no Internet Gateway Device answered" + NotIgd -> CannotTell "a UPnP device answered but it is not an Internet Gateway Device" + Igd _ _ -> case [m | m <- parseMappings out, m.mapProto == pm.portMapProtocol, m.mapExternalPort == pm.portMapExternalPort] of + [] -> AlreadyGone + (m : _) + | m.mapDescription == marker pm -> DeleteIt + | otherwise -> NotOurs ("refusing to delete mapping '" <> m.mapDescription <> "' on external port " <> Text.pack (show pm.portMapExternalPort) <> ": it does not carry our marker " <> marker pm) + +-- | Thrown by 'up' and 'down' when they must not (or cannot) proceed. +newtype PortMappingRefused = PortMappingRefused Text + deriving (Show) + +instance Exception PortMappingRefused + +------------------------------------------------------------------------------- + +-- | Runs @upnpc -l@ and hands back everything it printed, whatever its exit status (a missing gateway exits non-zero and is an answer, not an error). +listing :: IO Text +listing = do + (_code, out, err) <- readCreateProcessWithExitCode (proc "upnpc" ["-l"]) "" + pure (dec out <> "\n" <> dec err) + where + dec = Text.decodeUtf8With Text.lenientDecode + +{- | The external address the gateway reports, if there is an IGD (for a DNS +registration node that would rather not guess). +-} +gatewayExternalAddress :: IO (Maybe Text) +gatewayExternalAddress = do + out <- Text.decodeUtf8With Text.lenientDecode . (\(_, o, e) -> o <> "\n" <> e) <$> readCreateProcessWithExitCode (proc "upnpc" ["-s"]) "" + pure $ case parseGateway out of + Igd ext _ -> ext + _ -> Nothing + +-- | Maps one port on the gateway. See the module header. +portMapping :: Reporter Report -> Track' (Binary "upnpc") -> PortMap -> Op +portMapping r upnpc pm = + withBinary upnpc upnpcCommand (Add pm) $ \add -> + withBinary upnpc upnpcCommand (Delete pm) $ \del -> + op "upnp-port-mapping" nodeps $ \actions -> + actions + { help = + Text.unwords + [ "maps" + , protoText pm.portMapProtocol + , "external port" + , Text.pack (show pm.portMapExternalPort) + , "on the gateway to" + , pm.portMapInternalAddress <> ":" <> Text.pack (show pm.portMapInternalPort) + , "(opens a port to the Internet)" + ] + , notes = + [ "UPnP is unauthenticated on the LAN side: this opens one port to the Internet" + , "description on the gateway: " <> marker pm + ] + , ref = mkRef "upnp-map" (protoText pm.portMapProtocol, pm.portMapExternalPort) + , check = checkOf . planFor pm <$> listing + , up = do + when (pm.portMapLeaseSeconds <= 0) $ + throwIO (PortMappingRefused "the lease must be positive: a permanent lease is not portable across routers") + before <- planFor pm <$> listing + case before of + InPlace -> pure () + NeedsAdd _ -> do + add (contramap (RunUpnpc (Add pm)) r) + after <- planFor pm <$> listing + when (after /= InPlace) $ + throwIO (PortMappingRefused ("the gateway did not take the mapping: " <> Text.pack (show after))) + Taken why -> throwIO (PortMappingRefused why) + DoubleNat why -> throwIO (PortMappingRefused why) + NoGateway why -> throwIO (PortMappingRefused why) + , down = do + before <- teardownFor pm <$> listing + case before of + AlreadyGone -> pure () + DeleteIt -> do + del (contramap (RunUpnpc (Delete pm)) r) + after <- teardownFor pm <$> listing + when (after /= AlreadyGone) $ + throwIO (PortMappingRefused "the gateway still lists the mapping after deleting it") + NotOurs why -> throwIO (PortMappingRefused why) + CannotTell why -> throwIO (PortMappingRefused why) + , dynamics = [toDyn pm] + } diff --git a/src/Salmon/Builtin/Nodes/PortMapping/Upnpc.hs b/src/Salmon/Builtin/Nodes/PortMapping/Upnpc.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/PortMapping/Upnpc.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Pure parsers for @upnpc@ (miniupnpc) output, and the classification of +the external address it reports. + +Kept apart from "Salmon.Builtin.Nodes.PortMapping" so that anything else that +wants to know what a gateway offers (a capabilities report, a probe) can +import the parsers without importing a node. + +The formats are those of miniupnpc 2.2.6. The "device answered but is not an +Internet Gateway Device" and "nothing answered" outputs were captured from a +real LAN; the listing format follows @upnpc.c@'s @-l@ and has not been seen +against a live IGD by the author of this module. +-} +module Salmon.Builtin.Nodes.PortMapping.Upnpc ( + Gateway (..), + parseGateway, + Mapping (..), + Proto (..), + protoText, + parseMappings, + AddressClass (..), + classifyAddress, +) where + +import Data.Char (isDigit, isSpace) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import Text.Read (readMaybe) + +data Proto = TCP | UDP + deriving (Eq, Show) + +protoText :: Proto -> Text +protoText TCP = "TCP" +protoText UDP = "UDP" + +-- | What discovery found. +data Gateway + = -- | nothing answered the multicast search + NoDevice + | -- | something answered, but it is not an Internet Gateway Device (e.g. a WPS @WFADevice.xml@) + NotIgd + | -- | a gateway, with the external address it reports and this host's LAN address when printed + Igd {gwExternal :: Maybe Text, gwLocal :: Maybe Text} + deriving (Eq, Show) + +-- | Reads the output (stdout and stderr together) of @upnpc -s@ or @upnpc -l@. +parseGateway :: Text -> Gateway +parseGateway out + | noIgd && deviceSeen = NotIgd + | noIgd = NoDevice + | otherwise = Igd (valueAfter "ExternalIPAddress = ") (valueAfter "Local LAN ip address : ") + where + ls = fmap Text.strip (Text.lines out) + noIgd = + any + (\l -> "No valid UPNP Internet Gateway Device found" `Text.isInfixOf` l || "No IGD UPnP Device found" `Text.isInfixOf` l) + ls + deviceSeen = any ("UPnP device found. Is it an IGD" `Text.isInfixOf`) ls + valueAfter key = case [Text.strip v | l <- ls, Just v <- [Text.stripPrefix key l]] of + (v : _) | not (Text.null v) -> Just v + _ -> Nothing + +-- | One line of the redirection listing. +data Mapping = Mapping + { mapProto :: Proto + , mapExternalPort :: Int + , mapInternalAddress :: Text + , mapInternalPort :: Int + , mapDescription :: Text + , mapRemoteHost :: Text + , mapLease :: Int + -- ^ seconds, 0 for permanent + } + deriving (Eq, Show) + +{- | The mappings in @upnpc -l@ output: lines of the form +@ 0 UDP 51820->192.168.1.5:51820 'description' 'remote host' 3600@. +Lines that are not of that shape are skipped. +-} +parseMappings :: Text -> [Mapping] +parseMappings = mapMaybe parseLine . Text.lines + +parseLine :: Text -> Maybe Mapping +parseLine l0 = do + let (idx, r1) = Text.break isSpace (Text.stripStart l0) + if not (Text.null idx) && Text.all isDigit idx then Just () else Nothing + let (protoTxt, r2) = Text.break isSpace (Text.stripStart r1) + proto <- case protoTxt of + "TCP" -> Just TCP + "UDP" -> Just UDP + _ -> Nothing + let (spec, r3) = Text.break isSpace (Text.stripStart r2) + (extTxt, afterArrow) = Text.breakOn "->" spec + extPort <- readMaybe (Text.unpack extTxt) + target <- Text.stripPrefix "->" afterArrow + let (addrColon, portTxt) = Text.breakOnEnd ":" target + inPort <- readMaybe (Text.unpack portTxt) + inAddr <- Text.stripSuffix ":" addrColon + -- the rest is 'description' 'remote host' lease + let (quoted, leaseTxt) = Text.breakOnEnd "'" (Text.strip r3) + lease <- readMaybe (Text.unpack (Text.strip leaseTxt)) + body <- Text.stripPrefix "'" quoted + body' <- Text.stripSuffix "'" body + let (beforeRemote, remote) = Text.breakOnEnd "'" body' + desc = Text.dropWhileEnd (\c -> c == '\'' || isSpace c) beforeRemote + pure (Mapping proto extPort inAddr inPort desc remote lease) + +data AddressClass + = Public + | -- | RFC 1918, loopback or link-local: the gateway is itself behind a NAT + Private + | -- | 100.64.0.0/10, carrier-grade NAT: no mapping on this router can be reached + CGNAT + | Unparseable + deriving (Eq, Show) + +classifyAddress :: Text -> AddressClass +classifyAddress t = case traverse (readMaybe . Text.unpack) (Text.splitOn "." (Text.strip t)) :: Maybe [Int] of + Just [a, b, c, d] + | all (\x -> x >= 0 && x <= 255) [a, b, c, d] -> go a b + _ -> Unparseable + where + go :: Int -> Int -> AddressClass + go 10 _ = Private + go 127 _ = Private + go 172 b | b >= 16 && b <= 31 = Private + go 192 168 = Private + go 169 254 = Private + go 100 b | b >= 64 && b <= 127 = CGNAT + go _ _ = Public diff --git a/src/Salmon/Builtin/Nodes/Postgres.hs b/src/Salmon/Builtin/Nodes/Postgres.hs --- a/src/Salmon/Builtin/Nodes/Postgres.hs +++ b/src/Salmon/Builtin/Nodes/Postgres.hs @@ -3,7 +3,18 @@ module Salmon.Builtin.Nodes.Postgres where +import Control.Concurrent (threadDelay) +import Control.Exception (Exception, IOException, throwIO, try) +import Control.Monad (unless, when) +import qualified Crypto.Hash as Hash +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.Random as Random import Data.Aeson (FromJSON, ToJSON) +import Data.Bits (xor) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Base64 as Base64 +import Data.Char (isAscii) +import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text @@ -18,7 +29,7 @@ import Salmon.Actions.UpDown (CheckResult (..)) import Salmon.Builtin.Extension -import Salmon.Builtin.Nodes.Binary (Binary, Command (..), justInstall, untrackedExec, withBinary, withBinaryStdin) +import Salmon.Builtin.Nodes.Binary (Binary, Command (..), justInstall, untrackedExec, withBinary, withBinaryStdin, withBinaryStdinAtUp) import qualified Salmon.Builtin.Nodes.Binary as Binary import Salmon.Builtin.Nodes.Filesystem (File, withFile) import qualified Salmon.Builtin.Nodes.Filesystem as FS @@ -303,18 +314,36 @@ newtype User = User {userRole :: RoleName} deriving (Show, ToJSON, FromJSON) +{- | A login role with this password. Its check is 'checkUserPassword': a +role whose password was changed outside salmon is a 'Failure' naming the +role, not a node that re-applies blindly every pass. + +The @ALTER ROLE@ sends a verifier computed here, not the password, so a +server with @log_statement = ddl|all@ logs that verifier; a password with a +non-ASCII character is the exception and is sent (and so may be logged) in +plaintext. See 'psqlAdminStdinSalted'. +-} user :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> User -> Password -> Op user r server psql port user pwd = - withBinary psql (psqlAdminRun_Sudo port) (CreateUser user.userRole pwd) $ \up -> + withBinaryStdinAtUp psql (psqlAdminRun_Sudo port) createUser $ \up -> op "pg-user" (deps [run server localServer]) $ \actions -> actions { ref = mkRef "pg-user" user.userRole , help = Text.unwords ["create user", user.userRole] - , up = up r' + , check = checkUserPassword port user.userRole (pure pwd) + , up = psqlAdminStdin createUser >>= \stdin -> up stdin r' } where r' = contramap (PGCreateUser user) r + createUser = CreateUser user.userRole pwd +{- | A login role whose password is the content of a file, read at @check@ +and @up@ time (never at graph build). Its check is 'checkUserPassword': the +password the cluster holds is compared with the file, so a rotation (a new +file) and a drift (a role altered by hand, restored from a backup) both show +as a 'Failure' before @up@ puts the file's password back. As for 'user', the +@ALTER ROLE@ carries a verifier, not the password, unless it is non-ASCII. +-} userPassFile :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> File "passfile" -> User -> Op userPassFile r server psql port genpass user = withFile genpass $ \passfile -> @@ -322,14 +351,150 @@ actions { ref = mkRef "pg-user" user.userRole , help = Text.unwords ["set user password for", user.userRole, "from file at", Text.pack passfile] + , check = checkUserPassword port user.userRole (readPassword passfile) , up = do up =<< fmap Password (Text.readFile passfile) } where r' = contramap (PGSetUserPass user) r runningServer = run server localServer - up pass = untrackedExec (psqlAdminRun_Sudo port) (CreateUser user.userRole pass) "" r' + up pass = do + let cmd = CreateUser user.userRole pass + stdin <- psqlAdminStdin cmd + untrackedExec (psqlAdminRun_Sudo port) cmd stdin r' +{- | The check of a @pg-user@ node: does the role exist, may it log in, and +is its password the declared one. + +PostgreSQL never gives a password back, only the verifier it keeps in +@pg_authid.rolpassword@ (SCRAM-SHA-256 since 14, MD5 before). The declared +password is run through that same verifier's parameters here and the +results compared: no login as the role is attempted, so the check is the +same whatever @pg_hba.conf@ allows, and leaves no failed authentication in +the server's log. The reading is 'interpretRoleAuthRow', which is pure. + +'Unknown' when the cluster cannot be asked or the password cannot be read +(the file is not there yet): acts like a 'Failure' for @run up@, which then +does what it did before this check existed. + +Nothing secret leaves this function: the query names the role only, and a +'Failure' says what differs, never a verifier or anything computed from the +password. +-} +checkUserPassword :: Port -> RoleName -> IO Password -> IO CheckResult +checkUserPassword port name readPass = do + pass <- try readPass :: IO (Either IOException Password) + case pass of + Left _ -> pure Unknown + Right pwd -> either (const Unknown) (interpretRoleAuthRow name pwd) <$> psqlQuery_Sudo port (roleAuthSql name) + +{- | One row, @t|VERIFIER@ or @f|VERIFIER@ (empty for a role without a +password), or none when the role does not exist. @pg_authid@, not +@pg_roles@: the latter shows the password as @********@. Needs a superuser, +which the @postgres@ OS user is. + +The role is matched by its exact name, as 'CreateUser''s own existence test +does: a name with upper case letters, which 'CreateUser' leaves unquoted and +PostgreSQL folds, is never found and the check fails every pass (and @up@ +runs every pass, as it did without a check). +-} +roleAuthSql :: RoleName -> Text +roleAuthSql name = + "SELECT CASE WHEN rolcanlogin THEN 't' ELSE 'f' END, coalesce(rolpassword, '') FROM pg_authid WHERE rolname = " + <> quoteLiteral name + +{- | The verdict on 'roleAuthSql''s output for this declared password. + +* No row: 'Failure', the role does not exist. +* @NOLOGIN@: 'Failure', since @up@ declares @LOGIN@. +* No password: 'Failure'. +* A verifier the password matches: 'Success'. +* A verifier the password does not match: 'Failure'. +* A verifier this cannot recompute (an unknown scheme, a SCRAM one for a + password that is not pure ASCII, which PostgreSQL first normalizes with + SASLprep, or an absurd iteration count): 'Unknown'. +-} +interpretRoleAuthRow :: RoleName -> Password -> Text -> CheckResult +interpretRoleAuthRow name pwd out = + case Text.lines (Text.strip out) of + [] -> Failure ("role " <> name <> " does not exist") + (row : _) -> case Text.breakOn "|" row of + (canLogin, rest) + | canLogin /= "t" -> Failure ("role " <> name <> " cannot log in") + | otherwise -> case Text.drop 1 rest of + "" -> Failure ("role " <> name <> " has no password") + verifier -> case matchesVerifier name pwd verifier of + Just True -> Success + Just False -> Failure ("the password of role " <> name <> " is not the declared one") + Nothing -> Unknown + +{- | Whether the password is the one this verifier was made from; 'Nothing' +when that cannot be told here (see 'interpretRoleAuthRow'). +-} +matchesVerifier :: RoleName -> Password -> Text -> Maybe Bool +matchesVerifier name pwd verifier + | Just hex <- Text.stripPrefix "md5" verifier + , Text.length hex == 32 = + Just (md5Verifier name pwd == verifier) + | Just params <- Text.stripPrefix "SCRAM-SHA-256$" verifier = + case Text.splitOn "$" params of + [iterSalt, keys] + | (iterText, saltText) <- Text.breakOn ":" iterSalt + , [(iters, "")] <- reads (Text.unpack iterText) + , iters > 0 + , iters <= maxScramIterations + , Right salt <- Base64.decode (Text.encodeUtf8 (Text.drop 1 saltText)) + , Text.all isAscii pwd.revealPassword -> + Just (Text.splitOn ":" keys == scramKeys iters salt pwd) + _ -> Nothing + | otherwise = Nothing + +{- | A verifier asking for more rounds than this is answered 'Unknown' +rather than computed: the check runs every pass, and PostgreSQL's own +default is 4096. +-} +maxScramIterations :: Int +maxScramIterations = 1000000 + +-- | PostgreSQL's MD5 verifier: @md5@ and the hex MD5 of the password followed by the role name. +md5Verifier :: RoleName -> Password -> Text +md5Verifier name pwd = + "md5" <> Text.pack (show (Hash.hashWith Hash.MD5 (Text.encodeUtf8 (pwd.revealPassword <> name)))) + +{- | A SCRAM-SHA-256 verifier as PostgreSQL writes it, +@SCRAM-SHA-256$ITERATIONS:SALT$STOREDKEY:SERVERKEY@ (RFC 5802, RFC 7677), +for a pure-ASCII password, which PostgreSQL uses as it is. +-} +scramVerifier :: Int -> ByteString.ByteString -> Password -> Text +scramVerifier iters salt pwd = + "SCRAM-SHA-256$" + <> Text.pack (show iters) + <> ":" + <> Text.decodeUtf8 (Base64.encode salt) + <> "$" + <> Text.intercalate ":" (scramKeys iters salt pwd) + +-- | @[StoredKey, ServerKey]@, base64, as in the verifier. +scramKeys :: Int -> ByteString.ByteString -> Password -> [Text] +scramKeys iters salt pwd = + fmap (Text.decodeUtf8 . Base64.encode) [SHA256.hash clientKey, serverKey] + where + salted = pbkdf2Sha256 (Text.encodeUtf8 pwd.revealPassword) salt iters + clientKey = SHA256.hmac salted "Client Key" + serverKey = SHA256.hmac salted "Server Key" + +{- | PBKDF2-HMAC-SHA256 with a 32-byte output, the one block SCRAM-SHA-256 +needs: @U1 = HMAC(P, S || 1)@, @Ui = HMAC(P, Ui-1)@, their XOR. +-} +pbkdf2Sha256 :: ByteString.ByteString -> ByteString.ByteString -> Int -> ByteString.ByteString +pbkdf2Sha256 pass salt iters = go (iters - 1) u1 u1 + where + u1 = SHA256.hmac pass (salt <> ByteString.pack [0, 0, 0, 1]) + go 0 _ acc = acc + go n u acc = + let u' = SHA256.hmac pass u + in go (n - 1 :: Int) u' (ByteString.pack (ByteString.zipWith xor acc u')) + data Group = Group {groupRole :: RoleName} deriving (Show, Generic) instance ToJSON Group @@ -512,60 +677,17 @@ , "'" ] ] - -- 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 - , ";" - ] - ] - ) + -- The two role commands carry a password, so their SQL is not in argv + -- (which every local user reads in /proc while psql runs, and which + -- 'Binary.CommandStart' reports): psql reads it on stdin, from + -- 'psqlAdminStdin'. @-X@ so no @.psqlrc@ turns on @ECHO@, which would + -- copy the statement into the captured output and from there into a + -- 'Binary.CommandFailed'; @VERBOSITY=terse@ so an error does not quote + -- the line it failed on (the default verbosity prints a @LINE 1:@ excerpt + -- of the statement); @ON_ERROR_STOP@ because a script read from stdin + -- otherwise exits 0 after an error. + go (CreateUser _ _) = psqlFromStdin + go (CreateReplicationUser _ _) = psqlFromStdin go (AlterSystemSet param val) = proc "sudo" @@ -650,8 +772,14 @@ ] ) - quotePass :: Password -> String - quotePass pwd = "'" <> Text.unpack pwd.revealPassword <> "'" + psqlFromStdin :: CreateProcess + psqlFromStdin = + proc + "sudo" + ( ["-u", "postgres", "psql"] + <> portArgs + <> ["-X", "-q", "-v", "ON_ERROR_STOP=1", "-v", "VERBOSITY=terse", "-f", "-"] + ) renderRight :: PGRight -> Text renderRight CREATE = "CREATE" @@ -660,6 +788,87 @@ commaList :: [Text] -> Text commaList = Text.intercalate "," +{- | What 'psqlAdminRun_Sudo' sends on psql's stdin: the role commands' SQL, +which holds the password (or a verifier of it), and nothing for every other +command (they keep their SQL in @-c@, having no secret in it). Draws a fresh +16-byte SCRAM salt each time, so it runs at @up@ time; 'psqlAdminStdinSalted' +is the same with the salt given. +-} +psqlAdminStdin :: PsqlAdmin -> IO ByteString.ByteString +psqlAdminStdin cmd = do + salt <- Random.getRandomBytes scramSaltBytes + pure (psqlAdminStdinSalted salt cmd) + +{- | 'psqlAdminStdin' with the SCRAM salt given (pure, for the tests). + +A role is created if missing and its password set either way: the password +is part of what the node declares, so a role that exists with some other one +has drifted from the declaration rather than been left alone deliberately. +Guarding the @ALTER@ behind the @IF NOT EXISTS@, as this used to, means a +rotated password never reaches the cluster and the failure arrives later as +"password authentication failed" somewhere that looks unrelated. CREATE ROLE +has no IF NOT EXISTS form, but (unlike CREATE DATABASE) it is fine inside a +@DO@ block, hence the explicit existence check. + +__The plaintext is not sent__ for a pure-ASCII password: the @ALTER ROLE@ +carries a verifier computed here, as psql's @\\password@ does, so a server +with @log_statement = ddl@ or @all@ (or an error, or @pg_stat_statements@) +records a verifier rather than the password. Which verifier follows the +server's @password_encryption@, read first with @\\gset@: MD5 (salted by the +role name, see 'md5Verifier') when it says @md5@ (or @on@), SCRAM-SHA-256 +with 4096 iterations and a random salt otherwise (see 'scramVerifier'); a +verifier is stored as it is whatever that setting says, so this keeps the +scheme the server would have chosen. 'checkUserPassword' reads either. Note +that an MD5 verifier, in a log as in @pg_authid@, is enough to log in with +the @md5@ method: only a SCRAM one is safe to see. + +A password with a non-ASCII character is still sent in plaintext, because +PostgreSQL normalizes such a password with SASLprep before deriving the +SCRAM keys and that is not reimplemented here; a server logging DDL logs it. + +Needs psql 10 or later (@\\if@). The password or verifier is a +'quoteLiteral', so a quote in it cannot end the literal (and so cannot put +the rest of it in a syntax error's text). +-} +psqlAdminStdinSalted :: ByteString.ByteString -> PsqlAdmin -> ByteString.ByteString +psqlAdminStdinSalted salt (CreateUser name pass) = Text.encodeUtf8 (roleWithPasswordSql salt "LOGIN" name pass) +psqlAdminStdinSalted salt (CreateReplicationUser name pass) = Text.encodeUtf8 (roleWithPasswordSql salt "REPLICATION LOGIN" name pass) +psqlAdminStdinSalted _ _ = "" + +-- | PostgreSQL's own default salt length (@SCRAM_DEFAULT_SALT_LEN@). +scramSaltBytes :: Int +scramSaltBytes = 16 + +-- | PostgreSQL's own default (@scram_iterations@, @SCRAM_SHA_256_DEFAULT_ITERATIONS@). +scramIterations :: Int +scramIterations = 4096 + +roleWithPasswordSql :: ByteString.ByteString -> Text -> RoleName -> Password -> Text +roleWithPasswordSql salt attrs name pass = + mconcat + [ "DO $$ BEGIN IF NOT EXISTS (SELECT FROM pg_roles WHERE rolname = '" + , name + , "') THEN CREATE ROLE " + , name + , " WITH " + , attrs + , "; END IF; END $$;\n" + , setPassword + ] + where + alterWith secret = "ALTER ROLE " <> name <> " WITH " <> attrs <> " PASSWORD " <> quoteLiteral secret <> ";\n" + setPassword + | Text.all isAscii pass.revealPassword = + mconcat + [ "SELECT current_setting('password_encryption') IN ('md5', 'on') AS salmon_md5 \\gset\n" + , "\\if :salmon_md5\n" + , alterWith (md5Verifier name pass) + , "\\else\n" + , alterWith (scramVerifier scramIterations salt pass) + , "\\endif\n" + ] + | otherwise = alterWith pass.revealPassword + ------------------------------------------------------------------------------- data ConnString pass = ConnString @@ -701,7 +910,7 @@ Op userScriptInMemoryPass r psql mksetup c@(ConnString server user pass db) file = withFile file $ \path -> - withBinary psql (psqlUserRun c) (UserScript path) $ \up -> + withBinaryStdin psql (psqlUserRun c) (UserScript path) (passwordStdin pass) $ \up -> op "pg-script" (deps [run mksetup c]) $ \actions -> actions { ref = mkRef "pg-script" path @@ -729,22 +938,54 @@ } where r' path = contramap (PGScript path) r - up path pass = untrackedExec (psqlUserRun $ c `withPassword` pass) (UserScript path) "" (r' path) + up path pass = untrackedExec (psqlUserRun c) (UserScript path) (passwordStdin pass) (r' path) data PsqlUser = UserScript FilePath -psqlUserRun :: ConnString Password -> Command "psql" PsqlUser +{- | Runs a script as the connection's user. __The password is not in argv__ +(which every local user reads in @/proc@ while psql runs, and which +'Binary.CommandStart' reports), nor in the 'CreateProcess' at all (its +environment is reported too): a @bash@ reads it from its stdin (see +'passwordStdin') into @PGPASSWORD@ and @exec@s psql with a connection URL +that has no password, so it lives only in psql's own environment, which only +the same user and root can read. Newlines in it are kept (@read -d ''@), as +they were in the URL this used to build: a password file written by +@openssl rand -hex@ ends with one, and so does the role's password set from +it. psql's stdin is @\/dev\/null@. +-} +psqlUserRun :: ConnString a -> Command "psql" PsqlUser psqlUserRun c = Command go where go (UserScript path) = proc - "psql" - [ Text.unpack $ connstring c + "bash" + [ "-c" + , "IFS= read -r -d '' PGPASSWORD || true; export PGPASSWORD; exec psql \"$@\" ByteString.ByteString +passwordStdin pass = Text.encodeUtf8 pass.revealPassword + +-- | 'connstring' without the @:password@, which libpq then takes from @PGPASSWORD@. +connstringWithoutPassword :: ConnString a -> Text +connstringWithoutPassword (ConnString server user _ db) = + mconcat + [ "postgresql://" + , user.userRole + , "@" + , server.serverHost + , ":" + , Text.pack $ show server.serverPort + , "/" + , db.getDatabase + ] + ------------------------------------------------------------------------------- -- Cluster lifecycle (named, non-"main" clusters) @@ -958,18 +1199,23 @@ } deriving (Show) --- | A login role carrying the @REPLICATION@ attribute, for a standby's @pg_basebackup@\/streaming connection. +{- | A login role carrying the @REPLICATION@ attribute, for a standby's +@pg_basebackup@\/streaming connection. Its password goes as 'user''s does: +a verifier (what @log_statement = ddl|all@ may log), except for a non-ASCII +password, sent in plaintext; see 'psqlAdminStdinSalted'. +-} replicationUser :: Reporter Report -> Track' Server -> Track' (Binary "psql") -> Port -> User -> Password -> Op replicationUser r server psql port u pwd = - withBinary psql (psqlAdminRun_Sudo port) (CreateReplicationUser u.userRole pwd) $ \up -> + withBinaryStdinAtUp psql (psqlAdminRun_Sudo port) createUser $ \up -> op "pg-replication-user" (deps [run server localServer]) $ \actions -> actions { ref = mkRef "pg-replication-user" u.userRole , help = Text.unwords ["create replication user", u.userRole] - , up = up r' + , up = psqlAdminStdin createUser >>= \stdin -> up stdin r' } where r' = contramap (PGCreateReplicationUser u) r + createUser = CreateReplicationUser u.userRole pwd alterSystemSet :: Reporter Report -> Track' (Binary "psql") -> Port -> Text -> Text -> Op alterSystemSet r psql port param val = @@ -1084,20 +1330,35 @@ something tries to connect, since the reload itself succeeds.) -} serverTls :: Reporter Report -> Track' (Binary "psql") -> Port -> ServerTls -> Op -serverTls r psql port tls = +serverTls = serverTlsAfter [] + +{- | 'serverTls', with nodes every setting and the reload wait for: the +certificate, key and CA in place with the ownership postgres demands, +typically. + +The node returned (@pg-server-tls@) has no effect of its own: a node +@inject@ed onto it is a sibling of the settings and the reload, which may +then run first and point the cluster at a key not yet there. These go under +each of them instead. With @[]@ the graph is 'serverTls''s, unchanged. +-} +serverTlsAfter :: [Op] -> Reporter Report -> Track' (Binary "psql") -> Port -> ServerTls -> Op +serverTlsAfter prerequisites r psql port tls = op "pg-server-tls" (deps [reload]) $ \actions -> actions { ref = mkRef "pg-server-tls" (port, tls.tls_certFile) , help = Text.unwords ["serves TLS on port", Text.pack (show port)] } where - reload = foldl inject (reloadConf r psql port) settings + after o = foldl inject o prerequisites + reload = foldl inject (after (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) - ] + map + after + [ alterSystemSet r psql port "ssl" "on" + , alterSystemSet r psql port "ssl_cert_file" (Text.pack tls.tls_certFile) + , alterSystemSet r psql port "ssl_key_file" (Text.pack tls.tls_keyFile) + , alterSystemSet r psql port "ssl_ca_file" (Text.pack tls.tls_caFile) + ] allowReplicationFrom :: Reporter Report -> Track' (Binary "pg_ctlcluster") -> ClusterName -> RoleName -> AllowedCidr -> Op allowReplicationFrom r pgctl name replRole cidr = @@ -1534,3 +1795,134 @@ , up = create (contramap (PGExtension e) r) , down = dropIt (contramap (PGExtension e) r) } + +------------------------------------------------------------------------------- +-- shared_preload_libraries + +{- | Something this module refuses or could not do, outside the tracked +commands of "Salmon.Builtin.Nodes.Binary" (whose failures carry their own +type). +-} +newtype PostgresError = PostgresError Text + deriving (Show) + +instance Exception PostgresError + +{- | The libraries in a @shared_preload_libraries@ value, as PostgreSQL +writes one: comma-separated, each possibly double-quoted. A library whose +quoted name contains a comma is not handled. +-} +parseLibraryList :: Text -> [Text] +parseLibraryList = filter (not . Text.null) . fmap (unquote . Text.strip) . Text.splitOn "," + where + unquote s = fromMaybe s (Text.stripPrefix "\"" s >>= Text.stripSuffix "\"") + +-- | Appends, unless it is there already. The others keep their order: it can matter. +addLibrary :: Text -> [Text] -> [Text] +addLibrary lib libs + | lib `elem` libs = libs + | otherwise = libs <> [lib] + +removeLibrary :: Text -> [Text] -> [Text] +removeLibrary lib = filter (/= lib) + +{- | @ALTER SYSTEM SET@ takes a list, and writes it back as one value. The +reload that follows changes nothing in the running server; it is what makes +the server notice the files and report the setting as @pending_restart@, +which is the question 'restartClusterIfPending' asks. + +An empty list is a @RESET@, never @= ''@: PostgreSQL writes that as +@shared_preload_libraries = '""'@, a list of one library with an empty +name, and __does not start again__ (@FATAL: could not access file ""@, +observed on 17). It is what this rendered for an empty list until +@pg_textsearch@'s Layer 2 test restarted a cluster after a teardown. A +@RESET@ drops the entry @ALTER SYSTEM@ holds, so a value in +@postgresql.conf@ itself, if there is one, applies again. +-} +alterPreloadSql :: [Text] -> Text +alterPreloadSql libs = + statement <> ";\nSELECT pg_reload_conf();\n" + where + statement = case libs of + [] -> "ALTER SYSTEM RESET shared_preload_libraries" + _ -> "ALTER SYSTEM SET shared_preload_libraries = " <> Text.intercalate ", " (fmap quoteLiteral libs) + +{- | What the configuration files say a setting is, which for a +restart-only setting is not what the running server has: a library another +node added and that is still waiting for its restart is in the files and +nowhere else, and a merge that read the running value would drop it. + +Rows with an @error@ are not left out: @pg_file_settings@ marks exactly +those entries (\"setting could not be applied\") once the files are reloaded. +-} +fileSettingSql :: Text -> Text +fileSettingSql name = + "SELECT coalesce((SELECT setting FROM pg_file_settings WHERE name = " + <> quoteLiteral name + <> " ORDER BY seqno DESC LIMIT 1), '')" + +{- | Feeds a batch to @psql@ on its standard input, as the @postgres@ OS +user, and throws a 'PostgresError' carrying @psql@'s standard error unless +it exits 0. For nodes that decide in 'IO' what the batch is; a batch known +when the graph is built goes through 'withBinaryStdin'. Not for a batch that +holds a secret: the failure text quotes what @psql@ said. +-} +psqlBatchOrThrow_Sudo :: Port -> Text -> IO () +psqlBatchOrThrow_Sudo port sql = do + (code, _out, err) <- + readCreateProcessWithExitCode + (Binary.prepare (psqlBatchRun_Sudo port) PsqlBatch) + (Text.encodeUtf8 sql) + case code of + ExitSuccess -> pure () + ExitFailure n -> + throwIO . PostgresError $ + "psql exited " + <> Text.pack (show n) + <> ": " + <> Text.strip (Text.decodeUtf8With TextError.lenientDecode err) + +{- | The library is in @shared_preload_libraries@, next to whatever else is. + +@ALTER SYSTEM SET shared_preload_libraries@ replaces the whole value, so +this reads the list the files hold and writes it back with one more entry. +That is a read followed by a write: two of these for two libraries need an +edge between them, and a declaration that sets the whole value some other +way (an 'alterSystemSet' of the same parameter has no check and runs every +pass) undoes this one every time. + +Going down takes the library out of the list and leaves the others. Neither +direction restarts anything; see 'restartClusterIfPending'. + +It was written in the experimental @pg_turret@ module, the first to need +it, and moved here when @pg_textsearch@ needed the same node: the 'Ref', the +help and the notes are the ones it had there. +-} +preloadLibrary :: Track' (Binary "psql") -> Port -> Text -> Op +preloadLibrary psql port lib = + op "pg-preload-library" (deps [justInstall psql]) $ \actions -> + actions + { ref = mkRef "pg-preload-library" (port, lib) + , help = Text.unwords ["preload", lib, "in the cluster on port", Text.pack (show port)] + , notes = ["takes effect at the next restart of the cluster", "keeps the other entries of shared_preload_libraries"] + , check = either (const Unknown) verdict <$> current + , up = rewrite (addLibrary lib) + , down = rewrite (removeLibrary lib) + } + where + current = fmap parseLibraryList <$> psqlQuery_Sudo port (fileSettingSql "shared_preload_libraries") + verdict libs + | lib `elem` libs = Success + | otherwise = Failure (lib <> " is not in shared_preload_libraries") + rewrite f = do + libs <- either (\err -> throwIO (PostgresError ("cannot read shared_preload_libraries: " <> Text.strip err))) pure =<< current + when (f libs /= libs) $ do + psqlBatchOrThrow_Sudo port (alterPreloadSql (f libs)) + awaitReload (20 :: Int) + -- A reload is a signal, and the restart node's check is a new session + -- asking the postmaster a moment later. Waits up to two seconds for the + -- flag, and carries on without it: a list put back to what the running + -- server already has is never pending. + awaitReload n = do + seen <- psqlQuery_Sudo port "SELECT pending_restart FROM pg_settings WHERE name = 'shared_preload_libraries'" + unless (n <= 0 || fmap Text.strip seen == Right "t") $ threadDelay 100000 >> awaitReload (n - 1) diff --git a/src/Salmon/Builtin/Nodes/Qemu.hs b/src/Salmon/Builtin/Nodes/Qemu.hs --- a/src/Salmon/Builtin/Nodes/Qemu.hs +++ b/src/Salmon/Builtin/Nodes/Qemu.hs @@ -68,6 +68,7 @@ import Control.Exception (SomeException, bracket, throwIO, try) import Control.Monad (filterM, void) import qualified Data.ByteString as BS +import Data.IORef (newIORef, readIORef, writeIORef) import Data.List (isPrefixOf) import Data.Text (Text) import qualified Data.Text as Text @@ -160,7 +161,7 @@ `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} + graceful = amendNode (\e -> e{down = void (shutdown grace cfg.vm_monitor_socket) >> e.down}) trackConfig :: Track' Systemd.Config trackConfig = Track $ \_ -> op "qemu-setup" (deps [justInstall qemuBin]) id @@ -305,6 +306,64 @@ drain s = do bs <- SocketBS.recv s 4096 if BS.null bs then pure () else drain s + +{- | Whether the guest's CPUs are running, as qemu's monitor says it +(@info status@). 'Paused' is what 'pause' leaves behind: qemu is still there, +its unit is still active and its monitor still answers, and the guest does +nothing at all -- no packet answered, no clock advanced. +-} +data RunState = Running | Paused | OtherState Text + deriving (Eq, Show) + +-- | Stops the guest's CPUs (@stop@). The machine a peer sees is one that went silent mid-sentence. 'False' if the monitor could not be talked to. +pause :: MonitorSocket -> IO Bool +pause sock = monitorCommand sock "stop" + +-- | Resumes a paused guest (@cont@): it carries on from the instruction it was stopped at. 'False' if the monitor could not be talked to. +resume :: MonitorSocket -> IO Bool +resume sock = monitorCommand sock "cont" + +{- | Asks the monitor @info status@. 'Nothing' when the monitor could not be +talked to or said nothing 'interpretStatus' recognises within two seconds: +"cannot tell", which is not the same as "not running". +-} +runState :: MonitorSocket -> IO (Maybe RunState) +runState sock = do + answer <- newIORef Nothing + _ <- withMonitor sock $ \s -> do + SocketBS.sendAll s (Text.encodeUtf8 "info status\n") + _ <- timeout 2000000 (collect answer s BS.empty) + pure () + readIORef answer + where + -- the monitor is a terminal: a banner, a prompt and an echo of the + -- command come before the answer, in as many reads as qemu likes. + collect answer s acc = do + bs <- SocketBS.recv s 4096 + let acc' = acc <> bs + case interpretStatus acc' of + Just st -> writeIORef answer (Just st) + Nothing -> if BS.null bs then pure () else collect answer s acc' + +{- | Reads @VM status: running@ \/ @VM status: paused (...)@ out of whatever +the monitor printed around it. 'Nothing' until a whole status line is there, +so a partial read is not mistaken for an answer. +-} +interpretStatus :: BS.ByteString -> Maybe RunState +interpretStatus bytes = + case [Text.drop (Text.length marker) found | l <- completeLines, let found = snd (Text.breakOn marker l), not (Text.null found)] of + [] -> Nothing + (rest : _) -> Just $ case Text.words rest of + ("running" : _) -> Running + ("paused" : _) -> Paused + _ -> OtherState (Text.strip rest) + where + marker = "VM status: " + txt = Text.decodeUtf8With (\_ _ -> Just '?') bytes + -- the last piece is only a line once its newline has arrived + completeLines = case Text.splitOn "\n" txt of + [] -> [] + pieces -> init pieces -- | Is something accepting connections on the monitor socket? listening :: MonitorSocket -> IO Bool diff --git a/src/Salmon/Builtin/Nodes/Readiness.hs b/src/Salmon/Builtin/Nodes/Readiness.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/Readiness.hs @@ -0,0 +1,269 @@ +{- | Waiting for a service to answer. + +@podman run -d@ (or @systemctl start@, or a detached process) returns long +before the service inside accepts anything: Postgres takes a few seconds to +open its socket, an HTTP server longer to warm up. A dependant applied in +that window fails for no reason of its own. 'waitUntil' is the node that sits +between the two: it does nothing but ask, and its dependants run once the +answer is yes. + +The question is a 'Probe' (a command that exits 0, or a TCP port that +accepts) or any @IO Bool@ ('untilIO'), so the same node serves a database in +a container ('pgIsReady', 'podmanExec'), a published port ('ProbeTcp') and an +HTTP health endpoint the caller asks in its own way. + +* @check@ asks once. Yes is 'Success' (the node is skipped); no is 'Unknown', + not 'Failure': the node cannot make the service answer, only wait for it, + so a "no" is a service on its way up (or down), which is what 'Unknown' is + for. Under @run serve@ it restarts nothing; the node that runs the service + is the one whose own check should notice it gone. +* @up@ asks again every 'waitEvery' milliseconds until yes or until + 'waitDeadline' seconds have passed, and then throws 'NotReadyInTime', so + the node is @Failed@ and its dependants @Blocked@. +* @down@ does nothing: there is no effect to take back. + +Each attempt is cut at five seconds (or at what is left of the deadline, +whichever is shorter), and an attempt that throws counts as "no". + +The probe is run on the machine salmon runs on, as whoever runs it. Its +command and arguments are rendered in @help@ and @notes@, which are public: +a probe must not carry a secret on its command line. +-} +module Salmon.Builtin.Nodes.Readiness ( + -- * probes + Probe (..), + describeProbe, + runProbe, + pgIsReady, + podmanExec, + + -- * the node + WaitUntil (..), + untilProbe, + untilIO, + waitUntil, + NotReadyInTime (..), + + -- * the wait, apart from the node + Clock (..), + systemClock, + pollUntil, + askOnce, +) where + +import Control.Concurrent (threadDelay) +import Control.Exception (Exception (..), SomeException, bracket, throwIO, try) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Clock (getMonotonicTimeNSec) +import qualified Network.Socket as Net +import System.Exit (ExitCode (..)) +import System.Process (proc, readCreateProcessWithExitCode) +import System.Timeout (timeout) + +import Salmon.Actions.UpDown (CheckResult (..)) +import Salmon.Builtin.Extension +import Salmon.Op.Ref (mkRef) + +------------------------------------------------------------------------------- + +{- | A question asked from the machine salmon runs on, as whoever runs it, +whose answer "yes" means the service does its job. +-} +data Probe + = -- | a TCP connection to this host and port is accepted (a published port) + ProbeTcp Text Int + | -- | this command exits 0. It is run on the /host/; one asking inside + -- the container is @ProbeCommand "podman" ["exec", NAME, ...]@ + -- (see 'podmanExec') + ProbeCommand FilePath [Text] + deriving (Eq, Ord, Show) + +describeProbe :: Probe -> Text +describeProbe (ProbeTcp host port) = "tcp " <> host <> ":" <> Text.pack (show port) <> " accepts" +describeProbe (ProbeCommand cmd args) = "`" <> Text.unwords (Text.pack cmd : args) <> "` exits 0" + +{- | One attempt, cut at five seconds; anything thrown is "no". + +The command's stdin is a pipe closed at once (never the caller's, which +under @run serve@ is the command channel), and its output is discarded. +-} +runProbe :: Probe -> IO Bool +runProbe probe = do + answer <- timeout 5000000 (try attempt) :: IO (Maybe (Either SomeException Bool)) + pure $ case answer of + Just (Right ok) -> ok + _ -> False + where + attempt :: IO Bool + attempt = case probe of + ProbeCommand cmd args -> do + (code, _out, _err) <- readCreateProcessWithExitCode (proc cmd (map Text.unpack args)) "" + pure (code == ExitSuccess) + ProbeTcp host port -> do + let hints = Net.defaultHints{Net.addrSocketType = Net.Stream} + addrs <- Net.getAddrInfo (Just hints) (Just (Text.unpack host)) (Just (show port)) + case addrs of + [] -> pure False + addr : _ -> + bracket (Net.openSocket addr) Net.close $ \sock -> + True <$ Net.connect sock (Net.addrAddress addr) + +{- | The host's @pg_isready@ against this host and port: exit 0 only once the +server accepts connections (1 while it is starting, 2 with no answer). It +needs no password, so nothing secret is on the command line. +-} +pgIsReady :: Text -> Int -> Probe +pgIsReady host port = + ProbeCommand "pg_isready" ["--host", host, "--port", Text.pack (show port), "--quiet"] + +{- | This command, run inside the named container with @podman exec@, exits 0: +@podmanExec "db" "pg_isready" ["--quiet"]@ asks the container's own +@pg_isready@, for a database whose port is not published. +-} +podmanExec :: Text -> FilePath -> [Text] -> Probe +podmanExec container cmd args = ProbeCommand "podman" ("exec" : container : Text.pack cmd : args) + +------------------------------------------------------------------------------- + +-- | What 'waitUntil' waits for, and how long. +data WaitUntil + = WaitUntil + { waitKey :: Text + -- ^ the node's 'Salmon.Op.Ref.Ref' key: two waits with one key are one + -- node (last writer wins), so name the service, e.g. @"db-pg"@ + , waitAsking :: Text + -- ^ what is asked, for @help@ and @notes@ (public: no secrets) + , waitProbe :: IO Bool + -- ^ one attempt; an exception counts as "no" + , waitDeadline :: Int + -- ^ seconds @up@ waits for a yes before it throws. Below one, @up@ asks + -- exactly once. + , waitEvery :: Int + -- ^ milliseconds between two attempts + } + +-- | Wait for this probe, for up to this many seconds, asking four times a second. +untilProbe :: Text -> Probe -> Int -> WaitUntil +untilProbe key probe seconds = + WaitUntil + { waitKey = key + , waitAsking = describeProbe probe + , waitProbe = runProbe probe + , waitDeadline = seconds + , waitEvery = 250 + } + +{- | Wait for any @IO Bool@ (an HTTP health endpoint, a file appearing), said +in words for @help@ and @notes@, for up to this many seconds, asking four +times a second. +-} +untilIO :: Text -> Text -> IO Bool -> Int -> WaitUntil +untilIO key asking probe seconds = + WaitUntil + { waitKey = key + , waitAsking = asking + , waitProbe = probe + , waitDeadline = seconds + , waitEvery = 250 + } + +-- | The service never answered yes within the deadline. +data NotReadyInTime = NotReadyInTime + { notReadyKey :: Text + , notReadyAsking :: Text + , notReadySeconds :: Int + } + deriving (Show) + +instance Exception NotReadyInTime where + displayException e = + Text.unpack $ + "not ready after " + <> Text.pack (show e.notReadySeconds) + <> "s (" + <> e.notReadyKey + <> "): " + <> e.notReadyAsking + <> " never held" + +{- | A node that is satisfied once the service answers; see the module +header for what each of @check@, @up@ and @down@ does. Put it between the +node that starts the service and the ones that use it: + +@ +waitUntil (untilProbe "db-pg" (pgIsReady "127.0.0.1" 5432) 60) + \`inject\` runDatabaseContainer +@ +-} +waitUntil :: WaitUntil -> Op +waitUntil w = + op "wait-until" nodeps $ \actions -> + actions + { help = "waits until " <> w.waitAsking <> " (up to " <> seconds <> ")" + , notes = + [ "asks: " <> w.waitAsking + , "every " <> Text.pack (show w.waitEvery) <> "ms, for up to " <> seconds <> ", then fails" + , "check asks once: no answer is Unknown, not Failure" + , "down does nothing" + ] + , ref = mkRef "wait-until" w.waitKey + , check = do + ok <- askOnce 5000 w.waitProbe + pure (if ok then Success else Unknown) + , up = do + answered <- pollUntil systemClock (w.waitDeadline * 1000) w.waitEvery w.waitProbe + if answered + then pure () + else throwIO (NotReadyInTime w.waitKey w.waitAsking w.waitDeadline) + } + where + seconds :: Text + seconds = Text.pack (show w.waitDeadline) <> "s" + +------------------------------------------------------------------------------- + +-- | Time, in milliseconds, so that 'pollUntil' can be driven without sleeping. +data Clock = Clock + { clockNow :: IO Int + -- ^ monotonic milliseconds + , clockSleep :: Int -> IO () + -- ^ sleep this many milliseconds + } + +systemClock :: Clock +systemClock = + Clock + { clockNow = (\ns -> fromIntegral (ns `div` 1000000)) <$> getMonotonicTimeNSec + , clockSleep = \ms -> threadDelay (ms * 1000) + } + +-- | One attempt, cut at this many milliseconds; anything thrown is "no". +askOnce :: Int -> IO Bool -> IO Bool +askOnce ms probe = do + answer <- timeout (max 1 ms * 1000) (try probe) :: IO (Maybe (Either SomeException Bool)) + pure $ case answer of + Just (Right ok) -> ok + _ -> False + +{- | Ask until yes (True) or until @budget@ milliseconds have passed since +the first attempt (False), sleeping @every@ milliseconds in between. Always +asks at least once, and every attempt gets at least 100ms, so the last one +may end that much past the budget. +-} +pollUntil :: Clock -> Int -> Int -> IO Bool -> IO Bool +pollUntil clock budget every probe = do + start <- clock.clockNow + let go = do + now <- clock.clockNow + let remaining = budget - (now - start) + ok <- askOnce (min 5000 (max 100 remaining)) probe + if ok + then pure True + else do + after <- clock.clockNow + let left = budget - (after - start) + if left <= 0 + then pure False + else clock.clockSleep (max 1 (min every left)) >> go + go diff --git a/src/Salmon/Builtin/Nodes/Rsync.hs b/src/Salmon/Builtin/Nodes/Rsync.hs --- a/src/Salmon/Builtin/Nodes/Rsync.hs +++ b/src/Salmon/Builtin/Nodes/Rsync.hs @@ -1,5 +1,6 @@ module Salmon.Builtin.Nodes.Rsync 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 @@ -8,9 +9,14 @@ import Salmon.Op.Ref import Salmon.Reporter +import Control.Exception (IOException, try) 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 qualified Data.Text.Encoding.Error as Text +import System.Exit (ExitCode (..)) import System.FilePath (takeDirectory, ()) import System.Process.ByteString (readCreateProcessWithExitCode) @@ -122,12 +128,184 @@ dirpath :: FilePath dirpath = dir.directoryPath +{- | Copies a directory /from/ a remote under a local one: 'sendDir' in the +other direction, and 'receiveFile' for more than one file. It exists so that +fetching a directory of results does not need an archive made on the remote +first. + +The paths mean what they mean to rsync, as they do for 'sendDir': a remote +path without a trailing slash lands as a directory of that name /under/ the +local one (@\/srv\/results@ into @\/var\/in@ is @\/var\/in\/results@), and one +with a trailing slash has its contents put directly in the local one. + +Unlike 'sendDir' this node has a 'check', which is what lets a pass run again +without fetching again: rsync is asked, with @--dry-run --itemize-changes@, +what the transfer would do, and the answer is read by 'interpretProbe'. Two +things follow from that: + +* the transfer carries @--times@, which 'sendDir' does not. Without it the + local copies get the time of the transfer, rsync's size-and-time comparison + never finds a file up to date, and both the check and the fetch would redo + everything every time. So the local files carry the remote's modification + times. +* asking costs one ssh connection and a walk of the directory on both sides, + each time something asks: every pass of @run up@, and every look a + supervisor takes under @serve@. + +A remote that cannot be reached, or an rsync that fails for any other reason, +answers 'Unknown' and not 'Failure': the check could not look, and that is +different from having looked and found the local copy behind. + +Nothing is deleted. A file gone from the remote stays in the local copy (no +@--delete@), and @down@ leaves the fetched directory alone for the reason +'receiveFile' gives. A file changed locally is fetched again when its size or +time no longer match the remote's. +-} +receiveDir :: + Reporter Report -> + Track' (Binary "rsync") -> + Track' Directory -> + Remote -> + -- | directory on the remote + FilePath -> + -- | local directory to copy it under + Directory -> + Op +receiveDir = receiveDirWith Ssh.noClientOpts + +{- | 'receiveDir', with explicit ssh client options, through @--rsh@ as for +'sendDirWith'. They are not part of the node's 'ref': the same directory +fetched to the same place is the same effect whichever key reached it. +-} +receiveDirWith :: + Ssh.ClientOpts -> + Reporter Report -> + Track' (Binary "rsync") -> + Track' Directory -> + Remote -> + -- | directory on the remote + FilePath -> + -- | local directory to copy it under + Directory -> + Op +receiveDirWith opts r rsync mkdir remote remotepath dir = + withBinary rsync rsyncRun cmd $ \up -> + op "rsync:receive-dir" (deps [run mkdir dir]) $ \actions -> + actions + { help = "copies " <> Text.pack remotepath <> " from " <> loginAtHost remote <> " under " <> Text.pack dirpath <> " over rsync" + , ref = mkRef "rsync-receivedir" (remotepath, dirpath, remote.remoteUser, remote.remoteHost) + , check = probeReceiveDir r remote remotepath dirpath opts + , up = up r' + , down = pure () + } + where + cmd = ReceiveDir remote remotepath dirpath opts + r' = contramap (RunRsyncCommand cmd) r + dirpath :: FilePath + dirpath = dir.directoryPath + +{- | Asks rsync what 'receiveDir' would transfer, without transferring it. + +The command's standard input is a pipe that is closed at once, never this +process's own. A process that could not be started at all (no @rsync@) is +'Unknown' like any other way of not having been able to look. +-} +probeReceiveDir :: Reporter Report -> Remote -> FilePath -> FilePath -> Ssh.ClientOpts -> IO CheckResult +probeReceiveDir r remote remotepath dirpath opts = do + runReporter r' (Binary.CommandStart p) + ran <- try (readCreateProcessWithExitCode p "") + case ran of + Left (_ :: IOException) -> pure Unknown + Right (code, out, err) -> do + runReporter r' (Binary.CommandStopped p code out err) + pure (interpretProbe code out) + where + cmd = ProbeReceiveDir remote remotepath dirpath opts + p = Binary.prepare rsyncRun cmd + r' = contramap (RunRsyncCommand cmd) r + +{- | The verdict drawn from a 'ProbeReceiveDir' run: its exit code and what +it wrote on standard output. + +A non-zero exit is 'Unknown' whatever was printed (rsync could not complete +the comparison). Otherwise the copy is in place exactly when no line is +'Pending'. The 'Failure' text counts the differing items and names none of +them. +-} +interpretProbe :: ExitCode -> ByteString -> CheckResult +interpretProbe (ExitFailure _) _ = Unknown +interpretProbe ExitSuccess out = + case length (filter (== Pending) (probeLines out)) of + 0 -> Success + n -> Failure (Text.pack (show n) <> " item(s) differ from the remote directory") + +-- | What one line of @rsync --dry-run --itemize-changes@ says. +data ProbeLine + = -- | says nothing about the transfer: a blank line, or rsync's remark + -- about something it never copies (@skipping non-regular file@) + Noise + | -- | an item rsync looked at and would leave alone (only printed when + -- asked twice for itemizing, which the probe does not do) + Unchanged + | -- | anything else: an item to create, update or retouch, or a line + -- this module does not know + Pending + deriving (Show, Eq, Ord) + +probeLines :: ByteString -> [ProbeLine] +probeLines = map classifyProbeLine . Text.lines . Text.decodeUtf8With Text.lenientDecode + +{- | Reads one line of the probe's output. + +Deliberately lopsided: only what is positively recognised as harmless is +'Noise' or 'Unchanged', and everything else is 'Pending'. Being wrong towards +'Pending' costs an rsync run that transfers nothing; being wrong the other way +would leave a stale copy in place for good. + +An itemized line is rsync's @YXcstpoguax@ followed by a space and the path: +eleven characters, the first being the kind of update and the last nine the +attributes. An item is unchanged when the update is @.@ and no attribute is +named (blanks or dots). +-} +classifyProbeLine :: Text -> ProbeLine +classifyProbeLine line + | Text.null (Text.strip line) = Noise + | "skipping " `Text.isPrefixOf` line = Noise + | isUnchangedItem = Unchanged + | otherwise = Pending + where + (code, rest) = Text.splitAt itemizedWidth line + isUnchangedItem = + Text.length code == itemizedWidth + && " " `Text.isPrefixOf` rest + && Text.take 1 code == "." + && Text.all (`elem` ("fdLDS" :: String)) (Text.take 1 (Text.drop 1 code)) + && Text.all (`elem` (" ." :: String)) (Text.drop 2 code) + +-- | The width of rsync's itemized-change code, @YXcstpoguax@. +itemizedWidth :: Int +itemizedWidth = 11 + data RsyncCommand = SendFile FilePath Remote FilePath Ssh.ClientOpts | ReceiveFile Remote FilePath FilePath Ssh.ClientOpts | SendDir FilePath Remote FilePath Ssh.ClientOpts + | -- | remote, directory there, local directory to copy it under + ReceiveDir Remote FilePath FilePath Ssh.ClientOpts + | -- | 'ReceiveDir' asked as a question: same operands, nothing written + ProbeReceiveDir Remote FilePath FilePath Ssh.ClientOpts deriving (Show) +{- | The flags of a directory fetch. @--times@ is what makes a second run find +the first one's files up to date; see 'receiveDir'. +-} +receiveDirFlags :: [String] +receiveDirFlags = ["--copy-links", "--recursive", "--times"] + +-- | What turns the fetch into a question about it. +probeFlags :: [String] +probeFlags = ["--dry-run", "--itemize-changes"] + rsyncRun :: Command "rsync" RsyncCommand rsyncRun = Command $ \run -> case run of @@ -146,6 +324,17 @@ ["--copy-links", "--recursive"] <> (case Ssh.clientArgs opts of [] -> []; args -> ["--rsh", unwords ("ssh" : args)]) <> [src, Text.unpack (loginAtHost rem) <> ":" <> dst] + (ReceiveDir rem src dst opts) -> + proc "rsync" $ + receiveDirFlags + <> (case Ssh.clientArgs opts of [] -> []; args -> ["--rsh", unwords ("ssh" : args)]) + <> [Text.unpack (loginAtHost rem) <> ":" <> src, dst] + (ProbeReceiveDir rem src dst opts) -> + proc "rsync" $ + receiveDirFlags + <> probeFlags + <> (case Ssh.clientArgs opts of [] -> []; args -> ["--rsh", unwords ("ssh" : args)]) + <> [Text.unpack (loginAtHost rem) <> ":" <> src, dst] loginAtHost :: Remote -> Text loginAtHost rem = mconcat [rem.remoteUser, "@", rem.remoteHost] diff --git a/src/Salmon/Builtin/Nodes/SecretDelivery.hs b/src/Salmon/Builtin/Nodes/SecretDelivery.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/SecretDelivery.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Putting a secret that already exists onto the machine that needs it. + +Recipes in this tree take secrets as /pre-provisioned files/: a path, an +owner, and the assumption that something else put the bytes there. This +module is that something else, and it is deliberately a builtin a caller +opts into rather than a step inside any recipe -- a recipe that shipped its +own secrets would have chosen a transport for everybody who uses it. + +Two transports, one per side of a hand-off: + +* 'uploadSecretFile' runs on the /controlling/ machine and writes a local + file onto a remote over ssh, with an owner and a mode. It is what a + "SreBox.Gcp.VmProvision" @vmp_beforeCall@ wants. +* 'installSecretBytes' / 'checkInstalledSecret' are the on-machine half, the + part of "Salmon.Builtin.Nodes.Gcp.SecretManager".@secretFile@ that is not + about GCP: bytes obtained locally, placed atomically. + +What every function here has in common is what it does /not/ do with the +bytes: + +* they are read at @up@\/@check@ time, never when the graph is built, so + they are not in the directive, the @ref@, @help@ or @notes@; +* they travel on a process's standard input, never in its argv (which is + world-readable through @\/proc@ for as long as the process lives); +* no report, failure text or exception carries them, and neither does any + digest of them. A fingerprint in @notes@ is what would let @run serve@ see + a re-declared secret as a changed node, and it is left out on purpose: a + digest of a password is an offline guessing oracle for whoever reads a + report, and reports are public. The cost is that a changed secret is + noticed by the node's @check@ (which compares the bytes themselves, over + the same channel that carries them) and not by @Dag.sameRepresentative@. +-} +module Salmon.Builtin.Nodes.SecretDelivery ( + -- * Where a secret goes + Placement (..), + validatePlacement, + + -- * Upload over ssh + SecretUpload (..), + Elevation (..), + uploadSecretFile, + Report (..), + SecretDeliveryError (..), + + -- * The remote scripts, and what their exit codes mean + uploadScript, + probeScript, + removeScript, + interpretProbe, + deliveryCommand, + DeliveryCommand (..), + remoteCommand, + shellQuote, + + -- * On-machine placement + installSecretBytes, + checkInstalledSecret, + removeInstalledSecret, +) where + +import Control.Exception (Exception, onException, throwIO) +import Control.Monad (unless, when) +import Data.Bits ((.&.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import Data.Char (isAlphaNum, isOctDigit) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.IO.Exception (ExitCode (..)) +import Numeric (readOct) +import System.Directory (doesFileExist, getFileSize, removeFile, renameFile) +import System.FilePath (isAbsolute) +import System.IO (Handle, IOMode (..), hClose, stderr, withBinaryFile) +import System.Posix.Files (fileGroup, fileMode, fileOwner, getFileStatus, setFileMode, setOwnerAndGroup) +import System.Posix.IO (createFile, fdToHandle) +import System.Posix.Types (FileMode) +import System.Posix.User (getGroupEntryForName, getUserEntryForName, groupID, userID) +import System.Process (ProcessHandle, StdStream (..), waitForProcess) +import System.Process.ListLike (CreateProcess (..), proc) + +import Salmon.Actions.UpDown (CheckResult (..)) +import Salmon.Builtin.Extension +import Salmon.Builtin.Nodes.Binary (Binary, CommandIO (..), untrackedExecIO, withBinaryIO) +import qualified Salmon.Builtin.Nodes.Ssh as Ssh +import Salmon.Op.Ref +import Salmon.Reporter + +------------------------------------------------------------------------------- + +{- | What is said about a delivery. It names files and machines and carries +an exit code; there is no constructor that could hold the bytes. +-} +data Report + = UploadStart !SecretUpload + | UploadDone !SecretUpload !ExitCode + | RemoveDone !SecretUpload !ExitCode + deriving (Show) + +-- | Thrown by @up@. The text names paths and machines, never contents. +newtype SecretDeliveryError = SecretDeliveryError Text + +instance Show SecretDeliveryError where + show (SecretDeliveryError t) = "secret delivery: " <> Text.unpack t + +instance Exception SecretDeliveryError + +------------------------------------------------------------------------------- + +-- | Where a secret file goes, and who may read it. +data Placement = Placement + { placePath :: FilePath + -- ^ absolute + , placeOwner :: Text + , placeGroup :: Text + , placeMode :: Text + -- ^ octal, three or four digits (@"0600"@, @"640"@). A mode granting + -- anything to /others/ is refused: there is no secret that is right for. + } + deriving (Eq, Ord, Show) + +{- | The placement with its mode normalized (no leading zeros, the way +@stat -c %a@ prints one), or why it is refused. + +Everything here ends up inside a shell script run as root on another +machine, so this is the narrow gate: names are plain account names, the mode +is digits. The path is quoted rather than restricted ('shellQuote'), but a +newline or a NUL in one is refused as a mistake. +-} +validatePlacement :: Placement -> Either Text Placement +validatePlacement p + | not (isAbsolute p.placePath) = refuse "the path must be absolute" + | any (`elem` ['\n', '\r', '\0']) p.placePath = refuse "the path holds a control character" + | not (accountName p.placeOwner) = refuse "the owner must be a plain account name" + | not (accountName p.placeGroup) = refuse "the group must be a plain group name" + | Text.length p.placeMode < 3 || Text.length p.placeMode > 4 || not (Text.all isOctDigit p.placeMode) = + refuse "the mode must be three or four octal digits" + | Text.last p.placeMode /= '0' = refuse "the mode grants access to others" + | otherwise = Right p{placeMode = normalized} + where + refuse why = Left (Text.pack p.placePath <> ": " <> why) + normalized = case Text.dropWhile (== '0') p.placeMode of + "" -> "0" + m -> m + accountName t = case Text.uncons t of + Just (c, _) -> c /= '-' && Text.all (\x -> isAlphaNum x && x < '\x80' || x `elem` ['_', '-', '.']) t + Nothing -> False + +------------------------------------------------------------------------------- + +-- | Whether the remote side needs root to write where the secret goes. +data Elevation + = -- | write as the ssh login user + AsLoginUser + | -- | write under @sudo -n@: for any owner but the login user + WithSudo + deriving (Eq, Ord, Show) + +-- | A local secret file, and where it goes on which machine. +data SecretUpload = SecretUpload + { uploadSource :: FilePath + -- ^ on the controlling machine; read when @up@ or @check@ runs, so a + -- secret generated by an earlier node of the same pass is the one sent. + , uploadRemote :: Ssh.Remote + , uploadPlacement :: Placement + , uploadElevation :: Elevation + } + deriving (Eq, Show) + +{- | Writes a local secret file onto a remote over ssh, owned and moded as +declared. + +The bytes go down the ssh connection as the remote command's standard input, +into a temporary file beside the destination (created @0600@, so there is no +moment at which it is more readable than it will end up), which is then +chowned, chmoded and renamed over the destination: a reader sees the old +secret or the new one, never half of either. A missing enclosing directory +is created owned as the file and @0750@; an existing one is left as it is. + +@check@ compares the remote file with the local one byte for byte (@cmp@ on +the remote, fed over the same connection) and then its owner and mode, so a +healthy delivery is skipped and a rotated, edited or re-moded one is put +back. An unreachable machine is 'Unknown', not 'Failure': nothing was +learned about the file. + +@down@ removes the remote file (the local one is somebody else's node), and +treats a machine it cannot reach as having nothing left to remove: a failed +@down@ blocks the teardown of everything beneath it, which here includes the +machine. + +The 'Ref' is the remote host and path -- the effect site -- so two +declarations putting different files at one path collide, as they should. +-} +uploadSecretFile :: Ssh.ClientOpts -> Reporter Report -> Track' (Binary "ssh") -> SecretUpload -> Op +uploadSecretFile opts r ssh upload = + withBinaryIO ssh deliveryCommand (deliver uploadScript) $ \send -> + op "secret:upload" nodeps $ \actions -> + actions + { help = + Text.unwords + [ "uploads the secret file" + , Text.pack upload.uploadSource + , "to" + , Ssh.loginAtHost upload.uploadRemote <> ":" <> Text.pack place.placePath + ] + , notes = + [ "owner " <> place.placeOwner <> ":" <> place.placeGroup <> ", mode " <> place.placeMode + , "the contents are sent on standard input and never reported" + ] + , ref = mkRef "secret-upload" (upload.uploadRemote.remoteHost, place.placePath) + , check = checkUpload + , up = do + valid + sourceReady + runReporter r (UploadStart upload) + code <- feeding upload.uploadSource send + runReporter r (UploadDone upload code) + exited "upload to" code + , down = do + valid + code <- feeding "/dev/null" (untrackedExecIO deliveryCommand (deliver removeScript)) + runReporter r (RemoveDone upload code) + -- 255 is ssh failing to connect. A machine that cannot + -- be reached is usually one that is already gone, and a + -- throw here would leave this node standing and block + -- the teardown of the very machine it is on. + unless (code == ExitFailure 255) (exited "removal from" code) + } + where + place = upload.uploadPlacement + + -- An invalid placement renders a harmless script: every action checks + -- 'valid' before running anything. + deliver script = DeliveryCommand opts upload.uploadRemote upload.uploadElevation (script (either (const place) id (validatePlacement place))) + + valid :: IO () + valid = either (throwIO . SecretDeliveryError) (const (pure ())) (validatePlacement place) + + sourceReady :: IO () + sourceReady = do + present <- doesFileExist upload.uploadSource + unless present $ throwIO (SecretDeliveryError ("nothing to upload: " <> Text.pack upload.uploadSource)) + size <- getFileSize upload.uploadSource + when (size == 0) $ throwIO (SecretDeliveryError ("refusing to upload an empty secret: " <> Text.pack upload.uploadSource)) + + exited :: Text -> ExitCode -> IO () + exited _ ExitSuccess = pure () + exited what (ExitFailure n) = + throwIO . SecretDeliveryError $ + Text.unwords [what, Ssh.loginAtHost upload.uploadRemote <> ":" <> Text.pack place.placePath, "failed (ssh exit", Text.pack (show n) <> ")"] + + checkUpload :: IO CheckResult + checkUpload = case validatePlacement place of + Left why -> pure (Failure why) + Right _ -> do + present <- doesFileExist upload.uploadSource + if not present + then pure (Failure ("nothing to upload: " <> Text.pack upload.uploadSource)) + else interpretProbe place <$> feeding upload.uploadSource (untrackedExecIO deliveryCommand (deliver probeScript)) + +-- | Runs a prepared remote command with a local file as its standard input. +feeding :: FilePath -> (Handle -> IO (a, b, c, ProcessHandle)) -> IO ExitCode +feeding path exec = + withBinaryFile path ReadMode $ \h -> do + (_, _, _, ph) <- exec h + waitForProcess ph + +------------------------------------------------------------------------------- + +-- | One ssh invocation: who to reach, as whom, and the script to run there. +data DeliveryCommand = DeliveryCommand Ssh.ClientOpts Ssh.Remote Elevation Text + deriving (Show) + +{- | @ssh@ running a script on the remote with the given handle as its +standard input. The remote's standard output is sent to this process's +standard error: the scripts print nothing, and a salmon binary's standard +output may be a @--json@ stream. + +@BatchMode@ because the only thing that may ever be read from the terminal +here is nothing. +-} +deliveryCommand :: CommandIO "ssh" DeliveryCommand Handle +deliveryCommand = CommandIO $ \(DeliveryCommand opts remote elevation script) input -> + pure + ( proc + "ssh" + ( ["-o", "BatchMode=yes"] + <> Ssh.clientArgs opts + <> [Text.unpack (Ssh.loginAtHost remote), remoteCommand elevation script] + ) + ) + { std_in = UseHandle input + , std_out = UseHandle stderr + } + +{- | The single word handed to ssh as the remote command. ssh joins its +arguments with spaces and gives the result to the remote user's shell, so +the script has to arrive as one quoted argument of @sh -c@. +-} +remoteCommand :: Elevation -> Text -> String +remoteCommand elevation script = + Text.unpack (prefix <> "sh -c " <> shellQuote script) + where + prefix = case elevation of + AsLoginUser -> "" + WithSudo -> "sudo -n " + +-- | A string as one single-quoted POSIX shell word. +shellQuote :: Text -> Text +shellQuote t = "'" <> Text.replace "'" "'\\''" t <> "'" + +{- | Reads the secret from standard input into place. Expects a placement +that went through 'validatePlacement'. +-} +uploadScript :: Placement -> Text +uploadScript p = + Text.intercalate + "\n" + [ "set -eu" + , "p=" <> path + , "d=$(dirname \"$p\")" + , "if [ ! -d \"$d\" ]; then" + , " mkdir -p \"$(dirname \"$d\")\"" + , " install -d -m 0750 -o " <> shellQuote p.placeOwner <> " -g " <> shellQuote p.placeGroup <> " \"$d\"" + , "fi" + , "umask 077" + , "t=$(mktemp \"$p.XXXXXX\")" + , "trap 'rm -f \"$t\"' EXIT" + , "cat > \"$t\"" + , "test -s \"$t\"" + , "chown " <> shellQuote (p.placeOwner <> ":" <> p.placeGroup) <> " \"$t\"" + , "chmod " <> shellQuote p.placeMode <> " \"$t\"" + , "mv -f \"$t\" \"$p\"" + ] + where + path = shellQuote (Text.pack p.placePath) + +{- | Compares the file in place with standard input, then its owner and +mode. Exits 0 when all three match, 3 when the file is absent, 4 when the +contents differ, 5 when the owner or mode do, 6 when it could not be read. +Prints nothing. +-} +probeScript :: Placement -> Text +probeScript p = + Text.intercalate + "\n" + [ "p=" <> shellQuote (Text.pack p.placePath) + , "[ -f \"$p\" ] || exit 3" + , "cmp -s - \"$p\"" + , "case $? in 0) ;; 1) exit 4 ;; *) exit 6 ;; esac" + , "[ \"$(stat -c '%U:%G %a' \"$p\")\" = " <> shellQuote (p.placeOwner <> ":" <> p.placeGroup <> " " <> p.placeMode) <> " ] || exit 5" + , "exit 0" + ] + +-- | Removes the file in place; succeeds when there is none. +removeScript :: Placement -> Text +removeScript p = "rm -f " <> shellQuote (Text.pack p.placePath) + +{- | The verdict drawn from 'probeScript'\'s exit code as ssh relays it. + +255 is ssh's own "could not connect", which says nothing about the file: +'Unknown', so that a supervisor keeps looking rather than re-uploading at a +machine it cannot reach. (A one-shot pass reads 'Unknown' as "apply", and the +upload then fails loudly, which is the right report.) +-} +interpretProbe :: Placement -> ExitCode -> CheckResult +interpretProbe _ ExitSuccess = Success +interpretProbe p (ExitFailure n) = case n of + 3 -> Failure ("missing: " <> path) + 4 -> Failure (path <> " holds different contents") + 5 -> Failure (path <> " has the wrong owner or mode") + 6 -> Failure (path <> " could not be read") + 255 -> Unknown + _ -> Failure ("could not inspect " <> path <> " (exit " <> Text.pack (show n) <> ")") + where + path = Text.pack p.placePath + +------------------------------------------------------------------------------- +-- On-machine placement + +{- | Writes bytes to a placement on /this/ machine: a @0600@ temporary file +beside the destination, chowned, chmoded, then renamed over it. + +The enclosing directory must exist (declare it as a dependency): unlike the +upload, the caller here is a graph running on the machine and has the +vocabulary to say what that directory should be. + +Throws on an invalid placement, an empty secret, an unknown owner or group, +or a chown this process is not allowed to make. +-} +installSecretBytes :: Placement -> ByteString -> IO () +installSecretBytes place bytes = do + p <- either (throwIO . SecretDeliveryError) pure (validatePlacement place) + when (ByteString.null bytes) $ + throwIO (SecretDeliveryError ("refusing to write an empty secret: " <> Text.pack p.placePath)) + let tmp = p.placePath <> ".salmon-tmp" + -- a leftover from a killed pass keeps whatever mode it had; createFile + -- would truncate it without tightening it. + stale <- doesFileExist tmp + when stale (removeFile tmp) + ( do + h <- createFile tmp 0o600 >>= fdToHandle + ByteString.hPut h bytes `onException` hClose h + hClose h + user <- getUserEntryForName (Text.unpack p.placeOwner) + grp <- getGroupEntryForName (Text.unpack p.placeGroup) + setOwnerAndGroup tmp (userID user) (groupID grp) + setFileMode tmp (modeBits p) + renameFile tmp p.placePath + ) + `onException` (doesFileExist tmp >>= \left -> when left (removeFile tmp)) + +{- | Whether a placement on this machine holds exactly these bytes, with the +declared owner and mode. The failure text names the file and never quotes it. +-} +checkInstalledSecret :: Placement -> ByteString -> IO CheckResult +checkInstalledSecret place wanted = case validatePlacement place of + Left why -> pure (Failure why) + Right p -> do + let path = Text.pack p.placePath + present <- doesFileExist p.placePath + if not present + then pure (Failure ("missing: " <> path)) + else do + size <- getFileSize p.placePath + same <- + if size /= fromIntegral (ByteString.length wanted) + then pure False + else (== wanted) <$> ByteString.readFile p.placePath + st <- getFileStatus p.placePath + user <- getUserEntryForName (Text.unpack p.placeOwner) + grp <- getGroupEntryForName (Text.unpack p.placeGroup) + pure $ + if not same + then Failure (path <> " holds different contents") + else + if fileOwner st /= userID user || fileGroup st /= groupID grp || fileMode st .&. 0o7777 /= modeBits p + then Failure (path <> " has the wrong owner or mode") + else Success + +-- | Removes a placement on this machine; nothing to do when it is absent. +removeInstalledSecret :: Placement -> IO () +removeInstalledSecret place = do + present <- doesFileExist place.placePath + when present (removeFile place.placePath) + +-- | The mode of a validated placement. +modeBits :: Placement -> FileMode +modeBits p = case readOct (Text.unpack p.placeMode) of + [(n, "")] -> n + _ -> 0o600 diff --git a/src/Salmon/Builtin/Nodes/Self.hs b/src/Salmon/Builtin/Nodes/Self.hs --- a/src/Salmon/Builtin/Nodes/Self.hs +++ b/src/Salmon/Builtin/Nodes/Self.hs @@ -4,6 +4,8 @@ module Salmon.Builtin.Nodes.Self where import Data.Aeson (FromJSON, ToJSON, encode) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap import Data.ByteString.Lazy (toStrict) import qualified Data.ByteString.Lazy as LByteString import Data.Dynamic (toDyn) @@ -15,11 +17,13 @@ import qualified Salmon.Builtin.CommandLine as CLI import Salmon.Builtin.Extension +import qualified Salmon.Builtin.NodeLog as NodeLog +import qualified Salmon.Builtin.Nodes.Binary as Binary 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.OpGraph (OpGraph (..)) import Salmon.Op.Track (Track (..), Tracked (..), bindTracked, trackedGraph, using, (>*<)) import Salmon.Reporter @@ -47,13 +51,19 @@ data RemoteSelf = RemoteSelf {selfRemote :: Remote, selfRemotePath :: FilePath} +{- | Copies this binary to a remote host. + +The node the result tracks /is/ the copy (@rsync:sendfile@), not a wrapper +standing on it: what a caller injects onto it then precedes the copy itself. +See 'remoteCallNode' for why that matters. +-} 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) + Tracked (Track $ const copy) (RemoteSelf remote selfpathOnRemote) where selfpathOnRemote = remotedir takeFileName (getSelfPath path) rsyncRemote = Rsync.Remote remote.remoteUser remote.remoteHost @@ -76,6 +86,26 @@ instance (ToJSON a) => ToJSON (RemoteCall a) instance (FromJSON a) => FromJSON (RemoteCall a) +{- | Marks the ssh call that runs the self binary with the graph the directive +would expand to on the other side ('CLI.RemoteOp'), and hands back /that +node/ -- the one whose @up@ makes the call. + +It used to be wrapped: an effect-less @self-call@ node with the ssh call as +one of its predecessors. 'inject' adds a predecessor to the node it is given +and orders nothing among that node's predecessors, so everything a caller +injected onto the wrapper -- the upload ('bindTracked' in +'uploadAndCallSelf'), a recipe's secret uploads, an ssh probe -- became a +sibling of the call rather than something the call waits for. A one-shot pass +visits siblings in listed order, which hid it while everything succeeded; a +failed sibling did not block the call, and @run serve@ converges siblings +concurrently. See @Test.DeferredSpec@. +-} +remoteCallNode :: Track' directive -> directive -> Op -> Op +remoteCallNode simulate directive call = + amendNode mark call + where + mark ext = ext{dynamics = toDyn (CLI.RemoteOp (run simulate directive)) : ext.dynamics} + callSelf :: forall directive. (ToJSON directive, FromJSON directive) => @@ -86,21 +116,162 @@ CLI.BaseCommand -> directive -> Tracked' (RemoteCall directive) -callSelf r mkRemote self simulate base directive = - Tracked (Track $ \_ -> op "self-call" (deps [callOverSSH]) modActions) rc +callSelf = callSelfOpts defaultCallOpts + +{- | What is done, on this side, with what a remote salmon prints while it +runs. The choice is the caller's, per call, for the reason +"Salmon.Builtin.Nodes.Binary".'Binary.Routing' gives: only the author of the +directive knows whether the other side can print a secret. +-} +data RemoteOutput + = {- | Held until ssh exits and handed to the final report: what every + self-call did before there was a choice, and still the default. + -} + RemoteCaptured + | {- | Each line the remote salmon prints is a "Salmon.Builtin.NodeLog" + line about the calling node, as it is read. The remote command line is + the same as under 'RemoteCaptured', so the call is the same node. + -} + RemoteLines + | {- | The remote salmon is run with @--json@ and each report it writes + is re-told as a line about the calling node ('remoteReportLines'), + as it is read. The extra flag is part of the remote command line, so + the call is a /different/ node from the captured one (another 'Ref'). + Only @up@ and @down@ take @--json@; for any other + 'CLI.BaseCommand' this is 'RemoteLines'. + -} + RemoteReports + deriving (Eq, Ord, Show) + +-- | How a self-call is made: with which ssh options, under @sudo@ or not, +-- and what becomes of what the other side prints. +data CallOpts = CallOpts + { callClient :: Ssh.ClientOpts + , callAsSudo :: Bool + , callOutput :: RemoteOutput + } + deriving (Eq, Show) + +-- | Ambient ssh authentication, no @sudo@, output captured: 'callSelf'. +defaultCallOpts :: CallOpts +defaultCallOpts = CallOpts Ssh.noClientOpts False RemoteCaptured + +{- | Runs the self binary on the remote with a directive on its standard +input. 'callSelf', 'callSelfAsSudo' and 'callSelfAsSudoWith' are this +function at fixed 'CallOpts' and declare the node they always did. + +Nothing here reads the directive: it travels as bytes, and what the remote +salmon says about applying it is public in the sense every report is (see +'RemoteOutput' before following a remote that can print a secret). +-} +callSelfOpts :: + forall directive. + (ToJSON directive, FromJSON directive) => + CallOpts -> + Reporter Report -> + Track' Ssh.Remote -> + RemoteSelf -> + Track' directive -> + CLI.BaseCommand -> + directive -> + Tracked' (RemoteCall directive) +callSelfOpts o r mkRemote self simulate base directive = + Tracked (Track $ const $ remoteCallNode simulate directive callOverSSH) 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] + (cmdPath, cmdArgs) = remoteCommand o self base cmdStdin = toStrict $ encode directive - callOverSSH = Ssh.call r' Debian.ssh mkRemote sshRemote self.selfRemotePath cmdArgs cmdStdin + (routing, tap) = remoteRouting o.callOutput base + callOverSSH = Ssh.callTapped routing tap o.callClient r' Debian.ssh mkRemote sshRemote cmdPath cmdArgs cmdStdin r' = contramap RunSsh r +-- | The remote program and its arguments, as ssh is given them. +remoteCommand :: CallOpts -> RemoteSelf -> CLI.BaseCommand -> (FilePath, [Text]) +remoteCommand o self base + | o.callAsSudo = ("sudo", Text.pack self.selfRemotePath : runArgs) + | otherwise = (self.selfRemotePath, runArgs) + where + runArgs = ["run", CLI.argForBaseCommand base] <> ["--json" | reportsAsJson o.callOutput base] + +-- | Whether the remote salmon is asked for @--json@: only the two +-- subcommands that take the flag are. +reportsAsJson :: RemoteOutput -> CLI.BaseCommand -> Bool +reportsAsJson output base = output == RemoteReports && base `elem` [CLI.Up, CLI.Down] + +remoteRouting :: RemoteOutput -> CLI.BaseCommand -> (Binary.Routing, Binary.LineTap) +remoteRouting output base = case output of + RemoteCaptured -> (Binary.captured, Binary.plainLines) + RemoteLines -> (Binary.streamed, Binary.plainLines) + RemoteReports + | reportsAsJson output base -> (Binary.streamed, remoteReportLines) + | otherwise -> (Binary.streamed, Binary.plainLines) + +{- | Re-tells one line of a remote @run up --json@ as lines about the node +that made the call. + +How a remote report nests under the local node: /as text/. The calling node +is the only node the local side has for the other machine's work (the remote +graph is not in the local DAG), so a remote report becomes a +"Salmon.Builtin.NodeLog" line under the caller's 'Ref' that names the remote +node by its short ref and shorthand: + +> remote: done [a1b2c3d4] file:/etc/motd +> remote: failed [a1b2c3d4] file:/etc/motd: +> remote: +> remote: [a1b2c3d4] STEP 2/5: RUN make + +A report about a node is a 'NodeLog.Message'; a line a remote node said +(@kind: log@, or a held action's @output@) keeps the channel it was said on. +Wrappers (@acted@, @tended@) are looked through to the report they carry. +A standard-output line that is not a JSON object with a @kind@ (something a +recipe's own reporter printed) and every standard-error line are said as +they are. + +No new event and no new field: these are ordinary @log@ lines on the +@output@ stream, which every client already tails. What that gives up is +structure: a client cannot rebuild the remote graph from them. +-} +remoteReportLines :: Binary.LineTap +remoteReportLines NodeLog.Stdout line + | Just (Aeson.Object o) <- Aeson.decodeStrict (Text.encodeUtf8 line) + , Just said <- renderRemoteReport o = + said +remoteReportLines channel line = [(channel, line)] + +renderRemoteReport :: Aeson.Object -> Maybe [(NodeLog.Channel, Text)] +renderRemoteReport outer = do + kind <- textAt "kind" o + pure $ case textAt "line" o of + Just said + | kind `elem` ["log", "output"] -> + [(saidOn, Text.unwords (["remote:"] <> subject <> [said]))] + _ -> + let headline = Text.unwords (["remote:", kind] <> subject) + in case maybe [] Text.lines (textAt "error" o) of + [] -> [(NodeLog.Message, headline)] + (e : es) -> + (NodeLog.Message, headline <> ": " <> e) + : [(NodeLog.Message, "remote: " <> l) | l <- es] + where + o = innermost outer + innermost x = case KeyMap.lookup "report" x of + Just (Aeson.Object inner) | KeyMap.member "kind" inner -> innermost inner + _ -> x + textAt k x = case KeyMap.lookup k x of + Just (Aeson.String t) -> Just t + _ -> Nothing + objectAt k x = case KeyMap.lookup k x of + Just (Aeson.Object y) -> Just y + _ -> Nothing + subject = + maybe [] (\short -> ["[" <> short <> "]"]) (objectAt "ref" o >>= textAt "short") + <> maybe [] pure (objectAt "node" o >>= textAt "shorthand") + saidOn = case textAt "channel" o of + Just "stderr" -> NodeLog.Stderr + Just "message" -> NodeLog.Message + _ -> NodeLog.Stdout + callSelfAsSudo :: forall directive. (ToJSON directive, FromJSON directive) => @@ -125,24 +296,14 @@ 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 +callSelfAsSudoWith opts = callSelfOpts defaultCallOpts{callClient = opts, callAsSudo = True} -- | 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. +-- +-- The node tracked is the call, standing on the upload; whatever a recipe +-- injects onto it (files the directive reads) precedes the call too. uploadAndCallSelf :: forall directive. (ToJSON directive, FromJSON directive) => @@ -156,10 +317,30 @@ 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 +uploadAndCallSelf = uploadAndCallSelfOpts defaultCallOpts +{- | The upload, then the call, both under one 'CallOpts': the upload takes +its ssh options, the call all of it. This is the form to reach for to follow +a remote salmon while it works (@defaultCallOpts{callOutput = RemoteReports}@). +-} +uploadAndCallSelfOpts :: + forall directive. + (ToJSON directive, FromJSON directive) => + CallOpts -> + Reporter Report -> + Reporter Report -> + FilePath -> + Remote -> + SelfPath -> + Track' Ssh.Remote -> + Track' directive -> + CLI.BaseCommand -> + directive -> + Tracked' (RemoteCall directive) +uploadAndCallSelfOpts o rUpload rCall remotedir uploadRemote selfpath mkRemote simulate base directive = + uploadSelfWith o.callClient rUpload remotedir uploadRemote selfpath `bindTracked` \self -> + callSelfOpts o rCall mkRemote self simulate base directive + -- | Same as 'uploadAndCallSelf', but invokes the remote binary via sudo. uploadAndCallSelfAsSudo :: forall directive. @@ -194,9 +375,7 @@ 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 +uploadAndCallSelfAsSudoWith opts = uploadAndCallSelfOpts defaultCallOpts{callClient = opts, callAsSudo = True} remoteDir :: forall directive. diff --git a/src/Salmon/Builtin/Nodes/Ssh.hs b/src/Salmon/Builtin/Nodes/Ssh.hs --- a/src/Salmon/Builtin/Nodes/Ssh.hs +++ b/src/Salmon/Builtin/Nodes/Ssh.hs @@ -1,7 +1,7 @@ module Salmon.Builtin.Nodes.Ssh where import Salmon.Builtin.Extension -import Salmon.Builtin.Nodes.Binary (Binary, Command (..), withBinaryStdin) +import Salmon.Builtin.Nodes.Binary (Binary, Command (..)) import qualified Salmon.Builtin.Nodes.Binary as Binary import Salmon.Builtin.Nodes.Filesystem import Salmon.Op.Ref @@ -89,8 +89,53 @@ [Text] -> ByteString -> Op -callWith opts r ssh tRemote remote remotepath args stdin = - withBinaryStdin ssh sshRun cmd stdin $ \up -> +callWith = callTapped Binary.captured Binary.plainLines + +{- | 'callWith', with a say in where the remote command's output goes +("Salmon.Builtin.Nodes.Binary".'Binary.Routing'). + +Under 'Binary.streamed' each line the remote command writes is a +"Salmon.Builtin.NodeLog" line about this node, said while the command is +still running on the other machine, where 'call' and 'callWith' hold all of +it until ssh exits. Only the caller knows whether that is safe: a streamed +line is public the moment it is read, so a remote command that can print a +secret keeps 'Binary.captured', which is what every call was before there +was a choice. + +The node is the same node whatever the routing: same 'Ref', @help@ and +@notes@, so asking for the output to be followed restarts nothing. +-} +callRouted :: + Binary.Routing -> + ClientOpts -> + Reporter Report -> + Track' (Binary "ssh") -> + Track' Remote -> + Remote -> + FilePath -> + [Text] -> + ByteString -> + Op +callRouted routing = callTapped routing Binary.plainLines + +{- | 'callRouted', with a 'Binary.LineTap' deciding what is said for each +streamed line: for a remote command whose output is a report stream to +re-tell rather than text to repeat. +-} +callTapped :: + Binary.Routing -> + Binary.LineTap -> + ClientOpts -> + Reporter Report -> + Track' (Binary "ssh") -> + Track' Remote -> + Remote -> + FilePath -> + [Text] -> + ByteString -> + Op +callTapped routing tap opts r ssh tRemote remote remotepath args stdin = + Binary.withBinaryStdinTapped routing tap 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 diff --git a/src/Salmon/Builtin/Nodes/Systemd.hs b/src/Salmon/Builtin/Nodes/Systemd.hs --- a/src/Salmon/Builtin/Nodes/Systemd.hs +++ b/src/Salmon/Builtin/Nodes/Systemd.hs @@ -1,6 +1,10 @@ module Salmon.Builtin.Nodes.Systemd where +import Control.Exception (Exception, IOException, finally, throwIO, try) +import Control.Monad (unless) import qualified Crypto.Hash.SHA256 as SHA256 +import Crypto.Random (getRandomBytes) +import Data.Bits ((.&.)) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as C8 @@ -8,9 +12,14 @@ 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.Directory (createDirectoryIfMissing, doesFileExist, removeFile) import System.Exit (ExitCode (..)) -import System.FilePath (()) +import System.FilePath (takeDirectory, ()) +import System.IO (hClose) +import System.IO.Error (isAlreadyExistsError) +import System.Posix.Files (createLink, fileMode, fileSize, getFileStatus, setFileMode) +import System.Posix.IO (createFile, fdToHandle) +import System.Posix.Types (FileMode) import System.Process.ByteString (readCreateProcessWithExitCode) import Salmon.Actions.UpDown (CheckResult (..)) @@ -18,6 +27,7 @@ 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 (OpGraph (..)) import Salmon.Op.Ref import Salmon.Op.Track import Salmon.Reporter @@ -72,12 +82,64 @@ Track' Config -> Config -> Op -systemdServiceWatching watched r systemctl t cfg = +systemdServiceWatching = systemdServiceWatchingWith PlainDigest + +{- | 'systemdServiceWatching', with the watched files' digest keyed: the +trailing comment is @# salmon-watches: hmac-sha256:BASE64@, an HMAC-SHA256 +under a key only the owner of the unit directory can read +('unitWatchKeyNode', @\\/.salmon-watch.key@), instead of a +plain SHA-256 of the files. + +Why it exists: a unit file is world-readable (so is @systemctl cat@), and the +files a service watches are often the ones holding its secrets (a pgbouncer +userlist, a patroni secrets file). A plain hash of them there lets any local +user check guesses at a low-entropy secret offline. The keyed line detects +the same changes and says nothing without the key. It is the mechanism +"Salmon.Builtin.Nodes.Podman.Quadlet" uses for its env files, with the same +key format and rules: made once, @0600@, never replaced, never removed by +@down@ (a new key is a new line, so a restart, for every watching unit in +the directory). + +It is a separate entry point rather than a change to +'systemdServiceWatching' because moving an existing declaration from the +plain line to the keyed one rewrites its unit file, and so __restarts the +service once__. A caller opts in knowing that. With nothing watched it is +'systemdService' exactly, and no key is read or made. +-} +systemdServiceWatchingKeyed :: + [FilePath] -> + Reporter Report -> + Track' (Binary "systemctl") -> + Track' Config -> + Config -> + Op +systemdServiceWatchingKeyed = systemdServiceWatchingWith KeyedDigest + +{- | How the watched files' contents show in an authored unit file. +'PlainDigest' is what 'systemdServiceWatching' has always written, +'KeyedDigest' is 'systemdServiceWatchingKeyed''s. +-} +data WatchDigest + = -- | @# salmon-watches: BASE64@, a SHA-256 of 'watchedFrames' + PlainDigest + | -- | @# salmon-watches: hmac-sha256:BASE64@, under the unit directory's key + KeyedDigest + deriving (Eq, Show) + +systemdServiceWatchingWith :: + WatchDigest -> + [FilePath] -> + Reporter Report -> + Track' (Binary "systemctl") -> + Track' Config -> + Config -> + Op +systemdServiceWatchingWith digest 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 -> + op "systemd-service" (deps [unitFileNodeWith digest watched cfg, run t cfg]) $ \actions -> actions { help = "installs a systemd-unit and up it" , ref = mkRef "systemd-unit" cfg.config_target @@ -93,13 +155,61 @@ g callbin = f (callbin (r' cmd)) in withBinary systemctl callSystemctl cmd g + +{- | The unit file of a 'systemdServiceWatching': 'filecontents' at +@config_unit_dir/config_target@, standing on a 'unitDirectory' rather than on +'Salmon.Builtin.Nodes.Filesystem.dir'. The file node itself is what +'filecontents' renders (same 'ref', @help@ and @notes@); only its +predecessor differs. + +The directory is shared by every unit on the machine and +'Salmon.Builtin.Nodes.Filesystem.dir''s @down@ refuses a non-empty directory +on purpose, so with that node under it a @run down@ of one service among +several removed the unit file and then reported the directory @Failed@, +which also blocks the teardown of anything declared under the directory. +-} +unitFileNode :: [FilePath] -> Config -> Op +unitFileNode = unitFileNodeWith PlainDigest + +{- | 'unitFileNode' with the digest chosen. A 'KeyedDigest' file that watches +something also stands on the directory's key ('unitWatchKeyNode'); with +nothing watched the two digests give the same node. +-} +unitFileNodeWith :: WatchDigest -> [FilePath] -> Config -> Op +unitFileNodeWith digest watched cfg = + file{predecessors = deps (unitDirectory unitDir : keyNode)} + where + file :: Op + file + | null watched = filecontents $ FileContents unitPath (render_config cfg) + | otherwise = case digest of + PlainDigest -> filecontents $ FileContents unitPath (withWatchedFingerprint watched (render_config cfg)) + KeyedDigest -> filecontents $ FileContents unitPath (withKeyedWatchFingerprint (watchKeyFile unitDir) watched (render_config cfg)) + keyNode :: [Op] + keyNode + | KeyedDigest <- digest, not (null watched) = [unitWatchKeyNode unitDir] + | otherwise = [] + unitDir :: FilePath + unitDir = takeDirectory unitPath 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 directory unit files go in, shared by every unit on the machine: +created if missing, left alone by @down@. +'Salmon.Builtin.Nodes.Filesystem.dir' would refuse to go down while anything +else is in it, which for this directory is always. One node per directory +(@"systemd-unit-dir"@, keyed on the path), shared by authored services +('unitFileNode') and jobs ("Salmon.Builtin.Nodes.Systemd.Job"). +-} +unitDirectory :: FilePath -> Op +unitDirectory path = + op "systemd-unit-dir" nodeps $ \actions -> + actions + { help = "ensures " <> Text.pack path <> " exists" + , notes = ["shared by every unit in it: down leaves it"] + , ref = mkRef "systemd-unit-dir" path + , up = createDirectoryIfMissing True path + } {- | 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 @@ -107,9 +217,17 @@ -} withWatchedFingerprint :: [FilePath] -> Text -> IO Text withWatchedFingerprint paths unitText = do - parts <- concat <$> traverse framed paths + parts <- watchedFrames paths let digest = SHA256.finalize (SHA256.updates SHA256.init parts) pure (unitText <> "# salmon-watches: " <> Text.decodeUtf8 (Base64.encode digest) <> "\n") + +{- | What 'withWatchedFingerprint' hashes: each file as its path, its length +and its bytes, in the order given, a missing file being an empty one. Exposed +for a caller that digests the same thing another way +("Salmon.Builtin.Nodes.Podman.Quadlet" keys it). +-} +watchedFrames :: [FilePath] -> IO [ByteString.ByteString] +watchedFrames paths = concat <$> traverse framed paths where framed :: FilePath -> IO [ByteString.ByteString] framed path = do @@ -117,6 +235,118 @@ bytes <- if exists then ByteString.readFile path else pure ByteString.empty pure [C8.pack (path <> ":" <> show (ByteString.length bytes) <> ":"), bytes] +{- | The unit text with the keyed line ('keyedWatchLine') under the key at +the given path. Throws 'WatchKeyUnusable' when the key cannot be read: there +is no fallback to a plain hash, which is the thing the key is there to avoid. +-} +withKeyedWatchFingerprint :: FilePath -> [FilePath] -> Text -> IO Text +withKeyedWatchFingerprint keyPath paths unitText = do + key <- readWatchKeyAt keyPath + frames <- watchedFrames paths + pure (unitText <> keyedWatchLine key frames) + +{- | The trailing comment: @# salmon-watches: hmac-sha256:BASE64@, the +HMAC-SHA256 under the key of what 'watchedFrames' read. Pure, and the whole +of what the watched files leave in the file. +-} +keyedWatchLine :: ByteString.ByteString -> [ByteString.ByteString] -> Text +keyedWatchLine key frames = + "# salmon-watches: hmac-sha256:" <> Text.decodeUtf8 (Base64.encode (SHA256.hmac key (ByteString.concat frames))) <> "\n" + +{- | Where a directory's watch key is: beside the units, so it has the +directory's owner and lifetime. systemd and the quadlet generator load only +names with a unit suffix they know, and leave this one alone. +-} +watchKeyFile :: FilePath -> FilePath +watchKeyFile dir = dir ".salmon-watch.key" + +-- | The key is missing, unreadable or empty: its path, and which. +data WatchKeyUnusable = WatchKeyUnusable !FilePath !Text + deriving (Show) + +instance Exception WatchKeyUnusable + +-- | The key at a path, stripped; 'WatchKeyUnusable' when there is none. +readWatchKeyAt :: FilePath -> IO ByteString.ByteString +readWatchKeyAt path = do + read_ <- try (ByteString.readFile path) :: IO (Either IOException ByteString.ByteString) + case read_ of + Left _ -> throwIO (WatchKeyUnusable path "the key of the watched files' digest cannot be read") + Right bytes + | ByteString.null (C8.strip bytes) -> throwIO (WatchKeyUnusable path "the key of the watched files' digest is empty") + | otherwise -> pure (C8.strip bytes) + +{- | Makes the key at a path if there is none, and makes it owner-only +whatever it was. + +A key that exists is never replaced: a new key is a new digest, and so a +restart, for everything watching under it. It is written to a temporary file +created @0600@ and put in place with @link(2)@, which refuses an existing +name, so of two processes making it at once one wins and both read the +winner's. +-} +ensureWatchKeyAt :: FilePath -> IO () +ensureWatchKeyAt path = do + present <- doesFileExist path + unless present $ do + secret <- getRandomBytes 32 :: IO ByteString.ByteString + suffix <- getRandomBytes 6 :: IO ByteString.ByteString + let tmp = path <> ".tmp-" <> concatMap hex (ByteString.unpack suffix) + ( do + h <- fdToHandle =<< createFile tmp 0o600 + ByteString.hPut h (Base64.encode secret <> "\n") `finally` hClose h + placed <- try (createLink tmp path) + case placed of + Right () -> pure () + Left e + | isAlreadyExistsError e -> pure () + | otherwise -> throwIO e + ) + `finally` removeFile tmp + setFileMode path 0o600 + where + hex w = [digits !! fromIntegral (w `div` 16), digits !! fromIntegral (w `mod` 16)] + digits = "0123456789abcdef" :: String + +{- | The verdict on a key file's mode and size, 'Nothing' for no file. A key +others can read is a 'Failure' ('ensureWatchKeyAt' then closes it; it does +not make a new one, see there). +-} +interpretWatchKey :: FilePath -> Maybe (FileMode, Integer) -> CheckResult +interpretWatchKey path Nothing = Failure ("no key at " <> Text.pack path) +interpretWatchKey path (Just (mode, size)) + | size <= 0 = Failure ("the key at " <> Text.pack path <> " is empty") + | mode .&. 0o077 /= 0 = Failure ("the key at " <> Text.pack path <> " is readable by others than its owner") + | otherwise = Success + +-- | 'interpretWatchKey' of what is at the path now. +checkWatchKeyAt :: FilePath -> IO CheckResult +checkWatchKeyAt path = do + present <- doesFileExist path + if present + then do + st <- getFileStatus path + pure (interpretWatchKey path (Just (fileMode st, fromIntegral (fileSize st)))) + else pure (interpretWatchKey path Nothing) + +{- | The watch key of a unit directory (@"systemd-unit-watch-key"@, keyed on +the key's path): one node for every 'systemdServiceWatchingKeyed' unit there +that watches a file. It stands on the directory and, like it, is never +removed. +-} +unitWatchKeyNode :: FilePath -> Op +unitWatchKeyNode dir = + op "systemd-unit-watch-key" (deps [unitDirectory dir]) $ \actions -> + actions + { help = "ensures " <> Text.pack path <> " exists, readable by its owner alone" + , notes = ["keys the digest of the files the units watch, shared by every unit there: down leaves it"] + , ref = mkRef "systemd-unit-watch-key" path + , check = checkWatchKeyAt path + , up = ensureWatchKeyAt path + } + where + path = watchKeyFile dir + {- | 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 @@ -163,14 +393,22 @@ makes it happen again. -} checkService :: Config -> IO CheckResult -checkService cfg = do +checkService cfg = checkUnit interpretShow cfg.config_scope cfg.config_target + +{- | 'checkService' for any unit, with the caller's own reading of what +@systemctl show@ printed: the one @systemctl show@ and its "we could not ask" +answer, shared with nodes whose unit is not one 'Config' describes (a quadlet's +generated service, see "Salmon.Builtin.Nodes.Podman.Quadlet"). +-} +checkUnit :: ([Text] -> CheckResult) -> Scope -> UnitTarget -> IO CheckResult +checkUnit interpret scope target = do (code, out, _err) <- readCreateProcessWithExitCode ( proc "systemctl" - ( scopeArgs cfg.config_scope + ( scopeArgs scope <> [ "show" - , Text.unpack cfg.config_target + , Text.unpack target , "--property=ActiveState" , "--property=UnitFileState" , "--property=NeedDaemonReload" @@ -179,7 +417,7 @@ ) "" pure $ case code of - ExitSuccess -> interpretShow (Text.lines (Text.decodeUtf8With TextError.lenientDecode out)) + ExitSuccess -> interpret (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 @@ -196,13 +434,24 @@ @ActiveState=inactive@ rather than by way of a special case. -} interpretShow :: [Text] -> CheckResult -interpretShow ls +interpretShow = interpretShowAccepting installedStates + +-- | The @UnitFileState@s of a unit this module installed and enabled. +installedStates :: [Text] +installedStates = ["enabled", "enabled-runtime", "static", "indirect"] + +{- | 'interpretShow' with the acceptable @UnitFileState@s as an argument: a +unit written by a generator is @generated@, can never be @enabled@, and is +exactly as installed as it will ever be. +-} +interpretShowAccepting :: [Text] -> [Text] -> CheckResult +interpretShowAccepting accepted 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 + | st `elem` accepted -> 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 @@ -263,6 +512,20 @@ | Enable Scope UnitTarget | Up Scope UnitTarget | Stop Scope UnitTarget + | -- | @start@: for a @Type=oneshot@ unit, returns when the command has + -- exited and fails if it did; a unit already running is joined, where + -- 'Up' (@restart@) would kill it first + StartUnit Scope UnitTarget + | -- | @start --no-block@: the start is queued and the call returns + -- without waiting for the unit, so it says nothing about how a + -- @Type=oneshot@ unit's command went. A unit already starting or + -- queued is left as it is. + StartUnitNoBlock Scope UnitTarget + | -- | @disable --now@: stops the unit and removes what 'Enable' linked + Disable Scope UnitTarget + | -- | @mask --now@: stops the unit and points it at @\/dev\/null@ + Mask Scope UnitTarget + | Unmask Scope UnitTarget deriving (Show) callSystemctl :: Command "systemctl" SystemCtlCall @@ -272,7 +535,62 @@ 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]) + go (StartUnit sc u) = proc "systemctl" (scopeArgs sc <> ["start", Text.unpack u]) + go (StartUnitNoBlock sc u) = proc "systemctl" (scopeArgs sc <> ["start", "--no-block", Text.unpack u]) + go (Disable sc u) = proc "systemctl" (scopeArgs sc <> ["disable", "--now", Text.unpack u]) + go (Mask sc u) = proc "systemctl" (scopeArgs sc <> ["mask", "--now", Text.unpack u]) + go (Unmask sc u) = proc "systemctl" (scopeArgs sc <> ["unmask", Text.unpack u]) +{- | A unit that must never run, masked rather than merely disabled: a +disabled unit can still be started by anything that @Wants=@ it (Debian's +@postgresql.service@ pulls in every @postgresql\@V-C@), a masked one cannot. + +@up@ is @systemctl mask --now@, so a unit that is running when the mask lands +is stopped; one that is not (a Postgres cluster started by Patroni is not +owned by any unit) is untouched. @down@ unmasks and does not start anything. +The @check@ reads @systemctl is-enabled@ ('interpretIsEnabled'). +-} +maskedUnit :: Reporter Report -> Track' (Binary "systemctl") -> Scope -> UnitTarget -> Op +maskedUnit r systemctl scope target = + withCommand (Mask scope target) $ \mask -> + withCommand (Unmask scope target) $ \unmask -> + op "systemd-masked-unit" nodeps $ \actions -> + actions + { help = "masks " <> target <> " so that nothing can start it" + , ref = mkRef "systemd-masked" target + , check = checkMasked scope target + , up = mask + , down = unmask + } + 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 + +checkMasked :: Scope -> UnitTarget -> IO CheckResult +checkMasked scope target = do + -- @is-enabled@ exits non-zero for most states, so the exit code carries + -- nothing; only the word it prints does. + (_code, out, _err) <- + readCreateProcessWithExitCode + (proc "systemctl" (scopeArgs scope <> ["is-enabled", Text.unpack target])) + "" + pure (interpretIsEnabled (Text.decodeUtf8With TextError.lenientDecode out)) + +{- | The verdict on @systemctl is-enabled@'s output, pure. Only @masked@ is +satisfied: @masked-runtime@ (a mask under @\/run@) does not survive a reboot, +and a unit that is merely @disabled@ is the case this node exists to refuse. +-} +interpretIsEnabled :: Text -> CheckResult +interpretIsEnabled out = case Text.strip (Text.takeWhile (/= '\n') (Text.strip out)) of + "masked" -> Success + "" -> Unknown + other -> Failure ("not masked: " <> Text.take 60 other) + ------------------------------------------------------------------------------- data Config @@ -382,17 +700,76 @@ 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" + +{- | One word of a command line as systemd splits it: quoted when it holds +whitespace or a character the splitter reads, left alone otherwise. It does +not touch @$@ or @%@, which systemd expands inside quotes too; see +'literalArg' for a word that must arrive as written. +-} +quoteArg :: Text -> Text +quoteArg a + | Text.any (`elem` (" \t\"'$`\\" :: String)) a = + "\"" <> Text.replace "\"" "\\\"" (Text.replace "\\" "\\\\" a) <> "\"" + | otherwise = a + +{- | 'quoteArg' for a word the process must receive exactly as declared: +@$@ is written @$$@ and @%@ is written @%%@, the two characters systemd +substitutes in a command line (environment variables and unit specifiers) +whatever the quoting. Without it a @sh -c@ script naming @$HOME@ is handed +to the shell with systemd's idea of @HOME@ already spliced in, or nothing +at all for a variable only the script sets. An empty word is kept as one. +-} +literalArg :: Text -> Text +literalArg a + -- an empty word is a word, and a bare @;@ would end the command + | Text.null a = "\"\"" + | a == ";" = "\";\"" + | otherwise = quoteArg (Text.replace "%" "%%" (Text.replace "$" "$$" a)) + +{- | Is this unit known to systemd as its file is now written, whether or not +it is running? The question for a unit nothing starts at install time: a +@Type=oneshot@ job a timer triggers. + +@LoadState=loaded@ and @NeedDaemonReload=no@. A unit file systemd has not +been told about reads @loaded@ already when it sits in a directory systemd +searches (@show@ loads it on demand), and @not-found@ when it is made by a +generator that has not run since; @bad-setting@ and @error@ are a file +systemd refuses, which a reload does not cure. +-} +checkLoaded :: Scope -> UnitTarget -> IO CheckResult +checkLoaded scope target = do + (code, out, _err) <- + readCreateProcessWithExitCode + ( proc + "systemctl" + (scopeArgs scope <> ["show", Text.unpack target, "--property=LoadState", "--property=NeedDaemonReload"]) + ) + "" + pure $ case code of + ExitSuccess -> interpretLoaded (Text.lines (Text.decodeUtf8With TextError.lenientDecode out)) + ExitFailure _ -> Unknown + +-- | The verdict 'checkLoaded' draws from @systemctl show@'s output, pure. +interpretLoaded :: [Text] -> CheckResult +interpretLoaded ls + | property "NeedDaemonReload" == Just "yes" = + Failure "the unit file on disk has changed since systemd loaded it" + | otherwise = case property "LoadState" of + Just "loaded" -> Success + Just "not-found" -> Failure "systemd does not know the unit" + Just other -> Failure ("the unit is " <> other) + Nothing -> Failure "systemctl said nothing about the unit's load 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 data Install = Install diff --git a/src/Salmon/Builtin/Nodes/Systemd/Job.hs b/src/Salmon/Builtin/Nodes/Systemd/Job.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Builtin/Nodes/Systemd/Job.hs @@ -0,0 +1,1185 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Jobs under systemd: a command that runs to completion, and what runs it. + +'Salmon.Builtin.Nodes.Systemd.systemdService' declares a /service/: a unit +that is enabled, started and expected to stay @active@. A job is the other +kind of unit and none of that fits it. A @Type=oneshot@ service is +@inactive@ whenever it is not running, which is nearly always, so a check +that wants @ActiveState=active@ calls a healthy job broken and an @up@ that +restarts the unit runs the job at every pass. + +So there are three nodes here, and they are separate on purpose: + +* 'jobService' /installs/ a job: the unit file is written and systemd knows + it as written. Nothing starts it. Its check is + 'Salmon.Builtin.Nodes.Systemd.checkLoaded'. +* 'timerUnit' /schedules/ a unit: a @.timer@ that is enabled and waiting. A + timer is long-lived, so its check is the service one + ('Salmon.Builtin.Nodes.Systemd.interpretShow': active, enabled, loaded as + written). 'scheduledJob' is the two together. +* 'runJob' /runs/ a job now and waits for it, failing if the job fails. + +The container equivalent of 'jobService' is +'Salmon.Builtin.Nodes.Podman.Quadlet.quadletJob', whose generated service a +'timerUnit' or a 'runJob' names like any other. + +Changing a schedule is a changed timer file. systemd re-arms a waiting timer +with the new schedule at @daemon-reload@ (seen on systemd 255: the next +elapse moves without a restart), so it does not matter which node's reload +got there first. + +How the last run /went/ is a fourth node's question, not 'jobService''s +(re-installing a job does not un-fail it, and a check that said otherwise +would have a supervisor reload systemd forever). 'completedRun' is 'runJob' +with a check: it reads the unit's last run from systemd ('interpretLastRun') +and answers 'Completed' when that run succeeded and started after everything +the job stands on was last written, a 'Failure' when it failed, never +happened or predates a write. Its @up@ is 'runJob''s, so a job that fails +fails the pass. 'completedJob' and 'completedScheduledJob' are that node +standing on the job. + +What systemd remembers is the limit of it, and it is less than one would +think (all seen on systemd 255). A /failed/ run is remembered until the unit +is started again, @reset-failed@ or the machine reboots. A /successful/ run +is remembered only while something keeps the unit loaded: a waiting timer +that triggers it does, and with nothing referring to it the unit is +collected the moment the run ends and reads exactly like one never run. And +nothing survives a reboot. 'jobStamp' is for the cases that leaves (a job +with no timer; a verdict that must hold across a reboot): the unit then +records its own runs in two files the check reads beside systemd's answer. + +'runJob' and 'completedRun' /wait/: for a job of half an hour that is one +call held for half an hour, and over ssh a dropped link fails the pass +although the unit goes on and ends well. 'launchedRun' is the same +declaration ("this job has run to completion") for such a job: its @up@ +queues the start and returns, and the answer comes from asking again. A pass +that finds the job running starts nothing and says so ('RunInProgress'); +see 'launchedRun' for what that looks like to a driver. +-} +module Salmon.Builtin.Nodes.Systemd.Job ( + -- * a job + Job (..), + job, + systemUnitDir, + jobServiceTarget, + jobServicePath, + renderJobService, + jobProblems, + jobService, + + -- * a schedule + Schedule (..), + Timer (..), + timer, + jobTimer, + timerTarget, + timerPath, + renderTimer, + timerProblems, + timerUnit, + scheduledJob, + + -- * running one now + runJob, + + -- * a run that succeeded, and since when + Completion (..), + jobCompletion, + stampRunning, + RunEvidence (..), + noEvidence, + interpretLastRun, + parseTimestamp, + lastRunProperties, + checkLastRun, + completedRun, + completedJob, + completedScheduledJob, + + -- * a run started and asked about later + RunState (..), + classifyRun, + runVerdict, + runStateProperties, + readRunState, + Launch (..), + launchDecision, + Outcome (..), + runOutcome, + Polling (..), + noWait, + pollDelays, + launchProblems, + launchNotes, + CannotLaunch (..), + RunInProgress (..), + RunFailed (..), + RunUndetermined (..), + launchedRun, + launchedJob, + + -- * shared with other unit-writing nodes + unitDirectory, + unitFile, + reloadAndRequireLoaded, + stopIfKnown, + unitNameProblems, + InvalidUnit (..), + UnitNotLoaded (..), +) where + +import Control.Concurrent (threadDelay) +import Control.Exception (Exception, throwIO) +import Control.Monad (forM, forM_, unless, when) +import Data.Char (isAlphaNum, isAscii) +import Data.Maybe (catMaybes, fromMaybe, maybeToList) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Time (UTCTime, defaultTimeLocale, parseTimeM) +import System.Directory (createDirectoryIfMissing, doesFileExist, getModificationTime, removeFile) +import System.Exit (ExitCode (..)) +import System.FilePath (isAbsolute, takeDirectory, ()) +import System.Process (proc, readCreateProcessWithExitCode) + +import Salmon.Actions.UpDown (CheckResult (..)) +import Salmon.Builtin.Extension +import Salmon.Builtin.Nodes.Binary (Binary, withBinary) +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.OpGraph (OpGraph (..), inject) +import Salmon.Op.Ref +import Salmon.Op.Track +import Salmon.Reporter + +------------------------------------------------------------------------------- + +{- | A command run to completion as @NAME.service@. 'job' is the starting +point; set the rest with record update. +-} +data Job + = Job + { jobScope :: Systemd.Scope + , jobUnitDir :: FilePath + -- ^ 'systemUnitDir' for 'Systemd.System'; a caller-resolved + -- @~\/.config\/systemd\/user@ for 'Systemd.User' + , jobName :: Text + -- ^ names the unit, @NAME.service@ + , jobDescription :: Text + , jobAfter :: [Systemd.UnitTarget] + , jobCommand :: [Text] + -- ^ the argv, program first as an absolute path. Each word reaches the + -- program as written ('Systemd.literalArg'): systemd expands no @$VAR@ + -- and no @%@ specifier in it. + , jobUser :: Maybe Text + -- ^ who runs it; 'Nothing' is the manager's own user (root in + -- 'Systemd.System'). Not rendered in 'Systemd.User' scope, where + -- systemd refuses it. + , jobGroup :: Maybe Text + , jobWorkingDir :: Maybe FilePath + , jobEnvironment :: [(Text, Text)] + , jobEnvFile :: Maybe FilePath + -- ^ an @EnvironmentFile=@ somebody else provisions, read at each run + , jobTimeout :: Maybe Int + -- ^ @TimeoutStartSec=@ in seconds: how long one run may take. systemd's + -- default for a oneshot unit is no limit at all. + , jobStamp :: Maybe FilePath + -- ^ a file the unit keeps as the record of its last successful run, for + -- 'completedRun' to read where systemd's own memory does not reach (see + -- the module's header). Each run touches @STAMP.running@ before the + -- command and renames it to @STAMP@ after the command succeeded, so + -- @STAMP@'s time is when the last successful run /started/, and a + -- @STAMP.running@ newer than it is a run that did not succeed. The + -- directory is the caller's: it has to exist and be writable by whoever + -- runs the job. @touch@ and @mv@ are found by systemd on its own search + -- path. + } + deriving (Eq, Show) + +-- | Where an administrator's system units live. +systemUnitDir :: FilePath +systemUnitDir = "/etc/systemd/system" + +-- | A system-scope job run as root with no limit on how long it takes. +job :: Text -> [Text] -> Job +job name command = + Job + { jobScope = Systemd.System + , jobUnitDir = systemUnitDir + , jobName = name + , jobDescription = "job " <> name <> " (salmon)" + , jobAfter = [] + , jobCommand = command + , jobUser = Nothing + , jobGroup = Nothing + , jobWorkingDir = Nothing + , jobEnvironment = [] + , jobEnvFile = Nothing + , jobTimeout = Nothing + , jobStamp = Nothing + } + +jobServiceTarget :: Job -> Systemd.UnitTarget +jobServiceTarget j = j.jobName <> ".service" + +jobServicePath :: Job -> FilePath +jobServicePath j = j.jobUnitDir Text.unpack (jobServiceTarget j) + +{- | The unit file. There is no @[Install]@ section: nothing starts a job at +boot, a timer or an operator does. +-} +renderJobService :: Job -> Text +renderJobService j = + Text.unlines $ + mconcat + [ ["[Unit]", "Description=" <> j.jobDescription] + , ["After=" <> Text.unwords j.jobAfter | not (null j.jobAfter)] + , ["", "[Service]", "Type=oneshot"] + , case j.jobScope of + Systemd.System -> + ["User=" <> u | u <- maybeToList j.jobUser] <> ["Group=" <> g | g <- maybeToList j.jobGroup] + Systemd.User -> [] + , ["WorkingDirectory=" <> Text.pack d | d <- maybeToList j.jobWorkingDir] + , ["Environment=" <> assignment k v | (k, v) <- j.jobEnvironment] + , ["EnvironmentFile=" <> Text.pack f | f <- maybeToList j.jobEnvFile] + , ["TimeoutStartSec=" <> Text.pack (show t) | t <- maybeToList j.jobTimeout] + , ["ExecStartPre=" <> command ["touch", Text.pack (stampRunning s)] | s <- maybeToList j.jobStamp] + , ["ExecStart=" <> command j.jobCommand] + , -- only reached when every ExecStart= exited 0 + ["ExecStartPost=" <> command ["mv", "-f", Text.pack (stampRunning s), Text.pack s] | s <- maybeToList j.jobStamp] + ] + where + command :: [Text] -> Text + command = Text.unwords . map Systemd.literalArg + + -- specifiers are expanded in @Environment=@, variables are not + assignment :: Text -> Text -> Text + assignment k v = Systemd.quoteArg (k <> "=" <> Text.replace "%" "%%" v) + +{- | Why this job cannot be written, if it cannot. Every value lands on a +line of a file systemd parses, so a line break inside one is another key. +-} +jobProblems :: Job -> [Text] +jobProblems j = + mconcat + [ unitNameProblems "job" j.jobName + , case j.jobCommand of + [] -> ["the job has no command"] + (program : _) + | not ("/" `Text.isPrefixOf` program) -> + ["the job's program is not an absolute path: " <> program] + | otherwise -> [] + , ["an environment variable with no name" | (k, _) <- j.jobEnvironment, Text.null k] + , ["not an environment variable name: " <> k | (k, _) <- j.jobEnvironment, Text.any (`elem` ("= \t" :: String)) k] + , ["the timeout is not positive" | Just t <- [j.jobTimeout], t <= 0] + , ["the stamp is not an absolute path: " <> Text.pack s | s <- maybeToList j.jobStamp, not (isAbsolute s)] + , lineBreaks fields + ] + where + fields :: [(Text, Text)] + fields = + mconcat + [ [("description", j.jobDescription)] + , [("after", a) | a <- j.jobAfter] + , [("command", w) | w <- j.jobCommand] + , [("user", u) | u <- maybeToList j.jobUser] + , [("group", g) | g <- maybeToList j.jobGroup] + , [("working directory", Text.pack d) | d <- maybeToList j.jobWorkingDir] + , [("environment", k <> v) | (k, v) <- j.jobEnvironment] + , [("environment file", Text.pack f) | f <- maybeToList j.jobEnvFile] + , [("stamp", Text.pack s) | s <- maybeToList j.jobStamp] + ] + +-- | The file a run touches when it starts; see 'jobStamp'. +stampRunning :: FilePath -> FilePath +stampRunning stamp = stamp <> ".running" + +lineBreaks :: [(Text, Text)] -> [Text] +lineBreaks fields = ["a line break in the " <> what | (what, value) <- fields, Text.any (`elem` ("\n\r" :: String)) value] + +-- | What stops a name from being the stem of a unit (and of its file). +unitNameProblems :: Text -> Text -> [Text] +unitNameProblems what name + | Text.null name = ["the " <> what <> " has no name"] + | Text.all allowed name = [] + | otherwise = ["the " <> what <> " name is not a unit name: " <> name] + where + allowed c = (isAscii c && isAlphaNum c) || c `elem` (":_.-@\\" :: String) + +data InvalidUnit = InvalidUnit !FilePath ![Text] + deriving (Show) + +instance Exception InvalidUnit + +-- | systemd was reloaded and still does not hold the unit as a usable one. +data UnitNotLoaded = UnitNotLoaded !Systemd.UnitTarget !Text + deriving (Show) + +instance Exception UnitNotLoaded + +------------------------------------------------------------------------------- + +{- | Installs the job: writes @NAME.service@ and has systemd load it. It +does not run it. + +@up@ is @daemon-reload@, then systemd is asked again and anything but a +loaded unit is thrown ('UnitNotLoaded'): a file systemd refuses +(@bad-setting@) would otherwise be an @up@ that succeeds at every pass. +@down@ stops the job if it is running, and the file's own @down@ removes the +file and reloads. The unit directory is created if missing and never removed +('unitDirectory'). + +The 'Track'' is what the job stands on: the program it runs, its user, its +environment file. The node's 'Ref' is the unit's (@"systemd-unit"@ +@NAME.service@), the effect site an authored service of that name has. +-} +jobService :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Track' Job -> + Job -> + Op +jobService r systemctl t j = + withSystemctl r systemctl (Systemd.DaemonReload j.jobScope) $ \reload -> + withSystemctl r systemctl (Systemd.Stop j.jobScope target) $ \stop -> + op "systemd-job" (deps [file, run t j]) $ \actions -> + actions + { help = "installs the job " <> target <> " without running it" + , notes = ["unit: " <> FS.hashBytes (Text.encodeUtf8 rendered)] + , ref = mkRef "systemd-unit" target + , check = Systemd.checkLoaded j.jobScope target + , up = reloadAndRequireLoaded j.jobScope target reload + , down = stopIfKnown j.jobScope target stop + } + where + target = jobServiceTarget j + rendered = renderJobService j + file = unitFile r j.jobScope (jobServicePath j) (jobProblems j) rendered + +-- | @reload@, then throw unless systemd now holds the unit as written. +reloadAndRequireLoaded :: Systemd.Scope -> Systemd.UnitTarget -> IO () -> IO () +reloadAndRequireLoaded scope target reload = do + reload + loaded <- Systemd.checkLoaded scope target + case loaded of + Failure why -> throwIO (UnitNotLoaded target why) + _ -> pure () + +{- | Runs @stop@ unless systemd has never heard of the unit: @systemctl stop@ +exits 5 for one, and a @down@ that throws for a job that was never installed +blocks the teardown of everything under it. +-} +stopIfKnown :: Systemd.Scope -> Systemd.UnitTarget -> IO () -> IO () +stopIfKnown scope target stop = do + loaded <- Systemd.checkLoaded scope target + unless (loaded == Failure unknownUnit) stop + where + unknownUnit = case Systemd.interpretLoaded ["LoadState=not-found"] of + Failure why -> why + _ -> "" + +{- | 'Systemd.unitDirectory': one node per unit directory, shared with the +authored services of "Salmon.Builtin.Nodes.Systemd"; created if missing, +left alone by @down@. +-} +unitDirectory :: FilePath -> Op +unitDirectory = Systemd.unitDirectory + +{- | A unit file: 'FS.filecontents' in a 'unitDirectory', refusing to write +when there are problems, and reloading systemd after its @down@ removed the +file (a unit outlives its file until the next reload). +-} +unitFile :: Reporter Systemd.Report -> Systemd.Scope -> FilePath -> [Text] -> Text -> Op +unitFile r scope path problems contents = + let file = FS.filecontents (FS.FileContents path contents) + in file{node = fmap own file.node, predecessors = deps [unitDirectory (takeDirectory path)]} + where + own :: Extension -> Extension + own ext = + ext + { up = do + unless (null problems) $ throwIO (InvalidUnit path problems) + ext.up + , down = do + ext.down + Binary.untrackedExec + Systemd.callSystemctl + (Systemd.DaemonReload scope) + "" + (contramap (Systemd.CallSystemCtl (Systemd.DaemonReload scope)) r) + } + +withSystemctl :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Systemd.SystemCtlCall -> + (IO () -> Op) -> + Op +withSystemctl r systemctl cmd f = + let + g :: (Reporter Binary.Report -> IO ()) -> Op + g callbin = f (callbin (contramap (Systemd.CallSystemCtl cmd) r)) + in + withBinary systemctl Systemd.callSystemctl cmd g + +------------------------------------------------------------------------------- + +{- | When a timer fires. The texts are systemd's own (@systemd.time(7)@): a +calendar expression for 'OnCalendar' (@"*-*-* 03:00:00"@, @"Mon..Fri 08:00"@, +@"hourly"@), a time span for the others (@"15min"@, @"1h 30min"@). +-} +data Schedule + = -- | at these wall-clock times + OnCalendar Text + | -- | this long after the machine booted + OnBootSec Text + | -- | this long after the manager started (the user's login, in user scope) + OnStartupSec Text + | -- | this long after the triggered unit was last /started/ + OnUnitActiveSec Text + | -- | this long after the triggered unit last /finished/ + OnUnitInactiveSec Text + deriving (Eq, Ord, Show) + +{- | @NAME.timer@, starting 'timerTriggers' on a schedule. 'timer' and +'jobTimer' are the starting points. +-} +data Timer + = Timer + { timerScope :: Systemd.Scope + , timerUnitDir :: FilePath + , timerName :: Text + , timerDescription :: Text + , timerTriggers :: Systemd.UnitTarget + -- ^ written out as @Unit=@ even when it is the default @NAME.service@ + , timerSchedules :: [Schedule] + -- ^ any of them firing starts the unit + , timerPersistent :: Bool + -- ^ @Persistent=@: a calendar run missed while the machine was off is + -- made up at the next boot. Only 'OnCalendar' schedules are affected. + , timerRandomizedDelay :: Maybe Text + -- ^ @RandomizedDelaySec=@, a time span: so a fleet does not fire at once + , timerAccuracy :: Maybe Text + -- ^ @AccuracySec=@; systemd's default is a minute + , timerWantedBy :: Systemd.UnitTarget + } + deriving (Eq, Show) + +-- | A system-scope timer, started with @timers.target@, that makes up no missed run. +timer :: Text -> Systemd.UnitTarget -> [Schedule] -> Timer +timer name triggers schedules = + Timer + { timerScope = Systemd.System + , timerUnitDir = systemUnitDir + , timerName = name + , timerDescription = "runs " <> triggers <> " (salmon)" + , timerTriggers = triggers + , timerSchedules = schedules + , timerPersistent = False + , timerRandomizedDelay = Nothing + , timerAccuracy = Nothing + , timerWantedBy = "timers.target" + } + +-- | The timer for a 'Job': same name, scope and directory. +jobTimer :: Job -> [Schedule] -> Timer +jobTimer j schedules = + (timer j.jobName (jobServiceTarget j) schedules) + { timerScope = j.jobScope + , timerUnitDir = j.jobUnitDir + } + +timerTarget :: Timer -> Systemd.UnitTarget +timerTarget tm = tm.timerName <> ".timer" + +timerPath :: Timer -> FilePath +timerPath tm = tm.timerUnitDir Text.unpack (timerTarget tm) + +renderTimer :: Timer -> Text +renderTimer tm = + Text.unlines $ + mconcat + [ ["[Unit]", "Description=" <> tm.timerDescription] + , ["", "[Timer]", "Unit=" <> tm.timerTriggers] + , map schedule tm.timerSchedules + , ["Persistent=true" | tm.timerPersistent] + , ["RandomizedDelaySec=" <> d | d <- maybeToList tm.timerRandomizedDelay] + , ["AccuracySec=" <> a | a <- maybeToList tm.timerAccuracy] + , ["", "[Install]", "WantedBy=" <> tm.timerWantedBy] + ] + where + schedule :: Schedule -> Text + schedule (OnCalendar e) = "OnCalendar=" <> e + schedule (OnBootSec s) = "OnBootSec=" <> s + schedule (OnStartupSec s) = "OnStartupSec=" <> s + schedule (OnUnitActiveSec s) = "OnUnitActiveSec=" <> s + schedule (OnUnitInactiveSec s) = "OnUnitInactiveSec=" <> s + +{- | Why this timer cannot be written. Whether a calendar expression or a +time span /means/ anything is systemd's to say: a timer it cannot read fails +to start, which fails @up@. +-} +timerProblems :: Timer -> [Text] +timerProblems tm = + mconcat + [ unitNameProblems "timer" tm.timerName + , ["the timer has no schedule" | null tm.timerSchedules] + , ["an empty schedule" | s <- tm.timerSchedules, Text.null (Text.strip (scheduleText s))] + , ["the timer triggers nothing" | Text.null tm.timerTriggers] + , ["the timer triggers itself" | tm.timerTriggers == timerTarget tm] + , lineBreaks fields + ] + where + scheduleText :: Schedule -> Text + scheduleText (OnCalendar e) = e + scheduleText (OnBootSec s) = s + scheduleText (OnStartupSec s) = s + scheduleText (OnUnitActiveSec s) = s + scheduleText (OnUnitInactiveSec s) = s + + fields :: [(Text, Text)] + fields = + mconcat + [ [("description", tm.timerDescription), ("triggered unit", tm.timerTriggers), ("wanted-by", tm.timerWantedBy)] + , [("schedule", scheduleText s) | s <- tm.timerSchedules] + , [("randomized delay", d) | d <- maybeToList tm.timerRandomizedDelay] + , [("accuracy", a) | a <- maybeToList tm.timerAccuracy] + ] + +{- | Installs the timer and keeps it waiting: written, enabled, started. + +The 'Track'' is where the caller says what it triggers (a 'jobService', a +'Salmon.Builtin.Nodes.Podman.Quadlet.quadletJob'); 'scheduledJob' does that +for a 'Job'. A timer naming a unit systemd does not know refuses to start, +so the triggered unit has to be there first. + +@up@ is reload, enable, restart; restarting a timer runs nothing, it re-arms +it. @down@ is @disable --now@ (the triggered unit is left to its own node), +then the file's @down@ removes the file and reloads. +-} +timerUnit :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Track' Timer -> + Timer -> + Op +timerUnit r systemctl t tm = + withSystemctl r systemctl (Systemd.DaemonReload tm.timerScope) $ \reload -> + withSystemctl r systemctl (Systemd.Enable tm.timerScope target) $ \enable -> + withSystemctl r systemctl (Systemd.Up tm.timerScope target) $ \restart -> + withSystemctl r systemctl (Systemd.Disable tm.timerScope target) $ \disable -> + op "systemd-timer" (deps [file, run t tm]) $ \actions -> + actions + { help = "schedules " <> tm.timerTriggers <> " with " <> target + , notes = ["unit: " <> FS.hashBytes (Text.encodeUtf8 rendered)] + , ref = mkRef "systemd-unit" target + , check = Systemd.checkUnit Systemd.interpretShow tm.timerScope target + , up = reload >> enable >> restart + , -- @disable@ fails for a unit file that is not + -- there, which is a timer already gone + down = do + present <- doesFileExist (timerPath tm) + when present disable + } + where + target = timerTarget tm + rendered = renderTimer tm + file = unitFile r tm.timerScope (timerPath tm) (timerProblems tm) rendered + +{- | A 'Job' and the timer that runs it: 'timerUnit' over 'jobTimer', standing +on 'jobService'. The 'Track'' is the job's. +-} +scheduledJob :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Track' Job -> + Job -> + [Schedule] -> + Op +scheduledJob r systemctl t j schedules = + timerUnit r systemctl (Track (const (jobService r systemctl t j))) (jobTimer j schedules) + +{- | Runs a job now: @systemctl start@, which for a oneshot unit returns when +the command has exited and fails if it did not exit 0, so a failed job is a +failed @up@. A run already under way (the timer fired) is joined, not killed. + +It has no check, so it runs at every pass, which is what a step of a +deployment wants ("migrate, then restart") and not what a once-ever job +wants; such a caller gives the node its own check. It has no dependency +either: the caller injects whatever installs the unit. @down@ does nothing, +since a run that finished left nothing of its own behind. +-} +runJob :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Systemd.Scope -> + Systemd.UnitTarget -> + Op +runJob r systemctl scope target = + withSystemctl r systemctl (Systemd.StartUnit scope target) $ \start -> + op "systemd-job-run" nodeps $ \actions -> + actions + { help = "runs " <> target <> " to completion" + , ref = mkRef "systemd-job-run" target + , up = start + } + +------------------------------------------------------------------------------- + +{- | What 'completedRun' asks about: a unit, the files a run of it has to be +newer than, and the stamp its runs leave, if it leaves one. +-} +data Completion + = Completion + { completionScope :: Systemd.Scope + , completionUnit :: Systemd.UnitTarget + , completionWritten :: [FilePath] + -- ^ a run that started before any of these was last written does not + -- count: the unit file, its configuration, its script. A file that is + -- not there is not counted; it was not written. + , completionStamp :: Maybe FilePath + -- ^ the 'jobStamp' of the unit, which has to be the same path + } + deriving (Eq, Show) + +{- | The question for a 'Job': a run newer than its unit file and its +environment file, read from its stamp if it has one. The program is not in +the list (for most jobs it is @\/bin\/sh@ or a packaged binary, whose upgrade +is not a reason to run a backup); a script or a configuration file the +command reads is the caller's to add. +-} +jobCompletion :: Job -> Completion +jobCompletion j = + Completion + { completionScope = j.jobScope + , completionUnit = jobServiceTarget j + , completionWritten = jobServicePath j : maybeToList j.jobEnvFile + , completionStamp = j.jobStamp + } + +-- | What is known about a unit's runs besides what systemd says. +data RunEvidence + = RunEvidence + { evidenceWritten :: [(FilePath, UTCTime)] + -- ^ when each file the job stands on was last written + , evidenceSucceeded :: Maybe UTCTime + -- ^ the stamp's time: when the last successful run started + , evidenceStarted :: Maybe UTCTime + -- ^ the running stamp's time: when the last run started, if it has not + -- succeeded + } + deriving (Eq, Show) + +-- | No file to be newer than and no stamp: systemd's answer alone. +noEvidence :: RunEvidence +noEvidence = RunEvidence [] Nothing Nothing + +-- | The properties 'checkLastRun' asks @systemctl show@ for. +lastRunProperties :: [String] +lastRunProperties = ["LoadState", "ActiveState", "Result", "ExecMainStatus", "ExecMainStartTimestamp"] + +{- | The verdict on a job's last run, from @systemctl show +--timestamp=us+utc@'s lines and the 'RunEvidence', pure. + +In the order asked: + +* a unit systemd does not hold is a 'Failure' (there is nothing to have run); +* a unit on its way somewhere (@activating@ is a oneshot unit /running/) is + 'Unknown': the run under way has not gone either way yet; +* @ActiveState=failed@, or a @Result@ other than @success@, is a 'Failure' + naming the result and the exit status. This is the last run, since a + failed unit stays loaded; +* a running stamp newer than the stamp is a run that started and did not + succeed, a 'Failure'. This is what is left of a failure after a reboot; +* the last successful run is the later of systemd's @ExecMainStartTimestamp@ + (only there while the unit stayed loaded) and the stamp. None is a + 'Failure': the job never ran, or ran and was forgotten, and the two cannot + be told apart; +* a file written after that run started is a 'Failure' naming the file; +* otherwise 'Completed'. + +A timestamp that is there and cannot be read is 'Unknown' rather than a +missing run. +-} +interpretLastRun :: RunEvidence -> [Text] -> CheckResult +interpretLastRun evidence ls + | loadState /= Just "loaded" = + Failure (maybe "systemctl said nothing about the unit's load state" ("the unit is " <>) loadState) + | activeState `elem` map Just ["activating", "deactivating", "reloading"] = Unknown + | activeState == Just "failed" || maybe False (/= "success") result = + Failure + ( "the last run failed: Result=" + <> fromMaybe "?" result + <> maybe "" (", exit status " <>) (property "ExecMainStatus") + ) + | unsucceeded = Failure "the last run that started did not succeed" + | otherwise = case systemdStarted of + Nothing -> Unknown + Just started -> case catMaybes [started, evidence.evidenceSucceeded] of + [] -> Failure "there is no record of a successful run" + runs -> + let lastSuccess = maximum runs + in case [path | (path, written) <- evidence.evidenceWritten, written > lastSuccess] of + (path : _) -> Failure ("no run has succeeded since " <> Text.pack path <> " was written") + [] -> Completed + where + loadState = property "LoadState" + activeState = property "ActiveState" + result = property "Result" + + unsucceeded :: Bool + unsucceeded = case (evidence.evidenceStarted, evidence.evidenceSucceeded) of + (Just started, Just succeeded) -> started > succeeded + (Just _, Nothing) -> True + (Nothing, _) -> False + + -- 'Nothing' is a timestamp that could not be read, @Just Nothing@ none + systemdStarted :: Maybe (Maybe UTCTime) + systemdStarted = case property "ExecMainStartTimestamp" of + Nothing -> Just Nothing + Just "n/a" -> Just Nothing + Just raw -> Just <$> parseTimestamp raw + + property :: Text -> Maybe Text + property name = + case [Text.strip (Text.drop 1 v) | l <- ls, let (k, v) = Text.breakOn "=" l, k == name] of + (x : _) | not (Text.null x) -> Just x + _ -> Nothing + +-- | A timestamp as @--timestamp=us+utc@ prints it: @Mon 2026-10-05 09:56:02.675581 UTC@. +parseTimestamp :: Text -> Maybe UTCTime +parseTimestamp raw = parseTimeM True defaultTimeLocale "%a %Y-%m-%d %H:%M:%S%Q UTC" (Text.unpack raw) + +{- | Asks systemd and the filesystem, then 'interpretLastRun'. @systemctl@ +not answering (or not knowing @--timestamp@, which is systemd 247's) is +'Unknown'. +-} +checkLastRun :: Completion -> IO CheckResult +checkLastRun c = maybe Unknown (uncurry interpretLastRun) <$> readRun lastRunProperties c + +{- | The files' times and @systemctl show@'s lines for these properties; +'Nothing' when @systemctl@ did not answer. +-} +readRun :: [String] -> Completion -> IO (Maybe (RunEvidence, [Text])) +readRun properties c = do + written <- fmap catMaybes (forM c.completionWritten (\path -> fmap (fmap ((,) path)) (modified path))) + succeeded <- maybe (pure Nothing) modified c.completionStamp + started <- maybe (pure Nothing) (modified . stampRunning) c.completionStamp + (code, out, _err) <- + readCreateProcessWithExitCode + ( proc + "systemctl" + ( Systemd.scopeArgs c.completionScope + <> ["show", Text.unpack c.completionUnit, "--timestamp=us+utc"] + <> map ("--property=" <>) properties + ) + ) + "" + pure $ case code of + ExitSuccess -> Just (RunEvidence written succeeded started, Text.lines (Text.pack out)) + ExitFailure _ -> Nothing + where + modified :: FilePath -> IO (Maybe UTCTime) + modified path = do + present <- doesFileExist path + if present then Just <$> getModificationTime path else pure Nothing + +{- | A job that has run: 'runJob' with 'checkLastRun' as its check. A pass +skips it when the last run succeeded after everything in 'completionWritten' +was written, runs it otherwise, and fails when that run fails, so a job +whose last run failed (the timer's or anybody's) fails every pass until a +run succeeds. Under @run serve@ the verdict of a job at rest is 'Completed'. + +It is keyed like 'runJob' (@"systemd-job-run"@ and the unit): the two are +one effect site. It has no dependency: the caller injects what installs the +unit, or uses 'completedJob'. Without a timer keeping the unit loaded and +without a stamp, a successful run is not remembered and the job runs at +every pass, as 'runJob' does (see the module's header). + +@down@ removes the stamp files, the one thing a run leaves that is this +node's. +-} +completedRun :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Completion -> + Op +completedRun r systemctl c = + withSystemctl r systemctl (Systemd.StartUnit c.completionScope target) $ \start -> + op "systemd-job-completed" nodeps $ \actions -> + actions + { help = "has " <> target <> " run to completion since it was last changed" + , notes = + ["newer than: " <> Text.pack path | path <- c.completionWritten] + <> ["stamp: " <> Text.pack s | s <- maybeToList c.completionStamp] + , ref = mkRef "systemd-job-run" target + , check = checkLastRun c + , up = start + , down = removeStamps c + } + where + target = c.completionUnit + +-- | Removes the stamp files, the one thing a run leaves that is a run node's. +removeStamps :: Completion -> IO () +removeStamps c = + forM_ c.completionStamp $ \s -> + forM_ [s, stampRunning s] $ \path -> do + present <- doesFileExist path + when present (removeFile path) + +-- | 'completedRun' for a 'Job', standing on its 'jobService'. +completedJob :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Track' Job -> + Job -> + Op +completedJob r systemctl t j = + completedRun r systemctl (jobCompletion j) `inject` jobService r systemctl t j + +{- | 'completedRun' for a 'Job', standing on its 'scheduledJob': the timer is +waiting before the first run, so systemd keeps that run's outcome. +-} +completedScheduledJob :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Track' Job -> + Job -> + [Schedule] -> + Op +completedScheduledJob r systemctl t j schedules = + completedRun r systemctl (jobCompletion j) `inject` scheduledJob r systemctl t j schedules + +------------------------------------------------------------------------------- + +{- | Where a job's runs stand, as much of it as @up@ needs to decide whether +to start one. 'interpretLastRun' folds the same reading into a +'CheckResult'; 'runVerdict' of this is that answer, for every input. +-} +data RunState + = -- | systemd does not hold the unit, and why + NotLoaded Text + | -- | a run is under way (or the unit is otherwise between states) + Running + | -- | the last run failed, and how. The path is a file written /after/ + -- that failure, if there is one: somebody changed what the job stands + -- on since, so the failure is of a job that is no longer the one + -- declared. + LastFailed Text (Maybe FilePath) + | -- | systemd answered with a timestamp that cannot be read, or did not + -- answer + Unreadable + | -- | there is no record of a successful run + NeverRan + | -- | the last successful run started before this file was written + Outdated FilePath + | -- | the last run succeeded, after everything was written + Succeeded + deriving (Eq, Show) + +{- | 'lastRunProperties' and when the unit last came to rest: +@InactiveEnterTimestamp@ is, for a failed unit, when the run failed (seen on +systemd 255; it is empty while the unit is @activating@). +-} +runStateProperties :: [String] +runStateProperties = lastRunProperties <> ["InactiveEnterTimestamp"] + +{- | 'interpretLastRun', keeping what it found apart. The branches are its +branches in its order; the one thing added is /when/ a failure happened +(@InactiveEnterTimestamp@, or the running stamp's time where systemd has +forgotten), so that a file written since can be told from one written +before. +-} +classifyRun :: RunEvidence -> [Text] -> RunState +classifyRun evidence ls + | loadState /= Just "loaded" = + NotLoaded (maybe "systemctl said nothing about the unit's load state" ("the unit is " <>) loadState) + | activeState `elem` map Just ["activating", "deactivating", "reloading"] = Running + | activeState == Just "failed" || maybe False (/= "success") result = + LastFailed + ( "the last run failed: Result=" + <> fromMaybe "?" result + <> maybe "" (", exit status " <>) (property "ExecMainStatus") + ) + (writtenSince =<< failedAt) + | unsucceeded = LastFailed "the last run that started did not succeed" (writtenSince =<< evidence.evidenceStarted) + | otherwise = case timestamp "ExecMainStartTimestamp" of + Nothing -> Unreadable + Just started -> case catMaybes [started, evidence.evidenceSucceeded] of + [] -> NeverRan + runs -> maybe Succeeded Outdated (writtenSince (maximum runs)) + where + loadState = property "LoadState" + activeState = property "ActiveState" + result = property "Result" + + unsucceeded :: Bool + unsucceeded = case (evidence.evidenceStarted, evidence.evidenceSucceeded) of + (Just started, Just succeeded) -> started > succeeded + (Just _, Nothing) -> True + (Nothing, _) -> False + + -- when systemd saw the run fail; failing that, when the run that left + -- no stamp started + failedAt :: Maybe UTCTime + failedAt = case timestamp "InactiveEnterTimestamp" of + Just (Just at) -> Just at + _ | unsucceeded -> evidence.evidenceStarted + _ -> Nothing + + writtenSince :: UTCTime -> Maybe FilePath + writtenSince at = case [path | (path, written) <- evidence.evidenceWritten, written > at] of + (path : _) -> Just path + [] -> Nothing + + -- 'Nothing' is a timestamp that could not be read, @Just Nothing@ none + timestamp :: Text -> Maybe (Maybe UTCTime) + timestamp name = case property name of + Nothing -> Just Nothing + Just "n/a" -> Just Nothing + Just raw -> Just <$> parseTimestamp raw + + property :: Text -> Maybe Text + property name = + case [Text.strip (Text.drop 1 v) | l <- ls, let (k, v) = Text.breakOn "=" l, k == name] of + (x : _) | not (Text.null x) -> Just x + _ -> Nothing + +-- | What a check answers for a 'RunState': 'interpretLastRun''s answer. +runVerdict :: RunState -> CheckResult +runVerdict (NotLoaded why) = Failure why +runVerdict Running = Unknown +runVerdict (LastFailed why _) = Failure why +runVerdict Unreadable = Unknown +runVerdict NeverRan = Failure "there is no record of a successful run" +runVerdict (Outdated path) = Failure ("no run has succeeded since " <> Text.pack path <> " was written") +runVerdict Succeeded = Completed + +-- | Asks systemd and the filesystem, then 'classifyRun'. +readRunState :: Completion -> IO RunState +readRunState c = maybe Unreadable (uncurry classifyRun) <$> readRun runStateProperties c + +-- | What 'launchedRun''s @up@ does about a 'RunState'. +data Launch + = -- | queue a start + Start + | -- | a run is under way: start nothing + LeaveRunning + | -- | the job has run: start nothing + LeaveDone + | -- | the last run failed and nothing was written since: start nothing, fail + ReportFailure Text + | -- | what is there cannot be read: start nothing, fail + CannotTell + deriving (Eq, Show) + +{- | A start is queued only for a job that is at rest and whose last run does +not count: never run, older than a file it stands on, or failed /before/ +such a file was written. A run under way is never started over, a completed +job is never run again, and a failure nobody has answered is reported and +not retried: a pass asking twice must not be a job run twice. + +A unit systemd does not hold is started all the same, for @systemctl@ to +refuse and say why. +-} +launchDecision :: RunState -> Launch +launchDecision (NotLoaded _) = Start +launchDecision Running = LeaveRunning +launchDecision (LastFailed _ (Just _)) = Start +launchDecision (LastFailed why Nothing) = ReportFailure why +launchDecision Unreadable = CannotTell +launchDecision NeverRan = Start +launchDecision (Outdated _) = Start +launchDecision Succeeded = LeaveDone + +-- | How a run that was started, or found running, stands when asked again. +data Outcome + = -- | it ran to completion + Finished + | -- | it has not ended as far as can be seen: running, or queued and not + -- yet shown as running by systemd + Pending + | -- | it failed + Broken Text + | -- | what is there cannot be read + Undetermined + deriving (Eq, Show) + +{- | Read after a start was queued or a run was found under way, so a state +'launchDecision' would start from is the moment before systemd shows the +queued run, not a reason to start another. +-} +runOutcome :: RunState -> Outcome +runOutcome st = case launchDecision st of + LeaveDone -> Finished + ReportFailure why -> Broken why + CannotTell -> Undetermined + LeaveRunning -> Pending + Start -> Pending + +{- | How long 'launchedRun''s @up@ stays to see the run end. 'noWait' is the +starting point. +-} +data Polling + = Polling + { pollingWait :: Int + -- ^ seconds @up@ may stay asking, at most; none or less is "ask once + -- and return" + , pollingEvery :: Int + -- ^ seconds between two questions; less than one is one + } + deriving (Eq, Show) + +-- | Start and return: the answer is a later pass's. +noWait :: Polling +noWait = Polling{pollingWait = 0, pollingEvery = 5} + +{- | The pauses between questions, in seconds: each at most 'pollingEvery', +together exactly 'pollingWait'. +-} +pollDelays :: Polling -> [Int] +pollDelays p = go (max 0 p.pollingWait) + where + every = max 1 p.pollingEvery + go 0 = [] + go left = let pause = min every left in pause : go (left - pause) + +{- | Why this run cannot be started and asked about later. It needs a stamp: +with nothing referring to the unit systemd forgets a successful run as it +ends, and a later pass would find a job that never ran and start it a +second time. (A waiting timer keeps the record too, but not across a +reboot.) +-} +launchProblems :: Completion -> [Text] +launchProblems c = + ["a run that is not waited for needs a stamp to be found completed later (jobStamp)" | Nothing <- [c.completionStamp]] + +-- | 'launchedRun''s notes: 'completedRun''s, and the wait when there is one. +launchNotes :: Polling -> Completion -> [Text] +launchNotes polling c = + mconcat + [ ["newer than: " <> Text.pack path | path <- c.completionWritten] + , ["stamp: " <> Text.pack s | s <- maybeToList c.completionStamp] + , [ "waits: up to " <> Text.pack (show polling.pollingWait) <> "s, asking every " <> Text.pack (show (max 1 polling.pollingEvery)) <> "s" + | polling.pollingWait > 0 + ] + ] + +-- | The run cannot be declared this way; see 'launchProblems'. +data CannotLaunch = CannotLaunch !Systemd.UnitTarget ![Text] + deriving (Show) + +instance Exception CannotLaunch + +{- | The job is running and @up@ did not stay to see it end. Not a failure of +the job: the next pass asks again. +-} +newtype RunInProgress = RunInProgress Systemd.UnitTarget + +instance Show RunInProgress where + show (RunInProgress target) = + "RunInProgress: " <> Text.unpack target <> " is still running (in progress, neither failed nor done); a later pass will find how it ended" + +instance Exception RunInProgress + +-- | The job's last run failed and nothing it stands on was written since. +data RunFailed = RunFailed !Systemd.UnitTarget !Text + deriving (Show) + +instance Exception RunFailed + +-- | Neither systemd nor the stamps said where the job stands; nothing was started. +newtype RunUndetermined = RunUndetermined Systemd.UnitTarget + deriving (Show) + +instance Exception RunUndetermined + +{- | A job that has run, started without being waited for: 'completedRun' +whose @up@ is @systemctl start --no-block@ and returns. + +The check is 'completedRun''s ('runVerdict' of 'readRunState'): 'Completed' +once a run succeeded after everything in 'completionWritten' was written, +'Unknown' while a run is under way, a 'Failure' otherwise. + +@up@ reads the same state and follows 'launchDecision': it queues a start +for a job at rest whose last run does not count, starts nothing for a job +that is running or has run, and for a job whose last run failed throws +'RunFailed' /without/ running it again (write one of the files it stands +on, which is what fixing it usually is, or @systemctl reset-failed@ and +remove @STAMP.running@, to have it run again). It then asks again, for up +to 'pollingWait' seconds, and: + +* returns if the run succeeded; +* throws 'RunFailed' if it failed; +* throws 'RunInProgress' if it is still running. + +The last one is how "in progress" reaches a driver, which knows a node's +@up@ as done or failed and nothing between: what stands on the job is not +run against a job that has not finished, the pass ends unsuccessful, and +the report names 'RunInProgress' and not a failure of the job. A later pass +finds the run under way (and starts nothing), completed (a skip) or failed. +Each pass is a call of its own, so a link that drops costs a pass and not +the run; a caller wanting one command that returns when the job is over +repeats the pass, with a 'pollingWait' as long as it cares to hold one call. + +The 'Completion' has to name a stamp ('launchProblems'): @up@ throws +'CannotLaunch' without one. Keyed like 'runJob' and 'completedRun', being +the same effect site; no dependency, the caller injects what installs the +unit or uses 'launchedJob'. @down@ removes the stamp files and stops +nothing: a run under way is the installing node's to stop. +-} +launchedRun :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Polling -> + Completion -> + Op +launchedRun r systemctl polling c = + withSystemctl r systemctl (Systemd.StartUnitNoBlock c.completionScope target) $ \start -> + op "systemd-job-launched" nodeps $ \actions -> + actions + { help = "has " <> target <> " run to completion since it was last changed, started without waiting for it" + , notes = launchNotes polling c + , ref = mkRef "systemd-job-run" target + , check = runVerdict <$> readRunState c + , up = launch start + , down = removeStamps c + } + where + target = c.completionUnit + + launch :: IO () -> IO () + launch start = do + let problems = launchProblems c + unless (null problems) $ throwIO (CannotLaunch target problems) + found <- readRunState c + case launchDecision found of + Start -> start >> settle (pollDelays polling) + LeaveRunning -> settle (pollDelays polling) + LeaveDone -> pure () + ReportFailure why -> throwIO (RunFailed target why) + CannotTell -> throwIO (RunUndetermined target) + + settle :: [Int] -> IO () + settle pauses = do + outcome <- runOutcome <$> readRunState c + case (outcome, pauses) of + (Finished, _) -> pure () + (Broken why, _) -> throwIO (RunFailed target why) + (_, pause : rest) -> threadDelay (pause * 1000000) >> settle rest + (Pending, []) -> throwIO (RunInProgress target) + (Undetermined, []) -> throwIO (RunUndetermined target) + +-- | 'launchedRun' for a 'Job', standing on its 'jobService'. +launchedJob :: + Reporter Systemd.Report -> + Track' (Binary "systemctl") -> + Track' Job -> + Polling -> + Job -> + Op +launchedJob r systemctl t polling j = + launchedRun r systemctl polling (jobCompletion j) `inject` jobService r systemctl t j diff --git a/src/Salmon/Client/Model.hs b/src/Salmon/Client/Model.hs --- a/src/Salmon/Client/Model.hs +++ b/src/Salmon/Client/Model.hs @@ -43,8 +43,40 @@ 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. +after the pass, and @\/dag@ would not show it either. Dropping it costs a +lookup, not a pass over the display order ('Order'): a teardown is one such +event per node, and filtering a list of every node for each of them made +the fold quadratic over one (finding 5 of @resources\/graph-profiles.md@). += The output stream + +The @output@ stream is what a node writes while it works, and it carries +two kinds that are folded into two different fields because a snapshot +covers one and not the other: + + * @output@, a line a /held/ action wrote. The server pushes it into the + node's ring as it reports it, and @\/dag@ returns that ring as + @status.output@. So it is appended to 'nodeOutput' under the node's own + stamp like any other event about the node, and a re-read snapshot + replaces the lot. + * @log@, a line a node said during a one-shot @up@ + ("Salmon.Builtin.NodeLog": a streamed command's output, or its own + progress message). They are not in the ring; a @\/dag@ answer carries + them in the node's @tail@ (the newest events about it, none numbered + above the answer's @seq@), and one from before that field existed does + not have them at all. So they are kept apart in 'nodeSaid' with a + stamp of their own ('nodeSaidSeq'): seeded from @tail@ at the + snapshot's number when there is one, and 'rebase' keeps whichever of + the old and the fresh is current to the later number, so a re-read + every @declared@ asks for neither loses a build's tail nor repeats + it. + +Neither moves 'nodeLastKind': a line is not something that happened to +the node's convergence, and a table whose last column reads @log@ for the +length of a build says less than one that still reads @eval@. Both are +bounded ('outputKept' lines, the oldest dropped), because a client left +open on a chatty node would otherwise grow without limit. + = Replays are dropped, per stamp One counter numbers everything on the stream, and a snapshot carries the @@ -86,11 +118,20 @@ resolve, rebase, + -- * The display order + Order, + orderFromList, + orderToList, + orderRemove, + orderSize, + -- * Reading it nodesInOrder, Counts (..), counts, lookupNode, + outputKept, + tailLines, -- * Rendering pieces renderNodeRow, @@ -103,10 +144,13 @@ import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap import Data.Foldable (toList) +import Data.Function (on) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap import Data.List (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Text (Text) import qualified Data.Text as Text import Data.Word (Word64) @@ -172,7 +216,13 @@ -- ^ @pending@\/@stale@\/@converged@\/@errored@\/@blocked@ , nodeCheck :: !(Maybe Check) , nodeOutput :: ![Text] - -- ^ the snapshot's output ring, oldest first + -- ^ the snapshot's output ring, then each @output@ line since, oldest first + , nodeSaid :: ![Text] + -- ^ the @log@ lines the stream carried (what the node said during a + -- one-shot @up@), oldest first; a line from standard error is prefixed + -- @err| @ and the node's own message @msg| @. In no snapshot. + , nodeSaidSeq :: !Word64 + -- ^ the number 'nodeSaid' is current to; 0 until a line arrives , nodeError :: !(Maybe Text) -- ^ the last @failed@'s error, cleared by a later @done@\/@skip@ , nodeLastKind :: !(Maybe Text) @@ -186,6 +236,74 @@ } deriving (Show, Eq) +{- | The order the nodes are shown in: the refs of a snapshot, in the +snapshot's order, less the ones removed since. + +It reads as the list it is built from ('orderToList'), and 'orderRemove' +is that list with every copy of a ref filtered out, which is what the +model did on a plain list until a teardown of ten thousand nodes was +measured at two seconds of filtering. Each ref keeps the seat the snapshot +gave it, so removing one is a lookup of its seats and a deletion of each, +and the refs that stay are never renumbered: ascending seats are the +snapshot's order whatever has been removed in between. + +A ref listed twice has two seats and is shown twice, as before; a @\/dag@ +answer has one node per ref, so this only keeps the fold total on a +document that is not one. + +Two orders are equal when they read the same: which seats a removal left +empty is not something a reader can see, and a model that dropped a node +equals one read from a snapshot that never had it (as it did when the +order was a list). +-} +data Order = Order + { orderSeats :: !(IntMap RefId) + -- ^ seat to ref; ascending seats are the display order + , orderPlaces :: !(Map RefId [Int]) + -- ^ the seats of each ref still shown + } + +instance Eq Order where + (==) = (==) `on` orderToList + +instance Show Order where + showsPrec d o = showParen (d > 10) (showString "orderFromList " . showsPrec 11 (orderToList o)) + +-- | The order that shows these refs, first to last. +orderFromList :: [RefId] -> Order +orderFromList rs = orderSeated rs (Map.fromListWith (++) [(r, [i]) | (i, r) <- zip [0 ..] rs]) + +-- | 'orderFromList' for a caller that already has each ref's seats (its +-- positions in the list, counted from 0): 'fromDag', which keys the nodes +-- by ref anyway and would otherwise compare every ref a second time. +orderSeated :: [RefId] -> Map RefId [Int] -> Order +orderSeated rs places = + Order + { orderSeats = IntMap.fromDistinctAscList (zip [0 ..] rs) + , orderPlaces = places + } + +-- | The refs shown, first to last. +orderToList :: Order -> [RefId] +orderToList = IntMap.elems . orderSeats + +-- | How many refs are shown (a ref listed twice counts twice). +orderSize :: Order -> Int +orderSize = IntMap.size . orderSeats + +{- | Stop showing a ref: @orderToList (orderRemove r o) == filter (/= r) +(orderToList o)@, at the cost of a lookup rather than of the list. A ref +that is not shown leaves the order as it was. +-} +orderRemove :: RefId -> Order -> Order +orderRemove r o = case Map.lookup r o.orderPlaces of + Nothing -> o + Just seats -> + Order + { orderSeats = foldl' (flip IntMap.delete) o.orderSeats seats + , orderPlaces = Map.delete r o.orderPlaces + } + -- | The loop's last convergence pass as the stream told it. data Pass = -- | @converge-start@: nodes to turn down, nodes to turn up @@ -202,8 +320,9 @@ -- 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') + , modelOrder :: !Order + -- ^ the snapshot's dependency order ('Salmon.Op.Dag.dagOrder'), less + -- the nodes dropped since; read it with 'orderToList' , modelNodes :: !(Map RefId Node) , modelPass :: !(Maybe Pass) , modelSupervised :: !(Maybe Bool) @@ -228,18 +347,26 @@ 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. +why the loop's part is not simply the snapshot's. What a node said +('nodeSaid') is the old model's unless the fresh snapshot's is current to a later number +(so always the old model's against a server whose @\/dag@ has no @tail@). -} rebase :: Model -> Model -> Model rebase old fresh = fresh - { modelSeq = max old.modelSeq fresh.modelSeq + { modelNodes = Map.mapWithKey keepSaid fresh.modelNodes + , modelSeq = max old.modelSeq fresh.modelSeq , modelLoopSeq = old.modelLoopSeq , modelPass = old.modelPass , modelSupervised = old.modelSupervised , modelLast = old.modelLast , modelResyncReason = Nothing } + where + keepSaid :: RefId -> Node -> Node + keepSaid r n = case Map.lookup r old.modelNodes of + Just o | not (n.nodeSaidSeq > o.nodeSaidSeq) -> n{nodeSaid = o.nodeSaid, nodeSaidSeq = o.nodeSaidSeq} + _ -> n {- | 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 @@ -250,22 +377,40 @@ 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 + let seated = seatedOf parsed pure Model { modelMode = fromMaybe "?" (textAt ["mode"] v) , modelSeq = seqNo , modelLoopSeq = 0 - , modelOrder = fmap nodeRef parsed - , modelNodes = Map.fromList [(nodeRef n, n) | n <- parsed] + , modelOrder = orderSeated (fmap nodeRef parsed) (Map.map snd seated) + , modelNodes = Map.map fst seated , modelPass = Nothing , modelSupervised = Nothing , modelLast = Nothing , modelResyncReason = Nothing } where + -- each ref's node (the last listed, as 'Map.fromList' keeps) and its + -- seats, keyed once: the refs are compared for one map, not for the + -- node map and again for the order's + seatedOf :: [Node] -> Map RefId (Node, [Int]) + seatedOf parsed = Map.fromListWith (\(n, new) (_, old) -> (n, new ++ old)) [(nodeRef n, (n, [i])) | (i, n) <- zip [0 ..] parsed] + nodeOf :: Word64 -> Value -> Either String Node nodeOf seqNo n = do r <- maybe (Left ("a node without a ref: " <> show n)) Right (refAt ["ref"] n) + let tailEvents = arrayAt ["tail"] n + hasTail = isJust tailEvents + -- what the node said, as 'step' would have folded it live + saidIn = + lastKept + [ channelMark (textAt ["channel"] e) <> line + | e <- fromMaybe [] tailEvents + , textAt ["stream"] e == Just "output" + , textAt ["kind"] e == Just "log" + , Just line <- [textAt ["line"] e] + ] pure Node { nodeRef = r @@ -276,6 +421,8 @@ , nodeConvergence = fromMaybe "?" (textAt ["convergence"] n) , nodeCheck = checkAt ["status", "check"] n , nodeOutput = maybe [] (mapMaybe asText) (arrayAt ["status", "output"] n) + , nodeSaid = saidIn + , nodeSaidSeq = if hasTail then seqNo else 0 , nodeError = Nothing , nodeLastKind = Nothing , nodeLastSeq = Nothing @@ -321,8 +468,30 @@ ("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 + -- a held action's line: in the ring, so under the node's stamp + ("output", "output") -> + case (e.eventRef, textAt ["line"] e.eventValue) of + (Just r, Just line) -> onNode r (\n -> n{nodeOutput = keepLast (n.nodeOutput ++ [line])}) m + _ -> m + -- a line said during a one-shot up: in no snapshot, so its own stamp + ("output", "log") -> + case (e.eventRef, textAt ["line"] e.eventValue) of + (Just r, Just line) -> said r (channelMark (textAt ["channel"] e.eventValue) <> line) m + _ -> m _ -> m + said :: RefId -> Text -> Model -> Model + said r line m = case Map.lookup r m.modelNodes of + Nothing -> m + Just n + | Just s <- e.eventSeq, s <= n.nodeSaidSeq -> m + | otherwise -> + let n' = n{nodeSaid = keepLast (n.nodeSaid ++ [line]), nodeSaidSeq = fromMaybe n.nodeSaidSeq e.eventSeq} + in m{modelNodes = Map.insert r n' m.modelNodes} + + keepLast :: [Text] -> [Text] + keepLast xs = drop (length xs - outputKept) xs + -- 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 @@ -340,7 +509,7 @@ | 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} + then m{modelNodes = Map.delete r m.modelNodes, modelOrder = orderRemove r m.modelOrder} else m{modelNodes = Map.insert r n' m.modelNodes} touch :: Text -> Node -> Node @@ -363,11 +532,37 @@ -- | The nodes in the snapshot's dependency order. nodesInOrder :: Model -> [Node] -nodesInOrder m = mapMaybe (`Map.lookup` m.modelNodes) m.modelOrder +nodesInOrder m = mapMaybe (`Map.lookup` m.modelNodes) (orderToList m.modelOrder) lookupNode :: RefId -> Model -> Maybe Node lookupNode r m = Map.lookup r m.modelNodes +-- | The last 'outputKept' of some lines. +lastKept :: [a] -> [a] +lastKept xs = drop (length xs - outputKept) xs + +-- | How many lines of 'nodeOutput' and of 'nodeSaid' a node's view keeps. +outputKept :: Int +outputKept = 200 + +-- | How a @log@ line's channel shows in front of it: nothing for standard +-- output, the marks the text reporter and the web UI's tail use otherwise. +channelMark :: Maybe Text -> Text +channelMark c = case c of + Just "stderr" -> "err| " + Just "message" -> "msg| " + _ -> "" + +{- | The last @k@ lines a live tail of this node shows: what it said during +its one-shot @up@ when it said anything, its ring otherwise (a held +action's output, which is the only other thing that moves while one +watches). +-} +tailLines :: Int -> Node -> [Text] +tailLines k n = lastN (if null n.nodeSaid then n.nodeOutput else n.nodeSaid) + where + lastN xs = drop (length xs - k) xs + data Counts = Counts { countConverged :: !Int , countErrored :: !Int @@ -440,10 +635,13 @@ , describeEvent e ] --- | The words after the kind: the node's short ref, or the loop-level --- fields worth a glance. +-- | The words after the kind: the node's short ref (and, for a line of +-- output, the line), or the loop-level fields worth a glance. describeEvent :: Event -> Text describeEvent e = case e.eventRef of + Just r + | e.eventStream == "output" -> + r.refShort <> " " <> channelMark (textAt ["channel"] e.eventValue) <> fromMaybe "" (textAt ["line"] e.eventValue) 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"]) diff --git a/src/Salmon/Op/CardTemplate.hs b/src/Salmon/Op/CardTemplate.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Op/CardTemplate.hs @@ -0,0 +1,45 @@ +{- | An optional Tramaj template a node carries for the web UI: when it is +there, the page draws the node's card (the descriptive part of the panel a +selected node opens) from the template, evaluated in the browser against the +node's own public fields, instead of the default sections. + +It rides in 'Salmon.Builtin.Extension.Extension''s @dynamics@ as a +'CardTemplate', so a node without one carries nothing new and renders +exactly what it did. It is presentation only: "Salmon.Op.Dag"'s +@representative@ leaves it out, so adding, changing or removing a template +never changes a node's representative (no conflict, no @Stale@, no restart +of a held action); a re-declaration still replaces it in the magma like +every other field, since the newest declaration's 'Act' wins there. + +The source is public, like @help@ and @notes@: it is served on @\/dag@ as the +node's @template@. It is author-written text, never read from a secret. +The contract a template is written against is @salmon-ops\/ui\/card-template.js@. +-} +module Salmon.Op.CardTemplate ( + CardTemplate (..), + cardTemplateOf, + isCardTemplate, + setCardTemplate, +) where + +import Data.Dynamic (Dynamic, fromDynamic, toDyn) +import Data.Maybe (isJust, mapMaybe) +import Data.Text (Text) + +-- | A Tramaj program, as source text. +newtype CardTemplate = CardTemplate {cardTemplateSource :: Text} + deriving (Show, Eq) + +-- | The template among a node's dynamics, the last one if several. +cardTemplateOf :: [Dynamic] -> Maybe Text +cardTemplateOf ds = + case mapMaybe fromDynamic ds of + [] -> Nothing + ts -> Just (cardTemplateSource (last ts)) + +isCardTemplate :: Dynamic -> Bool +isCardTemplate d = isJust (fromDynamic d :: Maybe CardTemplate) + +-- | Replace any template among the dynamics with this one. +setCardTemplate :: Text -> [Dynamic] -> [Dynamic] +setCardTemplate src ds = filter (not . isCardTemplate) ds <> [toDyn (CardTemplate src)] diff --git a/src/Salmon/Op/Dag.hs b/src/Salmon/Op/Dag.hs --- a/src/Salmon/Op/Dag.hs +++ b/src/Salmon/Op/Dag.hs @@ -70,6 +70,7 @@ record, collapseInto, addEdge, + transposeOf, -- * Colliding representatives Conflict (..), @@ -79,18 +80,26 @@ ) where import Control.Comonad.Cofree (Cofree (..)) +import Control.Monad (foldM) +import Data.Array (Array, accumArray) +import Data.Array.ST (newListArray, readArray, runSTUArray, writeArray) +import Data.Array.Unboxed (UArray, (!)) import Data.Dynamic (Dynamic, fromDynamic) import Data.Foldable (toList) +import qualified Data.IntSet as IntSet import Data.List (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) 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.CardTemplate (isCardTemplate) import Salmon.Op.Graph +import Salmon.Op.Guard (Guard) import Salmon.Op.OpGraph import Salmon.Op.Ref import Salmon.Op.Supervision (Supervision) @@ -124,6 +133,9 @@ -- ^ 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. + -- 'foldDag' records one per declaration that lost, each against the + -- final representative; 'record' (and so 'mergeDag') one per + -- replacement. } -- | A representative that lost to last-writer-wins, and the one that beat it. @@ -131,7 +143,8 @@ { conflictRef :: !Ref , conflictKept :: !(Act ext) -- ^ The representative that replaced 'conflictReplaced'. Note a /later/ - -- write may have replaced this one in turn; @'dagNodes' dag '!' + -- write may have replaced this one in turn (a merge; within one + -- 'foldDag' it is always the final one); @'dagNodes' dag '!' -- 'conflictRef'@ is the final answer. , conflictReplaced :: !(Act ext) } @@ -187,8 +200,18 @@ @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. +what is left over when it runs out of ready nodes is the answer. Only the +nodes of the 'Dag' count: a 'Ref' @waitsOn@ names that the 'Dag' does not +hold is never waited for. +One pass: each node keeps a count of the waits still outstanding, and a node +that becomes ready decrements its waiters once, so the cost is +O((nodes + edges) log nodes) for numbering the 'Ref's each wait names, and +linear after that. It used to recompute the ready set over all the +remaining nodes once per round, which is one round per level of depth and so +quadratic on a chain (2 s on a 3 000-node chain, @resources\/graph-profiles.md@). +"Test.DagStuckSpec" checks the two agree. + 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 @@ -196,33 +219,136 @@ 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)) +stuck waitsOn dag = + Set.fromDistinctAscList [r | (i, r) <- numbered, outstanding ! i > 0] 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) + -- every node numbered by its position among the keys of 'dagNodes' + -- (which are the nodes of 'dagOrder', by the invariant), so that the + -- walk below indexes arrays rather than comparing 'Ref's, and numbering + -- costs no map of its own. + numbered :: [(Int, Ref)] + numbered = zip [0 ..] (Map.keys (dagNodes dag)) + bounds' :: (Int, Int) + bounds' = (0, Map.size (dagNodes dag) - 1) + + -- what each node waits on, restricted to the nodes of the 'Dag' (a 'Ref' + -- it has never seen is never waited for) and deduplicated (a repeat is + -- one wait, as with 'all'). + waits :: [(Int, [Int])] + waits = + [ (i, IntSet.toList (IntSet.fromList [j | w <- waitsOn dag r, Just j <- [Map.lookupIndex w (dagNodes dag)]])) + | (i, r) <- numbered + ] + + -- the transpose of 'waits': who is released, one wait at a time, when a + -- node becomes ready. A self-wait lands here too and is never released, + -- since a node that waits on itself never becomes ready. + releases :: Array Int [Int] + releases = accumArray (flip (:)) [] bounds' [(j, i) | (i, ws) <- waits, j <- ws] + + -- Kahn's algorithm with a count of outstanding waits per node: each node + -- becomes ready at most once and releases its waiters then, so each wait + -- is looked at once instead of once per round. What is left above zero + -- is the answer. + outstanding :: UArray Int Int + outstanding = runSTUArray $ do + counts <- newListArray bounds' [length ws | (_, ws) <- waits] + let drain [] = pure () + drain (i : queue) = do + freed <- foldM (release counts) [] (releases ! i) + drain (freed <> queue) + release counts' freed waiter = do + k <- readArray counts' waiter + writeArray counts' waiter (k - 1) + pure (if k == 1 then waiter : freed else freed) + drain [i | (i, ws) <- waits, null ws] + pure counts + ------------------------------------------------------------------------------- -{- | Collapse an expanded graph. +{- | Collapse an expanded graph, visiting each node once. -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. += What is walked -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. +An /occurrence/ is one cell of the expansion that carries a node. The +expansion is a tree, so a node reached by several paths has one occurrence +per path, and a chain of diamonds has exponentially many. This fold does not +walk them all. Of an occurrence it looks at three things, its /top/: + +* its 'Ref'; +* its act, as far as the conflict test (the first argument) can tell; +* the 'Ref's of its effective predecessors (the nearest nodes below it, + through any 'Actionless' glue), deduplicated, in order. + +An occurrence whose top has been walked already is __not walked again, and +neither is anything below it__. So the cost is one visit per distinct top +(one per node, in a graph where a node is declared one way) plus one look at +each of its predecessors, instead of one visit per path. It does not prune by +'Ref' alone, the way the collapse inside @downTreeWith@ used to: that dropped +the edges of a re-declaration with other predecessors, which is exactly what +a merge must not do. + += The precondition: coherent declarations + +Skipping is only right if a second occurrence with the same top has the same +things below it. That is the precondition, and nothing here checks it (doing +so is the per-path walk this fold exists to avoid): + +__Coherent__: whenever two occurrences have the same top, they have as many +effective predecessors as each other, and those have the same tops, one for +one in order. By induction, same top means same tree all the way down, up to +the conflict test. + +A graph built by calling the same functions with the same arguments is +coherent, however many paths reach a node. Two declarations of one 'Ref' that +differ in their description or in their predecessors have different tops, are +both walked, and are still merged (edges) and reported (conflict) as before. + +The conflict test is assumed to be an equivalence. 'sameRepresentative' is. + += What is the same as walking every occurrence, on a coherent expansion + +* 'dagNodes' has the same keys, and each representative is one the conflict + test cannot tell from the last occurrence in the tree (last writer wins, + in the order of the tree, not in the order of this walk). +* 'dagDependencies' and 'dagDependants' are equal, order included, and so is + 'dagOrder'. +* The same 'Ref's are contested, by the same declarations. + += What is not the same + +* __Conflicts are one per declaration that lost__, not one per change of + representative. Walking every occurrence used to record a 'Conflict' each + time the representative flipped, so a node and a differing declaration of + it under a parent reached by @k@ paths gave @2k - 1@ of them. Now each + contested 'Ref' with @n@ distinguishable declarations gives @n - 1@: the + final representative as 'conflictKept', against each of the others as + 'conflictReplaced'. With two declarations that is the last flip the old + walk recorded; with three or more, the old chain of flips (@b@ over @a@, + @c@ over @b@) reads @c@ over @a@, @c@ over @b@. +* __On an expansion that is not coherent, what differs below two occurrences + with the same top is not seen.__ The standard example: a unit declared + twice with the same description, each over a file with the same path, the + two files differing in content. The second unit is not walked, so the + second file is never met: no 'Conflict' is recorded, and the first file is + the representative where the last used to be. Nodes and edges that only + exist below such an occurrence are missed in the same way. A difference in + the description of the upper node (or in its predecessor 'Ref's) is enough + to have both walked. +* With a conflict test that cannot tell two declarations apart (@\\_ _ -> + True@ in particular), which of them is the representative is unspecified: + that is what the test said. + +The first argument decides whether two acts are the same node: 'True' records +no 'Conflict'. Pass 'sameRepresentative' unless you have something better; +pass @\\_ _ -> True@ to opt out of conflict detection entirely, at the price +of occurrences being told apart by 'Ref' and predecessors alone. + +The expansion is only forced where it is walked, so over a lazily built one +(@Identity@, as 'Salmon.Builtin.Extension.evalDeps' builds) the skipped +occurrences are never built at all. An expansion built in a strict monad has +been paid for per path before this is called. -} foldDag :: forall m ext. @@ -230,44 +356,183 @@ (Act ext -> Act ext -> Bool) -> Cofree Graph (OpGraph m (Actions ext)) -> Dag ext -foldDag same = go emptyDag +foldDag same root + | Map.null contested = folded + | otherwise = + folded + { dagNodes = Map.foldlWithKey' (\nodes r (winner, _) -> Map.insert r winner nodes) (dagNodes folded) verdicts + , dagConflicts = + reverse + [ Conflict r winner loser + | r <- dagOrder folded + , Just (winner, losers) <- [Map.lookup r verdicts] + , loser <- losers + ] + } where - go :: - Dag ext -> - Cofree Graph (OpGraph m (Actions ext)) -> - Dag ext - go dag (x :< g) = + walked :: Walk ext + walked = forward (Walk (building emptyDag) Map.empty) root + + folded :: Dag ext + folded = built (walkDag walked) + + variants :: Map Ref [Act ext] + variants = Map.map (fmap fst) (walkMet walked) + + -- the refs declared in more than one distinguishable way. + contested :: Map Ref [Act ext] + contested = Map.filter (\declared -> length declared > 1) variants + + -- for each contested ref, the declaration that is last in the tree and + -- the ones it beat, in first-met order. + verdicts :: Map Ref (Act ext, [Act ext]) + verdicts = Map.intersectionWith verdict contested (lastWriters same variants contested root) + + verdict :: [Act ext] -> Int -> (Act ext, [Act ext]) + verdict declared winner = + ( declared !! winner + , [v | (i, v) <- zip [0 ..] declared, i /= winner] + ) + + -- Depth first, predecessors in order, as the walk of every occurrence + -- was: on a coherent expansion a skipped occurrence would have recorded + -- nothing new, so what is recorded, and in which order, is unchanged. + forward :: Walk ext -> Cofree Graph (OpGraph m (Actions ext)) -> Walk ext + forward w (x :< g) = case x.node of - Actionless -> foldl' go dag (effPreds g) + Actionless -> foldl' forward w (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 + in case meet same act predRefs (Map.findWithDefault [] aref (walkMet w)) of + Nothing -> w + Just met -> + foldl' + forward + Walk + { -- only for the edges and the order: the + -- representative and the conflicts of + -- a contested ref are settled at the end. + walkDag = recordInto (\_ _ -> True) aref act predRefs (walkDag w) + , walkMet = Map.insert aref met (walkMet w) + } + 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') = +data Walk ext = Walk + { walkDag :: !(Building ext) + , walkMet :: !(Map Ref [(Act ext, [[Ref]])]) + -- ^ The tops walked, by 'Ref': the declarations of it the conflict test + -- tells apart, in first-met order, each with the predecessor lists it + -- was met with. One declaration with one list, almost always. + } + +-- | A top among those met for its 'Ref': 'Nothing' if it was walked already, +-- otherwise the tops with it added. +meet :: + forall ext. + (Act ext -> Act ext -> Bool) -> + Act ext -> + [Ref] -> + [(Act ext, [[Ref]])] -> + Maybe [(Act ext, [[Ref]])] +meet same act predRefs = go + where + go :: [(Act ext, [[Ref]])] -> Maybe [(Act ext, [[Ref]])] + go [] = Just [(act, [predRefs])] + go ((v, walked) : rest) + | same v act = if predRefs `elem` walked then Nothing else Just ((v, predRefs : walked) : rest) + | otherwise = fmap ((v, walked) :) (go rest) + +-- | What an occurrence is recognised by: its 'Ref', which of the +-- distinguishable declarations of that 'Ref' it is (by position, first met +-- first), and the 'Ref's it depends on. +type Top = (Ref, Int, [Ref]) + +-- | Which known declaration an act is, as far as the test can tell. +variantOf :: forall ext. (Act ext -> Act ext -> Bool) -> [Act ext] -> Act ext -> Maybe Int +variantOf same known act = go 0 known + where + go :: Int -> [Act ext] -> Maybe Int + go _ [] = Nothing + go i (v : vs) + | same v act = Just i + | otherwise = go (i + 1) vs + +{- | For each contested 'Ref', which of its declarations is the last +occurrence in the tree: the one walking every occurrence would have ended on. + +The forward walk cannot say: it skips occurrences, and the last one in the +tree may sit below a skipped one. So this walks the tree backwards (a node's +predecessors last to first, then the node), where the first occurrence met +of a 'Ref' is its last in the tree, and skips an occurrence whose top was +already walked for the same reason the forward walk does: on a coherent +expansion everything below it has been met. It stops as soon as every +contested 'Ref' is settled, and is not run at all when nothing is contested. +-} +lastWriters :: + forall m ext a. + (HasField "ref" ext Ref) => + (Act ext -> Act ext -> Bool) -> + Map Ref [Act ext] -> + Map Ref a -> + Cofree Graph (OpGraph m (Actions ext)) -> + Map Ref Int +lastWriters same variants contested root = snd (backward (Set.empty, Map.empty) root) + where + backward :: (Set Top, Map Ref Int) -> Cofree Graph (OpGraph m (Actions ext)) -> (Set Top, Map Ref Int) + backward acc@(tops, found) (x :< g) + | Map.size found == Map.size contested = acc + | otherwise = case x.node of - Actions _ -> [c] - Actionless -> effPreds g' + Actionless -> foldl' backward acc (reverse (effPreds g)) + Actions act -> + let aref = getField @"ref" act.extension + preds = effPreds g + predRefs = nubOrd [pr | p <- preds, Just pr <- [refOf p]] + -- always found: the forward walk classified this + -- occurrence, or one with the same top. + variant = fromMaybe 0 (variantOf same (Map.findWithDefault [] aref variants) act) + top = (aref, variant, predRefs) + in if Set.member top tops + then acc + else + let (tops', found') = foldl' backward (tops, found) (reverse preds) + found'' + | Map.member aref contested = Map.insertWith (\_ earlier -> earlier) aref variant found' + | otherwise = found' + in (Set.insert top tops', found'') - refOf :: Cofree Graph (OpGraph m (Actions ext)) -> Maybe Ref - refOf (x :< _) = +-- | 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 act -> Just (getField @"ref" act.extension) - Actionless -> Nothing + Actions _ -> [c] + Actionless -> effPreds g' +refOf :: (HasField "ref" ext Ref) => 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. + +One call costs the edge lists it touches (the node's own and each +dependency's dependants), once each. The functions here that record many +nodes in a row ('foldDag', 'mergeDag', 'fromMagma') do not go through this +one: they keep a 'Building' across the whole run, so a node gaining many +edges over many calls pays for each edge once rather than for its whole list +every time. -} record :: (Act ext -> Act ext -> Bool) -> @@ -276,15 +541,101 @@ [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' +record same aref act predRefs dag = built (recordInto same aref act predRefs (building dag)) + +{- | A 'Dag' being built by a run of 'record's. + +'dagDependencies' and 'dagDependants' are lists in first-seen order without +repeats. Adding an edge to such a list means asking whether it is there and +putting it at the end, both a walk of the list, so a node gaining @k@ edges +one at a time costs @k^2@ (the profiles' finding 3: a fan of 10 000 took +1.3 s to fold). While building, an edge list that has been touched is kept +as an 'Edges' instead, which answers both in @log k@; lists nobody touched +stay where they are in the 'Dag', so building on a large 'Dag' costs what is +touched, not the 'Dag'. 'built' turns the touched ones back into lists, +which are the same lists, in the same order, that appending one at a time +gives. + +Invariant: a key of either overlay is a key of the matching map of the +finished 'Dag' (it takes precedence over the 'Dag''s own entry, if any). +-} +data Building ext = Building + { buildingDag :: !(Dag ext) + -- ^ nodes, order and conflicts are current; of the two edge maps, only + -- the entries absent from the overlays below are. + , buildingDependencies :: !(Map Ref Edges) + , buildingDependants :: !(Map Ref Edges) + } + +-- | One edge list while building: its members, and the list itself reversed. +data Edges = Edges !(Set Ref) ![Ref] + +noEdges :: Edges +noEdges = Edges Set.empty [] + +edgesFromList :: [Ref] -> Edges +edgesFromList xs = Edges (Set.fromList xs) (reverse xs) + +edgesToList :: Edges -> [Ref] +edgesToList (Edges _ rev) = reverse rev + +-- | Add at the end unless already present: what @old <> [new]@ after an +-- @elem@ test did. +snocEdge :: Ref -> Edges -> Edges +snocEdge r e@(Edges members rev) + | Set.member r members = e + | otherwise = Edges (Set.insert r members) (r : rev) + +building :: Dag ext -> Building ext +building dag = Building dag Map.empty Map.empty + +built :: Building ext -> Dag ext +built b = + (buildingDag b) + { dagDependencies = settle (buildingDependencies b) (dagDependencies (buildingDag b)) + , dagDependants = settle (buildingDependants b) (dagDependants (buildingDag b)) } where + settle overlay base + | Map.null overlay = base + | otherwise = Map.union (Map.map edgesToList overlay) base + +-- | The edge list at a key, as an 'Edges', from the overlay or the 'Dag'. +edgesAt :: Map Ref Edges -> Map Ref [Ref] -> Ref -> Edges +edgesAt overlay base r = + case Map.lookup r overlay of + Just e -> e + Nothing -> maybe noEdges edgesFromList (Map.lookup r base) + +-- | Make @r@ a key, with no edges unless it has some. +ensureKey :: Map Ref [Ref] -> Ref -> Map Ref Edges -> Map Ref Edges +ensureKey base r overlay + | Map.member r overlay || Map.member r base = overlay + | otherwise = Map.insert r noEdges overlay + +-- | 'record', on a 'Building'. +recordInto :: + (Act ext -> Act ext -> Bool) -> + Ref -> + Act ext -> + [Ref] -> + Building ext -> + Building ext +recordInto same aref act predRefs (Building dag depsOverlay dependantsOverlay) = + Building + { buildingDag = + dag + { dagNodes = Map.insert aref act (dagNodes dag) + , dagOrderRev = order' + , dagConflicts = conflicts' + } + , buildingDependencies = deps' + , buildingDependants = dependants' + } + where + baseDeps = dagDependencies dag + baseDependants = dagDependants dag + previous = Map.lookup aref (dagNodes dag) conflicts' @@ -296,18 +647,20 @@ | 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 + -- every node is a key of both maps, even with no edges either way, and + -- so is every dependency, before it is recorded itself. The node's own + -- list is read once and extended in order; a dependency equal to the + -- node (a self-edge) lands in that same list, as it did. + deps' = + let withKeys = foldl' (flip (ensureKey baseDeps)) depsOverlay predRefs + own = foldl' (flip snocEdge) (edgesAt withKeys baseDeps aref) predRefs + in Map.insert aref own withKeys - -- 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 + dependants' = + foldl' + (\m d -> Map.insert d (snocEdge aref (edgesAt m baseDependants d)) m) + (ensureKey baseDependants aref dependantsOverlay) + predRefs {- | 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 @@ -320,20 +673,22 @@ 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) +fromMagma magma edges = built (Map.foldlWithKey' add (building emptyDag) 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 + add b r act = recordInto (\_ _ -> True) r act (deps r) b deps :: Ref -> [Ref] deps r = Map.findWithDefault [] r incoming + -- each list in edge-set order: built by consing (what 'Map.fromListWith' + -- does with '(<>)' on singletons) and reversed once, rather than by + -- appending on the right, which costs a node's whole list per edge. incoming :: Map Ref [Ref] incoming = - Map.fromListWith - (flip (<>)) + Map.map reverse . Map.fromListWith (<>) $ [ (dependant, [dependency]) | (dependency, dependant) <- Set.toList edges , Map.member dependency magma @@ -360,8 +715,8 @@ | otherwise = Dag { dagNodes = Map.insert into act survivors - , dagDependencies = Map.map (nubOrd . fmap rename) keptDeps - , dagDependants = transposeOf (Map.map (nubOrd . fmap rename) keptDeps) + , dagDependencies = renamedDeps + , dagDependants = transposeOf renamedDeps , dagOrderRev = reverse order' , dagConflicts = dagConflicts dag } @@ -371,6 +726,8 @@ rename r = if Set.member r present then into else r + renamedDeps = Map.map (nubOrd . fmap rename) keptDeps + -- every surviving node's dependencies, with members renamed and the -- resulting self-edges dropped; the replacement inherits the union of its -- members' own dependencies. @@ -411,10 +768,14 @@ -- | 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. +-- +-- Each dependant list is in key order of the dependants (with a repeat for a +-- dependency listed twice): consed and reversed once, not appended on the +-- right, which cost a node's whole list per edge. 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 reverse (Map.fromListWith (<>) [(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 @@ -422,12 +783,12 @@ running world. -} mergeDag :: (Act ext -> Act ext -> Bool) -> Dag ext -> Dag ext -> Dag ext -mergeDag same into from = foldl' step into (dagOrder from) +mergeDag same into from = built (foldl' step (building into) (dagOrder from)) where - step dag r = + step b r = case representativeOf from r of - Nothing -> dag - Just act -> record same r act (dependenciesOf from r) dag + Nothing -> b + Just act -> recordInto same r act (dependenciesOf from r) b ------------------------------------------------------------------------------- @@ -459,7 +820,13 @@ dynamics, whose identity 'foldDag' does not need to track this way). -} showDynamic :: Dynamic -> String -showDynamic d = maybe (show d) show (fromDynamic d :: Maybe Supervision) +showDynamic d = + case (fromDynamic d :: Maybe Supervision, fromDynamic d :: Maybe Guard) of + (Just s, _) -> show s + -- likewise by value: a guarded node whose hold set changed is a + -- different node to tend. See "Salmon.Op.Guard". + (_, Just g) -> show g + _ -> show d representative :: ( HasField "help" ext Text @@ -473,7 +840,9 @@ { repShorthand = act.shorthand , repHelp = getField @"help" act.extension , repNotes = getField @"notes" act.extension - , repDynamics = fmap showDynamic (getField @"dynamics" act.extension) + , -- a node's card template is presentation only, and left out: see + -- "Salmon.Op.CardTemplate" + repDynamics = fmap showDynamic (filter (not . isCardTemplate) (getField @"dynamics" act.extension)) } -- | The default conflict test for 'foldDag': equality on 'Representative'. diff --git a/src/Salmon/Op/Guard.hs b/src/Salmon/Op/Guard.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Op/Guard.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | What a node that cannot be undone says about itself: the marker a driver +reads, and the two values its preconditions speak in. + +The pattern itself (what goes in @check@, what goes in @up@, which +'Salmon.Op.Supervision.Supervision' it gets) is assembled by +"Salmon.Builtin.Guarded". This module is only the part the drivers and +"Salmon.Op.Dag" have to see, kept free of +'Salmon.Builtin.Extension.Extension' so that they can. + +It rides @dynamics@ for the reason "Salmon.Op.Supervision" gives: nothing +changes for the many nodes with no opinion. +-} +module Salmon.Op.Guard ( + -- * Preconditions + Precondition (..), + PreconditionUnmet (..), + + -- * The marker + Guard (..), + guardOf, + isGuarded, +) where + +import Control.Exception (Exception (..)) +import Data.Dynamic (Dynamic, fromDynamic) +import Data.Maybe (isJust, listToMaybe, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Records (HasField, getField) + +import Salmon.Op.Ref (Ref) + +{- | Whether a risky operation may start now. The text is public (it ends up +in reports), so it says which condition is unmet and never quotes a secret. +-} +data Precondition + = Met + | Unmet !Text + deriving (Show, Eq, Ord) + +{- | What a guarded node's @up@ throws when its preconditions are unmet at the +moment it is asked to act. + +A type of its own so that a driver can tell "refused to start" from "started +and failed": the first is not a failure of the operation and must not count +toward giving up on it. See "Salmon.Actions.Upkeep". +-} +newtype PreconditionUnmet = PreconditionUnmet Text + deriving (Show, Eq) + +instance Exception PreconditionUnmet where + displayException (PreconditionUnmet why) = + "guarded operation not started, precondition unmet: " <> Text.unpack why + +{- | The marker a guarded node carries. + +'guardHolds' is the hold set: the nodes that must stand still while this +one's @up@ runs. It is explicit, and not read off the dependency graph, on +purpose. An edge already keeps a /dependant/ from being brought up before +this node is, but it says nothing to a node that is already up: that node's +machine keeps checking its effect and puts it back when it goes away, which +is exactly the interference a restart or an upgrade of its neighbour causes. +And the nodes to hold are usually not dependants at all (the other members +of a cluster). + +Rendered by value in "Salmon.Op.Dag" (@showDynamic@), so a re-declaration +that only changes the hold set is a changed representative. +-} +newtype Guard = Guard + { guardHolds :: [Ref] + } + deriving (Show, Eq) + +-- | The first 'Guard' a node declared, if any. +guardOf :: (HasField "dynamics" ext [Dynamic]) => ext -> Maybe Guard +guardOf ext = listToMaybe (mapMaybe cast (getField @"dynamics" ext)) + where + cast :: Dynamic -> Maybe Guard + cast = fromDynamic + +isGuarded :: (HasField "dynamics" ext [Dynamic]) => ext -> Bool +isGuarded = isJust . guardOf diff --git a/src/Salmon/Op/Window.hs b/src/Salmon/Op/Window.hs --- a/src/Salmon/Op/Window.hs +++ b/src/Salmon/Op/Window.hs @@ -19,6 +19,15 @@ 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. +@run serve@ and "Salmon.Actions.Upkeep" take the same windows as a 'Windows' +policy and ask 'holdOf' instead: a convergence pass skips a held node without +recording it converged, and a tended node outside every window waits for the +next opening instead of running its @up@ (its check is still asked: a node +whose effect is already in place has nothing to hold back). Only bringing a +node up is held; a teardown is not, under any driver. An @up@ already running +when a window closes is never interrupted: the windows are asked before an +@up@ starts, never during one. + 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. @@ -39,6 +48,14 @@ -- * The gate windowGate, windowGateAt, + + -- * A policy the long-running drivers consult + Windows (..), + noWindows, + windowsAt, + Hold (..), + holdOf, + renderHold, ) where import Data.Dynamic (Dynamic, fromDynamic, toDyn) @@ -59,6 +76,7 @@ import Text.Read (readMaybe) import Salmon.Actions.UpDown (Gate, Requirement (..)) +import Salmon.Op.Supervision (Micros, seconds) import Salmon.Op.Actions (Act (..)) import Salmon.Builtin.Extension (Extension) import qualified Salmon.Builtin.Extension as Extension @@ -215,4 +233,54 @@ if inAnyWindow ws now then pure Required else onHeld act (nextOpening ws now) >> pure Skippable + +{- | The windows of one invocation, as the long-running drivers (@run serve@ +and "Salmon.Actions.Upkeep") consult them: not a 'Gate' asked once per pass +but a question asked again whenever a held node wakes. + +'windowsClock' is the wall clock in production and a test's own clock +otherwise. 'windowsRecheck' is the longest a held node sleeps before asking +the clock again, so a clock that jumps (a suspended host, an NTP step) is +noticed within it rather than at an opening computed before the jump. +-} +data Windows = Windows + { windowsSpans :: [Window] + -- ^ empty: nothing is ever held + , windowsClock :: IO UTCTime + , windowsRecheck :: Micros + } + +-- | No windows: every node runs whenever it is due, as before windows existed. +noWindows :: Windows +noWindows = windowsAt [] + +-- | These windows, on the wall clock, asked again at least once a minute. +windowsAt :: [Window] -> Windows +windowsAt ws = Windows ws getCurrentTime (seconds 60) + +-- | Whether a node may act now. +data Hold + = -- | not disruptive, no windows, or a window is open + Free + | -- | held; the next window opens then ('Nothing' only if none ever does) + HeldUntil !(Maybe UTCTime) + deriving (Show, Eq) + +{- | Ask the windows about one node. A node not marked 'disruptive' is +'Free' without the clock being read. +-} +holdOf :: (HasField "dynamics" ext [Dynamic]) => Windows -> ext -> IO Hold +holdOf ws ext + | null ws.windowsSpans = pure Free + | not (isDisruptive ext) = pure Free + | otherwise = do + now <- ws.windowsClock + pure $ + if inAnyWindow ws.windowsSpans now + then Free + else HeldUntil (nextOpening ws.windowsSpans now) + +-- | @until 2026-10-17 02:00:00 UTC@, or @until (never)@. +renderHold :: Maybe UTCTime -> Text +renderHold next = "until " <> maybe "(never)" (Text.pack . show) next diff --git a/src/Salmon/Reporter/Tagged.hs b/src/Salmon/Reporter/Tagged.hs --- a/src/Salmon/Reporter/Tagged.hs +++ b/src/Salmon/Reporter/Tagged.hs @@ -43,10 +43,13 @@ updownStream, upkeepStream, followStream, + nodeLogStream, + taggedNode, -- * Reporters reportJSONLines, reportTexts, + reportNodeLogText, -- * Encoding pieces refValue, @@ -70,6 +73,7 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.IO as Text import System.IO (Handle, hFlush) import qualified Salmon.Actions.Follow as Follow @@ -78,6 +82,7 @@ import qualified Salmon.Actions.UpDown as UpDown import qualified Salmon.Actions.Upkeep as Upkeep import Salmon.Builtin.Extension (Extension (..)) +import qualified Salmon.Builtin.NodeLog as NodeLog import Salmon.Op.Actions (Act (..)) import qualified Salmon.Op.Mailbox as Mailbox import qualified Salmon.Op.Dag as Dag @@ -94,6 +99,11 @@ | FromUpDown !(UpDown.Report Extension) | FromUpkeep !(Upkeep.Report Extension) | FromFollow !Follow.Report + | {- | A line a node said while working ("Salmon.Builtin.NodeLog"): not a + fifth vocabulary of what a driver did but what the node itself has to + say, so it is filed on the @output@ stream beside 'Upkeep.Output'. + -} + FromNode !NodeLog.Line deriving (Show) serveStream :: Reporter Tagged -> Reporter Serve.Report @@ -108,6 +118,64 @@ followStream :: Reporter Tagged -> Reporter Follow.Report followStream = contramap FromFollow +nodeLogStream :: Reporter Tagged -> Reporter NodeLog.Line +nodeLogStream = contramap FromNode + +{- | The one node a report is about, when there is one: the @ref@ its object +carries at the top level or, for a report nesting another ('Upkeep.Acted', +'Serve.Tended'), the nested one's. What a per-node tail is keyed by +("Salmon.Actions.Serve.Events"), so a client seeded from it sees the same +lines a live tail of that node would have shown. @Test/ReportJsonSpec.hs@ +checks it against the encoding of every golden. +-} +taggedNode :: Tagged -> Maybe Ref +taggedNode tagged = case tagged of + FromServe (Serve.Tended inner) -> upkeepNode inner + FromServe _ -> Nothing + FromUpDown rep -> updownNode rep + FromUpkeep rep -> upkeepNode rep + FromFollow _ -> Nothing + FromNode line -> Just line.lineRef + where + updownNode :: UpDown.Report Extension -> Maybe Ref + updownNode rep = case rep of + UpDown.Skip act -> about act + UpDown.Eval act -> about act + UpDown.Done act -> about act + UpDown.Failed act _ -> about act + UpDown.Blocked act -> about act + UpDown.Conflicting r _ _ -> Just r + UpDown.Instructed act _ -> about act + UpDown.DroppedInstructions act _ -> about act + + upkeepNode :: Upkeep.Report Extension -> Maybe Ref + upkeepNode rep = case rep of + Upkeep.Acted inner -> updownNode inner + Upkeep.Upkeep act _ -> about act + Upkeep.Downkeep act _ -> about act + Upkeep.NextLook act _ _ -> about act + Upkeep.Wedged act _ -> about act + Upkeep.Unwedged act -> about act + Upkeep.Output act _ -> about act + Upkeep.Demoted act _ -> about act + Upkeep.Parked act -> about act + Upkeep.Reapplying act _ -> about act + Upkeep.Held act _ -> about act + Upkeep.Paused act -> about act + Upkeep.Resumed act -> about act + Upkeep.GaveUp act _ -> about act + Upkeep.Adopted act -> about act + Upkeep.Released act -> about act + Upkeep.Policy act _ _ -> about act + Upkeep.Untended act -> about act + Upkeep.Escaped act _ -> about act + Upkeep.Supervising _ _ -> Nothing + Upkeep.Retired _ -> Nothing + Upkeep.Holding _ -> Nothing + + about :: Act Extension -> Maybe Ref + about act = Just act.extension.ref + {- | 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. @@ -117,14 +185,33 @@ Reporter (UpDown.Report Extension) -> Reporter (Upkeep.Report Extension) -> Reporter Follow.Report -> + Reporter NodeLog.Line -> Reporter Tagged -reportTexts serveR updownR upkeepR followR = ReporterM $ \tagged -> +reportTexts serveR updownR upkeepR followR nodeR = 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 + FromNode line -> runReporter nodeR line +{- | A node's line as text: the node's short ref, the channel, the line. One +write per line, so lines from two nodes working at once do not interleave +inside one another. +-} +reportNodeLogText :: Handle -> Reporter NodeLog.Line +reportNodeLogText h = ReporterM $ \line -> + Text.hPutStrLn h (renderNodeLogLine line) + +renderNodeLogLine :: NodeLog.Line -> Text +renderNodeLogLine line = + mconcat [" [", shortRef line.lineRef, "] ", channel, "| ", line.lineText] + where + channel = case line.lineChannel of + NodeLog.Stdout -> "out" + NodeLog.Stderr -> "err" + NodeLog.Message -> "msg" + {- | 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 @@ -150,6 +237,7 @@ FromUpkeep rep@(Upkeep.Output _ _) -> withOrigin "output" (toJSON rep) FromUpkeep rep -> withOrigin "upkeep" (toJSON rep) FromFollow rep -> withOrigin "follow" (toJSON rep) + FromNode line -> withOrigin "output" (toJSON line) where withOrigin :: Text -> Value -> Value withOrigin origin (Object o) = Object (KeyMap.insert "stream" (String origin) o) @@ -263,6 +351,21 @@ ------------------------------------------------------------------------------- +{- | @{kind: "log", ref, channel, line}@. No @node@: a line is said many +times a second and names its node by @ref@ alone, which is what a client +tailing it already holds. +-} +instance ToJSON NodeLog.Line where + toJSON line = + object + [ kind "log" + , "ref" .= refValue line.lineRef + , "channel" .= NodeLog.renderChannel line.lineChannel + , "line" .= line.lineText + ] + +------------------------------------------------------------------------------- + instance ToJSON (UpDown.Report Extension) where toJSON rep = object $ case rep of @@ -296,6 +399,7 @@ 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.Held act next -> kind "held" : actPairs act ++ ["until" .= next] 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] @@ -418,6 +522,8 @@ , "status" .= fmap statusValue st.nodeStatus , "paths" .= Map.findWithDefault [] r paths ] + -- only while held, so a node that is not reads exactly as before + ++ maybe [] (\next -> ["held_until" .= next]) st.nodeHeld ++ case selection of Nothing -> [] Just (sel, exc) -> diff --git a/src/Salmon/Reporter/UpDownText.hs b/src/Salmon/Reporter/UpDownText.hs new file mode 100644 --- /dev/null +++ b/src/Salmon/Reporter/UpDownText.hs @@ -0,0 +1,119 @@ +{- | A readable text reporter for @run up@\/@run down@: one line per +'UpDown.Report', where 'Salmon.Reporter.reportPrint' prints the derived +'Show' of the report and of its 'Act' (a long record per report). + +A line is the report's kind (the same word as its @kind@ in the JSON +encoding of "Salmon.Reporter.Tagged"), the node's 'shortRef' prefixed with +@#@ (what a @--select \#...@ selector matches), and the node's shorthand and +help: + +> eval #MTA4NDYx file: write /etc/motd +> done #MTA4NDYx file: write /etc/motd +> failed #MTA4NDYx file: write /etc/motd -- user error (exit 1) + +Everything printed (shorthand, help, the failure text) is already public +report text (see CLAUDE.md, "Secrets"). Newlines and carriage returns inside +those (any control character but a tab) are escaped as @\\n@\/@\\r@\/... so that each report is exactly one line. + +This is an opt-in: 'Salmon.Reporter.reportPrint' is unchanged, so a binary +that passes it prints what it always printed. @--json@ remains the +machine-readable form; this one is for people and is not a format to parse. +-} +module Salmon.Reporter.UpDownText ( + reportText, + reportHText, + renderReport, + renderKind, +) where + +import Control.Exception (SomeException) +import Data.Char (isControl, showLitChar) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import System.IO (Handle, hFlush, stdout) + +import qualified Salmon.Actions.UpDown as UpDown +import Salmon.Builtin.Extension (Extension (..)) +import Salmon.Op.Actions (Act (..)) +import qualified Salmon.Op.Mailbox as Mailbox +import Salmon.Op.Ref (Ref, shortRef) +import Salmon.Reporter (Reporter, ReporterM (..)) + +-- | 'reportHText' on standard output. +reportText :: Reporter (UpDown.Report Extension) +reportText = reportHText stdout + +{- | One 'renderReport' line per report, written in one call and flushed, so +that a report is never split by another thread writing to the same handle. +-} +reportHText :: Handle -> Reporter (UpDown.Report Extension) +reportHText h = ReporterM $ \rep -> do + Text.hPutStr h (renderReport rep <> "\n") + hFlush h + +-- | The report as one line, without its trailing newline. +renderReport :: UpDown.Report Extension -> Text +renderReport rep = + case rep of + UpDown.Skip act -> about act [] + UpDown.Eval act -> about act [] + UpDown.Done act -> about act [] + UpDown.Failed act e -> about act [exceptionText e] + UpDown.Blocked act -> about act [] + UpDown.Conflicting r kept replaced -> + line r ["kept", node kept <> ";", "replaced", node replaced] + UpDown.Instructed act instr -> about act [instructionText instr] + UpDown.DroppedInstructions act n -> about act [tshow n <> " dropped"] + where + about :: Act Extension -> [Text] -> Text + about act extra = + line act.extension.ref (node act : concatMap (\x -> ["--", x]) extra) + + line :: Ref -> [Text] -> Text + line r rest = Text.unwords (Text.justifyLeft 7 ' ' (renderKind rep) : ("#" <> shortRef r) : rest) + + node :: Act Extension -> Text + node act = oneLine act.shorthand <> ": " <> oneLine act.extension.help + +{- | The report's kind: the word "Salmon.Reporter.Tagged" puts in the @kind@ +field of the same report's JSON object. +-} +renderKind :: UpDown.Report ext -> Text +renderKind rep = + case rep of + UpDown.Skip _ -> "skip" + UpDown.Eval _ -> "eval" + UpDown.Done _ -> "done" + UpDown.Failed _ _ -> "failed" + UpDown.Blocked _ -> "blocked" + UpDown.Conflicting{} -> "conflicting" + UpDown.Instructed _ _ -> "instructed" + UpDown.DroppedInstructions _ _ -> "dropped-instructions" + +-- | As "Salmon.Reporter.Tagged" renders a failure: the exception's 'show'. +exceptionText :: SomeException -> Text +exceptionText = oneLine . Text.pack . show + +instructionText :: Mailbox.Instruction -> Text +instructionText instr = + case instr of + Mailbox.Force -> "force" + Mailbox.Satisfy -> "satisfy" + Mailbox.Recheck -> "recheck" + Mailbox.Pause -> "pause" + Mailbox.Resume -> "resume" + +{- | Escape what would break the line, so one report stays one line: every +control character but a tab, as Haskell writes it in a string literal +(@\\n@, @\\r@, @\\ESC@, ...). +-} +oneLine :: Text -> Text +oneLine = Text.concatMap escape + where + escape c + | isControl c && c /= '\t' = Text.pack (showLitChar c "") + | otherwise = Text.singleton c + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show diff --git a/ui-test/card-template.test.mjs b/ui-test/card-template.test.mjs new file mode 100644 --- /dev/null +++ b/ui-test/card-template.test.mjs @@ -0,0 +1,245 @@ +// The card-template contract (ui/card-template.js) against the vendored +// tramaj-js, under node: unit cases and seeded random properties. +// Run: node salmon-ops/ui-test/card-template.test.mjs +// (Test/UiTailTemplateSpec.hs runs it when `node` is on PATH.) +// SALMON_UI_TEST_SEED fixes the properties' seed; it is printed either way. + +import { test } from "node:test"; +import assert from "node:assert/strict"; + +const ct = await import(new URL("../ui/card-template.js", import.meta.url)); +const tt = await import(new URL("../ui/tail-template.js", import.meta.url)); +const tramaj = await import(new URL("../ui/vendor/tramaj-js/index.js", import.meta.url)); + +const SEED = Number(process.env.SALMON_UI_TEST_SEED ?? Math.floor(Math.random() * 2 ** 31)); +console.log(`# SALMON_UI_TEST_SEED=${SEED}`); +const CASES = 200; + +function rng(seed) { + let a = seed >>> 0; + return () => { + a = (a + 0x6d2b79f5) >>> 0; + let t = a; + t = Math.imul(t ^ (t >>> 15), t | 1); + t ^= t + Math.imul(t ^ (t >>> 7), t | 61); + return ((t ^ (t >>> 14)) >>> 0) / 4294967296; + }; +} +const R = rng(SEED); +const int = (n) => Math.floor(R() * n); +const pick = (xs) => xs[int(xs.length)]; +const ALPHABET = ["a", "Z", "0", " ", "\t", "<", ">", "&", '"', "'", "{", "}", "=", ":", "-", "é", "日", "\\", "`", "$", "."]; +const randomText = (max = 30) => Array.from({ length: int(max) }, () => pick(ALPHABET)).join(""); +const maybe = (f) => (int(3) === 0 ? undefined : f()); +const refOf = () => ({ full: "f".repeat(8) + randomText(8), short: randomText(8) }); + +const KEYS = [ + "check", + "conflict", + "convergence", + "dependants", + "dependencies", + "direction", + "dynamics", + "help", + "last", + "lastReason", + "machine", + "notes", + "output", + "paths", + "ref", + "shorthand", +].sort(); + +// a node as ui.js keeps it: /dag's object plus the live overlay, any of it missing +function randomNode() { + return { + ref: maybe(refOf), + shorthand: maybe(() => randomText()), + help: maybe(() => randomText()), + notes: maybe(() => Array.from({ length: int(3) }, () => randomText())), + dynamics: maybe(() => Array.from({ length: int(2) }, () => randomText())), + direction: maybe(() => pick(["up", "down"])), + convergence: maybe(() => pick(["pending", "converged", "stale", "errored", "blocked"])), + paths: maybe(() => Array.from({ length: int(3) }, () => randomText())), + dependencies: maybe(() => Array.from({ length: int(3) }, refOf)), + dependants: maybe(() => Array.from({ length: int(3) }, refOf)), + status: maybe(() => (int(2) ? null : { check: maybe(() => ({ verdict: pick(["success", "failure"]), reason: maybe(() => randomText()) })), output: maybe(() => [randomText()]) })), + conflict: maybe(() => ({ kept: {}, replaced: {} })), + machine: maybe(() => pick([null, "watching", "applying"])), + last: maybe(() => pick([null, "up-done"])), + lastReason: maybe(() => pick([null, randomText()])), + template: maybe(() => randomText()), + }; +} + +const node = { + ref: { full: "a".repeat(64), short: "aaaaaaaa" }, + shorthand: "file /tmp/x", + help: "a file", + notes: ["one", "two"], + dynamics: [], + direction: "up", + convergence: "converged", + status: { check: { verdict: "success", reason: null }, output: ["ok"] }, + paths: ["root/file /tmp/x"], + dependencies: [{ full: "b".repeat(64), short: "bbbbbbbb" }], + dependants: [], + machine: "watching", + last: null, + lastReason: null, + template: ".div($ctx.help)", +}; +const run = (src, n) => ct.foldCard(tramaj, tramaj.parseProgram(src), ct.cardContext(n)); + +test("the context carries every key, and only what /dag served", () => { + const ctx = ct.cardContext(node); + assert.deepEqual(Object.keys(ctx).sort(), KEYS); + assert.deepEqual(ctx.ref, { full: "a".repeat(64), short: "aaaaaaaa" }); + assert.deepEqual(ctx.dependencies, ["bbbbbbbb"]); + assert.deepEqual(ctx.check, { verdict: "success", reason: null }); + assert.equal(ctx.conflict, false); + assert.equal("template" in ctx, false, "the template does not see its own source"); + const bare = ct.cardContext({}); + assert.deepEqual(Object.keys(bare).sort(), KEYS); + assert.equal(bare.help, ""); + assert.deepEqual(bare.notes, []); + assert.deepEqual(bare.check, { verdict: null, reason: null }); + // a template reading any documented key evaluates on a bare node + for (const k of KEYS) assert.ok(!run(`str($ctx.${k})`, {}).error, k); + assert.ok(!run("str($ctx.ref.short)", {}).error); + assert.deepEqual(run('branch($ctx.check.verdict, eq($ctx.check.verdict, null), "never checked")', {}), { spec: "never checked" }); +}); + +test("a card draws block tags; class and title only, actions ignored", () => { + const r = run('.div(class: "t-ok", title: "t", style: "x", action("click", "k", {}), .h4($ctx.shorthand), .ul(map($ctx.notes, (x) => .li($x))))', node); + assert.deepEqual(r.spec, { + tag: "div", + cls: "t-ok", + title: "t", + children: [ + { tag: "h4", cls: null, title: null, children: ["file /tmp/x"] }, + { + tag: "ul", + cls: null, + title: null, + children: [ + { tag: "li", cls: null, title: null, children: ["one"] }, + { tag: "li", cls: null, title: null, children: ["two"] }, + ], + }, + ], + }); + const t = run('.table(.tr(.th("state"), .td($ctx.convergence)))', node); + assert.equal(tt.specText(t.spec), "stateconverged"); +}); + +test("null asks for the default card; a scalar is text", () => { + const p = 'branch(null, eq($ctx.convergence, "errored"), .p(class: "t-err", "broken"))'; + assert.deepEqual(run(p, node), { fallback: true }); + assert.deepEqual(run(p, { ...node, convergence: "errored" }), { spec: { tag: "p", cls: "t-err", title: null, children: ["broken"] } }); + assert.deepEqual(run("$ctx.help", node), { spec: "a file" }); +}); + +test("what is not drawn in a card is an error, never markup", () => { + for (const tag of ["script", "img", "iframe", "style", "form", "input", "object"]) { + assert.match(run(`.${tag}("x")`, node).error, /is not drawn in a card/, tag); + } + assert.match(run("$ctx.nope", node).error, /PathNotFound/); +}); + +test("a card's link keeps only an https href without credentials", () => { + const link = (href) => run(`.a(href: ${JSON.stringify(href)}, class: "c", "label")`, node).spec; + assert.deepEqual(link("https://console.cloud.google.com/storage/browser/b?project=p"), { + tag: "a", + cls: "c", + title: null, + href: "https://console.cloud.google.com/storage/browser/b?project=p", + children: ["label"], + }); + for (const bad of ["javascript:alert(1)", "JAVASCRIPT:alert(1)", " javascript:alert(1)", "data:text/html,x", "http://example.org/", "//example.org/x", "/dag", "x", "https://user:pw@example.org/", "https://user@example.org/", "vbscript:x", "file:///etc/passwd", ""]) { + const s = link(bad); + assert.equal(s.href, null, bad); + assert.equal(tt.specText(s), "label", bad); + } + // an href on any other tag is ignored, and only an `a` carries the key + assert.equal("href" in run('.span(href: "https://example.org/", "x")', node).spec, false); + assert.equal(run('.a("no href")', node).spec.href, null); + // a tail still draws no `a` + const ctx = tt.tailContext({ line: "x", text: "x" }, undefined); + assert.match(tt.foldLine(tramaj, tramaj.parseProgram('.a(href: "https://example.org/", "x")'), ctx).error, /is not drawn in a tail/); +}); + +test("property: safeHref keeps only https URLs, and keeps them as parsed", () => { + const SCHEMES = ["https://", "http://", "javascript:", "data:", "", "//", "HTTPS://", "ftp://"]; + for (let i = 0; i < CASES * 2; i++) { + const v = pick(SCHEMES) + pick(["", "u:p@", "u@"]) + randomText(12); + const h = ct.safeHref(v); + if (h !== null) { + const u = new URL(h); + assert.equal(u.protocol, "https:", v); + assert.equal(u.username + u.password, "", v); + assert.equal(ct.safeHref(h), h, "idempotent"); + } + } +}); + +test("the tail's allowlist is unchanged by the card's", () => { + const ctx = tt.tailContext({ line: "x", text: "x" }, undefined); + assert.match(tt.foldLine(tramaj, tramaj.parseProgram('.div("x")'), ctx).error, /is not drawn in a tail/); + for (const tag of tt.TEMPLATE_TAGS) assert.ok(ct.CARD_TAGS.has(tag), tag); + assert.ok(!tt.TEMPLATE_TAGS.has("div")); +}); + +test("property: every key is present and the context is plain JSON on any node", () => { + for (let i = 0; i < CASES; i++) { + const n = randomNode(); + const ctx = ct.cardContext(n); + assert.deepEqual(Object.keys(ctx).sort(), KEYS); + // no undefined anywhere: a JSON round-trip is the identity + assert.deepEqual(JSON.parse(JSON.stringify(ctx)), ctx); + assert.ok(["notes", "dynamics", "paths", "dependencies", "dependants", "output"].every((k) => Array.isArray(ctx[k]) && ctx[k].every((s) => typeof s === "string"))); + assert.equal(typeof ctx.help, "string"); + assert.equal(typeof ctx.conflict, "boolean"); + assert.equal("template" in ctx, false); + } +}); + +test("property: the help template shows the help unchanged, the notes in order", () => { + const help = tramaj.parseProgram(".p($ctx.help)"); + const notes = tramaj.parseProgram(".ul(map($ctx.notes, (x) => .li($x)))"); + for (let i = 0; i < CASES; i++) { + const n = { help: randomText(), notes: Array.from({ length: int(5) }, () => randomText()) }; + const ctx = ct.cardContext(n); + assert.equal(tt.specText(ct.foldCard(tramaj, help, ctx).spec), n.help); + assert.deepEqual(ct.foldCard(tramaj, notes, ctx).spec.children.map(tt.specText), n.notes); + } +}); + +// random normative Node JSON, allowed in a card and not +const TAGS = [...ct.CARD_TAGS, "script", "img", "iframe", "object"]; +function randomDoc(depth) { + const r = int(depth > 3 ? 2 : 4); + if (r === 0) return { type: "text", value: pick([randomText(8), 3, true, null]), annotations: {} }; + if (r === 1) return { type: "text", value: randomText(8), annotations: {} }; + if (r === 2) return { type: "fragment", children: Array.from({ length: int(3) }, () => randomDoc(depth + 1)), annotations: {} }; + const tag = int(10) === 0 ? pick(TAGS.slice(-4)) : pick(TAGS); + const attributes = Array.from({ length: int(3) }, () => ({ kind: "attribute", name: pick(["class", "title", "onclick", "href"]), value: randomText(5) })); + const children = tag === "br" || tag === "hr" ? [] : Array.from({ length: int(3) }, () => randomDoc(depth + 1)); + return { type: "element", tag, attributes, value: null, children, annotations: {} }; +} +const forbidden = (n) => (n.type === "element" && !ct.CARD_TAGS.has(n.tag)) || (n.children || []).some(forbidden); +const tags = (s) => (typeof s === "string" ? [] : [...(s.tag ? [s.tag] : []), ...s.children.flatMap(tags)]); + +test("property: a card document draws iff every tag is a card tag, and draws only card tags", () => { + for (let i = 0; i < CASES * 2; i++) { + const d = randomDoc(0); + if (forbidden(d)) { + assert.throws(() => tt.specOf(tramaj, d, ct.CARD_ALLOW), tt.TemplateError); + } else { + const s = tt.specOf(tramaj, d, ct.CARD_ALLOW); + assert.ok(tags(s).every((t) => ct.CARD_TAGS.has(t))); + } + } +}); diff --git a/ui-test/tail-template.test.mjs b/ui-test/tail-template.test.mjs new file mode 100644 --- /dev/null +++ b/ui-test/tail-template.test.mjs @@ -0,0 +1,169 @@ +// The tail-template contract (ui/tail-template.js) against the vendored +// tramaj-js, under node: unit cases and seeded random properties. +// Run: node salmon-ops/ui-test/tail-template.test.mjs +// (Test/UiTailTemplateSpec.hs runs it when `node` is on PATH.) +// SALMON_UI_TEST_SEED fixes the properties' seed; it is printed either way. + +import { test } from "node:test"; +import assert from "node:assert/strict"; + +const tt = await import(new URL("../ui/tail-template.js", import.meta.url)); +const tramaj = await import(new URL("../ui/vendor/tramaj-js/index.js", import.meta.url)); + +const SEED = Number(process.env.SALMON_UI_TEST_SEED ?? Math.floor(Math.random() * 2 ** 31)); +console.log(`# SALMON_UI_TEST_SEED=${SEED}`); +const CASES = 200; + +function rng(seed) { + let a = seed >>> 0; + return () => { + a = (a + 0x6d2b79f5) >>> 0; + let t = a; + t = Math.imul(t ^ (t >>> 15), t | 1); + t ^= t + Math.imul(t ^ (t >>> 7), t | 61); + return ((t ^ (t >>> 14)) >>> 0) / 4294967296; + }; +} +const R = rng(SEED); +const int = (n) => Math.floor(R() * n); +const pick = (xs) => xs[int(xs.length)]; +const ALPHABET = ["a", "Z", "0", " ", " ", "\t", "<", ">", "&", '"', "'", "{", "}", "=", ":", "-", "é", "日", "\\", "`", "$", "."]; +const randomText = (max = 40) => Array.from({ length: int(max) }, () => pick(ALPHABET)).join(""); + +const node = { ref: { full: "f".repeat(64), short: "ffffffff" }, shorthand: "file /tmp/x", convergence: "converged" }; +const entry = (over = {}) => ({ line: "err| boom", text: "boom", stream: "output", kind: "log", channel: "stderr", seq: 7, ...over }); +const run = (src, ctx) => tt.foldLine(tramaj, tramaj.parseProgram(src), ctx); + +test("the context carries every key, null when unknown", () => { + const ctx = tt.tailContext(entry(), node); + assert.deepEqual(Object.keys(ctx).sort(), ["channel", "fields", "kind", "line", "node", "seq", "stream", "text", "words"]); + assert.deepEqual(ctx.node, { ref: "f".repeat(64), short: "ffffffff", shorthand: "file /tmp/x", convergence: "converged" }); + const bare = tt.tailContext({ line: "x" }, undefined); + assert.equal(bare.text, "x"); + assert.equal(bare.seq, null); + assert.equal(bare.channel, null); + assert.deepEqual(bare.node, { ref: null, short: null, shorthand: null, convergence: null }); + // a template reading any documented key evaluates on a bare line + for (const k of ["line", "text", "stream", "kind", "channel", "seq", "words", "fields", "node.ref", "node.convergence"]) { + assert.ok(!run(`str($ctx.${k})`, bare).error, k); + } +}); + +test("fields: a JSON object, else key=value words, else nothing", () => { + assert.deepEqual(tt.fieldsOf(' {"level":"warn","n":3} '), { level: "warn", n: 3 }); + assert.deepEqual(tt.fieldsOf("ts=1 level=error msg=disk full"), { ts: "1", level: "error", msg: "disk" }); + assert.deepEqual(tt.fieldsOf("[1,2] a=b"), { a: "b" }); + assert.deepEqual(tt.fieldsOf("plain words"), {}); + assert.deepEqual(tt.fieldsOf("{not json"), {}); +}); + +test("a document draws as allowed elements; class and title only, actions ignored", () => { + const r = run('.span(class: "t-err", title: "why", style: "x", action("click", "k", {}), $ctx.text, " #", $ctx.seq)', tt.tailContext(entry(), node)); + assert.deepEqual(r, { spec: { tag: "span", cls: "t-err", title: "why", children: ["boom", " #", "7"] } }); + assert.equal(tt.specText(r.spec), "boom #7"); +}); + +test("null drops the line; a scalar is text", () => { + const keepStderr = 'branch(null, eq($ctx.channel, "stderr"), $ctx.line)'; + assert.deepEqual(run(keepStderr, tt.tailContext(entry({ channel: "stdout" }), node)), { drop: true }); + assert.deepEqual(run(keepStderr, tt.tailContext(entry(), node)), { spec: "err| boom" }); + assert.deepEqual(run("$ctx.seq", tt.tailContext(entry(), node)), { spec: "7" }); + assert.deepEqual(run("1.0", tt.tailContext(entry(), node)), { spec: "1.0" }); +}); + +test("structured fields are readable", () => { + const ctx = tt.tailContext(entry({ text: '{"level":"warn","msg":"slow"}' }), node); + const r = run('.span(class: lookup($ctx.fields, "level", "none"), $ctx.fields.msg)', ctx); + assert.deepEqual(r.spec, { tag: "span", cls: "warn", title: null, children: ["slow"] }); +}); + +test("what is not drawn is an error, never markup", () => { + for (const tag of ["script", "a", "img", "div", "iframe", "style"]) { + const r = run(`.${tag}("x")`, tt.tailContext(entry(), node)); + assert.match(r.error, /is not drawn/, tag); + } + assert.match(run("$ctx.nope", tt.tailContext(entry(), node)).error, /PathNotFound/); + assert.throws(() => tramaj.parseProgram(".span("), /ParseError|expected/); + const many = tt.tailContext(entry({ text: JSON.stringify({ xs: Array.from({ length: 600 }, (_, i) => i) }) }), node); + assert.match(run(".span(map($ctx.fields.xs, (x) => .b($x)))", many).error, /more than/); +}); + +test("property: the identity template shows the line unchanged", () => { + const asDoc = tramaj.parseProgram(".span($ctx.line)"); + const asExpr = tramaj.parseProgram("$ctx.line"); + for (let i = 0; i < CASES; i++) { + const line = randomText(); + const ctx = tt.tailContext({ line, text: line, stream: "output", kind: "output", channel: null, seq: i }, node); + assert.equal(tt.specText(tt.foldLine(tramaj, asDoc, ctx).spec), line); + assert.equal(tt.specText(tt.foldLine(tramaj, asExpr, ctx).spec), line); + } +}); + +test("property: words is the text split on whitespace", () => { + for (let i = 0; i < CASES; i++) { + const text = randomText(120); + const ws = tt.tailContext({ line: text, text }, node).words; + const expected = text.split(/\s+/).filter(Boolean); + assert.deepEqual(ws, expected.slice(0, tt.TEMPLATE_MAX_WORDS)); + assert.ok(ws.every((w) => w.length > 0 && !/\s/.test(w))); + } +}); + +test("property: a first-word filter keeps exactly the lines a JS filter keeps", () => { + const p = tramaj.parseProgram('branch(null, eq(lookup($ctx.words, 0, ""), "ERROR"), $ctx.line)'); + for (let i = 0; i < CASES; i++) { + const text = pick(["ERROR ", "error ", "WARN ", " ERROR ", "ERRORS ", ""]) + randomText(20); + const r = tt.foldLine(tramaj, p, tt.tailContext({ line: text, text }, node)); + const keep = text.split(/\s+/).filter(Boolean)[0] === "ERROR"; + assert.equal(Boolean(r.drop), !keep, JSON.stringify(text)); + if (keep) assert.equal(r.spec, text); + } +}); + +// random normative Node JSON, allowed and not +const TAGS = [...tt.TEMPLATE_TAGS, "script", "a", "div", "img"]; +const ATTRS = ["class", "title", "onclick", "href", "style", "class"]; +function randomNode(depth) { + const r = int(depth > 3 ? 2 : 4); + if (r === 0) return { type: "text", value: pick([randomText(8), 3, true, null]), annotations: {} }; + if (r === 1) return { type: "text", value: randomText(8), annotations: {} }; + if (r === 2) return { type: "fragment", children: Array.from({ length: int(3) }, () => randomNode(depth + 1)), annotations: {} }; + const tag = int(10) === 0 ? pick(TAGS.slice(-4)) : pick(TAGS); + const attributes = Array.from({ length: int(4) }, () => + int(4) === 0 ? { kind: "action", event: "click", key: "k", payload: {} } : { kind: "attribute", name: pick(ATTRS), value: pick([randomText(6), 1]) }, + ); + const children = tag === "br" ? [] : Array.from({ length: int(3) }, () => randomNode(depth + 1)); + return { type: "element", tag, attributes, value: null, children, annotations: {} }; +} +const hasForbidden = (n) => (n.type === "element" && !tt.TEMPLATE_TAGS.has(n.tag)) || (n.children || []).some(hasForbidden); +const leafText = (n) => + n.type === "text" ? (typeof n.value === "string" ? n.value : n.value === null ? "" : tramaj.stringify(n.value)) : n.tag === "br" ? "\n" : n.children.map(leafText).join(""); +function lastAttr(n, name) { + let v = null; + for (const a of n.attributes) if (a.kind === "attribute" && a.name === name && typeof a.value === "string") v = a.value; + return v; +} +function checkSpec(n, s) { + if (n.type === "text") return assert.equal(typeof s, "string"); + if (n.type === "fragment") assert.equal(s.tag, null); + else { + assert.ok(tt.TEMPLATE_TAGS.has(s.tag)); + assert.equal(s.cls, lastAttr(n, "class")); + assert.equal(s.title, lastAttr(n, "title")); + } + assert.deepEqual(Object.keys(s).sort(), ["children", "cls", "tag", "title"]); + n.children.forEach((c, i) => checkSpec(c, s.children[i])); +} + +test("property: a document draws iff every tag is allowed, keeping its text and only class/title", () => { + for (let i = 0; i < CASES * 2; i++) { + const n = randomNode(0); + if (hasForbidden(n)) { + assert.throws(() => tt.specOf(tramaj, n), tt.TemplateError); + } else { + const s = tt.specOf(tramaj, n); + checkSpec(n, s); + assert.equal(tt.specText(s), leafText(n)); + } + } +}); diff --git a/ui/card-template.js b/ui/card-template.js new file mode 100644 --- /dev/null +++ b/ui/card-template.js @@ -0,0 +1,137 @@ +// Card templates: the pure half of drawing a node's card in the panel from +// a Tramaj template the node itself carries (feature 458c16c8). Opt-in: a +// node declares one with `withCardTemplate` (Salmon.Builtin.Extension), and +// `/dag` then carries it as the node's `template`; a node without one has no +// `template` key and its card is the default one. `ui.js` imports this +// module, with `tail-template.js` and the vendored tramaj-js, only once a +// selected node has a template (or a tail window does). +// +// No DOM here, and the evaluator is passed in, so the contract can be checked +// under node (`salmon-ops/ui-test/card-template.test.mjs`). +// +// The contract a card template is written against, and which must stay +// stable: +// +// - It is a Tramaj program evaluated in concrete mode, with no libraries, +// against `$ctx` = `cardContext(node)`, every time the card is drawn: +// ref {full, short} +// shorthand the node's shorthand +// help its help text ("" when none) +// notes its notes (a list of strings) +// dynamics its rendered dynamics (a list of strings) +// direction "up" or "down": what the loop wants of it +// convergence "pending", "converged", "stale", ... +// machine the machine state the page last heard of, or null +// paths up to 8 declared paths to it, shortest first +// dependencies the short refs it depends on +// dependants the short refs that depend on it +// check {verdict, reason} of its last check; both null when it +// was never checked (an object either way, since Tramaj's +// `branch` evaluates both arms: `$ctx.check.verdict` is +// always a valid path) +// last the last event the page saw about it, or null +// lastReason that event's reason, or null +// output its tending machine's last output lines (a list) +// conflict true while two live declarations disagree about it +// Every key is always present (null or empty when unknown): Tramaj refuses +// a missing path. All of it is what `/dag` already serves to the page, +// so a template sees nothing that is not already public; the template's +// own source is public too (it is served on `/dag`). +// - Its result is the card: `null` means "draw the default card" (so a +// template can opt out per state); a string or other scalar is text; a +// document is drawn as elements. +// - Only the tags in CARD_TAGS are drawn (the tail's phrasing tags plus a +// few block ones, and `a`), and of attributes only `class` and `title`, +// plus `href` on an `a`. A tag outside the list is an error; another +// attribute, and every action, is ignored. Nothing is ever parsed as HTML. +// - An `a` is a link out of the page (a cloud console page, say). Its `href` +// is kept only when it is an absolute `https:` URL with no user name or +// password in it (`safeHref`); anything else (`javascript:`, `data:`, a +// relative path, plain `http:`) leaves the `a` without an href, drawn as +// its text. `ui.js` opens a kept link in a new tab, with +// `rel="noopener noreferrer"` and no referrer. At most TEMPLATE_MAX_NODES +// nodes and TEMPLATE_MAX_DEPTH deep, as in a tail. +// - A template that does not parse, or a card whose evaluation fails, is +// drawn as the default card with the error above it. +// - The card replaces the descriptive sections of the panel (help, notes, +// dynamics, last check, last event, output). The title, ref, state badges, +// the command buttons, paths, dependencies, dependants, the full ref and +// the seed list stay as they are: they are how the page is driven. + +import { TEMPLATE_ATTRS, TEMPLATE_TAGS, foldLine } from "./tail-template.js"; + +export const CARD_TAGS = new Set([ + ...TEMPLATE_TAGS, + "div", + "p", + "pre", + "ul", + "ol", + "li", + "dl", + "dt", + "dd", + "table", + "thead", + "tbody", + "tr", + "th", + "td", + "h4", + "h5", + "hr", + "details", + "summary", + "a", +]); + +// An `a`'s href as drawn, or null: only an absolute https URL without +// credentials, normalized by the URL parser. +export function safeHref(v) { + if (typeof v !== "string") return null; + let u; + try { + u = new URL(v); + } catch { + return null; + } + if (u.protocol !== "https:" || u.username !== "" || u.password !== "" || u.hostname === "") return null; + return u.href; +} + +export const CARD_ALLOW = { tags: CARD_TAGS, attrs: TEMPLATE_ATTRS, href: safeHref, where: "a card" }; + +const strings = (v) => (Array.isArray(v) ? v.map((x) => String(x)) : []); +const orNull = (v) => (v === undefined ? null : v); +const shortOf = (r) => (r && typeof r.short === "string" ? r.short : null); + +// The `$ctx` of a node as `ui.js` keeps it: the /dag object plus the live +// overlay (`machine`, `last`, `lastReason`). +export function cardContext(n) { + const check = n.status && n.status.check; + return { + ref: { full: orNull(n.ref && n.ref.full), short: orNull(n.ref && n.ref.short) }, + shorthand: orNull(n.shorthand), + help: typeof n.help === "string" ? n.help : "", + notes: strings(n.notes), + dynamics: strings(n.dynamics), + direction: orNull(n.direction), + convergence: orNull(n.convergence), + machine: orNull(n.machine), + paths: strings(n.paths), + dependencies: (Array.isArray(n.dependencies) ? n.dependencies : []).map(shortOf).filter((s) => s !== null), + dependants: (Array.isArray(n.dependants) ? n.dependants : []).map(shortOf).filter((s) => s !== null), + check: { verdict: orNull(check && check.verdict), reason: orNull(check && check.reason) }, + last: orNull(n.last), + lastReason: orNull(n.lastReason), + output: strings(n.status && n.status.output), + conflict: Boolean(n.conflict), + }; +} + +// A node's card through a parsed template: {fallback: true} (null: draw the +// default card), {spec}, or {error}. +export function foldCard(tramaj, program, ctx) { + const r = foldLine(tramaj, program, ctx, CARD_ALLOW); + return r.drop ? { fallback: true } : r; +} diff --git a/ui/index.html b/ui/index.html --- a/ui/index.html +++ b/ui/index.html @@ -16,17 +16,19 @@
nodes
–
last converge
–
stream
connecting
+
view
read-only