diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for salmon-apps + +## 0.1.0.0 -- unreleased + +* First release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2022-2026, Lucas DiCioccio +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/app/FleetApp.hs b/app/FleetApp.hs new file mode 100644 --- /dev/null +++ b/app/FleetApp.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified Fleet + +main :: IO () +main = Fleet.main diff --git a/app/GcpToyApp.hs b/app/GcpToyApp.hs new file mode 100644 --- /dev/null +++ b/app/GcpToyApp.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified GcpToy + +main :: IO () +main = GcpToy.main diff --git a/app/InitializerApp.hs b/app/InitializerApp.hs new file mode 100644 --- /dev/null +++ b/app/InitializerApp.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified Initializer + +main :: IO () +main = Initializer.main diff --git a/app/MigratorApp.hs b/app/MigratorApp.hs new file mode 100644 --- /dev/null +++ b/app/MigratorApp.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified Migrator + +main :: IO () +main = Migrator.main diff --git a/app/PatroniRootfsApp.hs b/app/PatroniRootfsApp.hs new file mode 100644 --- /dev/null +++ b/app/PatroniRootfsApp.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified PatroniRootfs + +main :: IO () +main = PatroniRootfs.main diff --git a/app/PgBackupApp.hs b/app/PgBackupApp.hs new file mode 100644 --- /dev/null +++ b/app/PgBackupApp.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified PgBackup + +main :: IO () +main = PgBackup.main diff --git a/app/PgPairApp.hs b/app/PgPairApp.hs new file mode 100644 --- /dev/null +++ b/app/PgPairApp.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified PgPair + +main :: IO () +main = PgPair.main diff --git a/app/QemuPgHaToyApp.hs b/app/QemuPgHaToyApp.hs new file mode 100644 --- /dev/null +++ b/app/QemuPgHaToyApp.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified QemuPgHaToy + +main :: IO () +main = QemuPgHaToy.main diff --git a/app/TuiApp.hs b/app/TuiApp.hs new file mode 100644 --- /dev/null +++ b/app/TuiApp.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified Tui + +main :: IO () +main = Tui.main diff --git a/salmon-apps.cabal b/salmon-apps.cabal new file mode 100644 --- /dev/null +++ b/salmon-apps.cabal @@ -0,0 +1,180 @@ +cabal-version: 2.4 +name: salmon-apps +version: 0.1.0.0 +synopsis: A set of utilities built with Salmon at their core. +description: Tools useful for operating systems, and which benefit from specialized implementations configured via external files: salmon-migrator, salmon-pgpair, salmon-fleet, salmon-tui and others. +homepage: https://lucasdicioccio.github.io/salmon/ +bug-reports: https://github.com/lucasdicioccio/salmon/issues +license: BSD-3-Clause +license-file: LICENSE +author: Lucas DiCioccio +maintainer: lucas@dicioccio.fr +copyright: 2022-2026 Lucas DiCioccio +category: Development +build-type: Simple +tested-with: GHC == 9.10.3 +extra-doc-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/lucasdicioccio/salmon + subdir: salmon-apps + +library + exposed-modules: + Fleet + Tui + Migrator + PgPair + QemuPgHaToy + PatroniRootfs + Initializer + GcpToy + PgBackup + other-modules: + Migrator.Ops + Migrator.Seed + Migrator.Spec + + build-depends: base >=4.16.3.0 && <4.22 + , aeson + , brick + , bytestring + , http-client + , containers + , directory + , filepath + , layoutz-hs + , optparse-applicative + , optparse-generic + , process + , salmon-core ^>=0.1.0.0 + , salmon-ops ^>=0.1.0.0 + , salmon-ops-recipes ^>=0.1.0.0 + , text + , time + , vty + , unix + ghc-options: -Wall + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: KindSignatures + , DataKinds + , OverloadedStrings + , DeriveFunctor + , OverloadedRecordDot + , TypeApplications + , ScopedTypeVariables + +executable salmon-toy-qemu-pg-ha + main-is: QemuPgHaToyApp.hs + build-depends: base >=4.16.3.0 && <4.22 + , salmon-apps + hs-source-dirs: app + ghc-options: -threaded + default-language: Haskell2010 + +executable salmon-patroni-rootfs + main-is: PatroniRootfsApp.hs + build-depends: base >=4.16.3.0 && <4.22 + , salmon-apps + hs-source-dirs: app + ghc-options: -threaded + default-language: Haskell2010 + +executable salmon-pgpair + main-is: PgPairApp.hs + build-depends: base >=4.16.3.0 && <4.22 + , salmon-apps + hs-source-dirs: app + -- every salmon binary can end up running the concurrent driver (`run + -- serve` does), and a node's own thread must not block the whole runtime. + ghc-options: -threaded + default-language: Haskell2010 + +executable salmon-migrator + main-is: MigratorApp.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base >=4.16.3.0 && <4.22 + , salmon-apps + hs-source-dirs: app + -- every salmon binary can end up running the concurrent driver (`run + -- serve` does), and a node's own thread must not block the whole runtime. + ghc-options: -threaded + default-language: Haskell2010 + +executable salmon-init-locally + main-is: InitializerApp.hs + + build-depends: base >=4.16.3.0 && <4.22 + , salmon-apps + hs-source-dirs: app + -- every salmon binary can end up running the concurrent driver (`run + -- serve` does), and a node's own thread must not block the whole runtime. + ghc-options: -threaded + default-language: Haskell2010 + +executable salmon-pg-backup + main-is: PgBackupApp.hs + + build-depends: base >=4.16.3.0 && <4.22 + , salmon-apps + hs-source-dirs: app + ghc-options: -threaded + default-language: Haskell2010 + +executable salmon-fleet + main-is: FleetApp.hs + + build-depends: base >=4.16.3.0 && <4.22 + , salmon-apps + hs-source-dirs: app + ghc-options: -threaded + default-language: Haskell2010 + +executable salmon-gcp-toy + main-is: GcpToyApp.hs + + build-depends: base >=4.16.3.0 && <4.22 + , salmon-apps + hs-source-dirs: app + ghc-options: -threaded + default-language: Haskell2010 + +executable salmon-tui + main-is: TuiApp.hs + + build-depends: base >=4.16.3.0 && <4.22 + , salmon-apps + hs-source-dirs: app + -- the stream is followed on its own thread while brick owns the terminal + ghc-options: -threaded + default-language: Haskell2010 + +test-suite salmon-apps-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: Test.FleetSpec + build-depends: base >=4.16.3.0 && <4.22 + , aeson + , bytestring + , directory + , filepath + , salmon-apps + , salmon-ops ^>=0.1.0.0 + , tasty + , tasty-hunit + , temporary + , text + , time + ghc-options: -Wall + default-language: Haskell2010 + default-extensions: OverloadedStrings + , OverloadedRecordDot + , ScopedTypeVariables diff --git a/src/Fleet.hs b/src/Fleet.hs new file mode 100644 --- /dev/null +++ b/src/Fleet.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | @salmon-fleet@: the controller's side of pull mode. @salmon-fleet +status DIR@ (milestone 5 of @specs/pull-mode.md@) folds every status +document in @DIR@ — one per host, written by each host's @run serve +--status-sink@ — into one line per host; the fold itself is +"Salmon.Actions.Fleet", and this is the command line over it. It reads +only, and writes nothing a host reads. + +@status@'s default output is one tab-separated line per host +('Salmon.Actions.Fleet.renderRow'), unchanged, for scripts and pipes. +Beside it, @--pretty@ draws the same rows as a bordered table (using +@layoutz-hs@, ) with the stale +marker as its own column, so it is visible on a screen reader or a pipe +and not only as color. Which one comes out by default follows the same +convention @ls@\/@git@ use: pretty on an interactive terminal +('System.IO.hIsTerminalDevice'), TSV otherwise; @--pretty@\/@--no-pretty@ force +either one regardless, and @--json@ still wins over both, unchanged. Color +is applied only when standard output actually is a terminal — never with +@--json@, never with plain TSV, and never just because @--pretty@ was +passed while piped — as a post-render, whole-line ANSI wrap (no new +dependency for it): 'Salmon.Actions.Fleet.renderRow'\/'Fleet.Row' are +already plain, so this never touches the fold or its TSV rendering, only +how @salmon-apps@ prints on top of it. The decision of whether to go +pretty at all is the pure, testable 'decidePretty': terminal detection +happens once in 'main' and is passed in as a plain 'Bool', so a test never +needs a real pty. + +@salmon-fleet keygen --out FILE@ and @salmon-fleet sign --key FILE@ are the +signing half of "Salmon.Actions.Follow.Signature": a key pair as two JWK +files (@FILE@, mode 0600, and @FILE.pub@ for the hosts' @--follow-key@), and +a document on standard input wrapped in a signed envelope on standard +output — so the round trip from a document to a host that verifies it needs +no tool but this one. @sign@ writes to the filesystem only where @--out@ +says; @keygen@ refuses to overwrite a key that exists. + +@salmon-fleet describe@ and @salmon-fleet run ARGS@ are the +@agents-exe@ bash-toolbox protocol (see @documentation/binary-tool.md@ in +the @agents-exe@ repository) wrapped around @status@ alone — the only +subcommand here that is flat-arg, one-shot and read-only to begin with. +@describe@ prints the tool's JSON description ('fleetDescribe'\/'describeValue'); +@run DIR [--label L] [--stale S]@ runs the equivalent of +@status DIR [--label L] [--stale S] --json@ (JSON forced; @--pretty@\/@--no-pretty@ +are a terminal's business and are not exposed to a toolbox caller, which is a +program, not a terminal). @status@ itself is unchanged. One known gap: the +current @describe@\/@run@ spec's @arity@ is @single@ or @optional@ only — there is +no repeatable arity — so @--label@, repeatable on the real CLI, is exposed to the +toolbox as a single optional string; a toolbox caller cannot filter on more than +one label at once. @keygen@\/@sign@ are not exposed this way (out of scope for +this pass). +-} +module Fleet ( + main, + + -- * The pretty table (exposed for tests) + decidePretty, + prettyTable, + + -- * The agents-exe bash-toolbox protocol (exposed for tests) + describeValue, + foldStatusDir, +) where + +import Control.Monad (forM_, unless, when) +import Data.Aeson (Value, encode, object, (.=)) +import qualified Data.ByteString.Lazy as LByteString +import Data.List (intercalate) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Time.Clock (getCurrentTime) +import qualified Layoutz as L +import Options.Applicative +import System.Directory (doesFileExist) +import System.Exit (exitFailure) +import System.IO (hIsTerminalDevice, hPutStrLn, stderr, stdout) + +import Salmon.Actions.Serve (AppliedDocument (..)) +import Salmon.Actions.Serve.StatusSink (Document) +import qualified Salmon.Actions.Fleet as Fleet +import qualified Salmon.Actions.Follow as Follow +import qualified Salmon.Actions.Follow.Signature as Signature + +data Command + = Status FilePath (Maybe String) Double Bool (Maybe Bool) + | Keygen FilePath + | Sign FilePath (Maybe FilePath) (Maybe String) + | Describe + | Run FilePath (Maybe String) Double + +main :: IO () +main = do + cmd <- execParser (info (commandP <**> helper) (fullDesc <> progDesc "The controller's side of pull mode: fold status sink documents, make signing keys, sign documents" <> header "salmon-fleet")) + case cmd of + Keygen path -> do + taken <- doesFileExist path + when taken $ do + hPutStrLn stderr ("salmon-fleet: " <> path <> " exists; not overwriting a key") + exitFailure + key <- Signature.generateKeyPair + Signature.writeKeyPair path key + hPutStrLn stderr ("salmon-fleet: wrote " <> path <> " (private, 0600) and " <> path <> ".pub (public); key id " <> Text.unpack (Signature.keyId (Signature.publicKey key))) + Sign keyPath out mlabel -> do + loaded <- Signature.readPrivateKeyFile keyPath + key <- case loaded of + Left err -> hPutStrLn stderr ("salmon-fleet: --key " <> Text.unpack err) >> exitFailure + Right k -> pure k + document <- LByteString.getContents + lbl <- case traverse (Follow.mkLabel . Text.pack) mlabel of + Left err -> hPutStrLn stderr ("salmon-fleet: --label: " <> Text.unpack err) >> exitFailure + Right l -> pure l + signed <- Signature.signDocumentFor key lbl document + case signed of + Left err -> hPutStrLn stderr ("salmon-fleet: cannot sign: " <> Text.unpack err) >> exitFailure + Right envelope -> maybe LByteString.putStr LByteString.writeFile out envelope + Status dir label stale asJson prettyOverride -> do + (docs, rows, rejected) <- foldStatusDir dir label stale + if asJson + then LByteString.putStr (encode rows <> "\n") + else do + isTty <- hIsTerminalDevice stdout + if decidePretty prettyOverride isTty + then Text.putStrLn (prettyTable isTty rows) + else do + Text.putStrLn Fleet.renderHeader + forM_ rows (Text.putStrLn . Fleet.renderRow) + reportStatusOutcome docs rows rejected label + Describe -> + LByteString.putStr (encode describeValue <> "\n") + Run dir label stale -> do + (docs, rows, rejected) <- foldStatusDir dir label stale + LByteString.putStr (encode rows <> "\n") + reportStatusOutcome docs rows rejected label + +-- | @status@ and @run@'s shared work: read the directory, fold it. Kept in +-- one place so the toolbox @run@ path (which always emits JSON) can't drift +-- from what @status --json@ computes. +foldStatusDir :: FilePath -> Maybe String -> Double -> IO ([(FilePath, Document)], [Fleet.Row], [(FilePath, String)]) +foldStatusDir dir label stale = do + (docs, rejected) <- Fleet.readStatusDir dir + forM_ rejected $ \(path, why) -> + hPutStrLn stderr ("salmon-fleet: skipping " <> path <> ": " <> why) + now <- getCurrentTime + let opts = Fleet.Options (Text.pack <$> label) (realToFrac stale) + rows = Fleet.fold opts now docs + pure (docs, rows, rejected) + +-- | @status@ and @run@'s shared stderr/exit-code behaviour: warn if +-- @--label@ matched nobody, and exit non-zero if the directory had nothing +-- readable in it at all. +reportStatusOutcome :: [(FilePath, Document)] -> [Fleet.Row] -> [(FilePath, String)] -> Maybe String -> IO () +reportStatusOutcome docs rows rejected label = do + unless (null docs || not (null rows) || label == Nothing) $ + hPutStrLn stderr ("salmon-fleet: no host carries label " <> maybe "" id label) + -- a directory with nothing readable in it is an error worth an + -- exit code: the fold has nothing to say and probably was not + -- pointed at the right place + unless (not (null docs) || null rejected) exitFailure + +{- | Pretty on an interactive terminal, TSV otherwise — the same convention +@ls@\/@git@ follow — unless @--pretty@\/@--no-pretty@ (a 'Just') forces one +or the other regardless of whether standard output is actually a terminal. +Pure so a test can drive both sides of the terminal-detection line without +a pty. -} +decidePretty :: Maybe Bool -> Bool -> Bool +decidePretty override isTerminal = maybe isTerminal id override + +{- | The rows as a bordered table (@layoutz-hs@), one row per host, with an +explicit @STALE@ column beside the other fields — so the stale marker +survives a pipe or a screen reader exactly like every other column, rather +than living only in color. The @Bool@ says whether standard output is +/actually/ a terminal: only then are stale and errored rows painted, and +only as a whole-line ANSI wrap applied /after/ layoutz has rendered and +padded every cell — layoutz sizes columns by the plain length of each +cell's text, so coloring a cell's substring in place would misalign every +column after it; wrapping the finished line does not, since the escape +codes carry no visible width. -} +prettyTable :: Bool -> [Fleet.Row] -> Text +prettyTable colorOn rows = + let headers = ["HOST", "MODE", "LABELS", "CONVERGED", "ERRORED", "AGE", "STALE"] + cellsOf r = + [ L.text (Text.unpack r.rowHost) + , L.text (Text.unpack r.rowMode) + , L.text (labelsCell r) + , L.text (show r.rowConverged <> "/" <> show r.rowNodes) + , L.text (show r.rowErrored) + , L.text (show (round r.rowAge :: Integer) <> "s") + , L.text (if r.rowStale then "STALE" else "") + ] + rendered = Text.pack (L.render (L.table headers (fmap cellsOf rows))) + in if colorOn then colorizeRows rows rendered else rendered + +labelsCell :: Fleet.Row -> String +labelsCell r + | null r.rowLabels = "-" + | otherwise = intercalate "," (fmap labelText r.rowLabels) + where + labelText :: AppliedDocument -> String + labelText a = Text.unpack (a.appliedDocLabel <> "=" <> a.appliedDocId <> "@" <> Text.take 12 a.appliedDocDigest) + +{- | Paint each data row of the rendered table: red for a stale host, yellow +for one with errored nodes, untouched otherwise (borders and header +included). The table's own shape is what makes this safe without parsing +it back: 'L.table' puts exactly one top border, one header, one separator, +then one line per row (none of our cells contain a newline), then one +bottom border — so the @i@-th row is line @3 + i@. -} +colorizeRows :: [Fleet.Row] -> Text -> Text +colorizeRows rows rendered = + Text.intercalate "\n" (zipWith paint [0 ..] (Text.lines rendered)) + where + n = length rows + paint :: Int -> Text -> Text + paint i line + | i >= 3 && i < 3 + n = + let r = rows !! (i - 3) + in if r.rowStale + then ansiWrap ansiRed line + else + if r.rowErrored > 0 + then ansiWrap ansiYellow line + else line + | otherwise = line + +ansiWrap :: Text -> Text -> Text +ansiWrap code line = code <> line <> ansiReset + +ansiRed, ansiYellow, ansiReset :: Text +ansiRed = "\ESC[31m" +ansiYellow = "\ESC[33m" +ansiReset = "\ESC[0m" + +------------------------------------------------------------------------------- +-- agents-exe bash-toolbox describe/run (documentation/binary-tool.md in the +-- agents-exe repository): a slug, a description, and one arg object per +-- 'runP' argument below, kept in exact correspondence with it by hand (see +-- Test.FleetSpec's schema-shape test). + +-- | The JSON @salmon-fleet describe@ prints: this tool's toolbox interface, +-- wrapping @status@ alone. See the module haddock for the known gap +-- (@--label@ is repeatable on the real CLI; the current toolbox spec's +-- @arity@ has no repeatable case, so it is exposed here as a single +-- optional string). +describeValue :: Value +describeValue = + object + [ "slug" .= ("salmon-fleet-status" :: Text) + , "description" + .= ( "One line per host, folded from a directory of salmon `run serve --status-sink` " + <> "status documents (one JSON file per host): host name, mode, applied labels, " + <> "converged/errored node counts out of the total, and how long ago the host " + <> "last wrote its status. Read-only; writes nothing." :: + Text + ) + , "args" + .= [ object + [ "name" .= ("dir" :: Text) + , "description" .= ("A directory of *.json status sink documents, one per host." :: Text) + , "type" .= ("string" :: Text) + , "backing_type" .= ("string" :: Text) + , "arity" .= ("single" :: Text) + , "mode" .= ("positional" :: Text) + ] + , object + [ "name" .= ("label" :: Text) + , "description" + .= ( "Only include hosts whose applied documents carry this label. The underlying " + <> "CLI allows repeating --label; this toolbox arg is single-valued only, since " + <> "the current describe/run spec has no repeatable arity." :: + Text + ) + , "type" .= ("string" :: Text) + , "backing_type" .= ("string" :: Text) + , "arity" .= ("optional" :: Text) + , "mode" .= ("dashdashspace" :: Text) + ] + , object + [ "name" .= ("stale" :: Text) + , "description" .= ("Flag a host whose status document is older than this many seconds (default 60)." :: Text) + , "type" .= ("number" :: Text) + , "backing_type" .= ("string" :: Text) + , "arity" .= ("optional" :: Text) + , "mode" .= ("dashdashspace" :: Text) + ] + ] + , "empty-result" + .= object + [ "tag" .= ("AddMessage" :: Text) + , "contents" .= ("No status documents found in DIR (or none carry --label)." :: Text) + ] + ] + +commandP :: Parser Command +commandP = + hsubparser $ + command "status" (info statusP (progDesc "One line per host from the status documents in DIR.")) + <> command "keygen" (info keygenP (progDesc "Write a fresh Ed25519 signing key pair: FILE (private, 0600) and FILE.pub (public, for --follow-key).")) + <> command "sign" (info signP (progDesc "Wrap the document on standard input in a signed envelope, on standard output (or --out FILE).")) + <> command "describe" (info (pure Describe) (progDesc "Print the agents-exe bash-toolbox JSON description of this tool (wraps `status` only).")) + <> command "run" (info runP (progDesc "The agents-exe bash-toolbox entry point: the equivalent of `status DIR [--label L] [--stale S] --json`.")) + where + keygenP = + Keygen + <$> strOption (long "out" <> metavar "FILE" <> help "Where to write the private key; the public key goes to FILE.pub.") + signP = + Sign + <$> strOption (long "key" <> metavar "FILE" <> help "The private key (JWK) to sign with, as `keygen --out FILE` wrote it.") + <*> optional (strOption (long "out" <> metavar "FILE" <> help "Write the signed envelope here instead of standard output.")) + <*> optional (strOption (long "label" <> metavar "LABEL" <> help "The label this document is for; put into the signed document so a host following another label refuses it. Hosts run with --follow-key refuse a signed document that names none, unless --follow-accept-unlabelled.")) + statusP = + Status + <$> strArgument (metavar "DIR" <> help "A directory of *.json status sink documents (one per host).") + <*> optional (strOption (long "label" <> metavar "LABEL" <> help "Only hosts whose applied documents include this label.")) + <*> option auto (long "stale" <> metavar "SECONDS" <> value 60 <> showDefault <> help "Flag a host whose document was written longer ago than this.") + <*> switch (long "json" <> help "Emit the fold as one JSON array instead of lines.") + <*> prettyOverrideP + -- agents-exe's flattening: DIR positional, --label/--stale + -- dashdashspace, exactly `describeValue`'s `args` — JSON is not a flag + -- here, it's what `run` always emits. + runP = + Run + <$> strArgument (metavar "DIR" <> help "A directory of *.json status sink documents (one per host).") + <*> optional (strOption (long "label" <> metavar "LABEL" <> help "Only hosts whose applied documents include this label.")) + <*> option auto (long "stale" <> metavar "SECONDS" <> value 60 <> showDefault <> help "Flag a host whose document was written longer ago than this.") + prettyOverrideP :: Parser (Maybe Bool) + prettyOverrideP = + flag' (Just True) (long "pretty" <> help "Force the table output even when standard output is not a terminal.") + <|> flag' (Just False) (long "no-pretty" <> help "Force the plain tab-separated output even on a terminal.") + <|> pure Nothing diff --git a/src/GcpToy.hs b/src/GcpToy.hs new file mode 100644 --- /dev/null +++ b/src/GcpToy.hs @@ -0,0 +1,866 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | A throwaway, tiered exercise of the "Salmon.Builtin.Nodes.Gcp" builtins +against a real GCP project, meant to be run in a sandbox organization or +billing account where deleting everything afterwards is the point. + +Tiers are cumulative and ordered by cost: + +* __tier 0__ (≈free): project (optional), billing link, APIs, a bucket, a + service account, IAM bindings on both, an Artifact Registry repository. +* __tier 1__ (cents): build an image with podman, push it to the + repository, deploy it to Cloud Run as that service account. The image is + either a one-line @FROM --base-image@ (Google's hello sample by default) or + the caller's own @--containerfile@, built with that file's directory as + context; either way it must serve HTTP on @$PORT@, as Cloud Run requires. +* __tier 2__ (an e2-micro's hourly rate): reserve an address, open ssh to a + tagged instance, boot a VM whose startup script trusts a salmon-generated + SSH CA, then upload this very binary and run it there over that CA -- + "SreBox.Gcp.VmProvision", i.e. @specs/gcloud-support.md@ §6's "objective". +* __tier 3__ (a forwarding rule's hourly rate on top): put a regional + external Application Load Balancer in front of that VM -- a proxy-only + subnet, an unmanaged instance group holding the instance, a health check, + and the balancer itself. The VM serves the page through a systemd unit the + /tier-2 hand-off/ installed, so a @200@ from the balancer's address is + evidence for both halves at once. + +Tier 2 takes __two passes__, which is not a wart but the shape of the +problem: GCP picks the address, so nothing can name the machine until after +the address node's @up@. Pass one declares the infrastructure; the driver +then reads the IP (@Compute.readAddress@) and passes it back in as +@--vm-ip@, and pass two declares the same graph plus the provisioning step. + +When the project is created by this binary (the default), it is the deepest +node of the graph, so @run down@ tears every resource down individually +first -- which is what is being validated -- and then deletes the project, +which sweeps whatever a buggy @down@ left behind. A failed @down@ leaves the +project standing (its dependants were not all removed), which is the signal +to go and look. + +See @salmon-apps/scripts/gcp-toy-validate.sh@ for the up → up → down driver. +-} +module GcpToy ( + main, + Seed (..), + Spec (..), + ParentRef (..), + Role (..), + VmConfig (..), + LbConfig (..), + ImageSource (..), + defaultBaseImage, + configure, + program, +) where + +import Control.Monad (when) +import qualified Data.Map as Map +import Data.Aeson (FromJSON, ToJSON) +import Data.Char (isAsciiLower, isDigit) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Options.Applicative (auto, execParser, flag', fullDesc, header, helper, info, long, metavar, option, optional, progDesc, strOption, switch, value, (<**>), (<|>)) +import qualified Options.Applicative as Opt +import Options.Generic (ParseRecord (..)) +import System.Directory (doesFileExist, makeAbsolute) + +import qualified Salmon.Builtin.CommandLine as CLI +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Gcp.ArtifactRegistry as ArtifactRegistry +import qualified Salmon.Builtin.Nodes.Gcp.Billing as Billing +import qualified Salmon.Builtin.Nodes.Gcp.CloudRun as CloudRun +import qualified Salmon.Builtin.Nodes.Gcp.Core as Core +import qualified Salmon.Builtin.Nodes.Gcp.Iam as Iam +import qualified Salmon.Builtin.Nodes.Gcp.Monitoring as Monitoring +import qualified Salmon.Builtin.Nodes.Gcp.ResourceManager as ResourceManager +import qualified Salmon.Builtin.Nodes.Gcp.ServiceUsage as ServiceUsage +import qualified Salmon.Builtin.Nodes.Gcp.Storage as Storage +import qualified Salmon.Builtin.Nodes.Debian.OS as OS +import qualified Salmon.Builtin.Nodes.Debian.Package as Debian +import qualified Salmon.Builtin.Nodes.Gcp.Compute as Compute +import qualified Salmon.Builtin.Nodes.Gcp.LoadBalancing as LoadBalancing +import qualified Salmon.Builtin.Nodes.Gcp.SshAccess as SshAccess +import qualified Salmon.Builtin.Nodes.Systemd as Systemd +import qualified Salmon.Builtin.Nodes.Keys as Keys +import qualified Salmon.Builtin.Nodes.Podman as Podman +import qualified Salmon.Builtin.Nodes.Self as Self +import Salmon.Op.Configure (Configure (..)) +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track (Track (..)) +import Salmon.Reporter (reportPrint) + +import qualified SreBox.Gcp.CloudRunAlerts as CloudRunAlerts +import qualified SreBox.Gcp.CloudRunDeploy as CloudRunDeploy +import qualified SreBox.Gcp.VmProvision as VmProvision + +main :: IO () +main = do + let desc = fullDesc <> progDesc "Tiered throwaway validation of salmon's GCP builtins" <> header "salmon-gcp-toy" + cmd <- execParser (info parseRecord desc) + CLI.execCommandOrSeed reportPrint configure program cmd + +------------------------------------------------------------------------------- +-- Seed + +data SeedParent = SeedOrganization Text | SeedFolder Text | SeedNoParent | SeedExistingProject + deriving (Eq, Show) + +data Seed = Seed + { seedProject :: Text + , seedParent :: SeedParent + , seedBillingAccount :: Maybe Text + , seedRegion :: Text + , seedTier :: Int + , seedPrefix :: Text + , seedImageTag :: Text + , seedImageSource :: ImageSource + , seedWorkDir :: FilePath + , seedVmZone :: Maybe Text + , seedVmMachineType :: Text + , seedVmImageFamily :: Text + , seedVmImageProject :: Text + , seedVmUser :: Text + , seedSshSourceRange :: Text + , seedVmIp :: Maybe Text + , seedLbProxyRange :: Text + , seedLbPort :: Int + , seedAlertEmail :: Maybe Text + } + deriving (Eq, Show) + +instance ParseRecord Seed where + parseRecord = + build <**> helper + where + build = + Seed + <$> strOption (long "project" <> metavar "PROJECT_ID" <> Opt.help "project id to create (or use, with --existing-project)") + <*> parent + <*> optional (strOption (long "billing-account" <> metavar "XXXXXX-XXXXXX-XXXXXX" <> Opt.help "billing account to link; required unless --existing-project")) + <*> strOption (long "region" <> value "europe-west1" <> Opt.help "region for the bucket, repository and Cloud Run service") + <*> option auto (long "tier" <> value 0 <> Opt.help "0: storage/iam/registry; 1: also build+push+deploy to Cloud Run (needs podman)") + <*> strOption (long "prefix" <> value "salmon-toy" <> Opt.help "prefix for every resource name") + <*> strOption (long "image-tag" <> value "v1" <> Opt.help "tier 1 image tag; bump it to exercise a redeploy") + <*> imageSourceP + <*> strOption (long "workdir" <> value "gcp-toy-work" <> Opt.help "local directory for the Containerfile, authfile, ssh keys and startup script") + <*> optional (strOption (long "vm-zone" <> Opt.help "tier 2 zone (default: -b)")) + <*> strOption (long "vm-machine-type" <> value "e2-micro" <> Opt.help "tier 2 machine type") + <*> strOption (long "vm-image-family" <> value "ubuntu-2404-lts-amd64" <> Opt.help "tier 2 boot image family") + <*> strOption (long "vm-image-project" <> value "ubuntu-os-cloud" <> Opt.help "tier 2 boot image project") + <*> strOption (long "vm-user" <> value "salmon" <> Opt.help "tier 2 login user, and the certificate principal signed for it") + <*> strOption (long "ssh-source-range" <> value "0.0.0.0/0" <> Opt.help "tier 2 CIDR allowed to reach port 22") + <*> optional (strOption (long "vm-ip" <> Opt.help "tier 2 second pass: the reserved IP, which a first pass cannot know")) + -- The default is outside 10.128.0.0/9 on purpose: the whole + -- of that block belongs to the subnets an auto-mode network + -- (which `default` is) creates per region on its own, + -- including for regions that do not exist yet. + <*> strOption (long "lb-proxy-range" <> value "192.168.100.0/24" <> Opt.showDefault <> Opt.help "tier 3 proxy-only subnet range (/26 or larger, must not overlap 10.128.0.0/9)") + <*> option auto (long "lb-port" <> value (8080 :: Int) <> Opt.showDefault <> Opt.help "tier 3 port the VM serves on, behind the balancer") + <*> optional (strOption (long "alert-email" <> metavar "ADDRESS" <> Opt.help "tier 1: also declare the standard Cloud Monitoring alerts on the service, to this email (SreBox.Gcp.CloudRunAlerts)")) + -- xor: once one branch has matched, the other flag is rejected by the parser + imageSourceP = + (FromContainerfile <$> strOption (long "containerfile" <> metavar "PATH" <> Opt.help "tier 1: build this Containerfile, with its directory as build context")) + <|> (FromBaseImage <$> strOption (long "base-image" <> metavar "IMAGE" <> value defaultBaseImage <> Opt.showDefault <> Opt.help "tier 1: build `FROM IMAGE`")) + parent = + (SeedOrganization <$> strOption (long "organization" <> metavar "ORG_ID" <> Opt.help "create the project under this organization")) + <|> (SeedFolder <$> strOption (long "folder" <> metavar "FOLDER_ID" <> Opt.help "create the project under this folder")) + <|> flag' SeedExistingProject (long "existing-project" <> Opt.help "do not create, link or delete the project") + <|> (const SeedNoParent <$> switch (long "no-parent" <> Opt.help "create the project with no parent (default)")) + +------------------------------------------------------------------------------- +-- Spec + +data ParentRef = OrganizationParent Text | FolderParent Text | NoParentRef + deriving (Eq, Show, Generic) + +instance FromJSON ParentRef +instance ToJSON ParentRef + +-- | What tier 1 builds. +data ImageSource + = -- | a generated one-line Containerfile, @FROM@ this image + FromBaseImage Text + | -- | the caller's own Containerfile (absolute once configured) + FromContainerfile FilePath + deriving (Eq, Show, Generic) + +instance FromJSON ImageSource +instance ToJSON ImageSource + +-- | Google's Cloud Run sample: a tiny server answering on @$PORT@. +defaultBaseImage :: Text +defaultBaseImage = "us-docker.pkg.dev/cloudrun/container/hello" + +{- | Which side of a 'SreBox.Gcp.VmProvision' hand-off a directive is for. +The tier-2 VM is provisioned by /this same binary/, uploaded and run there +with a directive of its own: 'OnVm' is what it declares once it arrives, and +it names nothing in GCP at all. +-} +data Role = Control | OnVm + deriving (Eq, Show, Generic) + +instance FromJSON Role +instance ToJSON Role + +-- | Tier 2's parameters, resolved. +data VmConfig = VmConfig + { vmZone :: Text + , vmMachineType :: Text + , vmImageFamily :: Text + , vmImageProject :: Text + , vmUser :: Text + , vmSshSourceRange :: Text + , vmIp :: Maybe Text + -- ^ 'Nothing' on the first pass: GCP has not picked it yet. + , vmSelfPath :: Self.SelfPath + , vmMarkerPath :: FilePath + -- ^ what the uploaded binary writes on the VM, as proof it ran there. + } + deriving (Eq, Show, Generic) + +instance FromJSON VmConfig +instance ToJSON VmConfig + +{- | Tier 3's parameters, resolved. + +Carried on the directive rather than being tier-2 fields because the /VM +side/ needs them too: the port the balancer's backend is configured for is +the same port the systemd unit the uploaded binary installs has to listen +on, and there is exactly one place to say it. +-} +data LbConfig = LbConfig + { lbProxyRange :: Text + , lbPort :: Int + } + deriving (Eq, Show, Generic) + +instance FromJSON LbConfig +instance ToJSON LbConfig + +data Spec = Spec + { role :: Role + , project :: Text + , createProjectUnder :: Maybe ParentRef + -- ^ 'Nothing': the project pre-exists and is left alone + , billingAccount :: Maybe Text + , region :: Text + , tier :: Int + , prefix :: Text + , imageTag :: Text + , imageSource :: ImageSource + , workDir :: FilePath + , vmConfig :: Maybe VmConfig + , lbConfig :: Maybe LbConfig + , alertEmail :: Maybe Text + -- ^ tier 1: the standard alerts on the service go here, if anywhere + } + deriving (Eq, Show, Generic) + +instance FromJSON Spec +instance ToJSON Spec + +configure :: Configure IO Seed Spec +configure = Configure $ \seed -> do + let creating = seed.seedParent /= SeedExistingProject + when (creating && seed.seedBillingAccount == Nothing) $ + fail "--billing-account is required when the project is created (pass --existing-project to use one as-is)" + when (seed.seedTier < 0 || seed.seedTier > 3) $ + fail "--tier must be 0, 1, 2 or 3" + -- GCP's own constraints, checked here so a typo fails before anything is created + when (not (validProjectId seed.seedProject)) $ + fail "--project must be 6-30 characters of [a-z0-9-], starting with a letter" + when (Text.length (seed.seedPrefix <> "-sa") > 30 || not (validPrefix seed.seedPrefix)) $ + fail "--prefix must be [a-z0-9-] starting with a letter, at most 27 characters" + source <- case seed.seedImageSource of + FromBaseImage img -> do + when (Text.null img || Text.any (`elem` [' ', '\t', '\n', '\r']) img) $ + fail "--base-image must be a single image reference" + pure (FromBaseImage img) + FromContainerfile path -> do + exists <- doesFileExist path + when (not exists) $ + fail ("--containerfile not found: " <> path) + FromContainerfile <$> makeAbsolute path + dir <- makeAbsolute seed.seedWorkDir + vm <- + if seed.seedTier < 2 + then pure Nothing + else do + self <- Self.readSelfPath_linux + pure $ + Just + VmConfig + { vmZone = maybe (seed.seedRegion <> "-b") id seed.seedVmZone + , vmMachineType = seed.seedVmMachineType + , vmImageFamily = seed.seedVmImageFamily + , vmImageProject = seed.seedVmImageProject + , vmUser = seed.seedVmUser + , vmSshSourceRange = seed.seedSshSourceRange + , vmIp = seed.seedVmIp + , vmSelfPath = self + , vmMarkerPath = "/var/lib/salmon-toy/provisioned" + } + let lb = + if seed.seedTier < 3 + then Nothing + else Just (LbConfig seed.seedLbProxyRange seed.seedLbPort) + pure $ + Spec + { role = Control + , project = seed.seedProject + , createProjectUnder = case seed.seedParent of + SeedOrganization org -> Just (OrganizationParent org) + SeedFolder folder -> Just (FolderParent folder) + SeedNoParent -> Just NoParentRef + SeedExistingProject -> Nothing + , billingAccount = seed.seedBillingAccount + , region = seed.seedRegion + , tier = seed.seedTier + , prefix = seed.seedPrefix + , imageTag = seed.seedImageTag + , imageSource = source + , workDir = dir + , vmConfig = vm + , lbConfig = lb + , alertEmail = if seed.seedTier >= 1 then seed.seedAlertEmail else Nothing + } + where + validProjectId t = + Text.length t >= 6 && Text.length t <= 30 && validPrefix t && not ("-" `Text.isSuffixOf` t) + validPrefix t = + case Text.uncons t of + Just (c, _) -> isAsciiLower c && Text.all (\x -> isAsciiLower x || isDigit x || x == '-') t + Nothing -> False + +------------------------------------------------------------------------------- +-- Program + +program :: Track' Spec +program = Track $ \spec -> case spec.role of + OnVm -> onVm spec + Control -> control spec + +{- | What the uploaded copy of this binary declares once it is running on the +VM: one file, whose existence is the whole proof that the hand-off worked. +-} +onVm :: Spec -> Op +onVm spec = + op "gcp-toy-on-vm" (deps (marker : maybe [] (\lb -> [webServer spec lb]) spec.lbConfig)) $ \actions -> + actions + { help = "the tier-2 payload, declared by this binary running on the VM" + , ref = mkRef "gcp-toy-on-vm" spec.project + } + where + path = maybe "/var/lib/salmon-toy/provisioned" vmMarkerPath spec.vmConfig + marker = FS.filecontents (FS.FileContents path ("provisioned by salmon-gcp-toy for " <> spec.project <> "\n")) + +{- | Tier 3's backend: a page, and a systemd unit serving it. + +Declared on the /VM side/ deliberately. A load balancer whose forwarding rule +merely exists proves nothing -- a balancer in front of no server answers +@502@ just as readily -- so what tier 3 actually checks is a @200@ carrying +the project id, and the only thing that can put that body there is salmon +running on the machine. It is therefore also a second, independent proof +that the tier-2 hand-off worked, this time through the front door. + +@python3@ is on every Ubuntu cloud image (cloud-init is written in it), so +the 'Debian.deb' node here is nearly always a 'Skip' -- it is declared +anyway, because "nearly always" is not a dependency. +-} +webServer :: Spec -> LbConfig -> Op +webServer spec lb = + Systemd.systemdService reportPrint OS.systemctl trackConfig config + where + root :: FilePath + root = "/var/www/salmon-toy" + + trackConfig :: Track' Systemd.Config + trackConfig = Track $ \_ -> + op "setup-salmon-toy-web" (deps [indexFile, Debian.deb (Debian.Package "python3")]) id + + indexFile :: Op + indexFile = + FS.filecontents + ( FS.FileContents + (root <> "/index.html") + ("served by salmon-gcp-toy from " <> spec.project <> "\n") + ) + + config :: Systemd.Config + config = + Systemd.Config + Systemd.System + "/etc/systemd/system" + "salmon-toy-web.service" + (Systemd.Unit "salmon-gcp-toy tier-3 backend" "network-online.target") + ( Systemd.Service + Systemd.Simple + "root" + "root" + "022" + start + Systemd.OnFailure + Systemd.Process + root + ) + (Systemd.Install "multi-user.target") + + start :: Systemd.Start + start = + Systemd.Start + "/usr/bin/python3" + [ "-m" + , "http.server" + , Text.pack (show lb.lbPort) + , "--bind" + , "0.0.0.0" + , "--directory" + , Text.pack root + ] + +control :: Spec -> Op +control spec = + op "gcp-toy" (deps (tier0 spec <> (if spec.tier >= 1 then tier1 spec else []) <> (if spec.tier >= 2 then tier2 spec else []) <> (if spec.tier >= 3 then tier3 spec else []))) $ \actions -> + actions + { help = Text.unwords ["salmon GCP toy validation, tier", Text.pack (show spec.tier), "in", spec.project] + , ref = mkRef "gcp-toy" (spec.project, spec.prefix) + } + +projectOf :: Spec -> Core.Project +projectOf spec = Core.Project spec.project + +regionOf :: Spec -> Core.Region +regionOf spec = Core.Region spec.region + +adc :: Op +adc = Core.applicationDefaultCredentials reportPrint Core.gcloud + +-- | Whatever every project-scoped resource must wait for. +foundation :: Spec -> [Op] +foundation spec = adc : catMaybes [projectNode, billingNode] + where + projectNode = + fmap + ( \parent -> + ResourceManager.project + reportPrint + Core.gcloud + (ResourceManager.ProjectSpec (projectOf spec) (toParent parent) mempty) + `inject` adc + ) + spec.createProjectUnder + billingNode = + fmap + ( \acct -> + foldl + inject + (Billing.linkBillingAccount reportPrint Core.gcloud (projectOf spec) (Billing.BillingAccount acct)) + (adc : catMaybes [projectNode]) + ) + spec.billingAccount + + toParent (OrganizationParent org) = ResourceManager.Organization org + toParent (FolderParent folder) = ResourceManager.Folder folder + toParent NoParentRef = ResourceManager.NoParent + +onFoundation :: Spec -> Op -> Op +onFoundation spec o = foldl inject o (foundation spec) + +api :: Spec -> Text -> Op +api spec name = + onFoundation spec (ServiceUsage.enableService reportPrint Core.gcloud (projectOf spec) (ServiceUsage.Api name)) + +serviceAccountId :: Spec -> Text +serviceAccountId spec = spec.prefix <> "-sa" + +serviceAccountEmail :: Spec -> Text +serviceAccountEmail spec = serviceAccountId spec <> "@" <> spec.project <> ".iam.gserviceaccount.com" + +repo :: Spec -> ArtifactRegistry.ArtifactRepo +repo spec = ArtifactRegistry.ArtifactRepo (spec.prefix <> "-repo") (projectOf spec) (regionOf spec) ArtifactRegistry.Docker + +serviceAccount :: Spec -> Op +serviceAccount spec = + Iam.serviceAccount reportPrint Core.gcloud (projectOf spec) (serviceAccountId spec) + `inject` api spec "iam.googleapis.com" + +repository :: Spec -> Op +repository spec = + ArtifactRegistry.artifactRepository reportPrint Core.gcloud (repo spec) + `inject` api spec "artifactregistry.googleapis.com" + +grant :: Spec -> Text -> Text -> Op +grant spec role resource = + Iam.iamBinding + reportPrint + Core.gcloud + (Iam.IamBinding (Iam.ServiceAccount (serviceAccountEmail spec)) role resource) + `inject` serviceAccount spec + +tier0 :: Spec -> [Op] +tier0 spec = + [ grant spec "roles/storage.objectViewer" ("buckets/" <> bucketName) `inject` bucket + , grant spec "roles/artifactregistry.reader" repoResource `inject` repository spec + ] + where + -- bucket names are global: scoping by project id keeps two sandboxes apart + bucketName = spec.project <> "-" <> spec.prefix + bucket = + Storage.bucket reportPrint Core.gcloud (Storage.Bucket bucketName (projectOf spec) (regionOf spec) True) + `inject` api spec "storage.googleapis.com" + repoResource = + Text.intercalate "/" ["projects", spec.project, "locations", spec.region, "repositories", (repo spec).repoName] + +tier1 :: Spec -> [Op] +tier1 spec = + [ CloudRunDeploy.buildPushDeploy + reportPrint + Core.gcloud + ignoreTrack + CloudRunDeploy.CloudRunDeployConfig + { CloudRunDeploy.crd_repo = repo spec + , CloudRunDeploy.crd_authFile = Podman.AuthFile (spec.workDir <> "/podman-auth.json") + , CloudRunDeploy.crd_containerfile = containerfile + , CloudRunDeploy.crd_image = image + , CloudRunDeploy.crd_service = spec.prefix <> "-hello" + , CloudRunDeploy.crd_project = projectOf spec + , CloudRunDeploy.crd_region = regionOf spec + , CloudRunDeploy.crd_env = mempty + , CloudRunDeploy.crd_serviceAccount = serviceAccountEmail spec + , CloudRunDeploy.crd_ingress = CloudRun.All + , CloudRunDeploy.crd_maxInstances = Just 1 + , CloudRunDeploy.crd_options = CloudRun.defaultCloudRunOptions + } + `inject` api spec "run.googleapis.com" + `inject` repository spec + `inject` serviceAccount spec + ] + <> [ CloudRunAlerts.standardAlerts + reportPrint + Core.gcloud + CloudRunAlerts.CloudRunAlertsConfig + { CloudRunAlerts.cra_project = projectOf spec + , CloudRunAlerts.cra_region = regionOf spec + , CloudRunAlerts.cra_service = spec.prefix <> "-hello" + , CloudRunAlerts.cra_email = email + , CloudRunAlerts.cra_channelName = spec.prefix <> " alerts" + , CloudRunAlerts.cra_maxInstances = Just 1 + , CloudRunAlerts.cra_thresholds = CloudRunAlerts.defaultAlertThresholds + } + `inject` api spec Monitoring.monitoringApi + | Just email <- [spec.alertEmail] + ] + where + image = + Text.concat [spec.region, "-docker.pkg.dev/", spec.project, "/", (repo spec).repoName, "/hello:", spec.imageTag] + containerfile :: FS.File "containerfile" + containerfile = case spec.imageSource of + -- the label makes each --image-tag build a distinct image rather + -- than the base image re-pushed under another name + FromBaseImage base -> + FS.generateFileContents + ( Text.unlines + [ "FROM " <> base + , "LABEL salmon-toy-tag=\"" <> spec.imageTag <> "\"" + ] + ) + (spec.workDir <> "/Containerfile") + FromContainerfile path -> FS.PreExisting path + +------------------------------------------------------------------------------- +-- Tier 2: a VM, provisioned over an SSH CA by this same binary. + +tier2 :: Spec -> [Op] +tier2 spec = case spec.vmConfig of + Nothing -> [] + Just vm -> case vm.vmIp of + -- First pass: the address does not have an IP yet, so nothing can + -- name the machine. Declare the infrastructure and stop; the driver + -- reads the IP and comes back with --vm-ip. + Nothing -> [infrastructure spec vm] + Just ip -> [provisioned spec vm ip] + +-- | The address, the firewall opening, the startup script, and the VM. +infrastructure :: Spec -> VmConfig -> Op +infrastructure spec vm = + op "gcp-toy-vm-infra" (deps [instanceNode spec vm]) $ \actions -> + actions + { help = Text.unwords ["reserves an address and boots", vmName spec] + , ref = mkRef "gcp-toy-vm-infra" (spec.project, vmName spec) + } + +provisioned :: Spec -> VmConfig -> Text -> Op +provisioned spec vm ip = + VmProvision.provisionedVm + reportPrint + Core.gcloud + OS.sshClient + VmProvision.VmProvisionConfig + { VmProvision.vmp_name = vmName spec + , VmProvision.vmp_instance = gceInstance spec vm + , VmProvision.vmp_ca = caKey spec + , VmProvision.vmp_clientIdentity = clientKey spec + , VmProvision.vmp_sshUser = vm.vmUser + , VmProvision.vmp_sshHost = ip + , VmProvision.vmp_sshPort = 22 + , VmProvision.vmp_prerequisites = vmPrerequisites spec vm + , VmProvision.vmp_beforeCall = const [] + , VmProvision.vmp_remoteDir = "/home/" <> Text.unpack vm.vmUser + , VmProvision.vmp_selfPath = vm.vmSelfPath + , VmProvision.vmp_directiveTrack = program + , VmProvision.vmp_directive = spec{role = OnVm} + } + +-- | The instance on its own, for the first pass (which has no IP to ssh to). +instanceNode :: Spec -> VmConfig -> Op +instanceNode spec vm = + foldl inject (Compute.gceInstance reportPrint Core.gcloud (gceInstance spec vm)) (vmPrerequisites spec vm) + +{- | Everything the instance needs to exist before it is created: the +reserved address it claims by name, the firewall rule its sshd needs, and the +startup script its metadata points at. +-} +vmPrerequisites :: Spec -> VmConfig -> [Op] +vmPrerequisites spec vm = + [ computeApi + , -- The CA has to be in project metadata before the instance *boots*, + -- not merely before it is provisioned: the startup script reads the key + -- at boot and nothing re-runs it afterwards. Declared here (rather than + -- left to 'VmProvision', which only appears in the second pass) so the + -- first pass -- the one that creates the VM -- carries it. Both + -- declarations are the same node: same 'Ref', deduped by the fold. + sshCaInMetadata spec + , Compute.address reportPrint Core.gcloud (addressSpec spec) `inject` computeApi + , Compute.firewallRule + reportPrint + Core.gcloud + Compute.FirewallRule + { Compute.firewallName = spec.prefix <> "-ssh" + , Compute.firewallProject = projectOf spec + , Compute.firewallNetwork = "default" + , Compute.firewallAllow = "tcp:22" + , Compute.firewallSourceRanges = [vm.vmSshSourceRange] + , Compute.firewallTargetTags = [sshTag spec] + } + `inject` computeApi + , FS.filecontents (FS.FileContents (startupScriptPath spec) (startupScript vm)) + ] + where + -- every tier-2 resource is a Compute Engine one, and a fresh project has + -- that API off: addresses, firewall rules and instances all answer + -- PERMISSION_DENIED/SERVICE_DISABLED until it is on. + computeApi = api spec "compute.googleapis.com" + +-- | The CA keypair, and its public half published as project metadata. +sshCaInMetadata :: Spec -> Op +sshCaInMetadata spec = + SshAccess.installMetadataCaKey + reportPrint + Core.gcloud + (SshAccess.MetadataSshCa (projectOf spec) (Keys.publicKeyPath (caKey spec))) + `inject` Keys.sshKey reportPrint OS.sshClient (caKey spec) + +addressSpec :: Spec -> Compute.Address +addressSpec spec = Compute.Address (spec.prefix <> "-ip") (projectOf spec) (regionOf spec) + +gceInstance :: Spec -> VmConfig -> Compute.Instance +gceInstance spec vm = + Compute.Instance + { Compute.instanceName = vmName spec + , Compute.instanceProject = projectOf spec + , Compute.instanceZone = Core.Zone vm.vmZone + , Compute.instanceMachineType = Compute.Custom vm.vmMachineType + , Compute.instanceBootDisk = + Compute.BootDisk + { Compute.bootDiskSizeGb = 10 + , Compute.bootDiskImage = Nothing + , Compute.bootDiskImageFamily = Just vm.vmImageFamily + , Compute.bootDiskImageProject = Just vm.vmImageProject + } + , Compute.instanceNetwork = "default" + , Compute.instanceSubnet = "default" + , Compute.instanceServiceAccount = Nothing + , Compute.instanceMetadata = Map.fromList [("enable-oslogin", "FALSE")] + , Compute.instanceMetadataFiles = Map.fromList [("startup-script", startupScriptPath spec)] + , Compute.instanceAddress = Just (addressSpec spec).addressName + , -- tags are fixed at create time, so the tier-3 one has to be on the + -- instance from the first pass -- there is no adding it later to a + -- machine the balancer has already been pointed at. + Compute.instanceTags = [sshTag spec] <> [lbTag spec | spec.tier >= 3] + , Compute.instancePower = Compute.PoweredOn + } + +------------------------------------------------------------------------------- +-- Tier 3: a regional external ALB in front of that VM. + +{- | The balancer and everything GCP insists on having first. + +Three of the four nodes below exist only because a /regional external/ +Application Load Balancer is an Envoy fleet rather than a Google frontend, +and that changes what has to be true before one can be created: + +* it runs its proxies inside the VPC, in a __proxy-only subnet__ that must + already exist in the region, be @ACTIVE@, and belong to the same network + as the backends; +* those proxies reach the backends __from that subnet's range__, so the + backend VMs' own firewall has to allow it -- as does the separate + @35.191.0.0\/16@ + @130.211.0.0\/22@ pair the health checks come from, + which is a different source entirely and the usual reason a balancer that + came up cleanly still answers @502@; +* and a VM is not a backend: an __instance group__ is, so the instance has + to be put in one. +-} +tier3 :: Spec -> [Op] +tier3 spec = case (spec.vmConfig, spec.lbConfig) of + (Just vm, Just lb) -> [balancer spec vm lb] + _ -> [] + +balancer :: Spec -> VmConfig -> LbConfig -> Op +balancer spec vm lb = + foldl + inject + (LoadBalancing.applicationLoadBalancer reportPrint Core.gcloud alb) + ([proxySubnet, membership, backendFirewall] <> served) + where + computeApi = api spec "compute.googleapis.com" + + alb :: LoadBalancing.ApplicationLoadBalancer + alb = + LoadBalancing.ApplicationLoadBalancer + { LoadBalancing.albName = spec.prefix <> "-lb" + , LoadBalancing.albProject = projectOf spec + , LoadBalancing.albRegion = regionOf spec + , -- omitted rather than "default": the forwarding rule falls back + -- to the default network, which is the one everything else here + -- is on, and naming it is one more thing to get wrong. + LoadBalancing.albNetwork = Nothing + , LoadBalancing.albBackends = + [ LoadBalancing.InstanceGroupBackend + (instanceGroupSpec spec vm).groupName + (LoadBalancing.InstanceGroupZone vm.vmZone) + [lb.lbPort] + ] + , LoadBalancing.albHealthCheck = Just (LoadBalancing.HealthCheck (spec.prefix <> "-hc") lb.lbPort) + } + + proxySubnet :: Op + proxySubnet = + Compute.subnet + reportPrint + Core.gcloud + Compute.Subnet + { Compute.subnetName = spec.prefix <> "-proxy" + , Compute.subnetProject = projectOf spec + , Compute.subnetRegion = regionOf spec + , Compute.subnetNetwork = "default" + , Compute.subnetRange = lb.lbProxyRange + , Compute.subnetPurpose = Compute.RegionalManagedProxy + } + `inject` computeApi + + membership :: Op + membership = + Compute.instanceGroupMember + reportPrint + Core.gcloud + (instanceGroupSpec spec vm) + (vmName spec) + `inject` group + `inject` instanceNode spec vm + + group :: Op + group = + Compute.instanceGroup reportPrint Core.gcloud (instanceGroupSpec spec vm) + `inject` computeApi + + backendFirewall :: Op + backendFirewall = + Compute.firewallRule + reportPrint + Core.gcloud + Compute.FirewallRule + { Compute.firewallName = spec.prefix <> "-lb-backend" + , Compute.firewallProject = projectOf spec + , Compute.firewallNetwork = "default" + , Compute.firewallAllow = "tcp:" <> Text.pack (show lb.lbPort) + , Compute.firewallSourceRanges = [lb.lbProxyRange, "35.191.0.0/16", "130.211.0.0/22"] + , Compute.firewallTargetTags = [lbTag spec] + } + `inject` computeApi + + -- On the pass that knows the IP, the balancer is declared *after* the + -- machine has been provisioned, so the backend is already serving by the + -- time the first health check runs. On the first pass there is no such + -- node and the balancer simply comes up in front of an unhealthy backend, + -- which is legal and is what the second pass fixes. + served :: [Op] + served = maybe [] (\ip -> [provisioned spec vm ip]) vm.vmIp + +instanceGroupSpec :: Spec -> VmConfig -> Compute.InstanceGroup +instanceGroupSpec spec vm = + Compute.InstanceGroup (spec.prefix <> "-ig") (projectOf spec) (Core.Zone vm.vmZone) + +vmName :: Spec -> Text +vmName spec = spec.prefix <> "-vm" + +sshTag :: Spec -> Text +sshTag spec = spec.prefix <> "-ssh" + +-- | The tag the tier-3 backend firewall rule targets. +lbTag :: Spec -> Text +lbTag spec = spec.prefix <> "-lb" + +startupScriptPath :: Spec -> FilePath +startupScriptPath spec = spec.workDir <> "/startup-script.sh" + +caKey :: Spec -> Keys.SSHKeyPair +caKey spec = Keys.SSHKeyPair Keys.ED25519 (spec.workDir <> "/ssh") "toy-ca" + +clientKey :: Spec -> Keys.SSHKeyPair +clientKey spec = Keys.SSHKeyPair Keys.ED25519 (spec.workDir <> "/ssh") "toy-client" + +{- | What makes the VM trust the CA at all -- the piece +'Salmon.Builtin.Nodes.Gcp.SshAccess'.@installMetadataCaKey@ deliberately does +not do: it publishes the CA's public key as project metadata, and nothing on +a GCE instance reads that key by itself. + +It also creates the login user the certificate names as its principal (with +no OS Login, a principal has to be a local account), gives it passwordless +sudo (@uploadAndCallSelfAsSudo@ runs the uploaded binary under sudo), and +makes sure rsync is there for the upload. Idempotent, because a startup +script runs on every boot. +-} +startupScript :: VmConfig -> Text +startupScript vm = + Text.unlines + [ "#!/bin/bash" + , "set -eux" + , -- The key is published just before the instance is created, and + -- "just before" is not "already visible from inside the guest": a + -- 404 here used to abort the whole script under `set -e`, leaving a + -- VM with no CA, no login user and an sshd that was never + -- restarted. Waiting is cheap; the alternative is a VM that can + -- only be fixed by a reset. + "for attempt in $(seq 1 30); do" + , " if curl -fsS -H 'Metadata-Flavor: Google' \\" + , " http://metadata.google.internal/computeMetadata/v1/project/attributes/ssh-ca \\" + , " > /etc/ssh/salmon_ca.pub; then break; fi" + , " echo \"ssh-ca not in metadata yet (attempt $attempt)\"; sleep 2" + , "done" + , "test -s /etc/ssh/salmon_ca.pub" + , "chmod 644 /etc/ssh/salmon_ca.pub" + , "grep -qxF 'TrustedUserCAKeys /etc/ssh/salmon_ca.pub' /etc/ssh/sshd_config \\" + , " || echo 'TrustedUserCAKeys /etc/ssh/salmon_ca.pub' >> /etc/ssh/sshd_config" + , "id -u " <> user <> " >/dev/null 2>&1 || useradd -m -s /bin/bash " <> user + , "printf '%s ALL=(ALL) NOPASSWD:ALL\\n' " <> user <> " > /etc/sudoers.d/" <> user + , "chmod 440 /etc/sudoers.d/" <> user + , "command -v rsync >/dev/null || { apt-get update -qq && apt-get install -y rsync; }" + , "systemctl restart ssh || systemctl restart sshd" + ] + where + user = vm.vmUser diff --git a/src/Initializer.hs b/src/Initializer.hs new file mode 100644 --- /dev/null +++ b/src/Initializer.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Initializer where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Options.Applicative (execParser, fullDesc, header, helper, info, long, optional, progDesc, strOption, (<**>)) +import qualified Options.Applicative +import Options.Generic (ParseRecord (..)) + +import qualified Salmon.Builtin.CommandLine as CLI +import Salmon.Builtin.Extension (Track') +import Salmon.Op.Configure (Configure (..)) +import Salmon.Op.Track (Track (..)) +import Salmon.Reporter (reportPrint) + +import qualified SreBox.Initialize as Initialize + +main :: IO () +main = do + let desc = fullDesc <> progDesc "Runs the local-machine salmon setup (sudoers, salmon user/group)" <> header "for Salmon" + let opts = info parseRecord desc + cmd <- execParser opts + CLI.execCommandOrSeed reportPrint configure program cmd + +newtype Seed = Seed + { authorizedKeyFile :: Maybe FilePath + } + deriving (Eq, Show, Generic) + +instance FromJSON Seed +instance ToJSON Seed + +instance ParseRecord Seed where + parseRecord = + build <**> helper + where + build = + Seed + <$> optional + ( strOption + ( long "authorized-key-file" + <> Options.Applicative.help "path to an SSH public key to authorize for the salmon user" + ) + ) + +newtype Spec = Spec + { authorizedKey :: Maybe Text + } + deriving (Eq, Show, Generic) + +instance FromJSON Spec +instance ToJSON Spec + +program :: Track' Spec +program = Track $ \spec -> Initialize.initialize reportPrint spec.authorizedKey + +configure :: Configure IO Seed Spec +configure = Configure $ \seed -> do + mbKey <- traverse readKeyFile seed.authorizedKeyFile + pure (Spec mbKey) + where + readKeyFile :: FilePath -> IO Text + readKeyFile path = Text.strip . Text.pack <$> readFile path diff --git a/src/Migrator.hs b/src/Migrator.hs new file mode 100644 --- /dev/null +++ b/src/Migrator.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Migrator where + +import qualified Data.Text as Text +import Options.Applicative (execParser, fullDesc, header, info, progDesc) +import Options.Generic (ParseRecord (..)) + +import qualified Salmon.Actions.Serve as Serve +import qualified Salmon.Builtin.CommandLine as CLI +import Salmon.Builtin.Extension (Op, Track', deps, notes, op, ref) +import qualified Salmon.Builtin.Nodes.Debian.Package as Debian +import qualified Salmon.Builtin.Nodes.Postgres as Postgres + +import Salmon.Op.Configure (Configure (..)) +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track (Track (..)) +import Salmon.Reporter + +import Migrator.Ops +import Migrator.Seed +import Migrator.Spec + +main :: IO () +main = do + let desc = fullDesc <> progDesc "Standalone db migration tool" <> header "for Postgres" + let opts = info parseRecord desc + cmd <- execParser opts + -- the apt-get collection is a registered rewrite rather than an + -- `Op -> Op` applied inside `program` below: a rewrite runs after the + -- fold, so it sees every declaration `run serve` currently holds and + -- which way each package node is wanted, and it can emit a removal batch + -- as well as an install one. Neither is expressible in `Track' Spec`, + -- which is a function of one directive alone. + CLI.execCommandOrSeedWithRewrites + Serve.reportText + reportPrint + [Debian.batchPackages reportPrint] + configure + program + cmd + +program :: Track' Spec +program = + go 0 + where + go n = Track $ \spec -> + op "program" (deps $ specOp (n + 1) spec) $ \actions -> + actions + { notes = [Text.pack $ "at depth " <> show n] + , ref = mkRef "program" n + } + + specOp :: Int -> Spec -> [Op] + -- meta + specOp _ (Migrate setup1 setup2) = [migrate setup2 `inject` migrateSuperUser setup1] + specOp _ (BuildTemplate setup1 setup2 fp) = [buildTemplate fp setup1 setup2] + specOp _ (Clone retention c) = [cloneOp retention c] + +configure :: Configure IO Seed Spec +configure = Configure go + where + go :: Seed -> IO Spec + go (Seed mode root1 tip1 root2 tip2 dbname username passfile extrausers) = do + setup1 <- prepare root1 tip1 dbname username extrausers passfile + setup2 <- prepare root2 tip2 dbname username extrausers passfile + case mode of + InPlace -> pure $ Migrate setup1 setup2 + AsTemplate -> BuildTemplate setup1 setup2 <$> fingerprintInputs setup1 setup2 + go (CloneSeed dbname template owner retain) = + pure $ + Clone + (if retain then Postgres.Retain else Postgres.Discard) + (Postgres.Clone dbname template owner) diff --git a/src/Migrator/Ops.hs b/src/Migrator/Ops.hs new file mode 100644 --- /dev/null +++ b/src/Migrator/Ops.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Migrator.Ops where + +import Data.Foldable (toList) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import Salmon.Builtin.Extension (Op, Track', ignoreTrack) +import qualified Salmon.Builtin.Migrations as Migrations +import qualified Salmon.Builtin.Nodes.Debian.OS as Debian +import Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Postgres as Postgres +import qualified Salmon.Builtin.Nodes.Secrets as Secrets +import qualified SreBox.PostgresInit as PGInit +import qualified SreBox.PostgresMigrations as PGMigrate +import qualified SreBox.PostgresTemplate as PGTemplate +import System.FilePath (takeDirectory, ()) + +import Salmon.Op.G (G (..)) +import Salmon.Op.OpGraph (inject, node) +import Salmon.Op.Track (Track (..)) +import Salmon.Reporter + +loadMigrations :: FilePath -> FilePath -> IO (G PGMigrate.MigrationFile) +loadMigrations root tip = + let reader = + Migrations.addFilePrefix root $ + PGMigrate.defaultMigrationReader + in G . fmap node <$> Migrations.loadMigrations reader tip + +prepare :: + FilePath -> + FilePath -> + Text -> + Text -> + [Text] -> + FilePath -> + IO PGMigrate.MigrationSetup +prepare root tip dbname migrateusername extrausernames passfile = + PGMigrate.MigrationSetup + <$> loadMigrations root tip + <*> pure (Postgres.User migrateusername) + <*> pure (Postgres.Database dbname) + <*> pure passfile + <*> pure [(Postgres.User u, passfileForUser u) | u <- extrausernames] + where + passfileForUser :: Text -> FilePath + passfileForUser u = takeDirectory passfile (Text.unpack $ u <> ".pass") + +migrateSuperUser :: PGMigrate.MigrationSetup -> Op +migrateSuperUser arg = + runMigration + where + runMigration :: Op + runMigration = + PGMigrate.applyAdminScriptMigration + reportPrint + Debian.psql + (Track $ PGInit.setupNakedPG reportPrint) + arg + +migrate :: PGMigrate.MigrationSetup -> Op +migrate arg = + runMigration + where + initPg = Track (\connstring -> initdb connstring `inject` passfile connstring) + + initdb :: Postgres.ConnString FilePath -> Op + initdb ownerConnstring = + PGInit.setupMultiUserPG + reportPrint + ownerConnstring + [(u, p, [], []) | (u, p) <- users] + [] + + users :: [(Postgres.User, FS.File "passfile")] + users = [(u, FS.Generated extrapassfile p) | (u, p) <- arg.setup_extra_users] + + passfile :: Postgres.ConnString FilePath -> Op + passfile conn = + Secrets.sharedSecretFile + reportPrint + Debian.openssl + (Secrets.Secret Secrets.Hex 48 conn.connstring_user_pass) + + extrapassfile :: Track' FilePath + extrapassfile = Track $ \path -> + Secrets.sharedSecretFile + reportPrint + Debian.openssl + (Secrets.Secret Secrets.Hex 48 path) + + runMigration :: Op + runMigration = + PGMigrate.applyUserScriptMigration + reportPrint + Debian.psql + initPg + arg + +{- | The migrations of both sets, built into a template database. + +Same two migration graphs, same order, same users as 'migrate' and +'migrateSuperUser' -- only walked from inside the template node, behind its +check, so that a template already built from these files is not touched at +all (see "SreBox.PostgresTemplate" for why it cannot be an ordinary +dependency). +-} +buildTemplate :: Text -> PGMigrate.MigrationSetup -> PGMigrate.MigrationSetup -> Op +buildTemplate fp superuser owner = + PGTemplate.template + reportPrint + (Track $ Postgres.pgLocalCluster reportPrint Debian.postgres Debian.pg_ctlcluster) + Debian.psql + Postgres.localServer + (PGTemplate.Template owner.setup_database.getDatabase fp) + (migrate owner `inject` migrateSuperUser superuser) + +{- | What a template is built from: every migration file's path and contents, +each set tagged so moving a file from one to the other counts as a change, +plus the database and roles, which end up baked into the template's +ownership and grants. +-} +{- | Copies a preview environment's database from a template already built +by 'buildTemplate' / @salmon-migrator template@ on this same cluster. + +The template is named, not tracked: this binary has no graph position for +"the template got built", only a name it trusts is already there (an +already-run @template@ invocation, out of band -- see 'Salmon.Builtin.Extension.ignoreTrack'). +'Postgres.cloneDatabase' refuses to run against a database it did not +itself create as a clone, so this is safe to re-run. +-} +cloneOp :: Postgres.Retention -> Postgres.Clone -> Op +cloneOp retention c = + Postgres.cloneDatabase + reportPrint + Debian.psql + Postgres.localServer.serverPort + ignoreTrack + retention + c + +fingerprintInputs :: PGMigrate.MigrationSetup -> PGMigrate.MigrationSetup -> IO Text +fingerprintInputs superuser owner = do + superuserFiles <- PGTemplate.fileFingerprintParts (paths superuser) + ownerFiles <- PGTemplate.fileFingerprintParts (paths owner) + pure $ + PGTemplate.fingerprint $ + ["superuser"] + <> superuserFiles + <> ["owner"] + <> ownerFiles + <> ["database", Text.encodeUtf8 owner.setup_database.getDatabase, "owner", Text.encodeUtf8 owner.setup_user.userRole] + <> ["user:" <> Text.encodeUtf8 u.userRole | (u, _) <- owner.setup_extra_users] + where + paths :: PGMigrate.MigrationSetup -> [FilePath] + paths setup = [m.path | m <- toList setup.setup_migration] diff --git a/src/Migrator/Seed.hs b/src/Migrator/Seed.hs new file mode 100644 --- /dev/null +++ b/src/Migrator/Seed.hs @@ -0,0 +1,123 @@ +module Migrator.Seed where + +import Data.Text (Text) +import qualified Data.Text as Text +import Options.Applicative (command, commandGroup, flag, fullDesc, header, help, helper, info, long, many, optional, progDesc, strOption, subparser, value, (<**>)) + +import Options.Generic (ParseRecord (..)) + +-- | What the migrations are applied to. +data Mode + = -- | a live database, moved forward in place + InPlace + | -- | a template database, rebuilt from nothing whenever they change + AsTemplate + +data Seed + = Seed + { migrateMode :: Mode + , migrateRoot_superuser :: FilePath + , migrateTip_superuser :: FilePath + , migrateRoot :: FilePath + , migrateTip :: FilePath + , migrateDatabase :: Text + , migrateUser :: Text + , migratePassFile :: FilePath + , migrateExtraUsers :: [Text] + } + | -- | Copies a preview environment's database from an already-built + -- template. See @salmon-migrator clone --help@. + CloneSeed + { cloneSeedDatabase :: Text + -- ^ the new database's name -- typically derived from a branch, e.g. + -- @preview_\@ + , cloneSeedTemplate :: Text + -- ^ the template database's name, as built by @salmon-migrator template --db=...@ + , cloneSeedOwner :: Maybe Text + -- ^ role to own the new database; must already exist on this cluster + , cloneSeedRetain :: Bool + -- ^ @True@: @down@/teardown leaves the database in place (a still-open + -- PR). @False@: @down@ drops it (a merged/closed PR). + } + +instance ParseRecord Seed where + parseRecord = + combo <**> helper + where + combo = + subparser $ + mconcat + [ commandGroup "pg" + , command + "migrate" + (info (build InPlace) (header "Migrate" <> fullDesc <> progDesc description)) + , command + "template" + (info (build AsTemplate) (header "Template" <> fullDesc <> progDesc templateDescription)) + , command + "clone" + (info buildClone (header "Clone" <> fullDesc <> progDesc cloneDescription)) + ] + templateDescription :: String + templateDescription = + unlines + [ "Builds a template database from the same migrations `migrate` applies." + , "" + , "The database named by --db is created from nothing, migrated, then locked" + , "(IS_TEMPLATE, no connections), so `CREATE DATABASE x TEMPLATE ` copies it." + , "It is skipped while the migration files are unchanged, and dropped and" + , "rebuilt when any of them change -- never migrated in place." + , "" + , "Roles are cluster-wide: the owner and extra users are those of this cluster," + , "and objects inside a clone keep the owners they have here." + , "Refuses to replace a database salmon did not build as a template." + ] + description :: String + description = + unlines + [ "Migrates PostgreSQL files on a Debian-like." + , "" + , "Assumes two sets of migrations: admin and user." + , "Admin migrations run first as the `postgres` system user." + , "User migrations run with a user-name and a password (in a password file)." + ] + cloneDescription :: String + cloneDescription = + unlines + [ "Copies a database from a template already built by `template`." + , "" + , "Does not migrate anything: the template must already be locked on this" + , "cluster (run `template` first, or point at a template some other run of" + , "this cluster already built). Meant for preview environments: one clone per" + , "branch, named from the branch." + , "" + , "--retain keeps the clone on `down` (an open PR's environment); without it," + , "`down` drops the database (a merged/closed PR). Refuses to touch a database" + , "salmon did not itself clone." + ] + build mode = + Seed mode + <$> strOption + (long "superuser-root" <> Options.Applicative.help "root of migration files [database superuser]" <> value "migrations/superuser") + <*> strOption + (long "superuser-tip" <> Options.Applicative.help "tip of migration files [database superuser]" <> value "tip.sql") + <*> strOption + (long "owner-root" <> Options.Applicative.help "root of migration files [database owner]" <> value "migrations/owner") + <*> strOption + (long "owner-tip" <> Options.Applicative.help "tip of migration files [database owner]" <> value "tip.sql") + <*> strOption + (long "db" <> Options.Applicative.help "dbname") + <*> strOption + (long "db-owner" <> Options.Applicative.help "username [database owner]") + <*> strOption + (long "db-passfile" <> Options.Applicative.help "passfile") + <*> ( many $ + strOption + (long "db-extra-user" <> Options.Applicative.help "username [database user]") + ) + buildClone = + CloneSeed + <$> (Text.pack <$> strOption (long "db" <> Options.Applicative.help "name of the database to create (the clone)")) + <*> (Text.pack <$> strOption (long "template" <> Options.Applicative.help "name of the template database to copy from")) + <*> optional (Text.pack <$> strOption (long "db-owner" <> Options.Applicative.help "role to own the clone [default: postgres]")) + <*> flag False True (long "retain" <> Options.Applicative.help "keep the clone on teardown (`down`) instead of dropping it") diff --git a/src/Migrator/Spec.hs b/src/Migrator/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Migrator/Spec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Migrator.Spec where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import qualified Salmon.Builtin.Nodes.Postgres as Postgres +import qualified SreBox.PostgresMigrations as PGMigrate + +data Spec + = Migrate + { migrateAsSuperUser :: PGMigrate.MigrationSetup + , migrateAsOwner :: PGMigrate.MigrationSetup + -- todo: some PGInit.InitSetup + } + | BuildTemplate + { templateAsSuperUser :: PGMigrate.MigrationSetup + , templateAsOwner :: PGMigrate.MigrationSetup + , templateFingerprint :: Text + -- ^ resolved by @configure@, on the machine holding the migration files + } + | -- | Copies a preview environment's database from an already-built + -- template (see 'BuildTemplate'). Does not migrate anything itself -- + -- @salmon-migrator template@ must have already locked + -- 'cloneTemplateName' on this cluster. The template is referenced by + -- name only ('Salmon.Builtin.Extension.ignoreTrack'): this command + -- does not know or care how the template got there, only that it did. + Clone + { cloneRetention :: Postgres.Retention + , cloneSpec :: Postgres.Clone + } + deriving (Generic) +instance FromJSON Spec +instance ToJSON Spec diff --git a/src/PatroniRootfs.hs b/src/PatroniRootfs.hs new file mode 100644 --- /dev/null +++ b/src/PatroniRootfs.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | The root filesystems of the three-VM Patroni harness +(@specs\/pg-patroni.md@, "Disaster scenarios"). + +The guests have no network past boot, so every package a scenario needs is +baked in here: @postgresql@, @patroni@, @etcd-server@ and @haproxy@ on all +three machines (a scenario decides which member runs which). It is the +same shape as @salmon-toy-qemu-pg-ha prereqs@ -- 'Debootstrap.rootTree' plus +'Debootstrap.ensureVm9pBoot' -- and is the only part that needs root: + +> t=$(cabal list-bin salmon-patroni-rootfs) +> sudo $t config prereqs | sudo $t run up + +The rootfses land where "Test.PatroniVms" looks for them +(@\/var\/lib\/salmon-test-vms\/patroni-{1,2,3}\/root@). The test harness +writes each guest's SSH trust into its rootfs at boot, so the only other +thing provisioned here is that each guest's @\/etc\/ssh@ belongs to whoever +runs the tests. +-} +module PatroniRootfs (main) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Options.Applicative (command, execParser, fullDesc, header, helper, info, long, progDesc, strOption, subparser, value, (<**>)) +import qualified Options.Applicative as Opt +import Options.Generic (ParseRecord (..)) +import System.Environment (lookupEnv) +import System.FilePath (()) +import System.Posix.User (getEffectiveUserName) + +import qualified Salmon.Builtin.CommandLine as CLI +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.Binary as Binary +import qualified Salmon.Builtin.Nodes.Debian.Debootstrap as Debootstrap +import Salmon.Builtin.Nodes.Debian.Package (Package (..)) +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import Salmon.Op.Configure (Configure (..)) +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track (Track (..)) +import Salmon.Reporter (reportPrint) + +main :: IO () +main = do + let desc = + fullDesc + <> progDesc "Root filesystems for the three-VM Patroni test harness" + <> header "salmon-patroni-rootfs" + cmd <- execParser (info parseRecord desc) + CLI.execCommandOrSeed reportPrint configure program cmd + +newtype Seed = SeedPrereqs {seedRoot :: FilePath} + +instance ParseRecord Seed where + parseRecord = combo <**> helper + where + combo = + subparser $ + command "prereqs" (info (SeedPrereqs <$> rootOpt) (progDesc "the three root filesystems -- needs root")) + rootOpt = strOption (long "root" <> Opt.help "where the guests' root filesystems live" <> value defaultRoot) + +data Spec = Prereqs + { specRoot :: FilePath + , specOwner :: Text + -- ^ who runs the tests afterwards, and so must own each guest's @\/etc\/ssh@ + } + deriving (Generic) + +instance FromJSON Spec +instance ToJSON Spec + +-- | Where "Test.PatroniVms" expects to find them. +defaultRoot :: FilePath +defaultRoot = "/var/lib/salmon-test-vms" + +-- | One rootfs per guest. Named by number, not role: which member leads is Patroni's business. +guests :: [Int] +guests = [1, 2, 3] + +rootfsOf :: FilePath -> Int -> FilePath +rootfsOf root n = root ("patroni-" <> show n) "root" + +-- | What every guest carries; the guests cannot install anything after boot. +patroniPackages :: Debootstrap.Includes +patroniPackages = + Debootstrap.vmEssentials + <> map Package ["postgresql", "sudo", "patroni", "etcd-server", "etcd-client", "haproxy"] + +configure :: Configure IO Seed Spec +configure = Configure $ \(SeedPrereqs root) -> Prereqs root <$> unprivilegedUser + +-- | The user who typed @sudo@, since real root has nobody to hand the rootfs to. +unprivilegedUser :: IO Text +unprivilegedUser = do + sudoUser <- lookupEnv "SUDO_USER" + case sudoUser of + Just u | not (null u) -> pure (Text.pack u) + _ -> do + me <- getEffectiveUserName + if me == "root" + then fail "run `prereqs` with sudo, or pass SUDO_USER: somebody unprivileged has to own /etc/ssh afterwards" + else pure (Text.pack me) + +program :: Track' Spec +program = Track $ \(Prereqs root owner) -> + op "patroni-prereqs" (deps (map (rootfsFor root owner) guests)) $ \actions -> + actions + { help = "root filesystems for the Patroni harness's guests" + , notes = ["owned afterwards by " <> owner] + , ref = mkRef "patroni-prereqs" root + } + +rootfsFor :: FilePath -> Text -> Int -> Op +rootfsFor root owner n = + handOver `inject` bootable + where + tree = Debootstrap.RootTree Debootstrap.Stable (rootfsOf root n) patroniPackages + bootable = + Debootstrap.ensureVm9pBoot reportPrint bashTrack tree + `inject` Debootstrap.rootTree reportPrint debootstrapTrack tree + handOver = FS.ownedFile (FS.FileOwnership (rootfsOf root n "etc/ssh") (Just owner) Nothing 0o755) + +bashTrack :: Track' (Binary.Binary "bash") +bashTrack = ignoreTrack + +debootstrapTrack :: Track' (Binary.Binary "debootstrap") +debootstrapTrack = ignoreTrack diff --git a/src/PgBackup.hs b/src/PgBackup.hs new file mode 100644 --- /dev/null +++ b/src/PgBackup.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | @salmon-pg-backup@: take a Postgres dump, here or on another machine, or +install the job that keeps taking one. + +Two axes, chosen independently, which is the whole shape of the binary: + +* __what to do__ — @--action dump@ takes one backup now; @--action schedule@ + installs a @cron.d@ entry (and takes one immediately, so a broken + credential is discovered now rather than at 03:17 tomorrow). +* __where__ — with no @--over@, on this machine. With @--over user\@host@, + this binary uploads /itself/ to that machine, runs there with the same + directive (role flipped), and — for @dump@ — pulls the resulting file + back. + +That is four useful combinations out of two flags, and the remote ones need +nothing installed on the target beyond @rsync@, @bash@ and a Postgres client: +the salmon binary that does the work is the one you are already running. + += Why the timestamp is frozen in the directive + +A dump is named after the moment it is taken, and the machine that wants to +/fetch/ it is not the machine that takes it. If each side asks its own clock, +the two disagree whenever they land either side of a second — rarely, which +is the worst frequency for a bug of this kind. So @configure@ resolves the +timestamp once, on the controlling machine, and it travels in the directive. +Both ends then name the same file, and re-running the same directive is +idempotent: the node's check sees the dump already there and skips it. + += Credentials + +Never on a command line. @--pgpass@, @--pg-service@ and @--client-cert@ all +become environment variables (see +"SreBox.PostgresBackup".'SreBox.PostgresBackup.Credentials'); the default is +peer authentication as a local OS user over the unix socket, which needs no +credential at all and is what a job running on the database host should use. +This binary creates none of them: getting a credential onto a machine is a +separate problem with a separate answer per site. +-} +module PgBackup ( + main, + Seed (..), + Spec (..), + Role (..), + Action (..), + RemoteSpec (..), + configure, + program, + remoteDumpPath, +) where + +import Control.Monad (when) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (defaultTimeLocale, formatTime, getCurrentTime) +import GHC.Generics (Generic) +import Options.Applicative (auto, execParser, fullDesc, header, helper, info, long, metavar, option, optional, progDesc, strOption, value, (<**>), (<|>)) +import qualified Options.Applicative as Opt +import Options.Generic (ParseRecord (..)) +import System.FilePath (()) + +import qualified Salmon.Builtin.CommandLine as CLI +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.CronTask as Cron +import qualified Salmon.Builtin.Nodes.Debian.OS as OS +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Postgres as Postgres +import qualified Salmon.Builtin.Nodes.Rsync as Rsync +import qualified Salmon.Builtin.Nodes.Self as Self +import qualified Salmon.Builtin.Nodes.Ssh as Ssh +import Salmon.Op.Configure (Configure (..)) +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track (Track (..), trackedGraph) +import Salmon.Reporter (reportPrint) + +import qualified SreBox.PostgresBackup as Backup + +main :: IO () +main = do + let desc = fullDesc <> progDesc "Take or schedule a Postgres backup, here or over ssh" <> header "salmon-pg-backup" + cmd <- execParser (info parseRecord desc) + CLI.execCommandOrSeed reportPrint configure program cmd + +------------------------------------------------------------------------------- +-- Seed + +data Seed = Seed + { seedDatabase :: Text + , seedPgRole :: Maybe Text + , seedHost :: Maybe Text + , seedPort :: Int + , seedSudoUser :: Maybe Text + , seedDir :: FilePath + , seedScript :: Maybe FilePath + , seedCronUser :: Text + , seedCredentials :: Backup.Credentials + , seedPrefix :: Maybe Text + , seedTimestampFormat :: Text + , seedSuffix :: Text + , seedRetentionDays :: Int + , seedMaxAgeHours :: Int + , seedHour :: Text + , seedMinute :: Text + , seedGcsBucket :: Maybe Text + , seedGcsPrefix :: Text + , seedAction :: Action + , seedOver :: Maybe Text + , seedRemoteDir :: FilePath + , seedIdentity :: Maybe FilePath + , seedKnownHosts :: Maybe FilePath + , seedFetchInto :: Maybe FilePath + } + deriving (Eq, Show) + +instance ParseRecord Seed where + parseRecord = + build <**> helper + where + build = + Seed + <$> strOption (long "database" <> metavar "DB" <> Opt.help "database to dump") + <*> optional (strOption (long "pg-role" <> metavar "ROLE" <> Opt.help "connect as this database role (default: whatever the OS user maps to)")) + <*> optional (strOption (long "host" <> metavar "HOST" <> Opt.help "connect over TCP to this host (default: the local unix socket, which is the only place peer auth exists)")) + <*> option auto (long "port" <> value 5432 <> Opt.showDefault <> Opt.help "port, when --host is given") + <*> sudoUserP + <*> strOption (long "dir" <> value "/var/backups/postgresql" <> Opt.showDefault <> Opt.help "where dumps are written, on whichever machine runs the dump") + <*> optional (strOption (long "script" <> metavar "PATH" <> Opt.help "where the generated script is written (default: /opt/salmon/postgres/backup-.sh)")) + <*> strOption (long "cron-user" <> value "root" <> Opt.showDefault <> Opt.help "the user the cron entry runs as") + <*> credentialsP + <*> optional (strOption (long "prefix" <> metavar "NAME" <> Opt.help "dump filename prefix (default: the database name)")) + <*> strOption (long "timestamp-format" <> value "%Y%m%d_%H%M%S" <> Opt.showDefault <> Opt.help "date(1) format for the timestamp in the filename") + <*> strOption (long "suffix" <> value ".sql.gz" <> Opt.showDefault <> Opt.help "dump filename suffix") + <*> option auto (long "retention-days" <> value 7 <> Opt.showDefault <> Opt.help "delete local dumps older than this") + <*> option auto (long "max-age-hours" <> value 26 <> Opt.showDefault <> Opt.help "how old the newest dump may be before the freshness check fails") + <*> strOption (long "hour" <> value "3" <> Opt.showDefault <> Opt.help "schedule: hour") + <*> strOption (long "minute" <> value "17" <> Opt.showDefault <> Opt.help "schedule: minute (an odd one, so a fleet does not stampede)") + <*> optional (strOption (long "gcs-bucket" <> metavar "BUCKET" <> Opt.help "also copy each dump to this GCS bucket")) + <*> strOption (long "gcs-prefix" <> value "" <> Opt.help "path prefix inside the bucket") + <*> actionP + <*> optional (strOption (long "over" <> metavar "USER@HOST" <> Opt.help "do the work on this machine instead, by uploading this binary to it")) + <*> strOption (long "remote-dir" <> value "/tmp" <> Opt.showDefault <> Opt.help "where this binary is uploaded on the remote") + <*> optional (strOption (long "ssh-identity" <> metavar "PATH" <> Opt.help "ssh private key for --over")) + <*> optional (strOption (long "ssh-known-hosts" <> metavar "PATH" <> Opt.help "known_hosts file for --over")) + <*> optional (strOption (long "fetch-into" <> metavar "DIR" <> Opt.help "with --over and --action dump: pull the dump back into this local directory")) + + -- `--sudo-user` has a default, so it can never be *absent*; opting + -- out needs a flag of its own. + sudoUserP = + Opt.flag' Nothing (long "no-sudo" <> Opt.help "run pg_dump as the current user rather than via sudo") + <|> (Just <$> strOption (long "sudo-user" <> value "postgres" <> Opt.showDefault <> Opt.help "run pg_dump as this OS user")) + + actionP = + Opt.option + (Opt.eitherReader parseAction) + (long "action" <> value DumpNow <> metavar "dump|schedule" <> Opt.help "take one backup now, or install the periodic job") + + parseAction "dump" = Right DumpNow + parseAction "schedule" = Right InstallSchedule + parseAction other = Left ("expected dump or schedule, got: " <> other) + + -- xor by construction: the first branch that matches wins, and the + -- flags are distinct, so no two credential mechanisms can be given. + credentialsP = + (Backup.PassFile <$> strOption (long "pgpass" <> metavar "PATH" <> Opt.help "a .pgpass file (PGPASSFILE)")) + <|> ( Backup.ServiceFile + <$> strOption (long "pg-service-file" <> metavar "PATH" <> Opt.help "a libpq service file (PGSERVICEFILE)") + <*> strOption (long "pg-service" <> metavar "NAME" <> Opt.help "the service to use from it (PGSERVICE)") + ) + <|> ( Backup.ClientCertificate + <$> strOption (long "client-cert" <> metavar "PATH" <> Opt.help "client certificate (PGSSLCERT)") + <*> strOption (long "client-key" <> metavar "PATH" <> Opt.help "client key (PGSSLKEY)") + <*> strOption (long "client-ca" <> metavar "PATH" <> Opt.help "CA certificate (PGSSLROOTCERT)") + ) + <|> pure Backup.PeerAuth + +------------------------------------------------------------------------------- +-- Spec + +{- | Which side of the hand-off a directive is for. 'OnTarget' is what the +uploaded copy of this binary receives; it names no remote of its own, which +is what stops a directive bouncing forever. +-} +data Role = Controller | OnTarget + deriving (Eq, Show, Generic) + +instance FromJSON Role +instance ToJSON Role + +data Action = DumpNow | InstallSchedule + deriving (Eq, Show, Generic) + +instance FromJSON Action +instance ToJSON Action + +data RemoteSpec = RemoteSpec + { rs_user :: Text + , rs_host :: Text + , rs_selfDir :: FilePath + , rs_identity :: Maybe FilePath + , rs_knownHosts :: Maybe FilePath + } + deriving (Eq, Show, Generic) + +instance FromJSON RemoteSpec +instance ToJSON RemoteSpec + +data Spec = Spec + { role :: Role + , action :: Action + , backup :: Backup.PgBackupConfig + , stamp :: Maybe Text + -- ^ the frozen timestamp; see the module header + , remote :: Maybe RemoteSpec + , fetchInto :: Maybe FilePath + , selfPath :: Maybe Self.SelfPath + } + deriving (Eq, Show, Generic) + +instance FromJSON Spec +instance ToJSON Spec + +configure :: Configure IO Seed Spec +configure = Configure $ \seed -> do + when (seed.seedFetchInto /= Nothing && seed.seedOver == Nothing) $ + fail "--fetch-into only means something with --over (without it, the dump is already local)" + when (seed.seedFetchInto /= Nothing && seed.seedAction /= DumpNow) $ + fail "--fetch-into only means something with --action dump" + -- Frozen here, on the controlling machine, so both ends of a driven + -- backup name the same file. A scheduled job must NOT have one, or every + -- run would overwrite a single dump forever. + frozen <- case seed.seedAction of + InstallSchedule -> pure Nothing + DumpNow -> do + now <- getCurrentTime + pure (Just (Text.pack (formatTime defaultTimeLocale (Text.unpack seed.seedTimestampFormat) now))) + self <- traverse (const Self.readSelfPath_linux) seed.seedOver + remoteSpec <- traverse (parseOver seed) seed.seedOver + pure $ + Spec + { role = Controller + , action = seed.seedAction + , backup = backupConfig seed frozen + , stamp = frozen + , remote = remoteSpec + , fetchInto = seed.seedFetchInto + , selfPath = self + } + where + parseOver :: Seed -> Text -> IO RemoteSpec + parseOver seed spec = + case Text.breakOn "@" spec of + (user, rest) + | Just host <- Text.stripPrefix "@" rest + , not (Text.null user) + , not (Text.null host) -> + pure + RemoteSpec + { rs_user = user + , rs_host = host + , rs_selfDir = seed.seedRemoteDir + , rs_identity = seed.seedIdentity + , rs_knownHosts = seed.seedKnownHosts + } + _ -> fail ("--over wants USER@HOST, got: " <> Text.unpack spec) + +backupConfig :: Seed -> Maybe Text -> Backup.PgBackupConfig +backupConfig seed frozen = + Backup.PgBackupConfig + { Backup.pgb_database = seed.seedDatabase + , Backup.pgb_role = seed.seedPgRole + , Backup.pgb_server = fmap (\h -> Postgres.Server h seed.seedPort) seed.seedHost + , Backup.pgb_sudoUser = seed.seedSudoUser + , Backup.pgb_dir = seed.seedDir + , Backup.pgb_scriptPath = + maybe ("/opt/salmon/postgres/backup-" <> Text.unpack seed.seedDatabase <> ".sh") id seed.seedScript + , Backup.pgb_osUser = seed.seedCronUser + , Backup.pgb_credentials = seed.seedCredentials + , Backup.pgb_naming = + Backup.NamingPolicy + { Backup.np_prefix = maybe seed.seedDatabase id seed.seedPrefix + , Backup.np_timestampFormat = seed.seedTimestampFormat + , Backup.np_suffix = seed.seedSuffix + } + , Backup.pgb_fixedTimestamp = frozen + , Backup.pgb_retentionDays = seed.seedRetentionDays + , Backup.pgb_schedule = Cron.dailyAt seed.seedHour seed.seedMinute + , Backup.pgb_gcs = fmap (\b -> Backup.GcsDestination b seed.seedGcsPrefix) seed.seedGcsBucket + , Backup.pgb_maxAge = fromIntegral seed.seedMaxAgeHours * 3600 + } + +------------------------------------------------------------------------------- +-- Program + +program :: Track' Spec +program = Track $ \spec -> case spec.role of + OnTarget -> onTarget spec + Controller -> case spec.remote of + Nothing -> onTarget spec + Just rs -> driven spec rs + +{- | The work itself, on whichever machine is running it. Reached either +directly (no @--over@) or as the uploaded copy. +-} +onTarget :: Spec -> Op +onTarget spec = + op "pg-backup-target" (deps [work]) $ \actions -> + actions + { help = Text.unwords ["backs up", spec.backup.pgb_database, "on this machine"] + , ref = mkRef "pg-backup-target" (spec.backup.pgb_database, spec.backup.pgb_dir) + } + where + work = case spec.action of + InstallSchedule -> Backup.postgresBackup reportPrint OS.bash spec.backup + DumpNow -> case spec.stamp of + -- The named form is what makes a re-run of the same directive a + -- no-op, and it is the only form whose output another machine + -- can name in advance. + Just st -> Backup.namedBackup reportPrint OS.bash spec.backup st + Nothing -> Backup.recentBackup reportPrint OS.bash spec.backup + +{- | Upload this binary to the target, run it there, and (for a dump) pull +the result back. + +The fetch is injected onto the remote call, not merely declared beside it: +rsync would otherwise be racing the dump it is fetching. +-} +driven :: Spec -> RemoteSpec -> Op +driven spec rs = + op "pg-backup-driven" (deps [maybe remoteWork id fetch]) $ \actions -> + actions + { help = Text.unwords ["backs up", spec.backup.pgb_database, "on", rs.rs_host] + , ref = mkRef "pg-backup-driven" (rs.rs_user, rs.rs_host, spec.backup.pgb_database) + } + where + opts = + Ssh.ClientOpts + { Ssh.optIdentity = rs.rs_identity + , Ssh.optKnownHosts = rs.rs_knownHosts + } + + remoteWork :: Op + remoteWork = + trackedGraph $ + Self.uploadAndCallSelfAsSudoWith + opts + reportPrint + reportPrint + rs.rs_selfDir + (Self.Remote rs.rs_user rs.rs_host) + (maybe (error "configure should have read the self path") id spec.selfPath) + Ssh.preExistingRemoteMachine + program + CLI.Up + spec{role = OnTarget, remote = Nothing} + + fetch :: Maybe Op + fetch = do + into <- spec.fetchInto + st <- spec.stamp + let local = into Backup.dumpNameFor spec.backup.pgb_naming st + pure $ + Rsync.receiveFileWith + opts + reportPrint + OS.rsync + (Track FS.dir) + (Rsync.Remote rs.rs_user rs.rs_host) + (remoteDumpPath spec st) + local + `inject` remoteWork + +{- | Where the dump will be on the target, given the frozen timestamp. + +Exposed because it is the contract between the two halves: the remote writes +this path and the controller fetches it, and nothing else reconciles them. +-} +remoteDumpPath :: Spec -> Text -> FilePath +remoteDumpPath spec st = + spec.backup.pgb_dir Backup.dumpNameFor spec.backup.pgb_naming st diff --git a/src/PgPair.hs b/src/PgPair.hs new file mode 100644 --- /dev/null +++ b/src/PgPair.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | A two-machine Postgres pair with a declared primary, and the bouncer +that follows it. + +The whole point of this binary is that moving the primary is an /edit/, not +a procedure: one word of the seed changes, and a pass makes the machines +agree with it. + +> salmon-pgpair config --primary A --a HOST_A --b HOST_B --bouncer HOST_C | salmon-pgpair run up +> salmon-pgpair config --primary B --a HOST_A --b HOST_B --bouncer HOST_C | salmon-pgpair run up + +What it assumes was done before it ever ran, because a recipe that ships +secrets has chosen a transport for everybody who uses it: the two machines +have a Postgres cluster, the bouncer has pgbouncer and a @userlist.txt@, and +all three have the @.pgpass@ files named below. See @specs\/pg-switchover.md@. +-} +module PgPair (main) where + +import Control.Applicative ((<|>)) +import Data.Text (Text) +import qualified Data.Text as Text +import Options.Applicative (auto, execParser, fullDesc, header, help, helper, info, long, option, optional, progDesc, strOption, value, (<**>)) +import Options.Generic (ParseRecord (..)) + +import qualified Salmon.Actions.Serve as Serve +import qualified Salmon.Builtin.CommandLine as CLI +import Salmon.Builtin.Extension (Track') +import Salmon.Op.Configure (Configure (..)) +import Salmon.Op.Track (Track (..)) +import Salmon.Reporter (reportPrint) + +import qualified SreBox.PostgresPair as Pair + +main :: IO () +main = do + let desc = + fullDesc + <> progDesc "A Postgres primary and standby, with the primary's location declared rather than discovered" + <> header "salmon-pgpair" + cmd <- execParser (info parseRecord desc) + CLI.execCommandOrSeedWith Serve.reportText reportPrint configure program cmd + +-- | The directive is the pair itself: there is nothing to resolve later. +program :: Track' Pair.Pair +program = Track (Pair.pairOp reportPrint) + +configure :: Configure IO Seed Pair.Pair +configure = Configure (pure . toPair) + +{- | What an operator types. Everything else about the pair is convention, +which is what makes the interesting part -- @--primary@ -- short enough to +be obviously the only thing that changed. +-} +data Seed + = Seed + { seedName :: Text + , seedPrimary :: Side + , seedMayDiscard :: Maybe Side + , seedSeed :: Maybe Side + , seedReseed :: Maybe Side + , seedHostA :: Text + , seedHostB :: Text + , seedBouncer :: Maybe Text + , seedIdentity :: Maybe FilePath + , seedIdentityA :: Maybe FilePath + , seedIdentityB :: Maybe FilePath + , seedIdentityBouncer :: Maybe FilePath + , seedKnownHosts :: Maybe FilePath + , seedDatabase :: Text + } + +-- | Parsed rather than derived, so that @--primary A@ is what it looks like. +newtype Side = Side {unSide :: Pair.Side} + +instance Read Side where + readsPrec _ s = case span (`notElem` (" \t" :: String)) s of + ("A", rest) -> [(Side Pair.A, rest)] + ("a", rest) -> [(Side Pair.A, rest)] + ("B", rest) -> [(Side Pair.B, rest)] + ("b", rest) -> [(Side Pair.B, rest)] + _ -> [] + +instance ParseRecord Seed where + parseRecord = build <**> helper + where + build = + Seed + <$> strOption (long "name" <> help "what to call this pair" <> value "app") + <*> option auto (long "primary" <> help "which machine should be the primary: A or B") + <*> optional + ( option + auto + ( long "may-discard" + <> help "accept losing the writes on this side that the other does not have; the only thing that makes a failover possible, and it must name the side that is not --primary" + ) + ) + <*> optional + ( option + auto + ( long "seed" + <> help "build this side's cluster from the other one: the first clone of a pair's life (does nothing once the two share a cluster; see --reseed for a standby that has fallen too far behind)" + ) + ) + <*> optional + ( option + auto + ( long "reseed" + <> help "this side's data may be thrown away and cloned again from the other, if (and only if) the primary reports its replication slot lost; it must name the side that is not --primary" + ) + ) + <*> strOption (long "a" <> help "machine A") + <*> strOption (long "b" <> help "machine B") + <*> optional (strOption (long "bouncer" <> help "a pgbouncer whose clients should follow the primary")) + <*> optional (strOption (long "ssh-identity" <> help "a key to reach the machines with")) + -- a fleet usually has one key; these exist because a test + -- harness that mints a CA per guest does not. + <*> optional (strOption (long "ssh-identity-a" <> help "a key for machine A alone")) + <*> optional (strOption (long "ssh-identity-b" <> help "a key for machine B alone")) + <*> optional (strOption (long "ssh-identity-bouncer" <> help "a key for the bouncer alone")) + <*> optional (strOption (long "ssh-known-hosts" <> help "a known-hosts file to learn the machines' keys into")) + <*> strOption (long "db" <> help "the database clients connect to" <> value "app") + +toPair :: Seed -> Pair.Pair +toPair seed = + Pair.Pair + { Pair.pair_name = seed.seedName + , Pair.pair_a = machine (seed.seedIdentityA <|> seed.seedIdentity) seed.seedHostA + , Pair.pair_b = machine (seed.seedIdentityB <|> seed.seedIdentity) seed.seedHostB + , Pair.pair_primary = unSide seed.seedPrimary + , Pair.pair_repl_role = "replicator" + , Pair.pair_repl_passfile = "/etc/postgresql/salmon-replication.pgpass" + , Pair.pair_rewind_role = "rewinder" + , Pair.pair_rewind_passfile = "/etc/postgresql/salmon-rewind.pgpass" + , Pair.pair_ssh_known_hosts = seed.seedKnownHosts + , Pair.pair_catch_up_seconds = 60 + , -- left declared is harmless: the clone does nothing once the two + -- sides share a cluster, and refuses a machine holding somebody + -- else's. + Pair.pair_seed = fmap unSide seed.seedSeed + , Pair.pair_bouncers = foldMap (pure . bouncer) seed.seedBouncer + , Pair.pair_may_discard = fmap unSide seed.seedMayDiscard + , Pair.pair_reseed = fmap unSide seed.seedReseed + } + where + machine identity host = + Pair.Member + { Pair.member_ssh_user = "root" + , Pair.member_host = host + , Pair.member_cluster = "main" + , Pair.member_port = 5432 + , Pair.member_ssh_identity = identity + } + + bouncer host = + Pair.Bouncer + { Pair.bouncer_name = host + , Pair.bouncer_ssh_user = "root" + , Pair.bouncer_ssh_host = host + , Pair.bouncer_ssh_identity = seed.seedIdentityBouncer <|> seed.seedIdentity + , -- pgbouncer's admin console is an ordinary connection to the + -- database named `pgbouncer` on the port clients use + Pair.bouncer_console_user = "router" + , Pair.bouncer_console_port = 6432 + , Pair.bouncer_console_passfile = "/etc/pgbouncer/console.pgpass" + , Pair.bouncer_alias = seed.seedDatabase + , Pair.bouncer_dbname = seed.seedDatabase + , Pair.bouncer_routing_path = "/etc/pgbouncer/routing.ini" + , Pair.bouncer_config_dir = "/etc/pgbouncer" + , Pair.bouncer_listen_port = 6432 + } diff --git a/src/QemuPgHaToy.hs b/src/QemuPgHaToy.hs new file mode 100644 --- /dev/null +++ b/src/QemuPgHaToy.hs @@ -0,0 +1,746 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | A Postgres pair, a pgbouncer in front of it, and a client that keeps +writing while the primary moves — all on qemu guests this binary makes for +itself. + +It is the demo of @specs\/pg-switchover.md@, and the same thing +"Test.PgPairDemoSpec" asserts, in a form a person can watch: + +> t=$(cabal list-bin salmon-toy-qemu-pg-ha) +> sudo $t config prereqs | sudo $t run up # once: three rootfses +> $t config up --primary A --seed B | $t run up # once: the pair, B built from A +> $t config client --seconds 120 | $t run up & # a client, writing +> $t config up --primary B | $t run up # the demo + +The client keeps writing across that last line, and says at the end how many +inserts it was told had happened, how many came back an error, and how many +went missing. Here, on the machine this was written on: + +> PauseBouncers -> StopMember A -> Promote B -> RepointBouncers B -> Rejoin A -> Done +> +> inserts acknowledged through the bouncer: 460 +> inserts that came back an error: 0 +> acknowledged rows missing afterwards: 0 + +@--seed@ is only needed the first time, when B has no cluster to be a copy +of A's: it is safe to leave on (the clone does nothing once the two sides +share a system identifier) and safe to leave off (a pair that is already a +pair does not need it). @--may-discard B@ is the other flag worth trying, +with machine B's guest paused or killed: it is what turns a refusal into a +failover. + += What this needs of the host + +Two capabilities, granted once, and no root after @prereqs@: + +> sudo setcap cap_net_admin+eip $(command -v capsh) +> sudo setcap cap_dac_override,cap_chown,cap_fowner+eip $(command -v qemu-system-x86_64) + +plus membership of the @kvm@ group. @specs\/qemu-test-vms-progress.md@ has +the reasoning, including why the first one is on @capsh@ and not on @ip@. + += Why two seeds + +@prereqs@ is the only part that needs root: debootstrapping a root +filesystem, regenerating its initrd through a chroot, and handing +@\/etc\/ssh@ to whoever will run the rest. Everything after it — the bridge, +the guests, the pair — is an unprivileged user with two capabilities granted +once (see "Salmon.Builtin.Nodes.Qemu" and @specs\/qemu-test-vms.md@). + +Splitting them is not only about privilege. @prereqs@ is slow and rarely +changes; @up@ is the one you re-run, and the whole demo is that re-running it +with one word changed moves a primary under a live client. + += What it is not + +A deployment. The secrets here are constants in the source, because the +point is to be able to read the whole thing: a pair in earnest is handed +@.pgpass@ files that somebody else provisioned, which is why +"SreBox.PostgresPair" takes paths and never passwords. +-} +module QemuPgHaToy (main) where + +import Control.Concurrent (threadDelay) +import Control.Monad (forM_, unless, when) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Options.Applicative (auto, command, execParser, fullDesc, header, helper, info, long, option, optional, progDesc, strOption, subparser, value, (<**>)) +import qualified Options.Applicative as Opt +import Options.Generic (ParseRecord (..)) +import System.Exit (ExitCode (..)) +import Data.Time.Clock (addUTCTime, getCurrentTime) +import System.Directory (createDirectoryIfMissing, doesFileExist, getXdgDirectory, XdgDirectory (XdgConfig)) +import System.FilePath (()) +import System.IO (hFlush, stdout) +import System.Posix.User (getEffectiveUserName) +import System.Environment (getEnvironment, lookupEnv) +import System.Process (CreateProcess (env), proc, readCreateProcessWithExitCode, readProcessWithExitCode) + +import qualified Salmon.Builtin.CommandLine as CLI +import Salmon.Builtin.Extension +import qualified Salmon.Builtin.Nodes.Binary as Binary +import qualified Salmon.Builtin.Nodes.Debian.Debootstrap as Debootstrap +import Salmon.Builtin.Nodes.Debian.Package (Package (..)) +import qualified Salmon.Builtin.Nodes.Filesystem as FS +import qualified Salmon.Builtin.Nodes.Keys as Keys +import qualified Salmon.Builtin.Nodes.LinuxBridge as LinuxBridge +import qualified Salmon.Builtin.Nodes.Qemu as Qemu +import qualified Salmon.Builtin.Nodes.Systemd as Systemd +import Salmon.Op.Configure (Configure (..)) +import Salmon.Op.OpGraph (inject) +import Salmon.Op.Ref (mkRef) +import Salmon.Op.Track (Track (..)) +import Salmon.Actions.UpDown (CheckResult (..)) +import Salmon.Reporter (reportPrint, silent) + +import qualified SreBox.PostgresPair as Pair + +main :: IO () +main = do + let desc = + fullDesc + <> progDesc "A Postgres pair on qemu guests, with a client that keeps writing while the primary moves" + <> header "salmon-toy-qemu-pg-ha" + cmd <- execParser (info parseRecord desc) + CLI.execCommandOrSeed reportPrint configure program cmd + +------------------------------------------------------------------------------- +-- Seed + +data Seed + = SeedPrereqs {seedRoot :: FilePath} + | SeedUp + { seedRoot :: FilePath + , seedPrimary :: Side + , seedClone :: Maybe Side + , seedDiscard :: Maybe Side + } + | SeedClient {seedRoot :: FilePath, seedSeconds :: Int} + +-- | @--primary A@ is what it looks like. +newtype Side = Side {unSide :: Pair.Side} + +instance Read Side where + readsPrec _ s = case span (`notElem` (" \t" :: String)) s of + ("A", r) -> [(Side Pair.A, r)] + ("a", r) -> [(Side Pair.A, r)] + ("B", r) -> [(Side Pair.B, r)] + ("b", r) -> [(Side Pair.B, r)] + _ -> [] + +instance ParseRecord Seed where + parseRecord = combo <**> helper + where + combo = + subparser $ + mconcat + [ command "prereqs" (info (SeedPrereqs <$> rootOpt) (progDesc "root filesystems for the guests -- needs root, and is the only part that does")) + , command + "up" + ( info + (SeedUp <$> rootOpt <*> primaryOpt <*> cloneOpt <*> discardOpt) + (progDesc "the bridge, the three guests, and the pair -- re-run with a different --primary to move it") + ) + , command "client" (info (SeedClient <$> rootOpt <*> secondsOpt) (progDesc "write through the bouncer until interrupted, then say what happened")) + ] + rootOpt = strOption (long "root" <> Opt.help "where the guests' root filesystems live" <> value "/var/lib/salmon-toy-pg-ha") + primaryOpt = option auto (long "primary" <> Opt.help "which guest should be the primary: A or B") + cloneOpt = optional (option auto (long "seed" <> Opt.help "build this side's cluster from the other one (the first time, and after a standby falls too far behind)")) + discardOpt = + optional + ( option + auto + ( long "may-discard" + <> Opt.help "accept losing the writes on this side that the other does not have -- what makes a failover possible, and it must name the side that is not --primary" + ) + ) + secondsOpt = option auto (long "seconds" <> Opt.help "how long to keep writing" <> value 120) + +------------------------------------------------------------------------------- +-- Spec +-- +-- The seed says what the operator wants; the spec says it in terms that +-- need no further looking around. Everything resolved here -- who is +-- running this, where systemd keeps user units, which kernel each rootfs +-- has -- is a fact about /this/ machine, which is what `configure` is for. + +data Spec + = Prereqs + { specRoot :: FilePath + , specOwner :: Text + -- ^ who will run @up@ afterwards, and therefore who must own the + -- @\/etc\/ssh@ that @up@ writes into. + } + | Up + { specRoot :: FilePath + , specPair :: Pair.Pair + , specUser :: Text + , specUnitDir :: FilePath + , specRuntimeDir :: FilePath + -- ^ where qemu's monitor sockets go. Not under @--root@: a unix + -- socket path may be 107 bytes, and a directory deep enough to + -- exceed that produces a guest that will not start, with the reason + -- a long way from the flag that caused it. + , specBoot :: [(Text, FilePath, FilePath)] + -- ^ machine name, kernel, initrd: a debootstrapped rootfs names its + -- kernel after a version nobody can predict. + } + | RunClient + { specPair :: Pair.Pair + , specSeconds :: Int + } + deriving (Generic) + +instance FromJSON Spec +instance ToJSON Spec + +configure :: Configure IO Seed Spec +configure = Configure $ \seed -> case seed of + SeedPrereqs root -> Prereqs root <$> unprivilegedUser + SeedClient root secs -> pure (RunClient (thePair root) secs) + SeedUp root primary clone discard -> do + user <- Text.pack <$> getEffectiveUserName + unitDir <- getXdgDirectory XdgConfig "systemd/user" + runtimeDir <- maybe "/tmp" id <$> lookupEnv "XDG_RUNTIME_DIR" + boots <- traverse (resolveBoot root) machines + pure + ( Up + { specRoot = root + , specPair = + (thePair root) + { Pair.pair_primary = unSide primary + , Pair.pair_seed = fmap unSide clone + , Pair.pair_may_discard = fmap unSide discard + } + , specUser = user + , specUnitDir = unitDir + , specRuntimeDir = runtimeDir + , specBoot = boots + } + ) + where + resolveBoot root m = do + there <- doesFileExist (rootfsOf root m "etc/issue") + unless there $ + fail (rootfsOf root m <> " does not exist yet: run `prereqs` first, as root") + (kernel, initrd) <- Qemu.resolveKernelInitrd (rootfsOf root m) + pure (machineName m, kernel, initrd) + +{- | Whoever will run everything after @prereqs@. + +@prereqs@ is run with sudo, so the interesting answer is the user who typed +it rather than the root it became -- and if this is real root rather than +sudo, there is nobody to hand the rootfs to and saying so beats guessing. +-} +unprivilegedUser :: IO Text +unprivilegedUser = do + sudoUser <- lookupEnv "SUDO_USER" + case sudoUser of + Just u | not (null u) -> pure (Text.pack u) + _ -> do + me <- getEffectiveUserName + when (me == "root") $ + fail "run `prereqs` with sudo, or pass SUDO_USER: somebody unprivileged has to own the rootfs afterwards" + pure (Text.pack me) + +program :: Track' Spec +program = Track $ \spec -> case spec of + Prereqs root owner -> prereqs root owner + Up root pair user unitDir runtimeDir boots -> demo root pair user unitDir runtimeDir boots + RunClient pair secs -> clientOp pair secs + +------------------------------------------------------------------------------- +-- What the toy is made of: three guests on one bridge. + +data Machine = MachineA | MachineB | MachineBouncer + deriving (Eq, Show) + +machines :: [Machine] +machines = [MachineA, MachineB, MachineBouncer] + +machineName :: Machine -> Text +machineName MachineA = "a" +machineName MachineB = "b" +machineName MachineBouncer = "bouncer" + +{- | A bridge of its own (@10.98.0.0\/24@), so that this toy and the test +harness's guests (@10.99.0.0\/24@) can be up at the same time without two +machines answering to one address. +-} +machineAddr :: Machine -> Text +machineAddr MachineA = "10.98.0.2" +machineAddr MachineB = "10.98.0.3" +machineAddr MachineBouncer = "10.98.0.4" + +-- | Postgres on the two members, pgbouncer on the third. Baked into the +-- rootfs, because these guests have no route to the internet after boot. +machinePackages :: Machine -> Debootstrap.Includes +machinePackages MachineBouncer = [Package "pgbouncer", Package "postgresql-client"] +machinePackages _ = [Package "postgresql", Package "sudo"] + +rootfsOf :: FilePath -> Machine -> FilePath +rootfsOf root m = root Text.unpack (machineName m) "root" + +bridgeName :: Text +bridgeName = "salmontoy0" + +bridgeCidr :: LinuxBridge.Cidr +bridgeCidr = LinuxBridge.Cidr "10.98.0.1" 24 + +-- | One CA for all three guests, and one key signed by it. +caKey :: FilePath -> Keys.SSHKeyPair +caKey root = Keys.SSHKeyPair Keys.ED25519 (root "keys") "toy-ca" + +clientKey :: FilePath -> Keys.SSHKeyPair +clientKey root = Keys.SSHKeyPair Keys.ED25519 (root "keys") "toy-client" + +------------------------------------------------------------------------------- +-- Demo passwords. Real ones live in files somebody else provisioned, which +-- is why SreBox.PostgresPair takes paths and never passwords. + +replPassword, rewindPassword, appPassword, consolePassword :: Text +replPassword = "toy-replication-password" +rewindPassword = "toy-rewind-password" +appPassword = "toy-app-password" +consolePassword = "toy-console-password" + +thePair :: FilePath -> Pair.Pair +thePair root = + Pair.Pair + { Pair.pair_name = "toy" + , Pair.pair_a = member MachineA + , Pair.pair_b = member MachineB + , Pair.pair_primary = Pair.A + , Pair.pair_repl_role = "replicator" + , Pair.pair_repl_passfile = "/etc/postgresql/toy-replication.pgpass" + , Pair.pair_rewind_role = "rewinder" + , Pair.pair_rewind_passfile = "/etc/postgresql/toy-rewind.pgpass" + , -- the guests are rebuilt at fixed addresses, so remembering host + -- keys across runs would only ever be wrong + Pair.pair_ssh_known_hosts = Just "/dev/null" + , Pair.pair_catch_up_seconds = 60 + , Pair.pair_seed = Nothing + , Pair.pair_may_discard = Nothing + , Pair.pair_reseed = Nothing + , Pair.pair_bouncers = [theBouncer root] + } + where + member m = + Pair.Member + { Pair.member_ssh_user = "root" + , Pair.member_host = machineAddr m + , Pair.member_cluster = "main" + , Pair.member_port = 5432 + , Pair.member_ssh_identity = Just (Keys.privateKeyPath (clientKey root)) + } + +theBouncer :: FilePath -> Pair.Bouncer +theBouncer root = + Pair.Bouncer + { Pair.bouncer_name = "toy-bouncer" + , Pair.bouncer_ssh_user = "root" + , Pair.bouncer_ssh_host = machineAddr MachineBouncer + , Pair.bouncer_ssh_identity = Just (Keys.privateKeyPath (clientKey root)) + , Pair.bouncer_console_user = "router" + , Pair.bouncer_console_port = 6432 + , Pair.bouncer_console_passfile = "/etc/pgbouncer/console.pgpass" + , Pair.bouncer_alias = "app" + , Pair.bouncer_dbname = "app" + , Pair.bouncer_routing_path = "/etc/pgbouncer/routing.ini" + , Pair.bouncer_config_dir = "/etc/pgbouncer" + , Pair.bouncer_listen_port = 6432 + } + +------------------------------------------------------------------------------- +-- prereqs: the only part that needs root. + +{- | A root filesystem per guest, able to boot over 9p, with @\/etc\/ssh@ +handed to whoever runs the rest. + +All three are 'Debootstrap.rootTree' plus 'Debootstrap.ensureVm9pBoot', +which is the pair of nodes @specs\/qemu-test-vms-progress.md@ is about: the +stock initrd cannot mount a 9p root, because the modules for it are modules +and nothing loads them. + +The ownership node is the third thing that used to be done by hand. Whatever +boots these guests writes an SSH CA into @\/etc\/ssh@ before qemu starts, +and does that on the host as an ordinary user -- qemu's own capabilities +cover what the /guest/ reaches, not what is written beforehand. +-} +prereqs :: FilePath -> Text -> Op +prereqs root owner = + op "toy-prereqs" (deps (map rootfsFor machines <> map handOver workingDirs)) $ \actions -> + actions + { help = "root filesystems for the toy's guests" + , notes = ["owned afterwards by " <> owner] + , ref = mkRef "toy-prereqs" root + } + where + rootfsFor m = + let tree = Debootstrap.RootTree Debootstrap.Stable (rootfsOf root m) (Debootstrap.vmEssentials <> machinePackages m) + bootable = Debootstrap.ensureVm9pBoot reportPrint bashTrack tree `inject` Debootstrap.rootTree reportPrint debootstrapTrack tree + in sshOwnership m `inject` bootable + + -- ownedFile is about a path, not only a file; a directory is what needs + -- handing over here. + sshOwnership m = + FS.ownedFile (FS.FileOwnership (rootfsOf root m "etc/ssh") (Just owner) Nothing 0o755) + + {- Everything under this tree that the /unprivileged/ half then writes: + the keys it mints, the systemd units and monitor sockets each guest + needs. Not the root filesystems themselves, whose files belong to the + users inside the guest and are mapped back out by 9p -- chowning those + would tell the guest that root's files are somebody else's. -} + workingDirs = (root "keys") : [root Text.unpack (machineName m) | m <- machines] + + handOver path = + FS.ownedFile (FS.FileOwnership path (Just owner) Nothing 0o755) + `inject` FS.dir (FS.Directory path) + +------------------------------------------------------------------------------- +-- up: a bridge, three guests, and the pair on top of them. + +demo :: FilePath -> Pair.Pair -> Text -> FilePath -> FilePath -> [(Text, FilePath, FilePath)] -> Op +demo root pair user unitDir runtimeDir boots = + Pair.pairOp reportPrint pair `inject` secrets + where + secrets = + op "toy-secrets" (deps (map secretsOn machines)) $ \actions -> + actions + { help = "the passwords a deployment would have provisioned" + , ref = mkRef "toy-secrets" root + } + + secretsOn m = provisionSecrets root m `inject` reachable root m + + reachable r m = guestUp r m + + guestUp r m = + awaitSsh r m + `inject` ( Qemu.setup reportPrint silent systemctlTrack qemuTrack ipTrack (vmConfig r m user unitDir runtimeDir boots) + `inject` trustsTheCa r m + `inject` LinuxBridge.bridgeAddr silent ipTrack (LinuxBridge.Bridge bridgeName) bridgeCidr + ) + +vmConfig :: FilePath -> Machine -> Text -> FilePath -> FilePath -> [(Text, FilePath, FilePath)] -> Qemu.VmConfig +vmConfig root m user unitDir runtimeDir boots = + Qemu.VmConfig + { Qemu.vm_name = "salmon-toy-" <> machineName m + , Qemu.vm_memory_mb = 512 + , Qemu.vm_smp = 1 + , Qemu.vm_rootfs = rootfsOf root m + , Qemu.vm_kernel = kernel + , Qemu.vm_initrd = initrd + , Qemu.vm_extra_kernel_args = + ["ip=" <> machineAddr m <> "::" <> bridgeCidr.cidrAddr <> ":255.255.255.0::eth0:off"] + , Qemu.vm_tap = LinuxBridge.Tap ("toytap-" <> machineName m) (LinuxBridge.Bridge bridgeName) (Just user) + , Qemu.vm_mac = macOf m + , Qemu.vm_monitor_socket = runtimeDir ("salmon-toy-" <> Text.unpack (machineName m) <> ".sock") + , Qemu.vm_enable_kvm = True + , Qemu.vm_user = user + , Qemu.vm_group = user + , Qemu.vm_working_dir = root Text.unpack (machineName m) + , Qemu.vm_systemd_scope = Systemd.User + , Qemu.vm_unit_dir = unitDir + } + where + (kernel, initrd) = case [(k, i) | (n, k, i) <- boots, n == machineName m] of + ((k, i) : _) -> (k, i) + [] -> error ("no kernel resolved for " <> Text.unpack (machineName m)) + +-- | Fixed, because the guests are: three machines, three addresses. +macOf :: Machine -> Text +macOf MachineA = "52:54:00:70:a1:01" +macOf MachineB = "52:54:00:70:a1:02" +macOf MachineBouncer = "52:54:00:70:a1:03" + +{- | Makes the guest's sshd trust this toy's CA -- /one/ CA for all three, so +a single key reaches every machine, which is what a deployment looks like. + +The CA's public half is read when this runs rather than when the graph is +declared, because the node that generates it is a dependency of this one: +declaring a file's contents from a key that does not exist yet reads an +empty string and writes it, and an empty @TrustedUserCAKeys@ locks everybody +out of a guest that otherwise looks fine. +-} +trustsTheCa :: FilePath -> Machine -> Op +trustsTheCa root m = + op "toy-ssh-trust" (deps [signed]) $ \actions -> + actions + { help = "sshd on " <> machineName m <> " trusts the toy CA" + , ref = mkRef "toy-ssh-trust" (machineName m) + , up = do + pub <- readFile (Keys.publicKeyPath (caKey root)) + createDirectoryIfMissing True (rootfsOf root m "etc/ssh/sshd_config.d") + writeFile (rootfsOf root m "etc/ssh/ca.pub") pub + writeFile + (rootfsOf root m "etc/ssh/sshd_config.d/99-salmon-toy.conf") + (unlines ["TrustedUserCAKeys /etc/ssh/ca.pub", "PasswordAuthentication no"]) + } + where + signed = + Keys.signKey silent keygenTrack (Keys.SSHCertificateAuthority (caKey root)) (Keys.KeyIdentifier "salmon-toy") [Keys.Principal "root"] (clientKey root) + `inject` Keys.sshKey silent keygenTrack (clientKey root) + `inject` Keys.sshKey silent keygenTrack (caKey root) + +-- | A guest is not up when qemu is running; it is up when it answers. +awaitSsh :: FilePath -> Machine -> Op +awaitSsh root m = + op "toy-guest-up" nodeps $ \actions -> + actions + { help = machineName m <> " answers ssh" + , ref = mkRef "toy-guest-up" (machineName m) + , check = do + (code, _, _) <- sshToGuest root m "true" + pure (if code == ExitSuccess then Success else Failure (machineName m <> " is not answering yet")) + , up = poll (60 :: Int) + } + where + poll 0 = fail (Text.unpack (machineName m) <> " never answered ssh") + poll n = do + (code, _, _) <- sshToGuest root m "true" + unless (code == ExitSuccess) (threadDelay 2000000 >> poll (n - 1)) + +------------------------------------------------------------------------------- +-- The secrets a deployment would have provisioned, and this toy invents. + +provisionSecrets :: FilePath -> Machine -> Op +provisionSecrets root m = + op "toy-secret" nodeps $ \actions -> + actions + { help = "passwords on " <> machineName m + , notes = ["constants in this binary's source, which is the difference between a toy and a deployment"] + , ref = mkRef "toy-secret" (machineName m) + , up = do + (code, out, err) <- sshToGuest root m (secretScript m) + unless (code == ExitSuccess) $ + fail ("provisioning " <> Text.unpack (machineName m) <> ": " <> out <> err) + } + +secretScript :: Machine -> String +secretScript MachineBouncer = + unlines + [ "set -e" + , "mkdir -p /etc/pgbouncer" + , -- postgres's own scheme: md5, then the hex digest of password and + -- user run together. + "md5() { printf 'md5%s' \"$(printf '%s%s' \"$2\" \"$1\" | md5sum | cut -d' ' -f1)\"; }" + , "{" + , " printf '\"router\" \"%s\"\\n' \"$(md5 router " <> Text.unpack consolePassword <> ")\"" + , " printf '\"app\" \"%s\"\\n' \"$(md5 app " <> Text.unpack appPassword <> ")\"" + , "} > /tmp/toy-userlist.txt" + , "printf '*:*:*:router:" <> Text.unpack consolePassword <> "\\n' > /etc/pgbouncer/console.pgpass" + , "chmod 0600 /etc/pgbouncer/console.pgpass" + , "chown postgres:postgres /etc/pgbouncer/console.pgpass" + , {- pgbouncer reads its auth file when it starts and not again, so a + userlist written under a running process is a password that does + not work yet -- and the symptom is an authentication failure with + a correct password in a correct file, which is a bad afternoon. + Restarting is fine here and only here: this runs before there are + clients, and only when the file actually changed, because on every + later pass a restart would drop the very clients the bouncer is in + the way to protect. -} + "if ! cmp -s /tmp/toy-userlist.txt /etc/pgbouncer/userlist.txt; then" + , " install -m 0644 -o postgres -g postgres /tmp/toy-userlist.txt /etc/pgbouncer/userlist.txt" + , " systemctl restart pgbouncer" + , "fi" + , "rm -f /tmp/toy-userlist.txt" + ] +secretScript _ = + unlines $ + [ "set -e" + , "export LANG=C LC_ALL=C" + , "version=$(pg_lsclusters --no-header | awk '{print $1}' | head -n1)" + , "hba=/etc/postgresql/$version/main/pg_hba.conf" + ] + <> [ "printf '*:*:*:" <> role <> ":" <> pwd <> "\\n' > " <> path <> "; chown postgres:postgres " <> path <> "; chmod 0600 " <> path + | (path, role, pwd) <- + [ ("/etc/postgresql/toy-replication.pgpass", "replicator", Text.unpack replPassword) + , ("/etc/postgresql/toy-rewind.pgpass", "rewinder", Text.unpack rewindPassword) + ] + ] + <> [ -- the application's own access, which the pair knows nothing + -- about: it routes a database, it does not own one. + "line='host all app " <> Text.unpack (machineAddr MachineBouncer) <> "/32 md5'" + , "grep -qxF \"$line\" \"$hba\" || echo \"$line\" >> \"$hba\"" + , "pg_ctlcluster \"$version\" main reload" + , "if [ \"$(sudo -u postgres psql -tAXc 'SELECT pg_is_in_recovery()')\" = f ]; then" + , " sudo -u postgres psql -tAX -d postgres >/dev/null < Text.unpack appPassword <> "';" + , "TOY_SQL" + , " sudo -u postgres psql -tAXc \"SELECT 1 FROM pg_database WHERE datname='app'\" | grep -q 1 ||" + , " sudo -u postgres psql -tAXc 'CREATE DATABASE app OWNER app'" + , " sudo -u postgres psql -d app -tAXc 'CREATE TABLE IF NOT EXISTS canary (n int primary key, at timestamptz default now())'" + , " sudo -u postgres psql -d app -tAXc 'GRANT ALL ON canary TO app'" + , "fi" + ] + +------------------------------------------------------------------------------- +-- The client: on the host, through the bouncer, like anybody else's. + +{- | Writes one row a fifth of a second until the time runs out, then says +what happened. + +It runs here rather than on a guest because that is where a client is: the +bouncer is reachable over the toy's bridge, so this is an ordinary libpq +connection from an ordinary machine. The three numbers at the end are the +whole claim -- most of all the middle one, which is what a bouncer paused +and reloaded instead of restarted buys. +-} +clientOp :: Pair.Pair -> Int -> Op +clientOp pair seconds = + op "toy-client" nodeps $ \actions -> + actions + { help = Text.pack ("writes through the bouncer for " <> show seconds <> "s") + , ref = mkRef "toy-client" ("toy" :: Text) + , up = runClient pair seconds + } + +runClient :: Pair.Pair -> Int -> IO () +runClient pair seconds = do + -- the canary table outlives a run, and its key is the row number, so + -- this one starts where the last one stopped rather than colliding with + -- it and calling that an outage. + start <- highestSoFar bouncer + deadline <- addUTCTime (fromIntegral seconds) <$> getCurrentTime + putStrLn ("writing through " <> Text.unpack host <> ":" <> show port <> " for " <> show seconds <> "s; move the primary while this runs") + (ok, failed, firstError) <- go deadline start [] [] Nothing + putStrLn "" + present <- rowsPresent pair ok + putStrLn (" inserts acknowledged through the bouncer: " <> show (length ok)) + putStrLn (" inserts that came back an error: " <> show (length failed)) + putStrLn (" acknowledged rows missing afterwards: " <> show (length ok - present)) + forM_ firstError $ \e -> putStrLn (" the first error was: " <> takeWhile (/= '\n') e) + where + bouncer = case pair.pair_bouncers of + (b : _) -> b + [] -> error "the toy always declares a bouncer" + host = bouncer.bouncer_ssh_host + port = bouncer.bouncer_listen_port + + go deadline n ok failed firstError = do + now <- getCurrentTime + if now >= deadline + then pure (reverse ok, reverse failed, firstError) + else do + let i = n + 1 + (acked, err) <- insertOne bouncer i + putStr (if acked then "." else "!") + hFlush stdout + threadDelay 200000 + go + deadline + i + (if acked then i : ok else ok) + (if acked then failed else i : failed) + (if acked then firstError else maybe (Just err) Just firstError) + +insertOne :: Pair.Bouncer -> Int -> IO (Bool, String) +insertOne b i = do + (code, _, err) <- + psqlThroughBouncer + b + [ "-v" + , "ON_ERROR_STOP=1" + , "-tAXc" + , "INSERT INTO canary (n) VALUES (" <> show i <> ")" + ] + pure (code == ExitSuccess, err) + +{- | @psql@ against the bouncer, as the application. + +The password is in this process's environment rather than in a file only +because the whole toy's passwords are in its source; a client in earnest +reads a @.pgpass@, which is also what the recipe's own nodes take. +-} +psqlThroughBouncer :: Pair.Bouncer -> [String] -> IO (ExitCode, String, String) +psqlThroughBouncer b args = do + environment <- getEnvironment + let cp = + (proc "psql" (connArgs <> args)) + { env = Just (("PGPASSWORD", Text.unpack appPassword) : filter ((/= "PGPASSWORD") . fst) environment) + } + readCreateProcessWithExitCode cp "" + where + connArgs = + [ "-h" + , Text.unpack b.bouncer_ssh_host + , "-p" + , show b.bouncer_listen_port + , "-U" + , "app" + , "-d" + , Text.unpack b.bouncer_alias + ] + +-- | The highest row already there, so a second run does not collide with a first. +highestSoFar :: Pair.Bouncer -> IO Int +highestSoFar b = do + (code, out, _) <- psqlThroughBouncer b ["-tAXc", "SELECT coalesce(max(n), 0) FROM canary"] + pure $ case (code, reads (takeWhile (/= '\n') out)) of + (ExitSuccess, [(n, _)]) -> n + _ -> 0 + +-- | How many of the acknowledged inserts are actually there afterwards. +rowsPresent :: Pair.Pair -> [Int] -> IO Int +rowsPresent pair ok = do + (code, out, _) <- psqlThroughBouncer bouncer ["-tAXc", "SELECT n FROM canary"] + pure $ + if code /= ExitSuccess + then 0 + else length (filter (`elem` map show ok) (words out)) + where + bouncer = case pair.pair_bouncers of + (b : _) -> b + [] -> error "the toy always declares a bouncer" + +------------------------------------------------------------------------------- + +sshToGuest :: FilePath -> Machine -> String -> IO (ExitCode, String, String) +sshToGuest root m script = + readProcessWithExitCode + "ssh" + [ "-o" + , "BatchMode=yes" + , "-o" + , "StrictHostKeyChecking=no" + , "-o" + , "UserKnownHostsFile=/dev/null" + , "-o" + , "IdentitiesOnly=yes" + , "-o" + , "ConnectTimeout=5" + , "-i" + , Keys.privateKeyPath (clientKey root) + , "root@" <> Text.unpack (machineAddr m) + , "bash" + , "-c" + , shQuote script + ] + "" + where + shQuote x = "'" <> concatMap (\c -> if c == '\'' then "'\\''" else [c]) x <> "'" + +-- | The binaries this toy assumes are installed; it provisions none of them. +bashTrack :: Track' (Binary.Binary "bash") +bashTrack = ignoreTrack + +debootstrapTrack :: Track' (Binary.Binary "debootstrap") +debootstrapTrack = ignoreTrack + +systemctlTrack :: Track' (Binary.Binary "systemctl") +systemctlTrack = ignoreTrack + +qemuTrack :: Track' (Binary.Binary "qemu-system-x86_64") +qemuTrack = ignoreTrack + +ipTrack :: Track' (Binary.Binary "ip") +ipTrack = ignoreTrack + +keygenTrack :: Track' (Binary.Binary "ssh-keygen") +keygenTrack = ignoreTrack diff --git a/src/Tui.hs b/src/Tui.hs new file mode 100644 --- /dev/null +++ b/src/Tui.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | @salmon-tui PATH@: a terminal client against @run serve --http PATH@ +(milestone 6 of @specs\/generic-server.md@); or @salmon-tui +https:\/\/HOST:PORT --token-file FILE [--cacert FILE]@ against @run serve +--http-tcp HOST:PORT@'s listener (milestone 8), presenting the token from +the file — the same file the server was given, refused if others can read +it — on every request and trusting only the certificate in @--cacert@ when +one is named (a self-signed one is pinned this way), the system's store +otherwise. + +The whole client is "Salmon.Client.Http" for the socket and +"Salmon.Client.Model" for the state; this module is a @brick@ rendering +of the 'Model' and a keyboard over the client, kept thin on purpose so +that what a screen shows is what the model says and nothing more. It +reads @\/dag@ once, follows @\/events@ from that snapshot's @seq@, folds +each event into the model, and re-reads @\/dag@ (rebasing the model on +it) whenever the model asks — a @declared@ or a @gap@ — or when @r@ is +pressed. It holds no state the server does not: a restart is one @\/dag@ +read. + += What touches the loop + +Nothing here stands the tending machines down except the command line. +Every read bypasses the inbox (see "Salmon.Actions.Serve.Http"); only a +line typed after @:@ is a command, sent with @POST \/command?async@, and +the footer says so. The number the server queued it at is echoed, and +its reports arrive on the stream like everything else. + += Keys + + * @j@\/@k@ (or the arrows): move the cursor over the node table + * @enter@: expand the selected node — its help, notes, paths, edges, + last check and output ring — and collapse it again + * @:@: type a serve command; @enter@ sends it asynchronously, @esc@ + drops it + * @r@: re-read @\/dag@ + * @q@: quit (the server is left exactly as it was) + += The stream + +A lost connection is retried after a second with @?since=@ the last +number the stream delivered; the header says @reconnecting@ meanwhile. +The server replays what its ring still holds and sends a @gap@ first when +it does not, which the model turns into a re-read. +-} +module Tui (main) where + +import Brick +import Brick.BChan (BChan, newBChan, writeBChan) +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (SomeException, displayException, fromException, try) +import Control.Monad (forever, void) +import Control.Monad.IO.Class (liftIO) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (isPrefixOf) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Word (Word64) +import qualified Graphics.Vty as Vty +import qualified Network.HTTP.Client as HTTP +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + +import qualified Salmon.Actions.Serve.Http as Http +import qualified Salmon.Client.Http as Client +import qualified Salmon.Client.Model as Model +import Salmon.Client.Model (Model, Node (..)) + +------------------------------------------------------------------------------- + +data Name = Table | Detail + deriving (Eq, Ord, Show) + +-- | What the background threads tell the event loop. +data Msg + = -- | a @\/dag@ answer, or why there is none + Snapshot !(Either Text Model) + | -- | one event off the stream + Streamed !Model.Event + | -- | the stream is open (again) + StreamUp + | -- | the stream ended or failed; retrying + StreamLost !Text + | -- | the answer to a command typed at the prompt + Queued !Text !(Either Text Client.Enqueued) + +data St = St + { stTarget :: !String + , stClient :: !Client.Client + , stChan :: !(BChan Msg) + , stModel :: !Model + , stCursor :: !Int + , stExpanded :: !Bool + , stInput :: !(Maybe Text) + -- ^ the command line, while one is being typed + , stNotice :: !Text + -- ^ the footer's message line + , stStream :: !Text + -- ^ @live@ or @reconnecting@ + } + +main :: IO () +main = do + args <- getArgs + client <- either (\err -> usage err >> exitFailure) id (clientFor args) + first <- try (Client.dag client) + model <- case first of + Left (e :: SomeException) -> do + hPutStrLn stderr ("salmon-tui: cannot read /dag on " <> Client.clientTarget client <> ": " <> describe e) + exitFailure + Right v -> either (\err -> hPutStrLn stderr ("salmon-tui: " <> err) >> exitFailure) pure (Model.fromDag v) + chan <- newBChan 256 + cursor <- newIORef (Just model.modelSeq) + _ <- forkIO (follow client chan cursor) + let st0 = + St + { stTarget = Client.clientTarget client + , stClient = client + , stChan = chan + , stModel = model + , stCursor = 0 + , stExpanded = False + , stInput = Nothing + , stNotice = "reads bypass the loop; only a command typed after : stands the tending machines down" + , stStream = "connecting" + } + void (customMainWithDefaultVty (Just chan) app st0) + +{- | The client the arguments name: a socket path alone, or an @https@ URL +with the token file and optionally the certificate to pin. A token file +without a URL, or a URL without one, is refused rather than guessed at. +-} +clientFor :: [String] -> Either String (IO Client.Client) +clientFor args = + case args of + [path] | not (isUrl path) -> Right (Client.newUnixClient path) + url : flags | isUrl url -> do + opts <- flagsOf flags (Nothing, Nothing) + case opts of + (Nothing, _) -> Left (url <> " needs --token-file FILE: the listener answers nothing without the token") + (Just tokenFile, caFile) -> Right $ do + token <- Http.readTokenFile tokenFile + case token of + Left (Http.TokenFileReadable p) -> die ("--token-file " <> p <> " is readable by others; a token anyone on the box can read is not one (chmod 600 it)") + Left (Http.TokenFileEmpty p) -> die ("--token-file " <> p <> " is empty") + Right tok -> do + r <- try (Client.newTlsClient (Client.TlsTarget url tok caFile)) + either (\(e :: SomeException) -> die (describe e)) pure r + _ -> Left "" + where + isUrl a = "https://" `isPrefixOf` a || "http://" `isPrefixOf` a + flagsOf [] acc = Right acc + flagsOf ("--token-file" : f : rest) (_, ca) = flagsOf rest (Just f, ca) + flagsOf ("--cacert" : f : rest) (tok, _) = flagsOf rest (tok, Just f) + flagsOf (other : _) _ = Left ("unexpected argument: " <> other) + die msg = hPutStrLn stderr ("salmon-tui: " <> msg) >> exitFailure + +{- | An exception as one line: a refusal or a bad address as what the server +or the client said, a connection failure as its cause alone — +@http-client@'s own rendering prints the whole request first, which is +twenty lines of nothing the reader asked about. +-} +describe :: SomeException -> String +describe e + | Just (Client.Refused code err) <- fromException e = show code <> " " <> Text.unpack err + | Just (Client.BadTarget err) <- fromException e = Text.unpack err + | Just (Client.Undecodable err) <- fromException e = Text.unpack err + | Just (HTTP.HttpExceptionRequest _ content) <- fromException e = show content + | otherwise = displayException e + +usage :: String -> IO () +usage err = do + prog <- getProgName + mapM_ (hPutStrLn stderr) $ + [err | not (null err)] + ++ [ "usage: " <> prog <> " PATH (the socket `run serve --http PATH` listens on)" + , " " <> prog <> " https://HOST:PORT --token-file FILE [--cacert FILE] (`run serve --http-tcp HOST:PORT`)" + ] + +------------------------------------------------------------------------------- +-- the threads + +{- | Follow the stream forever, from the last number delivered. The cursor +starts at the snapshot's @seq@ and is moved by every event that carries +one; a gap carries none and leaves it where it was, so a reconnect after +a gap asks for the same range again and gets the same gap, which is +right — the model re-reads on each. +-} +follow :: Client.Client -> BChan Msg -> IORef (Maybe Word64) -> IO () +follow client chan cursor = forever $ do + since <- readIORef cursor + r <- try $ do + writeBChan chan StreamUp + Client.events client since Client.noFilter $ \e -> do + mapM_ (writeIORef cursor . Just) e.eventSeq + writeBChan chan (Streamed e) + pure True + case r of + Left (e :: SomeException) -> writeBChan chan (StreamLost (Text.pack (describe e))) + Right () -> writeBChan chan (StreamLost "the stream ended") + threadDelay 1000000 + +-- | Read @\/dag@ on its own thread; the answer arrives as a 'Snapshot'. +refresh :: St -> IO () +refresh st = void . forkIO $ do + r <- try (Client.dag st.stClient) + writeBChan st.stChan . Snapshot $ case r of + Left (e :: SomeException) -> Left (Text.pack (describe e)) + Right v -> either (Left . Text.pack) Right (Model.fromDag v) + +-- | Send a line asynchronously; the answer arrives as 'Queued'. +send :: St -> Text -> IO () +send st line = void . forkIO $ do + r <- try (Client.commandAsync st.stClient line) + writeBChan st.stChan . Queued line $ case r of + Left (e :: SomeException) -> Left (Text.pack (describe e)) + Right q -> Right q + +------------------------------------------------------------------------------- +-- the app + +app :: App St Msg Name +app = + App + { appDraw = draw + , appChooseCursor = neverShowCursor + , appHandleEvent = handle + , appStartEvent = pure () + , appAttrMap = const theme + } + +theme :: AttrMap +theme = + attrMap + Vty.defAttr + [ (attrName "selected", Vty.black `on` Vty.white) + , (attrName "header", Vty.withStyle Vty.defAttr Vty.bold) + , (attrName "converged", fg Vty.green) + , (attrName "errored", fg Vty.red) + , (attrName "blocked", fg Vty.yellow) + , (attrName "stale", fg Vty.yellow) + , (attrName "down", fg Vty.magenta) + , (attrName "notice", fg Vty.cyan) + , (attrName "prompt", Vty.withStyle Vty.defAttr Vty.bold) + ] + +handle :: BrickEvent Name Msg -> EventM Name St () +handle ev = case ev of + AppEvent msg -> onMsg msg + VtyEvent (Vty.EvKey key mods) -> do + typing <- gets stInput + case typing of + Just line -> onPromptKey line key mods + Nothing -> onKey key + _ -> pure () + +onMsg :: Msg -> EventM Name St () +onMsg msg = case msg of + Snapshot (Left err) -> modify $ \st -> st{stNotice = "/dag: " <> err} + Snapshot (Right fresh) -> modify $ \st -> + let m = Model.rebase st.stModel fresh + in st{stModel = m, stCursor = clampCursor m st.stCursor, stNotice = "re-read /dag at seq " <> tshow m.modelSeq} + Streamed e -> do + st <- get + let m = Model.step st.stModel e + modify $ \s -> s{stModel = m, stCursor = clampCursor m s.stCursor, stNotice = Model.renderEventLine e} + -- a declaration or a gap: the picture may have changed shape + case Model.modelResync m of + Just why -> do + modify $ \s -> s{stModel = Model.resolve m, stNotice = why <> "; re-reading /dag"} + liftIO (refresh st) + Nothing -> pure () + StreamUp -> modify $ \st -> st{stStream = "live"} + StreamLost why -> modify $ \st -> st{stStream = "reconnecting", stNotice = "stream: " <> why} + Queued line (Left err) -> modify $ \st -> st{stNotice = "refused: " <> line <> ": " <> err} + Queued line (Right q) -> modify $ \st -> st{stNotice = "queued at seq " <> tshow q.enqueuedSeq <> " (" <> q.enqueuedOrigin <> "): " <> line} + +onKey :: Vty.Key -> EventM Name St () +onKey key = case key of + Vty.KChar 'q' -> halt + Vty.KChar 'j' -> move 1 + Vty.KDown -> move 1 + Vty.KChar 'k' -> move (-1) + Vty.KUp -> move (-1) + Vty.KChar 'g' -> modify $ \st -> st{stCursor = 0} + Vty.KChar 'G' -> modify $ \st -> st{stCursor = max 0 (length (Model.nodesInOrder st.stModel) - 1)} + Vty.KEnter -> modify $ \st -> st{stExpanded = not st.stExpanded} + Vty.KChar 'r' -> do + st <- get + liftIO (refresh st) + modify $ \s -> s{stNotice = "re-reading /dag"} + Vty.KChar ':' -> modify $ \st -> st{stInput = Just ""} + _ -> pure () + where + move :: Int -> EventM Name St () + move d = modify $ \st -> st{stCursor = clampCursor st.stModel (st.stCursor + d)} + +onPromptKey :: Text -> Vty.Key -> [Vty.Modifier] -> EventM Name St () +onPromptKey line key mods = case key of + Vty.KEsc -> modify $ \st -> st{stInput = Nothing, stNotice = "command dropped"} + Vty.KEnter + | Text.null (Text.strip line) -> modify $ \st -> st{stInput = Nothing} + | otherwise -> do + st <- get + liftIO (send st (Text.strip line)) + modify $ \s -> s{stInput = Nothing, stNotice = "sending: " <> Text.strip line} + Vty.KBS -> modify $ \st -> st{stInput = Just (Text.dropEnd 1 line)} + Vty.KChar 'u' | Vty.MCtrl `elem` mods -> modify $ \st -> st{stInput = Just ""} + Vty.KChar c | null mods || mods == [Vty.MShift] -> modify $ \st -> st{stInput = Just (Text.snoc line c)} + _ -> pure () + +clampCursor :: Model -> Int -> Int +clampCursor m i = max 0 (min i (length (Model.nodesInOrder m) - 1)) + +------------------------------------------------------------------------------- +-- drawing + +draw :: St -> [Widget Name] +draw st = [vBox [header, table, detail, footer]] + where + m = st.stModel + nodes = Model.nodesInOrder m + + header = + withAttr (attrName "header") . padRight Max . txt $ + Model.renderHeader (Text.pack st.stTarget) m <> " stream=" <> st.stStream + + columns = Text.unwords [pad 10 "ref", pad 22 "shorthand", pad 4 "dir", pad 9 "state", pad 12 "check", "last event"] + pad n = Text.justifyLeft n ' ' + + table = + vBox + [ withAttr (attrName "header") (padRight Max (txt (" " <> columns))) + , viewport Table Vertical $ + vBox + [ row i n + | (i, n) <- zip [0 ..] nodes + ] + , when' (null nodes) (txt " (no node declared)") + ] + + row i n + | i == st.stCursor = visible (withAttr (attrName "selected") (padRight Max (txt ("> " <> Model.renderNodeRow n)))) + | otherwise = withAttr (stateAttr n) (padRight Max (txt (" " <> Model.renderNodeRow n))) + + stateAttr :: Node -> AttrName + stateAttr n + | n.nodeDirection == "down" = attrName "down" + | otherwise = attrName (Text.unpack n.nodeConvergence) + + detail + | not st.stExpanded = emptyWidget + | otherwise = case drop st.stCursor nodes of + (n : _) -> vLimit 14 (viewport Detail Vertical (vBox (fmap txtWrap (detailLines n)))) + [] -> emptyWidget + + footer = + vBox + [ withAttr (attrName "notice") (padRight Max (txt (Text.take 200 st.stNotice))) + , case st.stInput of + Just line -> withAttr (attrName "prompt") (padRight Max (txt (":" <> line <> "_"))) + Nothing -> padRight Max (txt "j/k move enter expand : command (async; stands the machines down) r re-read /dag q quit") + ] + + when' c w = if c then w else emptyWidget + +-- | The expanded view of one node: everything the model has about it. +detailLines :: Node -> [Text] +detailLines n = + [ "ref: " <> n.nodeRef.refShort <> " (" <> n.nodeRef.refFull <> ")" + , "shorthand: " <> n.nodeShorthand + , "help: " <> n.nodeHelp + ] + ++ ["note: " <> t | t <- n.nodeNotes] + ++ ["path: " <> p | p <- n.nodePaths] + ++ ["depends on: " <> Text.unwords (fmap (.refShort) n.nodeDependencies) | not (null n.nodeDependencies)] + ++ ["depended on by: " <> Text.unwords (fmap (.refShort) n.nodeDependants) | not (null n.nodeDependants)] + ++ [ "check: " <> c.checkVerdict <> maybe "" (" — " <>) c.checkReason | Just c <- [n.nodeCheck] ] + ++ ["error: " <> e | Just e <- [n.nodeError]] + ++ ["last event: " <> k <> maybe "" (\s -> " #" <> tshow s) n.nodeLastSeq | Just k <- [n.nodeLastKind]] + ++ case n.nodeOutput of + [] -> ["output: (none in the last snapshot)"] + ls -> "output (last snapshot):" : fmap (" " <>) (lastN 10 ls) + where + lastN k xs = drop (max 0 (length xs - k)) xs + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,13 @@ +module Main (main) where + +import Test.Tasty (defaultMain, testGroup) + +import qualified Test.FleetSpec as FleetSpec + +main :: IO () +main = + defaultMain $ + testGroup + "salmon-apps" + [ FleetSpec.tests + ] diff --git a/test/Test/FleetSpec.hs b/test/Test/FleetSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/FleetSpec.hs @@ -0,0 +1,321 @@ +{- | Layer 0 coverage for @salmon-fleet status@'s @--pretty@ table +(projectz feature 962ca8a9-48c7-4582-854f-e4581fdccc60): 'Fleet.decidePretty' +truth table, a golden of the pretty table (color forced off, so the golden +is stable across runs/terminals), and a golden of the plain TSV +('Salmon.Actions.Fleet.renderHeader'\/'renderRow', untouched by this +feature) — pinning "the default did not change" for existing pipe/script +consumers. +-} +module Test.FleetSpec (tests) where + +import Control.Monad (forM_) +import Data.Aeson (Value (..), decode, encode) +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString.Lazy as LByteString +import qualified Data.Text as Text +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..), addUTCTime, getCurrentTime) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) + +import Fleet (decidePretty, describeValue, foldStatusDir, prettyTable) +import Salmon.Actions.Fleet (Row (..), renderHeader, renderRow, rowValue) +import Salmon.Actions.Serve (AppliedDocument (..)) + +tests :: TestTree +tests = + testGroup + "Fleet" + [ testGroup "decidePretty: --pretty/--no-pretty override, else the terminal" decidePrettyTests + , testCase "the pretty table, color off (golden)" prettyGolden + , testCase "the plain TSV is unchanged (golden)" tsvGolden + , testCase "color on paints only stale/errored data rows, leaving borders/header/ok rows alone" prettyColorOn + , testGroup "agents-exe bash-toolbox: describe/run" toolboxTests + ] + +------------------------------------------------------------------------------- +-- decidePretty: pretty-when-tty, TSV-when-not, either overridable + +decidePrettyTests :: [TestTree] +decidePrettyTests = + [ testCase "no override, terminal -> pretty" $ assertEqual "" True (decidePretty Nothing True) + , testCase "no override, not a terminal -> TSV" $ assertEqual "" False (decidePretty Nothing False) + , testCase "--pretty forces pretty even when piped" $ assertEqual "" True (decidePretty (Just True) False) + , testCase "--pretty on a terminal stays pretty" $ assertEqual "" True (decidePretty (Just True) True) + , testCase "--no-pretty forces TSV even on a terminal" $ assertEqual "" False (decidePretty (Just False) True) + , testCase "--no-pretty stays TSV when piped too" $ assertEqual "" False (decidePretty (Just False) False) + ] + +------------------------------------------------------------------------------- +-- fixture rows: one converged with labels, one errored, one stale, one with no labels + +epoch :: UTCTime +epoch = UTCTime (fromGregorian 2024 1 1) 0 + +rowConvergedWithLabels :: Row +rowConvergedWithLabels = + Row + { rowHost = "host-a" + , rowMode = "following" + , rowLabels = [AppliedDocument "prod" "doc1" "abcdef0123456789abcdef0123456789" epoch] + , rowConverged = 3 + , rowErrored = 0 + , rowNodes = 3 + , rowWritten = epoch + , rowAge = 5 + , rowStale = False + , rowFile = "/status/host-a.json" + } + +rowWithErrors :: Row +rowWithErrors = + Row + { rowHost = "host-b" + , rowMode = "interactive" + , rowLabels = [] + , rowConverged = 1 + , rowErrored = 2 + , rowNodes = 3 + , rowWritten = epoch + , rowAge = 10 + , rowStale = False + , rowFile = "/status/host-b.json" + } + +rowIsStale :: Row +rowIsStale = + Row + { rowHost = "host-c" + , rowMode = "replay" + , rowLabels = [] + , rowConverged = 1 + , rowErrored = 0 + , rowNodes = 1 + , rowWritten = epoch + , rowAge = 3600 + , rowStale = True + , rowFile = "/status/host-c.json" + } + +rowNoLabels :: Row +rowNoLabels = + Row + { rowHost = "host-d" + , rowMode = "following" + , rowLabels = [] + , rowConverged = 2 + , rowErrored = 0 + , rowNodes = 2 + , rowWritten = epoch + , rowAge = 1 + , rowStale = False + , rowFile = "/status/host-d.json" + } + +fixtureRows :: [Row] +fixtureRows = [rowConvergedWithLabels, rowWithErrors, rowIsStale, rowNoLabels] + +------------------------------------------------------------------------------- + +prettyGolden :: IO () +prettyGolden = + assertEqual "prettyTable, color off" expected (prettyTable False fixtureRows) + where + expected = + Text.intercalate + "\n" + [ "┌────────┬─────────────┬────────────────────────┬───────────┬─────────┬───────┬───────┐" + , "│ HOST │ MODE │ LABELS │ CONVERGED │ ERRORED │ AGE │ STALE │" + , "├────────┼─────────────┼────────────────────────┼───────────┼─────────┼───────┼───────┤" + , "│ host-a │ following │ prod=doc1@abcdef012345 │ 3/3 │ 0 │ 5s │ │" + , "│ host-b │ interactive │ - │ 1/3 │ 2 │ 10s │ │" + , "│ host-c │ replay │ - │ 1/1 │ 0 │ 3600s │ STALE │" + , "│ host-d │ following │ - │ 2/2 │ 0 │ 1s │ │" + , "└────────┴─────────────┴────────────────────────┴───────────┴─────────┴───────┴───────┘" + ] + +tsvGolden :: IO () +tsvGolden = + assertEqual "renderHeader/renderRow (TSV)" expected actual + where + actual = Text.intercalate "\n" (renderHeader : fmap renderRow fixtureRows) + expected = + Text.intercalate + "\n" + [ "host\tmode\tlabels\tconverged\terrored\tage\tflags" + , "host-a\tfollowing\tprod=doc1@abcdef012345\t3/3\t0\t5s\t" + , "host-b\tinteractive\t-\t1/3\t2\t10s\t" + , "host-c\treplay\t-\t1/1\t0\t3600s\tstale" + , "host-d\tfollowing\t-\t2/2\t0\t1s\t" + ] + +{- | With color on, every line of a row that is stale or errored carries an +ANSI wrap around the /whole/ line (borders included — cheap and harmless, +since the point is a line painted, not a cell) and every other line — +borders, header, separator, an all-clear row — is untouched. Comparing +line-for-line against the color-off golden, rather than hardcoding escape +codes here too, is what keeps this test from re-encoding +'Fleet.colorizeRows'’s escape sequences by hand. -} +prettyColorOn :: IO () +prettyColorOn = do + let plainLines = Text.lines (prettyTable False fixtureRows) + coloredLines = Text.lines (prettyTable True fixtureRows) + assertEqual "same number of lines" (length plainLines) (length coloredLines) + -- lines: 0 top border, 1 header, 2 separator, 3 host-a, 4 host-b, 5 host-c, 6 host-d, 7 bottom border + let paintedAt i = "\ESC[" `Text.isPrefixOf` (coloredLines !! i) && "\ESC[0m" `Text.isSuffixOf` (coloredLines !! i) + untouchedAt i = coloredLines !! i == plainLines !! i + mapM_ (assertEqual "border/header/separator untouched" True . untouchedAt) [0, 1, 2, 7] + assertEqual "host-a (converged, ok) untouched" True (untouchedAt 3) + assertEqual "host-b (errored) painted" True (paintedAt 4) + assertEqual "host-c (stale) painted" True (paintedAt 5) + assertEqual "host-d (converged, ok) untouched" True (untouchedAt 6) + +------------------------------------------------------------------------------- +-- the agents-exe bash-toolbox protocol (documentation/binary-tool.md, +-- projectz feature cf574966-31f3-408c-ac28-ab04ff93531c): `describe`'s JSON +-- shape, and `run`'s output against a real fixture directory. + +toolboxTests :: [TestTree] +toolboxTests = + [ testCase "describeValue has the required top-level fields" describeTopLevel + , testCase "describeValue's args match dir/label/stale, with modes/arities from the current spec" describeArgs + , testCase "describeValue round-trips through JSON encode/decode" describeRoundTrips + , testCase "run DIR is the same JSON status --json would give" runMatchesStatusJson + , testCase "run DIR --label/--stale filters and flags exactly like status" runWithFilters + ] + +-- | The top-level object the spec requires: @slug@, @description@, @args@ +-- (all present, right shapes), plus the optional @empty-result@ this tool +-- declares. +describeTopLevel :: IO () +describeTopLevel = case describeValue of + Object o -> do + assertField o "slug" $ \v -> case v of + String s -> assertBool "slug has no spaces" (not (Text.any (== ' ') s)) + _ -> assertFailure "slug is not a string" + assertField o "description" $ \v -> case v of + String s -> assertBool "description is non-empty" (not (Text.null s)) + _ -> assertFailure "description is not a string" + assertField o "args" $ \v -> case v of + Array _ -> pure () + _ -> assertFailure "args is not an array" + assertField o "empty-result" $ \v -> case v of + Object er -> assertField er "tag" $ \tv -> case tv of + String "AddMessage" -> pure () + _ -> assertFailure "empty-result.tag is not AddMessage" + _ -> assertFailure "empty-result is not an object" + _ -> assertFailure "describeValue is not a JSON object" + where + assertField o k f = case KeyMap.lookup k o of + Nothing -> assertFailure ("missing field " <> show k) + Just v -> f v + +-- | Each arg object has exactly the fields +-- @documentation/binary-tool.md@ requires, and the three args this tool +-- declares (@dir@, @label@, @stale@) have the modes/arities that match how +-- @runP@ actually parses them: @dir@ positional/single, @label@ and +-- @stale@ dashdashspace/optional. @arity@ and @mode@ are checked against +-- the *closed* sets the current spec allows -- catching, in particular, any +-- future temptation to invent a "repeatable" arity that doesn't exist yet +-- (see the module haddock's noted gap for @--label@). +describeArgs :: IO () +describeArgs = case describeValue of + Object o -> case KeyMap.lookup "args" o of + Just (Array args) -> do + assertEqual "three args: dir, label, stale" 3 (length args) + forM_ args checkArg + namesAndModesMatch (foldr (:) [] args) + _ -> assertFailure "args is not an array" + _ -> assertFailure "describeValue is not a JSON object" + where + allowedArity = ["single", "optional"] :: [Text.Text] + allowedMode = ["positional", "dashdashspace", "dashdashequal", "stdin"] :: [Text.Text] + checkArg (Object a) = do + forM_ ["name", "description", "type", "backing_type", "arity", "mode"] $ \k -> + assertBool ("arg has field " <> show k) (KeyMap.member k a) + case KeyMap.lookup "arity" a of + Just (String s) -> assertBool ("arity is one of " <> show allowedArity) (s `elem` allowedArity) + _ -> assertFailure "arity is not a string" + case KeyMap.lookup "mode" a of + Just (String s) -> assertBool ("mode is one of " <> show allowedMode) (s `elem` allowedMode) + _ -> assertFailure "mode is not a string" + checkArg _ = assertFailure "an arg is not a JSON object" + namesAndModesMatch args = do + let byName n = [a | Object a <- args, Just (String n') <- [KeyMap.lookup "name" a], n' == n] + assertOne "dir" (byName "dir") "positional" "single" + assertOne "label" (byName "label") "dashdashspace" "optional" + assertOne "stale" (byName "stale") "dashdashspace" "optional" + assertOne n found mode arity = case found of + [a] -> do + assertEqual (n <> " mode") (Just (String mode)) (KeyMap.lookup "mode" a) + assertEqual (n <> " arity") (Just (String arity)) (KeyMap.lookup "arity" a) + _ -> assertFailure ("expected exactly one arg named " <> n) + +describeRoundTrips :: IO () +describeRoundTrips = + assertEqual "encode/decode is the identity" (Just describeValue) (decode (encode describeValue)) + +-- | @run DIR@ and @status DIR --json@ both go through 'foldStatusDir' — the +-- one place the fold happens — so there is structurally nothing for @run@ +-- to drift from; what is worth testing is that the shared helper computes +-- what a real fixture directory says it should. The fixture's @written@/ +-- @applied@ timestamps are pinned relative to 'getCurrentTime' (not a fixed +-- date) so @age_s@/@rowStale@ are meaningful without the test racing the +-- clock or two calls of 'foldStatusDir' (each of which samples the time +-- itself) disagreeing on it by a few microseconds. +fixtureDoc :: UTCTime -> UTCTime -> LByteString.ByteString +fixtureDoc written applied = + "{\"salmon-status\":1,\"host\":\"host-a\",\"written\":" + <> encode written + <> ",\"mode\":\"following\"," + <> "\"labels\":[{\"label\":\"prod\",\"id\":\"doc1\",\"sha256\":\"abcdef0123456789abcdef0123456789\",\"applied\":" + <> encode applied + <> "}]," + <> "\"status\":{\"nodes\":[{\"convergence\":\"converged\"},{\"convergence\":\"converged\"},{\"convergence\":\"errored\"}]}}" + +-- | A fixture directory with one host-a.json, written 5s ago. +withFixtureDir :: (FilePath -> IO a) -> IO a +withFixtureDir act = withSystemTempDirectory "salmon-fleet-toolbox-test" $ \dir -> do + createDirectoryIfMissing True dir + now <- getCurrentTime + let written = addUTCTime (-5) now + LByteString.writeFile (dir "host-a.json") (fixtureDoc written written) + act dir + +runMatchesStatusJson :: IO () +runMatchesStatusJson = withFixtureDir $ \dir -> do + -- `run DIR` (no --label/--stale) is `foldStatusDir dir Nothing 60` -- + -- exactly the defaults `runP` gives when neither flag is passed, and + -- exactly what `Status` takes for `status DIR --json`. + (_, runRows, rejected) <- foldStatusDir dir Nothing 60 + assertEqual "nothing rejected" [] rejected + assertEqual "one row, for host-a" 1 (length runRows) + case runRows of + [row] -> do + assertEqual "host" "host-a" row.rowHost + assertEqual "mode" "following" row.rowMode + assertEqual "converged/total" (2, 3) (row.rowConverged, row.rowNodes) + assertEqual "errored" 1 row.rowErrored + assertEqual "not stale (written 5s ago, default 60s threshold)" False row.rowStale + assertEqual "one label" 1 (length row.rowLabels) + -- the JSON `run` actually prints, via the same rowValue `status + -- --json` uses + case rowValue row of + Object o -> forM_ ["host", "mode", "labels", "converged", "errored", "nodes", "written", "age_s", "stale", "file"] $ \k -> + assertBool ("rowValue has field " <> show k) (KeyMap.member k o) + _ -> assertFailure "rowValue is not a JSON object" + _ -> assertFailure "expected exactly one row" + +runWithFilters :: IO () +runWithFilters = withFixtureDir $ \dir -> do + (_, matched, _) <- foldStatusDir dir (Just "prod") 60 + assertEqual "matching label keeps the row" 1 (length matched) + (_, unmatched, _) <- foldStatusDir dir (Just "nope") 60 + assertEqual "non-matching label drops the row" 0 (length unmatched) + (_, stale, _) <- foldStatusDir dir Nothing 1 + case stale of + [row] -> assertEqual "a tight --stale (1s, doc written 5s ago) flags the row" True row.rowStale + _ -> assertFailure "expected exactly one row"