salmon-ops-recipes 0.1.0.0 → 0.2.0.0

raw patch · 102 files changed

+27964/−1155 lines, 102 filesdep +ghc-heapdep ~salmon-opsdep ~salmon-ops-recipesPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-heap

Dependency ranges changed: salmon-ops, salmon-ops-recipes

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−1
• bench/GraphProfiles.hs +1035/−0
• salmon-ops-recipes.cabal +95/−6
• src/SreBox/DNSRegistration.hs +4/−1
• src/SreBox/Gcp/CloudRunAlerts.hs +14/−2
• src/SreBox/Gcp/CloudRunDeploy.hs +33/−4
• src/SreBox/Gcp/PlakarGcsBackup.hs +148/−0
• src/SreBox/Gcp/PostgrestCloudRun.hs +9/−1
• src/SreBox/Gcp/VmProvision.hs +209/−21
• src/SreBox/Initialize.hs +1/−1
• src/SreBox/PgVectorDemo.hs +577/−0
• src/SreBox/PostgresInit.hs +19/−6
• src/SreBox/PostgresMigrations.hs +23/−2
• src/SreBox/PostgresPair.hs +620/−78
• src/SreBox/PostgresPairPrereqs.hs +558/−0
• src/SreBox/PostgresTls.hs +6/−1
• src/SreBox/Postgrest.hs +9/−2
• src/SreBox/WireGuardMesh.hs +561/−0
• src/SreBox/WireGuardVpn.hs +21/−13
• test/Main.hs +89/−0
• test/Test/AmendNodeSpec.hs +48/−0
• test/Test/BinaryOutputSpec.hs +276/−0
• test/Test/BinarySpec.hs +96/−0
• test/Test/BuiltinCardsSpec.hs +425/−0
• test/Test/CardTemplateSpec.hs +97/−0
• test/Test/ClientModelReference.hs +433/−0
• test/Test/ClientModelSpec.hs +150/−5
• test/Test/ClientModelStepSpec.hs +636/−0
• test/Test/ClipCppSpec.hs +274/−0
• test/Test/DaemonSpec.hs +12/−0
• test/Test/DagPerNodeSpec.hs +583/−0
• test/Test/DagReference.hs +203/−0
• test/Test/DagStuckSpec.hs +235/−0
• test/Test/DebianPackageSpec.hs +74/−3
• test/Test/DeferredSpec.hs +311/−0
• test/Test/DetachedSpec.hs +265/−0
• test/Test/EdgeListReference.hs +195/−0
• test/Test/EdgeListSpec.hs +387/−0
• test/Test/EtcdSpec.hs +13/−0
• test/Test/FilesystemSpec.hs +143/−3
• test/Test/FollowCacheSpec.hs +2/−2
• test/Test/FollowRegistrySpec.hs +2/−2
• test/Test/FollowSchedulerSpec.hs +2/−2
• test/Test/FollowSignatureSpec.hs +3/−3
• test/Test/FollowSpec.hs +58/−7
• test/Test/GcpSpec.hs +4564/−881
• test/Test/GraphFixture.hs +485/−0
• test/Test/GraphFixtureSpec.hs +344/−0
• test/Test/GraphScaleSpec.hs +132/−0
• test/Test/HaproxySpec.hs +147/−0
• test/Test/Harness.hs +129/−16
• test/Test/HttpServerFlagSpec.hs +119/−0
• test/Test/ListedPathsSpec.hs +284/−0
• test/Test/LlamaServerSpec.hs +8/−0
• test/Test/NetbirdSpec.hs +216/−0
• test/Test/PathListReference.hs +72/−0
• test/Test/PatroniArchiveVmsSpec.hs +412/−0
• test/Test/PatroniPreferredLeaderSpec.hs +365/−0
• test/Test/PatroniRollingMaintenanceSpec.hs +440/−0
• test/Test/PatroniSpec.hs +121/−0
• test/Test/PatroniVms.hs +11/−3
• test/Test/PgBackRestSpec.hs +427/−0
• test/Test/PgTextSearchSpec.hs +937/−0
• test/Test/PgVectorDemoSpec.hs +227/−0
• test/Test/PlakarSpec.hs +26/−0
• test/Test/PodmanCommandSpec.hs +263/−2
• test/Test/PodmanSpec.hs +107/−4
• test/Test/PortMappingSpec.hs +136/−0
• test/Test/PostgresInitSpec.hs +10/−3
• test/Test/PostgresPairPrereqsSpec.hs +385/−0
• test/Test/PostgresPairSpec.hs +483/−2
• test/Test/PostgresSwitchoverSpec.hs +2/−1
• test/Test/PostgresTemplateSpec.hs +1/−1
• test/Test/PostgresUserSpec.hs +582/−0
• test/Test/QemuShutdownSpec.hs +76/−2
• test/Test/QemuSmokeSpec.hs +13/−8
• test/Test/QuadletSpec.hs +1092/−0
• test/Test/QuadletUserSpec.hs +741/−0
• test/Test/QuerySpec.hs +118/−1
• test/Test/ReadinessSpec.hs +180/−0
• test/Test/RemoteOutputSpec.hs +302/−0
• test/Test/ReportJsonSpec.hs +54/−2
• test/Test/RewriteSpec.hs +78/−6
• test/Test/RsyncSpec.hs +583/−0
• test/Test/SecretDeliverySpec.hs +379/−0
• test/Test/ServeApiSpec.hs +2/−2
• test/Test/ServeEventsSpec.hs +155/−3
• test/Test/ServeHttpSpec.hs +204/−5
• test/Test/ServeSocketSpec.hs +49/−4
• test/Test/ServeSpec.hs +126/−21
• test/Test/ServeTlsSpec.hs +4/−0
• test/Test/SharedDirSpec.hs +165/−0
• test/Test/StatusSinkSpec.hs +51/−7
• test/Test/SystemdJobSpec.hs +1332/−0
• test/Test/SystemdSpec.hs +295/−1
• test/Test/UiTailTemplateSpec.hs +37/−0
• test/Test/UpDownTextSpec.hs +166/−0
• test/Test/UpkeepRetentionSpec.hs +356/−0
• test/Test/UpkeepSpec.hs +358/−11
• test/Test/WindowSpec.hs +198/−3
• test/Test/WireGuardMeshSpec.hs +179/−0
• test/Test/WrapperOrderingSpec.hs +266/−0

@@ -1,5 +1,20 @@ # Revision history for salmon-ops-recipes -## 0.1.0.0 -- unreleased+## 0.2.0.0 -- unreleased++Breaking: `SreBox.PostgresPair`'s records and some exported functions changed. Requires+`salmon-ops ^>=0.2.0.0`.++* `SreBox.PostgresPair`: one bouncer routing several databases, `hostssl` and SCRAM for+  replication and rewind, a member's SSH address separate from its replication address, every+  script under one `sudo` when the SSH login is not root.+* New `SreBox.PostgresPairPrereqs`: what a pair assumed was done first, as nodes.+* New `SreBox.PgVectorDemo`: index a directory of text and images into pgvector with a+  llama-server, clip.cpp or a model-free stand-in embedder, and search it by cosine distance.+* New `SreBox.WireGuardMesh`: declared peers, groups and policies unfolded per host.+* New `SreBox.Gcp.PlakarGcsBackup`; `SreBox.Gcp.VmProvision` exports the startup script that makes+  an instance trust the SSH CA.++## 0.1.0.0 -- 2026-10-01  * First release.

@@ -0,0 +1,1035 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++{- | How each graph operation scales, per shape: every operation below run+over the "Test.GraphFixture" shapes at growing sizes, timed, with the bytes+it allocated, each series stopped once a step passes its budget.++Not part of @cabal test@ and not built by @cabal build all@ (it is a+@benchmark@ stanza): it is slow, and the numbers only mean something on a+quiet machine.++@+cabal bench salmon-ops-recipes:graph-profiles \\+  --benchmark-options='--max-size 100000 --heap 4g --out profiles.tsv'+cabal bench salmon-ops-recipes:graph-profiles \\+  --benchmark-options='--summarise profiles.tsv'+@++Each series (one operation over one shape) runs in a process of its own,+see 'measureAll' for why.++= What a row is++One operation, one shape, one size: the wall-clock time of the operation+alone (inputs are built and forced before the clock starts, a major+collection runs first) and the bytes allocated meanwhile, on every thread.+A step that takes under a quarter of a second is run three times and the+fastest kept.++= Two size axes++An operation that reads the whole expanded graph (the expansion itself,+@query show@ of every path, and the per-occurrence fold kept as+"Test.DagReference") pays per __occurrence__: per path from the root to a+node. On a shape that shares nodes that number is exponential in the node+count, so those series are sized by occurrences and reach a few dozen+nodes. An operation that reads a 'Dag' pays per __node__, and is given one+built by 'Test.GraphFixture.dagOf' without going through the fold, at+whatever node count the cap allows. 'Salmon.Op.Dag.foldDag', and so+@query plan@ and a declaration in @serve@, were sized by occurrences until+the fold went per node; they are sized by nodes now.++= When a series stops++At the size cap; when a step took more than a third of the budget (the next+one is three times larger, so it would be over); when a step was still+running at three times the budget (it is abandoned); when building its+inputs took two budgets; or when the heap bound (@--heap@) was hit. Which of+these ended a series is recorded.+-}+module Main (main) where++import Control.Comonad.Cofree (Cofree (..))+import Control.Concurrent.STM (atomically, readTVar, retry)+import Control.Exception (AsyncException (HeapOverflow), Exception, bracket, evaluate, finally, throwIO, try)+import Control.Monad (forM, forM_, unless, when)+import Control.Monad.Identity (runIdentity)+import Data.Aeson (Value (..), encode, toJSON)+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Lazy as LByteString+import Data.Dynamic (toDyn)+import Data.Foldable (toList)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)+import Data.List (foldl', intercalate, nub)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, isNothing, mapMaybe)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time.Clock (getCurrentTime)+import Data.Word (Word64)+import GHC.Clock (getMonotonicTimeNSec)+import GHC.Stats (allocated_bytes, getRTSStats, getRTSStatsEnabled, max_mem_in_use_bytes)+import Options.Applicative hiding (help)+import qualified Options.Applicative as O+import System.Environment (getExecutablePath)+import System.Exit (ExitCode (..), exitFailure)+import System.IO (IOMode (AppendMode, WriteMode), hClose, hFlush, hPutStr, hPutStrLn, openFile, stderr, stdout)+import System.Mem (performMajorGC, performMinorGC)+import System.Posix.Process (exitImmediately)+import System.Process (CreateProcess (..), StdStream (NoStream), createPipe, createProcess, proc, terminateProcess, waitForProcess)+import System.Timeout (timeout)+import Text.Printf (printf)+import Text.Read (readMaybe)++import GHC.IO.Handle (hDuplicate, hDuplicateTo)++import qualified Salmon.Actions.Concurrent as Concurrent+import qualified Salmon.Actions.Dot as Dot+import qualified Salmon.Actions.Help as Help+import qualified Salmon.Actions.Query as Query+import Salmon.Actions.Serve (Convergence (..), NodeState (..))+import qualified Salmon.Actions.Serve as Serve+import qualified Salmon.Actions.Serve.Http as Http+import qualified Salmon.Actions.Serve.StatusSink as StatusSink+import qualified Salmon.Actions.UpDown as UpDown+import qualified Salmon.Actions.Upkeep as Upkeep+import Salmon.Builtin.Extension (Extension (..), Op, evalDeps, nodeps, op, opAct)+import qualified Salmon.Client.Model as Model+import Salmon.Op.Actions (Act (..))+import Salmon.Op.Configure (Configure (..))+import Salmon.Op.Dag (Dag (..))+import qualified Salmon.Op.Dag as Dag+import qualified Salmon.Op.Ledger as Ledger+import Salmon.Op.Ref (Ref, mkRef)+import qualified Salmon.Op.Rewrite as Rewrite+import Salmon.Op.Status (Direction (..), Stability (..), Status (..))+import Salmon.Op.Track (Track (..))+import Salmon.Reporter (ReporterM (..), silent)+import Salmon.Reporter.Tagged (Tagged (..))++import Test.DagReference (foldDagPerOccurrence, stuckRounds)+import Test.GraphFixture+import Test.PathListReference (outlinePathsUncapped)++-------------------------------------------------------------------------------+-- options++data Options' = Options'+    { optMaxSize :: Int+    , optMaxOccurrences :: Integer+    , optBudget :: Double+    , optOut :: Maybe FilePath+    , optOnly :: [String]+    , optShapes :: [String]+    , optSummarise :: Maybe FilePath+    , optList :: Bool+    , optHeap :: String+    , optSeries :: Maybe String+    }++optionsP :: Parser Options'+optionsP =+    Options'+        <$> option auto (long "max-size" <> metavar "NODES" <> value 10000 <> showDefault <> O.help "The size cap: no graph has more nodes than this.")+        <*> option auto (long "max-occurrences" <> metavar "N" <> value 30000000 <> showDefault <> O.help "The cap for operations that read the expanded graph: no expansion has more nodes than this.")+        <*> option auto (long "budget" <> metavar "SECONDS" <> value 10 <> showDefault <> O.help "A series stops after a step over a third of this, and a step is abandoned at three times this.")+        <*> optional (strOption (long "out" <> metavar "FILE" <> O.help "Append the rows to this file (tab-separated). Standard output otherwise."))+        <*> many (strOption (long "only" <> metavar "TEXT" <> O.help "Only the operations whose group or name contains this. Repeatable."))+        <*> many (strOption (long "shape" <> metavar "NAME" <> O.help "Only this shape (see --list). Repeatable."))+        <*> optional (strOption (long "summarise" <> metavar "FILE" <> O.help "Measure nothing: print the table of the rows in this file, as markdown."))+        <*> switch (long "list" <> O.help "Measure nothing: list the operations and the shapes.")+        <*> strOption (long "heap" <> metavar "SIZE" <> value "4g" <> showDefault <> O.help "The heap bound of each series (its process runs with +RTS -M<SIZE>).")+        <*> optional (strOption (long "series" <> metavar "SHAPE:INDEX" <> internal))++main :: IO ()+main = do+    opts <- execParser (info (optionsP <**> helper) (fullDesc <> progDesc "Time the graph operations over synthetic graphs of growing size."))+    case (optList opts, optSummarise opts, optSeries opts) of+        (True, _, _) -> do+            forM_ shapes $ \(name, shape) -> putStrLn ("shape\t" <> name <> "\t" <> show shape)+            forM_ benches $ \b -> putStrLn ("operation\t" <> benchGroup b <> "\t" <> benchName b <> "\t" <> scaleName (benchScale b))+        (_, Just path, _) -> summarise path+        (_, _, Just series)+            | (shapeName, ':' : index) <- break (== ':') series+            , Just shape <- lookup shapeName shapes+            , Just i <- readMaybe index+            , b : _ <- drop i benches ->+                measureSeries opts shapeName shape b+            | otherwise -> hPutStrLn stderr ("no such series: " <> series) >> exitFailure+        _ -> measureAll opts++-------------------------------------------------------------------------------+-- shapes and sizes++shapes :: [(String, Shape)]+shapes =+    [ ("chain", Chain)+    , ("fan", Fan)+    , ("tree2", Tree 2)+    , ("diamonds2", Diamonds 2)+    , ("layered8x2", Layered 8 2)+    , ("random8x3", RandomLayered 8 3)+    , ("dense32", Layered 32 32)+    ]++seed :: Seed+seed = 3++-- | What a series is sized by, and fitted against.+data Scale = PerNode | PerOccurrence+    deriving (Eq)++scaleName :: Scale -> String+scaleName PerNode = "nodes"+scaleName PerOccurrence = "occurrences"++-- | 100, 300, 1000, 3000, ...+targets :: [Integer]+targets = concat [[10 ^ k, 3 * 10 ^ k] | k <- [2 :: Int ..]]++-- | The requested sizes a series visits: for each target, the largest size+-- under the cap whose node count (or occurrence count) does not exceed it.+sizesFor :: Options' -> Scale -> Shape -> [Int]+sizesFor opts scale shape = dedupe (mapMaybe fit (takeWhile (<= ceiling') targets))+  where+    ceiling' = case scale of+        PerNode -> fromIntegral (optMaxSize opts)+        PerOccurrence -> optMaxOccurrences opts+    metric n = case scale of+        PerNode -> (counts shape n).countNodes+        PerOccurrence -> (counts shape n).countOccurrences+    fit t =+        let hi = fromIntegral (min t (fromIntegral (optMaxSize opts)))+            n = search 1 hi+         in if metric n <= t then Just n else Nothing+      where+        -- the largest n in [lo, hi] with metric n <= t; the metric never+        -- decreases with the requested size.+        search lo hi+            | lo >= hi = lo+            | otherwise =+                let mid = (lo + hi + 1) `div` 2+                 in if metric mid <= t then search mid hi else search lo (mid - 1)+    -- two requests that realise the same graph are one step.+    dedupe = go Nothing+      where+        go _ [] = []+        go prev (n : rest)+            | Just (counts shape n).countNodes == prev = go prev rest+            | otherwise = n : go (Just (counts shape n).countNodes) rest++-------------------------------------------------------------------------------+-- measuring++data Sample = Sample+    { sampleLabel :: String+    , sampleSecs :: Double+    , sampleAlloc :: Word64+    }++allocated :: IO Word64+allocated = allocated_bytes <$> getRTSStats++-- | One run of an action whose result is forced by the 'Int' it returns.+timed :: IO Int -> IO (Double, Word64)+timed act = do+    performMajorGC+    a0 <- allocated+    t0 <- getMonotonicTimeNSec+    n <- act+    _ <- evaluate n+    t1 <- getMonotonicTimeNSec+    -- the counter is only brought up to date by a collection.+    performMinorGC+    a1 <- allocated+    pure (fromIntegral (t1 - t0) / 1e9, a1 - a0)++{- | The outer action prepares one run and returns what to time, so that a+repeat never finds a structure the previous run already evaluated.+-}+best :: IO (IO Int) -> IO (Double, Word64)+best prepare = do+    first <- prepare >>= timed+    if fst first >= 0.25+        then pure first+        else do+            more <- forM [1 :: Int, 2] (const (prepare >>= timed))+            pure (foldl (\a b -> if fst b < fst a then b else a) first more)++-- | Time a sequence of steps that hand state on to each other, once each.+phases :: [(String, IO Int)] -> IO [Sample]+phases steps = forM steps $ \(label, act) -> do+    (secs, bytes) <- timed act+    pure (Sample label secs bytes)++data Env = Env+    { envShape :: Shape+    , envSize :: Int+    , envBudget :: Double+    , envFresh :: IO Op+    -- ^ a new root each time: an 'Op' keeps the predecessors it has been+    -- asked for, so a root that was expanded once is no longer a+    -- description of a graph but the graph.+    , envFreshManaged :: IO Op+    , envDag :: Dag Extension+    -- ^ shared by every operation at this size; built by 'dagOf'+    , envPaths :: Map.Map Ref [Text]+    -- ^ what @serve@ lists per node, see 'pathsOf'+    }++data Bench = Bench+    { benchGroup :: String+    , benchName :: String+    , benchScale :: Scale+    , benchRun :: Env -> IO [Sample]+    }++-- | An operation with one number to report.+single :: String -> String -> Scale -> (Env -> IO (IO Int)) -> Bench+single grp name scale prepare =+    Bench grp name scale $ \e -> do+        (secs, bytes) <- best (prepare e)+        pure [Sample "" secs bytes]++-- | An operation over the shared 'Dag', forced before the clock starts.+overDag :: String -> String -> (Dag Extension -> IO (IO Int)) -> Bench+overDag grp name prepare =+    single grp name PerNode $ \e -> do+        _ <- evaluate (weighDag e.envDag)+        prepare e.envDag++-- | Building an operation's inputs took too long: the series ends, and the+-- operation itself was not what ended it.+data InputsOver = InputsOver+    deriving (Show)++instance Exception InputsOver++row :: Bench -> String -> Shape -> Int -> String -> Double -> Word64 -> String -> String+row b shapeName shape size label secs bytes status =+    intercalate+        "\t"+        [ benchGroup b+        , benchName b+        , label+        , scaleName (benchScale b)+        , shapeName+        , show size+        , show c.countNodes+        , show c.countEdges+        , abbreviated c.countOccurrences+        , printf "%.6f" secs+        , show bytes+        , status+        ]+  where+    c = counts shape size+    -- a shape that shares has more occurrences than digits worth writing:+    -- past eighteen of them only the magnitude is kept, as @1e<exponent>@.+    abbreviated n =+        let digits = show n+         in if length digits <= 18 then digits else "1e" <> show (length digits - 1)++{- | Every series in a process of its own, one after the other.++A step that is abandoned leaves its threads behind (a supervisor's machines,+a loop mid-pass), and they keep waking: measured in one process, every+series after the first abandoned step came out hundreds of times slower+than it is. A series ends at its first abandoned step, so in a process of+its own nothing is measured after one.+-}+measureAll :: Options' -> IO ()+measureAll opts = do+    self <- getExecutablePath+    let selected = [(i, b) | (i, b) <- zip [0 :: Int ..] benches, null (optOnly opts) || any (\o -> isIn o (benchGroup b) || isIn o (benchName b)) (optOnly opts)]+        chosen = [s | s@(name, _) <- shapes, null (optShapes opts) || name `elem` optShapes opts]+    forM_ chosen $ \(shapeName, shape) ->+        forM_ selected $ \(i, b) -> do+            let args =+                    ["--max-size", show (optMaxSize opts), "--max-occurrences", show (optMaxOccurrences opts), "--budget", show (optBudget opts)]+                        <> concat [["--out", path] | Just path <- [optOut opts]]+                        <> ["--series", shapeName <> ":" <> show i, "+RTS", "-M" <> optHeap opts, "-RTS"]+            hFlush stdout+            (_, _, _, child) <- createProcess (proc self args){std_in = NoStream}+            -- a series is a dozen steps of at most three budgets each.+            ended <- timeout (round (60 * optBudget opts * 1e6)) (waitForProcess child)+            died <- case ended of+                Just ExitSuccess -> pure Nothing+                Just (ExitFailure code) -> pure (Just ("stop:exit " <> show code))+                Nothing -> do+                    terminateProcess child+                    _ <- waitForProcess child+                    pure (Just "stop:killed")+            forM_ died $ \why -> do+                let line = row b shapeName shape 0 "" 0 0 why+                maybe (putStrLn line) (`appendFile` (line <> "\n")) (optOut opts)+  where+    isIn needle hay = Text.pack needle `Text.isInfixOf` Text.pack hay++-- | One operation over one shape, at growing sizes, until it stops.+measureSeries :: Options' -> String -> Shape -> Bench -> IO ()+measureSeries opts shapeName shape b = do+    enabled <- getRTSStatsEnabled+    unless enabled $ do+        hPutStrLn stderr "the allocation counter is off: run with +RTS -T"+        exitFailure+    out <- maybe (pure stdout) (`openFile` AppendMode) (optOut opts)+    let scheduled = sizesFor opts (benchScale b) shape+        steps size = do+            let c = counts shape size+                say label secs bytes status = hPutStrLn out (row b shapeName shape size label secs bytes status) >> hFlush out+            hPutStrLn stderr (shapeName <> " " <> show c.countNodes <> " nodes: " <> benchGroup b <> " / " <> benchName b)+            env <- newEnv (optBudget opts) shape size+            outcome <- try (try (timeout (round (3 * optBudget opts * 1e6)) (benchRun b env)))+            case outcome of+                Left HeapOverflow -> say "" 0 0 "stop:heap" >> pure False+                Left other -> throwIO other+                Right (Left InputsOver) -> say "" 0 0 "stop:inputs" >> pure False+                Right (Right Nothing) -> say "" 0 0 "stop:timeout" >> pure False+                Right (Right (Just samples)) -> do+                    forM_ samples $ \s -> say (sampleLabel s) (sampleSecs s) (sampleAlloc s) "ok"+                    if maximum (0 : fmap sampleSecs samples) > optBudget opts / 3+                        then say "" 0 0 "stop:budget" >> pure False+                        else+                            if size == last scheduled+                                then say "" 0 0 "stop:cap" >> pure False+                                else pure True+        go [] = pure ()+        go (size : rest) = do+            more <- steps size+            performMajorGC+            when more (go rest)+    go scheduled+    peak <- max_mem_in_use_bytes <$> getRTSStats+    hPutStrLn stderr ("peak memory in use: " <> show (peak `div` (1024 * 1024)) <> " MiB")+    hClose out+    -- not a normal return: whatever an abandoned step left running is not waited for.+    hFlush stdout+    exitImmediately ExitSuccess++newEnv :: Double -> Shape -> Int -> IO Env+newEnv budget shape size = do+    -- read back through a reference so that no two calls can be shared.+    cell <- newIORef seed+    let fresh options = do+            s <- readIORef cell+            pure (generateWith options shape size s)+    root <- fresh fixtureOptions+    pathRoot <- fresh fixtureOptions+    pure+        Env+            { envShape = shape+            , envSize = size+            , envBudget = budget+            , envFresh = fresh fixtureOptions+            , envFreshManaged = fresh fixtureOptions{optManaged = True}+            , envDag = dagOf root+            , envPaths = pathsOf pathRoot+            }++-- | A marker one node in ten carries, sixteen values of it: what the+-- rewrites below collect.+newtype Batch = Batch Int+    deriving (Show, Eq, Ord)++{- | The nodes every series runs over: no-ops whose @check@ answers+'UpDown.Immaterial' (what a node with no check says, so an @up@ pass runs+every @up@), one in ten carrying a 'Batch'.+-}+fixtureOptions :: Options+fixtureOptions =+    defaultOptions+        { optDynamics = \i -> [toDyn (Batch ((i `div` 10) `mod` 16)) | i `mod` 10 == 0]+        }++-------------------------------------------------------------------------------+-- forcing++weighDag :: Dag ext -> Int+weighDag dag =+    Map.size (dagNodes dag)+        + sum (fmap length (Map.elems (dagDependencies dag)))+        + sum (fmap length (Map.elems (dagDependants dag)))+        + length (dagOrderRev dag)+        + length (dagConflicts dag)++weighTexts :: [Text] -> Int+weighTexts = foldl' (\n t -> n + Text.length t) 0++weighPaths :: Map.Map Ref [Text] -> Int+weighPaths = Map.foldl' (\n ts -> n + weighTexts ts) 0++weighBytes :: LByteString.ByteString -> Int+weighBytes = fromIntegral . LByteString.length++-- | The number of nodes of an expansion, without the stack a recursion+-- over a deep one would take.+weighCofree :: Cofree f a -> ([Cofree f a] -> f (Cofree f a) -> [Cofree f a]) -> Int+weighCofree root push = go 0 [root]+  where+    go !n [] = n+    go !n ((_ :< g) : rest) = go (n + 1) (push rest g)++expansionSize :: Op -> Int+expansionSize root = weighCofree (evalDeps root) (\rest g -> toList g <> rest)++weighModel :: Model.Model -> Int+weighModel m =+    Model.orderSize m.modelOrder+        + Map.foldl' (\n x -> n + Text.length x.nodeShorthand + length x.nodeDependencies + length x.nodeDependants + length x.nodePaths + Text.length x.nodeConvergence) 0 m.modelNodes++-- | Run an action with standard output going nowhere: two of the renders+-- print rather than return.+quietly :: IO a -> IO a+quietly act =+    bracket+        ( do+            hFlush stdout+            saved <- hDuplicate stdout+            devNull <- openFile "/dev/null" WriteMode+            hDuplicateTo devNull stdout+            hClose devNull+            pure saved+        )+        (\saved -> hFlush stdout >> hDuplicateTo saved stdout >> hClose saved)+        (const act)++-------------------------------------------------------------------------------+-- the operations++{- | The paths @serve@ lists for each node ('Serve.worldPaths', for a world+with one declaration): at most 'Query.pathLimit' per node, a path longer+than 'Query.pathCap' shown as its tail.+-}+pathsOf :: Op -> Map.Map Ref [Text]+pathsOf root =+    Map.map (fmap Query.renderListedPath) (Query.outlinePaths Query.pathLimit Query.pathCap (Query.outline (evalDeps root)))++-- | The same before the cap ("Test.PathListReference"): every path in full.+pathsUncappedOf :: Op -> Map.Map Ref [Text]+pathsUncappedOf root =+    Map.map (fmap (Text.intercalate "/")) (outlinePathsUncapped Query.pathLimit (Query.outline (evalDeps root)))++benches :: [Bench]+benches =+    concat+        [ foldBenches+        , dagBenches+        , walkBenches+        , upkeepBenches+        , rewriteBenches+        , [ledgerBench]+        , queryBenches+        , [serveBench]+        , renderBenches+        , clientBenches+        ]++foldBenches :: [Bench]+foldBenches =+    [ single "fold" "expand (evalDeps, every occurrence visited)" PerOccurrence $ \e -> do+        root <- e.envFresh+        pure (evaluate (expansionSize root))+    , single "fold" "expand + foldDag" PerNode $ \e -> do+        root <- e.envFresh+        pure (evaluate (weighDag (Dag.foldDag Dag.sameRepresentative (evalDeps root))))+    , -- what 'Dag.foldDag' was before it went per node, for the comparison:+      -- "Test.DagReference", which the tests use as their reference.+      single "fold" "expand + foldDagPerOccurrence (the fold before it went per node)" PerOccurrence $ \e -> do+        root <- e.envFresh+        pure (evaluate (weighDag (foldDagPerOccurrence Dag.sameRepresentative (evalDeps root))))+    , single "fold" "dagOf (the fixture's per-node build, for comparison)" PerNode $ \e -> do+        root <- e.envFresh+        pure (evaluate (weighDag (dagOf root)))+    ]++dagBenches :: [Bench]+dagBenches =+    [ overDag "dag" "fromMagma" $ \dag -> do+        let magma = dagNodes dag+            edges = Dag.dagEdges dag+        _ <- evaluate (Map.size magma + Set.size edges)+        pure (evaluate (weighDag (Dag.fromMagma magma edges)))+    , overDag "dag" "mergeDag into an empty Dag" $ \dag ->+        pure (evaluate (weighDag (Dag.mergeDag Dag.sameRepresentative Dag.emptyDag dag)))+    , overDag "dag" "mergeDag onto itself" $ \dag ->+        pure (evaluate (weighDag (Dag.mergeDag Dag.sameRepresentative dag dag)))+    , overDag "dag" "dagEdges" $ \dag ->+        pure (evaluate (Set.size (Dag.dagEdges dag)))+    , overDag "dag" "roots + leaves" $ \dag ->+        pure (evaluate (length (Dag.roots dag) + length (Dag.leaves dag)))+    , overDag "dag" "stuck (waiting on dependencies)" $ \dag ->+        pure (evaluate (Set.size (Dag.stuck Dag.dependenciesOf dag)))+    , overDag "dag" "stuck (waiting on dependants)" $ \dag ->+        pure (evaluate (Set.size (Dag.stuck Dag.dependantsOf dag)))+    , -- what 'Dag.stuck' was before it went one pass, for the comparison:+      -- "Test.DagReference", which the tests use as their reference.+      overDag "dag" "stuckRounds (stuck before it went one pass, waiting on dependencies)" $ \dag ->+        pure (evaluate (Set.size (stuckRounds Dag.dependenciesOf dag)))+    ]++walkBenches :: [Bench]+walkBenches =+    [ overDag "walk" "upDag (sequential)" $ \dag ->+        pure (fromEnum <$> UpDown.upDag UpDown.alwaysRequired silent dag)+    , overDag "walk" "downDag (sequential)" $ \dag ->+        pure (fromEnum <$> UpDown.downDag UpDown.alwaysRequired silent dag)+    , overDag "walk" "upDagConcurrent" $ \dag ->+        pure (fromEnum <$> Concurrent.upDagConcurrent UpDown.alwaysRequired silent Concurrent.noMailboxes Nothing dag)+    , overDag "walk" "downDagConcurrent" $ \dag ->+        pure (fromEnum <$> Concurrent.downDagConcurrent UpDown.alwaysRequired silent Concurrent.noMailboxes Nothing dag)+    ]++-- | Wait until every machine has settled.+awaitStable :: Upkeep.Supervisor Extension -> IO Int+awaitStable sup = do+    forM_ (Map.elems (Upkeep.supervisorStatuses sup)) $ \var ->+        atomically $ do+            st <- readTVar var+            unless (st.statusStability == Stable) retry+    pure (Map.size (Upkeep.supervisorStatuses sup))++-- | Stop a supervisor a step left behind, whatever it was holding.+standDown :: IORef (Maybe (Upkeep.Supervisor Extension)) -> IO ()+standDown cell = do+    left <- readIORef cell+    writeIORef cell Nothing+    forM_ left $ \sup -> do+        kept <- Upkeep.stopUpkeep sup+        _ <- Upkeep.releaseKept silent (const False) kept+        pure ()++upkeepBenches :: [Bench]+upkeepBenches =+    [ Bench "upkeep" "tend nodes already up (settled)" PerNode $ \e -> do+        _ <- evaluate (weighDag e.envDag)+        cell <- newIORef Nothing+        flip finally (standDown cell) $+            phases+                [+                    ( "startUpkeep"+                    , do+                        sup <- Upkeep.startUpkeep silent Upkeep.noKept (const (Just (Upkeep.Tend TurnUp Upkeep.Settled))) e.envDag+                        writeIORef cell (Just sup)+                        pure (Map.size (Upkeep.supervisorStatuses sup))+                    )+                , ("until every machine is stable", readIORef cell >>= maybe (pure 0) awaitStable)+                , ("stopUpkeep", standDown cell >> pure 0)+                ]+    , Bench "upkeep" "bring nodes up (unsettled)" PerNode $ \e -> do+        _ <- evaluate (weighDag e.envDag)+        cell <- newIORef Nothing+        flip finally (standDown cell) $+            phases+                [+                    ( "startUpkeep"+                    , do+                        sup <- Upkeep.startUpkeep silent Upkeep.noKept (const (Just (Upkeep.Tend TurnUp Upkeep.Unsettled))) e.envDag+                        writeIORef cell (Just sup)+                        pure (Map.size (Upkeep.supervisorStatuses sup))+                    )+                , ("until every machine is stable", readIORef cell >>= maybe (pure 0) awaitStable)+                , ("stopUpkeep", standDown cell >> pure 0)+                ]+    , Bench "upkeep" "managed nodes: hold, hand over, adopt" PerNode $ \e -> do+        root <- e.envFreshManaged+        let dag = dagOf root+            tend = const (Just (Upkeep.Tend TurnUp Upkeep.Unsettled))+        _ <- evaluate (weighDag dag)+        cell <- newIORef Nothing+        kept <- newIORef Upkeep.noKept+        let release = do+                standDown cell+                held <- readIORef kept+                writeIORef kept Upkeep.noKept+                _ <- Upkeep.releaseKept silent (const False) held+                pure ()+        flip finally release $+            phases+                [+                    ( "startUpkeep"+                    , do+                        sup <- Upkeep.startUpkeep silent Upkeep.noKept tend dag+                        writeIORef cell (Just sup)+                        pure (Map.size (Upkeep.supervisorStatuses sup))+                    )+                , ("until every machine is stable", readIORef cell >>= maybe (pure 0) awaitStable)+                ,+                    ( "stopUpkeep (machines kept)"+                    , do+                        left <- readIORef cell+                        writeIORef cell Nothing+                        forM_ left $ \sup -> Upkeep.stopUpkeep sup >>= writeIORef kept+                        Map.size . Upkeep.keptHeld <$> readIORef kept+                    )+                ,+                    ( "startUpkeep (adopting)"+                    , do+                        held <- readIORef kept+                        writeIORef kept Upkeep.noKept+                        sup <- Upkeep.startUpkeep silent held tend dag+                        writeIORef cell (Just sup)+                        pure (Map.size (Upkeep.supervisorStatuses sup))+                    )+                , ("stopUpkeep + releaseKept", release >> pure 0)+                ]+    ]++rewriteBenches :: [Bench]+rewriteBenches =+    [ overDag "rewrite" "no phase registered (wholeGraph + rewrite)" $ \dag ->+        pure (evaluate (weighRewritten (Rewrite.rewrite [] (Rewrite.wholeGraph dag) dag)))+    , overDag "rewrite" "one batch of a tenth of the nodes" $ \dag ->+        pure (evaluate (weighRewritten (Rewrite.rewrite [oneBatch] (Rewrite.wholeGraph dag) dag)))+    , overDag "rewrite" "sixteen batches of a tenth of the nodes" $ \dag ->+        pure (evaluate (weighRewritten (Rewrite.rewrite [sixteenBatches] (Rewrite.wholeGraph dag) dag)))+    ]+  where+    weighRewritten r = weighDag (Rewrite.computedDag r) + sum (fmap Set.size (Map.elems (Rewrite.computedMembers r)))++    oneBatch :: Rewrite.Rewrite Extension+    oneBatch _ r =+        Rewrite.introduce (batchAct 0) (Set.fromList [aref | (aref, _ :: [Batch]) <- Rewrite.collectDynamic r]) r++    sixteenBatches :: Rewrite.Rewrite Extension+    sixteenBatches _ r =+        let groups = Map.fromListWith Set.union [(k, Set.singleton aref) | (aref, Batch k : _) <- Rewrite.collectDynamic r]+         in foldl' (\acc (k, members) -> Rewrite.introduce (batchAct (k + 1)) members acc) r (Map.toList groups)++    batchAct :: Int -> Act Extension+    batchAct k =+        fromMaybe (error "a batch node with no action") $+            opAct (op "batch" nodeps (\x -> x{ref = mkRef "graph-profiles-batch" k, help = "a batch"}))++{- | Eight declarations over the same graph, each leaving out a different+eighth of its nodes: several declarations that mostly overlap.+-}+ledgerBench :: Bench+ledgerBench =+    Bench "ledger" "eight overlapping declarations" PerNode $ \e -> do+        let dag = e.envDag+            position = Map.fromList (zip (Dag.dagOrder dag) [0 :: Int ..])+            whole = Ledger.contribution dag+            keeps k r = maybe False (\i -> i `mod` 8 /= k) (Map.lookup r position)+            part k =+                whole+                    { Ledger.contribRefs = Set.filter (keeps k) (Ledger.contribRefs whole)+                    , Ledger.contribEdges = Set.filter (\(a, b) -> keeps k a && keeps k b) (Ledger.contribEdges whole)+                    }+            ledger = foldl' (\l k -> Ledger.declare k (part k) l) Ledger.emptyLedger [0 .. 7 :: Int]+        _ <- evaluate (weighDag dag)+        _ <- evaluate (sum [Set.size (Ledger.contribRefs c) + Set.size (Ledger.contribEdges c) | c <- Map.elems ledger])+        phases+            [ ("contribution (of one Dag)", evaluate (let c = Ledger.contribution dag in Set.size (Ledger.contribRefs c) + Set.size (Ledger.contribEdges c)))+            , ("desired", evaluate (Set.size (Ledger.desired ledger)))+            , ("precedenceOf", evaluate (Set.size (Ledger.precedenceOf ledger)))+            , ("knownRefs", evaluate (Set.size (Ledger.knownRefs ledger)))+            , ("retractAll + collect, nothing standing", evaluate (Map.size (Ledger.collect (const False) (Ledger.retractAll ledger))))+            ]++queryBenches :: [Bench]+queryBenches =+    [ single "query" "outline" PerNode $ \e -> do+        root <- e.envFresh+        pure (evaluate (Set.size (Query.outlineRefs (Query.outline (evalDeps root)))))+    , single "query" "paths per node (outline + outlinePaths, as worldPaths)" PerNode $ \e -> do+        root <- e.envFresh+        pure (evaluate (weighPaths (pathsOf root)))+    , single "query" "paths per node, uncapped reference (outlinePathsUncapped)" PerNode $ \e -> do+        root <- e.envFresh+        pure (evaluate (weighPaths (pathsUncappedOf root)))+    , single "query" "resolveSelectors (select **, exclude **/n1/**)" PerNode $ \e -> do+        root <- e.envFresh+        pure $ do+            let (selected, excluded) = Query.resolveSelectors (evalDeps root) ["**"] ["**/n1/**"]+            evaluate (Set.size selected + Set.size excluded)+    , single "query" "query show --dedupe (renderAnnotated)" PerNode $ \e -> do+        root <- e.envFresh+        pure (evaluate (weighTexts (Query.renderAnnotated (evalDeps root) Set.empty Set.empty True True)))+    , single "query" "query show, every path (renderAnnotated)" PerOccurrence $ \e -> do+        root <- e.envFresh+        pure (evaluate (weighTexts (Query.renderAnnotated (evalDeps root) Set.empty Set.empty False True)))+    , single "query" "query plan (expand, fold, resolve, encode)" PerNode $ \e -> do+        root <- e.envFresh+        pure $ do+            -- what the command line does for @query plan@, minus reading the directive.+            let cograph = evalDeps root+            dag <- UpDown.expandDag silent (pure . runIdentity) root+            let computed = Rewrite.rewrite [] (Rewrite.wholeGraph dag) dag+                (_, excluded) = Query.resolveRewrittenSelectors cograph computed [] ["**/n1/**"]+                plan = Query.Plan "digest" (Set.toList excluded) ["**/n1/**"] Nothing+            evaluate (weighBytes (encode plan))+    , overDag "query" "run tree (dagLines)" $ \dag ->+        pure (evaluate (weighTexts (Help.dagLines dag)))+    , overDag "query" "run dag (printDagCograph, to /dev/null)" $ \dag ->+        pure (quietly (Dot.printDagCograph dag) >> pure 0)+    ]++{- | The loop itself, over a scripted input: supervision off (so nothing+tends between commands), one declaration, @status@, an idle @converge@,+@clear@. The steps are the intervals between the loop's own reports, so+each is what the operator waits for; evaluation is lazy, so a step can be+charged work that an earlier one set up.+-}+serveBench :: Bench+serveBench =+    Bench "serve" "loop" PerNode $ \e -> do+        marks <- newIORef []+        let mark name = do+                t <- getMonotonicTimeNSec+                performMinorGC+                a <- allocated+                t' <- getMonotonicTimeNSec+                modifyIORef' marks ((name, t, a, t') :)+            reporter = ReporterM $ \rep -> case rep of+                Serve.Supervised _ -> mark "supervised"+                Serve.Declared{} -> mark "declared"+                Serve.ConvergeStart{} -> mark "converge-start"+                Serve.ConvergeStop{} -> mark "converge-stop"+                Serve.StatusReport _ nodes paths -> do+                    _ <- evaluate (length nodes + weighPaths paths)+                    mark "status"+                Serve.Cleared _ -> mark "cleared"+                _ -> pure ()+            parse args = case args of+                [n] | Just size <- readMaybe n -> Right (size :: Int)+                _ -> Left "expected a size"+            program = Track (\size -> generateWith fixtureOptions e.envShape size seed)+        (readEnd, writeEnd) <- createPipe+        hPutStr writeEnd (unlines ["supervise off", "up " <> show e.envSize, "status", "converge", "clear"])+        hClose writeEnd+        performMajorGC+        _ <- Serve.serveWith [] Nothing True reporter silent parse (Configure pure) program readEnd+        seen <- reverse <$> readIORef marks+        let intervals = [(from <> " -> " <> to, fromIntegral (t1 - t0) / 1e9, a1 - a0) | ((from, _, a0, t0), (to, t1, a1, _)) <- zip seen (drop 1 seen)]+            names =+                [ "record a declaration (expand, fold, ledger)"+                , "before the first pass (rewrite, worldDag)"+                , "first pass, every node up"+                , "status"+                , "before the idle pass"+                , "idle pass, nothing pending"+                , "clear"+                , "before the teardown pass"+                , "teardown pass, every node down"+                ]+            expected = ["supervised", "declared", "converge-start", "converge-stop", "status", "converge-start", "converge-stop", "cleared", "converge-start", "converge-stop"]+        if [name | (name, _, _, _) <- seen] == expected+            then pure [Sample name secs bytes | (name, (_, secs, bytes)) <- zip names intervals]+            else pure [Sample ("unexpected: " <> name) secs bytes | (name, secs, bytes) <- intervals]++-- | What the HTTP reads are answered from, for a world whose nodes are all up.+viewOf :: Env -> Http.WorldView+viewOf e =+    Http.WorldView+        { Http.viewDag = e.envDag+        , Http.viewConflicts = Map.empty+        , Http.viewNodes = nodeStates e+        , Http.viewPaths = e.envPaths+        , Http.viewHistory = []+        , Http.viewElided = 0+        }++nodeStates :: Env -> Map.Map Ref NodeState+nodeStates e =+    Map.map+        (\act -> NodeState{nodeShorthand = act.shorthand, nodeHelp = act.extension.help, nodeDirection = Serve.TurnUp, nodeConvergence = Converged, nodeStatus = Nothing, nodeHeld = Nothing})+        (dagNodes e.envDag)++{- | The inputs of a render, forced. The listed paths are the expensive one+(the query group times them on their own), so they are given two budgets+and the series ends as 'InputsOver' rather than as a slow render.+-}+readied :: Env -> IO ()+readied e = do+    _ <- evaluate (weighDag e.envDag)+    listed <- timeout (round (2 * e.envBudget * 1e6)) (evaluate (weighPaths e.envPaths))+    when (isNothing listed) (throwIO InputsOver)+    _ <- evaluate (Map.foldl' (\n st -> n + Text.length st.nodeShorthand) 0 (nodeStates e))+    pure ()++renderBenches :: [Bench]+renderBenches =+    [ single "render" "GET /dag (dagValue + encode)" PerNode $ \e -> do+        readied e+        let view = viewOf e+        pure (evaluate (weighBytes (encode (Http.dagValue Serve.Interactive view))))+    , single "render" "GET /status (status report + encode)" PerNode $ \e -> do+        readied e+        let nodes = nodeStates e+        pure (evaluate (weighBytes (encode (toJSON (FromServe (Serve.StatusReport Serve.Interactive (Map.toList nodes) e.envPaths))))))+    , single "render" "status sink document (encode)" PerNode $ \e -> do+        readied e+        let nodes = nodeStates e+        now <- getCurrentTime+        pure $+            evaluate . weighBytes . encode $+                StatusSink.Document+                    { StatusSink.docHost = "host"+                    , StatusSink.docWritten = now+                    , StatusSink.docMode = Serve.renderMode Serve.Interactive+                    , StatusSink.docLabels = []+                    , StatusSink.docStatus = toJSON (Serve.StatusReport Serve.Interactive (Map.toList nodes) e.envPaths)+                    , StatusSink.docLastConverge = Nothing+                    , StatusSink.docLastFollow = Nothing+                    }+    ]++-- | A @\/dag@ answer as a client receives it, already decoded.+dagAnswer :: Env -> IO Value+dagAnswer e = do+    readied e+    let answer = case Http.dagValue Serve.Interactive (viewOf e) of+            Object o -> Object (KeyMap.insert "seq" (Number 0) o)+            other -> other+    _ <- evaluate (weighBytes (encode answer))+    pure answer++modelOf :: Env -> IO Model.Model+modelOf e = do+    answer <- dagAnswer e+    case Model.fromDag answer of+        Left err -> error ("fromDag: " <> err)+        Right m -> do+            _ <- evaluate (weighModel m)+            pure m++doneEvents :: Model.Model -> [Model.Event]+doneEvents m = [Model.Event (Just i) "updown" "done" (Just r) Nothing Null | (i, r) <- zip [1 ..] (Model.orderToList m.modelOrder)]++clientBenches :: [Bench]+clientBenches =+    [ single "client" "Model.fromDag" PerNode $ \e -> do+        answer <- dagAnswer e+        pure (evaluate (either (const 0) weighModel (Model.fromDag answer)))+    , single "client" "Model.step, one done event per node" PerNode $ \e -> do+        m <- modelOf e+        let events = doneEvents m+        _ <- evaluate (length events)+        pure (evaluate (weighModel (foldl' Model.step m events)))+    , single "client" "Model.step, a teardown: one done event per node wanted down" PerNode $ \e -> do+        m0 <- modelOf e+        let m = m0{Model.modelNodes = Map.map (\n -> n{Model.nodeDirection = "down"}) m0.modelNodes}+            events = doneEvents m+        _ <- evaluate (weighModel m + length events)+        pure (evaluate (weighModel (foldl' Model.step m events)))+    ]++-------------------------------------------------------------------------------+-- the table++data Row = Row+    { rowGroup :: String+    , rowBench :: String+    , rowLabel :: String+    , rowScale :: String+    , rowShape :: String+    , rowNodes :: Integer+    , rowOccurrences :: Integer+    , rowSecs :: Double+    , rowAlloc :: Double+    , rowStatus :: String+    }++parseRow :: String -> Maybe Row+parseRow line =+    case splitTabs line of+        [grp, bench, label, scale, shape, _, nodes, _, occurrences, secs, bytes, status] ->+            Row grp bench label scale shape <$> readMaybe nodes <*> magnitude occurrences <*> readMaybe secs <*> readMaybe bytes <*> pure status+        _ -> Nothing+  where+    magnitude s = case s of+        '1' : 'e' : k -> (10 ^) <$> (readMaybe k :: Maybe Int)+        _ -> readMaybe s+    splitTabs s = case break (== '\t') s of+        (cell, []) -> [cell]+        (cell, _ : rest) -> cell : splitTabs rest++{- | One table per group: an operation per row, a shape per column. A cell+reads @growth, largest size, time and allocation there, why it stopped@.+The growth is the slope of log time against log size over the last four+steps that took at least a millisecond.+-}+summarise :: FilePath -> IO ()+summarise path = do+    rows <- mapMaybe parseRow . lines <$> readFile path+    let groups = nub (fmap rowGroup rows)+    forM_ groups $ \grp -> do+        let inGroup = [r | r <- rows, rowGroup r == grp]+            series = nub [(rowBench r, rowLabel r) | r <- inGroup, rowStatus r == "ok"]+        putStrLn ("### " <> grp)+        putStrLn ""+        putStrLn ("| operation | sized by | " <> intercalate " | " (fmap fst shapes) <> " |")+        putStrLn ("|---|---|" <> concatMap (const "---|") shapes)+        forM_ series $ \(bench, label) -> do+            let mine = [r | r <- inGroup, rowBench r == bench]+                scale = maybe "" rowScale (safeHead mine)+                title = if null label then bench else bench <> ": " <> label+            cells <- forM shapes $ \(shapeName, _) -> do+                let points = [r | r <- mine, rowShape r == shapeName, rowLabel r == label, rowStatus r == "ok"]+                    ending = [r | r <- mine, rowShape r == shapeName, take 5 (rowStatus r) == "stop:"]+                pure (cell scale points ending)+            putStrLn ("| " <> title <> " | " <> scale <> " | " <> intercalate " | " cells <> " |")+        putStrLn ""+  where+    safeHead xs = case xs of+        [] -> Nothing+        (x : _) -> Just x++    size scale r = if scale == "occurrences" then rowOccurrences r else rowNodes r++    cell :: String -> [Row] -> [Row] -> String+    cell _ [] _ = "-"+    cell scale points ending =+        let top = last points+            why = case ending of+                [] -> "interrupted"+                (r : _) -> case drop 5 (rowStatus r) of+                    "cap" -> "cap"+                    "budget" -> "budget"+                    other+                        | rowNodes r <= 1 -> "process: " <> other+                        | otherwise -> other <> " at " <> human (size scale r)+         in growth scale points <> ", " <> human (size scale top) <> sizeNote scale top <> ": " <> seconds (rowSecs top) <> ", " <> bytes (rowAlloc top) <> " (" <> why <> ")"++    -- for a series sized by occurrences, the node count it corresponds to.+    sizeNote scale r+        | scale == "occurrences" && rowOccurrences r /= rowNodes r = " (" <> human (rowNodes r) <> " nodes)"+        | otherwise = ""++    growth :: String -> [Row] -> String+    growth scale points =+        let usable = [(log (fromIntegral (size scale r)), log (rowSecs r)) | r <- points, rowSecs r >= 0.001]+            window = drop (length usable - 4) usable+         in if length window < 3+                then "too fast to fit"+                else printf "n^%.1f" (slope window)++    slope :: [(Double, Double)] -> Double+    slope pts =+        let n = fromIntegral (length pts)+            mx = sum (fmap fst pts) / n+            my = sum (fmap snd pts) / n+            sxx = sum [(x - mx) ^ (2 :: Int) | (x, _) <- pts]+            sxy = sum [(x - mx) * (y - my) | (x, y) <- pts]+         in if sxx == 0 then 0 else sxy / sxx++    human :: Integer -> String+    human n+        | n >= 999950 = printf "%.1fM" (fromIntegral n / 1e6 :: Double)+        | n >= 1000 = printf "%.1fk" (fromIntegral n / 1e3 :: Double)+        | otherwise = show n++    seconds :: Double -> String+    seconds s+        | s >= 1 = printf "%.1f s" s+        | s >= 0.001 = printf "%.0f ms" (s * 1e3)+        | otherwise = printf "%.0f us" (s * 1e6)++    bytes :: Double -> String+    bytes b+        | b >= 1e9 = printf "%.1f GB" (b / 1e9)+        | b >= 1e6 = printf "%.0f MB" (b / 1e6)+        | otherwise = printf "%.0f kB" (b / 1e3)

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               salmon-ops-recipes-version:            0.1.0.0+version:            0.2.0.0 synopsis:           Opinionated recipes built from Salmon builtins. description:        Higher-level recipes (postgres migrations, postgres primary/standby pairs, micro DNS, ...) composed from salmon-ops builtins. homepage:           https://lucasdicioccio.github.io/salmon/@@ -33,13 +33,17 @@                    , SreBox.PostgresBackup                    , SreBox.PostgresTemplate                    , SreBox.PostgresPair+                   , SreBox.PostgresPairPrereqs+                   , SreBox.PgVectorDemo                    , SreBox.JWTSigning                    , SreBox.WireGuardVpn+                   , SreBox.WireGuardMesh                    , SreBox.Gcp.VmProvision                    , SreBox.Gcp.CloudRunDeploy                    , SreBox.Gcp.CloudRunAlerts                    , SreBox.Gcp.PostgrestCloudRun                    , SreBox.Gcp.PreviewEnvironment+                   , SreBox.Gcp.PlakarGcsBackup     build-depends:    base >=4.16.3.0 && <4.22                     , aeson                     , base16-bytestring@@ -68,7 +72,7 @@                     , process                     , process-extras                     , salmon-core ^>=0.1.0.0-                    , salmon-ops ^>=0.1.0.0+                    , salmon-ops ^>=0.2.0.0                     , text                     , time                     , tls@@ -88,19 +92,46 @@     hs-source-dirs:   test     other-modules:    Test.Harness                     , Test.CheckSpec+                    , Test.AmendNodeSpec+                    , Test.CardTemplateSpec+                    , Test.BuiltinCardsSpec+                    , Test.HttpServerFlagSpec+                    , Test.ClientModelReference                     , Test.ClientModelSpec+                    , Test.ClientModelStepSpec                     , Test.AptRepositorySpec                     , Test.DebianPackageSpec+                    , Test.ClipCppSpec                     , Test.LlamaServerSpec                     , Test.ServeApi                     , Test.ServeApiSpec                     , Test.PgVectorSpec+                    , Test.PgVectorDemoSpec+                    , Test.PgTextSearchSpec                     , Test.PlakarSpec                     , Test.WireGuardSpec+                    , Test.WireGuardMeshSpec+                    , Test.NetbirdSpec+                    , Test.PortMappingSpec+                    , Test.RsyncSpec                     , Test.DebootstrapSpec                     , Test.ConcurrentSpec+                    , Test.BinaryOutputSpec+                    , Test.BinarySpec                     , Test.DaemonSpec+                    , Test.DetachedSpec                     , Test.DagSpec+                    , Test.DagPerNodeSpec+                    , Test.DagReference+                    , Test.DagStuckSpec+                    , Test.EdgeListReference+                    , Test.EdgeListSpec+                    , Test.GraphFixture+                    , Test.GraphFixtureSpec+                    , Test.GraphScaleSpec+                    , Test.ListedPathsSpec+                    , Test.PathListReference+                    , Test.DeferredSpec                     , Test.DownTreeSpec                     , Test.FilesystemSpec                     , Test.FollowCacheSpec@@ -109,31 +140,42 @@                     , Test.FollowSignatureSpec                     , Test.FollowSpec                     , Test.GcpSpec+                    , Test.SecretDeliverySpec                     , Test.PodmanCommandSpec                     , Test.JWTSigningSpec                     , Test.LedgerSpec                     , Test.MigratorTemplateSpec                     , Test.PgBackupSpec+                    , Test.PgBackRestSpec                     , Test.PodmanSpec                     , Test.PostgresBackupSpec                     , Test.PostgresInitSpec                     , Test.PostgresReplicationSpec                     , Test.PostgresClusterSpec                     , Test.PgBouncerSpec+                    , Test.HaproxySpec                     , Test.EtcdSpec+                    , Test.PatroniSpec+                    , Test.PatroniPreferredLeaderSpec+                    , Test.PatroniRollingMaintenanceSpec                     , Test.PgPairDemoSpec+                    , Test.PatroniArchiveVmsSpec                     , Test.PatroniHarnessSpec                     , Test.PatroniVms                     , Test.PostgresPairSpec+                    , Test.PostgresPairPrereqsSpec                     , Test.PostgresSwitchoverSpec                     , Test.PostgresVms                     , Test.PostgresTemplateSpec+                    , Test.PostgresUserSpec                     , Test.PostgresTlsSpec                     , Test.PostgrestCloudRunSpec                     , Test.QemuResolveKernelSpec                     , Test.QemuShutdownSpec                     , Test.QemuSmokeSpec                     , Test.QuerySpec+                    , Test.ReadinessSpec+                    , Test.RemoteOutputSpec                     , Test.ReportJsonSpec                     , Test.RewriteSpec                     , Test.ServeEventsSpec@@ -143,10 +185,18 @@                     , Test.ServeSpec                     , Test.ServeTlsSpec                     , Test.StatusSinkSpec+                    , Test.QuadletSpec+                    , Test.QuadletUserSpec+                    , Test.SharedDirSpec+                    , Test.SystemdJobSpec                     , Test.SystemdSpec+                    , Test.UiTailTemplateSpec+                    , Test.UpDownTextSpec                     , Test.UpTreeSpec                     , Test.UpkeepSpec+                    , Test.UpkeepRetentionSpec                     , Test.WindowSpec+                    , Test.WrapperOrderingSpec     build-depends:    QuickCheck                     , base >=4.16.3.0 && <4.22                     , aeson@@ -159,6 +209,7 @@                     , directory                     , filepath                     , free+                    , ghc-heap                     , http-client                     , http-client-tls                     , http-types@@ -169,8 +220,8 @@                     , process-extras                     , stm                     , salmon-core ^>=0.1.0.0-                    , salmon-ops ^>=0.1.0.0-                    , salmon-ops-recipes ^>=0.1.0.0+                    , salmon-ops ^>=0.2.0.0+                    , salmon-ops-recipes ^>=0.2.0.0                     , tasty                     , tasty-hunit                     , tasty-quickcheck@@ -183,8 +234,46 @@                     , warp     -- Salmon.Actions.Serve reads its input handle on a forked thread, so a     -- test driving the loop wants a runtime where a blocking read does not-    -- stall every other Haskell thread.-    ghc-options:      -threaded+    -- stall every other Haskell thread. -rtsopts so that a large-graph run+    -- (Test.GraphFixtureSpec's opt-in case) can be given a heap bound.+    ghc-options:      -threaded -rtsopts+    default-language: Haskell2010+    default-extensions: DataKinds+                      , KindSignatures+                      , OverloadedStrings+                      , OverloadedRecordDot+                      , ScopedTypeVariables+                      , TypeApplications++-- How each graph operation scales, per shape and size: see+-- resources/graph-profiles.md. A benchmark stanza so that neither+-- `cabal build all` nor `cabal test` builds or runs it; it shares the test+-- suite's graph fixture by source directory.+benchmark graph-profiles+    type:             exitcode-stdio-1.0+    main-is:          GraphProfiles.hs+    hs-source-dirs:   bench test+    other-modules:    Test.GraphFixture+                    , Test.DagReference+                    , Test.PathListReference+    build-depends:    base >=4.16.3.0 && <4.22+                    , aeson+                    , bytestring+                    , comonad+                    , containers+                    , free+                    , mtl+                    , optparse-applicative+                    , process+                    , stm+                    , unix+                    , salmon-core ^>=0.1.0.0+                    , salmon-ops ^>=0.2.0.0+                    , text+                    , time+    -- one capability, as the binaries in salmon-apps are built; -T for the+    -- allocation counter; -rtsopts so a run can be given a heap bound.+    ghc-options:      -threaded -rtsopts "-with-rtsopts=-T"     default-language: Haskell2010     default-extensions: DataKinds                       , KindSignatures

@@ -57,7 +57,10 @@     (RegisteredMachineSetup -> directive) ->     Op setupRegistration r mkRemote simulate selfpath selfRemote dns cfg toSpec =-    op "registration" (deps [trackedGraph remoteRegistration, uploadPem, uploadToken]) id+    -- The uploads are injected onto the remote call rather than listed beside+    -- it: the call reads both files, and nodes listed side by side are+    -- unordered.+    op "registration" (deps [trackedGraph remoteRegistration `inject` uploadPem `inject` uploadToken]) id   where     rsyncRemote :: Rsync.Remote     rsyncRemote = (\(Self.Remote a b) -> Rsync.Remote a b) selfRemote

@@ -25,6 +25,7 @@     defaultAlertThresholds,     CloudRunAlertsConfig (..),     standardAlerts,+    standardAlertsAfter,     standardPolicies,     Report (..), ) where@@ -87,8 +88,19 @@  -- | The channel and the policies, under one node. standardAlerts :: Reporter Report -> Track' (Binary "gcloud") -> CloudRunAlertsConfig -> Op-standardAlerts r gcloudTrack cfg =-    op "gcp-cloudrun-alerts" (deps (map (Monitoring.alertPolicy rMon gcloudTrack) (standardPolicies cfg))) $ \actions ->+standardAlerts = standardAlertsAfter []++{- | 'standardAlerts', with nodes every policy and the channel wait for+(@monitoring.googleapis.com@ enabled, typically).++The node returned (@gcp-cloudrun-alerts@) has no effect of its own: a node+@inject@ed onto it is a sibling of the policies and the channel, not+something they wait for. These go under each of them instead. With @[]@ the+graph is 'standardAlerts''s, unchanged.+-}+standardAlertsAfter :: [Op] -> Reporter Report -> Track' (Binary "gcloud") -> CloudRunAlertsConfig -> Op+standardAlertsAfter prerequisites r gcloudTrack cfg =+    op "gcp-cloudrun-alerts" (deps (map (Monitoring.alertPolicyAfter prerequisites rMon gcloudTrack) (standardPolicies cfg))) $ \actions ->         actions             { help = Text.unwords ["the standard alerts for Cloud Run service", cfg.cra_service, "to", cfg.cra_email]             , ref = mkRef "gcp-cloudrun-alerts" (cfg.cra_project.projectId, cfg.cra_region.regionName, cfg.cra_service)

@@ -22,6 +22,7 @@ module SreBox.Gcp.CloudRunDeploy (     CloudRunDeployConfig (..),     buildPushDeploy,+    buildPushDeployAfter,     Report (..), ) where @@ -88,7 +89,30 @@     Track' (Binary "podman") ->     CloudRunDeployConfig ->     Op-buildPushDeploy r gcloudTrack podmanTrack cfg =+buildPushDeploy = buildPushDeployAfter [] []++{- | 'buildPushDeploy', with nodes the build waits for (a file the+Containerfile copies, say), and nodes the deploy waits for (the Cloud Run+API, the service account, the secrets the revision mounts and their grants).++The node returned (@gcp-cloudrun-deploy@) has no effect of its own: a node+@inject@ed onto it is a sibling of the build, the push and the deploy, not+something they wait for. These go under the build and under the deploy+instead. Neither list may hold a node of this recipe's own (the repository,+say): that would be a node waiting for itself. With @[] []@ the graph is+'buildPushDeploy''s, unchanged.+-}+buildPushDeployAfter ::+    -- | under the build (so under the push and the deploy too)+    [Op] ->+    -- | under the deploy+    [Op] ->+    Reporter Report ->+    Track' (Binary "gcloud") ->+    Track' (Binary "podman") ->+    CloudRunDeployConfig ->+    Op+buildPushDeployAfter beforeBuild beforeDeploy r gcloudTrack podmanTrack cfg =     op "gcp-cloudrun-deploy" (deps [deployed]) $ \actions ->         actions             { help = Text.unwords ["builds, pushes and deploys", cfg.crd_image, "as CloudRun service", cfg.crd_service]@@ -116,16 +140,21 @@             `inject` repo      built :: Op-    built = Podman.buildImage rPodman podmanTrack cfg.crd_containerfile cfg.crd_image+    built = foldl inject (Podman.buildImage rPodman podmanTrack cfg.crd_containerfile cfg.crd_image) beforeBuild      pushed :: Op     pushed =-        Podman.push rPodman podmanTrack (Just cfg.crd_authFile) cfg.crd_image+        -- logs in again itself: the build sits between the login node and+        -- this one, and an access token lasts an hour+        Podman.pushLoggingIn rPodman podmanTrack cfg.crd_authFile registry (Podman.Username "oauth2accesstoken") Core.printAccessToken cfg.crd_image             `inject` built             `inject` loggedIn      deployed :: Op-    deployed =+    deployed = foldl inject service beforeDeploy++    service :: Op+    service =         CloudRun.cloudRunService             rCloudRun             gcloudTrack

@@ -0,0 +1,148 @@+{-# LANGUAGE OverloadedStrings #-}++{- | A Plakar backup job whose Kloset lives in a Google Cloud Storage bucket,+built from what the tree already has: 'Storage.bucket', 'Iam.serviceAccount',+'Iam.iamBinding' (object admin on that one bucket) and+'Iam.serviceAccountKey', feeding the GCS store of+"Salmon.Builtin.Nodes.Plakar" and the job on top of it.++= What it sets and what it leaves to the bucket's owner++It creates the bucket with uniform bucket-level access, and nothing else:+__no retention policy, no object versioning, no lifecycle rules__. Plakar+advertises immutable snapshots, but how long a bucket refuses deletes is a+bucket property (as for "SreBox.PostgresBackup"), and a job whose @prune@ has+to delete objects would be broken by a retention lock shorter than its own+'KeepPolicy'. Set those on the bucket yourself.++= Credentials++A service-account key file, written by 'Iam.serviceAccountKey' (so by whoever+runs salmon, with gcloud's own file mode) and then only ever named by path. The+job's user must be able to read it, and the Plakar passphrase keyfile+('gbKeyfile') is provisioned by somebody else, as for the local store. Workload+identity is not supported.++= The integration version has no default++'gbGcsVersion' is a 'Pinned' release or an explicit 'Latest'.+-}+module SreBox.Gcp.PlakarGcsBackup (+    GcsBackup (..),+    gcsBackup,+    gcsServiceAccountEmail,+    gcsBucketRole,+    Report (..),+) where++import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time (NominalDiffTime)++import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary)+import Salmon.Builtin.Nodes.CronTask (Schedule)+import qualified Salmon.Builtin.Nodes.Gcp.Core as Core+import qualified Salmon.Builtin.Nodes.Gcp.Iam as Iam+import qualified Salmon.Builtin.Nodes.Gcp.Storage as Storage+import Salmon.Builtin.Nodes.Plakar+import Salmon.Op.Ref (mkRef)+import Salmon.Op.Track+import Salmon.Reporter++data Report+    = StorageReport !Storage.Report+    | IamReport !Iam.Report+    deriving (Show)++data GcsBackup = GcsBackup+    { gbProject :: Core.Project+    , gbBucket :: Text+    , gbLocation :: Core.Region+    , gbServiceAccountId :: Text+    -- ^ the account id (before the @\@@), created if absent+    , gbCredentialsFile :: FilePath+    -- ^ where its key is written, and the store reads it+    , gbStoreName :: Text+    , gbStorePrefix :: Text+    , gbGcsVersion :: IntegrationVersion+    , gbCredentialsOption :: Text+    -- ^ the GCS integration's option for the credentials file; see 'gcsCredentialsOption'+    , gbKeyfile :: FilePath+    -- ^ the Kloset passphrase, provisioned by somebody else+    , gbJobName :: Text+    , gbSource :: FilePath+    , gbSchedule :: Schedule+    , gbUser :: Text+    -- ^ runs the job, and owns the integration and the store configuration+    , gbKeep :: KeepPolicy+    , gbMaxAge :: NominalDiffTime+    , gbScriptPath :: FilePath+    }++-- | @ID\@PROJECT.iam.gserviceaccount.com@.+gcsServiceAccountEmail :: GcsBackup -> Text+gcsServiceAccountEmail b = b.gbServiceAccountId <> "@" <> b.gbProject.projectId <> ".iam.gserviceaccount.com"++-- | The role the account gets, on the bucket only.+gcsBucketRole :: Text+gcsBucketRole = "roles/storage.objectAdmin"++gcsBackup :: Reporter Report -> Track' (Binary "plakar") -> GcsBackup -> Op+gcsBackup r plakar b =+    plakarJobOn remote job+  where+    gcloud = Core.gcloud+    sr = contramap StorageReport r+    ir = contramap IamReport r+    user = Just b.gbUser++    bucketOp =+        Storage.bucket+            sr+            gcloud+            (Storage.Bucket b.gbBucket b.gbProject b.gbLocation True)+    accountOp = Iam.serviceAccount ir gcloud b.gbProject b.gbServiceAccountId+    bindingOp =+        Iam.iamBinding+            ir+            gcloud+            (Iam.IamBinding (Iam.ServiceAccount (gcsServiceAccountEmail b)) gcsBucketRole ("buckets/" <> b.gbBucket))+    keyOp = Iam.serviceAccountKey ir gcloud (Iam.ServiceAccountKey b.gbProject b.gbServiceAccountId b.gbCredentialsFile)++    -- everything the store's configuration needs to exist first+    prerequisites =+        op "plakar-gcs-prerequisites" (deps [bucketOp, accountOp, bindingOp, keyOp, integrationOp]) $ \actions ->+            actions+                { help = Text.unwords ["gs://" <> b.gbBucket, "with an account and key for plakar"]+                , notes = ["bucket retention, versioning and lifecycle are left to the bucket's owner"]+                , ref = mkRef "plakar-gcs-prerequisites" (b.gbProject.projectId, b.gbBucket, b.gbStoreName)+                }++    integrationOp = plakarIntegration plakar (Integration "gcs" b.gbGcsVersion user)++    storeOp =+        gcsStore+            prerequisites+            GcsStore+                { gcsStoreName = b.gbStoreName+                , gcsBucket = b.gbBucket+                , gcsPrefix = b.gbStorePrefix+                , gcsCredentialsFile = b.gbCredentialsFile+                , gcsCredentialsOption = b.gbCredentialsOption+                , gcsStoreUser = user+                }++    remote = remoteKloset storeOp user b.gbStoreName b.gbKeyfile++    job =+        PlakarJob+            { jobName = b.gbJobName+            , jobStore = KlosetStore ("@" <> Text.unpack b.gbStoreName) b.gbKeyfile+            , jobSource = b.gbSource+            , jobSchedule = b.gbSchedule+            , jobUser = b.gbUser+            , jobKeep = b.gbKeep+            , jobMaxAge = b.gbMaxAge+            , jobScriptPath = b.gbScriptPath+            }

@@ -161,11 +161,19 @@      (localCert, localKey, localCa) = cfg.pcr_clientMaterial +    -- The entrypoint goes under the build and the secrets and grants under+    -- the deploy, through 'CloudRunDeploy.buildPushDeployAfter':+    -- @gcp-cloudrun-deploy@ has no effect of its own, and injected onto it+    -- alone they were siblings of the build and the deploy, which could then+    -- run first. The injections onto it are kept, they leave that node's+    -- edges as they were.     deploy :: Op     deploy =         foldl             inject-            ( CloudRunDeploy.buildPushDeploy+            ( CloudRunDeploy.buildPushDeployAfter+                [entrypoint]+                secretsAndGrants                 rDeploy                 gcloudTrack                 podmanTrack

@@ -24,16 +24,26 @@ module SreBox.Gcp.VmProvision (     VmProvisionConfig (..),     provisionedVm,+    provisionedVmReadingHost,+    handOff,     Report (..),++    -- * Making the instance trust the CA+    caTrustStartupScript,+    caTrustStartupScriptFile,+    withStartupScriptFile, ) where  import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as Text  import Salmon.Builtin.Extension import qualified Salmon.Builtin.CommandLine as CLI import Salmon.Builtin.Nodes.Binary (Binary)+import qualified Salmon.Builtin.Nodes.Deferred as Deferred+import qualified Salmon.Builtin.Nodes.Filesystem as FS import qualified Salmon.Builtin.Nodes.Gcp.Compute as Compute import qualified Salmon.Builtin.Nodes.Gcp.SshAccess as SshAccess import Salmon.Builtin.Nodes.Keys (SSHKeyPair)@@ -53,6 +63,8 @@     | RunSshAccess !SshAccess.Report     | RunKeys !Keys.Report     | RunSelf !Self.Report+    | -- | 'provisionedVmReadingHost': the hand-off's own nested walk.+      RunHandOff !Deferred.Report     deriving (Show)  -------------------------------------------------------------------------------@@ -63,19 +75,22 @@ The SSH endpoint (host/port/user) is supplied by the caller rather than derived from the 'Compute.Instance', mirroring @specs/gcloud-support.md@ section 6's own signature: an ephemeral instance's-address generally is not known until after 'up' runs, so a recipe that needs-one has to either reserve a static address up front or thread it through-some other channel -- deriving it here would just move that problem, not-solve it.+address generally is not known until after 'up' runs. A caller that knows the+host (a declared internal address, a second pass handed the address by its+driver) writes it in 'vmp_sshHost' and uses 'provisionedVm'; one that does not+(a reserved external address, which GCP picks) gives a read of it to+'provisionedVmReadingHost' instead. -} data VmProvisionConfig directive = VmProvisionConfig     { vmp_name :: Text     -- ^ a unique name for this provisioning declaration, used as the 'Ref' key.     , vmp_instance :: Compute.Instance     , vmp_ca :: SSHKeyPair-    -- ^ the CA whose public key is pushed into project metadata; instances-    -- must be configured (e.g. via a startup script writing @sshd_config@'s-    -- @TrustedUserCAKeys@) to trust it, which is outside this module's scope.+    -- ^ the CA whose public key is pushed into project metadata. Nothing on+    -- an instance reads that key by itself: the instance has to boot with a+    -- startup script that does, which is 'caTrustStartupScript' (written to+    -- a file by 'caTrustStartupScriptFile', a node for 'vmp_prerequisites',+    -- and named in 'vmp_instance' by 'withStartupScriptFile').     , vmp_clientIdentity :: SSHKeyPair     -- ^ the key salmon connects with, signed by 'vmp_ca'.     , vmp_sshUser :: Text@@ -102,6 +117,66 @@     , vmp_directive :: directive     } +{- | The startup script that makes an instance trust the CA 'provisionedVm'+publishes -- the piece 'SshAccess.installMetadataCaKey' deliberately does not+do: it puts the CA's public key in project metadata, and nothing on a GCE+instance reads that key by itself.++Given the login user (the principal the client certificate names, i.e.+'vmp_sshUser'), the script: waits for the @ssh-ca@ project attribute and+writes it to @\/etc\/ssh\/salmon_ca.pub@; points sshd's @TrustedUserCAKeys@ at+it; creates the user (without OS Login a principal has to be a local+account); gives it passwordless sudo ('Self.uploadAndCallSelfAsSudoWith' runs+the uploaded binary under sudo); makes sure @rsync@ is there for the upload;+and restarts sshd. Idempotent, because a startup script runs on every boot.++The wait loop is load-bearing. The key is published just before the instance+is created, and "just before" is not "already visible from inside the guest":+a bare @curl -f@ that meets a 404 aborts the whole script under @set -e@,+leaving a machine with no CA, no login user and an sshd that was never+restarted -- one nobody can log into, fixable only by a reset. That is the+reason this lives here rather than in each consumer's copy.++The user is spliced into shell unquoted, so it must be a plain account name;+it comes from the declaration, never from input.+-}+caTrustStartupScript :: Text -> Text+caTrustStartupScript user =+    Text.unlines+        [ "#!/bin/bash"+        , "set -eux"+        , "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"+        ]++{- | 'caTrustStartupScript' written to a local file, as a node: @gcloud@ takes+a startup script by path (@--metadata-from-file@), so the file has to exist+before the instance is created. Belongs in 'vmp_prerequisites'.+-}+caTrustStartupScriptFile :: FilePath -> Text -> Op+caTrustStartupScriptFile path user =+    FS.filecontents (FS.FileContents path (caTrustStartupScript user))++{- | Points an instance's @startup-script@ metadata at a local file, replacing+whichever one it named and leaving every other metadata file alone.+-}+withStartupScriptFile :: FilePath -> Compute.Instance -> Compute.Instance+withStartupScriptFile path inst =+    inst{Compute.instanceMetadataFiles = Map.insert "startup-script" path inst.instanceMetadataFiles}+ {- | How this recipe's ssh, rsync and probe all authenticate: the signed client key, and a known-hosts file kept beside it rather than in the calling user's @~\/.ssh@.@@ -135,16 +210,95 @@     VmProvisionConfig directive ->     Op provisionedVm r gcloudTrack keygenTrack cfg =-    op "gcp-vm-provision" (deps [foldl inject (trackedGraph call) (sshReady : beforeCall)]) $ \actions ->+    op "gcp-vm-provision" (deps [handOff r cfg [vm, signedClient]]) $ \actions ->         actions-            { help = Text.unwords ["provisions GCE VM", cfg.vmp_instance.instanceName, "over SSH and runs the self binary on it"]+            { help = provisionHelp cfg             , ref = mkRef "gcp-vm-provision" cfg.vmp_name             }   where+    (vm, signedClient) = machine r gcloudTrack keygenTrack cfg++{- | 'provisionedVm' for a host that is not known when the graph is declared+-- an instance behind a reserved external address, which GCP picks -- so that+one pass creates the machine /and/ provisions it.++The host is a read (@'Compute.readAddress' addr@, typically) done once the+instance is up, and everything that has to name the machine -- the ssh probe,+the 'vmp_beforeCall' uploads, the remote call -- is a+"Salmon.Builtin.Nodes.Deferred" sub-graph built from what the read found.+The instance, the CA and the signed client key name nothing and stay+ordinary nodes, declared and ordered as in 'provisionedVm'.++Of the config, 'vmp_sshHost' is overwritten with the host read (give it+anything), and the completion function is applied after that: it is where a+'vmp_beforeCall' that needs the host is set, since one written in the config+would have to close over a host nobody has yet.++Three things follow from the hand-off being a nested walk, beyond what+'Salmon.Builtin.Nodes.Deferred.deferred' says of any:++* The node that makes the read answer has to be up before the instance is:+  the address belongs in 'vmp_prerequisites', where an instance claiming it+  by name needs it anyway.+* The 'vmp_beforeCall' nodes are walked /down/ by this node's @down@ along+  with the probe and the call, dependencies included. Whatever they stand on+  that is also declared elsewhere should be injected into this recipe's node+  rather than into them.+* A read that finds nothing fails this node's @up@ (nothing is provisioned+  at a guess) and makes its @down@ a no-op.+-}+provisionedVmReadingHost ::+    forall directive.+    (FromJSON directive, ToJSON directive) =>+    Reporter Report ->+    Track' (Binary "gcloud") ->+    Track' (Binary "ssh-keygen") ->+    -- | the ssh host, once the instance is up; e.g. @Compute.readAddress addr@+    IO (Maybe Text) ->+    -- | completes the config with the host just read+    (Text -> VmProvisionConfig directive -> VmProvisionConfig directive) ->+    VmProvisionConfig directive ->+    Op+provisionedVmReadingHost r gcloudTrack keygenTrack readHost complete cfg =+    op "gcp-vm-provision" (deps [late `inject` vm `inject` signedClient]) $ \actions ->+        actions+            { help = provisionHelp cfg+            , notes = ["ssh host read once the instance is up"]+            , ref = mkRef "gcp-vm-provision" cfg.vmp_name+            }+  where+    (vm, signedClient) = machine r gcloudTrack keygenTrack cfg++    late :: Op+    late =+        Deferred.deferred+            (contramap RunHandOff r)+            Deferred.Deferred+                { Deferred.deferredName = "gcp-vm-provision:" <> cfg.vmp_name+                , Deferred.deferredHelp =+                    Text.unwords ["reads the address of", cfg.vmp_instance.instanceName, "then waits for ssh and runs the self binary on it"]+                , Deferred.deferredRead = readHost+                , Deferred.deferredGraph = \host -> handOff r (complete host cfg{vmp_sshHost = host}) []+                }++provisionHelp :: VmProvisionConfig directive -> Text+provisionHelp cfg =+    Text.unwords ["provisions GCE VM", cfg.vmp_instance.instanceName, "over SSH and runs the self binary on it"]++{- | The half that names no host: the instance (after the CA is published and+every 'vmp_prerequisites' node), and the client key signed by that CA.+-}+machine ::+    Reporter Report ->+    Track' (Binary "gcloud") ->+    Track' (Binary "ssh-keygen") ->+    VmProvisionConfig directive ->+    (Op, Op)+machine r gcloudTrack keygenTrack cfg = (vm, signedClient)+  where     rCompute = contramap RunCompute r     rSshAccess = contramap RunSshAccess r     rKeys = contramap RunKeys r-    rSelf = contramap RunSelf r      -- The CA's public key has to be in project metadata *before* the     -- instance boots: the instance's startup script reads it from there to@@ -178,29 +332,63 @@             [Keys.Principal cfg.vmp_sshUser]             cfg.vmp_clientIdentity +{- | The half that names the host ('vmp_sshHost'): the ssh probe, standing on+the nodes given, then the upload of the self binary and every+'vmp_beforeCall' node (each waiting for the probe), then the remote call,+which waits for all of them.++The node returned is the call itself, so these are edges of the call and not+of something beside it: a probe that never answers blocks the upload and the+call, and under @run serve@ the call cannot start while an upload is still in+flight. Exported for the test that says so (@Test.DeferredSpec@).+-}+handOff ::+    forall directive.+    (FromJSON directive, ToJSON directive) =>+    Reporter Report ->+    VmProvisionConfig directive ->+    [Op] ->+    Op+handOff r cfg sshNeeds = foldl inject (trackedGraph call) (uploaded : sshReady : beforeCall)+  where+    rSshAccess = contramap RunSshAccess r+    rSelf = contramap RunSelf r+     sshReady :: Op     sshReady =-        SshAccess.sshAvailable-            rSshAccess-            (SshAccess.SshEndpoint (Just cfg.vmp_sshUser) cfg.vmp_sshHost cfg.vmp_sshPort (clientOpts cfg))-            `inject` vm-            `inject` signedClient+        foldl+            inject+            ( SshAccess.sshAvailable+                rSshAccess+                (SshAccess.SshEndpoint (Just cfg.vmp_sshUser) cfg.vmp_sshHost cfg.vmp_sshPort (clientOpts cfg))+            )+            sshNeeds      beforeCall :: [Op]     beforeCall = [step `inject` sshReady | step <- cfg.vmp_beforeCall (clientOpts cfg)] -    call :: Tracked' (Self.RemoteCall directive)-    call =-        -- The key this recipe just had signed lives at a path of its own-        -- choosing, which ssh has no reason to offer otherwise.-        Self.uploadAndCallSelfAsSudoWith+    -- The key this recipe just had signed lives at a path of its own+    -- choosing, which ssh has no reason to offer otherwise: hence the+    -- client options on both the upload and the call.+    upload :: Tracked' Self.RemoteSelf+    upload =+        Self.uploadSelfWith             (clientOpts cfg)             rSelf-            rSelf             cfg.vmp_remoteDir             (Self.Remote cfg.vmp_sshUser cfg.vmp_sshHost)             cfg.vmp_selfPath++    uploaded :: Op+    uploaded = trackedGraph upload `inject` sshReady++    call :: Tracked' (Self.RemoteCall directive)+    call =+        Self.callSelfAsSudoWith+            (clientOpts cfg)+            rSelf             Ssh.preExistingRemoteMachine+            upload.obj             cfg.vmp_directiveTrack             CLI.Up             cfg.vmp_directive

@@ -22,7 +22,7 @@   where     sudoerfile :: Op     sudoerfile =-        FS.filecontents+        FS.filecontentsInSharedDir             (FS.FileContents "/etc/sudoers.d/salmon" sudoercontent)      sudoercontent :: Text

@@ -0,0 +1,577 @@+{-# LANGUAGE OverloadedStrings #-}++{- | A demonstration of the embedding builtins end to end, on one machine:+__walk a directory, embed each file, keep the vectors in Postgres, and answer+"what is closest to this?"__. One @run up@ yields a table one can query by+meaning. It is a demo of the builtins, not a product.++The graph, in dependency order:++1. pgvector in the database ("Salmon.Builtin.Nodes.PgVector"), which brings+   the database (the caller's 'Track'') and the package (after the caller's+   choice of source).+2. 'schema': the table and its @hnsw@ index. The width of the column is the+   embedder's 'embDimension', never typed a second time, and a table already+   there with another width is refused rather than altered.+3. The embedder's own node ('embNode'): a llama-server for text+   ('llamaEmbedder'), clip.cpp for text and images ('clipEmbedder'), or the+   deterministic stand-in ('hashEmbedder') that needs no model.+4. 'indexDirectory': for each file of the directory whose content (or+   embedder) is not the one its row records, embed it and upsert the row.+   Its @check@ is "every file has a current row", so a second @run up@+   embeds nothing and @run serve@ notices a new or changed file.++'search' is the read side: embed the query with the same embedder and order+the rows by cosine distance. It never writes.++= What it decides++* __One embedder per table.__ Vectors from two models are not comparable,+  so the table records which embedder made each row ('embName') and a row+  from another one counts as stale. Text and images share a table only when+  one embedder takes both (clip.cpp).+* __The walk__ ('WalkPolicy'): recursive, sorted, no hidden files or+  directories, symbolic links not followed, kind by extension, whole files+  under a size cap, no chunking. Every skipped file is reported with why.+* __Rows of deleted files are left__, and counted in the report: dropping+  them is a deletion the operator did not name. Neither node's @down@ drops+  anything either.++= What is public++Paths and the embedder's name are in the reports. The files' contents are+not, but a text file given to 'clipEmbedder' is on @extract@'s command line+(see "Salmon.Builtin.Nodes.ClipCpp"); 'llamaEmbedder' sends it to @curl@ on+stdin. Do not index a directory of secrets.+-}+module SreBox.PgVectorDemo (+    Report (..),++    -- * Embedders+    Kind (..),+    kindName,+    Input (..),+    Embedder (..),+    llamaEmbedder,+    clipEmbedder,+    hashEmbedder,+    hashVector,++    -- * The walk+    WalkPolicy (..),+    defaultWalkPolicy,+    Skip (..),+    classify,+    walk,++    -- * The nodes+    Demo (..),+    defaultDemo,+    pgVectorDemo,+    schema,+    indexDirectory,++    -- * Search+    Hit (..),+    search,++    -- * Pieces, exposed for tests+    Candidate (..),+    vectorLiteral,+    schemaSql,+    inspectSchemaSql,+    interpretSchemaRow,+    indexedSql,+    parseIndexed,+    pendingFiles,+    staleCount,+    upsertSql,+    searchSql,+    parseHits,+    contentHash,+) where++import Control.Exception (throwIO)+import Control.Monad (forM, forM_, unless)+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as C8+import Data.Char (toLower)+import Data.List (sort)+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Encoding.Error as TextError+import GHC.IO.Exception (ExitCode (..))+import System.Directory (getFileSize, listDirectory, pathIsSymbolicLink, doesDirectoryExist, doesFileExist)+import System.FilePath (splitDirectories, takeExtension, (</>))+import System.Process.ByteString (readCreateProcessWithExitCode)+import System.Process.ListLike (proc)+import Text.Printf (printf)++import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Binary (Binary)+import qualified Salmon.Builtin.Nodes.ClipCpp as ClipCpp+import qualified Salmon.Builtin.Nodes.Debian.Package as Package+import Salmon.Builtin.Nodes.LlamaServer (LlamaServer (..), ModelFile (..), llamaEmbed)+import Salmon.Builtin.Nodes.PgVector (PgVector (..), pgvector)+import Salmon.Builtin.Nodes.Postgres (DatabaseName, Port, dollarQuote, quoteIdent, quoteLiteral)+import qualified Salmon.Builtin.Nodes.Postgres as Postgres+import Salmon.Op.OpGraph (inject)+import Salmon.Op.Ref+import Salmon.Op.Track+import Salmon.Reporter++-------------------------------------------------------------------------------++data Report+    = FileSkipped !FilePath !Skip+    | Indexed !FilePath !Kind+    | EmbedFailed !FilePath !Text+    | StaleRows !Int+    deriving (Show)++-------------------------------------------------------------------------------+-- Embedders++data Kind = TextKind | ImageKind+    deriving (Eq, Ord, Show)++-- | What the @kind@ column holds.+kindName :: Kind -> Text+kindName TextKind = "text"+kindName ImageKind = "image"++data Input+    = InputText Text+    | InputImage FilePath+    deriving (Eq, Show)++{- | What turns a file into a vector, and what must be up before it can.++'embName' is stored with every row, so a row made by another embedder is+re-embedded. It should change whenever the vectors would (another model,+another build), and must say nothing secret: it is in the table and in the+reports.+-}+data Embedder = Embedder+    { embName :: Text+    , embDimension :: Int+    , embKinds :: [Kind]+    , embNode :: Op+    , embEmbed :: Input -> IO (Either Text [Double])+    }++{- | Text only, through a running server. The node is the caller's (a+'Salmon.Builtin.Nodes.LlamaServer.llamaServerDaemon' for @run serve@, or a+'Salmon.Builtin.Nodes.LlamaServer.llamaServerSystemd'), since which run mode+fits is not this recipe's choice.+-}+llamaEmbedder :: Op -> LlamaServer -> Embedder+llamaEmbedder node s =+    Embedder+        { embName = "llama-server:" <> s.lsName <> ":" <> Text.take 16 s.lsModel.modelSha256+        , embDimension = s.lsDimension+        , embKinds = [TextKind]+        , embNode = node+        , embEmbed = \input -> case input of+            InputText t -> llamaEmbed s t+            InputImage _ -> pure (Left "llama-server embeds no images")+        }++-- | Text and images in one space. A text file is on @extract@'s command line.+clipEmbedder :: Reporter ClipCpp.Report -> ClipCpp.ClipTools -> ClipCpp.ClipCpp -> Embedder+clipEmbedder r tools c =+    Embedder+        { embName = "clip.cpp:" <> Text.take 16 c.ccSource.clipCommit <> ":" <> Text.take 16 c.ccModel.modelSha256+        , embDimension = c.ccDimension+        , embKinds = [TextKind, ImageKind]+        , embNode = ClipCpp.clipCpp r tools c+        , embEmbed = \input ->+            fmap (fmap realToFrac) <$> ClipCpp.embed c (case input of InputText t -> ClipCpp.EmbedText t; InputImage p -> ClipCpp.EmbedImage p)+        }++{- | A stand-in that needs no model: the vector is the sha256 of the bytes,+stretched to the width. It knows nothing of meaning (two files are close+only if they are the same file), but it makes the whole path runnable with+no model and no network, and the same text queried finds its own file at+distance 0. This is what the tests use.+-}+hashEmbedder :: Int -> Embedder+hashEmbedder dim =+    Embedder+        { embName = "sha256-stand-in"+        , embDimension = dim+        , embKinds = [TextKind, ImageKind]+        , embNode = op "pgvector-demo-hash-embedder" nodeps $ \actions ->+            actions+                { help = "a " <> tshow dim <> "-dimensional stand-in embedder (sha256, no model)"+                , ref = mkRef "pgvector-demo-hash-embedder" dim+                , up = pure ()+                }+        , embEmbed = \input -> case input of+            InputText t -> pure (Right (hashVector dim (Text.encodeUtf8 t)))+            InputImage p -> Right . hashVector dim <$> ByteString.readFile p+        }++-- | @dim@ values in @[-1, 1]@ from the bytes; never all zero, so a cosine distance is defined.+hashVector :: Int -> ByteString.ByteString -> [Double]+hashVector dim bytes =+    take dim [scale b | k <- [0 :: Int ..], b <- ByteString.unpack (SHA256.hash (bytes <> C8.pack (show k)))]+  where+    scale b = (fromIntegral b - 127.5) / 127.5++-------------------------------------------------------------------------------+-- The walk++data WalkPolicy = WalkPolicy+    { textExtensions :: [String]+    , imageExtensions :: [String]+    , maxTextBytes :: Integer+    , maxImageBytes :: Integer+    }+    deriving (Eq, Show)++{- | @.txt@, @.md@, @.rst@, @.org@ up to 64 KiB (whole files, no chunking:+a model truncates a long input at its own context anyway); @.jpg@, @.jpeg@,+@.png@, @.gif@ up to 10 MiB.+-}+defaultWalkPolicy :: WalkPolicy+defaultWalkPolicy = WalkPolicy [".txt", ".md", ".rst", ".org"] [".jpg", ".jpeg", ".png", ".gif"] (64 * 1024) (10 * 1024 * 1024)++data Skip+    = Hidden+    | SymbolicLink+    | UnknownExtension+    | TooLarge !Integer+    | Empty+    | NotEmbedded !Kind+    -- ^ the embedder takes no file of this kind+    deriving (Eq, Show)++{- | The verdict on one file, from its path relative to the directory and its+size: a kind, or why it is skipped.+-}+classify :: WalkPolicy -> [Kind] -> FilePath -> Integer -> Either Skip Kind+classify policy kinds rel size+    | any hidden (splitDirectories rel) = Left Hidden+    | otherwise = do+        (kind, cap) <- case map toLower (takeExtension rel) of+            ext+                | ext `elem` policy.textExtensions -> Right (TextKind, policy.maxTextBytes)+                | ext `elem` policy.imageExtensions -> Right (ImageKind, policy.maxImageBytes)+                | otherwise -> Left UnknownExtension+        unless (kind `elem` kinds) (Left (NotEmbedded kind))+        unless (size > 0) (Left Empty)+        unless (size <= cap) (Left (TooLarge size))+        pure kind+  where+    hidden ('.' : _) = True+    hidden _ = False++{- | Every file under the directory, relative to it and sorted, either with+its kind or with why it is skipped. Symbolic links are skipped, not+followed; a hidden directory is not entered.+-}+walk :: WalkPolicy -> [Kind] -> FilePath -> IO ([(FilePath, Kind)], [(FilePath, Skip)])+walk policy kinds root = do+    verdicts <- go ""+    pure ([(p, k) | (p, Right k) <- verdicts], [(p, s) | (p, Left s) <- verdicts])+  where+    go :: FilePath -> IO [(FilePath, Either Skip Kind)]+    go rel = do+        names <- sort <$> listDirectory (root </> rel)+        concat <$> forM names (\name -> visit (if null rel then name else rel </> name))+    visit rel = do+        let path = root </> rel+        link <- pathIsSymbolicLink path+        isDir <- doesDirectoryExist path+        isFile <- doesFileExist path+        case () of+            _+                | link -> pure [(rel, Left SymbolicLink)]+                | isDir -> case classify policy kinds rel 1 of+                    Left Hidden -> pure [(rel, Left Hidden)]+                    _ -> go rel+                | isFile -> do+                    size <- getFileSize path+                    pure [(rel, classify policy kinds rel size)]+                | otherwise -> pure []++-------------------------------------------------------------------------------+-- The nodes++data Demo = Demo+    { pvdDirectory :: FilePath+    , pvdMajor :: Int+    -- ^ the cluster's major version, for the pgvector package+    , pvdPort :: Port+    , pvdDatabase :: DatabaseName+    , pvdTable :: Text+    , pvdPolicy :: WalkPolicy+    }+    deriving (Eq, Show)++-- | Table @items@ and 'defaultWalkPolicy'.+defaultDemo :: FilePath -> Int -> Port -> DatabaseName -> Demo+defaultDemo dir major port db = Demo dir major port db "items" defaultWalkPolicy++{- | The whole demo: pgvector, the schema, the embedder, the index. @psql@,+the package source and the database are the caller's, as for+'Salmon.Builtin.Nodes.PgVector.pgvector'.+-}+pgVectorDemo ::+    Reporter Report ->+    Reporter Postgres.Report ->+    Reporter Package.Report ->+    Track' (Binary "psql") ->+    Track' () ->+    Track' DatabaseName ->+    Demo ->+    Embedder ->+    Op+pgVectorDemo r pgr pkgr psql source mkdb demo emb =+    indexDirectory r demo emb `inject` tables `inject` emb.embNode+  where+    tables = schema demo emb.embDimension `inject` pgvector pgr pkgr psql source mkdb (PgVector demo.pvdMajor demo.pvdPort [demo.pvdDatabase] False)++{- | The table and its index, for vectors of this width. @up@ refuses (and+changes nothing) when the table is there with another width: re-embedding+everything is the operator's decision, made by naming another table. @down@+leaves the table.++Above 2000 dimensions pgvector cannot build an @hnsw@ index on a @vector@,+so there is none and a search is a sequential scan.+-}+schema :: Demo -> Int -> Op+schema demo dim =+    op "pgvector-demo-schema" nodeps $ \actions ->+        actions+            { help = "table " <> demo.pvdTable <> " of vector(" <> tshow dim <> ") in " <> demo.pvdDatabase+            , notes =+                ["down leaves the table"]+                    <> ["no hnsw index above 2000 dimensions: searches scan" | dim > 2000]+            , ref = mkRef "pgvector-demo-schema" (demo.pvdPort, demo.pvdDatabase, demo.pvdTable)+            , check = either (const Unknown) (interpretSchemaRow demo.pvdTable dim) <$> psqlIn demo (inspectSchemaSql demo.pvdTable)+            , up = psqlIn demo (schemaSql demo.pvdTable dim) >>= either (throwIO . userError . Text.unpack) (const (pure ()))+            }++indexName :: Text -> Text+indexName table = table <> "_embedding_hnsw"++-- | Refuse another width, then create the table and (up to 2000 dimensions) the index.+schemaSql :: Text -> Int -> Text+schemaSql table dim =+    Text.unlines $+        [ "DO "+            <> dollarQuote+                ( "DECLARE found text; BEGIN SELECT format_type(atttypid, atttypmod) INTO found FROM pg_attribute WHERE attrelid = to_regclass("+                    <> quoteLiteral (quoteIdent table)+                    <> ") AND attname = 'embedding' AND NOT attisdropped; IF found IS NOT NULL AND found <> "+                    <> quoteLiteral column+                    <> " THEN RAISE EXCEPTION '%', "+                    <> quoteLiteral (table <> ".embedding is ")+                    <> " || found || "+                    <> quoteLiteral (", the embedder produces " <> column <> ": name another table")+                    <> "; END IF; END"+                )+            <> ";"+        , "CREATE TABLE IF NOT EXISTS "+            <> quoteIdent table+            <> " (path text PRIMARY KEY, kind text NOT NULL, content_hash text NOT NULL, embedder text NOT NULL, embedding "+            <> column+            <> " NOT NULL);"+        ]+            <> [ "CREATE INDEX IF NOT EXISTS " <> quoteIdent (indexName table) <> " ON " <> quoteIdent table <> " USING hnsw (embedding vector_cosine_ops);"+               | dim <= 2000+               ]+  where+    column = "vector(" <> tshow dim <> ")"++-- | Empty when there is no table; otherwise @vector(N)|t@ (or @|f@ without the index).+inspectSchemaSql :: Text -> Text+inspectSchemaSql table =+    "SELECT format_type(atttypid, atttypmod) || '|' || (to_regclass("+        <> quoteLiteral (quoteIdent (indexName table))+        <> ") IS NOT NULL)::text FROM pg_attribute WHERE attrelid = to_regclass("+        <> quoteLiteral (quoteIdent table)+        <> ") AND attname = 'embedding' AND NOT attisdropped;"++interpretSchemaRow :: Text -> Int -> Text -> CheckResult+interpretSchemaRow table dim out =+    case Text.splitOn "|" (Text.strip out) of+        [""] -> Failure ("no table " <> table)+        [ty, hasIndex]+            | ty /= column -> Failure (table <> ".embedding is " <> ty <> ", the embedder produces " <> column)+            | dim <= 2000 && hasIndex /= "true" -> Failure ("no hnsw index on " <> table)+            | otherwise -> Success+        _ -> Unknown+  where+    column = "vector(" <> tshow dim <> ")"++-------------------------------------------------------------------------------++-- | A file to index: its path relative to the directory, its kind and the sha256 of its bytes.+data Candidate = Candidate+    { candPath :: FilePath+    , candKind :: Kind+    , candHash :: Text+    }+    deriving (Eq, Show)++{- | Embed every file whose row is missing or stale, and upsert it. A file+that cannot be embedded is reported and the others are still indexed; @up@+then throws, naming how many failed. @down@ leaves the rows.+-}+indexDirectory :: Reporter Report -> Demo -> Embedder -> Op+indexDirectory r demo emb =+    op "pgvector-demo-index" nodeps $ \actions ->+        actions+            { help = "indexes " <> Text.pack demo.pvdDirectory <> " into " <> demo.pvdDatabase <> "." <> demo.pvdTable <> " with " <> emb.embName+            , notes = ["rows of deleted files are left and counted", "down leaves the rows"]+            , ref = mkRef "pgvector-demo-index" (demo.pvdPort, demo.pvdDatabase, demo.pvdTable, demo.pvdDirectory)+            , check = do+                (cands, _) <- candidates+                rows <- psqlIn demo (indexedSql demo.pvdTable)+                pure $ case rows of+                    Left _ -> Unknown+                    Right out -> case pendingFiles emb.embName cands (parseIndexed out) of+                        [] -> Success+                        ps -> Failure (tshow (length ps) <> " file(s) without a current row")+            , up = do+                (cands, skipped) <- candidates+                forM_ skipped $ \(p, s) -> runReporter r (FileSkipped p s)+                rows <- psqlIn demo (indexedSql demo.pvdTable) >>= either (throwIO . userError . Text.unpack) pure+                let indexed = parseIndexed rows+                    stale = staleCount cands indexed+                unless (stale == 0) (runReporter r (StaleRows stale))+                failures <- fmap concat . forM (pendingFiles emb.embName cands indexed) $ \c -> do+                    let path = demo.pvdDirectory </> c.candPath+                    input <- case c.candKind of+                        TextKind -> InputText . Text.decodeUtf8With TextError.lenientDecode <$> ByteString.readFile path+                        ImageKind -> pure (InputImage path)+                    vector <- emb.embEmbed input+                    case vector of+                        Left why -> runReporter r (EmbedFailed c.candPath why) >> pure [c.candPath]+                        Right v+                            | length v /= emb.embDimension -> do+                                runReporter r (EmbedFailed c.candPath ("got " <> tshow (length v) <> " dimensions"))+                                pure [c.candPath]+                            | otherwise -> do+                                psqlIn demo (upsertSql demo.pvdTable emb.embName c v) >>= either (throwIO . userError . Text.unpack) pure+                                runReporter r (Indexed c.candPath c.candKind)+                                pure []+                case failures of+                    [] -> pure ()+                    (first : _) -> throwIO (userError (show (length failures) <> " file(s) could not be embedded, first: " <> first))+            }+  where+    candidates = do+        (files, skipped) <- walk demo.pvdPolicy emb.embKinds demo.pvdDirectory+        cands <- forM files $ \(p, k) -> Candidate p k . contentHash <$> ByteString.readFile (demo.pvdDirectory </> p)+        pure (cands, skipped)++-- | Lower-case hex sha256.+contentHash :: ByteString.ByteString -> Text+contentHash = Text.pack . concatMap (printf "%02x") . ByteString.unpack . SHA256.hash++indexedSql :: Text -> Text+indexedSql table = "SELECT path, content_hash, embedder FROM " <> quoteIdent table <> ";"++-- | Path to (hash, embedder). The two last fields hold no @|@; a path may.+parseIndexed :: Text -> Map.Map FilePath (Text, Text)+parseIndexed = Map.fromList . mapMaybe row . Text.lines+  where+    row line = case reverse (Text.splitOn "|" line) of+        (e : h : rest@(_ : _)) -> Just (Text.unpack (Text.intercalate "|" (reverse rest)), (h, e))+        _ -> Nothing++-- | Files with no row, a row of other content, or a row from another embedder.+pendingFiles :: Text -> [Candidate] -> Map.Map FilePath (Text, Text) -> [Candidate]+pendingFiles name cands indexed =+    [c | c <- cands, Map.lookup c.candPath indexed /= Just (c.candHash, name)]++-- | Rows whose path is no longer a file to index.+staleCount :: [Candidate] -> Map.Map FilePath (Text, Text) -> Int+staleCount cands indexed = Map.size (Map.withoutKeys indexed (Set.fromList (candPath <$> cands)))++upsertSql :: Text -> Text -> Candidate -> [Double] -> Text+upsertSql table name c v =+    "INSERT INTO "+        <> quoteIdent table+        <> " (path, kind, content_hash, embedder, embedding) VALUES ("+        <> Text.intercalate ", " [quoteLiteral (Text.pack c.candPath), quoteLiteral (kindName c.candKind), quoteLiteral c.candHash, quoteLiteral name, quoteLiteral (vectorLiteral v)]+        <> ") ON CONFLICT (path) DO UPDATE SET kind = EXCLUDED.kind, content_hash = EXCLUDED.content_hash, embedder = EXCLUDED.embedder, embedding = EXCLUDED.embedding;"++-- | @[0.25,-1.0e-2]@, as pgvector reads one.+vectorLiteral :: [Double] -> Text+vectorLiteral v = "[" <> Text.intercalate "," (tshow <$> v) <> "]"++-------------------------------------------------------------------------------+-- Search++data Hit = Hit+    { hitPath :: FilePath+    , hitKind :: Text+    , hitDistance :: Double+    }+    deriving (Eq, Show)++{- | The @k@ rows nearest to the query, by cosine distance, among the rows the+same embedder made. Reads only.+-}+search :: Demo -> Embedder -> Input -> Int -> IO (Either Text [Hit])+search demo emb input k = do+    vector <- emb.embEmbed input+    case vector of+        Left why -> pure (Left why)+        Right v -> fmap parseHits <$> psqlIn demo (searchSql demo.pvdTable emb.embName v k)++searchSql :: Text -> Text -> [Double] -> Int -> Text+searchSql table name v k =+    "SELECT path, kind, embedding <=> "+        <> q+        <> " FROM "+        <> quoteIdent table+        <> " WHERE embedder = "+        <> quoteLiteral name+        <> " ORDER BY embedding <=> "+        <> q+        <> " LIMIT "+        <> tshow (max 1 k)+        <> ";"+  where+    q = quoteLiteral (vectorLiteral v) <> "::vector"++parseHits :: Text -> [Hit]+parseHits = mapMaybe row . Text.lines+  where+    row line = case reverse (Text.splitOn "|" line) of+        (d : kind : rest@(_ : _))+            | [(dist, "")] <- reads (Text.unpack d) -> Just (Hit (Text.unpack (Text.intercalate "|" (reverse rest))) kind dist)+        _ -> Nothing++-------------------------------------------------------------------------------++{- | SQL on @psql@'s stdin, as the @postgres@ OS user, unaligned and+@|@-separated, stopping at the first error. On stdin rather than @-c@ since+a statement holds a vector of hundreds of numbers.+-}+psqlIn :: Demo -> Text -> IO (Either Text Text)+psqlIn demo sql = do+    (code, out, err) <-+        readCreateProcessWithExitCode+            (proc "sudo" ["-u", "postgres", "psql", "-p", show demo.pvdPort, "-X", "-q", "-tA", "-F", "|", "-v", "ON_ERROR_STOP=1", "-d", Text.unpack demo.pvdDatabase])+            (Text.encodeUtf8 sql)+    pure $ case code of+        ExitSuccess -> Right (decode out)+        ExitFailure n -> Left ("psql exited " <> tshow n <> ": " <> Text.take 500 (Text.strip (decode err)))+  where+    decode = Text.decodeUtf8With TextError.lenientDecode++tshow :: (Show a) => a -> Text+tshow = Text.pack . show

@@ -57,25 +57,38 @@   where     (ownerUser, ownerPass) = setup.init_setup_owner --- | generate a db with a given sets of users, all having some rights+{- | generate a db with a given sets of users, all having some rights++The @pg-*@ nodes grouping users, groups, grants and memberships have no+effect of their own, and 'inject' onto one of them adds a predecessor to it,+not to the nodes it groups: those would be siblings of what was injected,+unordered (under @run serve@, concurrent). So each ordering is said on the+nodes doing the work: a role after the groups and the database, the+ownership and every grant after the database. (A membership already stands+on its group and its role.) The injections onto the grouping nodes are+kept: they order nothing more, and leave those nodes' edges as they were.+-} setupPG :: Reporter Report -> InitSetup (FS.File "passfile") -> Op setupPG r setup =     op "pg-setup" (deps [memberships, groupAcls, userAcls `inject` basics]) id   where     basics = op "pg-basics" (deps [users `inject` groups `inject` db, dbOwner `inject` db]) id +    afterDb :: Op -> Op+    afterDb o = o `inject` db+     cluster = Track $ Postgres.pgLocalCluster (contramap InitPostgres r) Debian.postgres Debian.pg_ctlcluster      port = Postgres.localServer.serverPort      db = Postgres.database (contramap InitPostgres r) cluster Debian.psql port setup.init_setup_database -    groups = op "pg-groups" (deps $ fmap group setup.init_setup_groups) id+    groups = op "pg-groups" (deps $ fmap (afterDb . group) setup.init_setup_groups) id      group (g, _) =         Postgres.group (contramap InitPostgres r) cluster Debian.psql port g -    users = op "pg-users" (deps $ fmap user setup.init_setup_users) id+    users = op "pg-users" (deps $ fmap (\u -> afterDb (user u) `inject` groups) setup.init_setup_users) id      -- roundabout ways to generate users and owner user     baseUser u pass =@@ -91,7 +104,7 @@     trackgroupsFromAclsByCreatingAllGroups = Track $ const groups     trackOwnerRoleForUser = Track $ const owner -    dbOwner = op "pg-db-ownership" (deps [ownership]) id+    dbOwner = op "pg-db-ownership" (deps [afterDb ownership]) id       where         ownership =             Postgres.databaseOnwership@@ -104,7 +117,7 @@                 trackOwnerRoleForUser                 (Postgres.UserRole $ fst setup.init_setup_owner) -    userAcls = op "pg-user-grants" (deps $ fmap acl setup.init_setup_users) id+    userAcls = op "pg-user-grants" (deps $ fmap (afterDb . acl) setup.init_setup_users) id       where         acl (u, _, rights, _) =             Postgres.grant@@ -114,7 +127,7 @@                 trackuserFromAclsByCreatingAllUsers                 (Postgres.AccessRight setup.init_setup_database (Postgres.UserRole u) rights) -    groupAcls = op "pg-group-grants" (deps $ fmap acl setup.init_setup_groups) id+    groupAcls = op "pg-group-grants" (deps $ fmap (afterDb . acl) setup.init_setup_groups) id       where         acl (g, rights) =             Postgres.grant

@@ -179,8 +179,29 @@     (Either PrepareRemoteMigrationSetup MigrationSetup -> directive) ->     RemoteMigrateConfig TrackedIO ->     Op-remoteMigrateOpaqueSetup uniquename r simulate selfRemote selfpath toSpec cfg =-    op "migrate-remotely" (deps [opaquemigration `inject` uploadsecrets]) $ \actions ->+remoteMigrateOpaqueSetup = remoteMigrateOpaqueSetupAfter []++{- | 'remoteMigrateOpaqueSetup', with nodes the migration itself waits for+(the database and roles it migrates, typically).++The node returned (@migrate-remotely@) has no effect of its own: a node+@inject@ed onto it is a sibling of the migration, not something the+migration waits for. These go under the node that migrates. With @[]@ the+graph is 'remoteMigrateOpaqueSetup''s, unchanged.+-}+remoteMigrateOpaqueSetupAfter ::+    (FromJSON directive, ToJSON directive) =>+    [Op] ->+    Text ->+    Reporter Report ->+    Track' directive ->+    Self.Remote ->+    Self.SelfPath ->+    (Either PrepareRemoteMigrationSetup MigrationSetup -> directive) ->+    RemoteMigrateConfig TrackedIO ->+    Op+remoteMigrateOpaqueSetupAfter prerequisites uniquename r simulate selfRemote selfpath toSpec cfg =+    op "migrate-remotely" (deps [Prelude.foldl inject opaquemigration prerequisites `inject` uploadsecrets]) $ \actions ->         actions             { help = Text.unwords ["remotely apply the (opaque) migration", uniquename]             , ref = mkRef "remote-migrate" uniquename

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}  {- | A primary and a streaming standby on two machines, with the primary's location declared rather than discovered.@@ -47,9 +48,27 @@     Member (..),     Pair (..),     Bouncer (..),+    RoutedDatabase (..),+    routedDatabases,+    bouncerProblems,     memberOn,+    memberSshHost,+    sshLogin,+    sshUser,+    remoteCommand,     slotNameFor, +    -- * How the two machines talk to each other+    ConnSecurity (..),+    Tls (..),+    ServerCheck (..),+    ServerFiles (..),+    ClientCerts (..),+    connSecurity,+    hbaLinesFor,+    hbaLinesRetired,+    securityProblems,+     -- * What the machines are     Lsn (..),     parseLsn,@@ -60,6 +79,7 @@     BouncerState (..),     bouncerProbeScript,     parseBouncerState,+    parseBouncerStates,      -- * What to do about it     Step (..),@@ -83,11 +103,15 @@     converge,     convergeUpTo,     stepBudget,++    -- * For recipes beside this one ("SreBox.PostgresPairPrereqs")+    sshToTarget, ) where  import Control.Concurrent (threadDelay) import Control.Exception (throwIO) import Data.Aeson (FromJSON, ToJSON)+import Data.List (nub, (\\)) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as Text@@ -122,13 +146,20 @@  {- | One machine of the pair. -@member_ssh_user@ and @member_host@ are how the /controller/ reaches it;-@member_host@ is also how the peer and the bouncers do, so it has to be an-address both can use.+@member_host@ is how the /peer and the bouncers/ reach it: it is what goes+into @pg_hba.conf@, @primary_conninfo@ and the routing file, and what a+standby reports as its upstream. @member_ssh_user@ and 'memberSshHost' are+how the /controller/ reaches it, and nothing else reads them: on a cloud+network the operator sees a machine on its external address and the peer+sees it on its internal one, and with one field for both the controller has+to live inside that network. -} data Member     = Member     { member_ssh_user :: Text+    -- ^ who the controller logs in as. Anything but @root@ must have+    -- passwordless sudo: every script is then run under one @sudo -n@+    -- (see 'remoteCommand').     , member_host :: Postgres.Host     , member_cluster :: Postgres.ClusterName     , member_port :: Postgres.Port@@ -136,12 +167,21 @@     -- ^ a key to authenticate with, for a machine that does not answer to     -- whatever the controller offers by default. Per member rather than per     -- pair: two machines need not have been given the same key.+    , member_ssh_host :: Maybe Text+    -- ^ where the controller's ssh goes, when that is not 'member_host'.+    -- Absent (also from a directive written before this field existed) it is+    -- 'member_host'. It appears in no script, no ref and no report: it is+    -- the controller's route to the machine, not the machine's name.     }     deriving (Eq, Show, Generic)  instance FromJSON Member instance ToJSON Member +-- | The address the controller's ssh connects to for this member.+memberSshHost :: Member -> Text+memberSshHost m = fromMaybe m.member_host m.member_ssh_host+ {- | One pgbouncer in front of the pair, and everything needed to move traffic through it without dropping any. @@ -157,6 +197,7 @@     { bouncer_name :: Text     -- ^ what to call it in reports; it identifies nothing else.     , bouncer_ssh_user :: Text+    -- ^ as 'member_ssh_user': @root@, or a login with passwordless sudo.     , bouncer_ssh_host :: Text     -- ^ how the /controller/ reaches it, which need not be how clients do.     , bouncer_ssh_identity :: Maybe FilePath@@ -178,12 +219,69 @@     -- leaves authentication to whoever put that file there.     , bouncer_listen_port :: Postgres.Port     -- ^ what clients connect to, as opposed to 'bouncer_console_port'.+    , bouncer_more_databases :: Maybe [RoutedDatabase]+    -- ^ the pair's other databases this bouncer routes, beside+    -- 'bouncer_alias'. Absent (also from a directive written before this+    -- field existed) there are none, and the bouncer routes the one database+    -- it always did. Read them all through 'routedDatabases'.     }     deriving (Eq, Show, Generic)  instance FromJSON Bouncer instance ToJSON Bouncer +{- | One database of the pair as a bouncer's clients see it: the name they+connect to, and the database it resolves to on whichever member is the+primary.+-}+data RoutedDatabase+    = RoutedDatabase+    { routed_alias :: Text+    , routed_dbname :: Text+    }+    deriving (Eq, Show, Generic)++instance FromJSON RoutedDatabase+instance ToJSON RoutedDatabase++{- | Every database a bouncer routes, 'bouncer_alias' first.++They live in /one/ routing file and move in /one/ pause, rewrite, reload and+resume, which is the point of declaring them on one bouncer rather than on+several: two @Bouncer@s on one machine would each write the same+@pgbouncer.ini@ and own the same service.+-}+routedDatabases :: Bouncer -> [RoutedDatabase]+routedDatabases b =+    RoutedDatabase b.bouncer_alias b.bouncer_dbname : fromMaybe [] b.bouncer_more_databases++{- | Everything wrong with the declared bouncers, not the first thing.++One alias twice in a routing file is one key twice in an ini section: the+bouncer keeps one of them and the probe reads whichever row it kept, so the+declaration could never be observed to hold. And a name that is not a plain+word would be read as something else by the routing file, by the console's+@PAUSE@, or by the shell carrying both -- checked only for the databases+beyond the first, so that a directive written before there could be several+is refused nothing it was not refused before.+-}+bouncerProblems :: Pair -> [Text]+bouncerProblems pair =+    concat+        [ [ "bouncer " <> b.bouncer_name <> ": the database " <> alias <> " is routed more than once"+          | alias <- nub (aliases \\ nub aliases)+          ]+            <> [ "bouncer " <> b.bouncer_name <> ": \"" <> name <> "\" is not a database name made of plain characters"+               | d <- fromMaybe [] b.bouncer_more_databases+               , name <- [d.routed_alias, d.routed_dbname]+               , Text.null name || Text.any (not . plain) name+               ]+        | b <- pair.pair_bouncers+        , let aliases = map routed_alias (routedDatabases b)+        ]+  where+    plain c = c `elem` ("_-." :: String) || c `elem` ['a' .. 'z'] || c `elem` ['A' .. 'Z'] || c `elem` ['0' .. '9']+ data Pair     = Pair     { pair_name :: Text@@ -251,12 +349,239 @@     -- a pair that is healthy, or merely lagging, never has anything wiped.     -- 'pair_seed' cannot do this job -- it is the /first/ clone, and its     -- guard leaves a data directory of the primary's own cluster alone.+    , pair_conn_security :: Maybe ConnSecurity+    -- ^ what the replication and rewind connections between the two members+    -- must be: see 'ConnSecurity'. Absent (also from a directive written+    -- before this field existed) it is 'PlainMd5', which is what every pair+    -- was before there was a choice; read it through 'connSecurity'.     }     deriving (Eq, Show, Generic)  instance FromJSON Pair instance ToJSON Pair +{- | What the connections one member makes to the other -- streaming+replication, @pg_basebackup@, @pg_rewind@, the slot bookkeeping -- must be.++Three choices, weakest first, and the weakest is the one with the plain+name: it is what an absent 'pair_conn_security' means, because that is what+every pair deployed before this type existed is, and a recipe that tightened+@pg_hba.conf@ under a running pair on upgrade would be a recipe that broke+replication on upgrade.++['PlainMd5'] @host ... md5@. TLS is not required by either end (libpq's+default @sslmode=prefer@ will use it if the server offers it, and will not+mind if somebody in the middle says it does not), and @md5@ accepts a+password stored either way. For a network nobody else is on.++['TlsScram'] @hostssl ... scram-sha-256@. The server refuses a connection+that is not TLS, the client refuses one too (@sslmode=require@ or stricter,+see 'ServerCheck'), and the password is only ever proven, never sent. The+roles' passwords are re-stored as SCRAM verifiers on the way.++['TlsClientCert'] @hostssl ... cert@. As above for the transport, and the+/client/ is authenticated by a certificate whose @CN@ is the role's name --+what "SreBox.PostgresTls" sets up for application clients, here for the two+roles the pair itself connects as. The passfiles are still read (the roles+are still given their passwords), but no line this recipe writes accepts one.++Every file named in here is __pre-provisioned on both members, at the same+path__: this recipe does not issue certificates and does not move them, for+the same reason it does not move passwords.+-}+data ConnSecurity+    = PlainMd5+    | TlsScram Tls+    | TlsClientCert Tls ClientCerts+    deriving (Eq, Show, Generic)++instance FromJSON ConnSecurity+instance ToJSON ConnSecurity++-- | The transport half of a TLS choice: both ends of it.+data Tls+    = Tls+    { tls_check :: ServerCheck+    -- ^ how hard a connecting member checks the one it connects to.+    , tls_server :: Maybe ServerFiles+    -- ^ what each member serves TLS with. 'Nothing' leaves the cluster's+    -- TLS settings as they were found -- Debian's clusters are created with+    -- @ssl = on@ and a self-signed certificate, which is enough for+    -- 'Encrypted' and for nothing stricter. Either way the member node+    -- refuses to write a @hostssl@ line on a cluster that is not serving+    -- TLS, since such a line matches nothing.+    }+    deriving (Eq, Show, Generic)++instance FromJSON Tls+instance ToJSON Tls++{- | What the connecting side demands of the server's certificate.++'Encrypted' is @sslmode=require@: the connection is encrypted and that is+all -- whoever answers at the peer's address is believed, so it keeps out an+eavesdropper and not somebody who can redirect the connection. The other two+name a CA certificate (on each member) and are @verify-ca@ and+@verify-full@; the last also wants the certificate to name 'member_host',+which for members declared by address means a certificate with that address+among its subject alternative names.+-}+data ServerCheck+    = Encrypted+    | VerifyCa FilePath+    | VerifyFull FilePath+    deriving (Eq, Show, Generic)++instance FromJSON ServerCheck+instance ToJSON ServerCheck++{- | A member's own certificate and key, and the CA it accepts client+certificates from. The paths are the same on both members; the files are+not (each member's certificate is its own). The key must be readable by+@postgres@ and by nobody else, or the cluster does not load it.+-}+data ServerFiles+    = ServerFiles+    { server_cert :: FilePath+    , server_key :: FilePath+    , server_client_ca :: Maybe FilePath+    -- ^ @ssl_ca_file@. Needed by 'TlsClientCert' (set here, or already set+    -- on the cluster); left as found when absent.+    }+    deriving (Eq, Show, Generic)++instance FromJSON ServerFiles+instance ToJSON ServerFiles++{- | The certificates the pair's two roles present, on each member (either+may be the one connecting). Each certificate's @CN@ must be the role's name:+that equality is the whole authentication. Keys are read by @postgres@ (the+standby's own connection, @pg_rewind@) and by root (the first clone), and+libpq refuses one that group or others can read.+-}+data ClientCerts+    = ClientCerts+    { client_repl_cert :: FilePath+    , client_repl_key :: FilePath+    , client_rewind_cert :: FilePath+    , client_rewind_key :: FilePath+    }+    deriving (Eq, Show, Generic)++instance FromJSON ClientCerts+instance ToJSON ClientCerts++-- | The pair's choice, with the absent one spelled out.+connSecurity :: Pair -> ConnSecurity+connSecurity = fromMaybe PlainMd5 . pair_conn_security++{- | The two @pg_hba.conf@ lines a member needs for a choice: the peer's+replication connection, and the peer's rewind connection.+-}+hbaLinesFor :: Pair -> Side -> ConnSecurity -> [Text]+hbaLinesFor pair side sec = hbaShape pair side (shapeOf sec)++{- | The lines the /other/ choices would have written on this member, which+a member removes before it adds its own.++@pg_hba.conf@ is read top to bottom and the first line that matches decides,+and @host@ matches a TLS connection as well as a plain one: left in place,+the @host ... md5@ line of a pair that was 'PlainMd5' yesterday sits above+the @hostssl@ line appended today and goes on accepting everything it ever+did. So this one recipe, whose lines are otherwise append-if-missing,+removes -- exactly these lines, compared whole, and nothing else in the file.+-}+hbaLinesRetired :: Pair -> Side -> ConnSecurity -> [Text]+hbaLinesRetired pair side sec =+    concat [hbaShape pair side shape | shape <- hbaShapes, shape /= shapeOf sec]++hbaShapes :: [(Text, Text)]+hbaShapes = [("host", "md5"), ("hostssl", "scram-sha-256"), ("hostssl", "cert")]++shapeOf :: ConnSecurity -> (Text, Text)+shapeOf PlainMd5 = ("host", "md5")+shapeOf (TlsScram _) = ("hostssl", "scram-sha-256")+shapeOf (TlsClientCert _ _) = ("hostssl", "cert")++hbaShape :: Pair -> Side -> (Text, Text) -> [Text]+hbaShape pair side (kind, method) =+    [ Text.unwords [kind, "replication", pair.pair_repl_role, peer.member_host <> "/32", method]+    , Text.unwords [kind, "all", pair.pair_rewind_role, peer.member_host <> "/32", method]+    ]+  where+    peer = memberOn pair (other side)++{- | Everything wrong with the declared choice, not the first thing.++The paths end up inside a libpq connection string, inside a line of+@postgresql.auto.conf@, inside a shell script: a path that is not a plain+word would be read as something else by one of the three.+-}+securityProblems :: Pair -> [Text]+securityProblems pair = case connSecurity pair of+    PlainMd5 -> []+    TlsScram tls -> tlsProblems tls+    TlsClientCert tls cc ->+        tlsProblems tls+            <> path "replication client certificate" cc.client_repl_cert+            <> path "replication client key" cc.client_repl_key+            <> path "rewind client certificate" cc.client_rewind_cert+            <> path "rewind client key" cc.client_rewind_key+  where+    tlsProblems :: Tls -> [Text]+    tlsProblems tls =+        ( case tls.tls_check of+            Encrypted -> []+            VerifyCa ca -> path "CA certificate" ca+            VerifyFull ca -> path "CA certificate" ca+        )+            <> foldMap+                ( \(sf :: ServerFiles) ->+                    path "server certificate" sf.server_cert+                        <> path "server key" sf.server_key+                        <> foldMap (path "client CA certificate") sf.server_client_ca+                )+                tls.tls_server+    path :: Text -> FilePath -> [Text]+    path what p =+        [ what <> ": \"" <> Text.pack p <> "\" is not an absolute path made of plain characters"+        | not (take 1 p == "/" && all plain p)+        ]+    plain c = c `notElem` (" \t\n\r'\"\\$`" :: String)++data ConnAs = AsReplication | AsRewind++{- | What a connection string gains from the choice. Nothing at all for+'PlainMd5', so that pair's scripts are what they always were.+-}+sslParams :: Pair -> ConnAs -> [String]+sslParams pair who = case connSecurity pair of+    PlainMd5 -> []+    TlsScram tls -> check tls.tls_check+    TlsClientCert tls cc -> check tls.tls_check <> certs cc+  where+    check Encrypted = ["sslmode=require"]+    check (VerifyCa ca) = ["sslmode=verify-ca", "sslrootcert=" <> ca]+    check (VerifyFull ca) = ["sslmode=verify-full", "sslrootcert=" <> ca]+    certs :: ClientCerts -> [String]+    certs cc = case who of+        AsReplication -> ["sslcert=" <> cc.client_repl_cert, "sslkey=" <> cc.client_repl_key]+        AsRewind -> ["sslcert=" <> cc.client_rewind_cert, "sslkey=" <> cc.client_rewind_key]++{- | The same, as environment, for the one command here that builds its own+connection: 'Postgres.cloneFromPrimaryScript', whose @pg_basebackup@ and+identity query take a host and a user rather than a string. libpq reads+these wherever a connection string says nothing, and every other connection+in these scripts says it in the string.+-}+sslEnvironment :: Pair -> [String]+sslEnvironment pair =+    [ "export " <> var <> "=" <> shQuote (drop 1 value)+    | param <- sslParams pair AsReplication+    , let (key, value) = break (== '=') param+    , Just var <- [lookup key [("sslmode", "PGSSLMODE"), ("sslrootcert", "PGSSLROOTCERT"), ("sslcert", "PGSSLCERT"), ("sslkey", "PGSSLKEY")]]+    ]+ memberOn :: Pair -> Side -> Member memberOn pair A = pair.pair_a memberOn pair B = pair.pair_b@@ -509,9 +834,26 @@ bouncerProbeScript :: Bouncer -> String bouncerProbeScript b = consoleCommand b "-AX" "SHOW DATABASES" --- | Reads 'bouncerProbeScript''s output, for the one database this pair owns.+{- | Reads 'bouncerProbeScript''s output: one state per database the bouncer+routes, in 'routedDatabases'' order.++One per /database/ rather than one per bouncer, because 'nextStep' reads+these as a set and asks the same two things of each -- is it held, is it+pointed at the primary -- and a bouncer summed up as one state has to lie+about one of them whenever its databases disagree: a bouncer with one alias+moved and one left behind is neither at the primary nor at the peer, and one+with a single alias still paused is an outage for that alias's clients.+Every alias has to agree before a pair has arrived.+-}+parseBouncerStates :: Bouncer -> Text -> [BouncerState]+parseBouncerStates b out = [parseDatabaseState d.routed_alias out | d <- routedDatabases b]++-- | 'parseBouncerStates' for 'bouncer_alias' alone. parseBouncerState :: Bouncer -> Text -> BouncerState-parseBouncerState b out =+parseBouncerState b = parseDatabaseState b.bouncer_alias++parseDatabaseState :: Text -> Text -> BouncerState+parseDatabaseState alias out =     case (header, row) of         (Just hs, Just r) ->             BouncerState@@ -526,7 +868,7 @@     row = do         hs <- header         i <- lookupIndex hs "name"-        case [r | r <- rows, atIndex r i == Just b.bouncer_alias] of+        case [r | r <- rows, atIndex r i == Just alias] of             (r : _) -> Just r             _ -> Nothing @@ -867,13 +1209,19 @@     one -- and because "did the clients actually stop" is the question this     step exists to answer, not "did a command exit zero". -}     pauseScript b =+        unlines ["set -e"]+            <> concatMap (pauseOne b . Text.unpack . routed_alias) (routedDatabases b)++    {- Every database the bouncer routes, one after the other and each+    checked before the next: the step is over only once all of them are+    held, and 'nextStep' does not stop the old primary before that. -}+    pauseOne b alias =         unlines-            [ "set -e"-            , -- kept, rather than discarded: "it did not pause" is a+            [ -- kept, rather than discarded: "it did not pause" is a               -- symptom, and what the console said about it is the cause.-              "said=$(" <> consoleCommand b "-tAX" ("PAUSE " <> Text.unpack b.bouncer_alias) <> " 2>&1)" <> " || true"-            , "paused=$(" <> showDatabasesColumn b "paused" <> ")"-            , "[ \"$paused\" = 1 ] || { echo " <> shQuote ("bouncer " <> Text.unpack b.bouncer_name <> " did not pause " <> Text.unpack b.bouncer_alias <> ", and said:") <> " \"$said\" >&2; "+              "said=$(" <> consoleCommand b "-tAX" ("PAUSE " <> alias) <> " 2>&1)" <> " || true"+            , "paused=$(" <> showDatabasesColumn b alias "paused" <> ")"+            , "[ \"$paused\" = 1 ] || { echo " <> shQuote ("bouncer " <> Text.unpack b.bouncer_name <> " did not pause " <> alias <> ", and said:") <> " \"$said\" >&2; "                 <> consoleCommand b "-AX" "SHOW DATABASES" <> " >&2 2>&1 || true; exit 1; }"             ] @@ -881,29 +1229,34 @@     bouncer reads it, RESUME so the clients it has been holding go to the new     primary. The file is written here rather than reloaded from a     declaration, because between those two things there is a moment when the-    bouncer would send clients to a machine that is not the primary yet. -}+    bouncer would send clients to a machine that is not the primary yet.++    One file and one RELOAD whatever number of databases the bouncer routes,+    so they move together; then each is resumed and checked. A database that+    fails its check leaves the ones after it held, which the next pass sees+    (not every alias is ready) and repoints again. -}     repointScript side b =         unlines-            [ "set -e"-            , "cat > " <> shQuote b.bouncer_routing_path <> " <<'SALMON_ROUTING'"-            , "[databases]"-            , Text.unpack b.bouncer_alias-                <> " = host="-                <> Text.unpack (on side).member_host-                <> " port="-                <> port side-                <> " dbname="-                <> Text.unpack b.bouncer_dbname-            , "SALMON_ROUTING"-            , consoleCommand b "-tAX" "RELOAD" <> " >/dev/null"-            , "said=$(" <> consoleCommand b "-tAX" ("RESUME " <> Text.unpack b.bouncer_alias) <> " 2>&1)" <> " || true"-            , "host=$(" <> showDatabasesColumn b "host" <> ")"-            , "paused=$(" <> showDatabasesColumn b "paused" <> ")"+            ( [ "set -e"+              , "cat > " <> shQuote b.bouncer_routing_path <> " <<'SALMON_ROUTING'"+              ]+                <> routingLines (on side) b+                <> [ "SALMON_ROUTING"+                   , consoleCommand b "-tAX" "RELOAD" <> " >/dev/null"+                   ]+            )+            <> concatMap (resumeOne side b . Text.unpack . routed_alias) (routedDatabases b)++    resumeOne side b alias =+        unlines+            [ "said=$(" <> consoleCommand b "-tAX" ("RESUME " <> alias) <> " 2>&1)" <> " || true"+            , "host=$(" <> showDatabasesColumn b alias "host" <> ")"+            , "paused=$(" <> showDatabasesColumn b alias "paused" <> ")"             , "[ \"$host\" = " <> shQuote (Text.unpack (on side).member_host) <> " ] && [ \"$paused\" = 0 ]"-                <> " || { echo " <> shQuote ("bouncer " <> Text.unpack b.bouncer_name <> " is still sending clients to $host (paused=$paused), and said:") <> " \"$said\" >&2; exit 1; }"+                <> " || { echo " <> shQuote ("bouncer " <> Text.unpack b.bouncer_name <> " is still sending clients of " <> alias <> " to $host (paused=$paused), and said:") <> " \"$said\" >&2; exit 1; }"             ] -    {- One column of this pair's row of SHOW DATABASES, found by column+    {- One column of one database's row of SHOW DATABASES, found by column     /name/: the columns have changed between pgbouncer versions, and     counting them reads the wrong one. @@ -911,14 +1264,30 @@     program, because a shell-quoted string spliced into a single-quoted awk     program stops being a string: the shell eats the quotes, awk reads a bare     word, and a bare word in awk is an empty variable that equals nothing. -}-    showDatabasesColumn b col =+    showDatabasesColumn b alias col =         consoleCommand b "-AX" "SHOW DATABASES"             <> " | awk -F'|' -v col="             <> shQuote col             <> " -v want="-            <> shQuote (Text.unpack b.bouncer_alias)+            <> shQuote alias             <> " 'NR==1 { for (i=1;i<=NF;i++) { if ($i==\"name\") n=i; if ($i==col) c=i } } NR>1 && $n==want { print $c }'" +{- The routing file's contents: one line per database the bouncer routes,+all sent to the same member. Shared by the two writers of that file so that+they cannot come to disagree about its shape. -}+routingLines :: Member -> Bouncer -> [String]+routingLines m b =+    "[databases]"+        : [ Text.unpack d.routed_alias+            <> " = host="+            <> Text.unpack m.member_host+            <> " port="+            <> show m.member_port+            <> " dbname="+            <> Text.unpack d.routed_dbname+          | d <- routedDatabases b+          ]+ {- Everything that makes a member /this pair's/ standby, whatever brought it here -- a rewind, or a clone from nothing. It writes the recovery configuration rather than trusting @pg_rewind -R@ or @pg_basebackup -R@@@ -971,16 +1340,17 @@  primaryConninfo :: Pair -> Side -> String primaryConninfo pair side =-    unwords+    unwords $         [ "host=" <> Text.unpack (memberOn pair side).member_host         , "port=" <> show (memberOn pair side).member_port         , "user=" <> Text.unpack pair.pair_repl_role         , "passfile=" <> pair.pair_repl_passfile         ]+            <> sslParams pair AsReplication  replicationConn :: Pair -> Side -> String replicationConn pair side =-    unwords+    unwords $         [ "host=" <> Text.unpack (memberOn pair side).member_host         , "port=" <> show (memberOn pair side).member_port         , "user=" <> Text.unpack pair.pair_repl_role@@ -989,15 +1359,17 @@           -- and pg_hba matches that against the database name.           "replication=true"         ]+            <> sslParams pair AsReplication  sourceServer :: Pair -> Side -> String sourceServer pair side =-    unwords+    unwords $         [ "host=" <> Text.unpack (memberOn pair side).member_host         , "port=" <> show (memberOn pair side).member_port         , "user=" <> Text.unpack pair.pair_rewind_role         , "dbname=postgres"         ]+            <> sslParams pair AsRewind   shQuote :: String -> String@@ -1066,8 +1438,12 @@             , notes =                 [ "accepts replication and rewind connections from " <> peer.member_host                 , "cluster " <> m.member_cluster <> " on port " <> Text.pack (show m.member_port)+                , -- what a re-declaration with another choice changes, so+                  -- that `run serve` sees one+                  "those connections: " <> securityNote (connSecurity pair)                 ]             , up = do+                refuseBadSecurity pair                 (code, out, err) <- sshToTarget pair (OnMember m) (memberScript pair side)                 runReporter r (Acted m.member_host code (Text.strip (out <> err)))                 case code of@@ -1079,9 +1455,6 @@     m = memberOn pair side     peer = memberOn pair (other side) -{- | The script 'member' runs. Pure, like the steps, so that what it does to-a machine can be read without one.--} {- | Builds one member out of the other: @pg_basebackup@, then everything that makes it this pair's standby. @@ -1106,6 +1479,7 @@                 [ "clones only over a pristine or matching data directory, and refuses anything else"                 ]             , up = do+                refuseBadSecurity pair                 (code, out, err) <- sshToTarget pair (OnMember m) (seedScript pair side)                 runReporter r (Acted m.member_host code (Text.strip (out <> err)))                 case code of@@ -1128,13 +1502,14 @@ seedScriptWith :: [String] -> Pair -> Side -> String seedScriptWith between pair side =     unlines $-        [ Postgres.cloneFromPrimaryScript setup-        , -- the clone leaves it running and streaming with whatever+        sslEnvironment pair+            <> [ Postgres.cloneFromPrimaryScript setup+               , -- the clone leaves it running and streaming with whatever           -- pg_basebackup's -R wrote; from here it is this pair's standby,           -- with this pair's slot, which nothing else would give it.           "version=$(pg_lsclusters --no-header | awk -v c=" <> shQuote (Text.unpack m.member_cluster) <> " '$2==c {print $1}' | head -n1)"         , "datadir=/var/lib/postgresql/$version/" <> Text.unpack m.member_cluster-        ]+               ]             <> between             <> standbyTail pair side             <> [ unwords ["pg_ctlcluster", "\"$version\"", Text.unpack m.member_cluster, "restart"]@@ -1233,7 +1608,7 @@             { ref = mkRef "pg-pair-bouncer" (pair.pair_name <> "@" <> b.bouncer_ssh_host)             , help = Text.unwords ["pgbouncer", b.bouncer_name, "in front of", pair.pair_name]             , notes =-                [ "clients reach " <> b.bouncer_alias <> " on port " <> Text.pack (show b.bouncer_listen_port)+                [ "clients reach " <> Text.intercalate ", " (map routed_alias (routedDatabases b)) <> " on port " <> Text.pack (show b.bouncer_listen_port)                 , "routing is " <> Text.pack b.bouncer_routing_path <> ", which the role node owns"                 ]             , up = do@@ -1256,22 +1631,17 @@         , -- written only if absent: after that it is the role node's, and a           -- pass that rewrote it here would move clients without pausing them           "[ -e " <> shQuote b.bouncer_routing_path <> " ] || cat > " <> shQuote b.bouncer_routing_path <> " <<'SALMON_ROUTING'"-        , "[databases]"-        , Text.unpack b.bouncer_alias-            <> " = host="-            <> Text.unpack primary.member_host-            <> " port="-            <> show primary.member_port-            <> " dbname="-            <> Text.unpack b.bouncer_dbname-        , "SALMON_ROUTING"-        , "if ! cmp -s /tmp/salmon-pgbouncer.ini " <> shQuote ini <> "; then"-        , "  install -m 0644 /tmp/salmon-pgbouncer.ini " <> shQuote ini <> ""-        , "  systemctl restart pgbouncer"-        , "fi"-        , "rm -f /tmp/salmon-pgbouncer.ini"-        , "systemctl is-active --quiet pgbouncer || systemctl start pgbouncer"         ]+        <> unlines (routingLines primary b)+        <> unlines+            [ "SALMON_ROUTING"+            , "if ! cmp -s /tmp/salmon-pgbouncer.ini " <> shQuote ini <> "; then"+            , "  install -m 0644 /tmp/salmon-pgbouncer.ini " <> shQuote ini <> ""+            , "  systemctl restart pgbouncer"+            , "fi"+            , "rm -f /tmp/salmon-pgbouncer.ini"+            , "systemctl is-active --quiet pgbouncer || systemctl start pgbouncer"+            ]   where     primary = memberOn pair pair.pair_primary     ini = b.bouncer_config_dir <> "/pgbouncer.ini"@@ -1294,6 +1664,71 @@             , PgBouncer.bouncer_routing_file = Just b.bouncer_routing_path             } +{- | A declaration whose paths would not survive being spliced into a script+runs nothing at all, and says everything that is wrong with it.+-}+refuseBadSecurity :: Pair -> IO ()+refuseBadSecurity pair =+    case (securityProblems pair, bouncerProblems pair) of+        ([], []) -> pure ()+        ([], problems) ->+            throwIO (userError (Text.unpack ("pair " <> pair.pair_name <> ": pair_bouncers: " <> Text.intercalate "; " problems)))+        (problems, _) ->+            throwIO (userError (Text.unpack ("pair " <> pair.pair_name <> ": pair_conn_security: " <> Text.intercalate "; " problems)))++-- | The choice in words, for a node's @notes@: paths, never contents.+securityNote :: ConnSecurity -> Text+securityNote PlainMd5 = "host, md5 (TLS not required)"+securityNote (TlsScram tls) = "hostssl, scram-sha-256, " <> tlsNote tls+securityNote (TlsClientCert tls cc) =+    "hostssl, client certificates ("+        <> Text.pack cc.client_repl_cert+        <> ", "+        <> Text.pack cc.client_rewind_cert+        <> "), "+        <> tlsNote tls++tlsNote :: Tls -> Text+tlsNote tls =+    Text.intercalate+        ", "+        [ case tls.tls_check of+            Encrypted -> "server not verified (sslmode=require)"+            VerifyCa ca -> "server verified against " <> Text.pack ca <> " (verify-ca)"+            VerifyFull ca -> "server and its name verified against " <> Text.pack ca <> " (verify-full)"+        , case tls.tls_server of+            Nothing -> "the cluster's TLS settings left as found"+            Just sf -> "served with " <> Text.pack sf.server_cert+        ]++{- | The script 'member' runs. Pure, like the steps, so that what it does to+a machine can be read without one.++= What it does to @pg_hba.conf@++It removes the lines the pair's /other/ 'ConnSecurity' choices would have+written for this peer ('hbaLinesRetired'), and appends this choice's two if+they are missing ('hbaLinesFor'). Removing is what makes a tightened choice+mean anything -- see 'hbaLinesRetired' -- and it touches those exact lines+only. A line somebody else wrote above them that also matches the peer still+wins: this recipe owns its lines, not the file.++For the TLS choices, in this order: the cluster is made to serve TLS (if+'tls_server' says with what), it is /asked/ whether it does, and only then+is the file touched. A @hostssl@ line on a cluster with @ssl = off@ matches+nothing, so a pass that wrote one first would cut the pair's replication to+announce that TLS is not set up. Afterwards the server is asked whether it+could read the file it was given (@pg_hba_file_rules@), since a file it+cannot parse is silently not loaded.++= What it does on a standby++Aligns @primary_conninfo@ with the declared choice, if and only if the+standby is already pointed at its peer: a choice changed on a running pair+otherwise reaches the standby's own connection at its next rejoin, and with+client certificates that connection would fail at its next reconnect. It+never points a standby anywhere -- that is the role node's, through a rejoin.+-} memberScript :: Pair -> Side -> String memberScript pair side =     unlines $@@ -1302,10 +1737,9 @@         , "hba=/etc/postgresql/$version/" <> cluster <> "/pg_hba.conf"         ]             <> map setting (Postgres.replicationSettings Postgres.defaultReplicationTuning)-            <> map hbaLine-                [ "host replication " <> Text.unpack pair.pair_repl_role <> " " <> Text.unpack peer.member_host <> "/32 md5"-                , "host all " <> Text.unpack pair.pair_rewind_role <> " " <> Text.unpack peer.member_host <> "/32 md5"-                ]+            <> servesTls+            <> map (retireHbaLine . Text.unpack) (hbaLinesRetired pair side security)+            <> map (hbaLine . Text.unpack) (hbaLinesFor pair side security)             <> -- roles are catalog rows: they reach the other machine through                -- the WAL like any other write, so only a primary makes them,                -- and a standby that is one tomorrow already has them.@@ -1314,10 +1748,22 @@                , "  rewindpw=$(awk -F: 'NR==1 {print $5}' " <> shQuote pair.pair_rewind_passfile <> ")"                , "  " <> heredoc (roleSql "REPLICATION LOGIN" pair.pair_repl_role "$replpw")                , "  " <> heredoc (roleSql "LOGIN" pair.pair_rewind_role "$rewindpw" <> " " <> grants)+               , "else"+               , -- a standby already pointed at its peer connects the way the+                 -- pair now says to. Compared first: for a pair whose choice+                 -- did not change this is one query and nothing else.+                 "  conninfo=$(" <> query "SELECT setting FROM pg_settings WHERE name = 'primary_conninfo'" <> ")"+               , "  case \"$conninfo\" in"+               , "    " <> shQuote ("host=" <> Text.unpack peer.member_host <> " ") <> "*)"+               , "      [ \"$conninfo\" = " <> shQuote wantedConninfo <> " ] || "+                    <> psql' ("ALTER SYSTEM SET primary_conninfo = " <> Text.unpack (quoteSql (Text.pack wantedConninfo)))+                    <> " ;;"+               , "  esac"                , "fi"                ]-            <> [ psql' "SELECT pg_reload_conf()"-               , -- the same shape as systemd's NeedDaemonReload: the file has+            <> [psql' "SELECT pg_reload_conf()"]+            <> hbaLoaded+            <> [ -- the same shape as systemd's NeedDaemonReload: the file has                  -- changed, and only the running server knows whether what                  -- changed needs it to come back.                  "pending=$(" <> query "SELECT count(*) FROM pg_settings WHERE pending_restart" <> ")"@@ -1328,12 +1774,62 @@     peer = memberOn pair (other side)     cluster = Text.unpack m.member_cluster     port = show m.member_port+    security = connSecurity pair+    wantedConninfo = primaryConninfo pair (other side)      setting (k, v) = psql' ("ALTER SYSTEM SET " <> Text.unpack k <> " = " <> Text.unpack (quoteSql v))     quoteSql v = "'" <> Text.replace "'" "''" v <> "'"      hbaLine l = "grep -qxF " <> shQuote l <> " \"$hba\" || echo " <> shQuote l <> " >> \"$hba\"" +    {- Written back with `cat >`, not moved into place: the file keeps its+    owner, its mode and its inode, which are postgresql-common's. -}+    retireHbaLine l =+        "if grep -qxF " <> shQuote l <> " \"$hba\"; then awk -v l=" <> shQuote l+            <> " '$0 != l' \"$hba\" > \"$hba.salmon\" && cat \"$hba.salmon\" > \"$hba\"; rm -f \"$hba.salmon\"; fi"++    servesTls = case security of+        PlainMd5 -> []+        TlsScram tls -> serving tls False+        TlsClientCert tls _ -> serving tls True++    serving :: Tls -> Bool -> [String]+    serving tls needsClientCa =+        foldMap serverFiles tls.tls_server+            <> [ psql' "SELECT pg_reload_conf()"+               , "[ \"$(" <> query "SHOW ssl" <> ")\" = on ] || { echo "+                    <> shQuote ("cluster " <> cluster <> " is not serving TLS (ssl is off), so a hostssl line would match nothing: pg_hba.conf left as it was")+                    <> " >&2; exit 1; }"+               ]+            <> [ "[ -n \"$(" <> query "SHOW ssl_ca_file" <> ")\" ] || { echo "+                    <> shQuote ("cluster " <> cluster <> " has no ssl_ca_file, so it cannot check a client certificate: pg_hba.conf left as it was")+                    <> " >&2; exit 1; }"+               | needsClientCa+               ]++    serverFiles :: ServerFiles -> [String]+    serverFiles sf =+        map readable ([sf.server_cert, sf.server_key] <> foldMap pure sf.server_client_ca)+            <> [ setting ("ssl_cert_file", Text.pack sf.server_cert)+               , setting ("ssl_key_file", Text.pack sf.server_key)+               ]+            <> foldMap (\ca -> [setting ("ssl_ca_file", Text.pack ca)]) sf.server_client_ca+            <> [setting ("ssl", "on")]++    readable f =+        "sudo -u postgres test -r " <> shQuote f <> " || { echo "+            <> shQuote ("pre-provisioned file missing or unreadable by postgres: " <> f)+            <> " >&2; exit 1; }"++    hbaLoaded = case security of+        PlainMd5 -> []+        _ ->+            [ "broken=$(" <> query "SELECT count(*) FROM pg_hba_file_rules WHERE error IS NOT NULL" <> ")"+            , "[ \"$broken\" = 0 ] || { echo "+                <> shQuote "the server could not read pg_hba.conf as it now stands (see pg_hba_file_rules), so it is still using the previous one"+                <> " >&2; exit 1; }"+            ]+     psql' sql = "sudo -u postgres psql -p " <> port <> " -tAX -d postgres -c " <> shQuote sql     query = psql' @@ -1346,9 +1842,13 @@         "sudo -u postgres psql -p " <> port <> " -tAX -d postgres >/dev/null <<PAIR_SQL\n" <> sql <> "\nPAIR_SQL"      {- Created if missing, and its password set either way, so that rotating-    the passfile is enough to rotate the role. -}+    the passfile is enough to rotate the role -- and, under a TLS choice,+    stored as a SCRAM verifier whatever the cluster's own default is, since+    @scram-sha-256@ in pg_hba.conf refuses a role whose password is stored+    as md5. -}     roleSql attrs role pw =-        "DO \\$do\\$ BEGIN CREATE ROLE "+        storedAs+            <> "DO \\$do\\$ BEGIN CREATE ROLE "             <> Text.unpack role             <> " "             <> attrs@@ -1361,6 +1861,10 @@             <> pw             <> "';" +    storedAs = case security of+        PlainMd5 -> ""+        _ -> "SET password_encryption = 'scram-sha-256'; "+     grants =         unwords             [ "GRANT EXECUTE ON FUNCTION pg_ls_dir(text, boolean, boolean) TO " <> Text.unpack pair.pair_rewind_role <> ";"@@ -1381,7 +1885,7 @@                 , maybe "no side may be re-seeded" (\s -> "may be re-seeded, if its slot is lost: " <> Text.pack (show s)) pair.pair_reseed                 ]             , check = verdict <$> decide pair-            , up = converge r pair+            , up = refuseBadSecurity pair >> converge r pair             }  {- | The whole pair as one declaration: both machines configured to be@@ -1430,7 +1934,7 @@     obsA <- observe pair A     obsB <- observe pair B     bouncers <- traverse (observeBouncer pair) pair.pair_bouncers-    pure (nextStep pair obsA obsB bouncers)+    pure (nextStep pair obsA obsB (concat bouncers))  {- | Asks a bouncer where it is sending clients, and whether it is holding them.@@ -1440,12 +1944,12 @@ cannot. That is the right way round: a pair whose clients are going somewhere unknown has not arrived. -}-observeBouncer :: Pair -> Bouncer -> IO BouncerState+observeBouncer :: Pair -> Bouncer -> IO [BouncerState] observeBouncer pair b = do     (code, out, _) <- sshToTarget pair (OnBouncer b) (bouncerProbeScript b)     pure $ case code of-        ExitSuccess -> parseBouncerState b out-        ExitFailure _ -> BouncerState Nothing False+        ExitSuccess -> parseBouncerStates b out+        ExitFailure _ -> [BouncerState Nothing False | _ <- routedDatabases b]  -- | Runs 'probeScript' on a member and reads what comes back. observe :: Pair -> Side -> IO Observed@@ -1529,20 +2033,58 @@ sshTo :: Pair -> Side -> String -> IO (ExitCode, Text, Text) sshTo pair side = sshToTarget pair (OnMember (memberOn pair side)) --- | The same, for whichever kind of machine a step addresses.-sshToTarget :: Pair -> Target -> String -> IO (ExitCode, Text, Text)-sshToTarget pair target script = do-    (code, out, err) <- readCreateProcessWithExitCode (proc "ssh" args) ""-    pure (code, decode out, decode err)+{- | The @user\@host@ the controller's ssh is given for a machine: the one+place a member's ssh address is read. Everything a script /contains/ about a+member is its 'member_host'.+-}+sshLogin :: Target -> Text+sshLogin target = sshUser target <> "@" <> case target of+    OnMember m -> memberSshHost m+    OnBouncer b -> b.bouncer_ssh_host++-- | The user the controller logs in as on a machine.+sshUser :: Target -> Text+sshUser (OnMember m) = m.member_ssh_user+sshUser (OnBouncer b) = b.bouncer_ssh_user++{- | The words ssh is given after the login: the script, under one @bash -c@,+and under one @sudo@ when the login is not root.++Every script this recipe sends was written to be run by root -- it appends to+@pg_hba.conf@, calls @pg_ctlcluster@, installs into @\/etc\/pgbouncer@,+restarts units, and reaches postgres through @sudo -u postgres@ -- and stock+cloud images refuse root logins. So the privilege is taken once, around the+whole script, rather than line by line: one wrapper cannot miss a line, and a+script reads the same whoever logged in. A root login is sent what it always+was, with no @sudo@ in front, so a machine without sudo installed still works+as root.++@-n@ because nobody is there to type a password: a login whose sudo wants one+fails at once, saying so, rather than waiting on a prompt. The locale is set+/inside/ the script, since sudo resets the environment.+-}+remoteCommand :: Target -> String -> [String]+remoteCommand target script = escalate <> ["bash", "-c", shQuote quieted]   where-    (login, identity) = case target of-        OnMember m -> (m.member_ssh_user <> "@" <> m.member_host, m.member_ssh_identity)-        OnBouncer b -> (b.bouncer_ssh_user <> "@" <> b.bouncer_ssh_host, b.bouncer_ssh_identity)+    escalate+        | sshUser target == "root" = []+        | otherwise = ["sudo", "-n"]     {- A neutral locale, because ssh forwards the caller's and Debian's psql     is a perl wrapper that complains about every locale the guest does not     have -- fifteen lines of it, per invocation, into the report of a node     that did nothing wrong. -}     quieted = "export LANG=C LC_ALL=C\n" <> script++-- | The same, for whichever kind of machine a step addresses.+sshToTarget :: Pair -> Target -> String -> IO (ExitCode, Text, Text)+sshToTarget pair target script = do+    (code, out, err) <- readCreateProcessWithExitCode (proc "ssh" args) ""+    pure (code, decode out, decode err)+  where+    login = sshLogin target+    identity = case target of+        OnMember m -> m.member_ssh_identity+        OnBouncer b -> b.bouncer_ssh_identity     args =         concat             [ maybe [] (\key -> ["-i", key, "-o", "IdentitiesOnly=yes"]) identity@@ -1556,6 +2098,6 @@               -- the probe is already running.               ["-o", "ConnectTimeout=10", "-o", "ServerAliveInterval=5", "-o", "ServerAliveCountMax=2"]             , [Text.unpack login]-            , ["bash", "-c", shQuote quieted]+            , remoteCommand target script             ]     decode = Text.decodeUtf8With TextError.lenientDecode

@@ -0,0 +1,558 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++{- | What "SreBox.PostgresPair" assumes was done before it ran, as nodes.++The pair is handed paths: two @.pgpass@ files on each member, a console+@.pgpass@ and a @userlist.txt@ on each bouncer, and it expects the packages+to be there and the application to have a role, a database and a way in.+This module declares that layer, so that a consumer of the pair does not+write it again -- it is the part where mistakes are quiet (a @userlist.txt@+written under a running pgbouncer is a correct password that does not work).++= Secrets are still somebody else's files++Nothing here carries a password and nothing here decides how one travels.+Every secret is a file that is /already on the machine it is for/, put there+by whatever the deployment uses for that; a 'SecretFile' says where it was+left ('secret_from') and this recipe installs it where the pair reads it,+with the owner and mode the pair needs. A file left at its destination+already ('secret_from' @= Nothing@) only has its owner and mode set.++The scripts contain paths, never contents, and say nothing about a file but+its name: a missing file is named, a password is read on the machine and fed+to @psql@ on standard input, and the one statement that holds it has its+output withheld from the report.++= What it declares++* 'memberPrereqs', per member: the packages, a cluster of the declared name+  to exist, and the replication and rewind passfiles.+* 'bouncerPrereqs', per bouncer: the packages, the console passfile, and the+  auth file -- installed only when it differs, and pgbouncer restarted only+  then, because pgbouncer reads it when it starts and a restart drops the+  clients it is holding.+* 'applications', per member: a @pg_hba.conf@ line per application and+  client (on both members: that file is not replicated), and, on whichever+  member is the primary, the role, its password and its database.++'pairWithPrereqs' is the pair with all of it, in order: a machine's+prerequisites before the pair's own node for that machine, and the+applications after the role node -- once there is exactly one primary to+create a role on. Before it, a member that is about to be cloned is a+pristine cluster not in recovery, and a database created there is what makes+the clone refuse to run over it.+-}+module SreBox.PostgresPairPrereqs (+    -- * Declaring them+    SecretFile (..),+    postgresOwned,+    inPlace,+    Application (..),+    Prereqs (..),+    defaultPrereqs,+    validate,++    -- * The nodes+    memberPrereqs,+    bouncerPrereqs,+    applications,+    pairWithPrereqs,++    -- * The scripts they run+    memberPrereqsScript,+    bouncerPrereqsScript,+    applicationsScript,+    hbaLines,+) where++import Control.Exception (throwIO)+import Control.Monad (unless)+import Data.Aeson (FromJSON, ToJSON)+import Data.Char (isAsciiLower, isDigit, isOctDigit)+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import System.Exit (ExitCode (..))+import System.FilePath (takeDirectory, (</>))++import Salmon.Builtin.Extension+import Salmon.Op.OpGraph (inject)+import Salmon.Op.Ref (mkRef)+import Salmon.Reporter++import SreBox.PostgresPair (Bouncer (..), Member (..), Pair (..), Side (..), Target (..), memberOn)+import qualified SreBox.PostgresPair as Pair++-------------------------------------------------------------------------------+-- Declaring them++{- | A secret somebody else put on the machine, and how it should be held+once it is where the pair reads it. The destination is not here: the pair+already names it.+-}+data SecretFile+    = SecretFile+    { secret_from :: Maybe FilePath+    -- ^ where it was provisioned, on the machine it is for. 'Nothing' (or+    -- the destination itself) is a file left in place: only its owner and+    -- mode are set.+    , secret_owner :: Text+    , secret_group :: Text+    , secret_mode :: Text+    -- ^ octal, as @install -m@ takes it.+    }+    deriving (Eq, Show, Generic)++instance FromJSON SecretFile+instance ToJSON SecretFile++{- | @postgres:postgres@, @0600@: what a passfile must be, since libpq+ignores one that anybody else can read and the pair's commands run as+@postgres@.+-}+postgresOwned :: FilePath -> SecretFile+postgresOwned from = SecretFile (Just from) "postgres" "postgres" "0600"++-- | The same, for a file provisioned straight to where the pair reads it.+inPlace :: SecretFile+inPlace = SecretFile Nothing "postgres" "postgres" "0600"++{- | One application's way into the pair: a role, the database it owns, and+who may connect as it.++The pair knows nothing of this -- it routes a database, it does not own one+-- which is why it is declared here and not there.+-}+data Application+    = Application+    { app_role :: Text+    , app_database :: Text+    , app_passfile :: FilePath+    -- ^ the role's password, in @.pgpass@ format, on /each member/ (either+    -- may be the primary). Read where it lies, by the login the controller+    -- uses; the password is the fifth field of its first line, as for the+    -- pair's own passfiles.+    , app_clients :: [Text]+    -- ^ the addresses that connect as this role -- the bouncers, as the+    -- members see them, which is not necessarily 'bouncer_ssh_host'. A bare+    -- address is one host; anything with a @\/@ is taken as written.+    , app_hba_method :: Text+    -- ^ @md5@ (which also accepts a SCRAM-stored password) or+    -- @scram-sha-256@.+    }+    deriving (Eq, Show, Generic)++instance FromJSON Application+instance ToJSON Application++data Prereqs+    = Prereqs+    { prereq_member_packages :: [Text]+    , prereq_bouncer_packages :: [Text]+    -- ^ Debian packages, installed only if missing. Empty for machines+    -- whose packages are somebody else's (an image, another recipe).+    , prereq_repl_passfile :: SecretFile+    -- ^ becomes 'pair_repl_passfile', on both members.+    , prereq_rewind_passfile :: SecretFile+    -- ^ becomes 'pair_rewind_passfile', on both members.+    , prereq_console_passfile :: SecretFile+    -- ^ becomes 'bouncer_console_passfile', on every bouncer.+    , prereq_userlist :: SecretFile+    -- ^ becomes @userlist.txt@ in 'bouncer_config_dir', on every bouncer: a+    -- file already in pgbouncer's @auth_file@ format, whatever hashing its+    -- author chose. Left in place ('secret_from' @= Nothing@) nothing can+    -- tell that it changed, so nothing restarts pgbouncer: whoever writes+    -- it there owns that.+    , prereq_applications :: [Application]+    }+    deriving (Eq, Show, Generic)++instance FromJSON Prereqs+instance ToJSON Prereqs++{- | Debian's packages, every secret left in place, and no application: the+smallest thing to amend.+-}+defaultPrereqs :: Prereqs+defaultPrereqs =+    Prereqs+        { prereq_member_packages = ["postgresql", "sudo"]+        , prereq_bouncer_packages = ["pgbouncer", "postgresql-client"]+        , prereq_repl_passfile = inPlace+        , prereq_rewind_passfile = inPlace+        , prereq_console_passfile = inPlace+        , -- pgbouncer runs as postgres on Debian, and nobody else needs it+          prereq_userlist = SecretFile Nothing "postgres" "postgres" "0640"+        , prereq_applications = []+        }++{- | Everything wrong with a declaration, not the first thing.++These values are spliced into shell scripts and SQL run as root on three+machines, so what is checked is that each is the kind of word it claims to+be. A node whose declaration does not pass refuses to run and says all of+this; a binary can ask earlier, where the directive is built.+-}+validate :: Pair -> Prereqs -> [Text]+validate pair pre =+    concat+        [ concatMap (package "member") pre.prereq_member_packages+        , concatMap (package "bouncer") pre.prereq_bouncer_packages+        , secret "replication passfile" pre.prereq_repl_passfile+        , secret "rewind passfile" pre.prereq_rewind_passfile+        , secret "console passfile" pre.prereq_console_passfile+        , secret "userlist" pre.prereq_userlist+        , concatMap application pre.prereq_applications+        ]+  where+    package whose p =+        [ whose <> " package " <> quoted p <> " is not a Debian package name"+        | not (packageName p)+        ]+    secret :: Text -> SecretFile -> [Text]+    secret what s =+        concat+            [ [what <> ": " <> quoted (Text.pack from) <> " is not an absolute path" | Just from <- [s.secret_from], not (plainPath from)]+            , [what <> ": owner " <> quoted s.secret_owner <> " is not a user name" | not (accountName s.secret_owner)]+            , [what <> ": group " <> quoted s.secret_group <> " is not a group name" | not (accountName s.secret_group)]+            , [what <> ": mode " <> quoted s.secret_mode <> " is not an octal mode" | not (octalMode s.secret_mode)]+            ]+    application :: Application -> [Text]+    application app =+        concat+            [ [who <> ": role " <> quoted app.app_role <> " is not a plain identifier" | not (identifier app.app_role)]+            , [who <> ": database " <> quoted app.app_database <> " is not a plain identifier" | not (identifier app.app_database)]+            , [ who <> ": role " <> quoted app.app_role <> " is the pair's own, whose password and attributes the pair sets"+              | app.app_role `elem` [pair.pair_repl_role, pair.pair_rewind_role]+              ]+            , [who <> ": passfile " <> quoted (Text.pack app.app_passfile) <> " is not an absolute path" | not (plainPath app.app_passfile)]+            , [who <> ": client " <> quoted c <> " is not an address" | c <- app.app_clients, not (address c)]+            , [ who <> ": " <> quoted app.app_hba_method <> " is not md5 or scram-sha-256"+              | app.app_hba_method `notElem` ["md5", "scram-sha-256"]+              ]+            ]+      where+        who = "application " <> quoted app.app_role++    quoted t = "\"" <> t <> "\""++    identifier t =+        not (Text.null t)+            && Text.length t <= 63+            && Text.all (\c -> isAsciiLower c || isDigit c || c == '_') t+            && not (isDigit (Text.head t))+    accountName t =+        not (Text.null t)+            && Text.all (\c -> isAsciiLower c || isDigit c || c `elem` ("_-" :: String)) t+            && not (Text.head t == '-')+    packageName t =+        not (Text.null t)+            && Text.all (\c -> isAsciiLower c || isDigit c || c `elem` ("+.-" :: String)) t+            && (isAsciiLower (Text.head t) || isDigit (Text.head t))+    octalMode t = Text.length t `elem` [3, 4] && Text.all isOctDigit t+    plainPath p = take 1 p == "/" && all (`notElem` ("\n\r" :: String)) p+    address t =+        not (Text.null t)+            && Text.all (\c -> isAsciiLower c || isDigit c || c `elem` ("ABCDEF.:/" :: String)) t++-------------------------------------------------------------------------------+-- The scripts++{- | The script 'memberPrereqs' runs: packages, the cluster the pair names,+and the two passfiles.+-}+memberPrereqsScript :: Pair -> Prereqs -> Side -> String+memberPrereqsScript pair pre side =+    unlines $+        ["set -e"]+            <> packagesFragment pre.prereq_member_packages+            <> [ -- the pair's every script starts by finding this cluster's+                 -- version, and an empty answer there reads as a path with a+                 -- hole in it; here it reads as what it is.+                 "pg_lsclusters --no-header | awk -v c=" <> shQuote cluster <> " '$2==c' | grep -q . || { echo "+                    <> shQuote ("no Postgres cluster named " <> cluster <> " on this machine")+                    <> " >&2; exit 1; }"+               ]+            <> installFragment pre.prereq_repl_passfile pair.pair_repl_passfile+            <> installFragment pre.prereq_rewind_passfile pair.pair_rewind_passfile+  where+    cluster = Text.unpack (memberOn pair side).member_cluster++{- | The script 'bouncerPrereqs' runs: packages, the console passfile, and+the auth file.++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. Hence the restart; and hence only when the file changed,+because on every later pass a restart would drop the very clients the+bouncer is there to hold. @try-restart@, so that a bouncer that is not+running yet is left for the pair's own node to start, on its own ini.+-}+bouncerPrereqsScript :: Prereqs -> Bouncer -> String+bouncerPrereqsScript pre b =+    unlines $+        ["set -e"]+            <> packagesFragment pre.prereq_bouncer_packages+            <> installFragment pre.prereq_console_passfile b.bouncer_console_passfile+            <> ["salmon_changed=0"]+            <> installFragment pre.prereq_userlist (b.bouncer_config_dir </> "userlist.txt")+            <> [ "if [ \"$salmon_changed\" = 1 ]; then systemctl try-restart pgbouncer; fi"+               ]++{- | Installs one pre-provisioned file where the pair reads it.++Compared before it is copied, so an unchanged file is not rewritten (and+@salmon_changed@, which the auth file's restart reads, stays as it was);+owner and mode are set either way, since they are sets rather than inserts.+What it says on failure is the file's /name/.+-}+installFragment :: SecretFile -> FilePath -> [String]+installFragment s dest =+    case s.secret_from of+        Just from+            | from /= dest ->+                [ "[ -r " <> shQuote from <> " ] || { echo " <> shQuote ("pre-provisioned file missing or unreadable: " <> from) <> " >&2; exit 1; }"+                , "mkdir -p " <> shQuote (takeDirectory dest)+                , "if ! cmp -s " <> shQuote from <> " " <> shQuote dest <> "; then"+                , "  install -m " <> mode <> " -o " <> owner <> " -g " <> group <> " " <> shQuote from <> " " <> shQuote dest+                , "  salmon_changed=1"+                , "fi"+                ]+                    <> hold+        _ ->+            ["[ -e " <> shQuote dest <> " ] || { echo " <> shQuote ("pre-provisioned file missing: " <> dest) <> " >&2; exit 1; }"]+                <> hold+  where+    owner = shQuote (Text.unpack s.secret_owner)+    group = shQuote (Text.unpack s.secret_group)+    mode = shQuote (Text.unpack s.secret_mode)+    hold =+        [ "chown " <> shQuote (Text.unpack (s.secret_owner <> ":" <> s.secret_group)) <> " " <> shQuote dest+        , "chmod " <> mode <> " " <> shQuote dest+        ]++{- | Installs what is missing and nothing else: a machine whose packages are+all there -- baked into an image, say, with no route to a mirror -- never+reaches @apt-get@.+-}+packagesFragment :: [Text] -> [String]+packagesFragment [] = []+packagesFragment packages =+    [ "salmon_missing=''"+    , "for p in " <> unwords (map (shQuote . Text.unpack) packages) <> "; do"+    , "  dpkg-query -W -f='${Status}' \"$p\" 2>/dev/null | grep -q 'install ok installed' || salmon_missing=\"$salmon_missing $p\""+    , "done"+    , "if [ -n \"$salmon_missing\" ]; then DEBIAN_FRONTEND=noninteractive apt-get install -y $salmon_missing; fi"+    ]++-- | The @pg_hba.conf@ lines the applications need, on either member.+hbaLines :: Prereqs -> [Text]+hbaLines pre =+    [ Text.unwords ["host", app.app_database, app.app_role, cidr client, app.app_hba_method]+    | app <- pre.prereq_applications+    , client <- app.app_clients+    ]+  where+    cidr c+        | "/" `Text.isInfixOf` c = c+        | ":" `Text.isInfixOf` c = c <> "/128"+        | otherwise = c <> "/32"++{- | The script 'applications' runs on a member.++The @pg_hba.conf@ lines go on whichever half this is, because that file+lives outside the data directory and reaches the other machine through+nothing. Roles and databases are catalog rows and do reach it, through the+WAL, so only a primary makes them -- the same rule as the pair's own roles.++The password is read here, from the file the declaration names, with its+quotes doubled, and reaches @psql@ on standard input: never an argument,+which is in @ps@. That one statement's output is withheld, because psql+quotes the line it failed on and this is the line with the password in it;+the failure is reported in words instead.+-}+applicationsScript :: Pair -> Prereqs -> Side -> String+applicationsScript pair pre side =+    unlines $+        [ "set -e"+        , "version=$(pg_lsclusters --no-header | awk -v c=" <> shQuote cluster <> " '$2==c {print $1}' | head -n1)"+        , "[ -n \"$version\" ] || { echo " <> shQuote ("no Postgres cluster named " <> cluster <> " on this machine") <> " >&2; exit 1; }"+        , "hba=/etc/postgresql/$version/" <> cluster <> "/pg_hba.conf"+        ]+            <> map hbaLine (hbaLines pre)+            <> [ psql "SELECT pg_reload_conf()" <> " >/dev/null"+               , "if [ \"$(" <> psql "SELECT pg_is_in_recovery()" <> ")\" = f ]; then"+               ]+            <> concatMap (map ("  " <>) . application) pre.prereq_applications+            <> [ "  :"+               , "fi"+               ]+  where+    m = memberOn pair side+    cluster = Text.unpack m.member_cluster+    port = show m.member_port++    hbaLine l = "grep -qxF " <> shQuote (Text.unpack l) <> " \"$hba\" || echo " <> shQuote (Text.unpack l) <> " >> \"$hba\""++    psqlBase = "sudo -u postgres psql -p " <> port <> " -tAX -v ON_ERROR_STOP=1 -d postgres"+    psql sql = psqlBase <> " -c " <> shQuote sql++    application :: Application -> [String]+    application app =+        [ "[ -r " <> shQuote app.app_passfile <> " ] || { echo " <> shQuote ("pre-provisioned file missing or unreadable: " <> app.app_passfile) <> " >&2; exit 1; }"+        , "salmon_pw=$(awk -F: 'NR==1 {print $5}' " <> shQuote app.app_passfile <> " | sed \"s/'/''/g\")"+        , "[ -n \"$salmon_pw\" ] || { echo " <> shQuote ("no password on the first line of " <> app.app_passfile) <> " >&2; exit 1; }"+        , psql ("DO $do$ BEGIN CREATE ROLE " <> role <> " LOGIN; EXCEPTION WHEN duplicate_object THEN NULL; END $do$") <> " >/dev/null"+        , -- created if missing and its password set either way, so that+          -- rotating the passfile is enough to rotate the role. The heredoc's+          -- delimiter is unquoted on purpose: the shell substitutes the+          -- password it just read.+          psqlBase+            <> " >/dev/null 2>&1 <<SALMON_APP_SQL || { echo "+            <> shQuote ("could not set the password of role " <> role <> " (psql's output is withheld: it quotes the statement)")+            <> " >&2; exit 1; }\nALTER ROLE "+            <> role+            <> " LOGIN PASSWORD '$salmon_pw';\nSALMON_APP_SQL"+        , "unset salmon_pw"+        , -- CREATE DATABASE runs in no transaction and has no IF NOT EXISTS+          psql ("SELECT 1 FROM pg_database WHERE datname = '" <> db <> "'")+            <> " | grep -q 1 || "+            <> psql ("CREATE DATABASE " <> db <> " OWNER " <> role)+            <> " >/dev/null"+        ]+      where+        role = Text.unpack app.app_role+        db = Text.unpack app.app_database++shQuote :: String -> String+shQuote s = "'" <> concatMap (\c -> if c == '\'' then "'\\''" else [c]) s <> "'"++-------------------------------------------------------------------------------+-- The nodes++{- | What a machine needs before it can be a member: the packages, a cluster+of the declared name, and the two passfiles where the pair reads them.++Like the pair's own member node it says nothing about which half this is,+and it has no @check@: everything it does is compare-then-set, and asking a+machine whether all of it holds costs the round trip that doing it does.+-}+memberPrereqs :: Reporter Pair.Report -> Pair -> Prereqs -> Side -> Op+memberPrereqs r pair pre side =+    op "pg-pair-member-prereqs" nodeps $ \actions ->+        actions+            { ref = mkRef "pg-pair-member-prereqs" (pair.pair_name <> "@" <> m.member_host)+            , help = Text.unwords ["what", m.member_host, "needs to be a member of", pair.pair_name]+            , notes =+                [ "packages: " <> packagesNote pre.prereq_member_packages+                , secretNote "replication passfile" pre.prereq_repl_passfile pair.pair_repl_passfile+                , secretNote "rewind passfile" pre.prereq_rewind_passfile pair.pair_rewind_passfile+                ]+            , up = runOn r pair pre (OnMember m) m.member_host (memberPrereqsScript pair pre side)+            }+  where+    m = memberOn pair side++{- | What a machine needs before it can be this pair's bouncer: the+packages, the console passfile, and the auth file -- see+'bouncerPrereqsScript' for when pgbouncer is restarted and when not.+-}+bouncerPrereqs :: Reporter Pair.Report -> Pair -> Prereqs -> Bouncer -> Op+bouncerPrereqs r pair pre b =+    op "pg-pair-bouncer-prereqs" nodeps $ \actions ->+        actions+            { ref = mkRef "pg-pair-bouncer-prereqs" (pair.pair_name <> "@" <> b.bouncer_ssh_host)+            , help = Text.unwords ["what", b.bouncer_name, "needs to be a bouncer of", pair.pair_name]+            , notes =+                [ "packages: " <> packagesNote pre.prereq_bouncer_packages+                , secretNote "console passfile" pre.prereq_console_passfile b.bouncer_console_passfile+                , secretNote "auth file" pre.prereq_userlist (b.bouncer_config_dir </> "userlist.txt")+                , "pgbouncer is restarted only when the auth file changed"+                ]+            , up = runOn r pair pre (OnBouncer b) b.bouncer_name (bouncerPrereqsScript pre b)+            }++{- | The applications' roles, databases and @pg_hba.conf@ lines, on one+member. Declared for both: the lines are per machine, and the rest is done+by whichever is the primary when the node runs.+-}+applications :: Reporter Pair.Report -> Pair -> Prereqs -> Side -> Op+applications r pair pre side =+    op "pg-pair-applications" nodeps $ \actions ->+        actions+            { ref = mkRef "pg-pair-applications" (pair.pair_name <> "@" <> m.member_host)+            , help = Text.unwords ["applications of", pair.pair_name, "on", m.member_host]+            , notes =+                [ Text.unwords+                    [ "role"+                    , app.app_role+                    , "owns database"+                    , app.app_database <> ","+                    , "password from"+                    , Text.pack app.app_passfile <> ","+                    , "reached from"+                    , if null app.app_clients then "nowhere" else Text.intercalate ", " app.app_clients+                    ]+                | app <- pre.prereq_applications+                ]+            , up = runOn r pair pre (OnMember m) m.member_host (applicationsScript pair pre side)+            }+  where+    m = memberOn pair side++packagesNote :: [Text] -> Text+packagesNote [] = "none (somebody else's)"+packagesNote ps = Text.unwords ps++-- | Paths, owner and mode: what a reader of @run tree@ may know of a secret.+secretNote :: Text -> SecretFile -> FilePath -> Text+secretNote what s dest =+    Text.unwords+        [ what+        , Text.pack dest+        , s.secret_owner <> ":" <> s.secret_group+        , s.secret_mode <> ","+        , case s.secret_from of+            Just from | from /= dest -> "installed from " <> Text.pack from+            _ -> "provisioned in place"+        ]++runOn :: Reporter Pair.Report -> Pair -> Prereqs -> Target -> Text -> String -> IO ()+runOn r pair pre target name script = do+    let refusals = validate pair pre+    unless (null refusals) $+        throwIO (userError (Text.unpack ("prerequisites of " <> pair.pair_name <> ": " <> Text.intercalate "; " refusals)))+    (code, out, err) <- Pair.sshToTarget pair target script+    runReporter r (Pair.Acted name code (Text.strip (out <> err)))+    case code of+        ExitSuccess -> pure ()+        ExitFailure _ ->+            throwIO (userError (Text.unpack ("prerequisites on " <> name <> ": " <> Text.strip (err <> out))))++{- | The pair, and everything it assumed.++The edges are the point, and there are three kinds. A machine's+prerequisites come before the pair's own node for that machine -- declared+by naming that node again with one more dependency, which the walk merges+with the pair's own declaration of it, since they are the same node. The+applications come after 'Pair.pairOp', so after the role node. And nothing+else is ordered: one member's packages do not wait for the other's.+-}+pairWithPrereqs :: Reporter Pair.Report -> Pair -> Prereqs -> Op+pairWithPrereqs r pair pre =+    op "pg-pair-with-prereqs" (deps (apps <> [whole] <> machines)) $ \actions ->+        actions+            { ref = mkRef "pg-pair-with-prereqs" pair.pair_name+            , help = Text.unwords ["the pair", pair.pair_name, "and what it needs first"]+            }+  where+    whole = Pair.pairOp r pair+    machines =+        [Pair.member r pair side `inject` memberPrereqs r pair pre side | side <- [A, B]]+            <> [Pair.bouncerSetup r pair b `inject` bouncerPrereqs r pair pre b | b <- pair.pair_bouncers]+    apps+        | null pre.prereq_applications = []+        | otherwise = [applications r pair pre side `inject` whole | side <- [A, B]]

@@ -157,9 +157,14 @@             client.ca_cidr             `inject` tls +    -- The material goes under the settings and the reload themselves:+    -- @pg-server-tls@ has no effect of its own, and injected onto it alone+    -- the material was their sibling, so @ssl = on@ and a reload could come+    -- before the key was in place. The injection onto it is kept, it+    -- leaves that node's edges as they were.     tls :: Op     tls =-        Postgres.serverTls rPg psql cfg.pgcc_port cfg.pgcc_tls+        Postgres.serverTlsAfter [ownedMaterial] rPg psql cfg.pgcc_port cfg.pgcc_tls             `inject` ownedMaterial      -- Postgres refuses to start with a group- or world-readable key, and

@@ -335,8 +335,15 @@                 ]             ) +    -- 'prest', the @migrate-remotely@ node and 'initDB' only group the+    -- nodes doing the work, and what is injected onto one of them is a+    -- sibling of that work: the order is said under the working nodes+    -- instead (the migration waits for the database and roles, the service+    -- for the migration). The injections onto the grouping nodes are kept;+    -- they leave those nodes' edges as they were.     migrateDBWithUser =-        PGMigrate.remoteMigrateOpaqueSetup+        PGMigrate.remoteMigrateOpaqueSetupAfter+            [initDB]             cfg.pma_serviceName             (contramap Migration r)             simulate@@ -352,7 +359,7 @@                 []             ) -    prest = op "postgrest" (deps [setupPrest]) $ \actions ->+    prest = op "postgrest" (deps [setupPrest `inject` migrateDBWithUser]) $ \actions ->         actions             { ref = mkRef "prest-service" cfg.pma_serviceName             }

@@ -0,0 +1,561 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++{- | A WireGuard mesh among hosts that have stable endpoints, declared once and+unfolded per host. See @specs\/wireguard-mesh.md@ for the whole design.++= Shape++The /seed/ ('MeshSeed') is the one declaration: peers (a declared address, a+public key collected out of band, an optional endpoint, groups), policies+(group to group, protocol, ports) and routers (a peer that also carries a+network, or the default route). 'genHost' is a __pure__ fan-out of that seed+to one host's view ('HostSpec'): its interface, its peers with their+allowed-ips, its routes and its nft rules. 'hostOp' turns a 'HostSpec' into+an 'Op'. Nothing in between touches the network or the filesystem, so the+table of seeds to host specs is a Layer 0 test.++= Delivery++'hostDocument' wraps a host's 'HostSpec' as a pull-mode document (one inline+directive), to be signed and published under a label named for the host and+followed with @run serve --follow ... --label HOST@. A peer added to or+removed from the seed is then a small diff of nodes the ledger brings up and+down, which is why "Salmon.Builtin.Nodes.WireGuard"'s @peer@ has a @down@.++= What this recipe does not do++* It ships no secret. Each host generates its own private key where it is+  (@WG.privateKey@, kept, never sent); a public key is not a secret and is+  carried inline in the seed.+* A peer with no endpoint dials out and sets a persistent keepalive; it is+  reached only through peers that have one. Two peers that both lack an+  endpoint have no link. There is no NAT traversal and no roaming.+* An endpoint given as a host name is resolved by WireGuard when the peer is+  configured. Following a changed address is left to the peer node's+  @check@ and the tending loop, not done here.+* Policies are enforced on the input of the mesh interface (traffic addressed+  to the host). Traffic a router forwards between the mesh and elsewhere is+  governed by the router's forward chain (mesh-interface traffic only), not+  by policies.+* IPv4 only. An exit router's endpoint must be an IPv4 literal, because the+  route pinning it off the tunnel needs an address, not a name.+-}+module SreBox.WireGuardMesh (+    -- * The declaration+    MeshSeed (..),+    PeerDecl (..),+    Policy (..),+    Proto (..),+    PortRange (..),+    RouterDecl (..),++    -- * The per-host view+    HostSpec (..),+    PeerLink (..),+    NftRuleSpec (..),+    MeshError (..),+    renderError,+    validate,+    genHost,+    genAll,++    -- * Delivery+    hostDocument,++    -- * The node+    hostOp,+    Report,+    Binaries (..),++    -- * Exposed for tests+    parseIpv4,+    parseCidr,+    inSubnet,+) where++import Data.Aeson (FromJSON, ToJSON, toJSON)+import Data.Bits (complement, shiftL, (.&.), (.|.))+import Data.List (nub, sort)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Word (Word32)+import GHC.Generics (Generic)+import Text.Read (readMaybe)++import Salmon.Actions.Follow (Document (..), Entry (..))+import Salmon.Builtin.Extension+import qualified Salmon.Builtin.Nodes.Netfilter as Nft+import qualified Salmon.Builtin.Nodes.Routes as IpRoute+import qualified Salmon.Builtin.Nodes.Sysctl as Sysctl+import qualified Salmon.Builtin.Nodes.WireGuard as WG+import Salmon.Op.OpGraph (inject)+import Salmon.Op.Track+import Salmon.Reporter++import SreBox.WireGuardVpn (Binaries (..), Report (..), pinHostRoute)++-------------------------------------------------------------------------------+-- the declaration++data MeshSeed = MeshSeed+    { mesh_subnet :: Text+    -- ^ the mesh's network, e.g. @10.66.0.0/24@+    , mesh_iface :: Text+    , mesh_port :: Int+    -- ^ the UDP port every host listens on+    , mesh_privkey_path :: FilePath+    -- ^ where each host keeps (and, if absent, generates) its private key+    , mesh_peers :: [PeerDecl]+    , mesh_policies :: [Policy]+    , mesh_routers :: [RouterDecl]+    }+    deriving (Eq, Show, Generic)++instance FromJSON MeshSeed+instance ToJSON MeshSeed++data PeerDecl = PeerDecl+    { peer_name :: Text+    , peer_addr :: Text+    -- ^ a bare IPv4 address inside the subnet, declared and never derived from+    -- position, so adding or removing a peer renumbers nobody+    , peer_pubkey :: Text+    -- ^ base64, collected out of band+    , peer_endpoint :: Maybe Text+    -- ^ @host:port@, host a literal or a name+    , peer_groups :: [Text]+    }+    deriving (Eq, Show, Generic)++instance FromJSON PeerDecl+instance ToJSON PeerDecl++data Proto = Tcp | Udp | Icmp | AnyProto+    deriving (Eq, Show, Generic)++instance FromJSON Proto+instance ToJSON Proto++data PortRange = PortRange {port_from :: Int, port_to :: Int}+    deriving (Eq, Show, Generic)++instance FromJSON PortRange+instance ToJSON PortRange++data Policy = Policy+    { policy_from :: [Text]+    -- ^ groups+    , policy_to :: [Text]+    -- ^ groups+    , policy_protocol :: Proto+    , policy_ports :: [PortRange]+    -- ^ only for 'Tcp' and 'Udp'; none means every port+    }+    deriving (Eq, Show, Generic)++instance FromJSON Policy+instance ToJSON Policy++{- | A peer that also reaches a network. @0.0.0.0/0@ makes it the mesh's exit+node; at most one router may be that.+-}+data RouterDecl = RouterDecl+    { router_peer :: Text+    , router_network :: Text+    }+    deriving (Eq, Show, Generic)++instance FromJSON RouterDecl+instance ToJSON RouterDecl++-------------------------------------------------------------------------------+-- the per-host view++-- | One peer as a host configures it.+data PeerLink = PeerLink+    { link_name :: Text+    , link_pubkey :: Text+    , link_endpoint :: Maybe Text+    , link_allowed_ips :: [Text]+    , link_keepalive :: Maybe Int+    }+    deriving (Eq, Show, Generic)++instance FromJSON PeerLink+instance ToJSON PeerLink++-- | A rule in the host's mesh input chain, as the words handed to @nft@.+newtype NftRuleSpec = NftRuleSpec {rule_words :: [Text]}+    deriving (Eq, Show, Generic)++instance FromJSON NftRuleSpec+instance ToJSON NftRuleSpec++data HostSpec = HostSpec+    { host_name :: Text+    , host_iface :: Text+    , host_addr :: Text+    -- ^ CIDR, the host's address with the mesh's prefix length+    , host_port :: Int+    , host_privkey_path :: FilePath+    , host_peers :: [PeerLink]+    , host_routes :: [Text]+    -- ^ networks to send over the interface (besides the mesh itself)+    , host_exit_pins :: [Text]+    -- ^ addresses kept off the tunnel (the endpoints of exit routers)+    , host_forwards :: Maybe Text+    -- ^ for a router, the mesh subnet it masquerades when it leaves elsewhere+    , host_input_rules :: [NftRuleSpec]+    -- ^ accepted traffic on the mesh interface, in order, after+    -- established/related and before the final drop+    }+    deriving (Eq, Show, Generic)++instance FromJSON HostSpec+instance ToJSON HostSpec++data MeshError+    = BadSubnet Text+    | BadAddress Text Text+    | AddressOutsideSubnet Text Text+    | DuplicatePeerName Text+    | DuplicateAddress Text [Text]+    | DuplicatePubkey [Text]+    | BadEndpoint Text Text+    | UnknownGroup Int Text+    | BadPorts Int Text+    | UnknownRouterPeer Text+    | BadNetwork Text Text+    | DuplicateRouterNetwork Text+    | SeveralExitRouters [Text]+    | ExitEndpointNotLiteral Text+    | UnknownHost Text+    deriving (Eq, Show)++renderError :: MeshError -> Text+renderError e = case e of+    BadSubnet s -> "mesh subnet is not an IPv4 CIDR: " <> s+    BadAddress p a -> "peer " <> p <> " has an address that is not IPv4: " <> a+    AddressOutsideSubnet p a -> "peer " <> p <> " has address " <> a <> " outside the mesh subnet"+    DuplicatePeerName p -> "two peers are named " <> p+    DuplicateAddress a ps -> "address " <> a <> " is declared by several peers: " <> Text.intercalate ", " ps+    DuplicatePubkey ps -> "peers share one public key: " <> Text.intercalate ", " ps+    BadEndpoint p ep -> "peer " <> p <> " has an endpoint that is not host:port: " <> ep+    UnknownGroup i g -> "policy #" <> tshow i <> " names a group no peer belongs to: " <> g+    BadPorts i why -> "policy #" <> tshow i <> ": " <> why+    UnknownRouterPeer p -> "router names an unknown peer: " <> p+    BadNetwork p n -> "router " <> p <> " has a network that is not an IPv4 CIDR: " <> n+    DuplicateRouterNetwork n -> "network " <> n <> " is carried by several routers"+    SeveralExitRouters ps -> "several peers are the exit node: " <> Text.intercalate ", " ps+    ExitEndpointNotLiteral p -> "exit router " <> p <> " needs an endpoint that is an IPv4 literal (its route is pinned by address)"+    UnknownHost h -> "no such peer in the seed: " <> h++tshow :: Show a => a -> Text+tshow = Text.pack . show++-------------------------------------------------------------------------------+-- pure IPv4++parseIpv4 :: Text -> Maybe Word32+parseIpv4 t = case traverse readOctet (Text.splitOn "." t) of+    Just [a, b, c, d] -> Just ((a `shiftL` 24) .|. (b `shiftL` 16) .|. (c `shiftL` 8) .|. d)+    _ -> Nothing+  where+    readOctet o+        | Text.null o || Text.any (`notElem` ['0' .. '9']) o || Text.length o > 3 = Nothing+        | otherwise = case readMaybe (Text.unpack o) :: Maybe Word32 of+            Just n | n <= 255 -> Just n+            _ -> Nothing++-- | An address and a prefix length.+parseCidr :: Text -> Maybe (Word32, Int)+parseCidr t = case Text.splitOn "/" t of+    [a, p] -> do+        addr <- parseIpv4 a+        n <- if Text.all (`elem` ['0' .. '9']) p && not (Text.null p) then readMaybe (Text.unpack p) else Nothing+        if n >= 0 && n <= 32 then Just (addr, n) else Nothing+    _ -> Nothing++mask :: Int -> Word32+mask 0 = 0+mask n = complement 0 `shiftL` (32 - n)++-- | Is the address inside the (address, prefix) network?+inSubnet :: (Word32, Int) -> Word32 -> Bool+inSubnet (net, n) a = (a .&. mask n) == (net .&. mask n)++-- | @host:port@ with a port in range.+parseEndpoint :: Text -> Maybe (Text, Int)+parseEndpoint t =+    let (h, rest) = Text.breakOnEnd ":" t+        host = Text.dropEnd 1 h+     in do+            port <- if Text.all (`elem` ['0' .. '9']) rest && not (Text.null rest) then readMaybe (Text.unpack rest) else Nothing+            if not (Text.null host) && port >= 1 && port <= 65535 then Just (host, port) else Nothing++-------------------------------------------------------------------------------+-- validation++duplicates :: Ord a => [a] -> [a]+duplicates xs = Map.keys (Map.filter (> (1 :: Int)) (Map.fromListWith (+) [(x, 1) | x <- xs]))++-- | Every refusal at once; empty when the seed is sound.+validate :: MeshSeed -> [MeshError]+validate s = subnetErrs <> nameErrs <> addrErrs <> keyErrs <> endpointErrs <> policyErrs <> routerErrs+  where+    peers = s.mesh_peers+    msubnet = parseCidr s.mesh_subnet+    subnetErrs = [BadSubnet s.mesh_subnet | Nothing <- [msubnet]]+    nameErrs = DuplicatePeerName <$> duplicates (peer_name <$> peers)+    addrErrs =+        concat+            [ case parseIpv4 p.peer_addr of+                Nothing -> [BadAddress p.peer_name p.peer_addr]+                Just a -> [AddressOutsideSubnet p.peer_name p.peer_addr | Just net <- [msubnet], not (inSubnet net a)]+            | p <- peers+            ]+            <> [DuplicateAddress a [p.peer_name | p <- peers, p.peer_addr == a] | a <- duplicates (peer_addr <$> peers)]+    keyErrs = [DuplicatePubkey [p.peer_name | p <- peers, p.peer_pubkey == k] | k <- duplicates (peer_pubkey <$> peers)]+    endpointErrs = [BadEndpoint p.peer_name ep | p <- peers, Just ep <- [p.peer_endpoint], Nothing <- [parseEndpoint ep]]+    groups = nub (concatMap peer_groups peers)+    policyErrs =+        concat+            [ [UnknownGroup i g | g <- pol.policy_from <> pol.policy_to, g `notElem` groups]+                <> portErrs i pol+            | (i, pol) <- zip [1 ..] s.mesh_policies+            ]+    portErrs i pol =+        [BadPorts i "ports given for a protocol without ports" | pol.policy_protocol `elem` [Icmp, AnyProto], not (null pol.policy_ports)]+            <> [ BadPorts i ("bad port range " <> tshow lo <> "-" <> tshow hi)+               | PortRange lo hi <- pol.policy_ports+               , lo < 1 || hi > 65535 || lo > hi+               ]+            <> [BadPorts i "a policy needs at least one group on each side" | null pol.policy_from || null pol.policy_to]+    routerErrs =+        concat+            [ [UnknownRouterPeer r.router_peer | r.router_peer `notElem` (peer_name <$> peers)]+                <> [BadNetwork r.router_peer r.router_network | Nothing <- [parseCidr r.router_network]]+            | r <- s.mesh_routers+            ]+            <> (DuplicateRouterNetwork <$> duplicates (router_network <$> s.mesh_routers))+            <> [SeveralExitRouters exits | let exits = [r.router_peer | r <- s.mesh_routers, isExit r.router_network], length exits > 1]+            <> [ ExitEndpointNotLiteral r.router_peer+               | r <- s.mesh_routers+               , isExit r.router_network+               , Just p <- [lookupPeer r.router_peer]+               , not (maybe False (isLiteral . fst) (p.peer_endpoint >>= parseEndpoint))+               ]+    lookupPeer n = case [p | p <- peers, p.peer_name == n] of (p : _) -> Just p; [] -> Nothing+    isLiteral h = parseIpv4 h /= Nothing++isExit :: Text -> Bool+isExit n = n == "0.0.0.0/0"++-------------------------------------------------------------------------------+-- fan-out++-- | The view of every host, or every refusal.+genAll :: MeshSeed -> Either [MeshError] [HostSpec]+genAll s = case validate s of+    [] -> Right [genChecked s p | p <- s.mesh_peers]+    errs -> Left errs++-- | One host's view, or every refusal (an unknown host included).+genHost :: MeshSeed -> Text -> Either [MeshError] HostSpec+genHost s name = case validate s of+    [] -> case [p | p <- s.mesh_peers, p.peer_name == name] of+        (p : _) -> Right (genChecked s p)+        [] -> Left [UnknownHost name]+    errs -> Left errs++-- | Fan-out for a seed already validated.+genChecked :: MeshSeed -> PeerDecl -> HostSpec+genChecked s me =+    HostSpec+        { host_name = me.peer_name+        , host_iface = s.mesh_iface+        , host_addr = me.peer_addr <> "/" <> prefixLen+        , host_port = s.mesh_port+        , host_privkey_path = s.mesh_privkey_path+        , host_peers = links+        , host_routes = routes+        , host_exit_pins = pins+        , host_forwards = if myRouters /= [] then Just s.mesh_subnet else Nothing+        , host_input_rules = inputRules+        }+  where+    prefixLen = maybe "32" (tshow . snd) (parseCidr s.mesh_subnet)+    others = [p | p <- s.mesh_peers, p.peer_name /= me.peer_name]+    routerNets p = [r.router_network | r <- s.mesh_routers, r.router_peer == p.peer_name]+    myRouters = routerNets me++    -- a link exists when at least one side has an endpoint to dial+    linked p = me.peer_endpoint /= Nothing || p.peer_endpoint /= Nothing+    links =+        [ PeerLink+            { link_name = p.peer_name+            , link_pubkey = p.peer_pubkey+            , link_endpoint = p.peer_endpoint+            , link_allowed_ips = (p.peer_addr <> "/32") : routerNets p+            , -- whoever has no endpoint is the one dialling, and keeps the path open+              link_keepalive = if me.peer_endpoint == Nothing then Just 25 else Nothing+            }+        | p <- others+        , linked p+        ]++    reachedRouters = [(p, n) | l <- links, Just p <- [byName l.link_name], n <- routerNets p]+    byName n = case [p | p <- s.mesh_peers, p.peer_name == n] of (p : _) -> Just p; [] -> Nothing+    routes =+        concat+            [ if isExit n then ["0.0.0.0/1", "128.0.0.0/1"] else [n]+            | (_, n) <- reachedRouters+            ]+    pins = [h | (p, n) <- reachedRouters, isExit n, Just (h, _) <- [p.peer_endpoint >>= parseEndpoint]]++    -- policies whose destination includes this host+    inputRules =+        [ NftRuleSpec (policyWords srcs pol)+        | pol <- s.mesh_policies+        , any (`elem` me.peer_groups) pol.policy_to+        , let srcs = sort (nub [p.peer_addr | p <- s.mesh_peers, any (`elem` p.peer_groups) pol.policy_from])+        ]++    ifaceQuoted = "\"" <> s.mesh_iface <> "\""+    policyWords srcs pol =+        ["iifname", ifaceQuoted, "ip", "saddr", set srcs]+            <> protoWords pol++    protoWords pol = case pol.policy_protocol of+        AnyProto -> ["accept"]+        Icmp -> ["ip", "protocol", "icmp", "accept"]+        Tcp -> portWords "tcp" pol.policy_ports+        Udp -> portWords "udp" pol.policy_ports+    portWords proto [] = ["meta", "l4proto", proto, "accept"]+    portWords proto ranges = [proto, "dport", set (renderRange <$> ranges), "accept"]+    renderRange (PortRange lo hi) = if lo == hi then tshow lo else tshow lo <> "-" <> tshow hi++    -- nft prints a one-element set without braces, and the rule's check+    -- matches the rendered text, so render it the way nft lists it+    set [x] = x+    set xs = "{ " <> Text.intercalate ", " xs <> " }"++-------------------------------------------------------------------------------+-- delivery++{- | A host's pull-mode document: one inline directive. @docid@ is the+publisher's name for this revision (it is what @history@ records).+-}+hostDocument :: Text -> HostSpec -> Document+hostDocument docid h = Document{docId = docid, docSeeds = [SeedDirective (toJSON h)], docPublished = Nothing}++-------------------------------------------------------------------------------+-- the node++{- | The Op for one host: the interface with its private key (generated here+if absent, never sent anywhere), the peers, the routes, and the forwarding+and nft rules the 'HostSpec' asks for.+-}+hostOp :: Reporter Report -> Binaries -> HostSpec -> Op+hostOp r bins h =+    op "wireguard-mesh-host" (deps [routing, forwarding, filtering]) $ \actions ->+        actions{help = "wireguard mesh host " <> h.host_name}+  where+    wg_r = contramap RunWireGuard r+    nft_r = contramap RunNft r+    sysctl_r = contramap RunSysctl r+    ip_r = contramap RunIpRoute r++    (_, plen) = fromMaybe (0, 32) (parseCidr h.host_addr)+    netCidr = WG.Ipv4Cidr (Text.takeWhile (/= '/') h.host_addr) plen++    ifaceTrack :: Track' WG.WgName+    ifaceTrack = Track $ \name -> WG.iface wg_r bins.binIp name netCidr++    privkeyTrack :: Track' FilePath+    privkeyTrack = Track $ WG.privateKey bins.binWg++    serverIface :: Op+    serverIface = WG.server wg_r bins.binWg privkeyTrack ifaceTrack h.host_iface h.host_privkey_path h.host_port++    peerOp :: PeerLink -> Op+    peerOp l =+        WG.peerWith+            wg_r+            bins.binWg+            ifaceTrack+            ignoreTrack+            h.host_iface+            (WG.PeerKeyValue l.link_pubkey)+            l.link_endpoint+            (Text.intercalate "," l.link_allowed_ips)+            l.link_keepalive++    -- Each peer is injected the interface's key and port, not only the+    -- grouping node: that one has no effect, and what is injected onto it+    -- alone is a sibling of the peers, not something they wait for.+    peers :: Op+    peers = op "wireguard-mesh-peers" (deps ((`inject` serverIface) . peerOp <$> h.host_peers)) id `inject` serverIface++    pinOps = [pinHostRoute ip_r bins a `inject` peers | a <- h.host_exit_pins]++    -- every pin precedes every route, or the tunnel's own traffic loops+    routing :: Op+    routing =+        op "wireguard-mesh-routes" (deps routeOps) id+            `inject` peers+      where+        routeOps =+            [ foldl inject (IpRoute.route ip_r bins.binIp (IpRoute.Route (IpRoute.RawNetwork n) h.host_iface Nothing)) (peers : pinOps)+            | n <- h.host_routes+            ]++    table :: Nft.Table+    table = Nft.Table "filter" Nft.Inet++    forwarding :: Op+    forwarding = case h.host_forwards of+        Nothing -> noop "no forwarding"+        Just subnet ->+            Sysctl.set sysctl_r bins.binSysctl (Sysctl.Setting "net.ipv4.ip_forward" "1")+                `inject` forwardChain+                `inject` natRule subnet++    ifaceQuoted = "\"" <> h.host_iface <> "\""++    forwardChain :: Op+    forwardChain =+        Nft.rule nft_r bins.binNft fchain (Nft.RawRule ["ct", "state", "established,related", "accept"])+            `inject` Nft.rule nft_r bins.binNft fchain (Nft.RawRule ["iifname", ifaceQuoted, "accept"])+      where+        fchain = Nft.baseChain "forward" table (Nft.BaseChainSpec Nft.FilterChain Nft.Forward 0 Nft.Drop)++    natRule subnet =+        Nft.rule+            nft_r+            bins.binNft+            (Nft.baseChain "postrouting" (Nft.Table "nat" Nft.Inet) (Nft.BaseChainSpec Nft.NatChain Nft.PostRouting 100 Nft.Accept))+            (Nft.RawRule ["ip", "saddr", subnet, "oifname", "!=", ifaceQuoted, "masquerade"])++    -- an input chain of its own (policy accept: only the mesh interface is+    -- restricted, ssh and everything else is untouched): established, then one+    -- accept per policy, then drop whatever else arrives over the mesh+    filtering :: Op+    filtering = case h.host_input_rules of+        [] | null h.host_peers -> noop "no mesh filter"+        rules ->+            let rs =+                    [Nft.RawRule ["iifname", ifaceQuoted, "ct", "state", "established,related", "accept"]]+                        <> [Nft.RawRule w | NftRuleSpec w <- rules]+                        <> [Nft.RawRule ["iifname", ifaceQuoted, "drop"]]+                -- `x inject y` puts y before x, so each rule injects its predecessor+                ops = Nft.rule nft_r bins.binNft inchain <$> rs+             in foldl1 (\prev next -> next `inject` prev) ops+      where+        inchain = Nft.baseChain ("mesh-" <> h.host_iface) (Nft.Table ("mesh_" <> h.host_iface) Nft.Inet) (Nft.BaseChainSpec Nft.FilterChain Nft.Input 0 Nft.Accept)+

@@ -94,9 +94,12 @@     privkeyTrack :: Track' FilePath     privkeyTrack = Track $ WG.privateKey bins.binWg +    -- Each peer is injected the interface's key and port, not only the+    -- grouping node: that one has no effect, and what is injected onto it+    -- alone is a sibling of the peers, not something they wait for.     wgSetup :: Op     wgSetup =-        op "wireguard-vpn-server-peers" (deps $ fmap addPeer spec.server_clients) id+        op "wireguard-vpn-server-peers" (deps $ fmap ((`inject` serverIface) . addPeer) spec.server_clients) id             `inject` serverIface      serverIface :: Op@@ -208,18 +211,7 @@     -- pin a host route to the server's own IP via whatever the kernel currently     -- uses (the physical uplink), so the tunnel's own traffic doesn't loop over itself     pinServerRoute :: Op-    pinServerRoute =-        ( op "wireguard-vpn-client-pin-server-route" (deps [justInstall bins.binIp]) $ \actions ->-            actions-                { help = "keeps the route to the VPN server itself off the tunnel"-                , ref = mkRef "wg-vpn-pin-server-route" spec.client_server_ip-                , up = do-                    (via, dev) <- IpRoute.discoverGatewayFor spec.client_server_ip-                    let cmd = IpRoute.ReplaceRoute (IpRoute.Route (IpRoute.RawNetwork (spec.client_server_ip <> "/32")) dev via)-                    Binary.untrackedExec IpRoute.ipcommand cmd "" (contramap (IpRoute.RunIp cmd) ip_r)-                }-        )-            `inject` serverPeer+    pinServerRoute = pinHostRoute ip_r bins spec.client_server_ip `inject` serverPeer      -- classic wg-quick "route all traffic" trick: two more-specific-than-default     -- routes over the VPN interface, leaving the real default route (and every@@ -229,3 +221,19 @@         IpRoute.route ip_r bins.binIp (IpRoute.Route (IpRoute.RawNetwork "128.0.0.0/1") spec.client_wg_iface Nothing)             `inject` IpRoute.route ip_r bins.binIp (IpRoute.Route (IpRoute.RawNetwork "0.0.0.0/1") spec.client_wg_iface Nothing)             `inject` pinServerRoute++{- | Keeps the route to one host off the tunnel: a @\/32@ via the gateway the+kernel currently uses for it. Shared with "SreBox.WireGuardMesh", whose exit+routers need the same pin. The address must be an IPv4 literal.+-}+pinHostRoute :: Reporter IpRoute.Report -> Binaries -> Text -> Op+pinHostRoute ip_r bins addr =+    op "wireguard-vpn-client-pin-server-route" (deps [justInstall bins.binIp]) $ \actions ->+        actions+            { help = "keeps the route to the VPN server itself off the tunnel"+            , ref = mkRef "wg-vpn-pin-server-route" addr+            , up = do+                (via, dev) <- IpRoute.discoverGatewayFor addr+                let cmd = IpRoute.ReplaceRoute (IpRoute.Route (IpRoute.RawNetwork (addr <> "/32")) dev via)+                Binary.untrackedExec IpRoute.ipcommand cmd "" (contramap (IpRoute.RunIp cmd) ip_r)+            }

@@ -1,18 +1,40 @@ module Main (main) where  import qualified Test.AptRepositorySpec as AptRepositorySpec+import qualified Test.AmendNodeSpec as AmendNodeSpec+import qualified Test.BuiltinCardsSpec as BuiltinCardsSpec+import qualified Test.CardTemplateSpec as CardTemplateSpec import qualified Test.CheckSpec as CheckSpec+import qualified Test.HttpServerFlagSpec as HttpServerFlagSpec import qualified Test.ClientModelSpec as ClientModelSpec+import qualified Test.ClientModelStepSpec as ClientModelStepSpec import qualified Test.ConcurrentSpec as ConcurrentSpec+import qualified Test.BinaryOutputSpec as BinaryOutputSpec+import qualified Test.BinarySpec as BinarySpec import qualified Test.DaemonSpec as DaemonSpec+import qualified Test.DetachedSpec as DetachedSpec+import qualified Test.DagPerNodeSpec as DagPerNodeSpec+import qualified Test.DagStuckSpec as DagStuckSpec+import qualified Test.EdgeListSpec as EdgeListSpec import qualified Test.DagSpec as DagSpec+import qualified Test.GraphFixtureSpec as GraphFixtureSpec+import qualified Test.GraphScaleSpec as GraphScaleSpec+import qualified Test.ListedPathsSpec as ListedPathsSpec import qualified Test.DebianPackageSpec as DebianPackageSpec+import qualified Test.ClipCppSpec as ClipCppSpec import qualified Test.LlamaServerSpec as LlamaServerSpec import qualified Test.ServeApiSpec as ServeApiSpec+import qualified Test.PgTextSearchSpec as PgTextSearchSpec import qualified Test.PgVectorSpec as PgVectorSpec+import qualified Test.PgVectorDemoSpec as PgVectorDemoSpec import qualified Test.PlakarSpec as PlakarSpec+import qualified Test.WireGuardMeshSpec as WireGuardMeshSpec import qualified Test.WireGuardSpec as WireGuardSpec+import qualified Test.NetbirdSpec as NetbirdSpec+import qualified Test.PortMappingSpec as PortMappingSpec+import qualified Test.RsyncSpec as RsyncSpec import qualified Test.DebootstrapSpec as DebootstrapSpec+import qualified Test.DeferredSpec as DeferredSpec import qualified Test.DownTreeSpec as DownTreeSpec import qualified Test.FilesystemSpec as FilesystemSpec import qualified Test.FollowCacheSpec as FollowCacheSpec@@ -21,10 +43,12 @@ import qualified Test.FollowSignatureSpec as FollowSignatureSpec import qualified Test.FollowSpec as FollowSpec import qualified Test.GcpSpec as GcpSpec+import qualified Test.SecretDeliverySpec as SecretDeliverySpec import qualified Test.JWTSigningSpec as JWTSigningSpec import qualified Test.LedgerSpec as LedgerSpec import qualified Test.PodmanCommandSpec as PodmanCommandSpec import qualified Test.MigratorTemplateSpec as MigratorTemplateSpec+import qualified Test.PgBackRestSpec as PgBackRestSpec import qualified Test.PgBackupSpec as PgBackupSpec import qualified Test.PodmanSpec as PodmanSpec import qualified Test.PostgresBackupSpec as PostgresBackupSpec@@ -32,18 +56,27 @@ import qualified Test.PostgresReplicationSpec as PostgresReplicationSpec import qualified Test.PostgresClusterSpec as PostgresClusterSpec import qualified Test.PgBouncerSpec as PgBouncerSpec+import qualified Test.HaproxySpec as HaproxySpec import qualified Test.EtcdSpec as EtcdSpec+import qualified Test.PatroniSpec as PatroniSpec+import qualified Test.PatroniPreferredLeaderSpec as PatroniPreferredLeaderSpec+import qualified Test.PatroniRollingMaintenanceSpec as PatroniRollingMaintenanceSpec+import qualified Test.PatroniArchiveVmsSpec as PatroniArchiveVmsSpec import qualified Test.PatroniHarnessSpec as PatroniHarnessSpec import qualified Test.PgPairDemoSpec as PgPairDemoSpec import qualified Test.PostgresPairSpec as PostgresPairSpec+import qualified Test.PostgresPairPrereqsSpec as PostgresPairPrereqsSpec import qualified Test.PostgresSwitchoverSpec as PostgresSwitchoverSpec import qualified Test.PostgresTemplateSpec as PostgresTemplateSpec+import qualified Test.PostgresUserSpec as PostgresUserSpec import qualified Test.PostgresTlsSpec as PostgresTlsSpec import qualified Test.PostgrestCloudRunSpec as PostgrestCloudRunSpec import qualified Test.QemuResolveKernelSpec as QemuResolveKernelSpec import qualified Test.QemuShutdownSpec as QemuShutdownSpec import qualified Test.QemuSmokeSpec as QemuSmokeSpec import qualified Test.QuerySpec as QuerySpec+import qualified Test.ReadinessSpec as ReadinessSpec+import qualified Test.RemoteOutputSpec as RemoteOutputSpec import qualified Test.ReportJsonSpec as ReportJsonSpec import qualified Test.RewriteSpec as RewriteSpec import qualified Test.ServeEventsSpec as ServeEventsSpec@@ -53,10 +86,18 @@ import qualified Test.ServeSpec as ServeSpec import qualified Test.ServeTlsSpec as ServeTlsSpec import qualified Test.StatusSinkSpec as StatusSinkSpec+import qualified Test.QuadletSpec as QuadletSpec+import qualified Test.QuadletUserSpec as QuadletUserSpec+import qualified Test.SharedDirSpec as SharedDirSpec+import qualified Test.SystemdJobSpec as SystemdJobSpec import qualified Test.SystemdSpec as SystemdSpec+import qualified Test.UiTailTemplateSpec as UiTailTemplateSpec+import qualified Test.UpDownTextSpec as UpDownTextSpec import qualified Test.UpTreeSpec as UpTreeSpec+import qualified Test.UpkeepRetentionSpec as UpkeepRetentionSpec import qualified Test.UpkeepSpec as UpkeepSpec import qualified Test.WindowSpec as WindowSpec+import qualified Test.WrapperOrderingSpec as WrapperOrderingSpec  import Test.Tasty (DependencyType (..), TestTree, defaultMain, sequentialTestGroup, testGroup) @@ -88,7 +129,11 @@                 , -- these two shim PATH, which is process-global                   PostgresInitSpec.tests                 , PostgresTemplateSpec.sandboxTests+                , PostgresUserSpec.sandboxTests                 , MigratorTemplateSpec.tests+                , PgBackRestSpec.sandboxTests+                , PgTextSearchSpec.sandboxTests+                , PgVectorDemoSpec.sandboxTests                 , -- the rest of the VM specs: they share one bridge and a                   -- handful of fixed addresses, so two at once is two guests                   -- claiming one address.@@ -98,19 +143,47 @@                 , PgBackupSpec.tests                 , PgPairDemoSpec.tests                 , PatroniHarnessSpec.tests+                , PatroniArchiveVmsSpec.vmTests+                , -- the user's own systemd manager and podman+                  QuadletUserSpec.tests+                , SystemdJobSpec.userTests                 ]             , CheckSpec.tests+            , AmendNodeSpec.tests+            , CardTemplateSpec.tests+            , BuiltinCardsSpec.tests+            , HttpServerFlagSpec.tests             , ClientModelSpec.tests+            , ClientModelStepSpec.tests             , ConcurrentSpec.tests+            , BinarySpec.tests             , DaemonSpec.tests+            , DetachedSpec.tests+            , BinaryOutputSpec.tests+            , RemoteOutputSpec.tests             , DagSpec.tests+            , DagPerNodeSpec.tests+            , DagStuckSpec.tests+            , EdgeListSpec.tests+            , GraphFixtureSpec.tests+            , GraphScaleSpec.tests+            , ListedPathsSpec.tests             , AptRepositorySpec.tests             , DebianPackageSpec.tests+            , ClipCppSpec.tests             , LlamaServerSpec.tests             , ServeApiSpec.tests+            , UiTailTemplateSpec.tests             , PgVectorSpec.tests+            , PgVectorDemoSpec.tests+            , PgTextSearchSpec.tests             , PlakarSpec.tests             , WireGuardSpec.tests+            , WireGuardMeshSpec.tests+            , NetbirdSpec.tests+            , PortMappingSpec.tests+            , RsyncSpec.tests+            , DeferredSpec.tests             , DownTreeSpec.tests             , FilesystemSpec.tests             , FollowCacheSpec.tests@@ -119,6 +192,7 @@             , FollowSignatureSpec.tests             , FollowSpec.tests             , GcpSpec.tests+            , SecretDeliverySpec.tests             , JWTSigningSpec.tests             , LedgerSpec.tests             , PodmanCommandSpec.tests@@ -126,14 +200,23 @@             , PostgresBackupSpec.tests             , PostgresClusterSpec.tests             , PgBouncerSpec.tests+            , HaproxySpec.tests             , EtcdSpec.tests+            , PatroniSpec.tests+            , PatroniPreferredLeaderSpec.tests+            , PatroniRollingMaintenanceSpec.tests+            , PatroniArchiveVmsSpec.tests+            , PgBackRestSpec.tests             , PostgresPairSpec.tests+            , PostgresPairPrereqsSpec.tests             , PostgresTemplateSpec.tests+            , PostgresUserSpec.tests             , PostgresTlsSpec.tests             , PostgrestCloudRunSpec.tests             , QemuResolveKernelSpec.tests             , QemuShutdownSpec.tests             , QuerySpec.tests+            , ReadinessSpec.tests             , ReportJsonSpec.tests             , RewriteSpec.tests             , ServeEventsSpec.tests@@ -143,8 +226,14 @@             , ServeSpec.tests             , ServeTlsSpec.tests             , StatusSinkSpec.tests+            , QuadletSpec.tests+            , SharedDirSpec.tests+            , SystemdJobSpec.tests             , SystemdSpec.tests+            , UpDownTextSpec.tests             , UpTreeSpec.tests             , UpkeepSpec.tests+            , UpkeepRetentionSpec.tests             , WindowSpec.tests+            , WrapperOrderingSpec.tests             ]

@@ -0,0 +1,48 @@+{- | Layer 0 coverage for 'amendNode': amending one node of an 'Op' leaves+its predecessors as they were, which an 'fmap' over the 'Op' does not.+-}+module Test.AmendNodeSpec (tests) where++import Data.Foldable (toList)+import Data.Text (Text)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertEqual, testCase)++import Salmon.Builtin.Extension (Extension (..), Help, Op, amendNode, deps, evalDeps, nodeps, op, realNoop)+import Salmon.Op.OpGraph (OpGraph (..))+import Salmon.Op.Ref (mkRef)++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Extension.amendNode"+        [ testCase "amends the node and not its predecessor" amendsOnlyTheNode+        , testCase "an fmap over the Op reaches the predecessor (the hazard)" fmapReachesPredecessor+        , testCase "an Actionless node is returned unchanged" actionlessUnchanged+        ]++predecessor :: Op+predecessor = op "pre" nodeps $ \x -> x{help = "pre", ref = mkRef "amend-test" ("pre" :: Text)}++root :: Op+root = op "root" (deps [predecessor]) $ \x -> x{help = "root", ref = mkRef "amend-test" ("root" :: Text)}++-- | Every node's help, the root first, as the evaluator materializes them.+helps :: Op -> [Help]+helps o = [x.help | n <- toList (evalDeps o), x <- toList n.node]++amended :: Extension -> Extension+amended x = x{help = "amended"}++amendsOnlyTheNode :: IO ()+amendsOnlyTheNode = do+    assertEqual "before" ["root", "pre"] (helps root)+    assertEqual "after" ["amended", "pre"] (helps (amendNode amended root))++fmapReachesPredecessor :: IO ()+fmapReachesPredecessor =+    assertEqual "fmap" ["amended", "amended"] (helps (fmap (fmap amended) root))++actionlessUnchanged :: IO ()+actionlessUnchanged =+    assertEqual "actionless" [] (helps (amendNode amended realNoop))

@@ -0,0 +1,276 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Layer 1 coverage for where a command's output goes+("Salmon.Builtin.Nodes.Binary"'s 'Binary.Routing') and for the per-node line+it rides on ("Salmon.Builtin.NodeLog"): real subprocesses, all of them+@\/bin\/sh@, none longer than a second.++What only a real process shows is the point of the feature: that a streamed+line reaches the listener /while the command is still running/ (the case+holds the command open on a file it waits for, and creates that file only+after the first line has arrived), that what is kept is bounded however much+is printed, and that a command which never reads its standard input, or is+routed to a file or to nothing, still ends with its own exit code.++The sink registry is process-wide and this suite runs its groups in parallel+in one process, so every assertion about what a sink saw filters by the+node's own 'Ref'.+-}+module Test.BinaryOutputSpec (tests) where++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (try)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as C8+import Data.Functor.Identity (runIdentity)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import System.Directory (doesFileExist)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.Process (proc)+import System.Timeout (timeout)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)++import qualified Salmon.Actions.UpDown as UpDown+import Salmon.Builtin.Extension (Extension (..), Op, Track', ignoreTrack, nodeps, op)+import qualified Salmon.Builtin.NodeLog as NodeLog+import Salmon.Builtin.Nodes.Binary (Binary, Command (..), Routing (..), Sink (..))+import qualified Salmon.Builtin.Nodes.Binary as Binary+import Salmon.Op.Ref (Ref, mkRef)+import Salmon.Reporter (ReporterM (..), silent)+import Test.Harness (withTempDir)++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Nodes.Binary: where output goes"+        [ testGroup+            "the tail a stream keeps"+            [ testCase "everything, when it fits" tailFits+            , testCase "whole trailing lines, when it does not" tailDropsFromTheFront+            , testCase "the end of a line longer than the bound" tailCutsALongLine+            ]+        , testCase "captured is what it was: both streams whole, nothing streamed" capturedUnchanged+        , testCase "a streamed line arrives while the command is still running" streamsWhileRunning+        , testCase "a stream keeps a bounded tail of megabytes, and reports every line" boundedTail+        , testCase "discarded output is not kept, and the exit code is" discardedKeepsExitCode+        , testCase "output appended to a file lands there, both streams, across runs" appendsToFile+        , testCase "each stream has its own sink" mixedSinks+        , testCase "a command that never reads its standard input is not a failure" unreadStdin+        , testCase "a failing streamed command throws with the tail it kept" failureCarriesTail+        , testCase "a node's streamed lines are node log lines under its ref, not reports" nodeLinesGoToTheLog+        , testCase "a captured node says nothing to the log" capturedNodeIsSilent+        , testCase "a node's own message is split into lines; a sink stops hearing when it leaves" sayAndLeave+        ]++-------------------------------------------------------------------------------++within :: Int -> IO a -> IO a+within secs act = do+    r <- timeout (secs * 1000000) act+    maybe (assertFailure ("timed out after " <> show secs <> "s")) pure r++sh :: Command "sh" String+sh = Command $ \script -> proc "/bin/sh" ["-c", script]++shTrack :: Track' (Binary "sh")+shTrack = ignoreTrack++-- | Collects what a callback or reporter is handed, in order.+collector :: IO (a -> IO (), IO [a])+collector = do+    cell <- newIORef []+    pure (\x -> atomicModifyIORef' cell (\xs -> (x : xs, ())), reverse <$> readIORef cell)++-------------------------------------------------------------------------------++tailFits :: IO ()+tailFits = assertEqual "" "a\nbb\n" (Binary.tailOf 100 ["a", "bb"])++tailDropsFromTheFront :: IO ()+tailDropsFromTheFront = do+    -- "three\n" is 6 bytes, "four\n" is 5: 11 fit in 12, "two\n" would not+    assertEqual "" "three\nfour\n" (Binary.tailOf 12 ["one", "two", "three", "four"])+    assertEqual "nothing but the last" "four\n" (Binary.tailOf 5 ["one", "two", "three", "four"])++tailCutsALongLine :: IO ()+tailCutsALongLine = do+    let kept = Binary.tailOf 8 ["short", C8.replicate 100 'x' <> "END"]+    assertBool "within the bound" (ByteString.length kept <= 8)+    assertBool "the end of the line, not its start" ("END\n" `ByteString.isSuffixOf` kept)++capturedUnchanged :: IO ()+capturedUnchanged = within 10 $ do+    (onLine, seen) <- collector+    r <- Binary.runRouted Binary.captured (\c l -> onLine (c, l)) (proc "/bin/sh" ["-c", "echo out; echo err >&2; exit 3"]) ""+    assertEqual "" (ExitFailure 3, "out\n", "err\n") r+    assertEqual "nothing streamed" [] =<< seen++streamsWhileRunning :: IO ()+streamsWhileRunning = within 20 . withTempDir $ \dir -> do+    let gate = dir </> "gate"+        script = "echo first; while [ ! -e '" <> gate <> "' ]; do sleep 0.05; done; echo second"+    arrived <- newEmptyMVar+    ended <- newEmptyMVar+    _ <- forkIO (putMVar ended =<< (try (Binary.runRouted Binary.streamed (\_ l -> putMVar arrived l) (proc "/bin/sh" ["-c", script]) "") :: IO (Either IOError (ExitCode, ByteString.ByteString, ByteString.ByteString))))+    first <- takeMVar arrived+    assertEqual "" "first" first+    -- the command cannot have ended: what lets it end does not exist yet+    opened <- doesFileExist gate+    assertBool "the gate was still shut when the first line arrived" (not opened)+    writeFile gate ""+    second <- takeMVar arrived+    assertEqual "" "second" second+    r <- takeMVar ended+    assertEqual "and the report still has both" (Right (ExitSuccess, "first\nsecond\n", "")) r++boundedTail :: IO ()+boundedTail = within 60 $ do+    count <- newIORef (0 :: Int)+    -- 200000 lines of 7 bytes: 1.4MB printed, 64 bytes kept+    (code, out, err) <-+        Binary.runRouted+            (Binary.streamedKeeping 64)+            (\_ _ -> atomicModifyIORef' count (\n -> (n + 1, ())))+            (proc "/bin/sh" ["-c", "i=100000; while [ $i -lt 300000 ]; do echo $i; i=$((i+1)); done"])+            ""+    assertEqual "" ExitSuccess code+    assertEqual "every line was reported" 200000 =<< readIORef count+    assertBool ("kept " <> show (ByteString.length out) <> " bytes") (ByteString.length out <= 64)+    assertBool "and it is the end of the stream" ("299999\n" `ByteString.isSuffixOf` out)+    assertEqual "" "" err++discardedKeepsExitCode :: IO ()+discardedKeepsExitCode = within 10 $ do+    (onLine, seen) <- collector+    r <- Binary.runRouted Binary.discarded (\c l -> onLine (c, l)) (proc "/bin/sh" ["-c", "echo out; echo err >&2; exit 4"]) ""+    assertEqual "" (ExitFailure 4, "", "") r+    assertEqual "nothing streamed" [] =<< seen++appendsToFile :: IO ()+appendsToFile = within 10 . withTempDir $ \dir -> do+    let logfile = dir </> "command.log"+        run script = Binary.runRouted (Binary.appendedTo logfile) (\_ _ -> pure ()) (proc "/bin/sh" ["-c", script]) ""+    r1 <- run "echo one; echo two >&2"+    assertEqual "nothing kept for the report" (ExitSuccess, "", "") r1+    _ <- run "echo three"+    written <- C8.readFile logfile+    assertEqual "both streams, then the second run after the first" "one\ntwo\nthree\n" written++mixedSinks :: IO ()+mixedSinks = within 10 $ do+    (onLine, seen) <- collector+    r <-+        Binary.runRouted+            (Routing{stdoutTo = Capture, stderrTo = Stream 1024})+            (\c l -> onLine (c, l))+            (proc "/bin/sh" ["-c", "echo result; echo progress >&2"])+            ""+    assertEqual "" (ExitSuccess, "result\n", "progress\n") r+    assertEqual "only the streamed one was reported" [(NodeLog.Stderr, "progress")] =<< seen++unreadStdin :: IO ()+unreadStdin = within 20 $ do+    -- far more than a pipe holds, to a command that reads none of it+    (code, out, _) <- Binary.runRouted Binary.streamed (\_ _ -> pure ()) (proc "/bin/sh" ["-c", "echo done"]) (C8.replicate (4 * 1024 * 1024) 'x')+    assertEqual "" (ExitSuccess, "done\n") (code, out)+    -- and one that does read it gets it+    (_, counted, _) <- Binary.runRouted Binary.streamed (\_ _ -> pure ()) (proc "/bin/sh" ["-c", "wc -c | tr -d ' '"]) (C8.replicate 100000 'x')+    assertEqual "" "100000\n" counted++failureCarriesTail :: IO ()+failureCarriesTail = within 10 $ do+    (onReport, seen) <- collector+    r <- try (Binary.untrackedExecWith Binary.streamed sh "echo building; echo broken >&2; exit 2" "" (ReporterM onReport))+    case r of+        Right () -> assertFailure "a non-zero exit did not throw"+        Left (Binary.CommandFailed _ code out err) ->+            assertEqual "" (2, "building\n", "broken\n") (code, out, err)+    reports <- seen+    assertEqual+        "start, the two lines, stop"+        ["start", "line", "line", "stopped"]+        (map shape reports)+  where+    shape rep = case rep of+        Binary.CommandStart{} -> "start" :: String+        Binary.CommandOutput{} -> "line"+        Binary.CommandStopped{} -> "stopped"+        Binary.Requested{} -> "requested"++-------------------------------------------------------------------------------++-- | A node running one shell script, with its output routed as asked.+scriptNode :: Routing -> Ref -> String -> (Binary.Report -> IO ()) -> Op+scriptNode routing r script onReport =+    Binary.withBinaryWith routing shTrack sh script $ \run ->+        op "script" nodeps $ \actions ->+            actions+                { help = "runs a script"+                , ref = r+                , up = run (ReporterM onReport)+                }++runUp :: Op -> IO Bool+runUp = UpDown.upTree silent (pure . runIdentity)++-- | The lines a sink saw about one node.+about :: Ref -> [NodeLog.Line] -> [(NodeLog.Channel, String)]+about r ls = [(l.lineChannel, show l.lineText) | l <- ls, l.lineRef == r]++nodeLinesGoToTheLog :: IO ()+nodeLinesGoToTheLog = within 20 $ do+    let r = mkRef "binary-output-spec" ("streamed" :: String)+    (onLine, lines') <- collector+    (onReport, reports) <- collector+    ok <- NodeLog.withSink (ReporterM onLine) (runUp (scriptNode Binary.streamed r "echo compiling; printf 'carriage\\r\\n'; echo careful >&2" onReport))+    assertBool "the node came up" ok+    seen <- about r <$> lines'+    assertEqual+        "stdout in order, under the node's ref, without line terminators"+        [show ("compiling" :: String), show ("carriage" :: String)]+        [t | (NodeLog.Stdout, t) <- seen]+    assertEqual "stderr on its own channel" [show ("careful" :: String)] [t | (NodeLog.Stderr, t) <- seen]+    reps <- reports+    assertEqual+        "the recipe's reporter got the start and the stop, and no line twice"+        ["start", "stopped"]+        (map shape reps)+    assertBool "and the stop carries what was kept" (any Binary.isCommandSuccessful reps)+  where+    shape rep = case rep of+        Binary.Requested _ Binary.CommandStart{} -> "start" :: String+        Binary.Requested _ Binary.CommandStopped{} -> "stopped"+        Binary.Requested _ Binary.CommandOutput{} -> "line"+        _ -> "other"++capturedNodeIsSilent :: IO ()+capturedNodeIsSilent = within 20 $ do+    let r = mkRef "binary-output-spec" ("captured" :: String)+    (onLine, lines') <- collector+    (onReport, reports) <- collector+    ok <- NodeLog.withSink (ReporterM onLine) (runUp (scriptNode Binary.captured r "echo a-secret-token" onReport))+    assertBool "the node came up" ok+    assertEqual "nothing was said" [] . about r =<< lines'+    reps <- reports+    assertEqual+        "and the report is the one it always was"+        ["a-secret-token\n"]+        [out | Binary.Requested _ (Binary.CommandStopped _ ExitSuccess out _) <- reps]++sayAndLeave :: IO ()+sayAndLeave = do+    let r = mkRef "binary-output-spec" ("say" :: String)+    (onLine, lines') <- collector+    NodeLog.withSink (ReporterM onLine) $ do+        NodeLog.say r "waiting for ssh"+        NodeLog.say r "step 1 of 2\nstep 2 of 2"+    NodeLog.say r "nobody is listening"+    seen <- about r <$> lines'+    assertEqual+        ""+        [(NodeLog.Message, show t) | t <- ["waiting for ssh", "step 1 of 2", "step 2 of 2" :: String]]+        seen

@@ -0,0 +1,96 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{- | Layer 1 coverage for what "Salmon.Builtin.Nodes.Binary" promises about a+child's standard input: real subprocesses, asked what their descriptor 0 is.++The rule under test is that no process started for a node inherits the+standard input of the pass that runs it — under @run serve@ that is the+command channel, and a child that prompts would block the pass and read the+loop's commands. The children here answer through @\/proc\/self\/fd\/0@+rather than by reading, so the cases hold whatever this test process's own+standard input happens to be.+-}+module Test.BinarySpec (tests) where++import Control.Exception (try)+import qualified Data.ByteString.Char8 as C8+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.IO (Handle, IOMode (..), hClose, openFile, withFile)+import System.IO.Temp (withSystemTempDirectory)+import System.Process (CreateProcess (..), StdStream (..), createProcess, proc, waitForProcess)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertEqual, assertFailure, testCase)++import Salmon.Builtin.Nodes.Binary (CommandFailed (..), CommandIO (..), detachedStdin, execDetached, untrackedExecIO)++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Nodes.Binary"+        [ testCase "a CommandIO naming no standard input reads /dev/null, not ours" ioCommandIsDetached+        , testCase "a CommandIO naming its own standard input keeps it" ioCommandKeepsItsInput+        , testCase "detachedStdin leaves the caller's CreateProcess otherwise as given" detachedOnlyTouchesInherit+        , testCase "execDetached hands back stdout and gives the child an empty input" execDetachedReads+        , testCase "execDetached throws on a non-zero exit" execDetachedThrows+        ]++-- | What the child's descriptor 0 is, as the kernel names it.+whatIsStdin :: CreateProcess+whatIsStdin = proc "readlink" ["/proc/self/fd/0"]++-- | Run a 'CommandIO' to completion with its stdout sent to a file; the file's contents.+capturing :: (Handle -> IO CreateProcess) -> IO String+capturing mk =+    withSystemTempDirectory "salmon-binary-spec" $ \dir -> do+        let outPath = dir </> "out"+        out <- openFile outPath WriteMode+        (_, _, _, ph) <- untrackedExecIO (CommandIO @"readlink" (\() h -> mk h)) () out+        code <- waitForProcess ph+        hClose out+        assertEqual "the child exited cleanly" ExitSuccess code+        s <- readFile outPath+        length s `seq` pure s++ioCommandIsDetached :: IO ()+ioCommandIsDetached = do+    s <- capturing (\out -> pure whatIsStdin{std_out = UseHandle out})+    assertEqual "descriptor 0 of the child" "/dev/null\n" s++ioCommandKeepsItsInput :: IO ()+ioCommandKeepsItsInput =+    withSystemTempDirectory "salmon-binary-spec" $ \dir -> do+        let inPath = dir </> "in"+        writeFile inPath "fed by the node\n"+        s <- capturing $ \out -> do+            input <- openFile inPath ReadMode+            pure (proc "cat" []){std_in = UseHandle input, std_out = UseHandle out}+        assertEqual "the child read what the node gave it" "fed by the node\n" s++detachedOnlyTouchesInherit :: IO ()+detachedOnlyTouchesInherit = do+    piped <- detachedStdin (proc "true" []){std_in = CreatePipe} (pure . std_in)+    assertEqual "an asked-for pipe is still a pipe" "CreatePipe" (show piped)+    none <- detachedStdin (proc "true" []){std_in = NoStream} (pure . std_in)+    assertEqual "an explicit NoStream is left alone" "NoStream" (show none)+    withFile "/dev/null" WriteMode $ \sink -> do+        (_, _, _, ph) <- detachedStdin (proc "true" []){std_out = UseHandle sink} createProcess+        code <- waitForProcess ph+        assertEqual "the process still runs" ExitSuccess code++execDetachedReads :: IO ()+execDetachedReads = do+    out <- execDetached (proc "sh" ["-c", "if read -r line; then echo \"read: $line\"; else echo eof; fi"])+    assertEqual "a prompt reads end-of-file at once" "eof\n" (C8.unpack out)++execDetachedThrows :: IO ()+execDetachedThrows = do+    r <- try @CommandFailed (execDetached (proc "sh" ["-c", "echo no >&2; exit 3"]))+    case r of+        Left e -> do+            assertEqual "exit code" 3 e.commandFailed_exitCode+            assertEqual "stderr is kept" "no\n" (C8.unpack e.commandFailed_stderr)+        Right out -> assertFailure ("expected CommandFailed, got " <> show out)

@@ -0,0 +1,425 @@+{- | Layer 0 coverage for the builtin card templates ("Salmon.Builtin.Cards",+feature 91138a85; "Salmon.Builtin.Cards.Gcp" and "Salmon.Builtin.Cards.Postgres",+feature d8a79380; "Salmon.Builtin.Cards.Keys" and "Salmon.Builtin.Cards.Patroni",+feature e593a79b).++* Attaching a card to a builtin changes nothing it renders: the same+  representative, @ref@, @help@ and @notes@, and its dependencies untouched.+* Each card, rendered here, parses and draws under the card contract with+  the vendored tramaj-js (@salmon-ops\/ui-test\/builtin-cards.test.mjs@, run+  under @node@, skipped loudly without it): the right sentence per verdict,+  its facts, no error on random contexts.+* 'Cards.tramajString' round-trips arbitrary text through tramaj-js.+* A card never carries what the builtin keeps out of its public fields: a+  password, a file's contents, an instance's metadata.+* A key or certificate card shows paths, never a key, a fingerprint or a+  digest; a pgBackRest card names an S3 archive by its kind only.+* A card's links are https console URLs built from the declaration's public+  names only, percent-encoded ('Cards.percentEncode').+* Every card links to its builtin's page on the docs site+  ('Cards.docsLink'), and that page has a source under+  @resources\/builtins\/@ (feature 42358f5a), and the link's base is the+  kitchen-sink site's published URL from @website\/src\/kitchen-sink.json@+  (feature 6b166715).+-}+module Test.BuiltinCardsSpec (tests) where++import Control.Monad (forM_, unless)+import qualified Data.ByteString as ByteString+import Data.Char (chr, isAsciiLower, isAsciiUpper, isDigit, isHexDigit)+import qualified Data.Map as Map+import Data.Aeson (object, (.=))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Lazy as LByteString+import Data.Foldable (toList)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Numeric (readHex)+import System.Directory (doesFileExist)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.Process (proc, readCreateProcessWithExitCode)+import Test.QuickCheck (Gen, arbitrary, elements, forAll, frequency, generate, listOf, vectorOf, (===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)+import Test.Tasty.QuickCheck (testProperty)++import qualified Salmon.Builtin.Cards as Cards+import qualified Salmon.Builtin.Cards.Gcp as GcpCards+import qualified Salmon.Builtin.Cards.Keys as KeyCards+import qualified Salmon.Builtin.Cards.Patroni as HaCards+import qualified Salmon.Builtin.Cards.Postgres as PgCards+import Salmon.Builtin.Extension (Extension (..), Op, evalDeps, ignoreTrack)+import qualified Salmon.Builtin.Nodes.Certificates as Certs+import qualified Salmon.Builtin.Nodes.Filesystem as FS+import qualified Salmon.Builtin.Nodes.Gcp.CloudDns as Dns+import qualified Salmon.Builtin.Nodes.Gcp.Compute as Compute+import qualified Salmon.Builtin.Nodes.Gcp.Core as Core+import qualified Salmon.Builtin.Nodes.Gcp.LoadBalancing as Lb+import qualified Salmon.Builtin.Nodes.Gcp.SecretManager as Secrets+import qualified Salmon.Builtin.Nodes.Gcp.SshAccess as SshAccess+import qualified Salmon.Builtin.Nodes.Gcp.Storage as Storage+import qualified Salmon.Builtin.Nodes.Haproxy as Haproxy+import qualified Salmon.Builtin.Nodes.Keys as Keys+import qualified Salmon.Builtin.Nodes.Patroni as Patroni+import Salmon.Builtin.Nodes.Patroni.PreferredLeader (PreferredLeader (..))+import qualified Salmon.Builtin.Nodes.Patroni.PreferredLeader as PreferredLeader+import qualified Salmon.Builtin.Nodes.PgBackRest as PgBackRest+import qualified Salmon.Builtin.Nodes.Ssh as Ssh+import Salmon.Builtin.Nodes.SecretDelivery (Placement (..))+import qualified Salmon.Builtin.Nodes.Postgres as Postgres+import qualified Salmon.Builtin.Nodes.Systemd as Systemd+import qualified Salmon.Builtin.Nodes.WireGuard as WireGuard+import Salmon.Op.Actions (Act (..), Actions (..))+import Salmon.Op.CardTemplate (cardTemplateOf)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.OpGraph (OpGraph (..))+import Salmon.Op.Ref (Ref)+import Salmon.Reporter (silent)+import Test.Harness (requireExecutable, withTempDir)++-- | A builtin and its card.+data Case = Case+    { caseName :: Text+    , casePlain :: Op+    , caseCard :: Cards.Card+    }++cases :: [Case]+cases =+    [ Case "file-contents" (FS.filecontents (FS.FileContents filePath ("not on the card" :: Text))) (Cards.fileContentsCard filePath)+    , Case "directory" (FS.dir (FS.Directory "/var/lib/demo")) (Cards.directoryCard "/var/lib/demo")+    , Case "systemd-service" (Systemd.systemdService silent ignoreTrack ignoreTrack unitCfg) (Cards.systemdServiceCard unitCfg)+    , Case "pg-database" (Postgres.database silent ignoreTrack ignoreTrack 5433 (Postgres.Database "appdb")) (Cards.pgDatabaseCard 5433 (Postgres.Database "appdb"))+    ]+        <> gcpCases+        <> pgCases+        <> keyCases+        <> haCases+  where+    filePath = "/etc/demo/app.conf"++-- | What no card may show: the declarations below carry these, in places the builtins keep out of their public fields.+secretWords :: [Text]+secretWords = [pgPassword, "metadata-value-not-on-card", "/tmp/w/startup-script.sh", "s3-bucket-not-on-card", "s3-endpoint-not-on-card"]++pgPassword :: Text+pgPassword = "pg-password-not-on-card"++project :: Core.Project+project = Core.Project "demo-proj"++gcpCases :: [Case]+gcpCases =+    [ Case "gcp-instance" (Compute.gceInstance silent ignoreTrack demoInstance) (GcpCards.instanceCard demoInstance)+    , Case "gcp-address" (Compute.address silent ignoreTrack addr) (GcpCards.addressCard addr)+    , Case "gcp-address-internal" (Compute.address silent ignoreTrack addrIn) (GcpCards.addressCard addrIn)+    , Case "gcp-firewall-rule" (Compute.firewallRule silent ignoreTrack fw) (GcpCards.firewallRuleCard fw)+    , Case "gcp-subnet" (Compute.subnet silent ignoreTrack net) (GcpCards.subnetCard net)+    , Case "gcp-dns-zone" (Dns.managedZone silent ignoreTrack zone) (GcpCards.managedZoneCard zone)+    , Case "gcp-dns-record" (Dns.recordSet silent ignoreTrack rs) (GcpCards.recordSetCard False rs)+    , Case "gcp-dns-record-resolved" (Dns.resolvedRecordSet silent ignoreTrack rs (pure Nothing)) (GcpCards.recordSetCard True rs)+    , Case "gcp-bucket" (Storage.bucket silent ignoreTrack bkt) (GcpCards.bucketCard bkt)+    , Case "gcp-secret" (Secrets.secret silent ignoreTrack sec) (GcpCards.secretCard sec)+    , Case "gcp-secret-file" (Secrets.secretFile silent ignoreTrack secFile) (GcpCards.secretFileCard secFile)+    , Case "gcp-application-lb" (Lb.applicationLoadBalancer silent ignoreTrack alb) (GcpCards.applicationLoadBalancerCard alb)+    ]+  where+    addr = Compute.Address "demo-ip" project (Core.Region "europe-west1") Compute.ExternalAddress+    addrIn = Compute.Address "demo-ip-in" project (Core.Region "europe-west1") (Compute.InternalAddress "demo-subnet" (Just "10.0.0.5"))+    fw = Compute.FirewallRule "demo-ssh" project "default" "tcp:22" ["203.0.113.0/24"] ["demo-ssh"]+    net = Compute.Subnet "demo-subnet" project (Core.Region "europe-west1") "default" "10.0.0.0/24" Compute.PrivateSubnet+    zone = Dns.ManagedZone "demo-zone" project "example.org" "a demo zone"+    rs = Dns.RecordSet zone "www.example.org" Dns.A 300 ["203.0.113.7"]+    bkt = Storage.Bucket "demo-bucket" project (Core.Region "europe-west1") True+    sec = Secrets.Secret "demo-secret" project "automatic"+    secFile = Secrets.SecretFile project "demo-secret" "latest" (Placement "/etc/demo/token" "root" "demo" "0640")+    alb = Lb.httpLoadBalancer "demo-lb" project (Core.Region "europe-west1") [Lb.InstanceGroupBackend "demo-group" (Lb.InstanceGroupZone "europe-west1-b") [8080]] Nothing++demoInstance :: Compute.Instance+demoInstance =+    Compute.Instance+        { Compute.instanceName = "demo-vm"+        , Compute.instanceProject = project+        , Compute.instanceZone = Core.Zone "europe-west1-b"+        , Compute.instanceMachineType = Compute.E2Medium+        , Compute.instanceBootDisk = Compute.BootDisk 10 Nothing (Just "ubuntu-2404-lts-amd64") (Just "ubuntu-os-cloud")+        , Compute.instanceNetwork = "default"+        , Compute.instanceSubnet = "default"+        , Compute.instanceServiceAccount = Nothing+        , Compute.instanceMetadata = Map.fromList [("some-key", "metadata-value-not-on-card")]+        , Compute.instanceMetadataFiles = Map.fromList [("startup-script", "/tmp/w/startup-script.sh")]+        , Compute.instanceExternalAddress = Compute.ReservedExternal "demo-ip"+        , Compute.instanceInternalAddress = Compute.EphemeralInternal+        , Compute.instanceTags = ["demo-ssh"]+        , Compute.instancePower = Compute.PoweredOn+        , Compute.instanceScopes = Compute.DefaultScopes+        , Compute.instanceMachineTypeChange = Compute.RefuseMachineTypeChange+        , Compute.instanceRunLimit = Compute.NoRunLimit+        }++pgCases :: [Case]+pgCases =+    [ Case "pg-user" (Postgres.user silent ignoreTrack ignoreTrack 5433 app (Postgres.Password pgPassword)) (PgCards.userCard 5433 app)+    , Case "pg-user-passfile" (Postgres.userPassFile silent ignoreTrack ignoreTrack 5433 (FS.PreExisting "/run/secrets/app.pass") app) (PgCards.userPassFileCard 5433 "/run/secrets/app.pass" app)+    , Case "pg-replication-user" (Postgres.replicationUser silent ignoreTrack ignoreTrack 5433 repl (Postgres.Password pgPassword)) (PgCards.replicationUserCard 5433 repl)+    , Case "pg-replication-slot" (Postgres.replicationSlot silent ignoreTrack 5433 "standby_1") (PgCards.replicationSlotCard 5433 "standby_1")+    , Case "pg-hba-line" (Postgres.hbaLine silent ignoreTrack "main" hba) (PgCards.hbaLineCard "main" hba)+    , Case "pg-alter-system" (Postgres.alterSystemSet silent ignoreTrack 5433 "wal_level" "replica") (PgCards.alterSystemCard 5433 "wal_level" "replica")+    , Case "pg-server-tls" (Postgres.serverTls silent ignoreTrack 5433 tls) (PgCards.serverTlsCard 5433 tls)+    ]+  where+    app = Postgres.User "app"+    repl = Postgres.User "replicator"+    hba = "hostssl all app 10.0.0.0/24 scram-sha-256"+    tls = Postgres.ServerTls "/etc/demo/tls/server.crt" "/etc/demo/tls/server.key" "/etc/demo/tls/ca.crt"++keyCases :: [Case]+keyCases =+    [ Case "ssh-key" (Keys.sshKey silent ignoreTrack sshPair) (KeyCards.sshKeyCard sshPair)+    , Case "ssh-ca-sign" (Keys.signKey silent ignoreTrack sshCa kid principals sshPair) (KeyCards.sshCaSignCard sshCa kid principals sshPair)+    , Case "ssh-available" (SshAccess.sshAvailable silent endpoint) (KeyCards.sshAvailableCard endpoint)+    , Case "gcp-metadata-ssh-ca" (SshAccess.installMetadataCaKey silent ignoreTrack metaCa) (KeyCards.metadataSshCaCard metaCa)+    , Case "tls-key" (Certs.tlsKey silent ignoreTrack tlsK) (KeyCards.tlsKeyCard tlsK)+    , Case "tls-csr" (Certs.signingRequest silent ignoreTrack csr) (KeyCards.signingRequestCard csr)+    , Case "tls-self-signed" (Certs.selfSign silent ignoreTrack selfS) (KeyCards.selfSignedCard selfS)+    , Case "tls-ca" (Certs.certificateAuthority silent ignoreTrack ca) (KeyCards.certificateAuthorityCard ca)+    , Case "tls-ca-signed" (Certs.caSign silent ignoreTrack ignoreTrack caS) (KeyCards.caSignedCard caS)+    , Case "jwk-key" (Keys.jwkKey jwk) (KeyCards.jwkKeyCard jwk)+    , Case "wg-private-key" (WireGuard.privateKey ignoreTrack "/etc/wireguard/wg0.key") (KeyCards.wgPrivateKeyCard "/etc/wireguard/wg0.key")+    , Case "wg-public-key" (WireGuard.publicKey ignoreTrack ignoreTrack "/etc/wireguard/wg0.key" "/etc/wireguard/wg0.pub") (KeyCards.wgPublicKeyCard "/etc/wireguard/wg0.key" "/etc/wireguard/wg0.pub")+    ]+  where+    sshPair = Keys.SSHKeyPair Keys.ED25519 "/home/demo/.ssh" "id_demo"+    sshCa = Keys.SSHCertificateAuthority (Keys.SSHKeyPair Keys.ED25519 "/etc/demo/ssh-ca" "ca")+    kid = Keys.KeyIdentifier "demo-login"+    principals = [Keys.Principal "root", Keys.Principal "demo"]+    endpoint = SshAccess.SshEndpoint (Just "root") "203.0.113.7" 22 Ssh.noClientOpts+    metaCa = SshAccess.MetadataSshCa project "/etc/demo/ssh-ca/ca.pub"+    tlsK = Certs.Key Certs.RSA2048 "/etc/demo/tls" "server.key"+    csr = Certs.SigningRequest (Certs.Domain "db.example.org") tlsK "/etc/demo/tls" "server.csr"+    selfS = Certs.SelfSigned "/etc/demo/tls/server.pem" csr+    ca = Certs.CertificateAuthority (Certs.Key Certs.RSA4096 "/etc/demo/ca" "ca.key") "/etc/demo/ca/ca.crt" (Certs.Domain "demo CA") 3650+    caS = Certs.CaSigned "/etc/demo/tls/app.crt" (Certs.SigningRequest (Certs.Domain "app") tlsK "/etc/demo/tls" "app.csr") ca 365+    jwk = Keys.JWKKeyPair Keys.ED25519 "/etc/demo/jwk" "signing.jwk"++haCases :: [Case]+haCases =+    [ Case "patroni-member" (Patroni.patroniMember silent ignoreTrack ignoreTrack patroniCfg) (HaCards.patroniMemberCard patroniCfg)+    , Case "patroni-preferred-leader" (PreferredLeader.preferredLeader preferred) (HaCards.preferredLeaderCard preferred)+    , Case "pgbackrest-config" (PgBackRest.configuration ignoreTrack pbrS3) (HaCards.pgBackRestConfigurationCard pbrS3)+    , Case "pgbackrest-config-posix" (PgBackRest.configuration ignoreTrack pbr) (HaCards.pgBackRestConfigurationCard pbr)+    , Case "pgbackrest-stanza" (PgBackRest.stanza silent ignoreTrack pbrS3) (HaCards.pgBackRestStanzaCard pbrS3)+    , Case "pgbackrest-first-backup" (PgBackRest.firstBackup silent ignoreTrack pbrS3) (HaCards.pgBackRestFirstBackupCard pbrS3)+    , Case "pgbackrest-restore" (PgBackRest.restoredCluster silent ignoreTrack pbr PgBackRest.Latest) (HaCards.pgBackRestRestoreCard pbr PgBackRest.Latest)+    , Case "haproxy" (Haproxy.setup silent ignoreTrack ignoreTrack router) (HaCards.haproxyCard router)+    ]+  where+    preferred = PreferredLeader "demo" "n1" "10.0.0.1:8008" (Just "/etc/patroni/rest.creds") 60+    pbr =+        PgBackRest.PgBackRestConfig+            { PgBackRest.pbr_stanza = "demo"+            , PgBackRest.pbr_pg_path = "/var/lib/postgresql/16/main"+            , PgBackRest.pbr_pg_port = 5432+            , PgBackRest.pbr_repo = PgBackRest.PosixRepo "/srv/archive"+            , PgBackRest.pbr_retention_full = 2+            , PgBackRest.pbr_global = []+            , PgBackRest.pbr_stanza_options = []+            , PgBackRest.pbr_config_file = "/etc/pgbackrest/pgbackrest.conf"+            , PgBackRest.pbr_secrets_file = Nothing+            , PgBackRest.pbr_log_path = "/var/log/pgbackrest"+            , PgBackRest.pbr_user = "postgres"+            , PgBackRest.pbr_run_as = Nothing+            , PgBackRest.pbr_binary = "/usr/bin/pgbackrest"+            }+    pbrS3 =+        pbr+            { PgBackRest.pbr_repo = PgBackRest.S3Repo "s3-bucket-not-on-card" "s3-endpoint-not-on-card" "eu" "/pgbackrest" True+            , PgBackRest.pbr_secrets_file = Just "/etc/pgbackrest/conf.d/secrets.conf"+            }+    router = Haproxy.patroniRouter [Haproxy.Member "n1" "10.0.0.1" 5432 8008, Haproxy.Member "n2" "10.0.0.2" 5432 8008]++patroniCfg :: Patroni.PatroniConfig+patroniCfg =+    Patroni.PatroniConfig+        { Patroni.pat_scope = "demo"+        , Patroni.pat_namespace = "/service/"+        , Patroni.pat_name = "n2"+        , Patroni.pat_etcd_hosts = ["10.0.0.1:2379", "10.0.0.2:2379"]+        , Patroni.pat_etcd_tls = Nothing+        , Patroni.pat_rest_listen = "0.0.0.0:8008"+        , Patroni.pat_rest_connect_address = "10.0.0.2:8008"+        , Patroni.pat_pg_version = "16"+        , Patroni.pat_pg_cluster = "main"+        , Patroni.pat_pg_listen = "0.0.0.0:5432"+        , Patroni.pat_pg_connect_address = "10.0.0.2:5432"+        , Patroni.pat_pg_hba = []+        , Patroni.pat_bootstrap_parameters = []+        , Patroni.pat_config_dir = "/etc/patroni"+        , Patroni.pat_secrets_file = "/etc/patroni/secrets.yml"+        , Patroni.pat_user = "postgres"+        , Patroni.pat_binary = "/usr/bin/patroni"+        , Patroni.pat_ready_timeout_seconds = 60+        , Patroni.pat_archive = Nothing+        }++unitCfg :: Systemd.Config+unitCfg = Systemd.Config Systemd.System "/etc/systemd/system" "demo.service" unit svc install+  where+    unit = Systemd.Unit "a service" "network-online.target"+    svc = Systemd.Service Systemd.Simple "nobody" "nogroup" "0022" (Systemd.Start "/bin/true" []) Systemd.OnFailure Systemd.Process "/"+    install = Systemd.Install "multi-user.target"++tests :: TestTree+tests =+    testGroup+        "Salmon.Builtin.Cards"+        [ testGroup "a card changes nothing the builtin renders" (fmap presentationOnly cases)+        , testCase "tramajString escapes what would end the literal" $ do+            assertEqual "plain" "\"abc\"" (Cards.tramajString "abc")+            assertEqual "quote, backslash, backtick" "\"\\\"\\\\\\`\"" (Cards.tramajString "\"\\`")+            assertEqual "newline, control" "\"a\\nb\\u{7}\"" (Cards.tramajString "a\nb\a")+        , testCase "no card carries a password, a file's contents or an instance's metadata" $+            forM_ cases $ \c -> forM_ ("not on the card" : secretWords) $ \w ->+                assertBool (Text.unpack c.caseName <> " shows " <> show w) (not (w `Text.isInfixOf` Cards.renderCard c.caseCard))+        , testCase "every GCP card links to the console, for its own project" $+            forM_ gcpCases $ \c -> do+                assertBool (Text.unpack c.caseName <> ": no link") (not (null c.caseCard.cardLinks))+                forM_ c.caseCard.cardLinks $ \l -> do+                    assertBool (show l) ("https://console.cloud.google.com/" `Text.isPrefixOf` l.linkUrl)+                    assertBool (show l) ("?project=demo-proj" `Text.isSuffixOf` l.linkUrl)+        , testCase "a console link, by hand" $ do+            assertEqual "instance" ["https://console.cloud.google.com/compute/instancesDetail/zones/europe-west1-b/instances/demo-vm?project=demo-proj"] (fmap (.linkUrl) (GcpCards.instanceCard demoInstance).cardLinks)+            assertEqual "encoded" "https://console.cloud.google.com/a%2Fb/%C3%A9%20%3F?project=p%26q%3Dr" (GcpCards.consoleUrl ["a/b", "é ?"] (Core.Project "p&q=r"))+        , testProperty "percentEncode: only unreserved characters and %XX, and decodes back" $+            forAll genText $ \t ->+                let e = Cards.percentEncode t+                 in (Text.all (\ch -> isAsciiLower ch || isAsciiUpper ch || isDigit ch || ch `elem` ("-._~%" :: String)) e, percentDecode e) === (True, Just t)+        , testCase "every card links to its builtin's docs page, last, and the page has a source" docsPages+        , testCase "a docs link, by hand" $+            assertEqual "url" (Cards.Link "docs" "https://lucasdicioccio.github.io/salmon/builtin-filesystem-file-contents.html") (Cards.docsLink "filesystem-file-contents")+        , testCase "the docs link base is the kitchen-sink site's published URL" docsSite+        , testCase "every card draws under tramaj-js; tramajString round-trips (node)" runNode+        ]++docsPages :: IO ()+docsPages = do+    let dir = "../resources/builtins"+    there <- doesFileExist (dir </> "README.md")+    forM_ cases $ \c -> case c.caseCard.cardDocs of+        Nothing -> assertFailure (Text.unpack c.caseName <> ": no docs page")+        Just slug -> do+            assertBool (show slug <> ": a slug is lowercase letters, digits and dashes") (not (Text.null slug) && Text.all (\ch -> isAsciiLower ch || isDigit ch || ch == '-') slug)+            assertEqual (Text.unpack c.caseName <> ": the docs link comes last") (Just (Cards.docsLink slug)) (lastMaybe (Cards.allLinks c.caseCard))+            assertBool (Text.unpack c.caseName <> ": the docs link is drawn") (Cards.tramajString (Cards.docsLink slug).linkUrl `Text.isInfixOf` Cards.renderCard c.caseCard)+            if not there+                then putStrLn "SKIPPED: resources/builtins is not next to the test suite; the page-source check needs the source tree"+                else do+                    page <- doesFileExist (dir </> Text.unpack slug <> ".md")+                    assertBool (Text.unpack c.caseName <> ": no page source " <> dir </> Text.unpack slug <> ".md") page+  where+    lastMaybe xs = if null xs then Nothing else Just (last xs)++{- | The pages under @resources\/builtins\/@ are a kitchen-sink input+(@website\/scripts\/sync-repo-docs.sh@ mirrors each to+@website\/src\/builtin-<slug>.cmark@, so they are on the site's search index+and navigation), and 'Cards.docsLink' must point at where that site is+published: @publishURL@ and @basePath@ of @website\/src\/kitchen-sink.json@.+A move of the site breaks this test instead of every card's link.+-}+docsSite :: IO ()+docsSite = do+    let cfg = "../website/src/kitchen-sink.json"+    there <- doesFileExist cfg+    if not there+        then putStrLn "SKIPPED: website/src/kitchen-sink.json is not next to the test suite; the site check needs the source tree"+        else do+            bytes <- LByteString.readFile cfg+            case Aeson.decode bytes of+                Just (Aeson.Object o)+                    | Just (Aeson.String publishUrl) <- KeyMap.lookup "publishURL" o+                    , Just (Aeson.String basePath) <- KeyMap.lookup "basePath" o ->+                        assertEqual "docsBaseUrl" (Text.dropWhileEnd (== '/') publishUrl <> basePath) Cards.docsBaseUrl+                _ -> assertFailure (cfg <> ": no publishURL/basePath strings")++percentDecode :: Text -> Maybe Text+percentDecode t = either (const Nothing) Just . Text.decodeUtf8' . ByteString.pack =<< go (Text.unpack t)+  where+    go [] = Just []+    go ('%' : a : b : rest)+        | isHexDigit a && isHexDigit b, [(n, "")] <- readHex [a, b] = (fromInteger n :) <$> go rest+    go ('%' : _) = Nothing+    go (ch : rest)+        | ch < chr 128 = (fromIntegral (fromEnum ch) :) <$> go rest+        | otherwise = Nothing++presentationOnly :: Case -> TestTree+presentationOnly c = testCase (Text.unpack c.caseName) $ do+    let carded = Cards.withCard (Cards.renderCard c.caseCard) c.casePlain+    assertEqual "the root: representative, shorthand, ref, help, notes" (fmap describe (rootOf c.casePlain)) (fmap describe (rootOf carded))+    assertEqual "the card is carried" (Just (Cards.renderCard c.caseCard)) (cardTemplateOf . (.extension.dynamics) =<< rootOf carded)+    assertEqual+        "the dependencies carry no card and are unchanged"+        [describe a | a <- drop 1 (allActs c.casePlain)]+        [describe a | a <- drop 1 (allActs carded)]+    assertEqual "nor do they carry a template" [] [() | a <- drop 1 (allActs carded), Just _ <- [cardTemplateOf a.extension.dynamics]]+  where+    describe :: Act Extension -> (Dag.Representative, Text, Ref, Text, [Text])+    describe a = (Dag.representative a, a.shorthand, a.extension.ref, a.extension.help, a.extension.notes)++rootOf :: Op -> Maybe (Act Extension)+rootOf o = case o.node of+    Actions a -> Just a+    Actionless -> Nothing++allActs :: Op -> [Act Extension]+allActs o = [a | n <- toList (evalDeps o), Actions a <- [n.node]]++-- arbitrary text, weighted towards what a Tramaj literal must escape+genText :: Gen Text+genText =+    Text.pack+        <$> listOf+            ( frequency+                [ (4, elements "\"\\`$@.(){}\n\t\r\0\a\DEL")+                , (2, elements "ab é日")+                , (1, arbitrary)+                ]+            )++runNode :: IO ()+runNode = do+    let script = "../salmon-ops/ui-test/builtin-cards.test.mjs"+    there <- doesFileExist script+    if not there+        then putStrLn "SKIPPED: salmon-ops/ui-test is not next to the test suite; the builtin card checks need the source tree"+        else requireExecutable "node" $ withTempDir $ \dir -> do+            texts <- generate (vectorOf 300 genText)+            let input = dir </> "cards.json"+                quote :: Text -> Aeson.Value+                quote t = object ["text" .= t, "source" .= (".p(" <> Cards.tramajString t <> ")")]+                card :: Case -> Aeson.Value+                card c =+                    object+                        [ "name" .= c.caseName+                        , "source" .= Cards.renderCard c.caseCard+                        , "facts" .= c.caseCard.cardFacts+                        , "verdicts" .= sentences c.caseCard.cardVerdicts+                        , "links" .= [(l.linkLabel, l.linkUrl) | l <- Cards.allLinks c.caseCard]+                        ]+            LByteString.writeFile input (Aeson.encode (object ["cards" .= fmap card cases, "quotes" .= fmap quote ("" : texts :: [Text])]))+            (code, out, err) <- readCreateProcessWithExitCode (proc "node" [script, input]) ""+            unless (code == ExitSuccess) $+                assertFailure ("node " <> script <> " failed (" <> show code <> "):\n" <> out <> err)++sentences :: Cards.Verdicts -> Aeson.Value+sentences v =+    object+        [ "unchecked" .= v.verdictUnchecked+        , "inPlace" .= v.verdictInPlace+        , "toApply" .= v.verdictToApply+        , "unsure" .= v.verdictUnsure+        , "noCheck" .= v.verdictNoCheck+        ]

@@ -0,0 +1,97 @@+{- | Layer 0 coverage for a node's card template (feature 458c16c8,+"Salmon.Op.CardTemplate"): it is opt-in, presentation only, and does not+change what a declaration renders. A node without one is exactly what it+was; a node with one has the same representative, @ref@, @help@ and+@notes@ as without; two declarations differing only by their template+do not conflict.+-}+module Test.CardTemplateSpec (tests) where++import Data.Dynamic (Dynamic, toDyn)+import Data.Foldable (toList)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import Test.QuickCheck (Gen, Property, arbitrary, choose, counterexample, elements, forAll, listOf, vectorOf, (===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)+import Test.Tasty.QuickCheck (testProperty)++import Salmon.Builtin.Extension (Extension (..), Op, amendNode, deps, evalDeps, nodeps, op, withCardTemplate)+import Salmon.Op.Actions (Act (..), Actions (..))+import Salmon.Op.CardTemplate (cardTemplateOf)+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.OpGraph (OpGraph (..))+import Salmon.Op.Ref (Ref, mkRef)+import Salmon.Op.Supervision (Supervision (..), defaultSupervision)++tests :: TestTree+tests =+    testGroup+        "Salmon.Op.CardTemplate"+        [ testCase "a node without a template has none" $+            assertEqual "" Nothing (cardTemplateOf (dynamicsOf (leaf "x" [])))+        , testCase "withCardTemplate replaces, the last one wins" $ do+            let o = amendNode (withCardTemplate "b") (amendNode (withCardTemplate "a") (leaf "x" []))+            assertEqual "the template" (Just "b") (cardTemplateOf (dynamicsOf o))+            assertEqual "only one is carried" 1 (length (dynamicsOf o))+        , testCase "amending the root with a template leaves its predecessor alone" $ do+            let pre = leaf "pre" []+                root = op "root" (deps [pre]) $ \x -> x{ref = mkRef "card-test" ("root" :: Text)}+                templates = [cardTemplateOf x.dynamics | n <- toList (evalDeps (amendNode (withCardTemplate "t") root)), x <- toList n.node]+            assertEqual "root first" [Just "t", Nothing] templates+        , testCase "two look-alikes differing only by template in one graph: no conflict, one template kept" $ do+            let a = amendNode (withCardTemplate "first") (leaf "same" ["n"])+                b = amendNode (withCardTemplate "second") (leaf "same" ["n"])+                top = op "top" (deps [a, b]) $ \x -> x{ref = mkRef "card-test" ("top" :: Text)}+                dag = Dag.foldDag Dag.sameRepresentative (evalDeps top)+            assertEqual "no conflict" 0 (length (Dag.dagConflicts dag))+            -- within one fold the look-alike skip keeps the one walked first+            -- (module notes, "Dag"); across declarations under serve the+            -- newest wins, which "Test.ServeHttpSpec" checks+            let kept = cardTemplateOf . (.extension.dynamics) =<< Map.lookup (refOf "same") (Dag.dagNodes dag)+            assertBool ("one of the two: " <> show kept) (kept `elem` [Just "first", Just "second"])+        , testProperty "a template changes neither the representative nor ref, help, notes" prop_presentationOnly+        , testProperty "other dynamics are kept, in order, and still compared" prop_otherDynamicsKept+        ]++refOf :: Text -> Ref+refOf k = mkRef "card-test" k++leaf :: Text -> [Text] -> Op+leaf k ns = op "leaf" nodeps $ \x -> x{ref = refOf k, help = "help " <> k, notes = ns}++dynamicsOf :: Op -> [Dynamic]+dynamicsOf o = concat [x.dynamics | x <- toList o.node]++actOf :: Op -> [Act Extension]+actOf o = case o.node of+    Actions a -> [a]+    Actionless -> []++genText :: Gen Text+genText = Text.pack <$> listOf (elements "ab {}()$.\"\\\n<>&é")++prop_presentationOnly :: Property+prop_presentationOnly =+    forAll genText $ \k ->+        forAll (listOf genText) $ \ns ->+            forAll genText $ \src ->+                let plain = leaf k ns+                    carded = amendNode (withCardTemplate src) plain+                 in counterexample (show (src, k, ns)) $+                        (fmap Dag.representative (actOf carded), fmap describe (actOf carded), cardTemplateOf (dynamicsOf carded))+                            === (fmap Dag.representative (actOf plain), fmap describe (actOf plain), Just src)+  where+    describe :: Act Extension -> (Text, Ref, Text, [Text])+    describe a =(a.shorthand, a.extension.ref, a.extension.help, a.extension.notes)++prop_otherDynamicsKept :: Property+prop_otherDynamicsKept =+    forAll (choose (0, 3 :: Int)) $ \n ->+        forAll (vectorOf n arbitrary) $ \reapplies ->+            forAll genText $ \src ->+                let sups = [defaultSupervision{supReapply = r} | r <- reapplies]+                    plain = amendNode (\x -> x{dynamics = fmap toDyn sups}) (leaf "d" [])+                    carded = amendNode (withCardTemplate src) plain+                 in fmap Dag.representative (actOf carded) === fmap Dag.representative (actOf plain)

@@ -0,0 +1,433 @@+{-# LANGUAGE OverloadedStrings #-}++{- | "Salmon.Client.Model" as it was before its display order stopped being+a list: the reference 'step' that "Test.ClientModelStepSpec" holds the+current one to.++__This is a copy, on purpose, and it is not to be improved.__ It is the+text of @salmon-ops\/src\/Salmon\/Client\/Model.hs@ at the commit before+'modelOrder' became an @Order@ (types, 'fromDag', 'step', 'rebase',+'nodesInOrder', 'counts' and the JSON readers, unchanged; the module+header and the rendering functions, which the comparison does not need,+left out). 'step' here removes a node with @filter (\/= r) modelOrder@:+quadratic over a teardown, and plainly right, which is what a reference is+for.++Because it is a copy it has types of its own ('Model', 'Node', 'Event')+with the same constructors and field names as the real ones, so the spec+compares the two through what they 'show'.++A rule added to the real fold after this copy was taken (a new event kind,+a new field) will fail the comparison until it is added here too. That is+the price of a reference that does not share code with what it checks; if+it stops being worth paying, delete this module and the comparison with+it, and keep the properties that need no reference.+-}+module Test.ClientModelReference (+    Event (..),+    eventOf,+    RefId (..),+    Model (..),+    Node (..),+    Check (..),+    Pass (..),+    Counts (..),+    fromDag,+    step,+    rebase,+    nodesInOrder,+    counts,+) where++import Data.Aeson (Result (..), Value (..), fromJSON)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Foldable (toList)+import Data.List (foldl')+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Word (Word64)++-------------------------------------------------------------------------------+-- events++-- | A node's identity on the wire: the short tag and the full text.+data RefId = RefId+    { refShort :: !Text+    , refFull :: !Text+    }+    deriving (Show, Eq, Ord)++{- | One event as the stream carried it. The fields are what every client+needs to route the object; 'eventValue' keeps the whole thing for whatever+else a report says.+-}+data Event = Event+    { eventSeq :: !(Maybe Word64)+    -- ^ 'Nothing' only for the @gap@ event, which the server sends without one+    , eventStream :: !Text+    , eventKind :: !Text+    , eventRef :: !(Maybe RefId)+    , eventOrigin :: !(Maybe Text)+    -- ^ the origin's name, for an event produced for a command+    , eventValue :: !Value+    }+    deriving (Show, Eq)++-- | Read an event out of its wire object. Total: a shapeless object is an+-- event of kind @?@ with no ref, which the model records and moves past.+eventOf :: Value -> Event+eventOf v =+    Event+        { eventSeq = numberAt ["seq"] v+        , eventStream = fromMaybe "?" (textAt ["stream"] v)+        , eventKind = fromMaybe "?" (textAt ["kind"] v)+        , eventRef = refAt ["ref"] v+        , eventOrigin = textAt ["origin", "name"] v+        , eventValue = v+        }++-------------------------------------------------------------------------------+-- the model++-- | A node's own last word on its effect, as @next-look@ and @\/dag@ carry it.+data Check = Check+    { checkVerdict :: !Text+    -- ^ @success@\/@skipped@\/@completed@\/@failure@\/@unknown@\/@immaterial@+    , checkReason :: !(Maybe Text)+    }+    deriving (Show, Eq)++data Node = Node+    { nodeRef :: !RefId+    , nodeShorthand :: !Text+    , nodeHelp :: !Text+    , nodeNotes :: ![Text]+    , nodeDirection :: !Text+    -- ^ @up@ or @down@+    , nodeConvergence :: !Text+    -- ^ @pending@\/@stale@\/@converged@\/@errored@\/@blocked@+    , nodeCheck :: !(Maybe Check)+    , nodeOutput :: ![Text]+    -- ^ the snapshot's output ring, then each @output@ line since, oldest first+    , nodeSaid :: ![Text]+    -- ^ the @log@ lines the stream carried (what the node said during a+    -- one-shot @up@), oldest first; a line from standard error is prefixed+    -- @err| @ and the node's own message @msg| @. In no snapshot.+    , nodeSaidSeq :: !Word64+    -- ^ the number 'nodeSaid' is current to; 0 until a line arrives+    , nodeError :: !(Maybe Text)+    -- ^ the last @failed@'s error, cleared by a later @done@\/@skip@+    , nodeLastKind :: !(Maybe Text)+    -- ^ the kind of the last event about this node, and its stream+    , nodeLastSeq :: !(Maybe Word64)+    , nodeSeq :: !Word64+    -- ^ the number this view is current to: the snapshot's, then each event's+    , nodeDependencies :: ![RefId]+    , nodeDependants :: ![RefId]+    , nodePaths :: ![Text]+    }+    deriving (Show, Eq)++-- | The loop's last convergence pass as the stream told it.+data Pass+    = -- | @converge-start@: nodes to turn down, nodes to turn up+      Converging !Int !Int+    | -- | @converge-stop@: everything applied cleanly, nodes left+      Stopped !Bool !Int+    deriving (Show, Eq)++data Model = Model+    { modelMode :: !Text+    -- ^ @interactive@\/@replay@\/@following@, from the snapshot's envelope+    , modelSeq :: !Word64+    -- ^ the highest sequence number seen: the snapshot's, then each+    -- event's; the cursor to resume @\/events@ from+    , modelLoopSeq :: !Word64+    -- ^ the number the loop-level fields are current to+    , modelOrder :: ![RefId]+    -- ^ the snapshot's dependency order ('Salmon.Op.Dag.dagOrder')+    , modelNodes :: !(Map RefId Node)+    , modelPass :: !(Maybe Pass)+    , modelSupervised :: !(Maybe Bool)+    -- ^ 'Nothing' until a @supervised@ event says+    , modelLast :: !(Maybe Event)+    -- ^ the last event folded, whatever it was about+    , modelResyncReason :: !(Maybe Text)+    -- ^ why the snapshot should be re-read; cleared by 'resolve' or 'fromDag'+    }+    deriving (Show, Eq)++-- | The snapshot should be re-read: a @gap@, or a declaration changed the+-- node set. The reason is human text for a status line.+modelResync :: Model -> Maybe Text+modelResync = modelResyncReason++-- | Forget the resync request (the snapshot is being re-read).+resolve :: Model -> Model+resolve m = m{modelResyncReason = Nothing}++{- | A re-read snapshot joining a model that has been folding: the nodes,+order and mode are the fresh snapshot's; the loop-level fields, their+stamp and the last event are the old model's; the cursor is the higher of+the two; and the resync request is answered. See the module header for+why the loop's part is not simply the snapshot's. What a node said+('nodeSaid') is the old model's too, for the nodes the fresh snapshot+still has: no snapshot carries it.+-}+rebase :: Model -> Model -> Model+rebase old fresh =+    fresh+        { modelNodes = Map.mapWithKey keepSaid fresh.modelNodes+        , modelSeq = max old.modelSeq fresh.modelSeq+        , modelLoopSeq = old.modelLoopSeq+        , modelPass = old.modelPass+        , modelSupervised = old.modelSupervised+        , modelLast = old.modelLast+        , modelResyncReason = Nothing+        }+  where+    keepSaid :: RefId -> Node -> Node+    keepSaid r n = case Map.lookup r old.modelNodes of+        Just o -> n{nodeSaid = o.nodeSaid, nodeSaidSeq = o.nodeSaidSeq}+        Nothing -> n++{- | A model from a @\/dag@ answer. 'Left' names what is missing; a @\/dag@+answer always has @nodes@ and @seq@, so a 'Left' is a wrong URL, not a+version skew.+-}+fromDag :: Value -> Either String Model+fromDag v = do+    nodes <- maybe (Left "/dag answer has no nodes array") Right (arrayAt ["nodes"] v)+    seqNo <- maybe (Left "/dag answer carries no seq") Right (numberAt ["seq"] v)+    parsed <- traverse (nodeOf seqNo) nodes+    pure+        Model+            { modelMode = fromMaybe "?" (textAt ["mode"] v)+            , modelSeq = seqNo+            , modelLoopSeq = 0+            , modelOrder = fmap nodeRef parsed+            , modelNodes = Map.fromList [(nodeRef n, n) | n <- parsed]+            , modelPass = Nothing+            , modelSupervised = Nothing+            , modelLast = Nothing+            , modelResyncReason = Nothing+            }+  where+    nodeOf :: Word64 -> Value -> Either String Node+    nodeOf seqNo n = do+        r <- maybe (Left ("a node without a ref: " <> show n)) Right (refAt ["ref"] n)+        pure+            Node+                { nodeRef = r+                , nodeShorthand = fromMaybe "?" (textAt ["shorthand"] n)+                , nodeHelp = fromMaybe "" (textAt ["help"] n)+                , nodeNotes = maybe [] (mapMaybe asText) (arrayAt ["notes"] n)+                , nodeDirection = fromMaybe "?" (textAt ["direction"] n)+                , nodeConvergence = fromMaybe "?" (textAt ["convergence"] n)+                , nodeCheck = checkAt ["status", "check"] n+                , nodeOutput = maybe [] (mapMaybe asText) (arrayAt ["status", "output"] n)+                , nodeSaid = []+                , nodeSaidSeq = 0+                , nodeError = Nothing+                , nodeLastKind = Nothing+                , nodeLastSeq = Nothing+                , nodeSeq = seqNo+                , nodeDependencies = maybe [] (mapMaybe (refAt [])) (arrayAt ["dependencies"] n)+                , nodeDependants = maybe [] (mapMaybe (refAt [])) (arrayAt ["dependants"] n)+                , nodePaths = maybe [] (mapMaybe asText) (arrayAt ["paths"] n)+                }++{- | Fold one event in. Total; an event already accounted for (numbered at+or below the stamp of the part it would change, see the module header)+leaves that part as it was. Otherwise the cursor moves to the event's+number, the node the event is about is updated, and the loop-level fields+follow the @serve@ stream. An event that changes nothing still becomes+'modelLast' if it is new to the cursor.+-}+step :: Model -> Event -> Model+step m0 e+    | Just s <- e.eventSeq, s <= m0.modelSeq = byStream m0+    | otherwise = byStream (m0{modelSeq = fromMaybe m0.modelSeq e.eventSeq, modelLast = Just e})+  where+    byStream m = case (e.eventStream, e.eventKind) of+        ("server", "gap") -> m{modelResyncReason = Just ("events " <> fromText (numberAt ["from"] e.eventValue) <> " fell off the ring")}+        ("server", _) -> m+        ("serve", "declared") ->+            onLoop m $ \l -> l{modelResyncReason = Just ("epoch " <> fromText (numberAt ["epoch"] e.eventValue) <> " declared " <> fromMaybe "?" (textAt ["direction"] e.eventValue))}+        ("serve", "cleared") -> onLoop m $ \l -> l{modelResyncReason = Just "every seed retired"}+        ("serve", "converge-start") ->+            onLoop m $ \l -> l{modelPass = Just (Converging (intAt ["down"] e.eventValue) (intAt ["up"] e.eventValue))}+        ("serve", "converge-stop") ->+            onLoop m $ \l -> l{modelPass = Just (Stopped (fromMaybe False (boolAt ["ok"] e.eventValue)) (intAt ["remaining"] e.eventValue))}+        ("serve", "supervised") -> onLoop m $ \l -> l{modelSupervised = boolAt ["on"] e.eventValue}+        ("serve", _) -> m+        ("updown", k) -> maybe m (\r -> onNode r (settle k e.eventValue) m) e.eventRef+        -- an @acted@ wraps what the tending machine did in the pass's+        -- vocabulary; the inner object carries the ref+        ("upkeep", "acted") ->+            case KeyMap.lookup "report" =<< asObject e.eventValue of+                Just inner | Just r <- refAt ["ref"] inner ->+                    let k = fromMaybe "?" (textAt ["kind"] inner)+                     in onNode r (updown k inner . touch ("acted " <> k)) m+                _ -> m+        ("upkeep", "next-look") ->+            maybe m (\r -> onNode r (\n -> (touch e.eventKind n){nodeCheck = checkAt ["check"] e.eventValue}) m) e.eventRef+        ("upkeep", k) -> maybe m (\r -> onNode r (touch k) m) e.eventRef+        -- a held action's line: in the ring, so under the node's stamp+        ("output", "output") ->+            case (e.eventRef, textAt ["line"] e.eventValue) of+                (Just r, Just line) -> onNode r (\n -> n{nodeOutput = keepLast (n.nodeOutput ++ [line])}) m+                _ -> m+        -- a line said during a one-shot up: in no snapshot, so its own stamp+        ("output", "log") ->+            case (e.eventRef, textAt ["line"] e.eventValue) of+                (Just r, Just line) -> said r (channelMark (textAt ["channel"] e.eventValue) <> line) m+                _ -> m+        _ -> m++    said :: RefId -> Text -> Model -> Model+    said r line m = case Map.lookup r m.modelNodes of+        Nothing -> m+        Just n+            | Just s <- e.eventSeq, s <= n.nodeSaidSeq -> m+            | otherwise ->+                let n' = n{nodeSaid = keepLast (n.nodeSaid ++ [line]), nodeSaidSeq = fromMaybe n.nodeSaidSeq e.eventSeq}+                 in m{modelNodes = Map.insert r n' m.modelNodes}++    keepLast :: [Text] -> [Text]+    keepLast xs = drop (length xs - outputKept) xs++    -- the loop-level fields, unless the event is at or below their stamp+    onLoop :: Model -> (Model -> Model) -> Model+    onLoop m f = case e.eventSeq of+        Just s | s <= m.modelLoopSeq -> m+        _ -> (f m){modelLoopSeq = fromMaybe m.modelLoopSeq e.eventSeq}++    -- update the node (unless the event is at or below its stamp), or+    -- drop it: a node wanted down that a pass has brought down is pruned+    -- by the loop after the pass, and /dag would no longer show it+    onNode :: RefId -> (Node -> Node) -> Model -> Model+    onNode r f m = case Map.lookup r m.modelNodes of+        Nothing -> m+        Just n+            | Just s <- e.eventSeq, s <= n.nodeSeq -> m+            | otherwise ->+                let n' = (f n){nodeSeq = fromMaybe n.nodeSeq e.eventSeq}+                 in if n'.nodeDirection == "down" && n'.nodeConvergence == "converged" && n'.nodeLastKind `elem` [Just "done", Just "acted done"]+                        then m{modelNodes = Map.delete r m.modelNodes, modelOrder = filter (/= r) m.modelOrder}+                        else m{modelNodes = Map.insert r n' m.modelNodes}++    touch :: Text -> Node -> Node+    touch k n = n{nodeLastKind = Just k, nodeLastSeq = e.eventSeq}++    -- the pass's verdict on a node, in /dag's convergence words+    settle :: Text -> Value -> Node -> Node+    settle k v n = updown k v (touch k n)++    updown :: Text -> Value -> Node -> Node+    updown k v n = case k of+        "done" -> n{nodeConvergence = "converged", nodeError = Nothing}+        "skip" -> n{nodeConvergence = "converged", nodeError = Nothing}+        "failed" -> n{nodeConvergence = "errored", nodeError = textAt ["error"] v}+        "blocked" -> n{nodeConvergence = "blocked"}+        _ -> n++-------------------------------------------------------------------------------+-- reading it++-- | The nodes in the snapshot's dependency order.+nodesInOrder :: Model -> [Node]+nodesInOrder m = mapMaybe (`Map.lookup` m.modelNodes) m.modelOrder++lookupNode :: RefId -> Model -> Maybe Node+lookupNode r m = Map.lookup r m.modelNodes++-- | How many lines of 'nodeOutput' and of 'nodeSaid' a node's view keeps.+outputKept :: Int+outputKept = 200++-- | How a @log@ line's channel shows in front of it: nothing for standard+-- output, the marks the text reporter and the web UI's tail use otherwise.+channelMark :: Maybe Text -> Text+channelMark c = case c of+    Just "stderr" -> "err| "+    Just "message" -> "msg| "+    _ -> ""++{- | The last @k@ lines a live tail of this node shows: what it said during+its one-shot @up@ when it said anything, its ring otherwise (a held+action's output, which is the only other thing that moves while one+watches).+-}+tailLines :: Int -> Node -> [Text]+tailLines k n = lastN (if null n.nodeSaid then n.nodeOutput else n.nodeSaid)+  where+    lastN xs = drop (length xs - k) xs++data Counts = Counts+    { countConverged :: !Int+    , countErrored :: !Int+    , countTotal :: !Int+    }+    deriving (Show, Eq)++counts :: Model -> Counts+counts m =+    foldl' tally (Counts 0 0 0) (Map.elems m.modelNodes)+  where+    tally :: Counts -> Node -> Counts+    tally (Counts c e t) n =+        Counts+            (c + fromEnum (n.nodeConvergence == "converged"))+            (e + fromEnum (n.nodeConvergence == "errored"))+            (t + 1)++-------------------------------------------------------------------------------+-- reading JSON, totally++asObject :: Value -> Maybe (KeyMap.KeyMap Value)+asObject (Object o) = Just o+asObject _ = Nothing++asText :: Value -> Maybe Text+asText (String t) = Just t+asText _ = Nothing++at :: [Text] -> Value -> Maybe Value+at [] v = Just v+at (k : ks) (Object o) = KeyMap.lookup (Key.fromText k) o >>= at ks+at _ _ = Nothing++textAt :: [Text] -> Value -> Maybe Text+textAt ks v = at ks v >>= asText++numberAt :: [Text] -> Value -> Maybe Word64+numberAt ks v = case fromJSON <$> at ks v of+    Just (Success n) -> Just n+    _ -> Nothing++intAt :: [Text] -> Value -> Int+intAt ks v = maybe 0 fromIntegral (numberAt ks v)++boolAt :: [Text] -> Value -> Maybe Bool+boolAt ks v = case at ks v of+    Just (Bool b) -> Just b+    _ -> Nothing++arrayAt :: [Text] -> Value -> Maybe [Value]+arrayAt ks v = case at ks v of+    Just (Array xs) -> Just (toList xs)+    _ -> Nothing++refAt :: [Text] -> Value -> Maybe RefId+refAt ks v = RefId <$> textAt (ks ++ ["short"]) v <*> textAt (ks ++ ["full"]) v++checkAt :: [Text] -> Value -> Maybe Check+checkAt ks v = Check <$> textAt (ks ++ ["verdict"]) v <*> pure (textAt (ks ++ ["reason"]) v)++fromText :: Maybe Word64 -> Text+fromText = maybe "?" (Text.pack . show)

@@ -10,7 +10,11 @@ folding it once; an @acted@ is unwrapped to the pass's vocabulary; a node wanted down is dropped by its @done@; the SSE block parser reads what "Salmon.Actions.Serve.Events" renders, comments included; and the rendered-rows and header are the text expected.+rows and header are the text expected. The same snapshot, sequence and text+are written out in @rs\/fixtures\/client-model.json@, which the Rust client's+fold is tested on (@rs\/salmon-serve-client@); one case here holds that file+to this module, so the two folds are tested on the same wire data and+neither side can change it alone.  Layer 1 over a real @withHttpServer@ on a temp socket, driven through the client itself: @dag@, then @commandAsync "up ..."@, then @events@ from the@@ -23,7 +27,7 @@ import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) import Control.Exception (try) import Control.Monad (forM_, when)-import Data.Aeson (FromJSON, ToJSON, Value (..), object, (.=))+import Data.Aeson (FromJSON, ToJSON, Value (..), eitherDecodeFileStrict, object, toJSON, (.=)) import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.ByteString.Builder as Builder@@ -36,6 +40,7 @@ import Data.Text (Text) import qualified Data.Text as Text import GHC.Generics (Generic)+import System.Directory (doesFileExist) import System.FilePath ((</>)) import System.IO (Handle, hClose) import System.Posix.IO (FdOption (CloseOnExec), createPipe, fdToHandle, setFdOption)@@ -52,7 +57,8 @@ import qualified Salmon.Client.Model as Model import Salmon.Client.Model (Check (..), Model (..), Node (..), Pass (..), RefId (..)) import Salmon.Op.Configure (Configure (..))-import Salmon.Op.Ref (mkRef)+import qualified Salmon.Builtin.NodeLog as NodeLog+import Salmon.Op.Ref (mkRef, shortRef, unRef) import Salmon.Op.Track (Track (..)) import Salmon.Reporter (contramap) import qualified Salmon.Reporter.Tagged as Tagged@@ -71,6 +77,9 @@             , testCase "a node wanted down is dropped by its done" downNodeDropped             , testCase "the SSE parser reads what the server renders" sseParser             , testCase "the rendered rows and header" rendering+            , testCase "the output stream: a held action's lines join the ring, a one-shot up's lines are kept across a re-read" outputFolded+            , testCase "a /dag tail seeds what a node said; a rebase keeps whichever is later" saidFromTail+            , testCase "the fixture the Rust client is tested on is this recorded pass" sharedFixture             ]         , testGroup             "the client against a real server"@@ -156,7 +165,7 @@ recordedPass = do     m0 <- start     assertEqual "the snapshot's seq" 5 m0.modelSeq-    assertEqual "the snapshot's order" [refOf "n1", refOf "n2", refOf "root"] m0.modelOrder+    assertEqual "the snapshot's order" [refOf "n1", refOf "n2", refOf "root"] (Model.orderToList m0.modelOrder)     assertEqual "mode" "interactive" m0.modelMode     -- the declaration asks for a re-read, and the fold goes on past it     let afterDeclared = fold m0 (take 1 recorded)@@ -234,7 +243,7 @@     assertEqual "two nodes" 2 (Model.countTotal (Model.counts m0))     let m = fold m0 [about "updown" "eval" "n1" 2 [], about "updown" "done" "n1" 3 []]     assertEqual "n1 is gone once down" Nothing (Model.lookupNode (refOf "n1") m)-    assertEqual "the order follows" [refOf "n2"] m.modelOrder+    assertEqual "the order follows" [refOf "n2"] (Model.orderToList m.modelOrder)     -- while a node wanted up that is done stays     let m' = fold m0 [about "updown" "done" "n2" 4 []]     assertEqual "n2 stays, converged" (Just "converged") (nodeConvergence <$> Model.lookupNode (refOf "n2") m')@@ -283,6 +292,138 @@     assertEqual "an event line about a node" "#11 updown failed n2 n2" (Model.renderEventLine (Model.eventOf (recorded !! 5)))     assertEqual "an event line about the loop" "#13 serve converge-stop ok=false remaining=2" (Model.renderEventLine (Model.eventOf (recorded !! 7))) +{- | The @output@ stream folded: a held action's @output@ lines go on after+the snapshot's ring under the node's stamp, a one-shot @up@'s @log@ lines+(encoded here by the server's own 'Tagged.FromNode', so the wire shape is+not this test's guess) go to 'nodeSaid' under a stamp of their own, and a+re-read snapshot replaces the first and keeps the second. Neither changes+what the node's last event is said to be.+-}+outputFolded :: IO ()+outputFolded = do+    let builder = mkRef "client-model-spec" ("builder" :: Text)+        rid = RefId (shortRef builder) (unRef builder)+        refJson = object ["short" .= shortRef builder, "full" .= unRef builder]+        node ring = case nodeValue "x" "the-builder" [] of+            Object o -> Object (KeyMap.insert "ref" refJson (KeyMap.insert "status" (object ["output" .= (ring :: [Text])]) o))+            v -> v+        dagAt :: Int -> [Text] -> Value+        dagAt seqNo ring = object ["mode" .= ("interactive" :: Text), "seq" .= seqNo, "nodes" .= [node ring]]+        said seqNo channel line = Events.eventValue (Events.Event seqNo Nothing (Events.Reported (Tagged.FromNode (NodeLog.Line builder channel line))))+        held :: Int -> Text -> Value+        held seqNo line = object ["stream" .= ("output" :: Text), "kind" .= ("output" :: Text), "seq" .= seqNo, "ref" .= refJson, "line" .= line]+        eval = object ["stream" .= ("updown" :: Text), "kind" .= ("eval" :: Text), "seq" .= (6 :: Int), "ref" .= refJson]+        events =+            [ eval+            , said 7 NodeLog.Stdout "STEP 1/2: FROM scratch"+            , said 8 NodeLog.Stderr "warning: no cache"+            , said 9 NodeLog.Message "waiting for ssh"+            , held 10 "listening on :8080"+            ]+        view m = maybe (assertFailure "no builder node") pure (Model.lookupNode rid m)+    m0 <- either (assertFailure . ("snapshot: " <>)) pure (Model.fromDag (dagAt 5 ["spawn"]))+    let m = fold m0 events+    n <- view m+    assertEqual "what it said, marked by channel" ["STEP 1/2: FROM scratch", "err| warning: no cache", "msg| waiting for ssh"] n.nodeSaid+    assertEqual "current to the last line" 9 n.nodeSaidSeq+    assertEqual "the ring, then the held action's line" ["spawn", "listening on :8080"] n.nodeOutput+    assertEqual "a line is not the node's last event" (Just "eval", Just 6) (n.nodeLastKind, n.nodeLastSeq)+    assertEqual "the cursor follows the lines" 10 m.modelSeq+    assertEqual "a tail prefers what was said" ["err| warning: no cache", "msg| waiting for ssh"] (Model.tailLines 2 n)+    assertEqual "the line shows in the event line" "#8 output log " (Text.take 14 (Model.renderEventLine (Model.eventOf (events !! 2))))+    assertBool "with its mark" ("err| warning: no cache" `Text.isSuffixOf` Model.renderEventLine (Model.eventOf (events !! 2)))+    -- replayed (a reconnect from an older cursor): nothing is said twice+    assertEqual "folding the lines again changes nothing" m (fold m events)+    -- a re-read snapshot has the ring's lines and none of the said ones+    fresh <- either (assertFailure . ("snapshot: " <>)) pure (Model.fromDag (dagAt 12 ["spawn", "listening on :8080"]))+    assertEqual "no snapshot carries what was said" (Just []) (nodeSaid <$> Model.lookupNode rid fresh)+    r <- view (Model.rebase m fresh)+    assertEqual "rebase keeps what was said" n.nodeSaid r.nodeSaid+    assertEqual "and takes the snapshot's ring" ["spawn", "listening on :8080"] r.nodeOutput+    -- the held line at 10 is below the fresh snapshot's stamp: not appended twice+    r' <- view (fold (Model.rebase m fresh) events)+    assertEqual "a replay onto the rebased model appends nothing" (r.nodeOutput, r.nodeSaid) (r'.nodeOutput, r'.nodeSaid)+    -- bounded: a chatty node keeps the last 'Model.outputKept' lines+    let chatty = fold m0 [said (100 + fromIntegral i) NodeLog.Stdout (Text.pack (show i)) | i <- [1 .. Model.outputKept + 50 :: Int]]+    c <- view chatty+    assertEqual "bounded" Model.outputKept (length c.nodeSaid)+    assertEqual "the newest kept" (Just (Text.pack (show (Model.outputKept + 50)))) (lastOf c.nodeSaid)+    -- a line about a node the model does not have is moved past+    let stranger = Events.eventValue (Events.Event 400 Nothing (Events.Reported (Tagged.FromNode (NodeLog.Line (mkRef "client-model-spec" ("other" :: Text)) NodeLog.Stdout "x"))))+    assertEqual "an unknown node's line changes no node" m0.modelNodes (fold m0 [stranger]).modelNodes+  where+    lastOf [] = Nothing+    lastOf xs = Just (last xs)++{- | A @\/dag@ answer whose node carries a @tail@ (what @\/events@ sent about+it, none above the answer's @seq@): its @log@ lines seed 'nodeSaid', current+to the snapshot's number, so the same lines replayed are not said twice and+a page opened after a build still shows it. A rebase keeps whichever side is+current to the later number.+-}+saidFromTail :: IO ()+saidFromTail = do+    let builder = mkRef "client-model-spec" ("tailed" :: Text)+        rid = RefId (shortRef builder) (unRef builder)+        refJson = object ["short" .= shortRef builder, "full" .= unRef builder]+        said seqNo channel line = Events.eventValue (Events.Event seqNo Nothing (Events.Reported (Tagged.FromNode (NodeLog.Line builder channel line))))+        eval = object ["stream" .= ("updown" :: Text), "kind" .= ("eval" :: Text), "seq" .= (6 :: Int), "ref" .= refJson]+        lines3 = [said 7 NodeLog.Stdout "STEP 1/2: FROM scratch", said 8 NodeLog.Stderr "warning: no cache", said 9 NodeLog.Message "waiting for ssh"]+        node tl = case nodeValue "x" "the-builder" [] of+            Object o -> Object (KeyMap.insert "ref" refJson (KeyMap.insert "tail" (toJSON (tl :: [Value])) o))+            v -> v+        dagAt :: Int -> [Value] -> Value+        dagAt seqNo tl = object ["mode" .= ("interactive" :: Text), "seq" .= seqNo, "nodes" .= [node tl]]+        view m = maybe (assertFailure "no tailed node") pure (Model.lookupNode rid m)+        load v = either (assertFailure . ("snapshot: " <>)) pure (Model.fromDag v)+    m <- load (dagAt 12 (eval : lines3))+    n <- view m+    assertEqual "the tail's log lines, marked by channel" ["STEP 1/2: FROM scratch", "err| warning: no cache", "msg| waiting for ssh"] n.nodeSaid+    assertEqual "current to the snapshot" 12 n.nodeSaidSeq+    assertEqual "replayed, they are not said twice" (Just n.nodeSaid) (nodeSaid <$> Model.lookupNode rid (fold m lines3))+    -- an older model that folded the same lines live, rebased onto it+    m0 <- load (dagAt 5 [])+    let live = fold m0 lines3+    r <- view (Model.rebase live m)+    assertEqual "the snapshot is the later: its lines" (n.nodeSaid, 12) (r.nodeSaid, r.nodeSaidSeq)+    -- a model that has heard more than the snapshot keeps what it heard+    let ahead = fold m [said 13 NodeLog.Stdout "STEP 2/2: COPY"]+    a <- view ahead+    r' <- view (Model.rebase ahead m)+    assertEqual "the model is the later: its lines" (a.nodeSaid, 13) (r'.nodeSaid, r'.nodeSaidSeq)++{- | @rs\/fixtures\/client-model.json@ against this module: its @snapshot@+and @recorded@ are 'snapshot' and 'recorded' object for object, and its+@expect@ is what "Salmon.Client.Model" renders after the fold. The Rust+tests read the same file, so a change to the fold's text or to the wire+shapes here fails this case until the file (and with it the Rust side) is+brought along.+-}+sharedFixture :: IO ()+sharedFixture = do+    let path = "../rs/fixtures/client-model.json"+    there <- doesFileExist path+    if not there+        then putStrLn "SKIPPED: rs/fixtures/client-model.json is not next to the test suite; the comparison needs the source tree"+        else do+            fixture <- either (assertFailure . ("the fixture is not JSON: " <>)) pure =<< eitherDecodeFileStrict path+            let field :: [Key.Key] -> Value -> Maybe Value+                field [] v = Just v+                field (k : ks) (Object o) = KeyMap.lookup k o >>= field ks+                field _ _ = Nothing+                expect ks = field ("expect" : ks) fixture+            assertEqual "snapshot" (Just snapshot) (field ["snapshot"] fixture)+            assertEqual "recorded" (Just (toJSON recorded)) (field ["recorded"] fixture)+            m0 <- start+            let m = fold m0 recorded+            target <- case expect ["target"] of+                Just (String t) -> pure t+                other -> assertFailure ("expect.target: " <> show other)+            assertEqual "expect.rows" (Just (toJSON (fmap Model.renderNodeRow (Model.nodesInOrder m)))) (expect ["rows"])+            assertEqual "expect.header" (Just (String (Model.renderHeader target m))) (expect ["header"])+            assertEqual "expect.eventLines" (Just (toJSON (fmap (Model.renderEventLine . Model.eventOf) recorded))) (expect ["eventLines"])+            assertEqual "expect.resync" (Just (toJSON (Model.modelResync m))) (expect ["resync"])+ ------------------------------------------------------------------------------- -- Layer 1: the client against a real server @@ -345,6 +486,10 @@                         Nothing                         [Serve.stdinProducer stdinR, Http.serverProducer server]                 putMVar worldVar w+            -- the loop publishes its inbox from a thread it forks: wait for+            -- it, or the first request can beat it and be answered 503+            timeout (10 * 1000000) (Http.awaitLoop server)+                >>= maybe (assertFailure "the loop did not start within 10s") pure             client <- Client.newUnixClient path             r <- act (Running stdinW worldVar client upsRef)             _ <- try (hClose stdinW) :: IO (Either IOError ())

@@ -0,0 +1,636 @@+{- | 'Salmon.Client.Model.step' removes a node by lookup, and shows what it+showed when it filtered a list.++The model's display order used to be a list, and dropping a node (one+wanted @down@ whose @done@ arrives) filtered all of it: a teardown, one+such event per node, was quadratic (finding 5 of+@resources\/graph-profiles.md@). The order is now 'Model.Order'. What must+not have moved is anything a client can see, so the bar here is+observable equivalence with the fold as it was, which is kept, untouched,+as "Test.ClientModelReference":++  * __QuickCheck__, over generated scripts ('Script': a snapshot, then+    events and re-read snapshots): after every step the two folds show the+    same nodes in the same order with the same fields, and agree on the+    loop's part; the order is the last snapshot's with exactly the dropped+    nodes missing, holds no node the model does not have, and repeats none;+    a teardown in any order agrees step by step; and 'Model.Order' on its+    own is the list operations it replaces. A further property checks that+    the scripts do reach what they are for (removals, a removed node read+    again, events about a node that is not there).+  * __Unit cases__ for the positions a removal can be in (first, middle,+    last, absent, all of them), for a removed node coming back with a+    re-read snapshot, and for a snapshot that lists a ref twice.+  * __One scale case__: a teardown of a hundred thousand nodes within a+    minute, in the manner of "Test.GraphScaleSpec" (it tells per node from+    per node squared; it times nothing).++All of it is Layer 0: pure, in-process. __Not covered:__ the events are+generated from the kinds the fold names plus one it does not, not recorded+from a server; the scripts use a pool of eight refs and a ghost, so they+say nothing about size (the scale case does, for a teardown only); and+'Model.fromDag' is only given well-formed snapshots, apart from repeated+refs. The shared fixture @rs\/fixtures\/client-model.json@ is held to this+fold by "Test.ClientModelSpec", unchanged.+-}+module Test.ClientModelStepSpec (tests) where++import Control.Exception (evaluate)+import Data.Aeson (Value (..), object, (.=))+import qualified Data.Aeson.Key as Key+import Data.List (foldl', nub)+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Word (Word64)+import System.Timeout (timeout)+import Test.Tasty (TestTree, localOption, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)+import Test.Tasty.QuickCheck (+    Arbitrary (..),+    Gen,+    Property,+    QuickCheckTests (..),+    checkCoverage,+    choose,+    conjoin,+    counterexample,+    cover,+    elements,+    frequency,+    listOf,+    oneof,+    property,+    shrinkList,+    shuffle,+    sized,+    sublistOf,+    testProperty,+    (===),+ )++import qualified Salmon.Client.Model as Model+import Salmon.Client.Model (RefId (..))++import qualified Test.ClientModelReference as Reference++tests :: TestTree+tests =+    testGroup+        "Salmon.Client.Model.step: removal without filtering the order"+        [ testGroup+            "unit"+            [ testCase "removing the first, a middle and the last node keeps the others in place" removesEachPosition+            , testCase "a done about a node that is absent changes neither the nodes nor the order" absentNodeChangesNothing+            , testCase "a full teardown empties the model, first to last and last to first" fullTeardown+            , testCase "a removed node is shown again, in the snapshot's place, once a re-read snapshot has it" removedThenReread+            , testCase "a ref a snapshot lists twice is shown twice and removed from both places" repeatedRef+            , testCase "an Order reads as its list, and equality is what is read" orderUnit+            ]+        , localOption (QuickCheckTests cases) $+            testGroup+                "properties"+                [ testProperty "step shows what the reference step shows, after every event of a script" prop_stepMatchesReference+                , testProperty "the order is the last snapshot's less the dropped nodes: no removed node, no duplicate" prop_orderInvariant+                , testProperty "a teardown in any order agrees with the reference at every step and ends empty" prop_teardownInAnyOrder+                , testProperty "Order: toList . fromList is the list" prop_orderRoundTrips+                , testProperty "Order: removals are the filters they replace" prop_orderRemoveIsFilter+                , testProperty "Order: two orders are equal exactly when they read the same" prop_orderEquality+                ]+        , testProperty "the generated scripts reach removals, re-read removed nodes and absent nodes" prop_scriptsReachTheCases+        , testCase "a teardown of a hundred thousand nodes folds within a minute" teardownAtScale+        ]++-- | Cases per property (QuickCheck's default is a hundred): the folds are+-- pure and a script is a hundred-odd steps at most, so this stays at a few+-- seconds each (the comparison shows every node at every step).+cases :: Int+cases = 1000++-------------------------------------------------------------------------------+-- wire objects++refOf :: Text -> RefId+refOf short = RefId short ("full-" <> short)++refValue :: Text -> Value+refValue short = object ["short" .= short, "full" .= ("full-" <> short)]++nodeValue :: Text -> Text -> Text -> Value+nodeValue direction convergence short =+    object+        [ "ref" .= refValue short+        , "shorthand" .= ("node " <> short)+        , "help" .= ("" :: Text)+        , "notes" .= ([] :: [Text])+        , "direction" .= direction+        , "convergence" .= convergence+        , "status" .= Null+        , "paths" .= (["/" <> short] :: [Text])+        , "dynamics" .= ([] :: [Text])+        , "dependencies" .= ([] :: [Value])+        , "dependants" .= ([] :: [Value])+        ]++snapshotValue :: Word64 -> [Value] -> Value+snapshotValue seqNo nodes = object ["mode" .= ("interactive" :: Text), "seq" .= seqNo, "nodes" .= nodes]++-- | A snapshot of nodes all wanted down, in this order.+retiring :: Word64 -> [Text] -> Value+retiring seqNo shorts = snapshotValue seqNo (fmap (nodeValue "down" "pending") shorts)++updown :: Text -> Text -> Word64 -> Value+updown kind short seqNo =+    object ["stream" .= ("updown" :: Text), "kind" .= kind, "seq" .= seqNo, "ref" .= refValue short]++-------------------------------------------------------------------------------+-- the two folds, side by side++-- | One step of a script: an event off the stream, or a snapshot re-read+-- and joined to the model that has been folding ('Model.rebase').+data Action+    = Fold Value+    | Reread Value+    deriving (Show)++-- | The first snapshot, then what follows it.+data Script = Script Value [Action]+    deriving (Show)++startNew :: Value -> Model.Model+startNew = either (error . ("fromDag: " <>)) id . Model.fromDag++startOld :: Value -> Reference.Model+startOld = either (error . ("reference fromDag: " <>)) id . Reference.fromDag++applyNew :: Model.Model -> Action -> Model.Model+applyNew m (Fold v) = Model.step m (Model.eventOf v)+applyNew m (Reread s) = Model.rebase m (startNew s)++applyOld :: Reference.Model -> Action -> Reference.Model+applyOld m (Fold v) = Reference.step m (Reference.eventOf v)+applyOld m (Reread s) = Reference.rebase m (startOld s)++-- | Every model a script goes through, the first snapshot's included.+runNew :: Script -> [Model.Model]+runNew (Script s actions) = scanl applyNew (startNew s) actions++runOld :: Script -> [Reference.Model]+runOld (Script s actions) = scanl applyOld (startOld s) actions++{- | Everything a client reads off a model. The reference has types of its+own, with the constructors and field names of the real ones, so a node, a+pass and an event are compared by what they 'show': every field of every+node is in there.+-}+data Seen = Seen+    { seenInOrder :: [String]+    -- ^ the nodes as shown, first to last ('nodesInOrder')+    , seenOrder :: [(Text, Text)]+    -- ^ the order itself, which may name what the node map does not+    , seenNodes :: [(Text, Text)]+    -- ^ the refs of the node map (the nodes themselves are in 'seenInOrder')+    , seenCounts :: (Int, Int, Int)+    , seenMode :: Text+    , seenSeq :: Word64+    , seenLoopSeq :: Word64+    , seenPass :: String+    , seenSupervised :: Maybe Bool+    , seenLast :: String+    , seenResync :: Maybe Text+    }+    deriving (Eq, Show)++seenNew :: Model.Model -> Seen+seenNew m =+    Seen+        { seenInOrder = fmap show (Model.nodesInOrder m)+        , seenOrder = [(r.refShort, r.refFull) | r <- Model.orderToList m.modelOrder]+        , seenNodes = [(r.refShort, r.refFull) | r <- Map.keys m.modelNodes]+        , seenCounts = let c = Model.counts m in (c.countConverged, c.countErrored, c.countTotal)+        , seenMode = m.modelMode+        , seenSeq = m.modelSeq+        , seenLoopSeq = m.modelLoopSeq+        , seenPass = show m.modelPass+        , seenSupervised = m.modelSupervised+        , seenLast = show m.modelLast+        , seenResync = Model.modelResync m+        }++seenOld :: Reference.Model -> Seen+seenOld m =+    Seen+        { seenInOrder = fmap show (Reference.nodesInOrder m)+        , seenOrder = [(r.refShort, r.refFull) | r <- m.modelOrder]+        , seenNodes = [(r.refShort, r.refFull) | r <- Map.keys m.modelNodes]+        , seenCounts = let c = Reference.counts m in (c.countConverged, c.countErrored, c.countTotal)+        , seenMode = m.modelMode+        , seenSeq = m.modelSeq+        , seenLoopSeq = m.modelLoopSeq+        , seenPass = show m.modelPass+        , seenSupervised = m.modelSupervised+        , seenLast = show m.modelLast+        , seenResync = m.modelResyncReason+        }++-------------------------------------------------------------------------------+-- generators++-- | Few enough refs that a script comes back to the same node many times:+-- updated, removed, removed again, read again from a later snapshot.+pool :: [Text]+pool = ["n" <> Text.pack (show i) | i <- [0 .. 7 :: Int]]++-- | A ref no snapshot has.+ghost :: Text+ghost = "ghost"++genShort :: Gen Text+genShort = frequency [(12, elements pool), (1, pure ghost)]++{- | A snapshot at this number: mostly a shuffled part of the pool, each+ref once, as @\/dag@ answers; one time in ten any list over the pool, so+that refs repeat (not something a server sends, but the fold is total over+it and removal has to stay what it was there too). Three nodes in four are+wanted down, since those are the ones a @done@ removes.+-}+genSnapshot :: Word64 -> Gen Value+genSnapshot seqNo = do+    shorts <- frequency [(9, sublistOf pool >>= shuffle), (1, listOf (elements pool))]+    snapshotValue seqNo <$> traverse genNode shorts+  where+    genNode short = do+        direction <- frequency [(3, pure "down"), (1, pure "up")]+        convergence <- elements ["pending", "stale", "converged", "errored", "blocked"]+        pure (nodeValue direction convergence short)++{- | One event, numbered or not. Every stream and kind the fold names, a+kind it does not (@novel@), an event with no ref, and a shapeless object;+weighted towards @done@, the one that removes.+-}+genEvent :: Maybe Word64 -> Gen Value+genEvent seqNo =+    numbered+        <$> frequency+            [ (10, genUpdown >>= \(kind, rest) -> about "updown" kind rest <$> genShort)+            , (3, acted <$> genUpdown <*> genShort)+            , (2, about "upkeep" "next-look" <$> ((: []) . ("check" .=) <$> genCheck) <*> genShort)+            , (1, about "upkeep" <$> elements ["parked", "hung-up", "novel"] <*> pure [] <*> genShort)+            , (2, about "output" "output" <$> genLine <*> genShort)+            , (2, about "output" "log" <$> ((<>) <$> genLine <*> genChannel) <*> genShort)+            , (3, genServe)+            , (1, (\(n :: Int) -> ["stream" .= ("server" :: Text), "kind" .= ("gap" :: Text), "from" .= n]) <$> choose (0, 50))+            , (1, pure ["stream" .= ("updown" :: Text), "kind" .= ("done" :: Text)])+            , (1, pure [])+            ]+  where+    numbered :: [(Key.Key, Value)] -> Value+    numbered fields = object (maybe fields (\s -> ("seq" .= s) : fields) seqNo)++    about :: Text -> Text -> [(Key.Key, Value)] -> Text -> [(Key.Key, Value)]+    about stream kind rest short = ["stream" .= stream, "kind" .= kind, "ref" .= refValue short] ++ rest++    -- what a tending machine did, in the pass's vocabulary: the inner+    -- object carries the kind and the ref+    acted :: (Text, [(Key.Key, Value)]) -> Text -> [(Key.Key, Value)]+    acted (kind, rest) short =+        ["stream" .= ("upkeep" :: Text), "kind" .= ("acted" :: Text), "report" .= object (about "updown" kind rest short)]++    genUpdown :: Gen (Text, [(Key.Key, Value)])+    genUpdown =+        frequency+            [ (7, pure ("done", []))+            , (1, pure ("skip", []))+            , (1, pure ("failed", ["error" .= ("boom" :: Text)]))+            , (1, pure ("blocked", []))+            , (1, pure ("eval", []))+            , (1, pure ("novel", []))+            ]++    genCheck :: Gen Value+    genCheck = do+        verdict <- elements ["success", "failure", "unknown" :: Text]+        reason <- elements [[], ["reason" .= ("because" :: Text)]]+        pure (object (("verdict" .= verdict) : reason))++    genLine :: Gen [(Key.Key, Value)]+    genLine = oneof [pure [], (\(n :: Int) -> ["line" .= ("line " <> Text.pack (show n))]) <$> choose (0, 9)]++    genChannel :: Gen [(Key.Key, Value)]+    genChannel = elements [[], ["channel" .= ("stderr" :: Text)], ["channel" .= ("message" :: Text)]]++    genServe :: Gen [(Key.Key, Value)]+    genServe = do+        (a :: Int) <- choose (0, 9)+        (b :: Int) <- choose (0, 9)+        on <- elements [True, False]+        (("stream" .= ("serve" :: Text)) :)+            <$> elements+                [ ["kind" .= ("declared" :: Text), "epoch" .= a, "direction" .= ("down" :: Text)]+                , ["kind" .= ("cleared" :: Text)]+                , ["kind" .= ("converge-start" :: Text), "down" .= a, "up" .= b]+                , ["kind" .= ("converge-stop" :: Text), "ok" .= on, "remaining" .= a]+                , ["kind" .= ("supervised" :: Text), "on" .= on]+                , ["kind" .= ("novel" :: Text)]+                ]++{- | What follows a snapshot at @cursor@: mostly events numbered just past+the last (as the stream numbers them), some numbered at or below it (a+replay, which each part of the model drops by its own stamp), a few with+no number; and now and then a re-read snapshot, at the cursor or behind+it, which is how a node the fold removed comes back.+-}+genActions :: Word64 -> Int -> Gen [Action]+genActions _ 0 = pure []+genActions cursor k = do+    (action, cursor') <- frequency [(12, event), (1, reread)]+    (action :) <$> genActions cursor' (k - 1)+  where+    event = do+        seqNo <-+            frequency+                [ (8, Just . (cursor +) <$> choose (1, 2))+                , (2, Just <$> choose (0, cursor))+                , (1, pure Nothing)+                ]+        v <- genEvent seqNo+        pure (Fold v, maybe cursor (max cursor) seqNo)+    reread = do+        seqNo <- frequency [(3, pure cursor), (1, choose (0, cursor))]+        v <- genSnapshot seqNo+        pure (Reread v, cursor)++instance Arbitrary Script where+    arbitrary = sized $ \size -> do+        seqNo <- choose (0, 5)+        first <- genSnapshot seqNo+        k <- choose (0, 10 + size)+        Script first <$> genActions seqNo k++    -- drop steps; the events themselves are not shrunk+    shrink (Script first actions) = Script first <$> shrinkList (const []) actions++-- | A ref from the pool or the ghost, for the properties of 'Model.Order' alone.+newtype SmallRef = SmallRef RefId+    deriving (Show)++instance Arbitrary SmallRef where+    arbitrary = SmallRef . refOf <$> genShort++unsmall :: [SmallRef] -> [RefId]+unsmall xs = [r | SmallRef r <- xs]++-------------------------------------------------------------------------------+-- properties++-- | The bar: whatever the script, the model shows after each step what the+-- fold that filtered a list shows.+prop_stepMatchesReference :: Script -> Property+prop_stepMatchesReference script =+    conjoin+        [ counterexample ("after " <> show k <> " steps") (seenNew new === seenOld old)+        | (k, new, old) <- zip3 [0 :: Int ..] (runNew script) (runOld script)+        ]++{- | Without the reference: at every step the order is the refs of the+last snapshot read, in its order, less exactly the nodes the model no+longer has. So it never holds a removed node, it names every node the+model has, and it repeats a ref only if the snapshot did.+-}+prop_orderInvariant :: Script -> Property+prop_orderInvariant (Script first actions) =+    conjoin+        [ counterexample ("after " <> show k <> " steps") $+            conjoin+                [ counterexample "the order is the snapshot's less the dropped" (order === filter (`Map.member` m.modelNodes) base)+                , counterexample "every node is in the order" (Set.fromList order === Map.keysSet m.modelNodes)+                , counterexample "no duplicate the snapshot did not have" (property (nub base /= base || nub order == order))+                , counterexample "the size is the list's" (Model.orderSize m.modelOrder === length order)+                ]+        | (k, (base, m)) <- zip [0 :: Int ..] states+        , let order = Model.orderToList m.modelOrder+        ]+  where+    states = scanl advance (listed first, startNew first) actions+    advance (base, m) action = case action of+        Fold _ -> (base, applyNew m action)+        Reread s -> (listed s, applyNew m action)+    -- the refs a snapshot lists, in its order+    listed = Model.orderToList . Model.modelOrder . startNew++{- | A teardown: every node wanted down, one @done@ each, in an order of+its own (a pass brings nodes down in dependency order, tending machines in+any). Up to two hundred nodes; the order and the nodes shown are+compared after every removal, everything else at the end.+-}+data Teardown = Teardown [Text] [Text]+    deriving (Show)++instance Arbitrary Teardown where+    arbitrary = sized $ \size -> do+        n <- choose (0, 2 * size)+        let shorts = ["t" <> Text.pack (show i) | i <- [1 .. n]]+        Teardown shorts <$> shuffle shorts+    shrink (Teardown shorts gone) =+        [Teardown (filter (/= s) shorts) (filter (/= s) gone) | s <- shorts]++prop_teardownInAnyOrder :: Teardown -> Property+prop_teardownInAnyOrder (Teardown shorts gone) =+    conjoin+        [ conjoin+            [ counterexample ("after " <> show k <> " removals") $+                conjoin+                    [ Model.orderToList new.modelOrder === [refOf short | Reference.RefId short _ <- old.modelOrder]+                    , shown new === [n.nodeRef.refShort | n <- Reference.nodesInOrder old]+                    ]+            | (k, new, old) <- zip3 [0 :: Int ..] news olds+            ]+        , counterexample "the same model at the end" (seenNew (last news) === seenOld (last olds))+        , counterexample "nothing is left" (Model.orderToList (last news).modelOrder === [])+        , counterexample "no node is left" (Map.size (last news).modelNodes === 0)+        ]+  where+    script = Script (retiring 0 shorts) [Fold (updown "done" s i) | (i, s) <- zip [1 ..] gone]+    news = runNew script+    olds = runOld script++prop_orderRoundTrips :: [SmallRef] -> Property+prop_orderRoundTrips xs =+    conjoin+        [ Model.orderToList (Model.orderFromList refs) === refs+        , Model.orderSize (Model.orderFromList refs) === length refs+        ]+  where+    refs = unsmall xs++-- | Any run of removals (of refs shown once, shown twice, already removed+-- or never there) reads as the same run of filters over the list.+prop_orderRemoveIsFilter :: [SmallRef] -> [SmallRef] -> Property+prop_orderRemoveIsFilter xs gone =+    fmap Model.orderToList (scanl (flip Model.orderRemove) (Model.orderFromList refs) (unsmall gone))+        === scanl (\rs r -> filter (/= r) rs) refs (unsmall gone)+  where+    refs = unsmall xs++-- | Equality sees the reading and not the seats: an order with a ref+-- removed is the order built without it.+prop_orderEquality :: [SmallRef] -> [SmallRef] -> SmallRef -> Property+prop_orderEquality xs ys (SmallRef r) =+    conjoin+        [ (Model.orderFromList a == Model.orderFromList b) === (a == b)+        , Model.orderRemove r (Model.orderFromList a) === Model.orderFromList (filter (/= r) a)+        ]+  where+    a = unsmall xs+    b = unsmall ys++{- | The scripts are only worth the equivalence they are run for if they+get to the cases: a node removed by the fold, a removed node shown again+after a re-read, and a @done@ about a node the model does not have (the+ghost, or one already removed). 'checkCoverage' runs as many cases as it+takes to be sure of the shares below.+-}+prop_scriptsReachTheCases :: Script -> Property+prop_scriptsReachTheCases script@(Script _ actions) =+    checkCoverage $+        cover 50 (removals > 0) "a node was removed" $+            cover 10 (removals > 3) "more than three nodes were removed" $+                cover 25 cameBack "a removed node was read again" $+                    cover 50 strangers "a done about a node that is not there" $+                        property True+  where+    states = runNew script+    steps = zip3 states actions (drop 1 states)+    keys :: Model.Model -> Set.Set RefId+    keys = Map.keysSet . Model.modelNodes+    dropped = [keys before `Set.difference` keys after | (before, Fold _, after) <- steps]+    removals = sum (fmap Set.size dropped)+    strangers =+        or+            [ maybe False (`Set.notMember` keys before) e.eventRef+            | (before, Fold v, _) <- steps+            , let e = Model.eventOf v+            , e.eventStream == "updown" && e.eventKind == "done"+            ]+    -- (refs the fold has removed and no snapshot has brought back, seen one come back)+    cameBack = snd (foldl' track (Set.empty, False) steps)+    track (gone, seen) (before, action, after) = case action of+        Fold _ -> (gone `Set.union` (keys before `Set.difference` keys after), seen)+        Reread _ -> (gone `Set.difference` keys after, seen || not (Set.null (gone `Set.intersection` keys after)))++-------------------------------------------------------------------------------+-- unit cases++shown :: Model.Model -> [Text]+shown = fmap (refShort . Model.nodeRef) . Model.nodesInOrder++foldNew :: Model.Model -> [Value] -> Model.Model+foldNew = foldl' (\m v -> Model.step m (Model.eventOf v))++four :: Model.Model+four = startNew (retiring 0 ["a", "b", "c", "d"])++removesEachPosition :: IO ()+removesEachPosition = do+    assertEqual "the snapshot's order" ["a", "b", "c", "d"] (shown four)+    let without short = foldNew four [updown "done" short 1]+    assertEqual "the first" ["b", "c", "d"] (shown (without "a"))+    assertEqual "a middle one" ["a", "c", "d"] (shown (without "b"))+    assertEqual "the other middle one" ["a", "b", "d"] (shown (without "c"))+    assertEqual "the last" ["a", "b", "c"] (shown (without "d"))+    let m = without "b"+    assertEqual "the order is what is shown" [refOf "a", refOf "c", refOf "d"] (Model.orderToList m.modelOrder)+    assertEqual "and its size" 3 (Model.orderSize m.modelOrder)+    assertEqual "the node is gone from the map too" Nothing (Model.lookupNode (refOf "b") m)+    assertEqual "three counted" 3 (Model.countTotal (Model.counts m))+    -- one after another, the rest keep their places+    assertEqual "two removed" ["a", "d"] (shown (foldNew four [updown "done" "c" 1, updown "done" "b" 2]))+    -- an eval does not remove, nor a failed+    assertEqual "only a done removes" ["a", "b", "c", "d"] (shown (foldNew four [updown "eval" "b" 1, updown "failed" "c" 2]))++absentNodeChangesNothing :: IO ()+absentNodeChangesNothing = do+    let m = foldNew four [updown "done" "ghost" 1]+    assertEqual "the order" (Model.orderToList four.modelOrder) (Model.orderToList m.modelOrder)+    assertEqual "the nodes" four.modelNodes m.modelNodes+    assertEqual "the cursor still moves" 1 m.modelSeq+    -- and a node already removed is such a node: a second done, numbered+    -- later, finds nothing to remove+    let once = foldNew four [updown "done" "b" 1]+        twice = foldNew once [updown "done" "b" 2]+    assertEqual "removed once" ["a", "c", "d"] (shown twice)+    assertEqual "the nodes are as after the first" once.modelNodes twice.modelNodes+    assertEqual "the order too" once.modelOrder twice.modelOrder++fullTeardown :: IO ()+fullTeardown = do+    let shorts = ["a", "b", "c", "d"]+        forwards = scanl (\m (i, s) -> foldNew m [updown "done" s i]) four (zip [1 ..] shorts)+        backwards = scanl (\m (i, s) -> foldNew m [updown "done" s i]) four (zip [1 ..] (reverse shorts))+    assertEqual "first to last" [["a", "b", "c", "d"], ["b", "c", "d"], ["c", "d"], ["d"], []] (fmap shown forwards)+    assertEqual "last to first" [["a", "b", "c", "d"], ["a", "b", "c"], ["a", "b"], ["a"], []] (fmap shown backwards)+    let emptied = last forwards+    assertEqual "no order left" [] (Model.orderToList emptied.modelOrder)+    assertEqual "no node left" 0 (Map.size emptied.modelNodes)+    assertEqual "nothing counted" (Model.Counts 0 0 0) (Model.counts emptied)+    assertEqual "the cursor is the last done's" 4 emptied.modelSeq+    assertBool "the last event is kept" (isJust emptied.modelLast)++removedThenReread :: IO ()+removedThenReread = do+    let m = foldNew four [updown "done" "b" 1, updown "done" "d" 2]+    assertEqual "two gone" ["a", "c"] (shown m)+    -- the server still has b (declared again, say): the re-read snapshot+    -- lists it where the server orders it, and that is where it shows+    let again = Model.rebase m (startNew (retiring 5 ["c", "b", "a"]))+    assertEqual "b is back, in the fresh snapshot's order" ["c", "b", "a"] (shown again)+    -- and it can be removed again, by an event past the snapshot+    assertEqual "a replay of its old done is dropped" ["c", "b", "a"] (shown (foldNew again [updown "done" "b" 1]))+    assertEqual "a new done removes it" ["c", "a"] (shown (foldNew again [updown "done" "b" 6]))++repeatedRef :: IO ()+repeatedRef = do+    let m = startNew (retiring 0 ["a", "b", "a", "c"])+    assertEqual "shown twice" ["a", "b", "a", "c"] (shown m)+    assertEqual "one node for the two" 3 (Map.size m.modelNodes)+    assertEqual "removed from both places" ["b", "c"] (shown (foldNew m [updown "done" "a" 1]))+    assertEqual "the others keep theirs" ["a", "a", "c"] (shown (foldNew m [updown "done" "b" 1]))++orderUnit :: IO ()+orderUnit = do+    let refs = fmap refOf ["a", "b", "c"]+        order = Model.orderFromList refs+    assertEqual "reads as its list" refs (Model.orderToList order)+    assertEqual "size" 3 (Model.orderSize order)+    assertEqual "the empty order" [] (Model.orderToList (Model.orderFromList []))+    assertEqual "removing from the empty order" (Model.orderFromList []) (Model.orderRemove (refOf "a") (Model.orderFromList []))+    assertEqual "a removal equals the order built without the ref" (Model.orderFromList (fmap refOf ["a", "c"])) (Model.orderRemove (refOf "b") order)+    assertBool "the order of the refs matters" (Model.orderFromList (reverse refs) /= order)+    assertEqual "shown as the list it reads as" "orderFromList [RefId {refShort = \"a\", refFull = \"full-a\"}]" (show (Model.orderFromList [refOf "a"]))++-------------------------------------------------------------------------------+-- scale++{- | A hundred thousand nodes wanted down and a @done@ for each, in the+snapshot's order: the benchmark's teardown series, without the graph. The+fold that filtered the order took 1.5 to 2 seconds for ten thousand and+grew with the square (so minutes here); this one is expected well under a+second. The bound is as loose as "Test.GraphScaleSpec"'s, for the same+reason: the suite shares its process and its machine.+-}+teardownAtScale :: IO ()+teardownAtScale = do+    let size = 100000 :: Int+        shorts = ["s" <> Text.pack (show i) | i <- [1 .. size]]+        events = [Model.Event (Just i) "updown" "done" (Just (refOf s)) Nothing Null | (i, s) <- zip [1 ..] shorts]+    m0 <- evaluate (startNew (retiring 0 shorts))+    assertEqual "every node is in the snapshot" size (Model.orderSize m0.modelOrder)+    outcome <- timeout (60 * 1000000) (evaluate (foldl' Model.step m0 events))+    case outcome of+        Nothing -> assertFailure "still folding after 60s, which is what a pass over the order per removal looks like"+        Just m -> do+            assertEqual "nothing left in the order" 0 (Model.orderSize m.modelOrder)+            assertEqual "nor in the node map" 0 (Map.size m.modelNodes)+            assertEqual "the cursor is the last event's" (fromIntegral size) m.modelSeq