-- | Generic plumbing to run 'Op' graphs for real (no mocking) and observe
-- what happened, on top of the existing 'Salmon.Actions.UpDown' machinery.
--
-- The rest of the test suite is organized in tiers by IO cost/blast-radius:
--
-- * Layer 0 (structural): 'evalDeps' on an 'Op', no side effects at all.
-- * Layer 1 (sandboxed IO): real 'up'\/'down' against a throwaway temp dir
-- or ephemeral resource, via 'runUpCapturing'\/'runDown'.
-- * Layer 2 (system services): real IO against a service that only exists
-- inside a disposable podman container, dogfooding "Podman.pullImage"\/
-- "Podman.runContainer" as the sandbox provisioner (see "Test.PodmanSpec").
-- * Layer 3 (whole-machine): real IO against a qemu VM booted from a
-- caller-prepared "Salmon.Builtin.Nodes.Debian.Debootstrap" rootfs,
-- dogfooding "Salmon.Builtin.Nodes.LinuxBridge"\/"Salmon.Builtin.Nodes.Qemu"
-- as the sandbox provisioner, for recipes Layer 2's containers can't
-- exercise well (real systemd-as-PID-1, real network interfaces). See
-- @specs/qemu-test-vms.md@ for the design.
module Test.Harness (
-- * capturing UpDown traversal reports
capture,
runUpCapturing,
runUp,
runDown,
runDownCapturing,
-- * scratch filesystem
withTempDir,
privatePipe,
-- * skipping tests when a precondition isn't met
requireExecutable,
-- * podman-backed sandboxes (Layer 2)
podmanTrack,
withContainer,
podmanExec_,
podmanExecCapture,
-- * redirecting a recipe's system binaries into a container via PATH shims
withShimmedPath,
-- * qemu-backed sandboxes (Layer 3)
testBridge,
testBridgeCidr,
testVmAddr,
testVmAddr2,
testVmAddr3,
testVmAddr4,
ensureTestBridge,
withVm,
withVmAt,
VmAccess (..),
sshToVm,
quoteForRemoteShell,
scpToVm,
testHarnessUser,
hasVmPrivileges,
) where
import Control.Concurrent (threadDelay)
import Control.Exception (bracket, bracket_)
import Control.Monad (forM_, unless, void)
import Control.Monad.Identity (Identity, runIdentity)
import Data.IORef
import Data.List (isInfixOf)
import qualified Data.List as List
import qualified Data.Text as Text
import Numeric (showHex)
import qualified Salmon.Actions.UpDown as UpDown
import Salmon.Actions.UpDown (downTree, upTree)
import Salmon.Builtin.Extension (Extension (..), Op, Track', ignoreTrack)
import qualified Salmon.Builtin.Nodes.Binary as Binary
import qualified Salmon.Builtin.Nodes.Keys as Keys
import qualified Salmon.Builtin.Nodes.LinuxBridge as LinuxBridge
import qualified Salmon.Builtin.Nodes.Podman as Podman
import qualified Salmon.Builtin.Nodes.Qemu as Qemu
import qualified Salmon.Builtin.Nodes.Ssh as Ssh
import qualified Salmon.Builtin.Nodes.Systemd as Systemd
import Salmon.Reporter (Reporter, ReporterM (..))
import System.CPUTime (getCPUTime)
import System.Directory (XdgDirectory (XdgConfig), canonicalizePath, createDirectoryIfMissing, findExecutable, getPermissions, getXdgDirectory, setOwnerExecutable, setPermissions)
import System.Environment (lookupEnv, setEnv, unsetEnv)
import System.Exit (ExitCode (..))
import System.FilePath ((</>))
import System.IO (Handle, hPutStrLn, stderr)
import System.Posix.IO (FdOption (CloseOnExec), createPipe, fdToHandle, setFdOption)
import System.IO.Temp (withSystemTempDirectory)
import System.Posix.User (getEffectiveUserID, getLoginName)
import System.Process (readProcessWithExitCode)
-- | Build a reporter that accumulates every emitted value, in order, plus a
-- way to read them back out. Good enough for single-threaded test runs.
capture :: IO (Reporter a, IO [a])
capture = do
ref <- newIORef []
let r = ReporterM $ \x -> atomicModifyIORef' ref (\xs -> (x : xs, ()))
pure (r, reverse <$> readIORef ref)
-- | 'Op'-graph traversal is 'Identity'-effectful in this codebase; both
-- entry points below hardcode that natural transformation.
nat :: Identity a -> IO a
nat = pure . runIdentity
-- | Run 'upTree' and return the full traversal trace (Eval\/Skip\/Blocked
-- per node, one report per node), so idempotency\/dedup can be asserted on
-- directly instead of only inferring it from side effects.
runUpCapturing :: Op -> IO [UpDown.Report Extension]
runUpCapturing o = do
(r, readBack) <- capture
_ <- upTree r nat o
readBack
{- | Run 'upTree' when you only care about the side effects, not the trace.
Returns whether everything actually succeeded (see 'UpDown.upTree') — most
callers that don't check it explicitly still get a real postcondition
assertion elsewhere in the test, but the result is there for callers that
want to assert on it directly instead.
-}
runUp :: Op -> IO Bool
runUp o = do
(r, _) <- capture
upTree r nat o
runDown :: Op -> IO Bool
runDown o = do
(r, _) <- capture
downTree r nat o
-- | 'runDown', keeping the trace — the teardown counterpart of
-- 'runUpCapturing'. Note 'downTree' reports more than per-node outcomes:
-- 'Salmon.Actions.UpDown.Conflicting' comes from the 'Salmon.Op.Dag' fold,
-- before any node runs.
runDownCapturing :: Op -> IO [UpDown.Report Extension]
runDownCapturing o = do
(r, readBack) <- capture
_ <- downTree r nat o
readBack
{- | A pipe neither end of which a child process may inherit.
The suite runs spec groups in parallel in one process, some of them spawn
processes, and nothing in the tree passes @close_fds@, so a child spawned
meanwhile inherits every descriptor not marked close-on-exec. A child holding
a copy of a loop's stdin write end keeps the loop from ever reading end of
input. @process@'s 'System.Process.createPipe' is plain; use this instead for
any pipe a test expects to see EOF on.
-}
privatePipe :: IO (Handle, Handle)
privatePipe = do
(r, w) <- createPipe
forM_ [r, w] $ \fd -> setFdOption fd CloseOnExec True
(,) <$> fdToHandle r <*> fdToHandle w
-- | A fresh, auto-cleaned-up temp directory for filesystem-touching nodes.
withTempDir :: (FilePath -> IO a) -> IO a
withTempDir = withSystemTempDirectory "salmon-ops-recipes-test"
-- | Layer-2 tests need a real binary on PATH (podman, postgres, ...). Rather
-- than failing the suite on a machine that doesn't have it, skip loudly:
-- print a note and report the test as passing-vacuously.
requireExecutable :: String -> IO () -> IO ()
requireExecutable name act = do
found <- findExecutable name
case found of
Just _ -> act
Nothing ->
hPutStrLn stderr $
"SKIPPED: `" <> name <> "` not found on PATH; this Layer 2 test needs it installed to run for real"
-------------------------------------------------------------------------------
-- Podman-backed sandboxes.
--
-- Dogfoods "Podman.pullImage"\/"Podman.runContainer"\/"Podman.runContainer"'s
-- 'down' (i.e. runs them for real through 'runUp'\/'runDown', exactly like
-- production code would) as the sandbox provisioner and cleaner-upper —
-- there is no hand-rolled @podman rm -f@ shell-out here at all, since the
-- Podman nodes now carry a real teardown of their own. We pick the
-- container's name ourselves (so it's known up front and 'down' has a
-- stable target), rather than needing to recover an id from `podman run`'s
-- stdout.
-- | Assumes podman is already installed on the host\/CI image running the
-- test (checked by 'requireExecutable' at the call site).
podmanTrack :: Track' (Binary.Binary "podman")
podmanTrack = ignoreTrack
-- | Pull an image and run it under a fresh, unique name (dogfooding the
-- project's own Podman ops both ways), and guarantee cleanup via the
-- production 'down' action afterwards, however the action exits (including
-- on exception). The pulled image itself is left in the local cache — only
-- the container is torn down — since removing shared image cache on every
-- test run would be needlessly destructive and slow subsequent runs down.
withContainer :: Podman.Image -> Podman.PortMapping -> (String -> IO a) -> IO a
withContainer img pm act =
bracket bringUp cleanup (act . fst)
where
cleanup :: (String, Op) -> IO ()
cleanup (_, runOp) = void (runDown runOp)
bringUp :: IO (String, Op)
bringUp = do
cname <- freshContainerName
(reporter, _) <- capture
let reg = Podman.dockerRegistry
opts = Podman.noRunOptions{Podman.runPorts = [pm]}
pullOp = Podman.pullImage reporter podmanTrack reg img
runOp = Podman.runContainer reporter podmanTrack reg img cname opts
pullOk <- runUp pullOp
unless pullOk (fail "withContainer: pulling the sandbox image failed")
runOk <- runUp runOp
unless runOk (fail "withContainer: starting the sandbox container failed")
pure (Text.unpack (Podman.getContainerName cname), runOp)
-- | CPU time at picosecond resolution is more than enough entropy to keep
-- concurrent\/successive test containers from colliding on a name.
freshContainerName :: IO Podman.ContainerName
freshContainerName = do
t <- getCPUTime
pure (Podman.ContainerName (Text.pack ("salmon-ops-recipes-test-" <> show t)))
-- | Run a command inside an already-running container, discarding its output.
-- Used for sandbox setup steps (installing prerequisites) that are not
-- themselves the thing under test.
podmanExec_ :: String -> [String] -> IO ()
podmanExec_ containerId args = do
(code, out, err) <- readProcessWithExitCode "podman" (["exec", "-i", containerId] <> args) ""
case code of
ExitSuccess -> pure ()
ExitFailure n ->
error $
"podmanExec_ " <> show args <> " failed with exit " <> show n <> "\nstdout: " <> out <> "\nstderr: " <> err
-- | Like 'podmanExec_', but for postcondition checks: hands back the full
-- (exit code, stdout, stderr) instead of throwing on failure.
podmanExecCapture :: String -> [String] -> IO (ExitCode, String, String)
podmanExecCapture containerId args =
readProcessWithExitCode "podman" (["exec", "-i", containerId] <> args) ""
-------------------------------------------------------------------------------
-- Redirecting a recipe's real system binaries (apt-get, sudo, pg_ctlcluster,
-- ...) into a podman container.
--
-- Recipes call these binaries directly by name via 'System.Process.proc',
-- with no indirection to hook into — so the only way to run their *real*
-- logic against a sandbox instead of the host is to put lookalike wrapper
-- scripts earlier on PATH that forward the invocation into the container via
-- @podman exec@. This tests the recipe's actual command construction and
-- graph wiring for real, unmodified, while keeping the destructive parts
-- (apt installs, service starts) confined to the disposable container.
-- | Create shims for the given command names that all forward into
-- @containerId@, prepend them to PATH for the duration of the action, and
-- restore the original PATH afterwards.
withShimmedPath :: String -> [String] -> IO a -> IO a
withShimmedPath containerId commands act =
withSystemTempDirectory "salmon-ops-recipes-test-shims" $ \dir -> do
mapM_ (writeShim dir) commands
withPrependedPath dir act
where
writeShim :: FilePath -> String -> IO ()
writeShim dir cmd = do
let path = dir </> cmd
writeFile path $
unlines
[ -- Absolute shebang on purpose: `#!/usr/bin/env bash` would
-- have `env` resolve "bash" via the (now shim-prepended)
-- PATH, which — if "bash" is itself one of the shimmed
-- commands — finds this very script and recurses into
-- itself forever instead of running real bash.
"#!/bin/bash"
, "exec podman exec -i " <> containerId <> " " <> cmd <> " \"$@\""
]
perms <- getPermissions path
setPermissions path (setOwnerExecutable True perms)
withPrependedPath :: FilePath -> IO a -> IO a
withPrependedPath dir act = do
original <- lookupEnv "PATH"
bracket_
(setEnv "PATH" (dir <> maybe "" (":" <>) original))
(maybe (unsetEnv "PATH") (setEnv "PATH") original)
act
-------------------------------------------------------------------------------
-- qemu-backed sandboxes (Layer 3).
--
-- Mirrors the podman section above in spirit: dogfoods
-- "Salmon.Builtin.Nodes.LinuxBridge"'s and "Salmon.Builtin.Nodes.Qemu"'s own
-- up\/down through 'runUp'\/'runDown' as the sandbox provisioner, real IO, no
-- mocking. Unlike podman, this needs real host privilege (@CAP_NET_ADMIN@
-- for the bridge\/tap devices, plus whatever qemu itself needs) that is
-- assumed already available to whoever runs this tier — a documented
-- prerequisite, same stance @specs/qemu-test-vms.md@'s privilege open
-- question leans towards, rather than this harness trying to sudo on its
-- own behalf. As of the tap-owner\/unprivileged-qemu change (see
-- 'testHarnessUser'\/'hasVmPrivileges'), that prerequisite no longer has to
-- mean root: a one-time @setcap@ on @ip@ and @qemu-system-x86_64@ plus
-- @kvm@ group membership is enough for routine test runs, with root (or
-- @sudo@) only still needed for building rootfses (@debootstrap@ itself
-- always needs a real chroot) and, once, granting those capabilities.
--
-- Caveat carried over from the spec: the guest-networking scheme here
-- (static IP via the kernel @ip=@ cmdline parameter, assumed @eth0@ naming)
-- is a first cut, not yet checked against a real boot — @specs/qemu-test-vms.md@'s
-- phased plan puts "hand-validate a boot" before wrapping things in a node,
-- and that hand-validation hasn't happened yet. Expect to revisit the exact
-- cmdline\/interface-naming details here once a real VM has actually booted.
ipTrack :: Track' (Binary.Binary "ip")
ipTrack = ignoreTrack
qemuBinTrack :: Track' (Binary.Binary "qemu-system-x86_64")
qemuBinTrack = ignoreTrack
systemctlTrack :: Track' (Binary.Binary "systemctl")
systemctlTrack = ignoreTrack
{- | The unprivileged host user this tier's tap device and qemu process
itself now run as (see 'withVmAt'), instead of root — prefers @SUDO_USER@
(set when this suite is still invoked via a transitional @sudo@, e.g. for
the one-time steps in 'hasVmPrivileges''s haddock) and falls back to the
process's own login name, which is what a non-sudo invocation already is.
Both the tap's owner and the systemd unit's @User=@\/@Group=@ use this same
name — relies on the Debian\/Ubuntu convention of a private group sharing
the user's name (true for any normal, non-system account).
-}
testHarnessUser :: IO Text.Text
testHarnessUser = do
viaSudo <- lookupEnv "SUDO_USER"
case viaSudo of
Just u | not (null u) -> pure (Text.pack u)
_ -> Text.pack <$> getLoginName
{- | Whether the calling process can plausibly bring up this tier without
being root: either it already is root (the original, still-supported
mode), or the two binaries this tier shells out to for privileged
operations have been granted just enough Linux capability to do those
operations as an unprivileged user —
* @capsh@ (not @ip@ itself!) needs @cap_net_admin@, to raise it into its
own ambient set before exec'ing the real, uncapped @ip@ —
'Salmon.Builtin.Nodes.LinuxBridge.ipLinkCommand's haddock has the full
story, but the short version: granting @cap_net_admin@ to @ip@ directly
does not work, because iproute2 unconditionally drops its entire
effective\/permitted\/inheritable capability set at startup and only
trusts the *ambient* set afterwards — which a plain file-capability grant
can never populate (the kernel zeroes ambient for any exec of a
"privileged" file). Hand-validated 2026-09-08 via @strace@ on a real
failing, then real passing, unprivileged @ip link add@.
* @qemu-system-x86_64@ needs @cap_dac_override@ (plus @cap_chown@\/
@cap_fowner@ for guest-side @chown@\/@chmod@ over 9p) so its
@security_model=passthrough@ export can still act on behalf of whichever
uid\/gid a file inside the debootstrapped rootfs actually belongs to
(e.g. the guest's own @postgres@ account) — without this, an
unprivileged qemu could only ever access files it happens to already own
on the host, which a real multi-user rootfs is not. Root granted this
for free; a plain unprivileged process needs the capability instead of
full root, not on top of it. Unlike @ip@, qemu does not appear to
self-drop its capabilities this way — it's a plain file-capability grant.
Both are one-time host setup (@setcap cap_net_admin+eip $(command -v
capsh)@, @setcap cap_dac_override,cap_chown,cap_fowner+eip $(command -v
qemu-system-x86_64)@), same spirit as the KVM group membership already
assumed — see @specs/qemu-test-vms-progress.md@ for the exact commands run
to validate this. @\/dev\/kvm@ access itself is deliberately not re-checked
here: it's already gated by 'Salmon.Builtin.Nodes.Qemu.vm_enable_kvm' being
best-effort (see 'withVmAt') and by plain group membership, no capability
needed.
-}
hasVmPrivileges :: IO Bool
hasVmPrivileges = do
isRoot <- (== 0) <$> getEffectiveUserID
if isRoot
then pure True
else
(&&)
<$> hasCapability "cap_net_admin" "capsh"
<*> hasCapability "cap_dac_override" "qemu-system-x86_64"
{- | Whether @exe@ (looked up on @PATH@) has been granted @capName@ via
@setcap@. Canonicalizes past any symlink first (e.g. Debian's usrmerge
makes @\/usr\/sbin\/ip@, which @PATH@ finds before the real @\/bin\/ip@, a
symlink) — @getcap@ reports nothing at all for a symlink path, only for the
real file the capability is actually stored on, same reason
'Salmon.Builtin.Nodes.Capabilities.grantCapabilities' itself needs the
canonical path to set it in the first place.
-}
hasCapability :: String -> String -> IO Bool
hasCapability capName exe = do
mPath <- findExecutable exe
case mPath of
Nothing -> pure False
Just linkedPath -> do
path <- canonicalizePath linkedPath
(code, out, _err) <- readProcessWithExitCode "getcap" [path] ""
pure (code == ExitSuccess && capName `isInfixOf` out)
-- | One shared bridge, left standing across test runs rather than torn down
-- per test — matches @specs/qemu-test-vms.md@'s leaning on bridge lifecycle
-- scope. Only each VM's own tap is created\/destroyed per test.
testBridge :: LinuxBridge.Bridge
testBridge = LinuxBridge.Bridge "salmontest0"
testBridgeCidr :: LinuxBridge.Cidr
testBridgeCidr = LinuxBridge.Cidr "10.99.0.1" 24
{- | Fixed guest address — v1 assumes a single VM under test at a time (see
@specs/qemu-test-vms.md@'s phased plan: proving the tier end to end comes
before anything like a real address pool).
-}
testVmAddr :: Text.Text
testVmAddr = "10.99.0.2"
-- | A second fixed guest address, for tests that need two VMs up at once
-- (e.g. a primary\/standby pair) via two nested 'withVmAt' calls.
testVmAddr2 :: Text.Text
testVmAddr2 = "10.99.0.3"
{- | A third address, so a spec that is not part of the primary\/standby pair
can boot without waiting for one of theirs to be free.
Sharing an address between specs does not stop at "they must not run at the
same time": a VM that is still shutting down answers for the next spec's VM,
and ssh reports @Connection closed by 10.99.0.2@ from a host that is not the
one under test. Serializing the specs makes that window small, not absent, so
a spec with no reason to share should not.
-}
testVmAddr3 :: Text.Text
testVmAddr3 = "10.99.0.4"
-- | A fourth, for "Test.MigratorTemplateSpec", on the same reasoning as 'testVmAddr3'.
testVmAddr4 :: Text.Text
testVmAddr4 = "10.99.0.5"
-- | Ensures the shared test bridge (and its address) exist. Idempotent via
-- the production 'LinuxBridge.bridgeAddr' op's own @check@ — safe to call
-- before every test.
ensureTestBridge :: IO ()
ensureTestBridge = do
(nodeReporter, _) <- capture
(traceReporter, readBack) <- capture
ok <- upTree traceReporter nat (LinuxBridge.bridgeAddr nodeReporter ipTrack testBridge testBridgeCidr)
unless ok $ do
trace <- readBack
fail ("ensureTestBridge: failed to bring up the shared test bridge:\n" <> unlines (map show trace))
-- | CPU time at picosecond resolution, truncated to fit Linux's 15-character
-- interface name limit — same entropy source as 'freshContainerName' above,
-- just shorter (an interface name, unlike a container name, can't be long).
freshTapName :: IO LinuxBridge.DevName
freshTapName = do
t <- getCPUTime
pure (Text.pack ("vmtap" <> take 6 (reverse (show t))))
{- | A locally-administered MAC in qemu's own default OUI (@52:54:00@), with
three CPU-time-derived bytes.
One byte is not enough, and the way it fails is worth remembering: two
guests that draw the same address are on one bridge claiming one IP, so the
host's ARP entry for the first is overwritten by the second and the first
goes unreachable /after/ it has already answered SSH. That reads as a VM
that died for no reason, in whichever spec boots two at once.
The odds were far worse than one in 256, too: 'getCPUTime' counts
picoseconds but the clock underneath it ticks in nanoseconds, so the low
digits are always zero and a single byte of it ranges over a fraction of its
values. The three bytes here are taken /above/ that dead range.
-}
freshMac :: IO Text.Text
freshMac = do
t <- getCPUTime
let ticks = t `div` 1000
byteAt k = fromInteger ((ticks `div` (256 ^ (k :: Int))) `mod` 256) :: Int
hex2 n = let h = showHex n "" in if length h < 2 then '0' : h else h
pure (Text.pack (List.intercalate ":" (["52", "54", "00"] <> map (hex2 . byteAt) [2, 1, 0])))
-- | What 'withVm' hands its action: the guest's login plus the private key
-- to authenticate with (see 'sshToVm' — always pass this explicitly rather
-- than relying on an ssh-agent\/default identity file, see 'VmAccess's
-- construction site in 'withVm' for why that doesn't work here).
data VmAccess = VmAccess {vmRemote :: Ssh.Remote, vmIdentityFile :: FilePath}
{- | Boots a VM from an already-prepared 'Salmon.Builtin.Nodes.Debian.Debootstrap.RootTree'
directory (built and populated by the caller — this harness does not run
debootstrap itself, see @specs/qemu-test-vms.md@) — waits for SSH to answer,
runs the action, and guarantees teardown afterwards via the production
'Qemu.setup' down action, however the action exits (including on
exception), same bracket-based shape as 'withContainer'.
Login access is entirely this harness's own doing, not the caller's: a
fresh SSH CA and a client key signed by it (via
"Salmon.Builtin.Nodes.Keys"'s production 'Keys.sshKey'\/'Keys.signKey', the
same primitives a real CA-backed recipe would use) are generated per boot
into the VM's own tmpdir, and the CA's public half plus a
@TrustedUserCAKeys@\/@PasswordAuthentication no@ sshd drop-in are written
straight into @rootfs@ before qemu starts — the 9p export means that's the
guest's own @\/etc\/ssh@, no separate transport step needed. This
sidesteps two problems hand-validation on 2026-08-20 ran into with relying
on a developer's own key instead (see @specs/qemu-test-vms-progress.md@):
running the whole privileged tier under @sudo@ doesn't forward the
invoking user's ssh-agent, so pubkey auth via a personal key silently never
succeeds and 'waitForSsh' just times out; and a per-run generated identity
means nothing here depends on a human having pre-populated
@root\/.ssh\/authorized_keys@ by hand at all.
@rootfs@ only needs 'Salmon.Builtin.Nodes.Debian.Debootstrap.vmEssentials'
and 'Salmon.Builtin.Nodes.Debian.Debootstrap.ensureVm9pBoot' already
applied; no key material needs pre-provisioning by the caller any more.
Fixed at 'testVmAddr' — for more than one VM at a time on the shared test
bridge (e.g. a primary/standby pair), see 'withVmAt'.
-}
withVm :: FilePath -> (VmAccess -> IO a) -> IO a
withVm = withVmAt testVmAddr
{- | Like 'withVm', but at a caller-chosen guest address on the shared test
bridge instead of the hardcoded 'testVmAddr' — lets a test bring up more
than one VM at once (e.g. nesting two calls, one per address, for a
primary/standby pair) without them fighting over the same IP. Caller picks
addresses inside 'testBridgeCidr' that don't collide with each other or
with 'testVmAddr' (still used by single-VM tests like
"Test.QemuSmokeSpec" running concurrently in the same tasty run).
Teardown ('runDown vmOp') is guaranteed from the moment 'upTree' has
actually brought the qemu process up, whatever happens afterwards —
including 'waitForSsh' timing out. That's the point of the inner
'bracket' below: 'bringUp' used to run 'upTree' /then/ 'waitForSsh' as
one action, so a 'waitForSsh' timeout threw out of 'bringUp' itself
before it ever returned @(access, vmOp)@ — and the outer 'bracket''s
cleanup only ever runs on a value 'bringUp' actually returned, so the
qemu process it had just started was orphaned on the shared bridge
(squatting its fixed test address for whichever spec runs next). Here,
once 'upTree' succeeds, an inner @bracket _ (const (void (runDown
vmOp)))@ owns teardown outright, and 'waitForSsh' runs strictly inside
that scope.
-}
withVmAt :: Text.Text -> FilePath -> (VmAccess -> IO a) -> IO a
withVmAt addr rootfs act =
withSystemTempDirectory "salmon-ops-recipes-test-vm" $ \tmpdir -> do
identityFile <- ensureVmSshAccess tmpdir rootfs
vmOp <- bringUpVm tmpdir identityFile
-- Once 'upTree' above has returned successfully, the qemu process
-- exists — from here on, 'runDown vmOp' must run no matter what,
-- including a 'waitForSsh' timeout. This inner 'bracket' owns that
-- teardown outright; the outer 'withSystemTempDirectory' can no
-- longer be the only thing standing between a thrown exception and
-- an orphaned qemu process.
bracket
(pure (VmAccess (Ssh.Remote "root" addr) identityFile))
(const (void (runDown vmOp)))
(\access -> waitForSsh access >> act access)
where
bringUpVm :: FilePath -> FilePath -> IO Op
bringUpVm tmpdir identityFile = do
ensureTestBridge
tapName <- freshTapName
mac <- freshMac
user <- testHarnessUser
unitDir <- getXdgDirectory XdgConfig "systemd/user"
(kernel, initrd) <- Qemu.resolveKernelInitrd rootfs
(reporter, _) <- capture
(reporterTap, _) <- capture
let cfg =
Qemu.VmConfig
{ Qemu.vm_name = Text.pack ("salmon-test-vm-" <> takeWhile (/= '/') (reverse tmpdir))
, Qemu.vm_memory_mb = 512
, Qemu.vm_smp = 1
, Qemu.vm_rootfs = rootfs
, Qemu.vm_kernel = kernel
, Qemu.vm_initrd = initrd
, Qemu.vm_extra_kernel_args =
[ "ip=" <> addr <> "::" <> testBridgeCidr.cidrAddr <> ":255.255.255.0::eth0:off"
]
, Qemu.vm_tap = LinuxBridge.Tap tapName testBridge (Just user)
, Qemu.vm_mac = mac
, Qemu.vm_monitor_socket = tmpdir </> "monitor.sock"
, Qemu.vm_enable_kvm = True
, Qemu.vm_user = user
, Qemu.vm_group = user
, Qemu.vm_working_dir = tmpdir
, Qemu.vm_systemd_scope = Systemd.User
, Qemu.vm_unit_dir = unitDir
}
vmOp = Qemu.setup reporter reporterTap systemctlTrack qemuBinTrack ipTrack cfg
(traceReporter, readBack) <- capture
ok <- upTree traceReporter nat vmOp
unless ok $ do
trace <- readBack
fail ("withVmAt: starting the sandbox VM failed:\n" <> unlines (map show trace))
-- Note: no cleanup on this path's own failure — 'upTree' returning
-- 'False' (or throwing) here means the VM never came up in the
-- first place (or 'upTree' itself already unwound whatever partial
-- state it made), so there is nothing yet for an inner 'bracket' to
-- guarantee teardown of. It's only once we have a 'vmOp' that
-- successfully started that this function returns, at which point
-- the caller's 'bracket' above takes over.
pure vmOp
{- | Generates a fresh SSH CA and a client key signed by it (both kept in
the VM's own @tmpdir@, torn down with everything else there), and wires
@rootfs@'s sshd to trust that CA instead of relying on
@root\/.ssh\/authorized_keys@ — see 'withVm's haddock for why. Returns the
signed client's private key path, for use with 'sshToVm'.
-}
ensureVmSshAccess :: FilePath -> FilePath -> IO FilePath
ensureVmSshAccess tmpdir rootfs = do
(reporter, _) <- capture
let keygenTrack = ignoreTrack :: Track' (Binary.Binary "ssh-keygen")
ca = Keys.SSHKeyPair Keys.ED25519 tmpdir "test-ca"
client = Keys.SSHKeyPair Keys.ED25519 tmpdir "test-client"
okCa <- runUp (Keys.sshKey reporter keygenTrack ca)
unless okCa (fail "ensureVmSshAccess: failed to generate the test CA key")
okSign <- runUp (Keys.signKey reporter keygenTrack (Keys.SSHCertificateAuthority ca) (Keys.KeyIdentifier "salmon-test-vm") [Keys.Principal "root"] client)
unless okSign (fail "ensureVmSshAccess: failed to sign the test client key")
caPub <- readFile (Keys.publicKeyPath ca)
let sshdDropinDir = rootfs </> "etc/ssh/sshd_config.d"
createDirectoryIfMissing True sshdDropinDir
writeFile (rootfs </> "etc/ssh/ca.pub") caPub
writeFile
(sshdDropinDir </> "99-salmon-test.conf")
( unlines
[ "TrustedUserCAKeys /etc/ssh/ca.pub"
, "PasswordAuthentication no"
, "KbdInteractiveAuthentication no"
]
)
pure (Keys.privateKeyPath client)
-- | Every ssh call this harness makes against a booted VM goes through
-- this: explicit identity file (never an agent\/default identity, see
-- 'withVm's haddock), 'IdentitiesOnly' so ssh doesn't also try any other
-- key it happens to find first.
--
-- @ssh@ joins every element of 'args' with a single space and ships the
-- result as one string for the remote shell to tokenize — same as typing
-- the words after the hostname by hand at a terminal. That means an 'args'
-- element containing its own whitespace (a whole SQL statement, a
-- @cmd 2>&1@ redirection) does NOT arrive remotely as one token: the
-- remote shell re-splits it on spaces just like everything else, so e.g.
-- @["psql", "-tAc", "SELECT state FROM t;"]@ arrives as
-- @psql -tAc SELECT state FROM t;@ — @-tAc@ only captures @SELECT@, and
-- @state@\/@FROM@\/@t;@ become stray extra arguments. Callers that need an
-- element to survive as a single remote token (a full SQL statement, a
-- whole @bash -c@ script) must pre-quote it themselves with
-- 'quoteForRemoteShell' before it goes in 'args' — see that function's
-- haddock for why this isn't done unconditionally for every element here.
sshToVm :: VmAccess -> [String] -> IO (ExitCode, String, String)
sshToVm access args =
readProcessWithExitCode
"ssh"
( [ "-o"
, "BatchMode=yes"
, "-o"
, "StrictHostKeyChecking=no"
, "-o"
, "UserKnownHostsFile=/dev/null"
, "-o"
, "IdentitiesOnly=yes"
, "-i"
, access.vmIdentityFile
, Text.unpack (Ssh.loginAtHost access.vmRemote)
]
<> args
)
""
{- | Single-quotes a string so it survives 'sshToVm''s ssh-level space-join
as one remote token, e.g. a whole SQL statement or @bash -c@ script that
must not be re-split by the remote shell. Not applied to every 'sshToVm'
argument automatically: some existing callers (e.g. "Test.QemuSmokeSpec"'s
@sshToVm access ["echo smoke-ok"]@) rely on the remote shell's own
re-splitting to turn one Haskell-level string into several remote words,
same as typing @echo smoke-ok@ by hand — quoting unconditionally would
instead hand the remote shell one literal token @"echo smoke-ok"@ (a
program name with a space in it) and break that. Use this only for an
argument you specifically want to arrive remotely as a single word.
-}
quoteForRemoteShell :: String -> String
quoteForRemoteShell s = "'" <> concatMap (\c -> if c == '\'' then "'\\''" else [c]) s <> "'"
-- | Copies a local file onto the VM at the given remote path, using the
-- same identity\/options as 'sshToVm' (never an agent\/default identity).
-- Used to get a compiled fixture\/recipe binary onto the guest without
-- needing it preinstalled in the rootfs.
scpToVm :: VmAccess -> FilePath -> String -> IO ()
scpToVm access localPath remotePath = do
(code, out, err) <-
readProcessWithExitCode
"scp"
[ "-o"
, "BatchMode=yes"
, "-o"
, "StrictHostKeyChecking=no"
, "-o"
, "UserKnownHostsFile=/dev/null"
, "-o"
, "IdentitiesOnly=yes"
, "-i"
, access.vmIdentityFile
, localPath
, Text.unpack (Ssh.loginAtHost access.vmRemote) <> ":" <> remotePath
]
""
case code of
ExitSuccess -> pure ()
ExitFailure n ->
error $
"scpToVm " <> localPath <> " -> " <> remotePath <> " failed with exit " <> show n <> "\nstdout: " <> out <> "\nstderr: " <> err
-- | Polls SSH every two seconds (a VM takes real seconds to boot, unlike a
-- podman container being "up") for up to two minutes, then fails loudly
-- rather than hanging the test suite indefinitely — same "skip\/fail loudly,
-- don't hang" spirit as 'requireExecutable'.
waitForSsh :: VmAccess -> IO ()
waitForSsh access = go (60 :: Int)
where
go 0 = fail ("withVm: " <> show (Ssh.loginAtHost access.vmRemote) <> " never answered SSH within the timeout")
go n = do
(code, _, _) <- sshToVm access ["-o", "ConnectTimeout=2", "true"]
case code of
ExitSuccess -> pure ()
_ -> threadDelay 2000000 >> go (n - 1)