salmon-apps (empty) → 0.1.0.0
raw patch · 26 files changed
+4077/−0 lines, 26 filesdep +aesondep +basedep +brick
Dependencies added: aeson, base, brick, bytestring, containers, directory, filepath, http-client, layoutz-hs, optparse-applicative, optparse-generic, process, salmon-apps, salmon-core, salmon-ops, salmon-ops-recipes, tasty, tasty-hunit, temporary, text, time, unix, vty
Files
- CHANGELOG.md +5/−0
- LICENSE +29/−0
- app/FleetApp.hs +6/−0
- app/GcpToyApp.hs +6/−0
- app/InitializerApp.hs +6/−0
- app/MigratorApp.hs +6/−0
- app/PatroniRootfsApp.hs +6/−0
- app/PgBackupApp.hs +6/−0
- app/PgPairApp.hs +6/−0
- app/QemuPgHaToyApp.hs +6/−0
- app/TuiApp.hs +6/−0
- salmon-apps.cabal +180/−0
- src/Fleet.hs +328/−0
- src/GcpToy.hs +866/−0
- src/Initializer.hs +67/−0
- src/Migrator.hs +75/−0
- src/Migrator/Ops.hs +159/−0
- src/Migrator/Seed.hs +123/−0
- src/Migrator/Spec.hs +36/−0
- src/PatroniRootfs.hs +131/−0
- src/PgBackup.hs +382/−0
- src/PgPair.hs +171/−0
- src/QemuPgHaToy.hs +746/−0
- src/Tui.hs +391/−0
- test/Main.hs +13/−0
- test/Test/FleetSpec.hs +321/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for salmon-apps++## 0.1.0.0 -- unreleased++* First release.
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2022-2026, Lucas DiCioccio+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ app/FleetApp.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified Fleet++main :: IO ()+main = Fleet.main
+ app/GcpToyApp.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified GcpToy++main :: IO ()+main = GcpToy.main
+ app/InitializerApp.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified Initializer++main :: IO ()+main = Initializer.main
+ app/MigratorApp.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified Migrator++main :: IO ()+main = Migrator.main
+ app/PatroniRootfsApp.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified PatroniRootfs++main :: IO ()+main = PatroniRootfs.main
+ app/PgBackupApp.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified PgBackup++main :: IO ()+main = PgBackup.main
+ app/PgPairApp.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified PgPair++main :: IO ()+main = PgPair.main
+ app/QemuPgHaToyApp.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified QemuPgHaToy++main :: IO ()+main = QemuPgHaToy.main
+ app/TuiApp.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified Tui++main :: IO ()+main = Tui.main
+ salmon-apps.cabal view
@@ -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
+ src/Fleet.hs view
@@ -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@, <https://github.com/mattlianje/layoutz>) 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
+ src/GcpToy.hs view
@@ -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: <region>-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
+ src/Initializer.hs view
@@ -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
+ src/Migrator.hs view
@@ -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)
+ src/Migrator/Ops.hs view
@@ -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]
+ src/Migrator/Seed.hs view
@@ -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_\<branch\>@+ , 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 <db>` 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")
+ src/Migrator/Spec.hs view
@@ -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
+ src/PatroniRootfs.hs view
@@ -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
+ src/PgBackup.hs view
@@ -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-<db>.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
+ src/PgPair.hs view
@@ -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+ }
+ src/QemuPgHaToy.hs view
@@ -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 <<TOY_SQL"+ , "DO \\$do\\$ BEGIN CREATE ROLE app LOGIN; EXCEPTION WHEN duplicate_object THEN NULL; END \\$do\\$;"+ , "ALTER ROLE app LOGIN PASSWORD '" <> 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
+ src/Tui.hs view
@@ -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
+ test/Main.hs view
@@ -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+ ]
+ test/Test/FleetSpec.hs view
@@ -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"