diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,461 @@ +# Changelog + +- unreleased + * The demo executables (censor-demo, censor-viz, censor-demo-ffi, + and the per-library suites censor-poly, censor-chacha, + censor-sha, censor-sha512, censor-aead, censor-secp), their + cabal flags, the rs-demo Rust crate, and the flake inputs they + pulled in are removed. Target-specific harnesses belong + outside censor, built on the library's suite scaffolds in + Censor.Runner.Report, which are unchanged. + + * **Breaking:** Censor.Runner drops Case, runBattery, and + partitionVerdicts, and Censor.Runner.Report drops Suite and + runSuite, all unused. resultToJSON moves from Censor.Runner to + Censor.Runner.Report. Censor.Runner.Manifest newly exports + readRange and readSeed. + + * The dlopen CLI now calls its target through an unsafe FFI + import. The import had defaulted to a safe call, which put the + RTS's thread suspend/resume inside every timed region. + + * In the CLI's single-target mode the A/A and B/B controls get a + fresh hypothesis instance, as in manifest mode, rather than + continuing the main run's sampler streams. + + * The haddocks are trimmed and deduplicated, with stale text + fixed (including a Censor.FFI example that did not compile). + +- 0.5.1 (2026-08-23) + * **Copy-source symmetry in fix-vs-random** + (issues/handled/ISSUE4.md). + `fixVsRandom` and `fixVsRandomCtx` take a re-materialisation + function (`s -> IO s`), run on the pinned secret by *both* + classes every sample: class A completes around the fresh copy, + class B discards its copy and completes around its fresh draw. + With a function that performs a real copy (for ByteString + secrets, `\s -> evaluate (BS.copy s)`) the long-lived pinned + value is read exactly once per sample in each class, and the + completion's input is a fresh, same-aged allocation in both -- + removing a copy-source locality asymmetry that surfaced as + intermittent CDF/shape rejections (effect CI straddling zero) + under the cycles meter, invisible to the A/A and B/B controls. + `pure` retains the old behaviour for secret types with no + cheap re-materialiser. + + * **Secret regeneration in the dlopen CLI.** The CLI's secret + ranges are no longer overlaid from a long-lived buffer that + only class A reads -- the FFI form of the copy-source + asymmetry above. Both classes now refill their secret ranges + in place each sample through one shared generator, reseeded + before every use (`Censor.Rng.reseed`, new): class A to a + seed pinned at setup, class B to a word drawn from its own + stream, so the classes run identical code and differ only in + the seed value written into the generator state. Sampler + streams for a given `--seed` shift accordingly. + + * censor-poly grows a pinned-pair (k1 vs k2, 320 B) + discriminator case: neither class draws or re-materialises + per sample, so a rejection there is key-content-dependent + timing alone -- the instrument that separates a copy-source + artefact from a real leak. + +- 0.5.0 (2026-08-21) + * **Margin calibration cells and a host power-gain probe** in + censor-validate. The margin calibration cells shift class B by + less than the resolved margin, so their interval null is true + while the sharp null is false -- empirically validating margin + mode's type-I claim under exactly the sub-tolerance systematic + the margin absorbs; margin power cells confirm shifts beyond + the margin are still caught, and a sharp-contrast cell shows + the sub-margin shift rejecting at ~100% without one. + `censor-validate --power-gain [METER]` measures the host + instead of a synthetic meter: a cycle-identical, maximally + power-asymmetric control (zeros vs alternating 01/10 rewrites + of a 64 KiB buffer) bounds the host's power-to-time coupling + gain from above, with an A/A control and, when the bound + resolves usefully, a suggested `--margin`. + + * **Interval nulls (margin mode).** `cfgMargin` (CLI `--margin`, + manifest `margin`) replaces the sharp null with the interval + null |E d_clipped| <= delta, where delta resolves at warmup as + the given fraction of the median pooled per-batch reading. The + three magnitude components become interval-null tests anchored + at +-delta (via ppad-eproc 0.5's `configInterval`) and alone + gate the verdict; the sign and CDF components are demoted to + non-gating diagnostics, since they carry no meter-unit + tolerance. A `Reject` then means the mean effect exceeds the + stated tolerance -- a claim the wall meter can actually support + on frequency-scaled hosts, where the sharp null is genuinely + false for host-mediated reasons and a consistent test + eventually rejects it (see the README's noisy-hosts section). + The resolved absolute margin is reported as `resMargin` + (`margin` in the result JSON) and must land in (0, c) for the + warmup clip bound c. `leakShape`/`diagnose` rank only the + gating components on margin-mode runs. Adding `cfgMargin` / + `resMargin` breaks positional construction of `Config` / + `Result`. Requires ppad-eproc >= 0.5. + + * **Channel-attribution counters.** Four new `Counter` meters + complete the wall-decomposition ladder: `RefCycles` + (constant-rate reference cycles -- a class difference here with + clean `Cycles` is a frequency/DVFS effect by construction), + `TaskClock` (on-CPU nanoseconds including kernel time on the + task's behalf; a software counter, so it needs no PMU access + and is available in VMs -- but counting kernel time is itself + privileged, so it needs `perf_event_paranoid` at most 1 and + fails with `OpenFailed 13` at the 2 the other counters + tolerate), `BranchMisses` (secret-dependent branch + direction under balanced retired counts), and `CacheMisses` + (memory access patterns). With the existing meters, each + adjacent rung of instructions -> cycles -> ref-cycles -> + task-clock -> wall isolates exactly one cause of a class + difference: code path, microarchitectural latency, frequency, + kernel/interrupt time, scheduling. The dlopen CLI and suites + accept them as `ref-cycles`, `task-clock`, `branch-misses`, + and `cache-misses`. Adding constructors to `Counter` is a + breaking change for exhaustive matches on that type. + +- 0.4.4 (2026-08-05) + * **Per-case baseline cost.** `baselineReading` measures the + target on fresh class-A draws at the case's batch and reports + the median and IQR in per-batch meter units -- the scale of + `resEffect` -- so an effect interval can be read as a relative + bound against the cost of a call. Fresh draws make every + measurement genuine work under any batch policy, unlike the + calibration noise probe, whose shared applied thunk makes it + meaningless for pure Haskell targets. `runTraceSuite` and both + dlopen CLI modes probe it per case; it surfaces as a new + optional per-case `baseline` key in the `censor/report-v3` + object and a `baseline med=N iqr=N` segment on the case detail + line. + + * Fixes the benchmark suites, which had failed to compile since + `prepare` was added to `Hypothesis` in 0.4.1. + +- 0.4.3 (2026-08-01) + * **The driver's pair loop is now flip-oblivious.** `runPair`'s + order branch compiled the two A/B orders to two distinct code + paths, so the per-pair order bit selected which physical code + executed the pair -- coupling the bit into the measured + readings through microarchitectural state and breaking the + conditional exchangeability the null rests on. The A/A + negative controls surfaced this as pervasive timing-meter + rejections on long-duration pure targets, with the + instruction lane clean (issues/ISSUE2.md). The pair now runs + one code path with a single call site per sampler and + measurement: sampler order is selected by indexing a + two-element array with the order word, class labels are + recovered by mask arithmetic after both measurements, and the + order bit is never scrutinised as a `Bool` inside the loop. + Verified branchless by disassembly, in both the main and + warmup loops. + + * **The darwin wall meter is tick-resolved.** `wallClock` now + reads `clock_gettime_nsec_np(CLOCK_UPTIME_RAW)` (~42 ns + ticks on Apple Silicon) rather than GHC's + `getMonotonicTimeNSec`, whose `CLOCK_MONOTONIC` macOS + quantises to microseconds. Microsecond atoms concentrated + wall readings so that warmup placed CDF cut points exactly on + quantisation boundaries, where the indicator channel + amplifies nanosecond-scale harness perturbations into + percent-scale class asymmetries. + + * Adds a `primitive` dependency (`SmallArray`, backing the + branchless sampler selection). + +- 0.4.2 (2026-08-01) + * Makes minor adjustments to the flake setup and some demo binaries. + +- 0.4.1 (2026-07-30) + * **`prepare` now runs during batch calibration.** `runPair` has + always run the prologue before either sampler, but + `calibrateBatchReport` drew its probe sample without one, so a + hypothesis whose sampler depends on its prologue calibrated + against uninitialised state. It now runs exactly one prologue + and one class-A draw. + + * **Calibration and the main run no longer share a hypothesis + instance.** `runTraceSuite` and the manifest runner built one + instance, calibrated it, then ran it — advancing its sampler + state, and contradicting `TraceCase`'s documented contract that + the builder is re-executed per phase. Each phase now gets its + own instance, as documented. + + * **Paired public context reaches the manifest.** A new + `context=off:len` case range (and matching `--context` flag) is + redrawn once per *pair* and written into both classes, so a + manifest can express a shared fresh public input. Previously + `fixVsRandomCtx` existed in the library with no route to it from + the foreign runner, whose public ranges were pinned for the + whole cell. + + * **One layout validator for both entry points.** `checkLayout` + requires every range to fit the workspace and the three roles — + secret, public, context — to be pairwise disjoint. The manifest + and the single-case command line now share it; previously the + command line bounds-checked only, so `--secret 0:8 --context + 0:8` ran a layout the manifest rejected, and the manifest in + turn accepted a public range that masked the context it + overlapped. A byte belongs to exactly one role, so an overlap + has no coherent reading and is an error rather than a + precedence question. + + * **`label=` is presentation only.** It set `mcName`, from which + the per-case seed was derived, so renaming a case for display + silently re-rolled the secret it tested against. `ManifestCase` + now carries `mcId` — the case token as written — and seeds + derive from that. + + * **The foreign runner no longer strands its buffers.** The three + per-hypothesis workspaces were raw `mallocBytes` with no + release; phase isolation multiplied that to as many as nine + workspaces per cell. They are now `ForeignPtr`s held by the + sampler closures, reclaimed with the hypothesis. + + * **Replicate identity is stable.** `replicates=1` and + `replicates=2` now agree on cell #1: replicate #1 keeps the + unreplicated case's seed, so adding coverage extends a battery + instead of redefining the cell already in it. Each case also + mixes its own name into the run-wide seed, so cases no longer + all begin from identical fixed bytes. + + * **`family-alpha on`** runs each of the M expanded cells at + `alpha / M`, making the battery a test at `alpha` family-wise + rather than only reporting the union bound. Off by default. + + * **Report schema is now `censor/report-v3`.** The two seeds are + named apart — `samplerSeed` in the header, `orderSeed` in each + case result — where v2 called both `seed`. The resolved order + seed also appears in pretty and plain output, not only in JSON; + it is what replays a case, and a reader should not have to + reach for the JSON to find it. + + * **The CDF channel reports per-cut-point detail.** `resCutPoints` + and the `resPeakCdf` field are replaced by `resCdf :: + [(Double, Double)]`, pairing each cut point with its + component's peak log e-value, so a CDF-driven rejection names + the threshold that found the difference. `resPeakCdf` remains, + as a function taking the maximum. In JSON, `cutPoints` becomes + `cdf` as `[cut point, peak]` pairs. + + * Documentation corrections. The null is *stronger* than "the two + classes induce the same timing distribution", not weaker: + exchangeability implies equal marginals, and equal marginals + alone do not imply an exchangeable joint law. What delivers it + is the randomised order, given class-blind within-pair nuisance + dynamics — an assumption now stated rather than elided. The + order-bit seed's OS-entropy source is documented as the normal + path, not an unconditional one, since `/dev/urandom` failure + falls back to the monotonic clock. Stale `K=4` claims are + corrected to `K = 4 + n`. + + * `censor-viz` uses `runCTWith` instead of a hand-rolled copy of + the driver, which had drifted: it omitted the CDF components and + the prologue while claiming to mirror `runCT`. The AEAD suite + draws its public input (nonce, AAD, plaintext) once per pair and + shares it across both classes, rather than independently per + class. + +- 0.4.0 (2026-07-30) + * The null is now stated, and tested, as conditional + *exchangeability* of the measured pair `(ta, tb)` rather than + symmetry of `d = ta - tb`. Exchangeability is what the + randomised A/B order actually delivers; every hedge component + is an antisymmetric functional of the pair, and each such + functional is conditionally symmetric about zero under the + null. + + * New **CDF-indicator channel**: one bounded-mean e-process on + `1[ta <= q] - 1[tb <= q]` per warmup-fixed cut point `q` (the + deciles and quartiles of the pooled warmup readings, + deduplicated). This detects dispersion leaks — a target whose + timing variance depends on the secret while its mean does not — + which leave `d` symmetric and were invisible to every previous + component. `K` grows from 4 to `4 + n`; `Result` gains + `resPeakCdf` and `resCutPoints`, and `LeakShape` gains + `CdfShift`. + + Previously such a target passed unconditionally. The + variance-only cell in the validation suite moves from H_0 to + the power table accordingly. + + The functional family is finite, so this is still not an + omnibus test of distributional equality. That limit is now + documented rather than left implicit. + + * `Attribution` is no longer a four-way label. It is a record + carrying the `ControlVerdict` plus *both* control runs in full, + and `TargetLeak` is renamed `ControlsPass`. The A/A and B/B + runs are negative controls: they can convict the harness but + cannot acquit it, so the old name overstated what they + establish. The JSON `attribution` string field becomes a + `controls` object with `verdict`, `aa`, and `bb`. + + * Clipping is counted at each of the hedge's three magnitude + bounds, not only the tight one. `Result` gains `resClipped4` + (`|d| > 4c`) and `resClipped16` (`|d| > 16c`) alongside + `resClipped`, and `resultToJSON` emits them as `clipped4` and + `clipped16`. The counts nest, and they qualify different + quantities: `resClipped` bounds what the tight magnitude + component could see, while `resClipped16` qualifies + `resEffect`, `16c` being the bound the effect interval's own + input is clipped to. A consumer quoting that interval + previously had no way to tell a starved tight component from a + truncated interval. + + `HighClipRate` accordingly carries a `ClipRates` record with + the fraction at all three bounds rather than a bare `Double` + (`clipFraction`, `clipFraction4`, `clipFraction16` in JSON). + Its trigger is unchanged — the counts nest, so the tight rate + is the largest of the three and one trigger covers the + profile. `Censor.Runner` exports `clipText`, which renders the + profile for the one-line and terminal reports and stays as + terse as it was when nothing clipped past `c`. + + * Reports carry suite-wide alpha accounting: `totals` gains + `alpha` and `familyAlpha` (the union bound `M * alpha` over `M` + cells), and multi-case footers render it. Censor's guarantee is + per run; a battery that fails when any cell rejects has the + family bound, not alpha. + + * The default order-bit seed is drawn from OS entropy + (`/dev/urandom`) rather than `getMonotonicTimeNSec`; a clock + reading is not independent entropy, and the nuisance process + the order bit must be independent of may itself be periodic in + that same clock. The resolved seed is reported as `resSeed`, so + a randomised run stays exactly replayable. + + * The `censor` CLI splits `--seed` (input samplers) from + `--order-seed` (the A/B order bit). They previously shared one + value, weakening the independence the conditional null needs. + + * `Censor.Runner.Env` records the conditions a run executed + under: a best-effort host snapshot (OS, arch, kernel release, + CPU model, core count, Linux cpufreq/SMT/perf_event knobs, load + average, UTC timestamp) taken once at run start, backed by a + small C shim. Rides on the report header and into the JSON. + Alongside it, `calibrateBatchReport` records the meter's noise + floor (`Noise`: median and IQR of repeated readings) at the + selected batch, so a `Pass` obtained where dispersion rivals + the effect sizes of interest can be recognised as such. + + * `TraceCase` carries an explicit `BatchPolicy` — `SingleShot`, + `RepeatableAuto`, or `FixedBatch n`. `runTraceSuite` no longer + auto-calibrates every case: repeating a pure Haskell target + forces one thunk and then measures no-ops, so a calibrated + batch counted no-ops as work. All bundled demo targets are + pure and now declare `SingleShot`. `--batch N` overrides every + case's policy; plain suites reject the flag. `rhAutoBatch` + becomes `rhPerCaseBatch`, rendering `batch=per-case`. + + * `Hypothesis` gains a `prepare` field: a per-pair prologue run + before either sampler and outside the timed region. New + `fixVsRandomCtx` uses it to draw one fresh public context per + pair and build both classes around that same context, so the + tested axis is secret dependence conditional on identical + fresh public input. Previously the completion ran independently + per class, so public inputs were either independently random + across the pair (adding nuisance variance to `d`) or fixed for + the whole run (testing one public input). `FFIHypothesis` + gains the matching `ffiPrepare`. + + * New `Censor.Runner.Manifest` and a `--manifest PATH` mode on + the `censor` CLI: a declarative battery of cases, driven by one + dlopen and emitted as a single report carrying every case, its + controls, the host environment, and the family-wise alpha. + Replaces the per-symbol process loop with hand-stitched output, + which duplicated the tool version and config in every script. + Cases support `replicates=N` to run several independent fixed + secrets, since a single pinned secret answers only whether + *that* secret times differently from random. See + `etc/example.manifest`. + + * `TraceSuite` takes a heterogeneous case list (an existential + `TraceCase`), so cases with different hypothesis payload types + share one list, and auto-attributes on `Reject`. A run collapses + to a single canonical JSON object — the same one the `json` + renderer emits to stdout, with optional per-case batch, noise, + and trace fields. `renderTrace` is gone. + + * The `censor` executable catches up with that surface: `--trace` + writes the same report object the `json` renderer emits, with + the frame trajectory embedded, rather than a separate format. + + * `Censor.Runner` exports `shapeName`; `Censor.Runner.Report` now + imports it rather than keeping a second copy that could (and + did) fall out of step with `LeakShape`. + + * `censor-secp` presents an 8-case surface: both constant-time + multipliers (`mul`, `mul_wnaf`), the ladder-based `sign_ecdsa` + / `sign_schnorr`, their precomputed-context wNAF variants, and + `ecdh` / `derive_pub`. The four signing cases hold the message + (and Schnorr aux) fixed and public across both classes, so the + derived RFC6979 / BIP340 nonce is deterministic in the fixed + class and fix-vs-random controls key + nonce rather than the + key alone. + + * Report schema bumped to `censor/report-v2`, reflecting the + `controls` object, the new `Result` fields (`seed`, + `cutPoints`, `peaks.cdf`, `clipped4`, `clipped16`), the + `totals` alpha fields, and `"batch":"per-case"`. + +- 0.3.1 (2026-07-09) + * The `censor` executable renders through `Censor.Runner.Report` + like the other suites. `--json` and `--summary` become + `--format pretty|json|plain`; verdict and attribution ride on + a single `CaseReport`. Exit codes and the `--trace` / + `--attribute` behavior are unchanged. + +- 0.3.0 (2026-07-09) + * `Censor.Runner.Report`: uniform report rendering with a + header/case/footer data model and three renderers: + `pretty` (the ppad terminal aesthetic), `json` + (line-oriented `censor/report-v1` object), and `plain` + (ASCII/CI-safe). + + * `Suite` and `TraceSuite` scaffolds package the full + test-suite lifecycle (arg parse, meter selection, header + assembly, `calibrateBatch`, per-case loop, optional trace + JSON dump) so a tool's `Main.hs` reduces to the + hypotheses and the case list. + + * `Censor.Runner.DL` and the `censor` executable: a + dlopen-based runner that drives a constant-time + hypothesis against a foreign target resolved by name from + a shared library. + + * `diagnose` interprets a `Result` into actionable + `Advisory`s (clip-rate warning, low-power `Pass`, + rejection-driver hint); `summary` and `resultToJSON` give + one-line and JSON views of the same evidence; + `calibrateBatchReport` returns the auto-batch decision + alongside its calibration probes. + +- 0.2.0 (2026-07-07) + * Hardware performance-counter meters on Linux + (instructions retired, branches retired, cycles) via + perf_event_open, alongside the existing wall-clock meter. + + * Foreign-function target support ('Censor.FFI'): a pinned + workspace shared across pairs lets C, Rust, or Go targets + run under the same sequential CT driver. + + * Fix-vs-random hypothesis and 'Attribution': A/A and B/B + diagnostics fold into a four-way attribution of any + rejection (target, sampler, or harness). + + * 'Result' now reports an anytime-valid p-value and a + time-uniform confidence interval on the leak's effect + size, with named fields throughout. + + * Mixture internals delegated to ppad-eproc; verdicts + unchanged. + + * 'Censor.Rng' extracts the splitmix64 sampler PRNG + previously duplicated across demos. + +- 0.1.0 (2026-05-31) + * Initial release. Sequential constant-time testing via + anytime-valid e-processes, with wall-clock measurement on macOS + and Linux. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2026 Jared Tobin + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-type-defaults #-} +{-# LANGUAGE BangPatterns #-} + +module Main where + +import Control.DeepSeq (NFData(..)) +import Criterion.Main +import qualified Censor as C +import Censor.Meter (Meter(..)) + +-- the small ADTs Result and Verdict are fully strict in their fields, +-- so WHNF == NF. orphan instance keeps the library API untouched. +instance NFData C.Result where rnf !_ = () + +-- A constant-returning meter. Still runs the wrapped action so any +-- per-call cost gets charged, but the reading itself is fixed -- this +-- isolates framework driver overhead from real meter / target work and +-- guarantees a deterministic Pass path (both classes report identical +-- readings, so the e-process wealth stays flat and the run goes to +-- budget). +constMeter :: Meter +constMeter = Meter $ \k act -> do + let go 0 = pure () + go i = act >> go (i - 1) + go k + pure 100 +{-# NOINLINE constMeter #-} + +-- noop hypothesis: samplers produce (), target does nothing. Combined +-- with constMeter, this exercises only the runCT driver loop and the +-- ppad-eproc per-step update. +noopHyp :: C.Hypothesis () +noopHyp = C.Hypothesis + { C.target = \_ -> pure () + , C.prepare = pure () + , C.sampleA = pure () + , C.sampleB = pure () + } + +main :: IO () +main = defaultMain [ + runCT_budget + , runCT_batch + ] + +-- runCT driver overhead vs budget. With a noop target + constMeter, +-- the per-pair cost is (sampleA + sampleB + 2 * meter-overhead + +-- EP.update + EP.decide). Scaling should be linear in budget after +-- warmup is amortised. +runCT_budget :: Benchmark +runCT_budget = + let cfg n = C.defaultConfig + { C.cfgBudget = n + , C.cfgWarmup = 50 + , C.cfgBatch = 1 + } + in bgroup "runCT (noop target, const meter, batch=1)" [ + bench "budget=100" $ nfIO (C.runCT constMeter (cfg 100) noopHyp) + , bench "budget=1000" $ nfIO (C.runCT constMeter (cfg 1000) noopHyp) + , bench "budget=10000" $ nfIO (C.runCT constMeter (cfg 10000) noopHyp) + , bench "budget=100000" $ nfIO (C.runCT constMeter (cfg 100000) noopHyp) + ] + +-- runCT driver overhead vs batch size. Total target invocations is +-- budget * batch; for a noop target the relative driver vs runOne cost +-- should be visible here. +runCT_batch :: Benchmark +runCT_batch = + let cfg b = C.defaultConfig + { C.cfgBudget = 1000 + , C.cfgWarmup = 50 + , C.cfgBatch = b + } + in bgroup "runCT (noop target, const meter, budget=1000)" [ + bench "batch=1" $ nfIO (C.runCT constMeter (cfg 1) noopHyp) + , bench "batch=10" $ nfIO (C.runCT constMeter (cfg 10) noopHyp) + , bench "batch=100" $ nfIO (C.runCT constMeter (cfg 100) noopHyp) + , bench "batch=1000" $ nfIO (C.runCT constMeter (cfg 1000) noopHyp) + ] diff --git a/bench/Weight.hs b/bench/Weight.hs new file mode 100644 --- /dev/null +++ b/bench/Weight.hs @@ -0,0 +1,62 @@ +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-type-defaults #-} +{-# LANGUAGE BangPatterns #-} + +module Main where + +import Control.DeepSeq (NFData(..)) +import qualified Censor as C +import Censor.Meter (Meter(..)) +import Weigh + +instance NFData C.Result where rnf !_ = () + +constMeter :: Meter +constMeter = Meter $ \k act -> do + let go 0 = pure () + go i = act >> go (i - 1) + go k + pure 100 +{-# NOINLINE constMeter #-} + +noopHyp :: C.Hypothesis () +noopHyp = C.Hypothesis + { C.target = \_ -> pure () + , C.prepare = pure () + , C.sampleA = pure () + , C.sampleB = pure () + } + +-- note that 'weigh' doesn't work properly in a repl +main :: IO () +main = mainWith $ do + runCT_budget + runCT_batch + +-- per-pair allocation should be constant: a budget-scaled run that +-- allocates O(budget) bytes per pair would surface as super-linear +-- growth across the rows. +runCT_budget :: Weigh () +runCT_budget = + let cfg n = C.defaultConfig + { C.cfgBudget = n + , C.cfgWarmup = 50 + , C.cfgBatch = 1 + } + in wgroup "runCT (noop target, const meter, batch=1)" $ do + io "budget=100" (C.runCT constMeter (cfg 100)) noopHyp + io "budget=1000" (C.runCT constMeter (cfg 1000)) noopHyp + io "budget=10000" (C.runCT constMeter (cfg 10000)) noopHyp + io "budget=100000" (C.runCT constMeter (cfg 100000)) noopHyp + +runCT_batch :: Weigh () +runCT_batch = + let cfg b = C.defaultConfig + { C.cfgBudget = 1000 + , C.cfgWarmup = 50 + , C.cfgBatch = b + } + in wgroup "runCT (noop target, const meter, budget=1000)" $ do + io "batch=1" (C.runCT constMeter (cfg 1)) noopHyp + io "batch=10" (C.runCT constMeter (cfg 10)) noopHyp + io "batch=100" (C.runCT constMeter (cfg 100)) noopHyp + io "batch=1000" (C.runCT constMeter (cfg 1000)) noopHyp diff --git a/cbits/censor_clock.c b/cbits/censor_clock.c new file mode 100644 --- /dev/null +++ b/cbits/censor_clock.c @@ -0,0 +1,22 @@ +/* Tick-resolved monotonic clock for Darwin. + * + * GHC's getMonotonicTimeNSec dispatches to + * clock_gettime(CLOCK_MONOTONIC), which macOS quantises to + * microseconds. That collapses sub-microsecond structure and + * concentrates wall readings onto 1000 ns atoms, which in turn + * lands warmup-calibrated CDF cut points exactly on quantisation + * boundaries (see issues/handled/ISSUE2.md). CLOCK_UPTIME_RAW is backed + * by the hardware counter (the mach_absolute_time time base) and + * resolves at its tick rate -- ~42 ns on 24 MHz Apple Silicon + * counters, finer where the counter runs faster. + */ +#if defined(__APPLE__) + +#include +#include + +uint64_t censor_monotonic_ns(void) { + return clock_gettime_nsec_np(CLOCK_UPTIME_RAW); +} + +#endif diff --git a/cbits/censor_dl.c b/cbits/censor_dl.c new file mode 100644 --- /dev/null +++ b/cbits/censor_dl.c @@ -0,0 +1,23 @@ +/* Portable dlopen/dlsym/dlclose/dlerror shim for Censor.Runner.DL. + * Baked flags: RTLD_NOW so unresolved symbols surface at open time; + * RTLD_LOCAL so the library's symbols do not leak into the global + * scope. Both constants differ in value between glibc and Darwin, so + * the flag word is set here rather than on the Haskell side. */ + +#include + +void *censor_dlopen(const char *path) { + return dlopen(path, RTLD_NOW | RTLD_LOCAL); +} + +void *censor_dlsym(void *handle, const char *name) { + return dlsym(handle, name); +} + +int censor_dlclose(void *handle) { + return dlclose(handle); +} + +const char *censor_dlerror(void) { + return dlerror(); +} diff --git a/cbits/censor_env.c b/cbits/censor_env.c new file mode 100644 --- /dev/null +++ b/cbits/censor_env.c @@ -0,0 +1,72 @@ +/* Host-environment shims for Censor.Runner.Env: load average, kernel + * release, a UTC timestamp, and (on Darwin) the CPU model string. + * + * Everything is best-effort: each call returns 0 (or, for loadavg, + * the sample count) on success and -1 when the facility is absent on + * the host, and the Haskell side maps failure to Nothing. On Windows + * every call fails; the fields simply stay unpopulated there. + */ + +#include + +#if !defined(_WIN32) + +#include +#include +#include +#include +#include + +#if defined(__APPLE__) +#include +#endif + +int censor_env_loadavg(double *out) { + return getloadavg(out, 3); +} + +/* via sysconf, not GHC's getNumProcessors: the latter reports 1 on + * the non-threaded RTS. */ +int censor_env_cores(void) { + long n = sysconf(_SC_NPROCESSORS_ONLN); + if (n < 1) return -1; + return (int) n; +} + +int censor_env_kernel(char *buf, size_t n) { + struct utsname u; + if (uname(&u) != 0) return -1; + if ((size_t) snprintf(buf, n, "%s", u.release) >= n) return -1; + return 0; +} + +int censor_env_time(char *buf, size_t n) { + time_t t = time(NULL); + struct tm tm; + if (gmtime_r(&t, &tm) == NULL) return -1; + if (strftime(buf, n, "%Y-%m-%dT%H:%M:%SZ", &tm) == 0) return -1; + return 0; +} + +int censor_env_cpu(char *buf, size_t n) { +#if defined(__APPLE__) + size_t len = n; + if (sysctlbyname("machdep.cpu.brand_string", buf, &len, NULL, 0) != 0) + return -1; + return 0; +#else + /* on Linux the Haskell side reads /proc/cpuinfo instead. */ + (void) buf; (void) n; + return -1; +#endif +} + +#else + +int censor_env_loadavg(double *out) { (void) out; return -1; } +int censor_env_cores(void) { return -1; } +int censor_env_kernel(char *buf, size_t n) { (void) buf; (void) n; return -1; } +int censor_env_time(char *buf, size_t n) { (void) buf; (void) n; return -1; } +int censor_env_cpu(char *buf, size_t n) { (void) buf; (void) n; return -1; } + +#endif diff --git a/cbits/censor_perf.c b/cbits/censor_perf.c new file mode 100644 --- /dev/null +++ b/cbits/censor_perf.c @@ -0,0 +1,79 @@ +/* Linux perf_event_open shim for Censor.Meter's hardware-counter + * meters. We count a single hardware event for the calling thread in + * user space only (exclude_kernel), which is permitted to unprivileged + * processes at kernel.perf_event_paranoid <= 2. + * + * The counter is thread-affine (pid == 0 binds it to the opening + * thread), so the Haskell side opens it and runs every measurement on + * the same bound OS thread. + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +static long censor_perf_event_open(struct perf_event_attr *attr, pid_t pid, + int cpu, int group, unsigned long flags) { + return syscall(__NR_perf_event_open, attr, pid, cpu, group, flags); +} + +/* counter: 0 = instructions retired, 1 = branch instructions retired, + * 2 = CPU cycles, 3 = reference cycles (constant-rate; availability + * is microarchitecture-dependent), 4 = task clock (software event, + * nanoseconds on-CPU; deliberately counts kernel time on the task's + * behalf, so task-clock minus user ref-cycle time isolates it), + * 5 = branch misses, 6 = cache misses. Returns a file descriptor + * (>= 0) on success, or -errno on failure. */ +int censor_perf_open(int counter) { + struct perf_event_attr attr; + memset(&attr, 0, sizeof(attr)); + attr.type = PERF_TYPE_HARDWARE; + attr.size = sizeof(attr); + attr.exclude_kernel = 1; + attr.exclude_hv = 1; + switch (counter) { + case 1: attr.config = PERF_COUNT_HW_BRANCH_INSTRUCTIONS; break; + case 2: attr.config = PERF_COUNT_HW_CPU_CYCLES; break; + case 3: attr.config = PERF_COUNT_HW_REF_CPU_CYCLES; break; + case 4: + attr.type = PERF_TYPE_SOFTWARE; + attr.config = PERF_COUNT_SW_TASK_CLOCK; + attr.exclude_kernel = 0; + attr.exclude_hv = 0; + break; + case 5: attr.config = PERF_COUNT_HW_BRANCH_MISSES; break; + case 6: attr.config = PERF_COUNT_HW_CACHE_MISSES; break; + default: attr.config = PERF_COUNT_HW_INSTRUCTIONS; break; + } + attr.disabled = 1; + + long fd = censor_perf_event_open(&attr, 0 /* this thread */, + -1 /* any cpu */, -1, 0); + if (fd < 0) return -errno; + return (int) fd; +} + +/* Reset and arm the counter immediately before a measured region. */ +void censor_perf_begin(int fd) { + ioctl(fd, PERF_EVENT_IOC_RESET, 0); + ioctl(fd, PERF_EVENT_IOC_ENABLE, 0); +} + +/* Disarm and read the accumulated count after a measured region. */ +uint64_t censor_perf_end(int fd) { + ioctl(fd, PERF_EVENT_IOC_DISABLE, 0); + uint64_t value = 0; + ssize_t n = read(fd, &value, sizeof(value)); + (void) n; + return value; +} + +void censor_perf_close(int fd) { + close(fd); +} diff --git a/lib/Censor.hs b/lib/Censor.hs new file mode 100644 --- /dev/null +++ b/lib/Censor.hs @@ -0,0 +1,1269 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: Censor +-- Copyright: (c) 2026 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Sequential constant-time testing. +-- +-- Declare a t'Hypothesis' (an @IO@ action plus two input samplers); +-- 'runCT' measures paired class-A \/ class-B timings in random order, +-- streams them through an anytime-valid test, and either rejects (a +-- leak is detected) or exhausts its budget. Type-I error is +-- controlled at 'cfgAlpha' whenever the run stops. +-- +-- = The null +-- +-- The null is /conditional exchangeability/ of the measured pair +-- @(ta, tb)@: given the past, swapping the class labels leaves the +-- joint law unchanged. The randomised per-pair order supplies it, +-- provided the nuisance dynamics within a pair (cache and predictor +-- state, frequency) are blind to the class labels; randomisation +-- cannot undo a nuisance process that reacts to the class itself. +-- +-- = The test +-- +-- Every component bets on an /antisymmetric functional/ of the pair +-- (@g(ta, tb) = -g(tb, ta)@), which is conditionally symmetric about +-- zero under the null. The test is a uniform mixture of e-processes +-- ("Numeric.Eproc.Mixture") over a family of them, with +-- @d = ta - tb@: +-- +-- * /sign/: @sign d@. Catches an asymmetry of @d@ itself, +-- including bulk shifts that heavy tails hide from the +-- magnitude components. +-- * /magnitude/: @d@ clipped to @[-c, c]@, @[-4c, 4c]@, and +-- @[-16c, 16c]@, for a warmup-estimated @c@. The tight bound is +-- the most powerful against small consistent shifts; the wide +-- ones keep rare outliers. +-- * /CDF/: @1[ta <= q] - 1[tb <= q]@ at warmup-fixed cut points +-- @q@. Catches dispersion leaks, which leave @d@ symmetric. +-- +-- The family is finite, so the test is not exhaustive: a departure +-- that moves none of these functionals off zero passes. Read a +-- 'Pass' as \"no evidence on these channels\", not as proof of +-- constant time. + +module Censor ( + -- * Hypothesis + Hypothesis(..) + , fixVsRandom + , fixVsRandomCtx + + -- * Configuration + , Config(..) + , defaultConfig + + -- * Result + , Result(..) + , resPeakCdf + + -- * Advisories + , Advisory(..) + , ClipRates(..) + , LeakShape(..) + , diagnose + , leakShape + + -- * Errors + , CensorError(..) + + -- * Running + , runCT + , runCTWith + , Frame(..) + , runCTAttributed + + -- * Batch calibration + , calibrateBatch + , CalibReport(..) + , calibrateBatchReport + , Noise(..) + + -- * Baseline probe + , baselineReading + + -- * A\/A and B\/B negative controls + , toAA + , runAA + , toBB + , runBB + , Attribution(..) + , ControlVerdict(..) + , attribute + + -- * Measurement (re-exports) + , Meter(..) + , wallClock + , Counter(..) + , MeterError(..) + , withCounter + + -- * Sampler support (re-exports) + , Rng + , mkRng + , nextWord + , reseed + , randomBytes + ) where + +import Control.Exception (Exception, IOException, throwIO, try) +import Control.Monad (unless) +import qualified Data.Bits as B +import qualified Data.ByteString as BS +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.List (sort, sortBy) +import Data.Primitive.SmallArray + (SmallArray, indexSmallArray, smallArrayFromListN) +import Data.Word (Word64) +import GHC.Clock (getMonotonicTimeNSec) +import System.IO (IOMode(ReadMode), withBinaryFile) +import qualified Numeric.Eproc.Bernoulli.TwoSided as EPSign +import qualified Numeric.Eproc.Bounded as EPMagn +import qualified Numeric.Eproc.ConfSeq as EPCS +import qualified Numeric.Eproc.Mixture as EPMix +import Numeric.Eproc.Bounded (Bettor(Newton), ConfigError) + +import Censor.Meter +import Censor.Rng + (Rng, mkRng, nextWord, randomBytes, reseed, splitMix) + +-- | A constant-time hypothesis. +-- +-- * @target@: the @IO@ action under test. +-- * @prepare@: a per-pair prologue, run before either sampler and +-- outside the timed region; @pure ()@ unless the classes share +-- per-pair state (see 'fixVsRandomCtx'). +-- * @sampleA@, @sampleB@: samplers for the two input classes, +-- typically \"fixed\" and \"random\". +-- +-- Only @target@ is timed, so any asymmetry in how the samplers +-- prepare inputs shows up as a class difference. Return inputs in +-- normal form, build the fixed class by the same code path as the +-- random one (not as a top-level constant), and keep the samplers +-- symmetric in allocation and in where the secret is read from. +-- 'fixVsRandom' does this for the usual case. +data Hypothesis a = Hypothesis + { target :: !(a -> IO ()) + , prepare :: !(IO ()) + , sampleA :: !(IO a) + , sampleB :: !(IO a) + } + +-- | A dudect-style /fix-vs-random/ t'Hypothesis', from a target, a +-- secret sampler, a re-materialisation function, and a completion +-- building a full input around a secret. +-- +-- The fixed secret is drawn once from the sampler, so it is an +-- ordinary heap value like the random class's. Each sample, class +-- A draws and discards a fresh secret and class B keeps its draw, +-- so the samplers allocate alike. Both classes then re-materialise +-- the pinned secret: class A completes around the copy, class B +-- discards it. With a real copy (for a 'BS.ByteString', +-- @\\s -> evaluate (BS.copy s)@), neither class is alone in reading +-- one long-lived, cache-hot value, a locality asymmetry that the +-- A\/A and B\/B controls cannot see. Pass 'pure' only for types +-- with no cheap copy. +-- +-- The completion runs identically in both classes, so per-pair +-- public inputs stay fresh on both sides. The sampler, +-- re-materialiser, and completion must return values in normal +-- form. +-- +-- > hyp <- fixVsRandom +-- > (\x -> () <$ evaluate (inv x)) -- target +-- > (randomMont g) -- secret sampler +-- > pure -- no re-materialiser +-- > pure -- input is just the secret +fixVsRandom + :: (a -> IO ()) -- ^ target + -> IO s -- ^ secret sampler + -> (s -> IO s) -- ^ re-materialise a secret into a fresh value + -> (s -> IO a) -- ^ complete an input around a secret + -> IO (Hypothesis a) +fixVsRandom tgt sec dup embed = do + !fix <- sec + pure Hypothesis + { target = tgt + , prepare = pure () + , sampleA = do + !_ <- sec -- draw and discard: balance class B + !s <- dup fix + embed s + , sampleB = do + !s <- sec + !_ <- dup fix -- copy and discard: balance class A + embed s + } + +-- | A /fix-vs-random/ t'Hypothesis' whose two classes share one +-- freshly drawn public context per pair. +-- +-- 'fixVsRandom' completes each class independently, so per-pair +-- public inputs (message, nonce, modulus) either differ across the +-- pair, adding nuisance variance to @d@, or are pinned for the +-- whole run, testing a single public input. Here 'prepare' draws +-- one context per pair and both classes are built around it, so +-- the test is of secret dependence given identical fresh public +-- input. The null is unaffected: given the context, the two +-- readings are still exchangeable under H_0. +-- +-- The re-materialisation function plays the same role as in +-- 'fixVsRandom'. +-- +-- > hyp <- fixVsRandomCtx +-- > (\(k, m) -> () <$ evaluate (mac k m)) -- target +-- > (randomBytes g 32) -- secret sampler +-- > (\k -> evaluate (BS.copy k)) -- re-materialise +-- > (randomBytes g 256) -- public context +-- > (\msg key -> pure (key, msg)) -- build the input +fixVsRandomCtx + :: (a -> IO ()) -- ^ target + -> IO s -- ^ secret sampler + -> (s -> IO s) -- ^ re-materialise a secret into a fresh value + -> IO c -- ^ public-context sampler (once per pair) + -> (c -> s -> IO a) -- ^ build an input from context and secret + -> IO (Hypothesis a) +fixVsRandomCtx tgt sec dup ctx embed = do + !fix <- sec + -- seeded with a real draw so the ref is total; 'prepare' + -- overwrites it before the first pair is ever measured. + !c0 <- ctx + ref <- newIORef c0 + pure Hypothesis + { target = tgt + , prepare = do + !c <- ctx + writeIORef ref c + , sampleA = do + !_ <- sec -- draw and discard: balance class B + !s <- dup fix + !c <- readIORef ref + embed c s + , sampleB = do + !s <- sec + !_ <- dup fix -- copy and discard: balance class A + !c <- readIORef ref + embed c s + } + +-- | Driver configuration. +data Config = Config + { cfgAlpha :: !Double + -- ^ significance level. + , cfgBudget :: !Int + -- ^ maximum sample pairs to consume. + , cfgBatch :: !Int + -- ^ target repetitions per timed region, all on one pre-drawn + -- sample. This multiplies real work only when each repetition + -- recomputes (an FFI call, mutable state). For a pure target + -- @\\a -> evaluate (f a)@ the thunk is forced once and the rest + -- are no-ops, so use @1@, and widen the work if it is + -- sub-quantum. + , cfgWarmup :: !Int + -- ^ warmup pairs, from which the clip bound @c@ (twice the + -- @~p99@ of @|d|@) and the CDF cut points are fixed. At @100@ + -- or fewer, the @p99@ is the sample maximum. + , cfgSeed :: !(Maybe Word64) + -- ^ seed for the per-pair A\/B order bit. 'Nothing' (the + -- default) draws one from @\/dev\/urandom@, falling back to the + -- monotonic clock if that is unreadable. The seed used is + -- reported as 'resSeed' for replay. Keep it independent of any + -- sampler seed: the null needs the order bit independent of the + -- timings. + , cfgMargin :: !(Maybe Double) + -- ^ relative interval-null margin. 'Nothing' (the default) tests + -- the sharp null. @Just m@ resolves at warmup to an absolute + -- margin @delta = m * median@ of the pooled per-batch readings + -- and tests @|E d_clipped| <= delta@: the magnitude components + -- become interval-null tests and alone gate the verdict, while + -- the sign and CDF components still report peaks as + -- diagnostics. Relative, because the channels that motivate it + -- (frequency, interrupts, scheduling) scale with the + -- timed-region duration. Meant for the wall meter on + -- frequency-scaled hosts (see the README); keep it 'Nothing' + -- under the PMU meters. The resolved margin must land in + -- @(0, c)@, else the run throws 'InvalidConfig'; it is reported + -- as 'resMargin'. + } deriving Show + +-- | Defaults: @alpha = 1e-6@, budget @100000@ pairs, batch 1 (no +-- inner repetition), warmup 200 pairs, order-bit seed drawn from +-- OS entropy per run, no margin (sharp null). +defaultConfig :: Config +defaultConfig = Config + { cfgAlpha = 1.0e-6 + , cfgBudget = 100000 + , cfgBatch = 1 + , cfgWarmup = 200 + , cfgSeed = Nothing + , cfgMargin = Nothing + } + +-- | Test outcome: 'Reject' (a leak was detected) or 'Pass' (none +-- within budget), each carrying the same run report. +-- +-- Evidence is on the log e-value scale: a run starts at @0@ and +-- rejects when the mixture's running supremum ('resPeakLogW') +-- crosses @log(1 \/ alpha)@. The per-component peaks say which +-- channel found the evidence. They are diagnostic only: each is a +-- supremum at its own time, and the verdict latches on the +-- mixture. +data Result + = Reject + { resPairs :: {-# UNPACK #-} !Int + -- ^ sample pairs consumed. + , resPeakLogW :: {-# UNPACK #-} !Double + -- ^ peak (supremum-so-far) log e-value of the mixture; + -- starts at @0@, crosses @log(1 \/ alpha)@ on rejection. + , resPValue :: {-# UNPACK #-} !Double + -- ^ the anytime-valid p-value @min 1 (exp -resPeakLogW)@; + -- at or below 'cfgAlpha' iff the verdict is 'Reject'. + , resEffect :: !(Double, Double) + -- ^ anytime-valid @1 - cfgAlpha@ confidence interval for the + -- mean of @d@ clipped to @[-16c, 16c]@, in meter units per + -- batch. Covers zero on a constant-time target. It can still + -- be wide after an early 'Reject': detection outpaces + -- estimation. Once the evidence pins the mean below the + -- estimation grid's resolution, the last resolvable interval + -- is reported. 'resClipped16' says how often the clipping + -- bit. + , resClipped :: {-# UNPACK #-} !Int + -- ^ pairs whose @|d|@ exceeded 'resBound' and was clipped for + -- the tight magnitude component. A large share of + -- 'resPairs' means the bound was too tight: raise + -- 'cfgWarmup' or 'cfgBatch'. + , resClipped4 :: {-# UNPACK #-} !Int + -- ^ pairs whose @|d|@ exceeded @4 * 'resBound'@. + , resClipped16 :: {-# UNPACK #-} !Int + -- ^ pairs whose @|d|@ exceeded @16 * 'resBound'@, the bound + -- behind the widest magnitude component and 'resEffect'. + , resBound :: {-# UNPACK #-} !Double + -- ^ the tight clip bound @c@ estimated during warmup + -- (@max 1 (2 * p99(|d|))@). + , resPeakSign :: {-# UNPACK #-} !Double + -- ^ peak log e-value of the sign component. + , resPeakMagn :: {-# UNPACK #-} !Double + -- ^ peak log e-value of the magnitude component at @c@. + , resPeakMagn4 :: {-# UNPACK #-} !Double + -- ^ peak log e-value of the magnitude component at @4c@. + , resPeakMagn16 :: {-# UNPACK #-} !Double + -- ^ peak log e-value of the magnitude component at @16c@. + , resCdf :: ![(Double, Double)] + -- ^ the CDF channel: each warmup-fixed cut point (ascending) + -- with its component's peak log e-value, so a CDF-driven + -- rejection names the threshold that separated the classes. + -- Empty when warmup readings were degenerate. + , resSeed :: {-# UNPACK #-} !Word64 + -- ^ the order-bit seed the run used; feed it back as + -- 'cfgSeed' to replay the same A\/B order. + , resMargin :: !(Maybe Double) + -- ^ the /absolute/ margin resolved from 'cfgMargin', in meter + -- units per batch; 'Nothing' under the sharp null. When + -- present, a 'Reject' means the mean effect exceeds it, and + -- a high 'resPeakSign' on a 'Pass' marks a systematic within + -- tolerance. + } + | Pass + { resPairs :: {-# UNPACK #-} !Int + , resPeakLogW :: {-# UNPACK #-} !Double + , resPValue :: {-# UNPACK #-} !Double + , resEffect :: !(Double, Double) + , resClipped :: {-# UNPACK #-} !Int + , resClipped4 :: {-# UNPACK #-} !Int + , resClipped16 :: {-# UNPACK #-} !Int + , resBound :: {-# UNPACK #-} !Double + , resPeakSign :: {-# UNPACK #-} !Double + , resPeakMagn :: {-# UNPACK #-} !Double + , resPeakMagn4 :: {-# UNPACK #-} !Double + , resPeakMagn16 :: {-# UNPACK #-} !Double + , resCdf :: ![(Double, Double)] + , resSeed :: {-# UNPACK #-} !Word64 + , resMargin :: !(Maybe Double) + } + deriving Show + +-- | The largest peak log e-value across the CDF-indicator +-- components — @0@ when warmup resolved no cut points. A maximum +-- over 'resCdf', which keeps the per-cut-point detail. +resPeakCdf :: Result -> Double +resPeakCdf = foldr (\(_, p) acc -> max p acc) 0 . resCdf + +-- | An actionable observation about a t'Result', produced by +-- 'diagnose'. +data Advisory + = HighClipRate !ClipRates + -- ^ More than 5% of pairs were clipped at @c@, starving the tight + -- magnitude component: raise 'cfgWarmup' or 'cfgBatch', or + -- treat the run with suspicion. Carries the rate at all three + -- bounds; a nonzero rate at @16c@ means 'resEffect' describes a + -- truncated variable. + | LowPower !Double + -- ^ On 'Pass' only: the effect-interval half-width exceeded the + -- tight clip bound @c@ (the ratio is carried here, in units of + -- @c@). Leaks with a mean shift below that scale would not have + -- been resolved by this run; raise 'cfgBudget' to sharpen the + -- interval. + | RejectionDriver !LeakShape + -- ^ On 'Reject' only: which channel of the hedge drove the + -- detection, i.e. what shape of leak was found. + deriving (Eq, Show) + +-- | The share of pairs clipped at each of the hedge's three +-- magnitude bounds, carried by 'HighClipRate'. Nested by +-- construction: @clipWidest <= clipWide <= clipTight@, since +-- @|d| > 16c@ implies @|d| > 4c@ implies @|d| > c@. +data ClipRates = ClipRates + { clipTight :: {-# UNPACK #-} !Double + -- ^ fraction of pairs with @|d| > c@. + , clipWide :: {-# UNPACK #-} !Double + -- ^ fraction of pairs with @|d| > 4c@. + , clipWidest :: {-# UNPACK #-} !Double + -- ^ fraction of pairs with @|d| > 16c@ — the bound behind + -- 'resEffect'. + } deriving (Eq, Show) + +-- | The qualitative shape of a leak, inferred from the per-component +-- peaks of the hedge. Reported by 'RejectionDriver' and available +-- standalone via 'leakShape'. +data LeakShape + = BulkShift + -- ^ 'resPeakMagn' (tight magnitude) dominates: a small consistent + -- mean shift in @d@. + | ShapeLeak + -- ^ 'resPeakSign' dominates: an equal-mean asymmetry of the + -- difference itself (@P(d > 0) \/= 1\/2@). + | RareOutlier + -- ^ 'resPeakMagn4' or 'resPeakMagn16' dominates: rare-tail + -- outliers (e.g. a rarely-taken data-dependent branch). + | CdfShift + -- ^ 'resPeakCdf' dominates: the two classes' CDFs differ at a + -- warmup-fixed cut point. Typical of a dispersion (variance) + -- leak, which leaves @d@ symmetric and so registers on no + -- other channel. + | MixedShape + -- ^ No single component peak dominates by @>= 1.5x@; the leak + -- registers on several channels comparably. + deriving (Eq, Show) + +-- | Interpret a t'Result': heavy clipping, a low-power 'Pass' (the +-- effect interval is wider than the tight bound), and, on +-- 'Reject', which channel of the hedge drove the detection. Always +-- in that order, so tooling can match by position. +diagnose :: Result -> [Advisory] +diagnose r = + let rate n = if resPairs r == 0 + then 0 + else fromIntegral n / (fromIntegral (resPairs r) :: Double) + !rates = ClipRates (rate (resClipped r)) (rate (resClipped4 r)) + (rate (resClipped16 r)) + -- the counts nest, so the tight rate is the largest of the + -- three and one trigger covers the profile + clipA = [HighClipRate rates | clipTight rates > 0.05] + powerA = case r of + Pass{} -> + let !hw = (snd (resEffect r) - fst (resEffect r)) / 2 + !c = resBound r + in [LowPower (hw / c) | c > 0 && hw > c] + Reject{} -> [] + drvA = case r of + Reject{} -> [RejectionDriver (leakShape r)] + Pass{} -> [] + in clipA ++ powerA ++ drvA + +-- | Identify which channel of the hedge has the largest peak log +-- e-value in a t'Result', binning the two wider magnitude +-- components together as 'RareOutlier' and the CDF-indicator +-- components together as 'CdfShift'. Returns 'MixedShape' when no +-- single peak exceeds the next-largest by a factor of @1.5@. +-- +-- Only meaningful on a 'Reject' — on a 'Pass' every peak sits near +-- the calibrated floor of @0@ and the returned shape is not +-- informative. +-- +-- Under a margin-mode run ('resMargin' present) only the gating +-- magnitude components are ranked: the sign and CDF peaks did not +-- drive the verdict there, and a sub-margin systematic routinely +-- inflates them. +leakShape :: Result -> LeakShape +leakShape r = + let !sig = resPeakSign r + !mag = resPeakMagn r + !tl = max (resPeakMagn4 r) (resPeakMagn16 r) + !cdf = resPeakCdf r + candidates = case resMargin r of + Just _ -> [ (mag, BulkShift) + , (tl, RareOutlier) + ] + Nothing -> [ (sig, ShapeLeak) + , (mag, BulkShift) + , (tl, RareOutlier) + , (cdf, CdfShift) + ] + ranked = sortBy (\a b -> compare (fst b) (fst a)) candidates + in case ranked of + (p1, s1) : (p2, _) : _ + | p1 > 1.5 * max 0 p2 -> s1 + | otherwise -> MixedShape + _ -> MixedShape + +-- | Errors thrown by 'runCT' when calibration or configuration fails. +data CensorError = + WarmupZeroDuration + -- ^ warmup observed only zero-duration measurements: the meter + -- cannot resolve the target under the current 'cfgBatch'. + -- Raise the batch size so the target runs in an inner loop. + -- (Zero /differences/ across all warmup pairs are OK — that + -- just means the target is deterministic in @|d|@ for the + -- sampled inputs, which is the expected happy path under a + -- PMU meter on truly CT code.) + | InvalidConfig !String + -- ^ a t'Config' field was outside its admissible range. The + -- 'String' names which field and why. + | InvalidEprocConfig !ConfigError + -- ^ the underlying e-process rejected the test configuration + -- derived from 'cfgAlpha' and the warmup-estimated bound. In + -- practice this is reachable only via a 'cfgAlpha' outside + -- @(0, 1)@; adjust 'cfgAlpha' to the standard significance + -- range. + deriving (Eq, Show) + +instance Exception CensorError + +-- | A per-pair snapshot of the driver's state, delivered to the +-- observer passed to 'runCTWith' after every main-phase pair. All +-- quantities are on the same scale as the corresponding 'Result' +-- fields; recording the stream of frames reconstructs the wealth +-- trajectory without reimplementing the driver. +data Frame = Frame + { frPair :: {-# UNPACK #-} !Int + -- ^ pair index (1-based; excludes warmup). + , frDiff :: {-# UNPACK #-} !Double + -- ^ the raw per-pair difference @d = ta - tb@, pre-clip. + , frLogW :: {-# UNPACK #-} !Double + -- ^ the mixture's current log e-value at this pair. + , frLogWSup :: {-# UNPACK #-} !Double + -- ^ its supremum-so-far (the quantity the reject latches on). + , frLo :: {-# UNPACK #-} !Double + -- ^ effect-interval lower endpoint (meter units per batch). + , frHi :: {-# UNPACK #-} !Double + -- ^ effect-interval upper endpoint. + , frClipped :: !Bool + -- ^ whether @|d|@ exceeded the warmup bound and was clipped. + } deriving Show + +-- | Run a constant-time test, handing a t'Frame' to the observer after +-- every main-phase pair. The observer runs outside the timed +-- region and gets the frame lazily, so the no-op observer of +-- 'runCT' costs nothing; a recording one reconstructs the +-- trajectory (see @record@ in "Censor.Runner"). +-- +-- 1. /Warmup/: @cfgWarmup@ pairs fix the clip bound @c@ and the +-- CDF cut points (order statistics of the pooled readings, so +-- they carry no class information). +-- 2. /Main/: each pair runs in random order, and every +-- component's functional of @(ta, tb)@ feeds its e-process. The +-- run halts when the mixture crosses @1 \/ alpha@ or the budget +-- runs out. @d@ clipped to @[-16c, 16c]@ also feeds the +-- confidence sequence behind 'resEffect'. +-- +-- With 'cfgMargin' set, warmup also resolves the absolute margin, +-- and only the magnitude components gate the verdict. +-- +-- Betting on @d@ rather than on the raw readings lets the bet size +-- scale with the noise, @p99(|d|)@, rather than with the target's +-- runtime: a large gain for slow targets with little jitter. +runCTWith + :: Meter -> Config -> Hypothesis a -> (Frame -> IO ()) -> IO Result +runCTWith meter cfg hyp observe = do + validateConfig cfg + (!root, !wSeed, !mSeed) <- resolveSeeds (cfgSeed cfg) + let !samplers = orderedSamplers hyp + (!c, !qs, !meterResolves, !medR) <- warmup meter cfg hyp samplers wSeed + unless meterResolves $ throwIO WarmupZeroDuration + !mdelta <- case cfgMargin cfg of + Nothing -> pure Nothing + Just rel -> do + let !delta = rel * medR + unless (delta > 0) $ throwIO $! InvalidConfig + "cfgMargin resolves to a zero absolute margin (warmup \ + \median reading is 0); raise cfgBatch" + unless (delta < c) $ throwIO $! InvalidConfig + "cfgMargin resolves to an absolute margin at or above the \ + \warmup clip bound; lower cfgMargin (the tolerance exceeds \ + \the pair-noise scale the test bets against)" + pure (Just delta) + !hcfg <- case mkHedgeCfg (cfgAlpha cfg) c qs mdelta of + Left e -> throwIO (InvalidEprocConfig e) + Right x -> pure x + !cscfg <- case EPCS.config (negate (hcC3 hcfg)) (hcC3 hcfg) + (cfgAlpha cfg) effectGrid of + Left e -> throwIO (InvalidEprocConfig e) + Right x -> pure x + let !mixc = hcMix hcfg + finish ctor !n !st !iv !cl = ctor + n (EPMix.log_evalue_sup mixc (hsMix st)) + (EPMix.p_value mixc (hsMix st)) + iv + (clAtC cl) (clAt4C cl) (clAt16C cl) c + (EPSign.log_evalue_sup (hsSign st)) + (EPMagn.log_evalue_sup (hsMagn1 st)) + (EPMagn.log_evalue_sup (hsMagn2 st)) + (EPMagn.log_evalue_sup (hsMagn3 st)) + (cdfPeaks qs (hsCdf st)) + root + mdelta + -- the effect interval is latched: once the evidence pins the + -- mean below the grid's resolution the survivor set empties, + -- and the last resolvable interval (nested within all earlier + -- ones, so still covered by the time-uniform guarantee) is + -- what finish reports. + go !n !st !cs !iv !rng !cl + | n >= cfgBudget cfg = + pure $! finish Pass n st iv cl + | otherwise = do + let (!rng', !bit) = nextOrderBit rng + (!ta, !tb) <- runPair meter cfg hyp samplers bit + let !xa = fromIntegral ta :: Double + !xb = fromIntegral tb :: Double + !d = xa - xb + !clipped = abs d > c + !st' = updateHedge hcfg st d xa xb + !cs' = EPCS.update cscfg cs (clipD (hcC3 hcfg) d) + !iv' = case EPCS.interval cscfg cs' of + Just x -> x + Nothing -> iv + !cl' = bumpClips hcfg cl d + !n' = n + 1 + -- lazy: the frame's fields (mixture reads) are forced + -- only if the observer forces them, so runCT pays nothing. + observe (Frame n' d + (EPMix.log_evalue mixc (hsMix st')) + (EPMix.log_evalue_sup mixc (hsMix st')) + (fst iv') (snd iv') clipped) + case EPMix.decide mixc (hsMix st') of + EPMix.Reject -> pure $! finish Reject n' st' iv' cl' + _ -> go n' st' cs' iv' rng' cl' + !iv0 = (negate (hcC3 hcfg), hcC3 hcfg) + go 0 (initialHedge hcfg) (EPCS.initial cscfg) iv0 mSeed noClips + +-- | Run a constant-time test. See 'runCTWith' for the phase-by-phase +-- description; this is that driver with the per-pair observer +-- discarded. +runCT :: Meter -> Config -> Hypothesis a -> IO Result +runCT meter cfg hyp = runCTWith meter cfg hyp (\_ -> pure ()) + +-- | Run a constant-time test and, if it rejects, qualify the +-- rejection with the A\/A and B\/B negative controls +-- ('attribute'). A 'Pass' returns 'Nothing' (no controls needed); +-- a 'Reject' returns @'Just' att@ reporting whether either +-- control convicted the harness. The controls re-run the test +-- twice, so this costs up to three runs on a rejection. +runCTAttributed + :: Meter -> Config -> Hypothesis a -> IO (Result, Maybe Attribution) +runCTAttributed meter cfg hyp = do + r <- runCT meter cfg hyp + case r of + Reject{} -> do + att <- attribute meter cfg hyp + pure (r, Just att) + Pass{} -> pure (r, Nothing) + +-- | Pick a 'cfgBatch' that lifts the per-batch reading well above the +-- meter's resolution: probe a class-A sample at geometrically +-- growing batches until the reading reaches a target magnitude, +-- then scale to it. Only meaningful for targets that recompute on +-- every repetition (see 'cfgBatch'). +-- +-- > b <- calibrateBatch meter hyp +-- > r <- runCT meter cfg { cfgBatch = b } hyp +-- +-- Consumes one 'prepare' and one class-A draw; build a fresh +-- hypothesis for the run if its sampler stream must start +-- undisturbed. Returns @1@ if the meter never resolves the target +-- (the run then throws 'WarmupZeroDuration'). The result is +-- meter-specific; pin 'cfgBatch' to compare meters. +calibrateBatch :: Meter -> Hypothesis a -> IO Int +calibrateBatch meter hyp = fmap crBatch (calibrateBatchReport meter hyp) + +-- | The probe history behind 'calibrateBatchReport', for when the +-- chosen batch surprises. +data CalibReport = CalibReport + { crBatch :: {-# UNPACK #-} !Int + -- ^ the batch size the calibrator selected. + , crProbes :: ![(Int, Word64)] + -- ^ @(batch, median reading)@ pairs, oldest first. + , crCapHit :: !Bool + -- ^ 'True' when the meter never reached 'crTargetMag' before + -- the internal cap. 'crBatch' will then be @1@ and a + -- subsequent 'runCT' will throw 'WarmupZeroDuration'. + , crTargetMag :: {-# UNPACK #-} !Double + -- ^ the target per-batch reading magnitude used for refinement. + , crNoise :: !(Maybe Noise) + -- ^ the meter's noise floor at 'crBatch', sampled right after + -- selection; 'Nothing' on a cap-hit. + } deriving Show + +-- | Dispersion of meter readings, in per-batch meter units (the scale +-- of 'resBound' and 'resEffect'). Deterministic meters read an IQR +-- of @0@. +data Noise = Noise + { nsMedian :: {-# UNPACK #-} !Word64 + -- ^ median reading at the selected batch. + , nsIqr :: {-# UNPACK #-} !Word64 + -- ^ interquartile range of readings at the selected batch. + } deriving (Eq, Show) + +-- | 'calibrateBatch' with its t'CalibReport'. +calibrateBatchReport :: Meter -> Hypothesis a -> IO CalibReport +calibrateBatchReport meter hyp = do + prepare hyp + !x <- sampleA hyp + let !act = target hyp x + -- grow the batch until the reading itself reaches the target + -- magnitude, then refine down from that measurement. Estimating + -- from a small probe would inflate per-call cost with the + -- meter's fixed per-measurement overhead (e.g. the clock reads); + -- at the resolved batch that overhead is amortised. + -- a cap-hit means the median per-call reading is well below + -- one meter unit at the largest probed batch, which no + -- functioning meter produces (the batch loop alone costs more); + -- return 1 so the subsequent run fails fast in warmup rather + -- than grinding through zero readings at a million calls per + -- measurement. + probe !b !ps + | b > calibCap = + pure $! finish 1 True Nothing ps + | otherwise = do + !r <- probeReading meter act b + let !ps' = (b, r) : ps + if fromIntegral r < calibTarget + then probe (b * 4) ps' + else do + let !b' = ceiling + (fromIntegral b * calibTarget / fromIntegral r) + !bf = max 1 (min calibCap b') + !ns <- noiseReading meter act bf + pure $! finish bf False (Just ns) ps' + finish !bf !cap !ns !ps = CalibReport + { crBatch = bf + , crProbes = reverse ps + , crCapHit = cap + , crTargetMag = calibTarget + , crNoise = ns + } + probe 1 [] + +-- median reading over a few measurements at batch @b@: robust to a +-- single 0 (fast target straddling the quantum) or a single spike +-- (a scheduler hiccup on the wall clock). +probeReading :: Meter -> IO () -> Int -> IO Word64 +probeReading meter act b = + fmap (nsMedian . dispersion) (samples calibProbes (measure meter b act)) + +-- dispersion of repeated readings at the selected batch: median and +-- interquartile range (nearest-rank quantiles), in per-batch meter +-- units. This is the meter's noise floor at the scale the driver +-- will observe, recorded as a snapshot of measurement conditions. +noiseReading :: Meter -> IO () -> Int -> IO Noise +noiseReading meter act b = + fmap dispersion (samples noiseSamples (measure meter b act)) + +-- run a reading action @n@ times, forcing each reading as it lands. +samples :: Int -> IO Word64 -> IO [Word64] +samples n act = go n + where + go 0 = pure [] + go i = do + !r <- act + fmap (r :) (go (i - 1)) + +-- median and nearest-rank interquartile range of a reading list. +dispersion :: [Word64] -> Noise +dispersion rs = + let !srt = sort rs + !n = length srt + !med = nth (n `div` 2) srt + !q1 = nth (n `div` 4) srt + !q3 = nth (3 * n `div` 4) srt + in Noise { nsMedian = med, nsIqr = q3 - q1 } + +-- | Baseline cost of the target: median and IQR of single +-- measurements on fresh class-A draws (each after a 'prepare'), at +-- 'cfgBatch', in the units of 'resEffect'. Unlike 'crNoise', which +-- remeasures one applied action (no-ops after the first, for a pure +-- target), every measurement here is genuine work. Give it its own +-- hypothesis instance if the run's sampler stream must start +-- undisturbed. +baselineReading :: Meter -> Config -> Hypothesis a -> IO Noise +baselineReading meter cfg hyp = + fmap dispersion (samples baselineSamples fresh) + where + fresh = do + prepare hyp + !x <- sampleA hyp + measure meter (cfgBatch cfg) (target hyp x) + +baselineSamples :: Int +baselineSamples = 15 + +-- the @k@th element of a sorted list (nearest-rank order statistic); +-- @0@ past the end. +nth :: Num a => Int -> [a] -> a +nth k xs = case drop k xs of + (v : _) -> v + [] -> 0 + +noiseSamples :: Int +noiseSamples = 15 + +-- Target per-batch reading magnitude (meter units) and probe budget. +-- 65536 matches the known-good hand-tuned batch for nanosecond-scale +-- targets (batch ~2000 at ~30 ns/call); erring high favours power, +-- since an underpowered default that misses a real leak is the +-- dangerous failure mode for a constant-time tester. +calibTarget :: Double +calibTarget = 65536 + +calibCap :: Int +calibCap = 1000000 + +calibProbes :: Int +calibProbes = 5 + +-- | The /A\/A control/: 'sampleB' replaced by 'sampleA'. The +-- hypothesis is then H_0 by construction, so a 'Reject' indicts +-- the harness (unbalanced samplers, RTS state, order effects) +-- rather than the target. Pair with 'toBB'. +toAA :: Hypothesis a -> Hypothesis a +toAA h = h { sampleB = sampleA h } +{-# INLINE toAA #-} + +-- | @'runCT' meter cfg ('toAA' hyp)@. +runAA :: Meter -> Config -> Hypothesis a -> IO Result +runAA meter cfg hyp = runCT meter cfg (toAA hyp) + +-- | The /B\/B control/: 'sampleA' replaced by 'sampleB', catching +-- asymmetries specific to 'sampleB' that 'toAA' cannot see. +toBB :: Hypothesis a -> Hypothesis a +toBB h = h { sampleA = sampleB h } +{-# INLINE toBB #-} + +-- | @'runCT' meter cfg ('toBB' hyp)@. +runBB :: Meter -> Config -> Hypothesis a -> IO Result +runBB meter cfg hyp = runCT meter cfg (toBB hyp) + +-- | The outcome of the A\/A and B\/B controls. They can convict the +-- harness but not acquit it: each compares a sampler against +-- itself, so an asymmetry only /between/ the samplers (say, one +-- returns a thunk that the target forces while timed) is invisible +-- to both. +data ControlVerdict + = ControlsPass + -- ^ Neither control rejected. A primary 'Reject' is then + -- consistent with a target leak, not proof of one. + | SampleAAsymmetry + -- ^ The A\/A control rejected: 'sampleA' itself induces a + -- timing asymmetry, and the primary verdict is not + -- informative until it is fixed. + | SampleBAsymmetry + -- ^ The B\/B control rejected: as above, for 'sampleB'. + | PervasiveAsymmetry + -- ^ Both controls rejected: the harness asymmetry is not + -- specific to either sampler. + deriving (Eq, Show) + +-- | The control verdict with both control runs in full, so the +-- evidence can be inspected rather than taken on trust. +data Attribution = Attribution + { attVerdict :: !ControlVerdict + -- ^ the combined outcome. + , attAA :: !Result + -- ^ the complete A\/A control run. + , attBB :: !Result + -- ^ the complete B\/B control run. + } deriving Show + +-- | Run the A\/A and B\/B controls. Only meaningful after a +-- 'Reject': on a symmetric harness both pass whether or not the +-- target leaks. +attribute :: Meter -> Config -> Hypothesis a -> IO Attribution +attribute meter cfg hyp = do + raa <- runAA meter cfg hyp + rbb <- runBB meter cfg hyp + let !v = case (raa, rbb) of + (Pass{}, Pass{}) -> ControlsPass + (Reject{}, Pass{}) -> SampleAAsymmetry + (Pass{}, Reject{}) -> SampleBAsymmetry + (Reject{}, Reject{}) -> PervasiveAsymmetry + pure $! Attribution + { attVerdict = v + , attAA = raa + , attBB = rbb + } + +-- internal + +validateConfig :: Config -> IO () +validateConfig Config{..} + | cfgBatch <= 0 = throwIO $! InvalidConfig + "cfgBatch must be positive" + | cfgWarmup <= 0 = throwIO $! InvalidConfig + "cfgWarmup must be positive" + | cfgBudget < 0 = throwIO $! InvalidConfig + "cfgBudget must be nonnegative" + | Just m <- cfgMargin + , not (m > 0 && not (isNaN m) && not (isInfinite m)) = + throwIO $! InvalidConfig + "cfgMargin must be a positive finite fraction" + | otherwise = pure () + +-- | The two samplers, indexed by the per-pair order word: slot 0 +-- holds 'sampleA', slot 1 'sampleB'. Built once per run so the +-- driver's pair loop selects a sampler by indexing — a +-- data-dependent load — rather than by branching on the order +-- bit. Both elements live in one cache line, so the selection's +-- microarchitectural footprint is as small as it can be made. +orderedSamplers :: Hypothesis a -> SmallArray (IO a) +orderedSamplers hyp = + let !sa = sampleA hyp + !sb = sampleB hyp + in smallArrayFromListN 2 [sa, sb] + +-- | Run one (sample, measure, sample, measure) pair in the order +-- given by the order word (@0@ = A first, @1@ = B first) and return +-- (A's reading, B's reading). 'prepare' runs first, outside the +-- timed region. +-- +-- The order bit is data only: one code path, the sampler chosen by +-- array index, the labels recovered by mask arithmetic. A branch +-- on the bit would give the two orders distinct code paths and +-- couple the bit into the readings through microarchitectural +-- state, breaking exchangeability (see @issues/handled/ISSUE2.md@). +runPair + :: Meter -> Config -> Hypothesis a -> SmallArray (IO a) -> Word64 + -> IO (Word64, Word64) +runPair meter cfg hyp samplers !bit = do + prepare hyp + let !iFst = fromIntegral bit :: Int + !iSnd = 1 - iFst + !u <- indexSmallArray samplers iFst + !t1 <- measure meter (cfgBatch cfg) (target hyp u) + !v <- indexSmallArray samplers iSnd + !t2 <- measure meter (cfgBatch cfg) (target hyp v) + -- branchless unscramble: swap iff bit = 1, via an all-ones mask. + -- x is class A's reading (slot 1 when the bit is 0, slot 2 when + -- it is 1), y class B's. + let !m = negate bit + !s = (t1 `B.xor` t2) B..&. m + !x = t1 `B.xor` s + !y = t2 `B.xor` s + pure (x, y) +{-# INLINE runPair #-} + +-- The hedge composition ---------------------------------------------------- + +-- The components are heterogeneous, so the driver steps each one +-- itself and hands their log e-values to 'EPMix.update' once per +-- pair. On a tie the sign component is unchanged, which is still its +-- current value, so the mixture's lockstep precondition holds. The +-- mixture owns the rejection latch and the threshold +-- @log(K \/ alpha)@, with @K = 4 + n@ for @n@ cut points: the +-- hedging price is @log K@ nats against @log(1 \/ alpha) = 13.8@ at +-- the default alpha. Under a margin only the three magnitude +-- components are mixed (@K = 3@); the sign and CDF ones are stepped +-- for their diagnostic peaks. + +data HedgeCfg = HedgeCfg + { hcSign :: !EPSign.Config + , hcMagn1 :: !EPMagn.Config + , hcMagn2 :: !EPMagn.Config + , hcMagn3 :: !EPMagn.Config + , hcCdf :: !EPMagn.Config -- shared by every cut point + , hcQs :: ![Double] -- the cut points themselves + , hcMix :: !EPMix.Config + , hcC1 :: {-# UNPACK #-} !Double -- tight clip level (base c) + , hcC2 :: {-# UNPACK #-} !Double -- 4c + , hcC3 :: {-# UNPACK #-} !Double -- 16c + , hcMargin :: !(Maybe Double) -- absolute margin; Nothing = + -- sharp null + } + +data HedgeState = HedgeState + { hsSign :: !EPSign.State + , hsMagn1 :: !EPMagn.State + , hsMagn2 :: !EPMagn.State + , hsMagn3 :: !EPMagn.State + , hsCdf :: ![EPMagn.State] -- aligned with 'hcQs' + , hsMix :: !EPMix.State + } + +mkHedgeCfg + :: Double -> Double -> [Double] -> Maybe Double + -> Either ConfigError HedgeCfg +mkHedgeCfg !alpha !c qs mmargin = do + let !c2 = 4 * c + !c3 = 16 * c + -- a magnitude component on d clipped to [-b, b]: mean-zero + -- under the sharp null, anchored at ±delta under a margin. + magn !b = case mmargin of + Nothing -> EPMagn.config 0 (negate b) b alpha Newton + Just d -> + EPMagn.configInterval (negate d) d (negate b) b alpha Newton + !k = case mmargin of + Nothing -> 4 + length qs + Just _ -> 3 + !sc <- EPSign.config 0.5 alpha Newton + !m1 <- magn c + !m2 <- magn c2 + !m3 <- magn c3 + !cd <- EPMagn.config 0 (negate 1) 1 alpha Newton + !mx <- EPMix.config k alpha + pure HedgeCfg + { hcSign = sc + , hcMagn1 = m1 + , hcMagn2 = m2 + , hcMagn3 = m3 + , hcCdf = cd + , hcQs = qs + , hcMix = mx + , hcC1 = c + , hcC2 = c2 + , hcC3 = c3 + , hcMargin = mmargin + } + +-- Running clipped-pair tallies at the hedge's three magnitude +-- bounds. Kept as one strict record rather than three accumulator +-- arguments so the driver loop's arity does not grow with them. +data Clips = Clips + { clAtC :: {-# UNPACK #-} !Int + , clAt4C :: {-# UNPACK #-} !Int + , clAt16C :: {-# UNPACK #-} !Int + } + +noClips :: Clips +noClips = Clips 0 0 0 + +-- Tally one pair's difference against each bound. Sits outside the +-- timed region, alongside the e-process updates. +bumpClips :: HedgeCfg -> Clips -> Double -> Clips +bumpClips HedgeCfg{..} (Clips !a !b !c) !d = Clips + (bump hcC1 a) (bump hcC2 b) (bump hcC3 c) + where + !m = abs d + bump !lim !n = if m > lim then n + 1 else n +{-# INLINE bumpClips #-} + +initialHedge :: HedgeCfg -> HedgeState +initialHedge HedgeCfg{..} = HedgeState + { hsSign = EPSign.initial hcSign + , hsMagn1 = EPMagn.initial hcMagn1 + , hsMagn2 = EPMagn.initial hcMagn2 + , hsMagn3 = EPMagn.initial hcMagn3 + , hsCdf = map (const (EPMagn.initial hcCdf)) hcQs + , hsMix = EPMix.initial hcMix + } + +updateHedge + :: HedgeCfg -> HedgeState -> Double -> Double -> Double -> HedgeState +updateHedge HedgeCfg{..} HedgeState{..} !d !ta !tb = + let !s' = if d == 0 + then hsSign + else EPSign.update hcSign hsSign (d > 0) + !m1' = EPMagn.update hcMagn1 hsMagn1 (clipD hcC1 d) + !m2' = EPMagn.update hcMagn2 hsMagn2 (clipD hcC2 d) + !m3' = EPMagn.update hcMagn3 hsMagn3 (clipD hcC3 d) + !cd' = stepCdf hcCdf hcQs hsCdf ta tb + -- under a margin only the magnitude components gate; the + -- sign and CDF components are stepped above for their + -- diagnostic peaks but stay out of the mixture. + !evs = case hcMargin of + Just _ -> + [ EPMagn.log_evalue m1' + , EPMagn.log_evalue m2' + , EPMagn.log_evalue m3' + ] + Nothing -> + ( EPSign.log_evalue s' + : EPMagn.log_evalue m1' + : EPMagn.log_evalue m2' + : EPMagn.log_evalue m3' + : map EPMagn.log_evalue cd' + ) + !x' = EPMix.update hcMix hsMix evs + in HedgeState + { hsSign = s' + , hsMagn1 = m1' + , hsMagn2 = m2' + , hsMagn3 = m3' + , hsCdf = cd' + , hsMix = x' + } + +-- Step every CDF-indicator component. Spine- and element-strict so +-- the per-pair states don't accumulate thunks across the budget. +stepCdf + :: EPMagn.Config -> [Double] -> [EPMagn.State] -> Double -> Double + -> [EPMagn.State] +stepCdf !cfg = go + where + go (q : qs) (s : ss) !ta !tb = + let !s' = EPMagn.update cfg s (cdfDiff q ta tb) + !ss' = go qs ss ta tb + in s' : ss' + go _ _ _ _ = [] + +-- The antisymmetric indicator functional at cut point @q@: +-- @1[ta <= q] - 1[tb <= q]@, valued in @{-1, 0, 1}@, with +-- conditional mean @F_A(q) - F_B(q)@. +cdfDiff :: Double -> Double -> Double -> Double +cdfDiff !q !ta !tb = ind ta - ind tb + where + ind !t | t <= q = 1 + | otherwise = 0 +{-# INLINE cdfDiff #-} + +-- Pair each cut point with its component's peak log e-value. The +-- state list is aligned with 'hcQs' by construction, so the zip is +-- total on both. +cdfPeaks :: [Double] -> [EPMagn.State] -> [(Double, Double)] +cdfPeaks qs = zip qs . map EPMagn.log_evalue_sup + +clipD :: Double -> Double -> Double +clipD !lim !x + | abs x > lim = if x > 0 then lim else negate lim + | otherwise = x +{-# INLINE clipD #-} + +-- The effect-estimation grid: interior candidate means over +-- @[-16c, 16c]@ for the confidence sequence behind 'resEffect'. +-- 300 candidates resolve the interval endpoints to ~0.1c, +-- comparable to the shift scale the tight magnitude component can +-- detect; the per-pair update cost is O(live candidates), falls as +-- evidence rejects candidates, and sits outside the timed region +-- (and is order-symmetric), so measurement hygiene is unaffected. +effectGrid :: Int +effectGrid = 300 + +-- The order bit: splitmix64 from the resolved seed, carried as a +-- @Word64@ in @{0, 1}@ and consumed arithmetically, never by a case +-- (see 'runPair'). + +nextOrderBit :: Word64 -> (Word64, Word64) +nextOrderBit !s = + let (!s', !w) = splitMix s + in (s', w B..&. 1) +{-# INLINE nextOrderBit #-} + +-- Resolve the (root, warmup, main) seed triple: the root is the +-- user's seed or fresh OS entropy, reported as 'resSeed'; warmup and +-- main derive from it. Entropy rather than a clock reading, since a +-- periodic nuisance process may be periodic in that very clock; the +-- clock is only a fallback where @\/dev\/urandom@ is unreadable. +resolveSeeds :: Maybe Word64 -> IO (Word64, Word64, Word64) +resolveSeeds mseed = do + !base <- case mseed of + Just s -> pure s + Nothing -> do + mw <- osEntropy + case mw of + Just w -> pure w + Nothing -> getMonotonicTimeNSec + let (!s1, !w1) = splitMix base + (_ , !w2) = splitMix s1 + pure (base, w1, w2) + +-- Eight bytes from /dev/urandom, big-endian. 'Nothing' on any IO +-- failure (absent device, sandbox, exhausted descriptors). +osEntropy :: IO (Maybe Word64) +osEntropy = fmap toWord (try (withBinaryFile urandom ReadMode grab)) + where + urandom = "/dev/urandom" + grab h = BS.hGet h 8 + toWord (Left e) = const Nothing (e :: IOException) + toWord (Right bs) + | BS.length bs == 8 = Just $! BS.foldl' step 0 bs + | otherwise = Nothing + step !acc !w = acc * 256 + fromIntegral w + +-- Warmup: run @cfgWarmup@ randomly ordered pairs and return +-- @(c, qs, meterResolves, medReading)@: +-- +-- * @c = max 1 (2 * p99(|d|))@, the clip bound; the floor keeps it +-- positive when a PMU meter on constant-time code reads zero +-- differences, which is fine (the run then passes at budget). +-- * @qs@, the CDF cut points: order statistics of the pooled +-- readings, identical for both classes (which keeps the +-- indicator antisymmetric), deduplicated so a discrete meter +-- does not inflate @K@. +-- * @meterResolves@, whether @p99@ of the readings is nonzero; +-- if not, the meter's quantum swallows the target and the caller +-- throws 'WarmupZeroDuration'. +-- * @medReading@, the pooled median, which resolves a relative +-- 'cfgMargin'. +warmup + :: Meter -> Config -> Hypothesis a -> SmallArray (IO a) -> Word64 + -> IO (Double, [Double], Bool, Double) +warmup meter cfg hyp samplers seed = do + let go !i !rng !accD !accR + | i >= cfgWarmup cfg = pure (accD, accR) + | otherwise = do + let (!rng', !bit) = nextOrderBit rng + (!x, !y) <- runPair meter cfg hyp samplers bit + let !dx = fromIntegral x :: Double + !dy = fromIntegral y :: Double + !da = abs (dx - dy) + go (i + 1) rng' (da : accD) (x : y : accR) + (diffs, readings) <- go 0 seed [] [] + let !sortedR = sort readings + !p99d = orderStat99 diffs + !p99r = orderStat99 readings + !qs = cutPoints sortedR + !medR = fromIntegral (nth (length sortedR `div` 2) sortedR) + -- twice the order statistic leaves headroom for occasional + -- outliers; larger differences are clipped in the main phase. + pure (max 1 (2 * p99d), qs, p99r > 0, medR) + +-- Empirical @~p99@ order statistic. Sorts and picks index +-- @(m * 99) \/ 100@; degenerates to the sample max at small @m@ +-- (documented on 'cfgWarmup'). +orderStat99 :: Ord a => Num a => [a] -> a +orderStat99 xs = + let !sorted = sort xs + in nth ((length sorted * 99) `div` 100) sorted +{-# INLINE orderStat99 #-} + +-- The levels at which the CDF-indicator components cut the pooled +-- warmup readings. Spread across the bulk rather than the tails: +-- a cut point out at the extremes leaves both indicators equal on +-- nearly every pair, contributing no evidence while still costing +-- its share of @log K@. The topmost level is deliberately below +-- the p99 that sets the clip bound, so the two calibrations do not +-- collapse onto the same statistic. +cdfLevels :: [Double] +cdfLevels = [0.10, 0.25, 0.50, 0.75, 0.90] + +-- Nearest-rank order statistics of a sorted reading list at +-- 'cdfLevels', ascending and deduplicated. Empty when warmup +-- collected nothing. +cutPoints :: [Word64] -> [Double] +cutPoints sorted + | m == 0 = [] + | otherwise = dedupAsc (map pick cdfLevels) + where + !m = length sorted + pick !p = + fromIntegral (nth (max 0 (min (m - 1) (floor (p * fromIntegral m)))) + sorted) + +-- Drop repeats from an ascending list. +dedupAsc :: [Double] -> [Double] +dedupAsc (x : y : rest) + | x == y = dedupAsc (y : rest) + | otherwise = x : dedupAsc (y : rest) +dedupAsc xs = xs diff --git a/lib/Censor/FFI.hs b/lib/Censor/FFI.hs new file mode 100644 --- /dev/null +++ b/lib/Censor/FFI.hs @@ -0,0 +1,102 @@ +{-# OPTIONS_HADDOCK prune #-} + +-- | +-- Module: Censor.FFI +-- Copyright: (c) 2026 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Testing foreign-function targets. +-- +-- A t'FFIHypothesis' works in one pinned workspace, allocated once +-- outside the timed region and reused for every pair. The samplers +-- fill it in place and the target reads (and may write) it, at +-- offsets of the caller's choosing. +-- +-- Only @ffiTarget@ is timed, so keep it to a single @ccall unsafe@ +-- FFI call: marshalling or allocation inside it lands in the timed +-- region, and a safe call adds the RTS's thread suspend\/resume. +-- +-- = Example +-- +-- > -- C side: void ct_mul(const uint8_t *a, const uint8_t *b, +-- > -- uint8_t *out); -- 32-byte operands. +-- > foreign import ccall unsafe "ct_mul" +-- > c_mul :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO () +-- > +-- > mulHyp :: Rng -> FFIHypothesis +-- > mulHyp g = FFIHypothesis +-- > { ffiWorkspaceBytes = 96 +-- > , ffiPrepare = pure () +-- > , ffiSampleA = \p -> do +-- > fillRandom g (p `plusPtr` 0) 32 -- draw and discard, +-- > fillBytes (p `plusPtr` 0) 0 32 -- then fix: input a +-- > fillRandom g (p `plusPtr` 32) 32 -- input b: random +-- > , ffiSampleB = \p -> do +-- > fillRandom g (p `plusPtr` 0) 32 +-- > fillRandom g (p `plusPtr` 32) 32 +-- > , ffiTarget = \p -> +-- > c_mul p (p `plusPtr` 32) (p `plusPtr` 64) +-- > } +-- > +-- > result <- withFFIHypothesis (mulHyp g) $ \h -> +-- > runCT wallClock defaultConfig h +-- +-- @fillBytes@ is 'Foreign.Marshal.Utils.fillBytes'. The discarded +-- 'fillRandom' in @ffiSampleA@ keeps the two samplers' generator work +-- symmetric before the fixed operand overwrites it. + +module Censor.FFI ( + -- * Foreign hypothesis + FFIHypothesis(..) + + -- * Bridging to runCT + , withFFIHypothesis + + -- * Workspace fills (re-exports) + , fillRandom + ) where + +import Censor.Rng (fillRandom) +import Censor (Hypothesis(..)) +import Data.Word (Word8) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Ptr (Ptr) + +-- | A foreign-function constant-time hypothesis over a pinned +-- workspace of @ffiWorkspaceBytes@ bytes. +data FFIHypothesis = FFIHypothesis + { ffiWorkspaceBytes :: !Int + -- ^ size of the pinned workspace, in bytes. + , ffiPrepare :: !(IO ()) + -- ^ per-pair prologue, run before either sampler and outside + -- the timed region. @pure ()@ for an ordinary hypothesis; a + -- shared-context hypothesis uses it to refresh a scratch + -- buffer that both samplers then overlay into the workspace. + , ffiSampleA :: !(Ptr Word8 -> IO ()) + -- ^ populate the workspace for an input drawn from class A. + , ffiSampleB :: !(Ptr Word8 -> IO ()) + -- ^ populate the workspace for an input drawn from class B. + , ffiTarget :: !(Ptr Word8 -> IO ()) + -- ^ the foreign action under test. Timed by the meter; should be + -- a single FFI call with no in-Haskell preparation. + } + +-- | Acquire the workspace, present a regular t'Hypothesis' that the +-- sequential driver ('Censor.runCT') can consume, and release the +-- workspace when the continuation returns. +-- +-- The same workspace pointer is handed to every sample\/measure +-- pair; samplers should establish the buffer state for their class +-- each call rather than relying on residual contents. +withFFIHypothesis + :: FFIHypothesis + -> (Hypothesis (Ptr Word8) -> IO a) + -> IO a +withFFIHypothesis h k = + allocaBytes (ffiWorkspaceBytes h) $ \p -> k Hypothesis + { target = ffiTarget h + , prepare = ffiPrepare h + , sampleA = ffiSampleA h p >> pure p + , sampleB = ffiSampleB h p >> pure p + } diff --git a/lib/Censor/Meter.hs b/lib/Censor/Meter.hs new file mode 100644 --- /dev/null +++ b/lib/Censor/Meter.hs @@ -0,0 +1,194 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +-- | +-- Module: Censor.Meter +-- Copyright: (c) 2026 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Measurement abstraction. +-- +-- A t'Meter' wraps an @IO@ action and returns a 'Word64' reading. +-- 'wallClock' is available everywhere. On Linux, 'withCounter' +-- provides performance-counter meters via @perf_event_open@: the +-- retired-instruction and retired-branch counts are deterministic +-- properties of the executed code, immune to the frequency, cache, +-- and scheduling noise that limits the wall clock on fast targets, +-- while the other counters help attribute a difference to a channel +-- (see t'Counter'). + +module Censor.Meter ( + -- * Meter type + Meter(..) + + -- * Implementations + , wallClock + + -- * Hardware performance-counter meters (Linux) + , Counter(..) + , MeterError(..) + , withCounter + ) where + +import Control.Exception (Exception, throwIO) +import Data.Word (Word64) +#if !defined(darwin_HOST_OS) +import GHC.Clock (getMonotonicTimeNSec) +#endif +#if defined(linux_HOST_OS) +import Control.Concurrent (runInBoundThread, rtsSupportsBoundThreads) +import Control.Exception (finally) +import Foreign.C.Types (CInt(..)) +#endif + +-- | A measurement device. @'measure' m k act@ runs @act@ @k@ times +-- back to back and returns one reading for the batch: nanoseconds +-- for 'wallClock', counted events for a 'withCounter' meter. Each +-- meter owns its inner loop, reading the clock or arming the +-- counter once per batch. +newtype Meter = Meter + { measure :: Int -> IO () -> IO Word64 + } + +-- | Wall-clock meter: elapsed nanoseconds over the batch. +-- +-- On Darwin, backed by @clock_gettime_nsec_np(CLOCK_UPTIME_RAW)@, +-- which resolves the hardware tick (~42 ns on Apple Silicon, so +-- sub-microsecond targets need batching; see 'Censor.cfgBatch'). +-- Not @GHC.Clock.getMonotonicTimeNSec@, which macOS quantises to +-- microseconds, putting CDF cut points on quantisation boundaries +-- (see @issues\/handled\/ISSUE2.md@). Elsewhere, backed by +-- @GHC.Clock.getMonotonicTimeNSec@. +wallClock :: Meter +wallClock = Meter measureWall + +#if defined(darwin_HOST_OS) +foreign import ccall unsafe "censor_monotonic_ns" + monotonicNS :: IO Word64 +#else +monotonicNS :: IO Word64 +monotonicNS = getMonotonicTimeNSec +{-# INLINE monotonicNS #-} +#endif + +measureWall :: Int -> IO () -> IO Word64 +measureWall !k !act = do + !t0 <- monotonicNS + rep k act + !t1 <- monotonicNS + pure $! t1 - t0 +{-# INLINE measureWall #-} + +-- shared inner loop. INLINE so it specialises at each meter call site +-- and the recursion compiles to a join-point with no per-iteration +-- closure allocation. +rep :: Int -> IO () -> IO () +rep !k !act = go k + where + go 0 = pure () + go i = act >> go (i - 1) +{-# INLINE rep #-} + +-- | A hardware (or, for 'TaskClock', software) event to count. +-- +-- With 'wallClock' the counters form a ladder in which each +-- adjacent gap isolates one cause of a class difference: +-- instructions (code path) -> cycles (microarchitectural latency) +-- -> ref-cycles (frequency) -> task-clock (kernel and interrupt +-- time) -> wall (scheduling gaps). +data Counter = + InstructionsRetired -- ^ @PERF_COUNT_HW_INSTRUCTIONS@; deterministic. + | BranchesRetired -- ^ @PERF_COUNT_HW_BRANCH_INSTRUCTIONS@; + -- deterministic. + | Cycles -- ^ @PERF_COUNT_HW_CPU_CYCLES@; also sensitive + -- to data-dependent latency. + | RefCycles -- ^ @PERF_COUNT_HW_REF_CPU_CYCLES@: cycles at + -- the constant reference rate, so a + -- difference here with clean 'Cycles' is a + -- frequency effect. Not available on every + -- microarchitecture. + | TaskClock -- ^ @PERF_COUNT_SW_TASK_CLOCK@: on-CPU + -- nanoseconds, including kernel time on the + -- task's behalf. A software counter, so + -- available in VMs, but counting kernel time + -- needs @kernel.perf_event_paranoid@ at most + -- @1@. + | BranchMisses -- ^ @PERF_COUNT_HW_BRANCH_MISSES@: catches a + -- secret-dependent branch direction when + -- retired branch counts balance. + | CacheMisses -- ^ @PERF_COUNT_HW_CACHE_MISSES@: attributes a + -- cycles-level difference to memory access + -- patterns. + deriving (Eq, Show) + +-- | Why a 'withCounter' meter could not be opened. +data MeterError = + Unsupported -- ^ not a Linux build; no hardware-counter support + | OpenFailed !Int -- ^ @perf_event_open@ failed with this @errno@ + -- (commonly @EACCES@\/@EPERM@ when + -- @kernel.perf_event_paranoid@ is too high) + deriving (Eq, Show) + +instance Exception MeterError + +#if defined(linux_HOST_OS) + +foreign import ccall unsafe "censor_perf_open" + c_perf_open :: CInt -> IO CInt +foreign import ccall unsafe "censor_perf_begin" + c_perf_begin :: CInt -> IO () +foreign import ccall unsafe "censor_perf_end" + c_perf_end :: CInt -> IO Word64 +foreign import ccall unsafe "censor_perf_close" + c_perf_close :: CInt -> IO () + +counterCode :: Counter -> CInt +counterCode InstructionsRetired = 0 +counterCode BranchesRetired = 1 +counterCode Cycles = 2 +counterCode RefCycles = 3 +counterCode TaskClock = 4 +counterCode BranchMisses = 5 +counterCode CacheMisses = 6 + +-- | Acquire a performance-counter t'Meter' for the duration of the +-- callback, then release it. Throws 'MeterError' if the counter +-- cannot be opened. +-- +-- Counters count user space only, which unprivileged processes may +-- open at @kernel.perf_event_paranoid@ @2@ or lower; 'TaskClock' +-- deliberately includes kernel time and needs @1@ or lower, failing +-- with @'OpenFailed' 13@ otherwise rather than silently degrading +-- to a user-only clock. A counter is bound to the thread that +-- opened it, so the callback runs on one OS thread. +withCounter :: Counter -> (Meter -> IO a) -> IO a +withCounter counter k = onOneThread $ do + fd <- c_perf_open (counterCode counter) + if fd < 0 + then throwIO (OpenFailed (negate (fromIntegral fd))) + else k (meterFor fd) `finally` c_perf_close fd + where + -- the perf fd is thread-affine; keep open + measures on one OS + -- thread. runInBoundThread requires the threaded RTS, so fall back + -- to running inline when there is only the single OS thread anyway. + onOneThread + | rtsSupportsBoundThreads = runInBoundThread + | otherwise = id + +meterFor :: CInt -> Meter +meterFor !fd = Meter $ \k act -> do + c_perf_begin fd + rep k act + c_perf_end fd +{-# INLINE meterFor #-} + +#else + +-- | Hardware performance-counter meters are only available on Linux; +-- on other platforms this always throws 'Unsupported'. +withCounter :: Counter -> (Meter -> IO a) -> IO a +withCounter _ _ = throwIO Unsupported + +#endif diff --git a/lib/Censor/Rng.hs b/lib/Censor/Rng.hs new file mode 100644 --- /dev/null +++ b/lib/Censor/Rng.hs @@ -0,0 +1,112 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module: Censor.Rng +-- Copyright: (c) 2026 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- A minimal splitmix64 PRNG for input samplers. +-- +-- Samplers feeding 'Censor.runCT' want a pseudorandom source that is +-- deterministic under a fixed seed, cheap, and light on allocation, +-- so that sampling work does not itself perturb the measurement (see +-- the measurement-hygiene notes in "Censor"). This module provides +-- exactly that and nothing more. It is /not/ a cryptographic +-- generator; the sampled inputs only need to be independent of the +-- target's timing distribution, not unpredictable. + +module Censor.Rng ( + -- * Stateful generator + Rng + , mkRng + , nextWord + , reseed + + -- * Byte fills + , randomBytes + , fillRandom + + -- * Pure step + , splitMix + ) where + +import qualified Data.Bits as B +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BI +import Data.IORef +import Data.Word (Word8, Word64) +import Foreign.Ptr (Ptr) +import Foreign.Storable (pokeByteOff) + +-- | splitmix64 state threaded through an 'IORef'. +newtype Rng = Rng (IORef Word64) + +-- | Create a generator from a seed. Equal seeds yield equal streams. +mkRng :: Word64 -> IO Rng +mkRng s = Rng <$> newIORef s +{-# INLINE mkRng #-} + +-- | Draw the next 'Word64' from the generator. +nextWord :: Rng -> IO Word64 +nextWord (Rng ref) = atomicModifyIORef' ref splitMix +{-# INLINE nextWord #-} + +-- | Reset a generator to a seed in place: after @reseed g s@ the +-- generator draws exactly the stream of a fresh @'mkRng' s@. +-- +-- Lets one long-lived generator replay a pinned stream, or adopt +-- a fresh one, without allocating per use — so the two classes +-- of a fix-vs-random sampler can share a single generator object +-- and differ only in the seed value written into it. +reseed :: Rng -> Word64 -> IO () +reseed (Rng ref) s = atomicWriteIORef ref s +{-# INLINE reseed #-} + +-- | The pure splitmix64 step: from a state, produce the successor +-- state and an output word. +splitMix :: Word64 -> (Word64, Word64) +splitMix !s = + let !s' = s + 0x9E3779B97F4A7C15 + !z0 = (s' `B.xor` (s' `B.shiftR` 30)) * 0xBF58476D1CE4E5B9 + !z1 = (z0 `B.xor` (z0 `B.shiftR` 27)) * 0x94D049BB133111EB + !z2 = z1 `B.xor` (z1 `B.shiftR` 31) + in (s', z2) +{-# INLINE splitMix #-} + +-- | Draw @n@ pseudorandom bytes as a strict 'BS.ByteString'. +-- +-- The result is a fresh, fully-materialised heap value -- no +-- thunks for the meter to pay inside the timed region -- so a +-- sampler can return it directly. +randomBytes :: Rng -> Int -> IO BS.ByteString +randomBytes !g !n + | n <= 0 = pure BS.empty + | otherwise = BI.create n $ \p -> fillRandom g p n + +-- | Fill @n@ bytes at the pointer with pseudorandom bytes drawn +-- from the generator. +fillRandom :: Rng -> Ptr Word8 -> Int -> IO () +fillRandom !g !dst !n = go 0 + where + go !i + | i >= n = pure () + | otherwise = do + !w <- nextWord g + let !left = n - i + !chunk = if left > 8 then 8 else left + writeWord dst i w chunk + go (i + chunk) + +-- write the low @lim@ bytes of a 'Word64', little-endian, at the +-- given offset. +writeWord :: Ptr Word8 -> Int -> Word64 -> Int -> IO () +writeWord !dst !off !w !lim = go 0 + where + go !j + | j >= lim = pure () + | otherwise = do + let !byte = fromIntegral (w `B.shiftR` (8 * j)) :: Word8 + pokeByteOff dst (off + j) byte + go (j + 1) diff --git a/lib/Censor/Runner.hs b/lib/Censor/Runner.hs new file mode 100644 --- /dev/null +++ b/lib/Censor/Runner.hs @@ -0,0 +1,205 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module: Censor.Runner +-- Copyright: (c) 2026 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Batteries-included harness support for "Censor": meter selection +-- from a command-line token, trace recording (built on +-- 'Censor.runCTWith', so it does not reimplement the driver), and +-- parameter sweeps. + +module Censor.Runner ( + -- * Meter selection + MeterChoice(..) + , parseMeter + , meterName + , withMeterArg + + -- * Recording traces + , Trace(..) + , record + , thin + + -- * Sweeps + , sweep + + -- * Verdicts and rendering + , verdictName + , shapeName + , summary + , clipText + ) where + +import Control.Exception (try) +import Control.Monad (forM) +import Data.IORef (newIORef, modifyIORef', readIORef) +import System.Exit (die) +import Text.Printf (printf) + +import Censor + +-- meter selection ------------------------------------------------------------- + +-- | A meter chosen by name. The PMU variants carry their display +-- label alongside the 'Counter'. +data MeterChoice + = MeterWall + | MeterPMU !Counter !String + +-- | Parse a meter name: @wall@, @instructions@, @cycles@, +-- @branches@, @ref-cycles@, @task-clock@, @branch-misses@, or +-- @cache-misses@. +parseMeter :: String -> Maybe MeterChoice +parseMeter s = case s of + "wall" -> Just MeterWall + "instructions" -> Just (MeterPMU InstructionsRetired "instructions") + "cycles" -> Just (MeterPMU Cycles "cycles") + "branches" -> Just (MeterPMU BranchesRetired "branches") + "ref-cycles" -> Just (MeterPMU RefCycles "ref-cycles") + "task-clock" -> Just (MeterPMU TaskClock "task-clock") + "branch-misses" -> Just (MeterPMU BranchMisses "branch-misses") + "cache-misses" -> Just (MeterPMU CacheMisses "cache-misses") + _ -> Nothing + +-- | The display name of a chosen meter. +meterName :: MeterChoice -> String +meterName MeterWall = "wall" +meterName (MeterPMU _ name) = name + +-- | Parse a meter token (defaulting to wall-clock when absent) and +-- run the callback with the resolved t'Meter' and its name, +-- bracketing a PMU counter for its lifetime and dying with a clear +-- message if it cannot be opened (e.g. the PMU meters off Linux, or +-- an unknown name). Handles the whole "wall everywhere, PMU +-- Linux-only, hard error otherwise" dance in one place. +withMeterArg :: Maybe String -> (String -> Meter -> IO a) -> IO a +withMeterArg marg k = do + choice <- case marg of + Nothing -> pure MeterWall + Just s -> case parseMeter s of + Just c -> pure c + Nothing -> die $ "unknown meter " ++ show s + ++ " (expected wall|instructions|cycles|branches|ref-cycles" + ++ "|task-clock|branch-misses|cache-misses)" + case choice of + MeterWall -> k "wall" wallClock + MeterPMU cnt name -> do + r <- try (withCounter cnt (k name)) + case r of + Right a -> pure a + Left e -> die $ name ++ " meter unavailable: " + ++ show (e :: MeterError) ++ hint e + where + -- EPERM/EACCES means the kernel refused a counter that exists, + -- which for an unprivileged process is the paranoid level. + -- task-clock counts kernel time and so needs a lower one than + -- the rest; see Censor.Meter. + hint (OpenFailed n) + | n == 1 || n == 13 = + " (check kernel.perf_event_paranoid: task-clock needs 1" + ++ " or lower, the other counters 2 or lower)" + hint _ = "" + +-- recording ------------------------------------------------------------------- + +-- | A recorded run: the final 'Result' plus the per-pair t'Frame' +-- trajectory. +data Trace = Trace + { traceName :: !String + , traceMeter :: !String + , traceResult :: !Result + , traceFrames :: ![Frame] + } deriving Show + +-- | Record a run, capturing every t'Frame' via 'runCTWith'. The +-- observer strictly accumulates frames; the driver is 'runCTWith' +-- itself, not a reimplementation of it. +record :: String -> String -> Meter -> Config -> Hypothesis a -> IO Trace +record name mname meter cfg hyp = do + ref <- newIORef [] + res <- runCTWith meter cfg hyp $ \ !fr -> modifyIORef' ref (fr :) + frs <- readIORef ref + pure $! Trace name mname res (reverse frs) + +-- | Downsample a frame list for compact plotting: keep all of the +-- first 150 frames (the early motion), then a uniform stride, then +-- the final frame. +thin :: [Frame] -> [Frame] +thin frs = + let !m = length frs + !stride = max 1 (m `div` 450) + keep fr = frPair fr <= 150 + || frPair fr `mod` stride == 0 + || frPair fr == m + in filter keep frs + +-- sweeps ---------------------------------------------------------------------- + +-- | Run a parameterised family of hypotheses under one meter and +-- return each parameter's result: the recurring "control vs swept +-- input" pattern (a mismatch position, a length, ...). +sweep + :: Meter -> Config -> (p -> IO (Hypothesis a)) -> [p] -> IO [(p, Result)] +sweep meter cfg mk ps = forM ps $ \p -> do + h <- mk p + r <- runCT meter cfg h + pure (p, r) + +-- verdicts and rendering ------------------------------------------------------ + +-- | @\"REJECT\"@ or @\"PASS\"@. +verdictName :: Result -> String +verdictName Reject{} = "REJECT" +verdictName Pass{} = "PASS" + +-- | A one-line human-readable render of a t'Result', suitable for +-- logging or embedding in a larger status line. Includes the +-- verdict, pairs consumed, evidence (peak log e-value, p-value), +-- effect interval, and clip count; on 'Reject' it also names the +-- driver channel of the hedge ('leakShape'). +-- +-- > REJECT after 342 pairs; driver=bulk peakLogW=18.42 p=1.0e-8 +-- > effect=[-101.5,-98.4] clipped=6/342 +summary :: Result -> String +summary r = + let !effLo = fst (resEffect r) + !effHi = snd (resEffect r) + base = printf "peakLogW=%.2f effect=[%.1f,%.1f] %s" + (resPeakLogW r) effLo effHi (clipText r) + in case r of + Reject{} -> + printf "REJECT after %d pairs; driver=%s %s p=%.2g" + (resPairs r) (shapeName (leakShape r)) + (base :: String) (resPValue r) + Pass{} -> + printf "PASS at %d pairs; %s" + (resPairs r) (base :: String) + +-- | Render a t'Result'\'s clipping as one field. The tight count is +-- always shown; the wider bounds are appended only when clipping +-- actually reached them, so the common case stays as terse as it +-- was and a run whose effect interval saw truncated input says so. +-- +-- > clipped=6/342 +-- > clipped=129/138 (4c 44, 16c 3) +clipText :: Result -> String +clipText r + | resClipped4 r == 0 && resClipped16 r == 0 = tight + | otherwise = tight ++ printf " (4c %d, 16c %d)" + (resClipped4 r) (resClipped16 r) + where + tight = printf "clipped=%d/%d" (resClipped r) (resPairs r) :: String + +-- | The short label for a 'LeakShape', as it appears on a case row +-- and in the @advisories@ block of the JSON report. +shapeName :: LeakShape -> String +shapeName s = case s of + BulkShift -> "bulk" + ShapeLeak -> "shape" + RareOutlier -> "tail" + CdfShift -> "cdf" + MixedShape -> "mixed" diff --git a/lib/Censor/Runner/DL.hs b/lib/Censor/Runner/DL.hs new file mode 100644 --- /dev/null +++ b/lib/Censor/Runner/DL.hs @@ -0,0 +1,105 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module: Censor.Runner.DL +-- Copyright: (c) 2026 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Minimal @dlopen@\/@dlsym@ bindings for driving a foreign +-- constant-time target that lives in a shared library. Used by the +-- @censor@ executable to resolve a symbol at runtime and hand it to +-- "Censor.FFI" as an @ffiTarget@. +-- +-- The underlying handle is opened with @RTLD_NOW | RTLD_LOCAL@: any +-- unresolved symbols surface immediately (so bad shims are caught at +-- 'withLibrary' entry, not at first call), and the library's own +-- symbols do not pollute the global namespace. Not available on +-- Windows. + +module Censor.Runner.DL ( + -- * Library handle + Library + , withLibrary + + -- * Resolving targets + , resolveTarget + + -- * Errors + , DLError(..) + ) where + +import Control.Exception (Exception, bracket, throwIO) +import Data.Word (Word8) +import Foreign.C.String (CString, peekCString, withCString) +import Foreign.Ptr (FunPtr, Ptr, castPtrToFunPtr, nullPtr) + +foreign import ccall unsafe "censor_dlopen" + c_dlopen :: CString -> IO (Ptr ()) + +foreign import ccall unsafe "censor_dlsym" + c_dlsym :: Ptr () -> CString -> IO (Ptr ()) + +foreign import ccall unsafe "censor_dlclose" + c_dlclose :: Ptr () -> IO Int + +foreign import ccall unsafe "censor_dlerror" + c_dlerror :: IO CString + +-- unsafe: this is the timed call, and a safe one would put the RTS's +-- suspend/resume of the calling thread inside the timed region. +foreign import ccall unsafe "dynamic" + mkTargetFun :: FunPtr (Ptr Word8 -> IO ()) -> Ptr Word8 -> IO () + +-- | An opened shared library. Bracketed by 'withLibrary'; do not +-- retain the value past its callback. +newtype Library = Library (Ptr ()) + +-- | Why a dynamic-linker operation failed. The 'String' payload is +-- the @dlerror@ message at the moment of failure. +data DLError + = DLOpenFailed !FilePath !String + -- ^ @dlopen@ returned null while opening this path. + | DLSymFailed !String !String + -- ^ @dlsym@ returned null for this symbol name. + deriving (Eq, Show) + +instance Exception DLError + +-- | Open a shared library for the duration of the callback and close +-- it on exit. Throws 'DLOpenFailed' if the library cannot be +-- loaded. +withLibrary :: FilePath -> (Library -> IO a) -> IO a +withLibrary path = bracket (open path) close + where + open p = do + h <- withCString p c_dlopen + if h == nullPtr + then do + !msg <- readErr + throwIO (DLOpenFailed p msg) + else pure (Library h) + close (Library h) = do + !_ <- c_dlclose h + pure () + +-- | Resolve a symbol as a @void(uint8_t *)@ target action. Throws +-- 'DLSymFailed' if the symbol is absent from the library. +-- +-- The resolved 'FunPtr' is not retained past the enclosing +-- 'withLibrary' scope; do not call the returned action after the +-- library has been closed. +resolveTarget :: Library -> String -> IO (Ptr Word8 -> IO ()) +resolveTarget (Library h) name = do + p <- withCString name (c_dlsym h) + if p == nullPtr + then do + !msg <- readErr + throwIO (DLSymFailed name msg) + else pure $! mkTargetFun (castPtrToFunPtr p) + +readErr :: IO String +readErr = do + s <- c_dlerror + if s == nullPtr then pure "(unknown)" else peekCString s diff --git a/lib/Censor/Runner/Env.hs b/lib/Censor/Runner/Env.hs new file mode 100644 --- /dev/null +++ b/lib/Censor/Runner/Env.hs @@ -0,0 +1,190 @@ +{-# OPTIONS_HADDOCK prune #-} + +-- | +-- Module: Censor.Runner.Env +-- Copyright: (c) 2026 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Host-environment capture. +-- +-- An t'Env' is a point-in-time snapshot of the machine a censor run +-- executed on: platform identity (OS, architecture, kernel release, +-- CPU model, core count), the timing-relevant tuning knobs visible +-- under Linux sysfs (cpufreq governor, turbo\/boost state, SMT +-- control, @perf_event_paranoid@), the load average, and a UTC +-- timestamp. +-- +-- Capture is best-effort: fields whose sources are absent on the +-- host (e.g. the sysfs knobs on Darwin) are 'Nothing'. Conditions +-- affect the /power/ of a run, not its validity — the paired, +-- order-randomised design cancels common-mode drift — so the +-- snapshot exists to make reports interpretable and provenanced, +-- not to gate execution. + +module Censor.Runner.Env ( + -- * Environment snapshot + Env(..) + , captureEnv + ) where + +import Control.Exception (try, IOException) +import qualified Data.ByteString.Char8 as B8 +import Data.Char (isSpace) +import Data.List (dropWhileEnd, isPrefixOf) +import Foreign.C.String (peekCString) +import Foreign.C.Types (CChar, CDouble, CInt(..), CSize(..)) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Array (allocaArray, peekArray) +import Foreign.Ptr (Ptr) +import GHC.Conc (getNumProcessors) +import qualified System.Info as Info + +foreign import ccall unsafe "censor_env_loadavg" + c_env_loadavg :: Ptr CDouble -> IO CInt + +foreign import ccall unsafe "censor_env_kernel" + c_env_kernel :: Ptr CChar -> CSize -> IO CInt + +foreign import ccall unsafe "censor_env_time" + c_env_time :: Ptr CChar -> CSize -> IO CInt + +foreign import ccall unsafe "censor_env_cpu" + c_env_cpu :: Ptr CChar -> CSize -> IO CInt + +foreign import ccall unsafe "censor_env_cores" + c_env_cores :: IO CInt + +-- | A host-environment snapshot, taken once at run start. +-- +-- The Linux knob fields ('envGovernor', 'envBoost', 'envSmt', +-- 'envParanoid') hold the raw sysfs\/procfs file contents; they +-- are 'Nothing' wherever the file does not exist (in particular, +-- everywhere but Linux). +data Env = Env + { envOs :: !String + -- ^ operating system, per @System.Info.os@. + , envArch :: !String + -- ^ architecture, per @System.Info.arch@. + , envKernel :: !(Maybe String) + -- ^ kernel release, per @uname(2)@. + , envCpu :: !(Maybe String) + -- ^ CPU model string (Darwin @sysctl@, or the first @model name@ + -- row of Linux @\/proc\/cpuinfo@; absent on most aarch64 Linux + -- kernels). + , envCores :: !Int + -- ^ logical core count. + , envGovernor :: !(Maybe String) + -- ^ Linux cpufreq scaling governor of cpu0. + , envBoost :: !(Maybe String) + -- ^ Linux turbo\/boost state, recorded verbatim as @key=value@ + -- (@boost=1@ is boost-enabled; @no_turbo=1@ is boost-disabled) + -- to avoid interpreting the two opposing conventions. + , envSmt :: !(Maybe String) + -- ^ Linux SMT control state (@on@ \/ @off@ \/ ...). + , envParanoid :: !(Maybe String) + -- ^ Linux @kernel.perf_event_paranoid@ level. + , envLoad :: !(Maybe (Double, Double, Double)) + -- ^ 1\/5\/15-minute load averages at capture time. + , envTime :: !(Maybe String) + -- ^ capture time, UTC ISO-8601. + } deriving (Eq, Show) + +-- | Snapshot the host environment. Cheap (a few syscalls and file +-- reads); call once at run start. +captureEnv :: IO Env +captureEnv = do + cores <- captureCores + kern <- cString 256 c_env_kernel + cpu <- captureCpu + gov <- readKnob + "/sys/devices/system/cpu/cpu0/cpufreq/scaling_governor" + boost <- captureBoost + smt <- readKnob "/sys/devices/system/cpu/smt/control" + para <- readKnob "/proc/sys/kernel/perf_event_paranoid" + load <- captureLoad + time <- cString 64 c_env_time + pure Env + { envOs = Info.os + , envArch = Info.arch + , envKernel = kern + , envCpu = cpu + , envCores = cores + , envGovernor = gov + , envBoost = boost + , envSmt = smt + , envParanoid = para + , envLoad = load + , envTime = time + } + +-- run a C fill-buffer shim, returning the trimmed NUL-terminated +-- contents on success and Nothing on failure. +cString :: Int -> (Ptr CChar -> CSize -> IO CInt) -> IO (Maybe String) +cString n fill = allocaBytes n $ \buf -> do + rc <- fill buf (fromIntegral n) + if rc == 0 + then fmap nonEmpty (peekCString buf) + else pure Nothing + +-- sysconf via the shim, because GHC's getNumProcessors reports 1 on +-- the non-threaded RTS; that stays as the fallback. +captureCores :: IO Int +captureCores = do + rc <- c_env_cores + if rc >= 1 + then pure (fromIntegral rc) + else getNumProcessors + +captureLoad :: IO (Maybe (Double, Double, Double)) +captureLoad = allocaArray 3 $ \p -> do + rc <- c_env_loadavg p + if rc == 3 + then do + vals <- peekArray 3 p + case map realToFrac vals of + [l1, l5, l15] -> pure (Just (l1, l5, l15)) + _ -> pure Nothing + else pure Nothing + +captureCpu :: IO (Maybe String) +captureCpu = do + s <- cString 256 c_env_cpu + case s of + Just _ -> pure s + Nothing -> cpuFromProcinfo + +-- first "model name" row of /proc/cpuinfo (x86 Linux; most aarch64 +-- kernels have no such row and the field stays Nothing). +cpuFromProcinfo :: IO (Maybe String) +cpuFromProcinfo = do + mc <- readKnob "/proc/cpuinfo" + pure $ case mc of + Nothing -> Nothing + Just s -> + case filter ("model name" `isPrefixOf`) (lines s) of + (l : _) -> nonEmpty (drop 1 (dropWhile (/= ':') l)) + [] -> Nothing + +captureBoost :: IO (Maybe String) +captureBoost = do + b <- readKnob "/sys/devices/system/cpu/cpufreq/boost" + case b of + Just v -> pure (Just ("boost=" ++ v)) + Nothing -> do + t <- readKnob "/sys/devices/system/cpu/intel_pstate/no_turbo" + pure (fmap ("no_turbo=" ++) t) + +-- read a small sysfs/procfs file, trimmed; Nothing when absent, +-- unreadable, or empty. Strict read so no handle outlives the call. +readKnob :: FilePath -> IO (Maybe String) +readKnob p = do + er <- try (B8.readFile p) :: IO (Either IOException B8.ByteString) + pure $ case er of + Left _ -> Nothing + Right b -> nonEmpty (B8.unpack b) + +nonEmpty :: String -> Maybe String +nonEmpty s = + let t = dropWhileEnd isSpace (dropWhile isSpace s) + in if null t then Nothing else Just t diff --git a/lib/Censor/Runner/Manifest.hs b/lib/Censor/Runner/Manifest.hs new file mode 100644 --- /dev/null +++ b/lib/Censor/Runner/Manifest.hs @@ -0,0 +1,366 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module: Censor.Runner.Manifest +-- Copyright: (c) 2026 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- A declarative battery for the @censor@ CLI: run-wide defaults and +-- a list of cases, each naming a target symbol and the workspace +-- layout to drive it with. One invocation opens the library once and +-- emits one @censor\/report-v3@ object covering every case. +-- +-- The format is line-oriented. Blank lines and @#@ comments are +-- ignored; every other line is either a run-wide directive +-- (@key value@) or a case (@case NAME key=value...@): +-- +-- > # ppad-secp256k1 scalar surfaces +-- > meter wall +-- > alpha 1e-6 +-- > budget 20000 +-- > warmup 500 +-- > target-prefix censor_target_ +-- > workspace 128 +-- > +-- > case mul secret=0:32 +-- > case sign workspace=96 secret=0:32 public=32:32 +-- > case ecdh secret=0:32 context=32:32 +-- > case inv secret=0:32 replicates=3 +-- +-- A case's target symbol is @target-prefix@ ++ its name unless +-- @target=@ overrides it outright. + +module Censor.Runner.Manifest ( + -- * Types + Manifest(..) + , Defaults(..) + , ManifestCase(..) + , Range(..) + , BatchSpec(..) + + -- * Parsing + , parseManifest + , emptyDefaults + , readRange + , readSeed + + -- * Layout validation + , checkLayout + ) where + +import Data.Char (isSpace) +import Data.Word (Word64) +import Numeric (readHex) + +-- | A byte range within the workspace: @off:len@. +data Range = Range + { rangeOff :: {-# UNPACK #-} !Int + , rangeLen :: {-# UNPACK #-} !Int + } deriving (Eq, Show) + +-- | How a case picks its @cfgBatch@. Foreign targets genuinely +-- recompute on every repetition, so 'BatchAuto' is meaningful +-- here in a way it is not for a pure Haskell target. +data BatchSpec + = BatchFixed !Int + -- ^ pin the batch. + | BatchAuto + -- ^ calibrate it per case. + deriving (Eq, Show) + +-- | Run-wide directives. Every field is optional; 'Nothing' defers +-- to the runner's own default (or a command-line override). +data Defaults = Defaults + { dfMeter :: !(Maybe String) + , dfAlpha :: !(Maybe Double) + , dfBudget :: !(Maybe Int) + , dfWarmup :: !(Maybe Int) + , dfBatch :: !(Maybe BatchSpec) + , dfMargin :: !(Maybe Double) + -- ^ relative interval-null margin (see 'Censor.cfgMargin'). + , dfSeed :: !(Maybe Word64) + -- ^ seeds the input samplers. + , dfOrderSeed :: !(Maybe Word64) + -- ^ seeds the A\/B order bit. Left unset in a checked-in + -- manifest: the default is fresh OS entropy per run, and the + -- resolved value is reported for replay. + , dfPrefix :: !(Maybe String) + , dfWorkspace :: !(Maybe Int) + , dfFamilyAlpha :: !(Maybe Bool) + -- ^ when set, run every expanded cell at @alpha \/ M@ (M being + -- the number of cells) so the /battery/ tests at @alpha@ + -- family-wise, rather than merely reporting the union bound. + } deriving (Eq, Show) + +-- | All directives unset. +emptyDefaults :: Defaults +emptyDefaults = Defaults + { dfMeter = Nothing + , dfAlpha = Nothing + , dfBudget = Nothing + , dfWarmup = Nothing + , dfBatch = Nothing + , dfMargin = Nothing + , dfSeed = Nothing + , dfOrderSeed = Nothing + , dfPrefix = Nothing + , dfWorkspace = Nothing + , dfFamilyAlpha = Nothing + } + +-- | One case: a display name, the symbol to resolve, the workspace +-- layout, and how many times to replicate it. +data ManifestCase = ManifestCase + { mcId :: !String + -- ^ the case token as written in the manifest, before any + -- @label=@ override. This is the case's /identity/: the + -- runner mixes it into the run-wide seed to give each case + -- its own fixed secret. + -- + -- Kept apart from 'mcName' so that renaming a case for + -- presentation does not change the experiment it runs. + , mcName :: !String + -- ^ the display name: 'mcId', or whatever @label=@ set. Used + -- for rendering only. + , mcTarget :: !String + , mcWorkspace :: !Int + , mcSecret :: ![Range] + , mcPublic :: ![Range] + , mcContext :: ![Range] + -- ^ ranges redrawn once per /pair/ and written identically into + -- both classes: a fresh public input shared by the pair (see + -- 'Censor.fixVsRandomCtx'). + , mcBatch :: !(Maybe BatchSpec) + , mcReplicates :: {-# UNPACK #-} !Int + -- ^ how many independent fixed secrets to run this case + -- against, each its own case row. One pinned secret only asks + -- whether /that/ secret times differently from random; + -- replicating guards against an unlucky draw. + } deriving (Eq, Show) + +-- | A parsed manifest. +data Manifest = Manifest + { mfDefaults :: !Defaults + , mfCases :: ![ManifestCase] + } deriving (Eq, Show) + +-- | Parse a manifest. Returns a message naming the offending line +-- on failure. +-- +-- Case order is preserved. A manifest with no cases is an error: +-- it is far more likely a typo than an intent. +parseManifest :: String -> Either String Manifest +parseManifest src = do + mf <- foldl step (Right (Manifest emptyDefaults [])) numbered + case mfCases mf of + [] -> Left "manifest: no cases declared" + cs -> Right mf { mfCases = reverse cs } + where + numbered = zip [1 :: Int ..] (lines src) + step acc (n, raw) = do + mf <- acc + case words (strip raw) of + [] -> Right mf + ("case" : r) -> fmap (\c -> mf { mfCases = c : mfCases mf }) + (parseCase n (mfDefaults mf) r) + [k, v] -> fmap (\d -> mf { mfDefaults = d }) + (parseDirective n (mfDefaults mf) k v) + ws -> Left (at n ("expected 'key value' or " + ++ "'case NAME ...', got " ++ show (unwords ws))) + +at :: Int -> String -> String +at n msg = "manifest line " ++ show n ++ ": " ++ msg + +-- Drop a comment and leading whitespace. '#' starts a comment +-- anywhere on the line: no field here (symbol, range, number) has +-- any use for one, so there is nothing to escape. +strip :: String -> String +strip = dropWhile isSpace . takeWhile (/= '#') + +parseDirective :: Int -> Defaults -> String -> String -> Either String Defaults +parseDirective n d k v = case k of + "meter" -> Right d { dfMeter = Just v } + "target-prefix" -> Right d { dfPrefix = Just v } + "alpha" -> fmap (\x -> d { dfAlpha = Just x }) (num "alpha") + "budget" -> fmap (\x -> d { dfBudget = Just x }) (nat "budget") + "warmup" -> fmap (\x -> d { dfWarmup = Just x }) (nat "warmup") + "workspace" -> fmap (\x -> d { dfWorkspace = Just x }) (pos "workspace") + "batch" -> fmap (\x -> d { dfBatch = Just x }) (batch n v) + "margin" -> fmap (\x -> d { dfMargin = Just x }) posnum + "seed" -> fmap (\x -> d { dfSeed = Just x }) (hex n "seed" v) + "order-seed" -> fmap (\x -> d { dfOrderSeed = Just x }) + (hex n "order-seed" v) + "family-alpha" -> fmap (\x -> d { dfFamilyAlpha = Just x }) + (flag n "family-alpha" v) + _ -> Left (at n ("unknown directive " ++ show k)) + where + num nm = case reads v of + [(x, "")] -> Right (x :: Double) + _ -> Left (at n (nm ++ " expects a number, got " ++ show v)) + posnum = case reads v of + [(x, "")] | x > 0 -> Right (x :: Double) + _ -> Left (at n ("margin expects a positive number, got " + ++ show v)) + nat nm = case reads v of + [(x, "")] | x >= 0 -> Right (x :: Int) + _ -> Left (at n (nm ++ " expects a non-negative integer, got " + ++ show v)) + pos nm = case reads v of + [(x, "")] | x > 0 -> Right (x :: Int) + _ -> Left (at n (nm ++ " expects a positive integer, got " ++ show v)) + +batch :: Int -> String -> Either String BatchSpec +batch _ "auto" = Right BatchAuto +batch n v = case reads v of + [(x, "")] | x >= 1 -> Right (BatchFixed x) + _ -> Left (at n ("batch expects a positive integer or 'auto', got " + ++ show v)) + +flag :: Int -> String -> String -> Either String Bool +flag _ _ "on" = Right True +flag _ _ "off" = Right False +flag n nm v = Left (at n (nm ++ " expects 'on' or 'off', got " ++ show v)) + +hex :: Int -> String -> String -> Either String Word64 +hex n nm v = case readSeed v of + Just w -> Right w + Nothing -> Left (at n (nm ++ " expects a hex Word64, got " ++ show v)) + +-- | Read a hex 'Word64', with or without a @0x@ prefix. +readSeed :: String -> Maybe Word64 +readSeed v = + let s = case v of + '0' : 'x' : r -> r + '0' : 'X' : r -> r + _ -> v + in case readHex s of + [(w, "")] -> Just w + _ -> Nothing + +parseCase + :: Int -> Defaults -> [String] -> Either String ManifestCase +parseCase n d toks = case toks of + [] -> Left (at n "case needs a name") + (name : kvs) -> do + let c0 = ManifestCase + { mcId = name + , mcName = name + , mcTarget = maybe "" id (dfPrefix d) ++ name + , mcWorkspace = maybe 0 id (dfWorkspace d) + , mcSecret = [] + , mcPublic = [] + , mcContext = [] + , mcBatch = Nothing + , mcReplicates = 1 + } + c <- foldl (\acc kv -> acc >>= \x -> applyKV n x kv) (Right c0) kvs + validateCase n c { mcSecret = reverse (mcSecret c) + , mcPublic = reverse (mcPublic c) + , mcContext = reverse (mcContext c) } + +applyKV :: Int -> ManifestCase -> String -> Either String ManifestCase +applyKV n c kv = case break (== '=') kv of + (k, '=' : v) -> case k of + "target" -> Right c { mcTarget = v } + "label" -> Right c { mcName = v } + "secret" -> fmap (\r -> c { mcSecret = r : mcSecret c }) + (range n "secret" v) + "public" -> fmap (\r -> c { mcPublic = r : mcPublic c }) + (range n "public" v) + "context" -> fmap (\r -> c { mcContext = r : mcContext c }) + (range n "context" v) + "batch" -> fmap (\b -> c { mcBatch = Just b }) (batch n v) + "workspace" -> case reads v of + [(x, "")] | x > 0 -> Right c { mcWorkspace = x } + _ -> Left (at n ("workspace expects a positive integer, got " + ++ show v)) + "replicates" -> case reads v of + [(x, "")] | x >= 1 -> Right c { mcReplicates = x } + _ -> Left (at n ("replicates expects a positive integer, got " + ++ show v)) + _ -> Left (at n ("unknown case key " ++ show k)) + _ -> Left (at n ("expected key=value, got " ++ show kv)) + +range :: Int -> String -> String -> Either String Range +range n nm v = case readRange v of + Just r -> Right r + Nothing -> Left (at n (nm ++ " expects off:len with off >= 0, len > 0," + ++ " got " ++ show v)) + +-- | Read an @off:len@ byte range, with @off >= 0@ and @len > 0@. +readRange :: String -> Maybe Range +readRange v = case break (== ':') v of + (off, ':' : len) -> case (reads off, reads len) of + ([(o, "")], [(l, "")]) | o >= 0 && l > 0 -> Just (Range o l) + _ -> Nothing + _ -> Nothing + +validateCase :: Int -> ManifestCase -> Either String ManifestCase +validateCase n c + | mcWorkspace c <= 0 = + Left (at n ("case " ++ mcName c ++ " has no workspace; set one " + ++ "on the case or a run-wide 'workspace' default")) + | null (mcSecret c) = + Left (at n ("case " ++ mcName c ++ " declares no secret range; " + ++ "there is no fix-vs-random axis without one")) + | otherwise = + case checkLayout (mcWorkspace c) (mcSecret c) (mcPublic c) + (mcContext c) of + Just msg -> Left (at n ("case " ++ mcName c ++ " " ++ msg)) + Nothing -> Right c + +-- | Check a workspace layout: every declared range must fit inside +-- the workspace, and the three roles must be pairwise disjoint. +-- 'Nothing' when the layout is sound; otherwise a message naming +-- the first problem, for the caller to place in context. +-- +-- Both entry points validate through this — a manifest case and +-- the single-case command line — so the two cannot drift on what +-- they accept. +-- +-- Overlapping roles are rejected rather than resolved by +-- precedence. A byte is pinned in class A only ('mcSecret'), +-- pinned in both for the run ('mcPublic'), refreshed per pair in +-- both ('mcContext'), or freshly random in each class; asking for +-- two of those at once has no coherent reading, and whichever +-- overlay happened to land last would silently pick one. That is +-- how a public range could mask the context it overlapped, +-- turning a per-pair refresh into a constant without saying so. +checkLayout + :: Int -- ^ workspace bytes + -> [Range] -- ^ secret ranges + -> [Range] -- ^ public ranges + -> [Range] -- ^ context ranges + -> Maybe String +checkLayout ws secrets publics contexts = + case filter (overflows . snd) tagged of + ((role, r) : _) -> Just + (role ++ " " ++ showRange r ++ " overflows the workspace of " + ++ show ws ++ " bytes") + [] -> case clashes of + ((ra, r, rb) : _) -> Just + (ra ++ " " ++ showRange r ++ " overlaps a " ++ rb ++ " range") + [] -> Nothing + where + tagged = concat + [ [("secret", r) | r <- secrets] + , [("public", r) | r <- publics] + , [("context", r) | r <- contexts] + ] + clashes = + [ (ra, a, rb) + | (ra, as, rb, bs) <- + [ ("secret", secrets, "public", publics) + , ("secret", secrets, "context", contexts) + , ("context", contexts, "public", publics) + ] + , a <- as, b <- bs, overlaps a b + ] + overflows (Range o l) = o + l > ws + overlaps (Range o1 l1) (Range o2 l2) = + o1 < o2 + l2 && o2 < o1 + l1 + +showRange :: Range -> String +showRange (Range o l) = show o ++ ":" ++ show l diff --git a/lib/Censor/Runner/Report.hs b/lib/Censor/Runner/Report.hs new file mode 100644 --- /dev/null +++ b/lib/Censor/Runner/Report.hs @@ -0,0 +1,1004 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} + +-- | +-- Module: Censor.Runner.Report +-- Copyright: (c) 2026 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Uniform report rendering and suite scaffolding for censor +-- executables. Three concentric layers: +-- +-- * The lowest layer is a header\/case\/footer data model streamed +-- through a 'Renderer'. Three renderers are provided — +-- 'pretty' (the ppad terminal aesthetic: bold brand line, dim +-- key column, middle-dot separators, ANSI-colored verdicts on a +-- TTY), 'json' (one @censor\/report-v3@ object per run, +-- deterministic key order, per-case trace arrays when present), +-- and 'plain' (ASCII-only, grep-safe). +-- * 'withReport' streams cases through the chosen renderer and +-- returns the accumulated list so callers can drive exit codes. +-- * At the top, t'TraceSuite' packages up the entire censor +-- test-suite shape (arg parse, meter selection, header assembly, +-- per-case calibration and attribution, trace record, JSON +-- artefact write) into one call, so a suite's @Main.hs@ contains +-- only the hypotheses and case list. + +module Censor.Runner.Report ( + -- * Report config + ReportCfg(..) + , initReportCfg + + -- * Data model + , ReportHeader(..) + , CaseReport(..) + , BatteryTail(..) + + -- * Renderers + , Renderer(..) + , pretty + , json + , plain + + -- * Driver + , withReport + + -- * Format flags + , Format(..) + , parseFormat + , rendererFor + , takeFormatArg + , resolveFormat + + -- * Standard suite arg surface + , SuiteArgs(..) + , parseSuiteArgs + + -- * Host environment (re-exports) + , Env(..) + , captureEnv + + -- * Suite scaffolds + , BatchPolicy(..) + , TraceCase(..) + , TraceSuite(..) + , runTraceSuite + + -- * JSON serialisation + , reportJSON + , resultToJSON + ) where + +import Control.Monad (forM_) +import Data.IORef (newIORef, modifyIORef', readIORef) +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Data.Version (showVersion) +import Data.Word (Word64) +import Numeric (showHex) +import qualified System.Environment as Env +import System.Exit (die) +import System.IO (BufferMode(..), hIsTerminalDevice, hSetBuffering, stdout) +import Text.Printf (printf) + +import Censor hiding (crBatch, crNoise) +import qualified Censor as C +import Censor.Runner + ( traceResult, traceFrames, record, thin + , verdictName, shapeName, clipText, withMeterArg + ) +import Censor.Runner.Env (Env(..), captureEnv) +import qualified Paths_ppad_censor as Paths + +-- | Package name used in the report brand line (@ppad censor@) and +-- the @tool@ field of the JSON envelope. All censor executables +-- render as this string — individual suites do not carry their own +-- brand. +brand :: String +brand = "censor" + +-- | Package version, sourced from the autogen'd @Paths_ppad_censor@ +-- module so it always tracks the cabal file. +brandVersion :: String +brandVersion = showVersion Paths.version + +-- report config ------------------------------------------------------------- + +-- | Runtime knobs for the renderer. +-- +-- 'rcColor' is set once at startup based on whether stdout is a +-- terminal. All ANSI helpers short-circuit to identity when it is +-- 'False'. +data ReportCfg = ReportCfg + { rcColor :: !Bool + } deriving (Eq, Show) + +-- | Initialise a 'ReportCfg' by probing whether stdout is a TTY. +-- Call once at the start of @main@ and thread the result through +-- the renderer callbacks. +initReportCfg :: IO ReportCfg +initReportCfg = do + !isTty <- hIsTerminalDevice stdout + pure ReportCfg { rcColor = isTty } + +-- data model --------------------------------------------------------------- + +-- | Static header emitted once, before any case row. Populate this +-- at 'main' entry with the run's own metadata; the brand line +-- (@ppad censor v\@) is fixed and does not appear here. +data ReportHeader = ReportHeader + { rhMeter :: !String + -- ^ meter name (@wall@ \/ @instructions@ \/ ...). + , rhConfig :: !Config + -- ^ the driver 'Config' the run used (surfaced on the header line). + , rhSeed :: !(Maybe Word64) + -- ^ user-facing sampler seed (distinct from 'cfgSeed', which + -- only seeds the per-pair A\/B order bit). + , rhTarget :: !(Maybe String) + -- ^ short target description, e.g. @\"Poly1305 MAC ==\"@. + , rhNote :: !(Maybe String) + -- ^ optional one-line caveat under the header block. + , rhEnv :: !(Maybe Env) + -- ^ host-environment snapshot taken at run start. 'runTraceSuite' + -- always populates it; 'Nothing' when the caller assembled the + -- header by hand without capturing one. + , rhPerCaseBatch :: !Bool + -- ^ 'True' when each case picks its own 'cfgBatch' from its + -- 'BatchPolicy' (see 'runTraceSuite'). Header renders + -- @batch=per-case@ and the config JSON emits + -- @\"batch\":\"per-case\"@; the resolved batch for each case + -- appears on that case's row via 'crBatch'. 'False' means the + -- run used a single 'cfgBatch' from 'rhConfig' throughout, + -- rendered as usual. + } deriving Show + +-- | A single case row. +data CaseReport = CaseReport + { crName :: !String + -- ^ case name displayed on the row. + , crResult :: !Result + -- ^ the driver's verdict + evidence. + , crAttribution :: !(Maybe Attribution) + -- ^ optional A\/A + B\/B attribution result, surfaced under the + -- case row on 'Reject'. 'Nothing' when the tool did not run + -- attribution. + , crBatch :: !(Maybe Int) + -- ^ the 'cfgBatch' the case actually ran under. Populated by + -- 'runTraceSuite' from per-case 'calibrateBatch'; 'Nothing' + -- when the case ran under a shared 'rhConfig' batch. + , crNoise :: !(Maybe Noise) + -- ^ the meter's noise floor at the calibrated batch, from the + -- case's t'CalibReport'. 'Nothing' when the case was not + -- calibrated per-case. + , crBaseline :: !(Maybe Noise) + -- ^ baseline cost of the target on fresh class-A draws at the + -- case's batch, from 'baselineReading': median and IQR in + -- per-batch meter units, the scale of 'resEffect'. 'Nothing' + -- when the tool did not probe one. + , crTrace :: !(Maybe [Frame]) + -- ^ per-pair 'Frame' trajectory, when the runner recorded one + -- (via 'record'). Surfaces in the JSON artefact as a thinned + -- array; the human renderers ignore it. + } deriving Show + +-- | The tail passed to a renderer's 'rndClose'. Carries the +-- accumulated case list and, optionally, the path to a companion +-- artefact (a trace JSON, a log) that the tool wrote alongside. +data BatteryTail = BatteryTail + { btCases :: ![CaseReport] + , btOutput :: !(Maybe FilePath) + } deriving Show + +-- renderer interface ------------------------------------------------------- + +-- | A rendering strategy: one callback per lifecycle event. +-- +-- The lifecycle is @rndOpen@ (once), then @rndCase@ per case (in +-- order), then @rndClose@ (once). Streaming renderers ('pretty', +-- 'plain') emit at each callback; buffered renderers ('json') use +-- the case callback as a no-op and emit the full object at close. +data Renderer = Renderer + { rndOpen :: ReportCfg -> ReportHeader -> IO () + , rndCase :: ReportCfg -> CaseReport -> IO () + , rndClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO () + } + +-- format flag -------------------------------------------------------------- + +-- | Selectable output format. +data Format = FmtPretty | FmtJson | FmtPlain + deriving (Eq, Show) + +-- | Parse a @--format@ argument: @pretty@, @json@, or @plain@. +parseFormat :: String -> Maybe Format +parseFormat s = case s of + "pretty" -> Just FmtPretty + "json" -> Just FmtJson + "plain" -> Just FmtPlain + _ -> Nothing + +-- | The 'Renderer' for a 'Format'. +rendererFor :: Format -> Renderer +rendererFor FmtPretty = pretty +rendererFor FmtJson = json +rendererFor FmtPlain = plain + +-- | Position-insensitively pluck a @--format FMT@ pair out of an +-- argv list. Returns the format token if present and the argv with +-- that pair removed. +takeFormatArg :: [String] -> (Maybe String, [String]) +takeFormatArg = takeFlagArg "--format" + +-- pluck a @FLAG VALUE@ pair out of an argv list, wherever it sits. +takeFlagArg :: String -> [String] -> (Maybe String, [String]) +takeFlagArg flag = go [] + where + go pre (x:v:rest) | x == flag = (Just v, reverse pre ++ rest) + go pre (x:xs) = go (x:pre) xs + go pre [] = (Nothing, reverse pre) + +-- | Resolve an optional format token to a 'Renderer', dying with a +-- clear message on unknown values. Defaults to 'pretty' when the +-- token is absent. +resolveFormat :: Maybe String -> IO Renderer +resolveFormat Nothing = pure pretty +resolveFormat (Just s) = case parseFormat s of + Just f -> pure (rendererFor f) + Nothing -> die $ "unknown --format " ++ show s + ++ " (expected pretty|json|plain)" + +-- driver ------------------------------------------------------------------- + +-- | Stream a battery through a renderer. +-- +-- The body callback is handed an @emit@ action that records one +-- case row; call it after each hypothesis completes. The body may +-- return the path of a companion artefact (e.g. a trace JSON) to +-- surface in the footer. The accumulated case list is returned so +-- callers can drive an exit code off the verdicts. +withReport + :: ReportCfg + -> Renderer + -> ReportHeader + -> ((CaseReport -> IO ()) -> IO (Maybe FilePath)) + -> IO [CaseReport] +withReport rc rnd hdr body = do + ref <- newIORef ([] :: [CaseReport]) + rndOpen rnd rc hdr + out <- body $ \cr -> do + rndCase rnd rc cr + modifyIORef' ref (cr :) + cases <- fmap reverse (readIORef ref) + rndClose rnd rc hdr (BatteryTail cases out) + pure cases + +-- ANSI helpers ------------------------------------------------------------- + +ansiReset, ansiBold, ansiDim, ansiRed, ansiGreen :: String +ansiReset = "\ESC[0m" +ansiBold = "\ESC[1m" +ansiDim = "\ESC[2m" +ansiRed = "\ESC[31m" +ansiGreen = "\ESC[32m" + +withColor :: Bool -> String -> String -> String +withColor False _ t = t +withColor True code t = code ++ t ++ ansiReset + +cBold, cDim, cRed, cGreen :: ReportCfg -> String -> String +cBold c = withColor (rcColor c) ansiBold +cDim c = withColor (rcColor c) ansiDim +cRed c = withColor (rcColor c) ansiRed +cGreen c = withColor (rcColor c) ansiGreen + +-- pretty renderer ---------------------------------------------------------- + +-- | The ppad terminal aesthetic: bold brand line, a dim key column, +-- middle-dot (@·@) separators, ANSI-colored verdicts on a TTY. +pretty :: Renderer +pretty = Renderer + { rndOpen = prettyOpen + , rndCase = prettyCase + , rndClose = prettyClose + } + +prettyOpen :: ReportCfg -> ReportHeader -> IO () +prettyOpen rc hdr = do + putStrLn $ " " ++ cBold rc ("ppad " ++ brand) + ++ " " ++ cDim rc ("v" ++ brandVersion) + putStr (prettyHeaderBlock rc hdr) + putStrLn "" + +prettyHeaderBlock :: ReportCfg -> ReportHeader -> String +prettyHeaderBlock rc hdr = + let entries = headerEntries " \183 " hdr + keyW = keyWidth entries + row (k, v) = " " ++ cDim rc (padR keyW k) ++ " " ++ v ++ "\n" + in concatMap row entries + +-- the header block's key/value rows, joining multi-part values with +-- the given separator. +headerEntries :: String -> ReportHeader -> [(String, String)] +headerEntries sep hdr = concat + [ [("meter", meterLine sep hdr)] + , maybe [] (\t -> [("target", t)]) (rhTarget hdr) + , maybe [] (\w -> [("sampler seed", seedHex w)]) (rhSeed hdr) + , maybe [] (envEntries sep) (rhEnv hdr) + , maybe [] (\n -> [("note", n)]) (rhNote hdr) + ] + +keyWidth :: [(String, String)] -> Int +keyWidth entries = maximum (1 : map (length . fst) entries) + +-- header rows for a host-environment snapshot: a system line +-- (os/kernel/arch, CPU model, cores), a knob line when any Linux +-- tuning knob resolved, the load average, and the capture time. +envEntries :: String -> Env -> [(String, String)] +envEntries sep e = concat + [ [("system", intercalate sep (systemSegs e))] + , case knobSegs e of + [] -> [] + ks -> [("env", intercalate sep ks)] + , maybe [] (\(l1, l5, l15) -> + [("load", printf "%.2f %.2f %.2f" l1 l5 l15)]) (envLoad e) + , maybe [] (\t -> [("time", t)]) (envTime e) + ] + +systemSegs :: Env -> [String] +systemSegs e = concat + [ [unwords (concat + [ [envOs e], maybe [] pure (envKernel e), [envArch e] ])] + , maybe [] pure (envCpu e) + , [show (envCores e) ++ " cores"] + ] + +knobSegs :: Env -> [String] +knobSegs e = concat + [ maybe [] (\v -> ["governor=" ++ v]) (envGovernor e) + , maybe [] pure (envBoost e) -- already key=value + , maybe [] (\v -> ["smt=" ++ v]) (envSmt e) + , maybe [] (\v -> ["paranoid=" ++ v]) (envParanoid e) + ] + +meterLine :: String -> ReportHeader -> String +meterLine sep hdr = + let c = rhConfig hdr + in intercalate sep $ + [ rhMeter hdr + , printf "alpha=%.1g" (cfgAlpha c) :: String + , "warmup=" ++ show (cfgWarmup c) + , "budget=" ++ show (cfgBudget c) + , "batch=" ++ batchText hdr + ] ++ marginSeg c + +-- the relative interval-null margin, when the run tests one. The +-- resolved absolute margin is per-case ('resMargin') and appears +-- on each case's metadata line. +marginSeg :: Config -> [String] +marginSeg c = + maybe [] (\m -> [printf "margin=%.1g" m]) (cfgMargin c) + +batchText :: ReportHeader -> String +batchText hdr + | rhPerCaseBatch hdr = "per-case" + | otherwise = show (cfgBatch (rhConfig hdr)) + +-- Row layout: verdict + pairs + driver in fixed-width columns on the +-- left, evidence in the middle, case name after a dim separator on +-- the right. Case-name column being last (unbounded) means the +-- numeric columns align across arbitrarily long names. +prettyCase :: ReportCfg -> CaseReport -> IO () +prettyCase rc cr = do + let r = crResult cr + verdict = case r of + Reject{} -> cRed rc "REJECT" + Pass{} -> cGreen rc "PASS " + pairs = padL 8 (show (resPairs r)) + driver = padR 6 $ case r of + Reject{} -> shapeName (leakShape r) + Pass{} -> "" + evid = printf "peakLogW=%5.2f p=%.2g" + (resPeakLogW r) (resPValue r) :: String + sep = cDim rc "\183" + putStrLn $ " " ++ verdict + ++ " " ++ cDim rc pairs + ++ " " ++ driver + ++ " " ++ evid + ++ " " ++ sep + ++ " " ++ crName cr + mapM_ (\l -> putStrLn $ replicate detailIndent ' ' ++ cDim rc l) + (detailLines " " cr) + +-- the lines under a case row: on 'Reject' the effect interval and +-- clipping (joined by the given gap), then the run metadata, then +-- the controls when they ran. +detailLines :: String -> CaseReport -> [String] +detailLines gap cr = concat + [ case r of + Reject{} -> + let (elo, ehi) = resEffect r + in [printf "effect=[%.1f,%.1f]%s%s" elo ehi gap (clipText r)] + Pass{} -> [] + , maybe [] pure (calibText cr) + , maybe [] (pure . attributionText) (crAttribution cr) + ] + where + r = crResult cr + +-- the run-metadata line under a case row: resolved batch, the +-- meter's noise floor at that batch when recorded, the target's +-- baseline cost when probed, and the order seed the run resolved +-- to. The seed is unconditional -- it is what replays the case, +-- and a reader should not have to reach for the JSON to find it. +calibText :: CaseReport -> Maybe String +calibText cr = case segs of + [] -> Nothing + xs -> Just (unwords xs) + where + segs = concat + [ maybe [] (\b -> ["batch=" ++ show b]) (crBatch cr) + , maybe [] (\n -> [ printf "noise med=%d iqr=%d" + (nsMedian n) (nsIqr n) ]) + (crNoise cr) + , maybe [] (\n -> [ printf "baseline med=%d iqr=%d" + (nsMedian n) (nsIqr n) ]) + (crBaseline cr) + , maybe [] (\m -> [ printf "margin=%.1f" m ]) + (resMargin (crResult cr)) + , ["orderSeed=" ++ seedHex (resSeed (crResult cr))] + ] + +-- Indent under the evidence column: 4 (row indent) + 6 (verdict) +-- + 2 + 8 (pairs) + 2 + 6 (driver) + 2 = 30. +detailIndent :: Int +detailIndent = 30 + +prettyClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO () +prettyClose rc hdr tl = do + let cs = btCases tl + (nrej, npas, pairs) = tally cs + parts = concat + [ [ colorCount cRed rc nrej " reject" + , colorCount cGreen rc npas " pass" + , show pairs ++ " pairs" ] + , familySeg hdr cs + , maybe [] (\p -> ["wrote " ++ p]) (btOutput tl) + ] + putStrLn "" + putStrLn $ " " ++ cDim rc (intercalate " \183 " parts) + +-- Family-wise alpha, shown only for multi-case batteries (for a +-- single case it is just alpha, and saying so adds noise). +familySeg :: ReportHeader -> [CaseReport] -> [String] +familySeg hdr cs + | n <= 1 = [] + | otherwise = [printf "family alpha<=%.1g" (familyAlpha alpha n)] + where + n = length cs + alpha = cfgAlpha (rhConfig hdr) + +colorCount + :: (ReportCfg -> String -> String) -> ReportCfg -> Int -> String -> String +colorCount col rc n suf + | n > 0 = col rc (show n) ++ suf + | otherwise = show n ++ suf + +-- json renderer ------------------------------------------------------------ + +-- | Emit one @censor\/report-v3@ JSON object per battery, +-- deterministic key order. Header and per-case callbacks are +-- no-ops; the whole object materialises at close, exactly as +-- 'reportJSON' would render it. +json :: Renderer +json = Renderer + { rndOpen = \_ _ -> pure () + , rndCase = \_ _ -> pure () + , rndClose = jsonClose + } + +jsonClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO () +jsonClose _ hdr tl = putStrLn (reportJSON hdr (btCases tl)) + +-- | Serialise a header + case list as the canonical +-- @censor\/report-v3@ JSON object. Deterministic key order; the +-- per-case block carries 'crBatch' and 'crTrace' as optional +-- fields, present exactly when the runner recorded them. +-- +-- The two seeds are named apart: @samplerSeed@ at the top level +-- is the harness-wide seed behind the input samplers, and +-- @orderSeed@ inside each case result is the resolved per-run +-- A\/B order seed that replays that case. +-- +-- The 'json' renderer and 'runTraceSuite' both call this so +-- stdout output and the on-disk artefact are byte-identical. +reportJSON :: ReportHeader -> [CaseReport] -> String +reportJSON hdr cases = concat + [ "{\"schema\":\"censor/report-v3\"" + , ",\"tool\":", jstr brand + , ",\"version\":", jstr brandVersion + , ",\"meter\":", jstr (rhMeter hdr) + , ",\"config\":", configJSON hdr + , maybe "" (\e -> ",\"env\":" ++ envJSON e) (rhEnv hdr) + , maybe "" (\w -> ",\"samplerSeed\":" ++ jstr (seedHex w)) + (rhSeed hdr) + , maybe "" (\t -> ",\"target\":" ++ jstr t) (rhTarget hdr) + , maybe "" (\n -> ",\"note\":" ++ jstr n) (rhNote hdr) + , ",\"cases\":[" + , intercalate "," (map caseJSON cases) + , "]" + , ",\"totals\":", totalsJSON (cfgAlpha (rhConfig hdr)) cases + , "}" + ] + +configJSON :: ReportHeader -> String +configJSON hdr = + let c = rhConfig hdr + batchField + | rhPerCaseBatch hdr = ",\"batch\":\"per-case\"" + | otherwise = ",\"batch\":" ++ show (cfgBatch c) + in concat + [ "{\"alpha\":", showF (cfgAlpha c) + , ",\"budget\":", show (cfgBudget c) + , ",\"warmup\":", show (cfgWarmup c) + , batchField + -- the *relative* margin; each case result carries the + -- absolute value it resolved to. + , maybe "" (\m -> ",\"margin\":" ++ showF m) (cfgMargin c) + -- the *requested* order seed; absent when the runner left + -- it to per-run OS entropy. Each case result carries the + -- value it actually resolved to. + , maybe "" (\w -> ",\"orderSeed\":" ++ jstr (seedHex w)) + (cfgSeed c) + , "}" + ] + +-- optional keys are omitted (rather than emitted null) when the +-- corresponding Env field did not resolve on the host. +envJSON :: Env -> String +envJSON e = concat + [ "{\"os\":", jstr (envOs e) + , ",\"arch\":", jstr (envArch e) + , maybe "" (\v -> ",\"kernel\":" ++ jstr v) (envKernel e) + , maybe "" (\v -> ",\"cpu\":" ++ jstr v) (envCpu e) + , ",\"cores\":", show (envCores e) + , maybe "" (\v -> ",\"governor\":" ++ jstr v) (envGovernor e) + , maybe "" (\v -> ",\"boost\":" ++ jstr v) (envBoost e) + , maybe "" (\v -> ",\"smt\":" ++ jstr v) (envSmt e) + , maybe "" (\v -> ",\"paranoid\":" ++ jstr v) (envParanoid e) + , maybe "" (\(l1, l5, l15) -> ",\"load\":[" + ++ intercalate "," (map showF [l1, l5, l15]) ++ "]") + (envLoad e) + , maybe "" (\v -> ",\"time\":" ++ jstr v) (envTime e) + , "}" + ] + +caseJSON :: CaseReport -> String +caseJSON cr = concat + [ "{\"name\":", jstr (crName cr) + , maybe "" (\b -> ",\"batch\":" ++ show b) (crBatch cr) + , maybe "" (\n -> ",\"noise\":{\"med\":" ++ show (nsMedian n) + ++ ",\"iqr\":" ++ show (nsIqr n) ++ "}") (crNoise cr) + , maybe "" (\n -> ",\"baseline\":{\"med\":" ++ show (nsMedian n) + ++ ",\"iqr\":" ++ show (nsIqr n) ++ "}") (crBaseline cr) + , ",\"result\":", resultToJSON (crResult cr) + , maybe "" (\a -> ",\"controls\":" ++ controlsJSON a) + (crAttribution cr) + , maybe "" (\frs -> ",\"trace\":" ++ traceArrayJSON frs) (crTrace cr) + , "}" + ] + +-- | Serialise a t'Result' as a stable JSON object. Includes verdict, +-- pairs, mixture peak log e-value, anytime-valid p-value, effect +-- interval, clip counts at each of the three magnitude bounds, +-- warmup bound, the resolved order seed, the CDF channel as +-- @[cut point, peak]@ pairs, per-component peaks, and the +-- 'diagnose' advisories. +-- +-- The seed here is the /order/ seed ('resSeed'), the one that +-- replays the A\/B order sequence. The sampler seed is a property +-- of the harness, not of a run, and appears in the report header. +-- +-- The object is a single line; pipe multiple runs into a +-- line-oriented store and diff or filter with @jq@. +resultToJSON :: Result -> String +resultToJSON r = concat + [ "{\"verdict\":", jstr (verdictName r) + , ",\"pairs\":", show (resPairs r) + , printf ",\"peakLogW\":%.6g" (resPeakLogW r) + , printf ",\"pvalue\":%.6g" (resPValue r) + , printf ",\"effect\":[%.6g,%.6g]" + (fst (resEffect r)) (snd (resEffect r)) + , ",\"clipped\":", show (resClipped r) + , ",\"clipped4\":", show (resClipped4 r) + , ",\"clipped16\":", show (resClipped16 r) + , printf ",\"bound\":%.6g" (resBound r) + -- the resolved absolute interval-null margin, present only on + -- margin-mode runs (in meter units per batch, like the bound). + , maybe "" (printf ",\"margin\":%.6g") (resMargin r) + , ",\"orderSeed\":", jstr (seedHex (resSeed r)) + , ",\"cdf\":[" + , intercalate "," + [ printf "[%.6g,%.6g]" q p | (q, p) <- resCdf r ] + , "]" + , ",\"peaks\":{" + , printf "\"sign\":%.6g" (resPeakSign r) + , printf ",\"magn\":%.6g" (resPeakMagn r) + , printf ",\"magn4\":%.6g" (resPeakMagn4 r) + , printf ",\"magn16\":%.6g" (resPeakMagn16 r) + , printf ",\"cdf\":%.6g" (resPeakCdf r) + , "}" + , ",\"advisories\":[" + , intercalate "," (map advisoryJSON (diagnose r)) + , "]}" + ] + +advisoryJSON :: Advisory -> String +advisoryJSON a = case a of + HighClipRate cr -> printf + ("{\"kind\":\"HighClipRate\",\"clipFraction\":%.4g" + ++ ",\"clipFraction4\":%.4g,\"clipFraction16\":%.4g}") + (clipTight cr) (clipWide cr) (clipWidest cr) + LowPower h -> printf + "{\"kind\":\"LowPower\",\"widthOverBound\":%.4g}" h + RejectionDriver s -> concat + [ "{\"kind\":\"RejectionDriver\",\"shape\":" + , jstr (shapeName s), "}" + ] + +traceArrayJSON :: [Frame] -> String +traceArrayJSON frs = + "[" ++ intercalate "," (map frameJSON (thin frs)) ++ "]" + where + frameJSON fr = printf "[%d,%.4f,%.4f,%.1f,%.1f]" + (frPair fr) (frLogW fr) (frLogWSup fr) (frLo fr) (frHi fr) + +totalsJSON :: Double -> [CaseReport] -> String +totalsJSON alpha cs = + let n = length cs + (nr, np, pr) = tally cs + in concat + [ "{\"cases\":", show n + , ",\"reject\":", show nr + , ",\"pass\":", show np + , ",\"pairs\":", show pr + , ",\"alpha\":", showF alpha + , ",\"familyAlpha\":", showF (familyAlpha alpha n) + , "}" + ] + +-- Censor's type-I guarantee is per run. A battery that calls +-- failure when /any/ of its M cells rejects has a family-wise false +-- alarm probability bounded by M * alpha (union bound), not alpha. +-- Reported so a reader does not have to reconstruct it; to actually +-- test at alpha family-wise, run each cell at alpha / M. +familyAlpha :: Double -> Int -> Double +familyAlpha !alpha !n = min 1 (alpha * fromIntegral (max 1 n)) + +-- The controls block: the combined verdict plus both control runs +-- in full. Serialising the runs (rather than reducing them to a +-- label) is deliberate — 'ControlsPass' is an absence of evidence, +-- and a reader should be able to see how much evidence was +-- actually gathered before accepting it. +controlsJSON :: Attribution -> String +controlsJSON a = concat + [ "{\"verdict\":", jstr (controlLabel (attVerdict a)) + , ",\"aa\":", resultToJSON (attAA a) + , ",\"bb\":", resultToJSON (attBB a) + , "}" + ] + +controlLabel :: ControlVerdict -> String +controlLabel v = case v of + ControlsPass -> "controls pass" + SampleAAsymmetry -> "sampleA asymmetry" + SampleBAsymmetry -> "sampleB asymmetry" + PervasiveAsymmetry -> "pervasive asymmetry" + +-- plain renderer ----------------------------------------------------------- + +-- | ASCII-only, no ANSI, no unicode. Suitable for CI logs and grep +-- pipelines that dislike middle dots. +plain :: Renderer +plain = Renderer + { rndOpen = plainOpen + , rndCase = plainCase + , rndClose = plainClose + } + +plainOpen :: ReportCfg -> ReportHeader -> IO () +plainOpen _ hdr = do + putStrLn $ "ppad " ++ brand ++ " v" ++ brandVersion + let entries = headerEntries ", " hdr + keyW = keyWidth entries + mapM_ (\(k, v) -> putStrLn $ padR keyW k ++ " " ++ v) entries + putStrLn "" + +plainCase :: ReportCfg -> CaseReport -> IO () +plainCase _ cr = do + let r = crResult cr + hd = printf "%s %s pairs=%d peakLogW=%.2f p=%.2g" + (verdictName r) (crName cr) (resPairs r) + (resPeakLogW r) (resPValue r) :: String + drv = case r of + Reject{} -> " driver=" ++ shapeName (leakShape r) + Pass{} -> "" + putStrLn (hd ++ drv) + mapM_ (putStrLn . (" " ++)) (detailLines " " cr) + +plainClose :: ReportCfg -> ReportHeader -> BatteryTail -> IO () +plainClose _ hdr tl = do + let cs = btCases tl + (nr, np, pr) = tally cs + fam = case familySeg hdr cs of + (s:_) -> " " ++ s + [] -> "" + wrote = case btOutput tl of + Just p -> " wrote=" ++ p + Nothing -> "" + putStrLn "" + putStrLn $ "summary: reject=" ++ show nr + ++ " pass=" ++ show np + ++ " pairs=" ++ show pr + ++ fam + ++ wrote + +-- shared helpers ----------------------------------------------------------- + +-- (rejects, passes, pairs consumed) across a battery. +tally :: [CaseReport] -> (Int, Int, Int) +tally cs = + let nr = length (filter (isReject . crResult) cs) + in (nr, length cs - nr, sum (map (resPairs . crResult) cs)) + +isReject :: Result -> Bool +isReject Reject{} = True +isReject Pass{} = False + +attributionText :: Attribution -> String +attributionText a = case attVerdict a of + ControlsPass -> + "controls: pass (A/A " ++ show (resPairs (attAA a)) + ++ ", B/B " ++ show (resPairs (attBB a)) + ++ " pairs; consistent with a target leak, not proof of one)" + SampleAAsymmetry -> + "controls: sampleA asymmetry (A/A rejected at " + ++ show (resPairs (attAA a)) ++ ")" + SampleBAsymmetry -> + "controls: sampleB asymmetry (B/B rejected at " + ++ show (resPairs (attBB a)) ++ ")" + PervasiveAsymmetry -> + "controls: pervasive harness asymmetry (A/A at " + ++ show (resPairs (attAA a)) ++ ", B/B at " + ++ show (resPairs (attBB a)) ++ ")" + +seedHex :: Word64 -> String +seedHex w = "0x" ++ showHex w "" + +showF :: Double -> String +showF = printf "%.6g" + +jstr :: String -> String +jstr s = "\"" ++ concatMap esc s ++ "\"" + where + esc '"' = "\\\"" + esc '\\' = "\\\\" + esc '\n' = "\\n" + esc '\r' = "\\r" + esc '\t' = "\\t" + esc c = [c] + +padR, padL :: Int -> String -> String +padR n s = s ++ replicate (max 0 (n - length s)) ' ' +padL n s = replicate (max 0 (n - length s)) ' ' ++ s + +-- shared suite arg surface ------------------------------------------------- + +-- | The parsed suite argv: +-- @[--format FMT] [--batch N] [--margin M] [METER] [EXTRA...]@. +-- 'runTraceSuite' takes the first extra as an output path. +data SuiteArgs = SuiteArgs + { saRenderer :: !Renderer + -- ^ resolved from @--format@; defaults to 'pretty'. + , saMeter :: !(Maybe String) + -- ^ meter name (@wall@, @instructions@, ...); 'Nothing' means + -- accept the runner's default. + , saBatch :: !(Maybe Int) + -- ^ fixed batch from @--batch@, overriding every case's + -- 'BatchPolicy'; 'Nothing' leaves each case's own. + , saMargin :: !(Maybe Double) + -- ^ relative interval-null margin from @--margin@ (see + -- 'Censor.cfgMargin'); 'Nothing' tests the sharp null + -- (mirrors the dlopen CLI's flag). + , saExtra :: ![String] + -- ^ positional arguments left after meter, in order. + } + +-- | Parse the standard suite argv from 'Env.getArgs'. Dies with a +-- clear message if @--format@ or @--batch@ is malformed. The +-- extras list is handed to the runner for further interpretation. +parseSuiteArgs :: IO SuiteArgs +parseSuiteArgs = do + raw <- Env.getArgs + let (farg, rest0) = takeFormatArg raw + (barg, rest1) = takeFlagArg "--batch" rest0 + (garg, rest) = takeFlagArg "--margin" rest1 + rnd <- resolveFormat farg + bat <- case barg of + Nothing -> pure Nothing + Just s -> case reads s of + [(n, "")] | n >= 1 -> pure (Just n) + _ -> die $ "unknown --batch " ++ show s + ++ " (expected a positive integer)" + mgn <- case garg of + Nothing -> pure Nothing + Just s -> case reads s of + [(m, "")] | m > (0 :: Double) -> pure (Just m) + _ -> die $ "unknown --margin " ++ show s + ++ " (expected a positive number)" + let (marg, extra) = case rest of + [] -> (Nothing, []) + (m:more) -> (Just m, more) + pure SuiteArgs + { saRenderer = rnd + , saMeter = marg + , saBatch = bat + , saMargin = mgn + , saExtra = extra + } + +-- trace-recording suite scaffold ------------------------------------------- + +-- | How a case's 'cfgBatch' is chosen. The distinction is a +-- /repeatability contract/ the case author asserts about the +-- target, and it cannot be inferred: batching only multiplies +-- real work when each repetition genuinely recomputes. +data BatchPolicy + = SingleShot + -- ^ One execution per timed region. The correct policy for a + -- pure Haskell target such as @\\a -> () <$ evaluate (f a)@: + -- the @f a@ thunk is shared across the batch and forced once, + -- so repetitions beyond the first are no-ops on an + -- already-evaluated value and a calibrated batch of @N@ would + -- describe one call plus @N-1@ no-ops. If the target is + -- sub-quantum under the meter, widen the work rather than + -- batching. + | RepeatableAuto + -- ^ Each repetition genuinely recomputes, so calibrate the + -- batch with 'calibrateBatchReport'. Appropriate for foreign + -- (FFI) calls and targets driving mutable state — anything + -- that cannot be memoised by a thunk. + | FixedBatch !Int + -- ^ Pin the batch outright, bypassing calibration. Use when + -- batches must match across meters for comparability. + deriving (Eq, Show) + +-- | One case in a t'TraceSuite': a display name, its 'BatchPolicy', +-- and an @IO@ action producing the hypothesis. Existentially +-- quantified over the hypothesis input type so a suite can hold +-- cases with different payload shapes in one list. +-- +-- > TraceCase "encrypt" SingleShot posAeadEncrypt +-- > TraceCase "mul" RepeatableAuto posFfiMul +-- +-- The action is re-executed for the calibration probe (under +-- 'RepeatableAuto'), the main run, and (on 'Reject') the negative +-- controls, so the builder should be inexpensive and side-effect +-- free. +data TraceCase = + forall a. TraceCase !String !BatchPolicy !(IO (Hypothesis a)) + +-- | A trace-recording suite: iterate a list of hypotheses under a +-- chosen meter, record each run's per-pair frame trajectory, and +-- write the whole battery as a single @censor\/report-v3@ JSON +-- artefact alongside the human-facing report. +-- +-- The tool's @Main.hs@ builds one of these and calls +-- 'runTraceSuite'; everything else — arg parse, meter selection, +-- per-case 'calibrateBatch', 'record', auto-attribution on +-- 'Reject', header assembly, @withReport@ driver, JSON write — +-- is done inside. +data TraceSuite = TraceSuite + { tsTarget :: !String + -- ^ one-line target description shown in the header block. + , tsConfig :: !Config + -- ^ base driver config. 'runTraceSuite' calibrates 'cfgBatch' + -- per case (or pins it from @--batch@), so the value of + -- @cfgBatch@ here is ignored; 'cfgAlpha', 'cfgWarmup', + -- 'cfgBudget', and 'cfgSeed' are applied verbatim. + , tsSeed :: !(Maybe Word64) + -- ^ user-facing sampler seed shown in the header block. + , tsNote :: !(Maybe String) + -- ^ optional one-line note under the header block. + , tsCases :: ![TraceCase] + -- ^ heterogeneous case list. + } + +-- | Drive a t'TraceSuite' end to end. The JSON artefact is written +-- to the first positional argument after the meter, defaulting to +-- @\-\.json@; it carries the same content the +-- 'json' renderer emits to stdout under @--format json@. +-- +-- A host-environment snapshot ('captureEnv') is taken at run start +-- and rides on the header. Per case: 'calibrateBatchReport' picks +-- the batch and records the meter's noise floor at it (both +-- surface on the case row and in the JSON) unless @--batch N@ +-- pins the batch (no probe, no noise floor — the honest setting +-- for pure Haskell targets is @--batch 1@), 'baselineReading' +-- records the target's baseline cost on fresh class-A draws at +-- the resolved batch (every policy — fresh draws are genuine work +-- even for pure targets), 'record' streams the run and keeps its +-- frames, and on 'Reject' 'attribute' runs the A\/A + B\/B +-- diagnostics automatically (two extra runs). +runTraceSuite :: TraceSuite -> IO () +runTraceSuite ts = do + hSetBuffering stdout LineBuffering + prog <- Env.getProgName + sa <- parseSuiteArgs + rc <- initReportCfg + case tsCases ts of + [] -> die (prog ++ ": no cases configured") + _ -> pure () + let out = case saExtra sa of + (o:_) -> Just o + _ -> Nothing + withMeterArg (saMeter sa) $ \mname meter -> do + env <- captureEnv + let cfgBase = (tsConfig ts) + { cfgMargin = + maybe (cfgMargin (tsConfig ts)) Just (saMargin sa) } + hdr = ReportHeader + { rhMeter = mname + , rhConfig = cfgBase + { cfgBatch = fromMaybe (cfgBatch cfgBase) (saBatch sa) } + , rhSeed = tsSeed ts + , rhTarget = Just (tsTarget ts) + , rhNote = tsNote ts + , rhEnv = Just env + , rhPerCaseBatch = maybe True (const False) (saBatch sa) + } + path = fromMaybe (prog ++ "-" ++ mname ++ ".json") out + ref <- newIORef ([] :: [CaseReport]) + _ <- withReport rc (saRenderer sa) hdr $ \emit -> do + forM_ (tsCases ts) $ \(TraceCase name policy mkH) -> do + -- --batch overrides every case's policy; otherwise the + -- case's own declared policy governs, and only + -- RepeatableAuto runs a calibration probe. + -- + -- Each probe gets its own instance: it runs a prologue and + -- class-A draws, and the main run should start from the + -- same state whether or not any probe happened. + (b, mnoise) <- case maybe policy FixedBatch (saBatch sa) of + SingleShot -> pure (1, Nothing) + FixedBatch n -> pure (n, Nothing) + RepeatableAuto -> do + hCal <- mkH + cb <- calibrateBatchReport meter hCal + pure (C.crBatch cb, C.crNoise cb) + let c = cfgBase { cfgBatch = b } + hBase <- mkH + base <- baselineReading meter c hBase + h <- mkH + t <- record name mname meter c h + let r = traceResult t + mat <- case r of + Reject{} -> do + hAtt <- mkH + Just <$> attribute meter c hAtt + Pass{} -> pure Nothing + let cr = CaseReport + { crName = name + , crResult = r + , crAttribution = mat + , crBatch = Just b + , crNoise = mnoise + , crBaseline = Just base + , crTrace = Just (traceFrames t) + } + modifyIORef' ref (cr :) + emit cr + cases <- fmap reverse (readIORef ref) + writeFile path (reportJSON hdr cases) + pure (Just path) + pure () diff --git a/ppad-censor.cabal b/ppad-censor.cabal new file mode 100644 --- /dev/null +++ b/ppad-censor.cabal @@ -0,0 +1,189 @@ +cabal-version: 3.0 +name: ppad-censor +version: 0.5.1 +synopsis: Anytime-valid sequential constant-time testing. +license: MIT +license-file: LICENSE +author: Jared Tobin +maintainer: jared@ppad.tech +category: Testing +build-type: Simple +tested-with: GHC == { 9.10.3 } +extra-doc-files: CHANGELOG +description: + A pure Haskell framework for sequential constant-time testing via + anytime-valid e-processes. + + Declare a constant-time hypothesis (an @IO@ action plus two input + samplers); the driver times the action on paired inputs from the two + classes, in random order, and tests them with a hedged mixture of + ppad-eproc e-processes, halting as soon as the evidence suffices. + + Provides dudect-style fix-vs-random hypotheses, A/A and B/B negative + controls, wall-clock and Linux hardware-counter meters, foreign + targets via FFI or a dlopen CLI, and anytime-valid p-values and + effect-size intervals. + +flag llvm + description: Use GHC's LLVM backend. + default: False + manual: True + +flag validate + description: Build the censor-validate executable, which runs the + empirical calibration battery (synthetic-meter false- + positive sweep + power table) and the host power-gain + probe. + default: False + manual: True + +flag run + description: Build the `censor` executable, a dlopen-based runner + that drives a constant-time hypothesis against a + foreign target resolved from a shared library. + default: False + manual: True + +flag integration + description: Build the censor-integration test suite, which drives + a compiled C shim through 'Censor.Runner.DL' end-to-end. + Requires a working C compiler on PATH; not available on + Windows. + default: False + manual: True + +source-repository head + type: git + location: git.ppad.tech/censor.git + +library + default-language: Haskell2010 + hs-source-dirs: lib + ghc-options: + -Wall + c-sources: cbits/censor_env.c + if flag(llvm) + ghc-options: -fllvm -O2 + if !os(windows) + c-sources: cbits/censor_dl.c + if os(linux) + c-sources: cbits/censor_perf.c + extra-libraries: dl + if os(osx) + c-sources: cbits/censor_clock.c + exposed-modules: + Censor + Censor.FFI + Censor.Meter + Censor.Rng + Censor.Runner + Censor.Runner.DL + Censor.Runner.Env + Censor.Runner.Manifest + Censor.Runner.Report + other-modules: + Paths_ppad_censor + autogen-modules: + Paths_ppad_censor + build-depends: + base >= 4.9 && < 5 + , bytestring >= 0.9 && < 0.13 + , ppad-eproc >= 0.5 && < 0.6 + , primitive >= 0.8 && < 0.10 + +test-suite censor-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + + ghc-options: + -rtsopts -Wall -O2 + + build-depends: + base + , bytestring + , ppad-censor + , tasty + , tasty-hunit + +benchmark censor-bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Main.hs + + ghc-options: + -rtsopts -O2 -Wall -fno-warn-orphans + if flag(llvm) + ghc-options: -fllvm + + build-depends: + base + , criterion + , deepseq + , ppad-censor + +benchmark censor-weigh + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Weight.hs + + ghc-options: + -rtsopts -O2 -Wall -fno-warn-orphans + if flag(llvm) + ghc-options: -fllvm + + build-depends: + base + , deepseq + , ppad-censor + , weigh + +executable censor-validate + default-language: Haskell2010 + hs-source-dirs: validate + main-is: Main.hs + ghc-options: + -O2 -rtsopts -Wall + + if !flag(validate) + buildable: False + else + build-depends: + base + , ppad-censor + +executable censor + default-language: Haskell2010 + hs-source-dirs: run + main-is: Main.hs + ghc-options: + -O2 -rtsopts -Wall + + if !flag(run) + buildable: False + else + build-depends: + base + , ppad-censor + +test-suite censor-integration + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test-integration + main-is: Main.hs + + ghc-options: + -rtsopts -Wall -O2 + + if !flag(integration) || os(windows) + buildable: False + else + build-depends: + base + , ppad-censor + , process + , tasty + , tasty-hunit diff --git a/run/Main.hs b/run/Main.hs new file mode 100644 --- /dev/null +++ b/run/Main.hs @@ -0,0 +1,606 @@ +{-# LANGUAGE BangPatterns #-} + +-- censor: dlopen-based sequential CT runner. See 'usage' for the +-- command line. +-- +-- Every sample starts from a workspace of fresh pseudorandom bytes +-- (independent per-class streams), then overlays the declared ranges: +-- +-- * --secret ranges are refilled each sample in BOTH classes +-- through one reseed-and-fill path: class A from a +-- seed pinned at setup, class B from a fresh seed. This +-- is the fix-vs-random axis; no long-lived secret +-- buffer exists for one class alone to read (see +-- issues/handled/ISSUE4.md). +-- * --public ranges are copied in BOTH classes from one buffer +-- drawn at setup, pinned for the whole run. +-- * --context ranges are copied in BOTH classes from a buffer +-- redrawn once per pair: one fresh public input shared +-- by the pair. +-- +-- --seed pins the input samplers only; the A/B order bit is seeded +-- separately by --order-seed (default: fresh OS entropy, reported for +-- replay), since the conditional null needs the two independent. + +module Main where + +import Control.Applicative ((<|>)) +import Control.Exception (catch) +import Control.Monad (forM_, when) +import Data.Bits (xor) +import Data.Maybe (fromMaybe, isJust) +import Data.Word (Word8, Word64) +import Foreign.ForeignPtr + (ForeignPtr, mallocForeignPtrBytes, withForeignPtr) +import Foreign.Marshal.Utils (copyBytes) +import Foreign.Ptr (Ptr, plusPtr) +import qualified System.Environment as Env +import System.Exit (ExitCode(..), exitWith) +import System.IO (hPutStrLn, stderr) + +import qualified Censor as C +import qualified Censor.FFI as F +import qualified Censor.Runner as R +import qualified Censor.Runner.DL as DL +import qualified Censor.Runner.Manifest as M +import qualified Censor.Runner.Report as Rep +import Censor.Runner.Manifest (Range(..)) + +-- args ------------------------------------------------------------------------ + +-- Command-line flags as given. 'parseArgs' validates them and +-- resolves the run mode. +data Args = Args + { argLib :: !(Maybe FilePath) + , argTarget :: !(Maybe String) + , argWorkspace :: !(Maybe Int) + , argSecret :: ![Range] + , argPublic :: ![Range] + , argContext :: ![Range] + , argMeter :: !(Maybe String) + , argAlpha :: !(Maybe Double) + , argBudget :: !(Maybe Int) + , argWarmup :: !(Maybe Int) + , argBatch :: !(Maybe Int) + , argMargin :: !(Maybe Double) + , argSeed :: !(Maybe Word64) + , argOrderSeed :: !(Maybe Word64) + , argFormat :: !(Maybe String) + , argTrace :: !(Maybe FilePath) + , argAttribute :: !Bool + , argManifest :: !(Maybe FilePath) + } + +emptyArgs :: Args +emptyArgs = Args + { argLib = Nothing + , argTarget = Nothing + , argWorkspace = Nothing + , argSecret = [] + , argPublic = [] + , argContext = [] + , argMeter = Nothing + , argAlpha = Nothing + , argBudget = Nothing + , argWarmup = Nothing + , argBatch = Nothing + , argMargin = Nothing + , argSeed = Nothing + , argOrderSeed = Nothing + , argFormat = Nothing + , argTrace = Nothing + , argAttribute = False + , argManifest = Nothing + } + +-- A single target with its workspace size, or a manifest battery. +data Mode + = Single !Int + | Battery !FilePath + +-- exit codes ------------------------------------------------------------------ + +exitReject, exitUsage, exitLoad :: Int +exitReject = 1 +exitUsage = 2 +exitLoad = 3 + +usage :: String +usage = unlines + [ "usage: censor --workspace BYTES [--target NAME]" + , " [--secret off:len]... [--public off:len]..." + , " [--context off:len]..." + , " [--meter wall|instructions|cycles|branches" + , " |ref-cycles|task-clock|branch-misses" + , " |cache-misses]" + , " [--alpha FLOAT] [--budget INT] [--warmup INT]" + , " [--batch INT] [--margin FLOAT]" + , " [--seed HEX] [--order-seed HEX]" + , " [--format pretty|json|plain]" + , " [--trace PATH] [--attribute]" + , " or: censor --manifest PATH [--format FMT]" + , " [--attribute] [run-wide overrides]" + , "" + , "--manifest runs a whole battery from one file and emits a" + , "single report; per-case layout flags are then rejected." + , "" + , "--secret pins class A only (fix vs. random axis)." + , "--public pins BOTH classes for the whole run." + , "--context refreshes BOTH classes together, once per pair." + , "" + , "--margin M tests the interval null |mean effect| <= delta," + , "with delta = M x the warmup median reading (see cfgMargin)." + , "" + , "--seed pins the input samplers; --order-seed pins the A/B" + , "order bit (default: fresh OS entropy, reported on the run)." + , "" + , "Exit codes: 0 Pass, 1 Reject, 2 usage error, 3 load/symbol error." + ] + +die2 :: String -> IO a +die2 msg = do + hPutStrLn stderr msg + hPutStrLn stderr "" + hPutStrLn stderr usage + exitWith (ExitFailure exitUsage) + +-- parsing --------------------------------------------------------------------- + +parseArgs :: [String] -> IO (Args, FilePath, Mode) +parseArgs xs = go emptyArgs xs >>= finish + +go :: Args -> [String] -> IO Args +go a [] = pure a +go _ ("-h":_) = printHelp +go _ ("--help":_) = printHelp +go a (x:xs) = case x of + "--target" -> withVal x xs $ \v ys -> + once x (argTarget a) $ go a { argTarget = Just v } ys + "--workspace" -> withVal x xs $ \v ys -> do + n <- parseInt x v + once x (argWorkspace a) $ go a { argWorkspace = Just n } ys + "--secret" -> withVal x xs $ \v ys -> do + r <- parseRange x v + go a { argSecret = r : argSecret a } ys + "--public" -> withVal x xs $ \v ys -> do + r <- parseRange x v + go a { argPublic = r : argPublic a } ys + "--context" -> withVal x xs $ \v ys -> do + r <- parseRange x v + go a { argContext = r : argContext a } ys + "--meter" -> withVal x xs $ \v ys -> + once x (argMeter a) $ go a { argMeter = Just v } ys + "--alpha" -> withVal x xs $ \v ys -> do + d <- parseDouble x v + go a { argAlpha = Just d } ys + "--budget" -> withVal x xs $ \v ys -> do + n <- parseInt x v + go a { argBudget = Just n } ys + "--warmup" -> withVal x xs $ \v ys -> do + n <- parseInt x v + go a { argWarmup = Just n } ys + "--batch" -> withVal x xs $ \v ys -> do + n <- parseInt x v + go a { argBatch = Just n } ys + "--margin" -> withVal x xs $ \v ys -> do + d <- parseDouble x v + go a { argMargin = Just d } ys + "--seed" -> withVal x xs $ \v ys -> do + w <- parseHex x v + go a { argSeed = Just w } ys + "--order-seed" -> withVal x xs $ \v ys -> do + w <- parseHex x v + go a { argOrderSeed = Just w } ys + "--format" -> withVal x xs $ \v ys -> + once x (argFormat a) $ go a { argFormat = Just v } ys + "--trace" -> withVal x xs $ \v ys -> + once x (argTrace a) $ go a { argTrace = Just v } ys + "--attribute" -> go a { argAttribute = True } xs + "--manifest" -> withVal x xs $ \v ys -> + once x (argManifest a) $ go a { argManifest = Just v } ys + _ + | take 2 x == "--" -> die2 ("censor: unknown flag " ++ x) + | otherwise -> case argLib a of + Nothing -> go a { argLib = Just x } xs + Just _ -> die2 ("censor: unexpected positional argument " ++ x) + +printHelp :: IO a +printHelp = do + putStr usage + exitWith ExitSuccess + +withVal :: String -> [String] -> (String -> [String] -> IO a) -> IO a +withVal name [] _ = die2 ("censor: " ++ name ++ " expects a value") +withVal _ (v:xs) k = k v xs + +once :: String -> Maybe b -> IO a -> IO a +once name (Just _) _ = die2 ("censor: " ++ name ++ " given twice") +once _ Nothing k = k + +parseInt :: String -> String -> IO Int +parseInt name v = case reads v of + [(n, "")] | n >= 0 -> pure n + _ -> die2 ("censor: " ++ name ++ " expects a non-negative integer," + ++ " got " ++ show v) + +parseDouble :: String -> String -> IO Double +parseDouble name v = case reads v of + [(d, "")] -> pure d + _ -> die2 ("censor: " ++ name ++ " expects a floating-point value," + ++ " got " ++ show v) + +parseHex :: String -> String -> IO Word64 +parseHex name v = case M.readSeed v of + Just w -> pure w + Nothing -> die2 ("censor: " ++ name ++ " expects a hex Word64," + ++ " got " ++ show v) + +parseRange :: String -> String -> IO Range +parseRange name v = case M.readRange v of + Just r -> pure r + Nothing -> die2 ("censor: " ++ name ++ " expects off:len with" + ++ " off >= 0, len > 0, got " ++ show v) + +finish :: Args -> IO (Args, FilePath, Mode) +finish a = do + lib <- case argLib a of + Just p -> pure p + Nothing -> die2 "censor: missing " + -- under --manifest the workspace layout is per case, so the + -- flags that describe a single case are rejected rather than + -- silently ignored. + mode <- case argManifest a of + Just p -> do + forM_ perCaseFlags $ \(name, given) -> + when given $ die2 ("censor: " ++ name ++ " is per-case under" + ++ " --manifest; declare it on the case") + pure (Battery p) + Nothing -> case argWorkspace a of + Just n | n > 0 -> pure (Single n) + Just _ -> die2 "censor: --workspace must be positive" + Nothing -> die2 "censor: missing --workspace BYTES" + let ws = case mode of + Single n -> n + Battery _ -> 0 + -- the same validator a manifest case goes through, so the two + -- entry points cannot accept different layouts. + case M.checkLayout ws (argSecret a) (argPublic a) (argContext a) of + Just msg -> die2 ("censor: " ++ msg) + Nothing -> pure () + let a' = a { argSecret = reverse (argSecret a) + , argPublic = reverse (argPublic a) + , argContext = reverse (argContext a) } + pure (a', lib, mode) + where + perCaseFlags = + [ ("--workspace", isJust (argWorkspace a)) + , ("--target", isJust (argTarget a)) + , ("--secret", not (null (argSecret a))) + , ("--public", not (null (argPublic a))) + , ("--context", not (null (argContext a))) + , ("--trace", isJust (argTrace a)) + ] + +-- hypothesis construction ----------------------------------------------------- + +-- fallback seed when the user does not pass --seed. Not +-- cryptographically meaningful; just a stable default so runs are +-- reproducible without a flag. +defaultSeed :: Word64 +defaultSeed = 0xC0FFEE5EED0BEEF7 + +-- setup: derive the pinned secret seed and draw the fixed --public +-- overlay buffer once from a seeded RNG; keep independent +-- per-class RNGs for the random fill of everything else. Context +-- ranges live in a second buffer that the prologue redraws once +-- per pair, so both classes see the same fresh public bytes there. +-- Returns an FFIHypothesis ready to hand to 'withFFIHypothesis'. +-- +-- Secret ranges are deliberately not overlaid from a long-lived +-- buffer: a buffer that only class A reads, every sample, is the +-- FFI form of the copy-source locality asymmetry described in +-- issues/handled/ISSUE4.md. Instead both classes refill their secret +-- ranges in place through one shared generator, reseeded before +-- every use: class A to the pinned seed, class B to a word drawn +-- from its own stream. The classes run identical code and differ +-- only in the seed value written into the generator state. +-- +-- The two buffers are ForeignPtrs held by the sampler closures, +-- so they live exactly as long as the hypothesis does and are +-- reclaimed with it. Each phase of a case builds its own hypothesis; +-- raw mallocs would strand a workspace apiece for the length of a +-- battery. +buildHypothesis + :: Int -- ^ workspace bytes + -> [Range] -- ^ secret ranges (class A pinned) + -> [Range] -- ^ public ranges (both classes, pinned) + -> [Range] -- ^ context ranges (both classes, per pair) + -> Word64 -- ^ sampler seed + -> (Ptr Word8 -> IO ()) + -> IO F.FFIHypothesis +buildHypothesis ws secrets publics contexts seed target = do + fixPub <- mallocForeignPtrBytes ws + ctxBuf <- mallocForeignPtrBytes ws + gFix <- C.mkRng seed + !s0 <- C.nextWord gFix + withForeignPtr fixPub $ \p -> F.fillRandom gFix p ws + ga <- C.mkRng (seed `xor` 0x0A0A0A0A0A0A0A0A) + gb <- C.mkRng (seed `xor` 0x0B0B0B0B0B0B0B0B) + gCtx <- C.mkRng (seed `xor` 0x0C0C0C0C0C0C0C0C) + rSec <- C.mkRng s0 + let refresh + | null contexts = pure () + | otherwise = withForeignPtr ctxBuf $ \p -> + mapM_ (\(Range o l) -> + F.fillRandom gCtx (p `plusPtr` o) l) contexts + -- both classes draw one word from their own stream and + -- reseed the shared secret generator -- class A pins the + -- seed ('const' s0) and discards its draw, class B seeds + -- with its draw ('id') -- then fill the secret ranges in + -- place. Short-circuits on no secret ranges, like 'overlay'. + fillSecrets !g seedOf !p + | null secrets = pure () + | otherwise = do + !w <- C.nextWord g + C.reseed rSec (seedOf w) + mapM_ (\(Range o l) -> + F.fillRandom rSec (p `plusPtr` o) l) secrets + refresh + pure F.FFIHypothesis + { F.ffiWorkspaceBytes = ws + , F.ffiPrepare = refresh + -- role ranges are validated pairwise disjoint, so the write + -- order below is immaterial: no two of them touch the same + -- byte. + , F.ffiSampleA = \p -> do + F.fillRandom ga p ws + overlay p ctxBuf contexts + overlay p fixPub publics + fillSecrets ga (const s0) p + , F.ffiSampleB = \p -> do + F.fillRandom gb p ws + overlay p ctxBuf contexts + overlay p fixPub publics + fillSecrets gb id p + , F.ffiTarget = target + } + +-- Copy the declared ranges out of a backing buffer into the +-- workspace. Short-circuits on an empty range list, so a role a +-- hypothesis does not use costs nothing per sample. +overlay :: Ptr Word8 -> ForeignPtr Word8 -> [Range] -> IO () +overlay _ _ [] = pure () +overlay dst src rs = withForeignPtr src $ \p -> + mapM_ (\(Range o l) -> + copyBytes (dst `plusPtr` o) (p `plusPtr` o) l) rs + +-- driver ---------------------------------------------------------------------- + +main :: IO () +main = do + (args, lib, mode) <- Env.getArgs >>= parseArgs + let run = case mode of + Single ws -> runSingle args lib ws + Battery p -> runManifest args lib p + run `catch` \e -> case e of + DL.DLOpenFailed p m -> + dieLoad ("censor: dlopen " ++ p ++ " failed: " ++ m) + DL.DLSymFailed s m -> + dieLoad ("censor: dlsym " ++ s ++ " failed: " ++ m) + +dieLoad :: String -> IO a +dieLoad msg = do + hPutStrLn stderr msg + exitWith (ExitFailure exitLoad) + +-- exit 0 when every case passed, 1 when any rejected. +exitVerdicts :: [Rep.CaseReport] -> IO a +exitVerdicts cases + | any (isReject . Rep.crResult) cases = exitWith (ExitFailure exitReject) + | otherwise = exitWith ExitSuccess + +isReject :: C.Result -> Bool +isReject C.Reject{} = True +isReject C.Pass{} = False + +-- The sampler seed. Distinct from the order-bit seed, which the +-- driver resolves from OS entropy unless --order-seed pins it. +samplerSeed :: Args -> Word64 +samplerSeed args = fromMaybe defaultSeed (argSeed args) + +-- CLI flag beats manifest directive beats built-in default. +pick :: Maybe a -> Maybe a -> a -> a +pick cli mf def = fromMaybe def (cli <|> mf) + +runConfig :: Args -> M.Defaults -> C.Config +runConfig args d = C.defaultConfig + { C.cfgAlpha = pick (argAlpha args) (M.dfAlpha d) + (C.cfgAlpha C.defaultConfig) + , C.cfgBudget = pick (argBudget args) (M.dfBudget d) + (C.cfgBudget C.defaultConfig) + , C.cfgWarmup = pick (argWarmup args) (M.dfWarmup d) + (C.cfgWarmup C.defaultConfig) + , C.cfgBatch = 1 -- resolved per case + , C.cfgMargin = argMargin args <|> M.dfMargin d + , C.cfgSeed = argOrderSeed args <|> M.dfOrderSeed d + -- deliberately not argSeed: the order bit must be independent of + -- the sampler stream. + } + +-- One case: a baseline probe, the run (recording its frames under +-- --trace), and, on a rejection under --attribute, the negative +-- controls. Each phase gets a fresh hypothesis instance, so the run +-- starts from the same sampler state whether or not a probe ran. +runCase + :: Args -> String -> C.Meter -> C.Config -> String + -> IO F.FFIHypothesis -> IO Rep.CaseReport +runCase args mname meter cfg name mk = do + base <- withHyp $ \h -> C.baselineReading meter cfg h + (result, mfrs) <- withHyp $ \h -> case argTrace args of + Nothing -> do + r <- C.runCT meter cfg h + pure (r, Nothing) + Just _ -> do + t <- R.record name mname meter cfg h + pure (R.traceResult t, Just (R.traceFrames t)) + mat <- case (argAttribute args, result) of + (True, C.Reject{}) -> withHyp $ \h -> Just <$> C.attribute meter cfg h + _ -> pure Nothing + pure Rep.CaseReport + { Rep.crName = name + , Rep.crResult = result + , Rep.crAttribution = mat + , Rep.crBatch = Nothing + , Rep.crNoise = Nothing + , Rep.crBaseline = Just base + , Rep.crTrace = mfrs + } + where + withHyp k = mk >>= \fh -> F.withFFIHypothesis fh k + +-- single target --------------------------------------------------------------- + +runSingle :: Args -> FilePath -> Int -> IO () +runSingle args lib ws = DL.withLibrary lib $ \lib' -> do + let name = fromMaybe "censor_target" (argTarget args) + seed = samplerSeed args + cfg = (runConfig args M.emptyDefaults) + { C.cfgBatch = fromMaybe 1 (argBatch args) } + target <- DL.resolveTarget lib' name + rnd <- Rep.resolveFormat (argFormat args) + rc <- Rep.initReportCfg + R.withMeterArg (argMeter args) $ \mname meter -> do + env <- Rep.captureEnv + let hdr = Rep.ReportHeader + { Rep.rhMeter = mname + , Rep.rhConfig = cfg + , Rep.rhSeed = Just seed + , Rep.rhTarget = Just name + , Rep.rhNote = Just ("library " ++ lib) + , Rep.rhEnv = Just env + , Rep.rhPerCaseBatch = False + } + cases <- Rep.withReport rc rnd hdr $ \emit -> do + cr <- runCase args mname meter cfg name $ + buildHypothesis ws (argSecret args) (argPublic args) + (argContext args) seed target + emit cr + -- the trace artefact is the same censor/report-v3 object the + -- json renderer emits, with the frame trajectory embedded. + forM_ (argTrace args) $ \tp -> writeFile tp (Rep.reportJSON hdr [cr]) + pure (argTrace args) + exitVerdicts cases + +-- manifest runner ------------------------------------------------------------ + +-- A case's batch: --batch overrides everything, then the case's own +-- key, then the manifest default, then 1. Defaulting to 1 rather +-- than 'auto' keeps a silently-calibrated batch out of a report +-- nobody asked to calibrate. +caseBatch :: Args -> M.Defaults -> M.ManifestCase -> M.BatchSpec +caseBatch args d mc = case argBatch args of + Just n -> M.BatchFixed n + Nothing -> fromMaybe (M.BatchFixed 1) (M.mcBatch mc <|> M.dfBatch d) + +-- Expand a case into one entry per replicate, each with its own +-- sampler seed so it draws an independent fixed secret. A single +-- replicate keeps the bare case name; several get a suffix. +data Cell = Cell + { cellName :: !String + , cellCase :: !M.ManifestCase + , cellSeed :: {-# UNPACK #-} !Word64 + } + +expand :: Word64 -> M.ManifestCase -> [Cell] +expand base mc + | n <= 1 = [Cell (M.mcName mc) mc s0] + | otherwise = + [ Cell (M.mcName mc ++ " #" ++ show i) mc (replicaSeed s0 i) + | i <- [1 .. n] + ] + where + n = M.mcReplicates mc + s0 = caseSeed base (M.mcId mc) + +-- Mix the run-wide seed with the case identity, so each case draws +-- its own fixed secret. Sharing one seed across every case would +-- start them all from identical bytes, which makes a battery far +-- less independent than its case count suggests. +-- +-- Deliberately 'mcId', not 'mcName': a label= override is a +-- presentation change, and must not silently re-roll the secret the +-- case tests against. +caseSeed :: Word64 -> String -> Word64 +caseSeed base name = base `xor` fnv1a name + +fnv1a :: String -> Word64 +fnv1a = foldl' step 0xCBF29CE484222325 + where + step !h ch = (h `xor` fromIntegral (fromEnum ch)) * 0x100000001B3 + +-- Replicate #1 *is* the base cell: raising 'replicates' must extend +-- a battery, never redefine the cell that was already in it. +-- Later indices decorrelate with the golden-ratio odd constant +-- rather than a small addend, so nearby indices do not produce +-- nearby generator states. +replicaSeed :: Word64 -> Int -> Word64 +replicaSeed base 1 = base +replicaSeed base i = base `xor` (fromIntegral i * 0x9E3779B97F4A7C15) + +runManifest :: Args -> FilePath -> FilePath -> IO () +runManifest args lib path = do + src <- readFile path + mf <- case M.parseManifest src of + Left err -> do + hPutStrLn stderr ("censor: " ++ err) + exitWith (ExitFailure exitUsage) + Right x -> pure x + let d = M.mfDefaults mf + seed = pick (argSeed args) (M.dfSeed d) defaultSeed + cells = concatMap (expand seed) (M.mfCases mf) + cfg0 = runConfig args d + -- 'family-alpha on' turns the reported union bound into an + -- actual correction: each of the M cells runs at alpha / M, so + -- "any cell rejects" is a test at alpha family-wise. + cfg = case M.dfFamilyAlpha d of + Just True -> cfg0 + { C.cfgAlpha = C.cfgAlpha cfg0 + / fromIntegral (max 1 (length cells)) } + _ -> cfg0 + rnd <- Rep.resolveFormat (argFormat args) + rc <- Rep.initReportCfg + DL.withLibrary lib $ \lib' -> + R.withMeterArg (argMeter args <|> M.dfMeter d) $ \mname meter -> do + env <- Rep.captureEnv + let hdr = Rep.ReportHeader + { Rep.rhMeter = mname + , Rep.rhConfig = cfg + , Rep.rhSeed = Just seed + , Rep.rhTarget = Just lib + , Rep.rhNote = Just ("manifest " ++ path) + , Rep.rhEnv = Just env + , Rep.rhPerCaseBatch = True + } + cases <- Rep.withReport rc rnd hdr $ \emit -> do + forM_ cells $ \cell -> + runCell args d mname meter cfg lib' cell >>= emit + pure Nothing + exitVerdicts cases + +runCell + :: Args -> M.Defaults -> String -> C.Meter -> C.Config -> DL.Library + -> Cell -> IO Rep.CaseReport +runCell args d mname meter cfg lib cell = do + let mc = cellCase cell + target <- DL.resolveTarget lib (M.mcTarget mc) + let mk = buildHypothesis (M.mcWorkspace mc) (M.mcSecret mc) + (M.mcPublic mc) (M.mcContext mc) (cellSeed cell) target + (b, mnoise) <- case caseBatch args d mc of + M.BatchFixed n -> pure (n, Nothing) + M.BatchAuto -> do + hCal <- mk + F.withFFIHypothesis hCal $ \h -> do + cb <- C.calibrateBatchReport meter h + pure (C.crBatch cb, C.crNoise cb) + cr <- runCase args mname meter cfg { C.cfgBatch = b } (cellName cell) mk + pure cr { Rep.crBatch = Just b, Rep.crNoise = mnoise } diff --git a/test-integration/Main.hs b/test-integration/Main.hs new file mode 100644 --- /dev/null +++ b/test-integration/Main.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE BangPatterns #-} + +-- End-to-end integration test for the dlopen runner path. +-- +-- Compiles a small C shim exporting two @void(uint8_t *)@ targets +-- (one constant-time, one linear in @ws[0]@), loads it through +-- 'Censor.Runner.DL', and drives fix-vs-random on byte offset 0..32 +-- through the sequential driver. Asserts Pass on the CT target and +-- Reject on the leaky one. + +module Main where + +import qualified Censor as C +import qualified Censor.FFI as F +import qualified Censor.Rng as R +import qualified Censor.Runner.DL as DL +import Data.Bits (xor) +import Data.Word (Word8, Word64) +import Foreign.Marshal.Alloc (mallocBytes) +import Foreign.Marshal.Utils (copyBytes) +import Foreign.Ptr (Ptr) +import System.Environment (lookupEnv) +import System.Info (os) +import System.Process (callProcess) +import Test.Tasty +import Test.Tasty.HUnit + +-- inline shim source; the build produces a shared library from this +-- string at test startup, so the suite doesn't depend on any file +-- outside the cabal target. +shimSource :: String +shimSource = unlines + [ "#include " + , "" + , "void ct_countdown(uint8_t *ws) {" + , " volatile uint64_t sink = 0;" + , " uint64_t n = 25500;" + , " (void)ws;" + , " while (n--) sink += n;" + , "}" + , "" + , "void leaky_countdown(uint8_t *ws) {" + , " volatile uint64_t sink = 0;" + , " uint64_t n = (uint64_t)ws[0] * 100;" + , " while (n--) sink += n;" + , "}" + ] + +sharedExt :: String +sharedExt = case os of + "darwin" -> "dylib" + _ -> "so" + +tmpDir :: IO FilePath +tmpDir = maybe "/tmp" id `fmap` lookupEnv "TMPDIR" + +buildShim :: IO FilePath +buildShim = do + dir <- tmpDir + let src = dir ++ "/censor-integration-shim.c" + lib = dir ++ "/censor-integration-shim." ++ sharedExt + writeFile src shimSource + callProcess "cc" ["-O2", "-shared", "-fPIC", "-o", lib, src] + pure lib + +main :: IO () +main = do + lib <- buildShim + defaultMain (tests lib) + +tests :: FilePath -> TestTree +tests lib = testGroup "censor-integration" [ + testCase "ct_countdown passes within budget" $ + runCase lib "ct_countdown" ExpectPass + + , testCase "leaky_countdown rejects within budget" $ + runCase lib "leaky_countdown" ExpectReject + ] + +data Expected = ExpectPass | ExpectReject + +runCase :: FilePath -> String -> Expected -> Assertion +runCase lib sym expected = DL.withLibrary lib $ \h -> do + target <- DL.resolveTarget h sym + hyp <- buildHyp target + res <- F.withFFIHypothesis hyp (C.runCT C.wallClock cfg) + case (expected, res) of + (ExpectPass, C.Pass{}) -> + pure () + (ExpectReject, C.Reject{}) -> + pure () + (ExpectPass, C.Reject { C.resPairs = n, C.resPeakLogW = w }) -> + assertFailure $ + "CT target falsely rejected at n=" ++ show n + ++ " logW=" ++ show w + (ExpectReject, C.Pass { C.resPairs = n, C.resPeakLogW = w }) -> + assertFailure $ + "leaky target not detected; passed at n=" ++ show n + ++ " logW=" ++ show w + where + cfg = C.defaultConfig + { C.cfgAlpha = 1.0e-3 + , C.cfgBudget = 4000 + , C.cfgWarmup = 100 + , C.cfgBatch = 1 + } + +-- workspace layout matches the manual smoke: 64 bytes, --secret 0:32, +-- --public empty. class A pins bytes 0..32 to a shared random-seeded +-- fixed buffer; class B fills the whole workspace at random. so ws[0] +-- is constant across class-A pairs and uniform across class-B pairs. +wsBytes :: Int +wsBytes = 64 + +secretLen :: Int +secretLen = 32 + +buildHyp :: (Ptr Word8 -> IO ()) -> IO F.FFIHypothesis +buildHyp target = do + let seed = 0xC0FFEE5EED0BEEF7 :: Word64 + fixSec <- mallocBytes wsBytes + gFix <- R.mkRng seed + F.fillRandom gFix fixSec wsBytes + ga <- R.mkRng (seed `xor` 0x0A0A0A0A0A0A0A0A) + gb <- R.mkRng (seed `xor` 0x0B0B0B0B0B0B0B0B) + pure F.FFIHypothesis + { F.ffiWorkspaceBytes = wsBytes + , F.ffiPrepare = pure () + , F.ffiSampleA = \p -> do + F.fillRandom ga p wsBytes + copyBytes p fixSec secretLen + , F.ffiSampleB = \p -> + F.fillRandom gb p wsBytes + , F.ffiTarget = target + } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1483 @@ +{-# LANGUAGE BangPatterns #-} + +module Main where + +import Control.Exception (try) +import Control.Monad (replicateM_) +import qualified Data.ByteString as BS +import Data.IORef +import Data.Word (Word8, Word64) +import Data.List (isInfixOf, isPrefixOf) +import qualified Censor as C +import qualified Censor.FFI as F +import qualified Censor.Runner as R +import qualified Censor.Runner.Env as E +import qualified Censor.Runner.Manifest as M +import qualified Censor.Runner.Report as Rep +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Array (peekArray) +import qualified System.Info as Info +import Test.Tasty +import Test.Tasty.HUnit + +main :: IO () +main = defaultMain $ testGroup "ppad-censor" [ + wallClockTests + , flatMeterTests + , calibrationTests + , batchCalibrationTests + , configValidationTests + , deterministicLeakTests + , runCTWithTests + , evidenceTests + , offByOneTests + , clipCountTests + , aaDiagnosticTests + , attributeTests + , attributedTests + , signOnlyLeakTests + , marginTests + , fixVsRandomTests + , fixVsRandomCtxTests + , rngTests + , randomBytesTests + , fillRandomTests + , smokeCalibrationTests + , diagnoseTests + , renderingTests + , calibReportTests + , baselineTests + , envTests + , reportJSONTests + , manifestTests + ] + +-- Test config for the wall-clock fixtures: a small budget, since +-- both produce strong signals (CT: identical work, leaky: 20x work +-- imbalance). +-- +-- alpha stays at the library default. A looser one is tempting for +-- the leaky fixture, which rejects under any alpha worth naming, +-- but it is the CT fixture that sets the floor: these are real +-- wall-clock measurements, and on a loaded machine the scheduler +-- leaves enough residual non-exchangeability to cross a 1e-3 +-- threshold over 5000 pairs. That is censor working, not censor +-- broken -- but it makes an H_0 assertion depend on ambient load. +-- Calibration proper belongs to censor-validate and its synthetic +-- meters; what these two fixtures check is that the wall-clock +-- meter and driver are wired together at all. +testConfig :: C.Config +testConfig = C.defaultConfig + { C.cfgAlpha = 1.0e-6 + , C.cfgBudget = 5000 + , C.cfgWarmup = 100 + , C.cfgBatch = 1 + } + +-- a meter that runs the wrapped action k times and reports a fixed +-- reading. Both classes look identical, so the wealth process never +-- grows and runCT exhausts its budget deterministically. +constMeter :: Word64 -> C.Meter +constMeter v = C.Meter $ \k act -> + let go 0 = pure () + go i = act >> go (i - 1) + in go k >> pure v + +wallClockTests :: TestTree +wallClockTests = testGroup "wall-clock" [ + testCase "constant-time target passes within budget" $ do + ref <- newIORef (0 :: Int) + let hyp = C.Hypothesis + { C.target = \_ -> + replicateM_ 1000 (modifyIORef' ref (+ 1)) + , C.prepare = pure () + , C.sampleA = pure (2000 :: Int) + , C.sampleB = pure (100 :: Int) + } + result <- C.runCT C.wallClock testConfig hyp + case result of + C.Pass{} -> pure () + C.Reject { C.resPairs = n, C.resPeakLogW = w } -> + assertFailure $ + "CT target falsely rejected at n=" ++ show n + ++ " logW=" ++ show w + + , testCase "leaky target rejected within budget" $ do + ref <- newIORef (0 :: Int) + let hyp = C.Hypothesis + { C.target = \n -> + replicateM_ n (modifyIORef' ref (+ 1)) + , C.prepare = pure () + , C.sampleA = pure (2000 :: Int) + , C.sampleB = pure (100 :: Int) + } + result <- C.runCT C.wallClock testConfig hyp + case result of + C.Reject{} -> pure () + C.Pass { C.resPairs = n, C.resPeakLogW = w } -> + assertFailure $ + "leaky target not detected; passed n=" ++ show n + ++ " logW=" ++ show w + ] + +noopHyp :: C.Hypothesis () +noopHyp = C.Hypothesis + { C.target = \_ -> pure () + , C.prepare = pure () + , C.sampleA = pure () + , C.sampleB = pure () + } + +flatMeterTests :: TestTree +flatMeterTests = testGroup "flat meter" [ + testCase "constant reading exhausts budget exactly" $ do + let c = C.defaultConfig + { C.cfgBudget = 500 + , C.cfgWarmup = 20 + , C.cfgBatch = 1 + } + r <- C.runCT (constMeter 100) c noopHyp + case r of + C.Pass { C.resPairs = n } -> n @?= C.cfgBudget c + C.Reject { C.resPairs = n, C.resPeakLogW = w } -> + assertFailure $ + "flat meter rejected at n=" ++ show n ++ " logW=" ++ show w + + , testCase "Pass count is invariant under cfgBatch" $ do + let mkCfg b = C.defaultConfig + { C.cfgBudget = 100 + , C.cfgWarmup = 10 + , C.cfgBatch = b + } + ns <- mapM (\b -> C.resPairs <$> + C.runCT (constMeter 100) (mkCfg b) noopHyp) + [1, 10, 100, 1000] + ns @?= replicate 4 100 + + , testCase "no clipping under a flat meter" $ do + let c = C.defaultConfig + { C.cfgBudget = 200 + , C.cfgWarmup = 20 + , C.cfgBatch = 1 + } + r <- C.runCT (constMeter 100) c noopHyp + case r of + C.Pass { C.resClipped = nc } -> nc @?= 0 + C.Reject{} -> assertFailure "flat meter unexpectedly rejected" + + -- zero warmup differences floor the clip bound at 1, and a flat + -- wealth process leaves every peak at its calibrated floor: a + -- log e-value of 0, for components and mixture alike. + , testCase "flat meter report: unit bound, floor peaks" $ do + let c = C.defaultConfig + { C.cfgBudget = 200 + , C.cfgWarmup = 20 + , C.cfgBatch = 1 + } + r <- C.runCT (constMeter 100) c noopHyp + C.resBound r @?= 1 + assertBool "mixture peak below floor" + (C.resPeakLogW r >= negate 1e-9) + let !minPeak = min (min (C.resPeakSign r) (C.resPeakMagn r)) + (min (C.resPeakMagn4 r) (C.resPeakMagn16 r)) + assertBool "component peak below floor" + (minPeak >= negate 1e-9) + ] + +calibrationTests :: TestTree +calibrationTests = testGroup "calibration" [ + testCase "zero-duration warmup throws WarmupZeroDuration" $ do + let c = C.defaultConfig { C.cfgWarmup = 5, C.cfgBudget = 10 } + r <- try (C.runCT (constMeter 0) c noopHyp) + :: IO (Either C.CensorError C.Result) + case r of + Left C.WarmupZeroDuration -> pure () + Left other -> assertFailure $ + "expected WarmupZeroDuration, got " ++ show other + Right _ -> assertFailure "expected WarmupZeroDuration" + ] + +-- a meter whose reading scales linearly with the batch: reads +-- @k * perCall@. Lets calibrateBatch resolve a per-call cost, which a +-- flat 'constMeter' (reading independent of @k@) cannot express. +linMeter :: Word64 -> C.Meter +linMeter perCall = C.Meter $ \k act -> + let go 0 = pure () + go i = act >> go (i - 1) + in go k >> pure (fromIntegral k * perCall) + +batchCalibrationTests :: TestTree +batchCalibrationTests = testGroup "batch calibration" [ + testCase "nanosecond-scale target picks a large batch" $ do + -- reading = 64 * batch; the target magnitude (65536) is reached + -- at batch 1024, which refines to itself. + b <- C.calibrateBatch (linMeter 64) noopHyp + b @?= 1024 + + , testCase "heavy target picks batch 1" $ do + -- a single call already exceeds the target magnitude. + b <- C.calibrateBatch (linMeter 100000) noopHyp + b @?= 1 + + , testCase "unresolvable meter picks batch 1" $ do + -- a meter stuck at zero never reaches the target magnitude; + -- calibration gives up at the cap and returns 1, so the + -- subsequent run fails fast in warmup (WarmupZeroDuration). + b <- C.calibrateBatch (linMeter 0) noopHyp + b @?= 1 + ] + +runCTWithTests :: TestTree +runCTWithTests = testGroup "runCTWith / Frame" [ + testCase "one frame per pair on a passing run" $ do + let c = C.defaultConfig + { C.cfgBudget = 300, C.cfgWarmup = 20, C.cfgBatch = 1 } + ref <- newIORef [] + r <- C.runCTWith (constMeter 100) c noopHyp $ \ !fr -> + modifyIORef' ref (fr :) + frs <- fmap reverse (readIORef ref) + length frs @?= C.resPairs r + map C.frPair frs @?= [1 .. C.resPairs r] + + , testCase "one frame per pair on a rejecting run" $ do + (hyp, meter) <- leakHyp + ref <- newIORef (0 :: Int) + r <- C.runCTWith meter leakCfg hyp $ \_ -> + modifyIORef' ref (+ 1) + n <- readIORef ref + case r of + C.Reject{} -> n @?= C.resPairs r + C.Pass{} -> assertFailure "leak fixture did not reject" + + , testCase "runCT agrees with runCTWith on a leak (pinned seed)" $ do + (h1, m1) <- leakHyp + (h2, m2) <- leakHyp + let c = leakCfg { C.cfgSeed = Just 12345 } + r1 <- C.runCT m1 c h1 + r2 <- C.runCTWith m2 c h2 (\_ -> pure ()) + C.resPairs r1 @?= C.resPairs r2 + ] + +attributedTests :: TestTree +attributedTests = testGroup "runCTAttributed" [ + testCase "pass yields no attribution" $ do + let c = C.defaultConfig + { C.cfgBudget = 200, C.cfgWarmup = 20, C.cfgBatch = 1 } + (r, ma) <- C.runCTAttributed (constMeter 100) c noopHyp + case (r, ma) of + (C.Pass{}, Nothing) -> pure () + _ -> assertFailure "expected (Pass, Nothing)" + + , testCase "reject runs controls, and they pass" $ do + (hyp, meter) <- leakHyp + (r, ma) <- C.runCTAttributed meter leakCfg hyp + case (r, ma) of + (C.Reject{}, Just att) + | C.attVerdict att == C.ControlsPass -> pure () + (C.Reject{}, Just other) -> assertFailure $ + "expected ControlsPass, got " ++ show (C.attVerdict other) + _ -> assertFailure "leak fixture did not reject" + ] + +configValidationTests :: TestTree +configValidationTests = testGroup "config validation" [ + testCase "cfgBatch = 0 is rejected" $ + assertInvalidConfig + (C.defaultConfig { C.cfgBatch = 0 }) + + , testCase "cfgBatch < 0 is rejected" $ + assertInvalidConfig + (C.defaultConfig { C.cfgBatch = -1 }) + + , testCase "cfgWarmup = 0 is rejected" $ + assertInvalidConfig + (C.defaultConfig { C.cfgWarmup = 0 }) + + , testCase "cfgWarmup < 0 is rejected" $ + assertInvalidConfig + (C.defaultConfig { C.cfgWarmup = -1 }) + + , testCase "cfgBudget < 0 is rejected" $ + assertInvalidConfig + (C.defaultConfig { C.cfgBudget = -1 }) + ] + where + assertInvalidConfig c = do + r <- try (C.runCT (constMeter 100) c noopHyp) + :: IO (Either C.CensorError C.Result) + case r of + Left (C.InvalidConfig _) -> pure () + Left other -> assertFailure $ + "expected InvalidConfig, got " ++ show other + Right _ -> assertFailure "expected InvalidConfig" + +-- deterministic A/B divergence via a meter that reports state the +-- target wrote during the timed region. No wall-clock noise: every +-- pair lands the same delta into the wealth process and rejection is +-- guaranteed. +leakHyp :: IO (C.Hypothesis Word64, C.Meter) +leakHyp = do + ref <- newIORef (0 :: Word64) + let leakMeter = C.Meter $ \k act -> + let go 0 = pure () + go i = act >> go (i - 1) + in go k >> readIORef ref + hyp = C.Hypothesis + { C.target = \n -> writeIORef ref n + , C.prepare = pure () + , C.sampleA = pure 100 + , C.sampleB = pure 200 + } + pure (hyp, leakMeter) + +leakCfg :: C.Config +leakCfg = C.defaultConfig + { C.cfgAlpha = 1.0e-3 + , C.cfgBudget = 500 + , C.cfgWarmup = 20 + , C.cfgBatch = 1 + } + +deterministicLeakTests :: TestTree +deterministicLeakTests = testGroup "deterministic leak" [ + testCase "deterministic A/B divergence is rejected" $ do + (hyp, meter) <- leakHyp + r <- C.runCT meter leakCfg hyp + case r of + C.Reject{} -> pure () + C.Pass { C.resPairs = n, C.resPeakLogW = w } -> + assertFailure $ + "deterministic divergence not detected; passed n=" + ++ show n ++ " logW=" ++ show w + ] + +-- Margin (interval-null) mode, against the deterministic leak +-- fixture: readings are 100 (class A) vs 200 (class B), so d = -100 +-- every pair, the warmup clip bound is c = 200, and the median +-- pooled reading is 200. A relative margin of 0.75 resolves to an +-- absolute delta = 150 > |mean d|, which the interval null +-- tolerates; 0.25 resolves to 50 < |mean d|, which it rejects. +marginTests :: TestTree +marginTests = testGroup "interval-null margin" [ + testCase "systematic within margin passes where sharp rejects" $ do + (hyp, meter) <- leakHyp + r <- C.runCT meter leakCfg { C.cfgMargin = Just 0.75 } hyp + case r of + C.Pass{} -> do + C.resMargin r @?= Just 150 + -- the sign component still sees d < 0 on every pair; its + -- peak grows even though it no longer gates. This is the + -- margin-mode diagnostic signature of a sub-margin + -- systematic. + assertBool "sign peak should register the systematic" + (C.resPeakSign r > 0) + C.Reject { C.resPairs = n, C.resPeakLogW = w } -> + assertFailure $ + "within-margin systematic rejected at n=" ++ show n + ++ " logW=" ++ show w + , testCase "systematic beyond margin still rejected" $ do + (hyp, meter) <- leakHyp + r <- C.runCT meter leakCfg { C.cfgMargin = Just 0.25 } hyp + case r of + C.Reject{} -> do + C.resMargin r @?= Just 50 + assertBool "Reject but resPValue > alpha" + (C.resPValue r <= C.cfgAlpha leakCfg) + C.Pass { C.resPairs = n } -> + assertFailure $ + "beyond-margin systematic not detected; passed n=" + ++ show n + , testCase "sharp runs report no margin" $ do + (hyp, meter) <- leakHyp + r <- C.runCT meter leakCfg hyp + C.resMargin r @?= Nothing + , testCase "margin-mode result JSON carries the resolved margin" $ do + (hyp, meter) <- leakHyp + r <- C.runCT meter leakCfg { C.cfgMargin = Just 0.75 } hyp + assertBool "resultToJSON should include a margin field" + ("\"margin\":" `isInfixOf` Rep.resultToJSON r) + , testCase "nonpositive margin rejected" $ do + r <- try (C.runCT (constMeter 100) + leakCfg { C.cfgMargin = Just 0 } noopHyp) + :: IO (Either C.CensorError C.Result) + case r of + Left (C.InvalidConfig _) -> pure () + other -> assertFailure $ + "expected InvalidConfig, got " ++ show other + , testCase "margin at or above the clip bound rejected" $ do + -- constMeter 100: d = 0 always, so c = 1 while the median + -- reading is 100; any appreciable relative margin resolves + -- above the clip bound and must be refused, not run. + r <- try (C.runCT (constMeter 100) + leakCfg { C.cfgMargin = Just 0.5 } noopHyp) + :: IO (Either C.CensorError C.Result) + case r of + Left (C.InvalidConfig msg) -> + assertBool "message should name the clip bound" + ("clip bound" `isInfixOf` msg) + other -> assertFailure $ + "expected InvalidConfig, got " ++ show other + , testCase "tiny margin under a flat meter passes" $ do + r <- C.runCT (constMeter 100) + leakCfg { C.cfgMargin = Just 1.0e-3 } noopHyp + case r of + C.Pass{} -> C.resMargin r @?= Just 0.1 + C.Reject{} -> + assertFailure "flat meter rejected under a margin" + ] + +-- resPValue is the mixture evidence recast as an anytime-valid +-- p-value: at or below alpha iff the verdict is Reject. resEffect +-- is an anytime-valid confidence interval for the mean clipped +-- difference: it covers the true mean at the stopping time (0 for +-- CT fixtures, the deterministic delta for the leak fixture). +-- Exclusion of 0 at a rejection stopping time is deliberately NOT +-- asserted: detection is more sample-efficient than estimation, so +-- a fast reject legitimately halts while the interval still +-- straddles zero. +evidenceTests :: TestTree +evidenceTests = testGroup "calibrated evidence" [ + testCase "leak fixture: p <= alpha, effect covers true delta" $ do + (hyp, meter) <- leakHyp + let c = leakCfg { C.cfgSeed = Just 0xE71DE0 } + r <- C.runCT meter c hyp + case r of + C.Reject{} -> do + assertBool "Reject but resPValue > alpha" + (C.resPValue r <= C.cfgAlpha c) + -- the fixture's difference is d = -100, every pair. + let (lo, hi) = C.resEffect r + assertBool "interval misses the true mean -100" + (lo <= -100 && -100 <= hi) + C.Pass{} -> assertFailure "leak fixture failed to reject" + + , testCase "flat fixture: p = 1, effect covers zero" $ do + let c = C.defaultConfig + { C.cfgBudget = 500 + , C.cfgWarmup = 20 + , C.cfgBatch = 1 + } + r <- C.runCT (constMeter 100) c noopHyp + case r of + C.Pass{} -> do + C.resPValue r @?= 1 + let (lo, hi) = C.resEffect r + assertBool "interval misses zero" (lo <= 0 && 0 <= hi) + C.Reject{} -> assertFailure "flat meter unexpectedly rejected" + ] + +-- regression for the off-by-one: a threshold crossing on the final +-- allowed pair must surface as Reject, not Pass. +offByOneTests :: TestTree +offByOneTests = testGroup "budget/decide off-by-one" [ + testCase "rejection observed on the final allowed pair" $ do + -- 1. find the rejection-pair count under a generous budget. + (hyp1, meter1) <- leakHyp + k <- do + r <- C.runCT meter1 leakCfg hyp1 + case r of + C.Reject { C.resPairs = n } -> pure n + C.Pass{} -> assertFailure + "leak fixture failed to reject under generous budget" + >> pure 0 -- unreachable + -- 2. re-run with cfgBudget = k. Without the fix the run would + -- pass at n = k. With the fix the rejection is reported. + (hyp2, meter2) <- leakHyp + let tight = leakCfg { C.cfgBudget = k } + r2 <- C.runCT meter2 tight hyp2 + case r2 of + C.Reject { C.resPairs = n } -> n @?= k + C.Pass { C.resPairs = n, C.resPeakLogW = w } -> + assertFailure $ + "off-by-one regression: tight budget passed at n=" + ++ show n ++ " logW=" ++ show w + ] + +-- An equal-mean shape leak that /only/ the sign component of the +-- hedge can detect. Class A returns 97 with probability 1/4 and 101 +-- with probability 3/4 (so E[ta] = 100), class B returns 100 +-- constantly. Then d = ta - tb has mean 0 (magnitude components +-- can't grow wealth) but P(d > 0) = 3/4 (sign component grows fast). +-- Guards the sign-component wiring per-commit; the equivalent +-- coverage in censor-validate takes an hour. +signOnlyLeakTests :: TestTree +signOnlyLeakTests = testGroup "sign-only leak" [ + testCase "equal-mean shape leak is rejected by the hedge" $ do + ref <- newIORef (0 :: Word64) + ctr <- newIORef (0 :: Int) + let leakMeter = C.Meter $ \k act -> + let go 0 = pure () + go i = act >> go (i - 1) + in go k >> readIORef ref + hyp = C.Hypothesis + { C.target = writeIORef ref + , C.prepare = pure () + , C.sampleA = do + n <- atomicModifyIORef' ctr (\i -> (i + 1, i)) + pure $! if n `mod` 4 == 0 then 97 else 101 + , C.sampleB = pure 100 + } + c = C.defaultConfig + { C.cfgAlpha = 1.0e-3 + , C.cfgBudget = 5000 + , C.cfgWarmup = 100 + , C.cfgBatch = 1 + , C.cfgSeed = Just 0xC0FFEE + } + r <- C.runCT leakMeter c hyp + case r of + -- a shape leak grows the sign component, not the magnitude + -- ones; the per-component peaks should reflect that. + C.Reject{} -> assertBool + "sign component did not dominate the rejection" + (C.resPeakSign r > C.resPeakMagn r) + C.Pass { C.resPairs = n, C.resPeakLogW = w } -> + assertFailure $ + "shape leak not detected; passed n=" ++ show n + ++ " logW=" ++ show w + ] + +-- toAA / toBB collapse a leaky hypothesis into H_0 by construction — +-- either sampleB is replaced by sampleA or vice versa, so both +-- classes measure the same distribution. A hypothesis that Rejects +-- under runCT should Pass under both runAA and runBB. +aaDiagnosticTests :: TestTree +aaDiagnosticTests = testGroup "A/A and B/B diagnostics" [ + testCase "runAA passes a hypothesis that runCT would reject" $ do + (hyp, meter) <- leakHyp + -- Fixed seed to keep the test deterministic; the leak fixture + -- itself is deterministic in outcome regardless of order. + let c = leakCfg { C.cfgSeed = Just 0xABAD1DEA } + r <- C.runAA meter c hyp + case r of + C.Pass{} -> pure () + C.Reject { C.resPairs = n, C.resPeakLogW = w } -> + assertFailure $ + "A/A diagnostic falsely rejected at n=" ++ show n + ++ " logW=" ++ show w + + , testCase "runBB passes a hypothesis that runCT would reject" $ do + (hyp, meter) <- leakHyp + let c = leakCfg { C.cfgSeed = Just 0xABAD1DEA } + r <- C.runBB meter c hyp + case r of + C.Pass{} -> pure () + C.Reject { C.resPairs = n, C.resPeakLogW = w } -> + assertFailure $ + "B/B diagnostic falsely rejected at n=" ++ show n + ++ " logW=" ++ show w + ] + +-- attribute composes runAA and runBB: the leak fixture has +-- class-constant samplers, so both diagnostics are flat and the +-- rejection attributes to the target. +attributeTests :: TestTree +attributeTests = testGroup "attribute" [ + testCase "symmetric harness: neither control convicts" $ do + (hyp, meter) <- leakHyp + let c = leakCfg { C.cfgSeed = Just 0xABAD1DEA } + att <- C.attribute meter c hyp + case C.attVerdict att of + C.ControlsPass -> pure () + other -> assertFailure $ + "expected ControlsPass, got " ++ show other + + , testCase "controls carry both full runs, not just a label" $ do + (hyp, meter) <- leakHyp + let c = leakCfg { C.cfgSeed = Just 0xABAD1DEA } + att <- C.attribute meter c hyp + -- both control runs must be present and non-degenerate, so a + -- reader can weigh how much evidence backs ControlsPass. + assertBool "A/A control consumed no pairs" + (C.resPairs (C.attAA att) > 0) + assertBool "B/B control consumed no pairs" + (C.resPairs (C.attBB att) > 0) + ] + +-- fixVsRandom pins the first secret draw as class A's input and +-- feeds fresh draws to class B. fixture: the target writes its +-- input to an IORef and the meter reads it back, so a sampler whose +-- first draw differs from all later draws leaks deterministically, +-- while the A/A collapse of the same hypothesis is null by +-- construction. +-- The shared per-pair public context must be exactly that: one +-- draw, visible identically to both classes, refreshed every pair. +-- The context sampler here is a counter, and the completion returns +-- the context itself, so each sampler's return value *is* what it +-- saw. +fixVsRandomCtxTests :: TestTree +fixVsRandomCtxTests = testGroup "fixVsRandomCtx" [ + testCase "one context per pair, shared by both classes" $ do + ctr <- newIORef (0 :: Int) + seen <- newIORef ([] :: [(Char, Int)]) + base <- C.fixVsRandomCtx + (\_ -> pure ()) + (pure ()) + pure + (atomicModifyIORef' ctr (\n -> (n + 1, n))) + (\c _ -> pure c) + let note t act = do + c <- act + modifyIORef' seen ((t, c) :) + pure c + hyp = base + { C.sampleA = note 'A' (C.sampleA base) + , C.sampleB = note 'B' (C.sampleB base) + } + cfg = C.defaultConfig + { C.cfgWarmup = 5, C.cfgBudget = 5, C.cfgBatch = 1 } + _ <- C.runCT (constMeter 100) cfg hyp + xs <- fmap reverse (readIORef seen) + let pairs = chunk2 xs + assertBool "expected 10 pairs of samples" (length pairs == 10) + mapM_ checkPair pairs + -- Contexts advance by exactly one per pair: each pair drew a + -- fresh one, and drew it only once. They start at 1, not 0: + -- the constructor's seeding draw takes 0 and 'prepare' + -- overwrites it before the first pair, so that draw is never + -- observed by either class. + let ctxs = map (snd . fst) pairs + ctxs @?= take 10 [1 ..] + + -- as in the fixVsRandom group: class A completes around the + -- re-materialised copy, class B around the raw draw, one copy + -- per sample in each class. + , testCase "both classes re-materialise the pinned secret" $ do + ctr <- newIORef (0 :: Int) + hyp <- C.fixVsRandomCtx + (\_ -> pure ()) + (pure (100 :: Word64)) + (\s -> do modifyIORef' ctr (+ 1); pure (s + 1)) + (pure ()) + (\_ s -> pure s) + a <- C.sampleA hyp + b <- C.sampleB hyp + n <- readIORef ctr + a @?= 101 + b @?= 100 + n @?= 2 + ] + where + chunk2 (a : b : rest) = (a, b) : chunk2 rest + chunk2 _ = [] + checkPair ((t1, c1), (t2, c2)) = do + assertBool ("both halves of a pair ran the same class: " ++ [t1, t2]) + (t1 /= t2) + assertEqual "classes saw different contexts in one pair" c1 c2 + +fixVsRandomTests :: TestTree +fixVsRandomTests = testGroup "fixVsRandom" [ + testCase "pinned-vs-random divergence is rejected" $ do + (hyp, meter) <- pinnedHyp + r <- C.runCT meter leakCfg hyp + case r of + C.Reject{} -> pure () + C.Pass { C.resPairs = n } -> assertFailure $ + "pinned divergence not detected; passed n=" ++ show n + + , testCase "A/A collapse of the pinned hypothesis passes" $ do + (hyp, meter) <- pinnedHyp + let c = leakCfg { C.cfgSeed = Just 0xABAD1DEA } + r <- C.runAA meter c hyp + case r of + C.Pass{} -> pure () + C.Reject { C.resPairs = n } -> assertFailure $ + "A/A collapse falsely rejected at n=" ++ show n + + , testCase "constant secret sampler passes at budget" $ do + ref <- newIORef (0 :: Word64) + let meter = C.Meter $ \k act -> + let go 0 = pure () + go i = act >> go (i - 1) + in go k >> readIORef ref + hyp <- C.fixVsRandom (writeIORef ref) (pure (100 :: Word64)) + pure pure + r <- C.runCT meter leakCfg hyp + case r of + C.Pass { C.resPairs = n } -> n @?= C.cfgBudget leakCfg + C.Reject { C.resPairs = n } -> assertFailure $ + "constant sampler rejected at n=" ++ show n + + -- the (+ 1) re-materialiser marks provenance: class A must + -- complete around the copy (fix + 1), class B around the raw + -- draw, and the copy must run once per sample in each class. + , testCase "both classes re-materialise the pinned secret" $ do + ctr <- newIORef (0 :: Int) + hyp <- C.fixVsRandom + (\_ -> pure ()) + (pure (100 :: Word64)) + (\s -> do modifyIORef' ctr (+ 1); pure (s + 1)) + pure + a1 <- C.sampleA hyp + a2 <- C.sampleA hyp + b <- C.sampleB hyp + n <- readIORef ctr + a1 @?= 101 + a2 @?= 101 + b @?= 100 + n @?= 3 + ] + where + -- first draw 100 (the pinned secret), all later draws 200. + pinnedHyp = do + ref <- newIORef (0 :: Word64) + ctr <- newIORef (0 :: Int) + let meter = C.Meter $ \k act -> + let go 0 = pure () + go i = act >> go (i - 1) + in go k >> readIORef ref + sec = do + n <- atomicModifyIORef' ctr (\i -> (i + 1, i)) + pure $! if n == 0 then 100 else 200 :: Word64 + hyp <- C.fixVsRandom (writeIORef ref) sec pure pure + pure (hyp, meter) + +rngTests :: TestTree +rngTests = testGroup "Censor.Rng" [ + testCase "equal seeds give equal streams" $ do + g1 <- C.mkRng 0xFEEDFACE + g2 <- C.mkRng 0xFEEDFACE + ws1 <- mapM (\_ -> C.nextWord g1) [1 .. 16 :: Int] + ws2 <- mapM (\_ -> C.nextWord g2) [1 .. 16 :: Int] + ws1 @?= ws2 + + , testCase "distinct seeds give distinct streams" $ do + g1 <- C.mkRng 1 + g2 <- C.mkRng 2 + w1 <- C.nextWord g1 + w2 <- C.nextWord g2 + assertBool "streams coincide" (w1 /= w2) + + , testCase "reseed replays a fresh generator's stream in place" $ do + g <- C.mkRng 0xAAAA + _ <- C.nextWord g + C.reseed g 0xFEEDFACE + h <- C.mkRng 0xFEEDFACE + ws1 <- mapM (\_ -> C.nextWord g) [1 .. 8 :: Int] + ws2 <- mapM (\_ -> C.nextWord h) [1 .. 8 :: Int] + ws1 @?= ws2 + ] + +randomBytesTests :: TestTree +randomBytesTests = testGroup "Censor.Rng.randomBytes" [ + testCase "lengths, including ragged, empty, and negative" $ do + g <- C.mkRng 0xABCD + mapM_ + (\n -> do + bs <- C.randomBytes g n + BS.length bs @?= max 0 n) + [-1, 0, 1, 7, 8, 13, 32] + + , testCase "deterministic under a fixed seed" $ do + g1 <- C.mkRng 0xABCD + g2 <- C.mkRng 0xABCD + b1 <- C.randomBytes g1 33 + b2 <- C.randomBytes g2 33 + b1 @?= b2 + assertBool "expected nonzero bytes" (BS.any (/= 0) b1) + + , testCase "agrees with fillRandom on the same stream" $ do + let n = 13 + g1 <- C.mkRng 0xABCD + bs <- C.randomBytes g1 n + g2 <- C.mkRng 0xABCD + ws <- allocaBytes n $ \p -> do + F.fillRandom g2 p n + peekArray n p + BS.unpack bs @?= ws + + , testCase "a shorter draw is a prefix of a longer one" $ do + g1 <- C.mkRng 0xABCD + g2 <- C.mkRng 0xABCD + short <- C.randomBytes g1 13 + long <- C.randomBytes g2 32 + short @?= BS.take 13 long + ] + +fillRandomTests :: TestTree +fillRandomTests = testGroup "Censor.FFI.fillRandom" [ + testCase "deterministic under a fixed seed, handles ragged n" $ do + let n = 13 -- deliberately not a multiple of 8 + bs1 <- fillWith 0xABCD n + bs2 <- fillWith 0xABCD n + bs1 @?= bs2 + assertBool "expected nonzero bytes" (any (/= 0) bs1) + ] + where + fillWith :: Word64 -> Int -> IO [Word8] + fillWith seed n = do + g <- C.mkRng seed + allocaBytes n $ \p -> do + F.fillRandom g p n + peekArray n p + +-- a tripwire calibration tier: run runCT a few hundred times under +-- a true-H_0 synthetic meter and assert the empirical rejection rate +-- stays well below a generous bound. Catches gross wiring regressions +-- (rejection rate exploding to 0.5+) but does *not* validate the +-- alpha guarantee in any rigorous sense — that's what censor-validate +-- is for. N is deliberately small so the suite stays fast. +data Class = ClassA | ClassB + +mkSynthMeter + :: IO Word64 -> IO Word64 -> IO (C.Meter, C.Hypothesis Class) +mkSynthMeter nextA nextB = do + ref <- newIORef ClassA + let meter = C.Meter $ \k act -> do + let go 0 = pure () + go i = act >> go (i - 1) + go k + c <- readIORef ref + case c of + ClassA -> nextA + ClassB -> nextB + hyp = C.Hypothesis + { C.target = writeIORef ref + , C.prepare = pure () + , C.sampleA = pure ClassA + , C.sampleB = pure ClassB + } + pure (meter, hyp) + +uniformInRange :: C.Rng -> Word64 -> Word64 -> IO Word64 +uniformInRange g lo hi = do + w <- C.nextWord g + pure $! lo + (w `mod` (hi - lo + 1)) + +countRejects :: Int -> IO C.Result -> IO Int +countRejects = go 0 + where + go !acc 0 _ = pure acc + go !acc !n act = do + r <- act + let !inc = case r of + C.Reject{} -> 1 + C.Pass{} -> 0 + go (acc + inc) (n - 1) act + +smokeCalibrationTests :: TestTree +smokeCalibrationTests = testGroup "smoke calibration" [ + -- an H_0 fixture, alpha = 0.1, N = 200, loose bound: a true + -- 0.1-FPR test would produce ~20 +/- ~10 rejections; a broken + -- driver flips this to 100+ rejections. The 0.30 bound is a + -- regression tripwire, not a real calibration check. + testCase "sym-uniform H_0 stays under 30%" $ + assertCalibrated symUniformTrial + + -- the mirror-image tripwire: a variance-only alternative must + -- be detected, not tolerated. This is the channel that a null + -- of "d is symmetric" cannot see and exchangeability can. + , testCase "asym-uniform-equal-mean H_1 detected above 90%" $ + assertDetected asymUniformTrial + ] + where + cfg = C.defaultConfig + { C.cfgAlpha = 0.1 + , C.cfgBudget = 1000 + , C.cfgWarmup = 50 + , C.cfgBatch = 1 + } + symUniformTrial = do + ra <- C.mkRng 0x5EED01 + rb <- C.mkRng 0x5EED02 + (m, h) <- mkSynthMeter (uniformInRange ra 0 200) + (uniformInRange rb 0 200) + C.runCT m cfg h + -- equal means, different variances. Under exchangeability this + -- is a genuine alternative: d stays symmetric (so sign and + -- magnitude see nothing), but the class CDFs differ, which the + -- indicator components detect. + asymUniformTrial = do + ra <- C.mkRng 0x5EED03 + rb <- C.mkRng 0x5EED04 + (m, h) <- mkSynthMeter (uniformInRange ra 0 200) + (uniformInRange rb 50 150) + C.runCT m cfg h + assertCalibrated trial = do + let n = 200 + rejects <- countRejects n trial + let rate = fromIntegral rejects / (fromIntegral n :: Double) + assertBool ("smoke calibration regressed: " ++ show rejects + ++ "/" ++ show n ++ " rejections (rate " + ++ show rate ++ ")") + (rate <= 0.30) + assertDetected trial = do + let n = 200 + rejects <- countRejects n trial + let rate = fromIntegral rejects / (fromIntegral n :: Double) + assertBool ("variance-only detection regressed: " ++ show rejects + ++ "/" ++ show n ++ " rejections (rate " + ++ show rate ++ ")") + (rate >= 0.90) + +clipCountTests :: TestTree +clipCountTests = testGroup "clip counts" [ + testCase "clip count rises when |d| exceeds bound" $ do + r <- runClipping 1000000 + -- every warmup |d| is exactly 100, so the bound is pinned at + -- 2 * p99(|d|) = 200. + C.resBound r @?= 200 + assertBool ("expected nonzero clip count, got " + ++ show (C.resClipped r)) + (C.resClipped r > 0) + + , testCase "|d| past every bound is counted at every bound" $ do + -- main-loop |d| ~= 999900, past c = 200, 4c = 800, 16c = 3200 + r <- runClipping 1000000 + C.resClipped4 r @?= C.resClipped r + C.resClipped16 r @?= C.resClipped r + + , testCase "|d| between 4c and 16c leaves the widest count at 0" $ do + -- main-loop |d| = 900: past c and 4c, under 16c. The tight + -- components are starved while the effect interval's own + -- input is untouched -- the two readings the counts separate. + r <- runClipping 1000 + assertBool ("expected clipping at c, got " + ++ show (C.resClipped r)) + (C.resClipped r > 0) + assertBool ("expected clipping at 4c, got " + ++ show (C.resClipped4 r)) + (C.resClipped4 r > 0) + C.resClipped16 r @?= 0 + + , testCase "the counts nest" $ do + r <- runClipping 1000 + assertBool "clipped4 exceeded clipped" + (C.resClipped4 r <= C.resClipped r) + assertBool "clipped16 exceeded clipped4" + (C.resClipped16 r <= C.resClipped4 r) + + , testCase "an unclipped run reports zero at every bound" $ do + r <- runFlatPass + C.resClipped r @?= 0 + C.resClipped4 r @?= 0 + C.resClipped16 r @?= 0 + ] + +-- Clipping fixture: the target writes its input to an IORef and the +-- meter reads it back, so a sample value /is/ the reading. Class A +-- always writes 100; class B writes 200 through warmup (every +-- |d| = 100, pinning the bound at 2 * p99(|d|) = 200) and @big@ +-- thereafter. Choosing @big@ places the main-loop |d| relative to +-- c = 200, 4c = 800, and 16c = 3200. +runClipping :: Word64 -> IO C.Result +runClipping big = do + ref <- newIORef (0 :: Word64) + ctr <- newIORef (0 :: Int) + let leakMeter = C.Meter $ \k act -> + let go 0 = pure () + go i = act >> go (i - 1) + in go k >> readIORef ref + warmupPairs = 20 + hyp = C.Hypothesis + { C.target = writeIORef ref + , C.prepare = pure () + , C.sampleA = pure 100 + , C.sampleB = do + n <- atomicModifyIORef' ctr (\i -> (i + 1, i)) + pure $! if n < warmupPairs + then 200 + else big + } + c = C.defaultConfig + { C.cfgAlpha = 1.0e-3 + , C.cfgBudget = 50 + , C.cfgWarmup = warmupPairs + , C.cfgBatch = 1 + } + C.runCT leakMeter c hyp + +-- deterministic constant-mean bulk shift, seeded for reproducibility. +-- Reused as a "reliably-rejects" fixture across diagnose / rendering +-- tests below. +runLeak :: IO C.Result +runLeak = do + (hyp, meter) <- leakHyp + let c = leakCfg { C.cfgSeed = Just 0xB0BFACE } + C.runCT meter c hyp + +-- deterministic Pass fixture with a well-behaved effect interval. +runFlatPass :: IO C.Result +runFlatPass = do + let c = C.defaultConfig + { C.cfgBudget = 500, C.cfgWarmup = 20, C.cfgBatch = 1 } + C.runCT (constMeter 100) c noopHyp + +isRejDriver :: C.Advisory -> Bool +isRejDriver (C.RejectionDriver _) = True +isRejDriver _ = False + +isHighClipRate :: C.Advisory -> Bool +isHighClipRate (C.HighClipRate _) = True +isHighClipRate _ = False + +diagnoseTests :: TestTree +diagnoseTests = testGroup "diagnose" [ + testCase "equal-mean shape leak -> a shape driver, not bulk" $ do + ref <- newIORef (0 :: Word64) + ctr <- newIORef (0 :: Int) + let leakMeter = C.Meter $ \k act -> + let go 0 = pure () + go i = act >> go (i - 1) + in go k >> readIORef ref + hyp = C.Hypothesis + { C.target = writeIORef ref + , C.prepare = pure () + , C.sampleA = do + n <- atomicModifyIORef' ctr (\i -> (i + 1, i)) + pure $! if n `mod` 4 == 0 then 97 else 101 + , C.sampleB = pure 100 + } + c = C.defaultConfig + { C.cfgAlpha = 1.0e-3 + , C.cfgBudget = 5000 + , C.cfgWarmup = 100 + , C.cfgBatch = 1 + , C.cfgSeed = Just 0xC0FFEE + } + r <- C.runCT leakMeter c hyp + case r of + C.Reject{} -> do + let advs = C.diagnose r + -- class A averages 100, as class B always does, so no + -- mean shift exists for the magnitude channel to find. + -- The leak lives in the shape, which both the sign and + -- the CDF-indicator channels can see; which of the two + -- dominates depends on where the pooled cut points + -- land, so accept either. + shapeDriven = C.RejectionDriver C.ShapeLeak `elem` advs + || C.RejectionDriver C.CdfShift `elem` advs + assertBool ("expected a shape driver in " ++ show advs) + shapeDriven + assertBool "sign component saw no evidence at all" + (C.resPeakSign r > 0) + C.Pass{} -> assertFailure "shape leak fixture did not reject" + + , testCase "bulk leak -> some RejectionDriver" $ do + r <- runLeak + case r of + C.Reject{} -> + let advs = C.diagnose r + in assertBool + ("expected some RejectionDriver in " ++ show advs) + (any isRejDriver advs) + C.Pass{} -> assertFailure "bulk leak did not reject" + + , testCase "flat Pass -> no RejectionDriver" $ do + r <- runFlatPass + case r of + C.Pass{} -> do + let advs = C.diagnose r + assertBool ("unexpected RejectionDriver on Pass: " ++ show advs) + (not (any isRejDriver advs)) + C.Reject{} -> assertFailure "flat meter unexpectedly rejected" + + , testCase "heavy clipping -> HighClipRate advisory" $ do + r <- runClipping 1000000 + let advs = C.diagnose r + assertBool ("expected HighClipRate in " ++ show advs) + (any isHighClipRate advs) + + , testCase "HighClipRate carries the rate at all three bounds" $ do + r <- runClipping 1000000 + case [ cr | C.HighClipRate cr <- C.diagnose r ] of + [] -> assertFailure "no HighClipRate advisory" + (cr : _) -> do + assertBool ("expected a positive tight rate: " ++ show cr) + (C.clipTight cr > 0.05) + -- this fixture clips past 16c, so every rate is equal + C.clipWide cr @?= C.clipTight cr + C.clipWidest cr @?= C.clipTight cr + + , testCase "HighClipRate separates a starved component from a \ + \truncated interval" $ do + r <- runClipping 1000 + case [ cr | C.HighClipRate cr <- C.diagnose r ] of + [] -> assertFailure "no HighClipRate advisory" + (cr : _) -> do + assertBool ("expected a positive tight rate: " ++ show cr) + (C.clipTight cr > 0.05) + -- the tight component is starved, but resEffect's own + -- input never hit its bound + C.clipWidest cr @?= 0 + ] + +renderingTests :: TestTree +renderingTests = testGroup "summary / resultToJSON" [ + testCase "summary on Pass starts with PASS" $ do + r <- runFlatPass + let s = R.summary r + assertBool ("expected PASS prefix, got: " ++ s) + ("PASS" `isPrefixOf` s) + + , testCase "summary on Reject starts with REJECT and names driver" $ do + r <- runLeak + let s = R.summary r + assertBool ("expected REJECT prefix, got: " ++ s) + ("REJECT" `isPrefixOf` s) + assertBool ("expected driver= in: " ++ s) + ("driver=" `isInfixOf` s) + + , testCase "resultToJSON on Pass exposes expected keys" $ do + r <- runFlatPass + let j = Rep.resultToJSON r + mapM_ (\k -> assertBool ("expected " ++ k ++ " in " ++ j) + (k `isInfixOf` j)) + [ "\"verdict\":\"PASS\"" + , "\"pairs\":" + , "\"peakLogW\":" + , "\"pvalue\":" + , "\"effect\":" + , "\"clipped\":" + , "\"clipped4\":" + , "\"clipped16\":" + , "\"bound\":" + , "\"orderSeed\":" + , "\"cdf\":" + , "\"peaks\":" + , "\"sign\":" + , "\"magn\":" + , "\"magn4\":" + , "\"magn16\":" + , "\"advisories\":" + ] + + , testCase "resultToJSON on Reject reports the driver in advisories" $ do + r <- runLeak + let j = Rep.resultToJSON r + assertBool ("expected verdict REJECT in " ++ j) + ("\"verdict\":\"REJECT\"" `isInfixOf` j) + assertBool ("expected RejectionDriver in " ++ j) + ("RejectionDriver" `isInfixOf` j) + + , testCase "a HighClipRate advisory serialises all three rates" $ do + r <- runClipping 1000000 + let j = Rep.resultToJSON r + mapM_ (\k -> assertBool ("expected " ++ k ++ " in " ++ j) + (k `isInfixOf` j)) + [ "\"clipFraction\":", "\"clipFraction4\":", "\"clipFraction16\":" ] + + , testCase "clipText stays terse when only the tight bound clipped" $ do + -- main-loop |d| = 400: past c = 200, under 4c = 800 + r <- runClipping 500 + let t = R.clipText r + assertBool ("expected a clipped= field, got: " ++ t) + ("clipped=" `isPrefixOf` t) + assertBool ("expected no wider-bound annotation, got: " ++ t) + (not ("16c" `isInfixOf` t)) + + , testCase "clipText names the wider bounds once they clip" $ do + r <- runClipping 1000000 + let t = R.clipText r + assertBool ("expected a 4c annotation, got: " ++ t) + ("4c" `isInfixOf` t) + assertBool ("expected a 16c annotation, got: " ++ t) + ("16c" `isInfixOf` t) + ] + +calibReportTests :: TestTree +calibReportTests = testGroup "calibrateBatchReport" [ + testCase "resolves a nanosecond target and records probes" $ do + let m = linMeter 64 + rep <- C.calibrateBatchReport m noopHyp + -- same batch as calibrateBatch's convenience wrapper. + b <- C.calibrateBatch m noopHyp + C.crBatch rep @?= b + C.crBatch rep @?= 1024 + C.crCapHit rep @?= False + -- probes grow geometrically (x4) from 1 until the reading + -- reaches calibTarget (65536); at 64 per call that lands + -- exactly at batch 1024. + map fst (C.crProbes rep) @?= [1, 4, 16, 64, 256, 1024] + + , testCase "records the noise floor at the selected batch" $ do + rep <- C.calibrateBatchReport (linMeter 64) noopHyp + -- linMeter is deterministic (reading = batch * 64), so the + -- median at the selected batch 1024 is exactly the calibration + -- target and the IQR is zero. + C.crNoise rep @?= Just (C.Noise 65536 0) + + , testCase "unresolvable meter -> capHit True, batch 1, no noise" $ do + rep <- C.calibrateBatchReport (linMeter 0) noopHyp + C.crBatch rep @?= 1 + C.crCapHit rep @?= True + C.crNoise rep @?= Nothing + + -- the driver runs 'prepare' before every measured pair, so a + -- sampler may depend on it. Calibrating without it would probe + -- uninitialised state. + , testCase "runs the prologue before drawing its probe sample" $ do + ref <- newIORef (0 :: Int) + seen <- newIORef (0 :: Int) + let hyp = C.Hypothesis + { C.target = \_ -> pure () + , C.prepare = modifyIORef' ref (+ 1) + , C.sampleA = readIORef ref >>= writeIORef seen + , C.sampleB = pure () + } + _ <- C.calibrateBatchReport (linMeter 64) hyp + n <- readIORef seen + assertBool "sampleA ran before any prepare" (n > 0) + + , testCase "consumes exactly one prologue and one class-A draw" $ do + preps <- newIORef (0 :: Int) + draws <- newIORef (0 :: Int) + let hyp = C.Hypothesis + { C.target = \_ -> pure () + , C.prepare = modifyIORef' preps (+ 1) + , C.sampleA = modifyIORef' draws (+ 1) + , C.sampleB = pure () + } + -- six probes, but the sample is drawn once and reused. + _ <- C.calibrateBatchReport (linMeter 64) hyp + readIORef preps >>= (@?= 1) + readIORef draws >>= (@?= 1) + ] + +baselineTests :: TestTree +baselineTests = testGroup "baselineReading" [ + testCase "reads the target cost at the configured batch" $ do + -- linMeter is deterministic (reading = batch * 64), so at + -- batch 3 every measurement reads 192 and the IQR is zero. + let c = testConfig { C.cfgBatch = 3 } + n <- C.baselineReading (linMeter 64) c noopHyp + n @?= C.Noise 192 0 + + -- unlike the calibration probe, which draws one class-A sample + -- and remeasures it, the baseline probe must draw fresh -- a + -- shared pure-target thunk would make later measurements no-ops. + , testCase "runs the prologue and draws fresh per measurement" $ do + preps <- newIORef (0 :: Int) + draws <- newIORef (0 :: Int) + let hyp = C.Hypothesis + { C.target = \_ -> pure () + , C.prepare = modifyIORef' preps (+ 1) + , C.sampleA = modifyIORef' draws (+ 1) + , C.sampleB = pure () + } + _ <- C.baselineReading (linMeter 64) testConfig hyp + np <- readIORef preps + nd <- readIORef draws + nd @?= np + assertBool "expected more than one draw" (nd > 1) + ] + +envTests :: TestTree +envTests = testGroup "captureEnv" [ + testCase "captures platform identity" $ do + e <- E.captureEnv + E.envOs e @?= Info.os + E.envArch e @?= Info.arch + assertBool "cores >= 1" (E.envCores e >= 1) + assertBool "kernel present" (E.envKernel e /= Nothing) + assertBool "time present" (E.envTime e /= Nothing) + + , testCase "load averages are nonnegative when present" $ do + e <- E.captureEnv + case E.envLoad e of + Nothing -> pure () + Just (l1, l5, l15) -> + assertBool "loads >= 0" (l1 >= 0 && l5 >= 0 && l15 >= 0) + ] + +reportJSONTests :: TestTree +reportJSONTests = testGroup "reportJSON" [ + testCase "surfaces env and per-case noise" $ do + r <- C.runCT (constMeter 100) testConfig noopHyp + env <- E.captureEnv + let hdr = Rep.ReportHeader + { Rep.rhMeter = "wall" + , Rep.rhConfig = testConfig + , Rep.rhSeed = Nothing + , Rep.rhTarget = Just "test" + , Rep.rhNote = Nothing + , Rep.rhEnv = Just env + , Rep.rhPerCaseBatch = False + } + cr = Rep.CaseReport + { Rep.crName = "case" + , Rep.crResult = r + , Rep.crAttribution = Nothing + , Rep.crBatch = Just 3 + , Rep.crNoise = Just (C.Noise 100 5) + , Rep.crBaseline = Just (C.Noise 41000 12) + , Rep.crTrace = Nothing + } + j = Rep.reportJSON hdr [cr] + assertBool ("expected env block in " ++ j) + ("\"env\":{\"os\":" `isInfixOf` j) + assertBool ("expected cores in " ++ j) + ("\"cores\":" `isInfixOf` j) + assertBool ("expected noise in " ++ j) + ("\"noise\":{\"med\":100,\"iqr\":5}" `isInfixOf` j) + assertBool ("expected baseline in " ++ j) + ("\"baseline\":{\"med\":41000,\"iqr\":12}" `isInfixOf` j) + + , testCase "omits env and noise when absent" $ do + r <- C.runCT (constMeter 100) testConfig noopHyp + let hdr = Rep.ReportHeader + { Rep.rhMeter = "wall" + , Rep.rhConfig = testConfig + , Rep.rhSeed = Nothing + , Rep.rhTarget = Nothing + , Rep.rhNote = Nothing + , Rep.rhEnv = Nothing + , Rep.rhPerCaseBatch = False + } + cr = Rep.CaseReport "case" r Nothing Nothing Nothing Nothing + Nothing + j = Rep.reportJSON hdr [cr] + assertBool ("unexpected env block in " ++ j) + (not ("\"env\":" `isInfixOf` j)) + assertBool ("unexpected noise in " ++ j) + (not ("\"noise\":" `isInfixOf` j)) + assertBool ("unexpected baseline in " ++ j) + (not ("\"baseline\":" `isInfixOf` j)) + ] + +-- manifest parsing ----------------------------------------------------------- + +manifestTests :: TestTree +manifestTests = testGroup "manifest" [ + testCase "directives, cases, comments, and inheritance" $ do + let src = unlines + [ "# a battery" + , "meter cycles" + , "alpha 1e-6" + , "budget 20000" + , "warmup 500 # trailing comment" + , "target-prefix censor_target_" + , "workspace 128" + , "" + , "case mul secret=0:32" + , "case sign workspace=96 secret=0:32 public=32:32" + ] + case M.parseManifest src of + Left err -> assertFailure ("unexpected parse error: " ++ err) + Right mf -> do + let d = M.mfDefaults mf + M.dfMeter d @?= Just "cycles" + M.dfBudget d @?= Just 20000 + M.dfWarmup d @?= Just 500 + case M.mfCases mf of + [a, b] -> do + -- order preserved, prefix applied, workspace inherited + M.mcName a @?= "mul" + M.mcTarget a @?= "censor_target_mul" + M.mcWorkspace a @?= 128 + M.mcSecret a @?= [M.Range 0 32] + M.mcPublic a @?= [] + -- per-case workspace overrides the run-wide default + M.mcName b @?= "sign" + M.mcWorkspace b @?= 96 + M.mcPublic b @?= [M.Range 32 32] + cs -> assertFailure ("expected 2 cases, got " ++ show (length cs)) + + , testCase "replicates and explicit target override the defaults" $ do + let src = unlines + [ "workspace 64" + , "case k secret=0:8 replicates=3 target=raw_sym batch=auto" + ] + case M.parseManifest src of + Left err -> assertFailure ("unexpected parse error: " ++ err) + Right mf -> case M.mfCases mf of + [c] -> do + M.mcReplicates c @?= 3 + M.mcTarget c @?= "raw_sym" + M.mcBatch c @?= Just M.BatchAuto + cs -> assertFailure ("expected 1 case, got " ++ show (length cs)) + + -- Every rejection below is a manifest that would otherwise run + -- and produce a confidently wrong report. + , testCase "a case with no secret range is rejected" $ + assertLeft "no fix-vs-random axis without a secret" + (M.parseManifest "workspace 32\ncase k\n") + + , testCase "a case with no workspace is rejected" $ + assertLeft "workspace must be set somewhere" + (M.parseManifest "case k secret=0:8\n") + + , testCase "a range overflowing the workspace is rejected" $ + assertLeft "range past the end of the workspace" + (M.parseManifest "workspace 16\ncase k secret=0:32\n") + + , testCase "an empty manifest is rejected" $ + assertLeft "no cases declared" + (M.parseManifest "# nothing here\nworkspace 32\n") + + , testCase "context ranges parse and stay distinct from public" $ do + let src = unlines + [ "workspace 128" + , "case ecdh secret=0:32 context=32:64 public=96:16" + ] + case M.parseManifest src of + Left err -> assertFailure ("unexpected parse error: " ++ err) + Right mf -> case M.mfCases mf of + [c] -> do + M.mcSecret c @?= [M.Range 0 32] + M.mcContext c @?= [M.Range 32 64] + M.mcPublic c @?= [M.Range 96 16] + cs -> assertFailure ("expected 1 case, got " ++ show (length cs)) + + -- A byte belongs to exactly one role. Whichever overlay landed + -- last would silently win, so an overlap is always a mistake. + , testCase "a context range overlapping a secret is rejected" $ + assertLeft "context cannot overlap a secret range" + (M.parseManifest "workspace 64\ncase k secret=0:32 context=16:8\n") + + , testCase "a context range overlapping a public is rejected" $ + assertLeft "context cannot overlap a public range" + (M.parseManifest + "workspace 64\ncase k secret=0:16 public=16:16 context=16:16\n") + + , testCase "a public range overlapping a secret is rejected" $ + assertLeft "public cannot overlap a secret range" + (M.parseManifest "workspace 64\ncase k secret=0:32 public=24:8\n") + + -- label is presentation only; the runner seeds each case from + -- mcId, so relabelling must not change the experiment. + , testCase "label sets the display name but not the identity" $ + case M.parseManifest + "workspace 32\ncase inv secret=0:8 label=fe_inv\n" of + Left err -> assertFailure ("unexpected parse error: " ++ err) + Right mf -> case M.mfCases mf of + [c] -> do + M.mcId c @?= "inv" + M.mcName c @?= "fe_inv" + cs -> assertFailure ("expected 1 case, got " ++ show (length cs)) + + , testCase "checkLayout accepts adjacent, non-overlapping roles" $ + M.checkLayout 64 [M.Range 0 16] [M.Range 16 16] [M.Range 32 16] + @?= Nothing + + , testCase "checkLayout names the role that overflows" $ + case M.checkLayout 16 [] [] [M.Range 8 16] of + Nothing -> assertFailure "expected an overflow rejection" + Just msg -> assertBool ("role not named in " ++ show msg) + ("context" `isInfixOf` msg) + + , testCase "family-alpha parses on and off" $ do + let parse v = fmap (M.dfFamilyAlpha . M.mfDefaults) + (M.parseManifest + ("workspace 32\nfamily-alpha " ++ v ++ "\ncase k secret=0:8\n")) + parse "on" @?= Right (Just True) + parse "off" @?= Right (Just False) + + , testCase "a non-boolean family-alpha is rejected" $ + assertLeft "family-alpha takes on or off" + (M.parseManifest + "workspace 32\nfamily-alpha 0.5\ncase k secret=0:8\n") + + , testCase "unknown keys are rejected, with the line number" $ do + case M.parseManifest "workspace 32\ncase k secret=0:8 wat=1\n" of + Right _ -> assertFailure "expected a parse failure" + Left err -> do + assertBool ("no line number in " ++ show err) + ("line 2" `isInfixOf` err) + assertBool ("key not named in " ++ show err) + ("wat" `isInfixOf` err) + ] + where + assertLeft what r = case r of + Left _ -> pure () + Right _ -> assertFailure ("expected rejection: " ++ what) diff --git a/validate/Main.hs b/validate/Main.hs new file mode 100644 --- /dev/null +++ b/validate/Main.hs @@ -0,0 +1,834 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} + +-- censor-validate: empirical calibration sweep for ppad-censor. +-- +-- Drives runCT under synthetic meters with known H_0 / H_1 +-- distributions, counts rejections across N independent trials per +-- cell, and reports Wilson 95% binomial CIs against each cell's +-- alpha bound. Bonferroni-adjusts confidence across the cell grid +-- so a family-wise PASS / FAIL / INCONCLUSIVE verdict means +-- something. +-- +-- Use case: pre-release calibration check. A full N = 10000 sweep +-- takes on the order of an hour; pass a smaller N as the first +-- argument (e.g. `censor-validate 1000`) for a fast pass while +-- iterating. +-- +-- `censor-validate --power-gain [METER]` runs a different job: the +-- host power-coupling probe, a cycle-identical but maximally +-- power-asymmetric positive control measured on the *real* host +-- (default meter: wall). See the probe section below. + +module Main where + +import qualified Censor as C +import qualified Censor.Runner as R +import Control.Monad (forM, forM_, unless) +import Data.IORef +import Data.List (intercalate) +import Data.Maybe (isJust) +import Data.Word (Word64) +import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr) +import Foreign.Ptr (Ptr) +import Foreign.Storable (pokeElemOff) +import qualified System.Environment as Env +import qualified System.Exit as Exit +import qualified System.IO as IO +import Text.Printf (printf) +import Text.Read (readMaybe) + +-- splitmix64 ----------------------------------------------------------------- + +-- Internal PRNG for the synthetic distributions, from Censor.Rng. +-- A separate generator is used for every stream; deterministic +-- seeding lets failures reproduce. + +-- uniform integer in @[lo, hi]@, inclusive. +uniformInt :: C.Rng -> Word64 -> Word64 -> IO Word64 +uniformInt !rng !lo !hi + | hi <= lo = pure lo + | otherwise = do + !w <- C.nextWord rng + let !range = hi - lo + 1 + pure $! lo + (w `mod` range) + +-- Wilson CI + verdict -------------------------------------------------------- + +-- two-sided z critical value, ladder. Rounds *up* so the resulting +-- CI is conservatively wide and verdicts are cautious. +zCritical :: Double -> Double +zCritical !conf + | conf > 0.99999 = 4.892 + | conf > 0.9999 = 4.417 + | conf > 0.999 = 3.890 + | conf > 0.99 = 3.291 + | conf > 0.95 = 2.576 + | otherwise = 1.960 + +-- Wilson score interval for a binomial proportion. Has better +-- coverage than the naive normal approximation when p is near 0, +-- which is exactly our regime. +wilsonCI :: Int -> Int -> Double -> (Double, Double) +wilsonCI !k !n !z + | n <= 0 = (0, 1) + | otherwise = + let !nn = fromIntegral n + !kk = fromIntegral k + !p = kk / nn + !z2 = z * z + !den = 1 + z2 / nn + !ctr = (p + z2 / (2 * nn)) / den + !rad = (z * sqrt (p * (1 - p) / nn + z2 / (4 * nn * nn))) / den + in (max 0 (ctr - rad), min 1 (ctr + rad)) + +data Verdict = VPass | VFail | VInconclusive + deriving (Eq, Show) + +renderVerdict :: Verdict -> String +renderVerdict VPass = "PASS" +renderVerdict VFail = "FAIL" +renderVerdict VInconclusive = "INCONC" + +-- A cell PASSes iff the CI's upper bound is below alpha (rejection +-- rate is comfortably under the type-I bound); FAILs iff the lower +-- bound is above alpha (rejection rate exceeds the bound — a real +-- statistical violation); INCONCLUSIVE if the CI straddles alpha +-- (need more trials to resolve). +verdictFor :: Double -> (Double, Double) -> Verdict +verdictFor !alpha (!lo, !hi) + | lo > alpha = VFail + | hi < alpha = VPass + | otherwise = VInconclusive + +-- synthetic meter ------------------------------------------------------------ + +-- The "class" being measured this call. The hypothesis's samplers +-- pass it through the IORef the meter reads. +data Class = ClassA | ClassB + +-- Constructs a (Meter, Hypothesis) pair that draws per-pair +-- measurements from two user-supplied streams. The samplers route +-- the class tag through an IORef the meter reads after running the +-- (no-op) target k times, so the meter knows which stream to pull +-- from. cfgBatch is honoured for fidelity to the real driver — the +-- target action runs k times — but only one stream element is +-- consumed per measure call. +mkSyntheticMeter + :: IO Word64 + -> IO Word64 + -> IO (C.Meter, C.Hypothesis Class) +mkSyntheticMeter !nextA !nextB = do + ref <- newIORef ClassA + let !meter = C.Meter $ \k act -> do + let go !0 = pure () + go !i = act >> go (i - 1) + go k + c <- readIORef ref + case c of + ClassA -> nextA + ClassB -> nextB + !hyp = C.Hypothesis + { C.target = writeIORef ref + , C.prepare = pure () + , C.sampleA = pure ClassA + , C.sampleB = pure ClassB + } + pure (meter, hyp) + +-- scenarios ------------------------------------------------------------------ + +-- A scenario is a stream factory: each trial calls scInit afresh, +-- producing two new per-class streams (and any state they share). +-- scInit takes the Config so scenarios that need to coordinate +-- with cfgWarmup (the pathological-clipping case) can do so. +data Scenario = Scenario + { scName :: !String + , scInit :: !(C.Config -> IO (IO Word64, IO Word64)) + } + +scConstant :: Scenario +scConstant = Scenario "constant" $ \_ -> + pure (pure 100, pure 100) + +scSymUniform :: Word64 -> Scenario +scSymUniform !seed = Scenario "sym-uniform-iid" $ \_ -> do + ra <- C.mkRng seed + rb <- C.mkRng (seed + 1) + pure (uniformInt ra 0 200, uniformInt rb 0 200) + +-- A uniform over a wide range, B uniform over a narrow centred +-- range. Both have mean 100; the only asymmetry is the variance. +-- +-- This is an H_1 scenario, not H_0. Both marginals are symmetric +-- about 100, so d = ta - tb is symmetric about zero and the sign +-- and magnitude channels see nothing. The class CDFs differ +-- everywhere but the centre, though, so the indicator components +-- detect it. It is the cell that distinguishes a null of +-- "d is symmetric" from a null of "the pair is exchangeable". +scAsymUniform :: Word64 -> Scenario +scAsymUniform !seed = Scenario "asym-uniform-equal-mean" $ \_ -> do + ra <- C.mkRng seed + rb <- C.mkRng (seed + 1) + pure (uniformInt ra 0 200, uniformInt rb 50 150) + +-- 95% uniform[50, 150] + 5% uniform[5000, 10000] for both classes. +-- Heavy upper tail exercises the clipping branch heavily; equal +-- distributions mean equal means, so H_0 holds. +scHeavyTail :: Word64 -> Scenario +scHeavyTail !seed = Scenario "heavy-tail" $ \_ -> do + ra <- C.mkRng seed + rb <- C.mkRng (seed + 1) + let draw rng = do + u <- C.nextWord rng + if u `mod` 20 == 0 + then uniformInt rng 5000 10000 + else uniformInt rng 50 150 + pure (draw ra, draw rb) + +-- Per-pair shared deterministic drift. Both classes' measurements +-- shift upward by 10 every pair; per-class noise is i.i.d. uniform +-- around zero. Conditional mean of the difference is exactly zero +-- throughout (the drift cancels), but the marginal expectation is +-- highly non-stationary — exercising the conditional-null regime +-- the order-bit randomisation is supposed to handle. +scDriftingBaseline :: Word64 -> Scenario +scDriftingBaseline !seed = Scenario "drifting-baseline" $ \_ -> do + ctr <- newIORef (0 :: Int) + noiseA <- C.mkRng seed + noiseB <- C.mkRng (seed + 1) + let draw rng = do + n <- atomicModifyIORef' ctr (\x -> (x + 1, x)) + let !base = 100 + fromIntegral (n `div` 2) * 10 + u <- C.nextWord rng + let !noise = fromIntegral (u `mod` 21) - 10 + pure $! fromIntegral (base + noise :: Int) + pure (draw noiseA, draw noiseB) + +-- Heavy main-loop clipping. Each class returns a small reading for +-- the first cfgWarmup calls (the warmup phase, where it is sampled +-- once per pair), then a huge reading thereafter. The warmup-derived +-- bound is small; every main-phase reading exceeds it and is +-- clipped to that bound. Both classes share the same stream, so +-- conditional mean of the difference stays zero — the test is that +-- clipping doesn't *itself* generate spurious rejections. +scAllClipping :: Word64 -> Scenario +scAllClipping !seed = Scenario "pathological-clipping" $ \cfg -> do + ctrA <- newIORef (0 :: Int) + ctrB <- newIORef (0 :: Int) + let !cutover = C.cfgWarmup cfg + draw ref = do + n <- atomicModifyIORef' ref (\x -> (x + 1, x)) + if n < cutover then pure 100 else pure 1000000 + let _ = seed -- reserved for future randomised variants + pure (draw ctrA, draw ctrB) + +-- Readings concentrated right against the upper end of the warmup +-- bound. Tests behaviour at the clipping boundary. +scNearBound :: Word64 -> Scenario +scNearBound !seed = Scenario "near-bound" $ \_ -> do + ra <- C.mkRng seed + rb <- C.mkRng (seed + 1) + pure (uniformInt ra 180 200, uniformInt rb 180 200) + +-- Mid-run regime change: warmup and the early main phase see a +-- narrow noise band, after which the noise widens. Conditional mean +-- of the difference stays at zero (both classes shift regime +-- together), but the warmup bound is no longer representative of +-- the main phase — stresses the assumption that warmup calibration +-- characterises the whole run. +scRegimeChange :: Word64 -> Scenario +scRegimeChange !seed = Scenario "regime-change" $ \cfg -> do + ctr <- newIORef (0 :: Int) + ra <- C.mkRng seed + rb <- C.mkRng (seed + 1) + let !switchAt = 2 * C.cfgWarmup cfg + C.cfgBudget cfg + draw rng = do + n <- atomicModifyIORef' ctr (\x -> (x + 1, x)) + if n < switchAt + then uniformInt rng 50 150 + else uniformInt rng 0 200 + pure (draw ra, draw rb) + +-- High baseline with narrow i.i.d. jitter per class. Concretely +-- readings sit at 10000 +/- 10; @|d|@ stays on the noise scale (~20) +-- while readings themselves stay on the baseline scale (~10000). +-- This is the regime where betting on the clipped difference (rather +-- than on the clipped readings) pays off dramatically: @lambda_max@ +-- is set by @|d|@ and stays ~500x higher than it would be if it +-- scaled with reading magnitude. +scNarrowJitter :: Word64 -> Scenario +scNarrowJitter !seed = Scenario "narrow-jitter" $ \_ -> do + ra <- C.mkRng seed + rb <- C.mkRng (seed + 1) + pure (uniformInt ra 9990 10010, uniformInt rb 9990 10010) + +-- Rare-outlier H_0: both classes are 99% uniform[50,150] + 1% +-- uniform[900,1100]. Independent draws, identical distributions, +-- so the null holds. Included to verify that the multi-clip hedge +-- doesn't spuriously reject under fat-tailed-but-symmetric structure +-- (symmetric clipping preserves symmetry across all three magnitude +-- components, so it shouldn't). +scRareOutlier :: Word64 -> Scenario +scRareOutlier !seed = Scenario "rare-outlier" $ \_ -> do + ra <- C.mkRng seed + rb <- C.mkRng (seed + 1) + let draw rng = do + u <- C.nextWord rng + if u `mod` 100 == 0 + then uniformInt rng 900 1100 + else uniformInt rng 50 150 + pure (draw ra, draw rb) + +-- Rare-outlier H_1: class A is pure bulk (uniform[50,150]); class B +-- is 99% bulk + 1% spike (uniform[900,1100]). Both classes match in +-- bulk, so the sign test and tight-clip magnitude see almost no +-- signal (the 1% spikes shift @P(d > 0)@ by ~0.005 and get clipped +-- away at bound @c@ by @magn(c)@). Only @magn(16c)@ preserves the +-- spike signal — this is the scenario that exercises the multi-clip +-- rationale for the hedge. +scRareOutlierAsym :: Word64 -> Scenario +scRareOutlierAsym !seed = Scenario "rare-outlier-asym" $ \_ -> do + ra <- C.mkRng seed + rb <- C.mkRng (seed + 1) + let drawA = uniformInt ra 50 150 + drawB = do + u <- C.nextWord rb + if u `mod` 100 == 0 + then uniformInt rb 900 1100 + else uniformInt rb 50 150 + pure (drawA, drawB) + +-- All H_0 calibration scenarios. +h0Scenarios :: [Scenario] +h0Scenarios = + [ scConstant + , scSymUniform 0x5EED01 + , scHeavyTail 0x5EED03 + , scDriftingBaseline 0x5EED04 + , scNearBound 0x5EED05 + , scAllClipping 0x5EED06 + , scRegimeChange 0x5EED07 + , scNarrowJitter 0x5EED08 + , scRareOutlier 0x5EED09 + ] + +-- A power scenario adds a positive shift to class B (so +-- E[ta - tb] = -shift). Used to characterise detection rate as a +-- function of effect size. +addShift :: Scenario -> Word64 -> Scenario +addShift !base !shift = base + { scName = scName base ++ "+shift=" ++ show shift + , scInit = \cfg -> do + (a, b) <- scInit base cfg + pure (a, fmap (+ shift) b) + } + +-- H_1 scenarios for the power table. Pick a couple of base +-- distributions and sweep the shift / budget grid against them. +-- narrow-jitter is included specifically to exhibit the bet-on-|d| +-- power gain: under bet-on-readings the ~500x smaller lambda_max +-- would leave every one of these cells at 0% detection. +powerBases :: [Scenario] +powerBases = + [ scSymUniform 0xB055ED01 + , scHeavyTail 0xB055ED02 + , scNarrowJitter 0xB055ED03 + ] + +powerShifts :: [Word64] +powerShifts = [1, 5, 10, 50] + +powerBudgets :: [Int] +powerBudgets = [1000, 10000] + +-- cells ---------------------------------------------------------------------- + +data Cell = Cell + { cellScenario :: !Scenario + , cellCfg :: !C.Config + , cellGate :: !(Maybe Double) + -- ^ alpha bound for PASS/FAIL gating; @Nothing@ means + -- characterisation only (power cells). + } + +baseCfg :: Int -> Int -> Double -> C.Config +baseCfg !budget !batch !alpha = C.defaultConfig + { C.cfgAlpha = alpha + , C.cfgBudget = budget + , C.cfgBatch = batch + , C.cfgWarmup = 200 + , C.cfgSeed = Just 0xBA5E11EDBA5E11ED + -- Pin the order-bit seed so the baseline CSV is reproducible + -- across runs. Production use of censor should leave cfgSeed at + -- the default 'Nothing' (fresh entropy per run). + } + +-- Gated cells: alphas where it is feasible to PASS at our N. A +-- PASS at alpha = a requires the Wilson upper bound to fall below +-- a, which (at family confidence) needs roughly N > 3.3^2 / a even +-- with zero observed rejections. So 1e-2 and 1e-3 are gateable at +-- N = 10000; 1e-4 and 1e-6 are characterisation-only (CI reported +-- but no PASS/FAIL). +gatedAlphas, ungatedAlphas :: [Double] +gatedAlphas = [1.0e-2, 1.0e-3] +ungatedAlphas = [1.0e-4, 1.0e-6] + +calibrationCells :: [Cell] +calibrationCells = gated ++ characterised + where + gated = + [ Cell sc (baseCfg 10000 1 a) (Just a) + | sc <- h0Scenarios, a <- gatedAlphas + ] + characterised = + [ Cell sc (baseCfg 10000 1 a) Nothing + | sc <- h0Scenarios, a <- ungatedAlphas + ] + +-- Edge-case cells: parameter regimes where the alpha guarantee +-- could plausibly degrade beyond what the calibration sweep +-- exercises. Kept small because most natural variations (cfgBatch, +-- cfgWarmup size) don't materially affect statistical behaviour in +-- synthetic-meter mode. +edgeCaseCells :: [Cell] +edgeCaseCells = + [ Cell sc (baseCfg 10000 1 1e-3) { C.cfgWarmup = 20 } (Just 1e-3) + , Cell sc (baseCfg 10000 100 1e-3) (Just 1e-3) + ] + where + sc = scSymUniform 0xED6E01 + +-- margin (interval-null) cells ----------------------------------------------- + +-- Cells exercising cfgMargin. A relative margin resolves against +-- the warmup median pooled reading, so each base names the reading +-- scale it was chosen for: narrow-jitter readings sit at ~10000, +-- where rel 1e-3 lands the absolute margin at ~10 against a clip +-- bound of ~40+; heavy-tail readings have median ~100, where rel +-- 5e-2 lands it at ~5 against a clip bound in the thousands. +-- +-- The calibration cells shift class B by LESS than the resolved +-- margin, so the interval null |E d_clipped| <= delta is true +-- while the sharp null is false: they validate margin mode's +-- type-I claim under exactly the sub-tolerance systematic the +-- margin exists to absorb. The sharp-contrast power cell runs the +-- same sub-margin shift without a margin and should reject at +-- ~100%, exhibiting the behaviour being ruled out of scope. +marginCfg :: Double -> Int -> Double -> C.Config +marginCfg !rel !budget !alpha = + (baseCfg budget 1 alpha) { C.cfgMargin = Just rel } + +withMarginName :: Double -> Scenario -> Scenario +withMarginName !rel sc = + sc { scName = scName sc ++ "+margin=" ++ showSci rel } + +marginH0Bases :: [(Scenario, Double)] +marginH0Bases = + [ (scNarrowJitter 0x3A6C01, 1.0e-3) -- no systematic + , (addShift (scNarrowJitter 0x3A6C02) 2, 1.0e-3) -- 2 < delta ~10 + , (addShift (scNarrowJitter 0x3A6C03) 8, 1.0e-3) -- 8 < delta ~10 + , (addShift (scHeavyTail 0x3A6C04) 2, 5.0e-2) -- 2 < delta ~5 + ] + +marginCalibrationCells :: [Cell] +marginCalibrationCells = + [ Cell (withMarginName rel sc) (marginCfg rel 10000 a) (Just a) + | (sc, rel) <- marginH0Bases + , a <- gatedAlphas + ] + +marginPowerCells :: [Cell] +marginPowerCells = beyond ++ contrast + where + -- shifts beyond the resolved margin (~10) must still be caught. + beyond = + [ Cell (withMarginName 1.0e-3 + (addShift (scNarrowJitter 0x3A6C05) s)) + (marginCfg 1.0e-3 budget 1e-3) Nothing + | s <- [20, 50], budget <- powerBudgets + ] + -- the sub-margin shift from the calibration cells, sharp mode. + contrast = + [ Cell (addShift (scNarrowJitter 0x3A6C06) 2) + (baseCfg 10000 1 1e-3) Nothing + ] + +powerCells :: [Cell] +powerCells = shiftedCells ++ asymCells ++ varianceCells + where + shiftedCells = + [ Cell (addShift base shift) (baseCfg budget 1 1e-3) Nothing + | base <- powerBases + , shift <- powerShifts + , budget <- powerBudgets + ] + -- The rare-outlier asymmetric H_1 encodes its leak in the tail + -- (spike rate), not in a scalar shift, so it doesn't ride + -- 'addShift'. Just two budget cells. + asymCells = + [ Cell (scRareOutlierAsym 0xB055ED04) (baseCfg budget 1 1e-3) + Nothing + | budget <- powerBudgets + ] + -- Likewise the variance-only H_1: its leak is a dispersion + -- difference at equal means, reachable only through the + -- CDF-indicator channel. + varianceCells = + [ Cell (scAsymUniform 0xB055ED05) (baseCfg budget 1 1e-3) + Nothing + | budget <- powerBudgets + ] + +-- runner --------------------------------------------------------------------- + +runTrial :: Scenario -> C.Config -> IO C.Result +runTrial !sc !cfg = do + (a, b) <- scInit sc cfg + (meter, hyp) <- mkSyntheticMeter a b + C.runCT meter cfg hyp + +countRejects :: Scenario -> C.Config -> Int -> IO Int +countRejects !sc !cfg !trials = go trials 0 + where + go !0 !acc = pure acc + go !n !acc = do + r <- runTrial sc cfg + let !inc = case r of + C.Reject{} -> 1 + C.Pass{} -> 0 + go (n - 1) (acc + inc) + +data CellResult = CellResult + { crCell :: !Cell + , crTrials :: !Int + , crRejects :: !Int + , crCI :: !(Double, Double) + , crVerdict :: !(Maybe Verdict) + -- ^ Nothing for power (characterisation) cells. + } + +runCell :: Int -> Double -> Cell -> IO CellResult +runCell !trials !familyConf cell@Cell{..} = do + rejects <- countRejects cellScenario cellCfg trials + let !z = zCritical familyConf + !ci = wilsonCI rejects trials z + !ver = fmap (`verdictFor` ci) cellGate + pure CellResult + { crCell = cell, crTrials = trials, crRejects = rejects + , crCI = ci, crVerdict = ver + } + +-- reporter ------------------------------------------------------------------- + +showSci :: Double -> String +showSci x + | x >= 0.01 = printf "%g" x + | otherwise = printf "%.0e" x + +rate :: Int -> Int -> Double +rate !k !n + | n <= 0 = 0 + | otherwise = fromIntegral k / fromIntegral n + +reportCell :: CellResult -> String +reportCell CellResult{..} = + let Cell{..} = crCell + !alpha = C.cfgAlpha cellCfg + !budget = C.cfgBudget cellCfg + !batch = C.cfgBatch cellCfg + !(lo, hi) = crCI + !verCol = maybe "-" renderVerdict crVerdict + in printf "%-36s %-9s %7d %5d %5d %9.5f [%7.5f, %7.5f] %-6s" + (scName cellScenario) (showSci alpha) budget batch + crRejects (rate crRejects crTrials) lo hi verCol + +reportHeader :: String +reportHeader = printf "%-36s %-9s %7s %5s %5s %9s %18s %-6s" + ("scenario" :: String) ("alpha" :: String) ("budget" :: String) + ("batch" :: String) ("rej" :: String) ("rate" :: String) + ("CI" :: String) ("verdict" :: String) + +reportSection :: String -> Int -> Double -> [CellResult] -> IO () +reportSection title trials cellConf results = do + putStrLn "" + putStrLn $ title ++ " (N=" ++ show trials + ++ ", per-cell conf=" ++ printf "%.4f%%" (cellConf * 100) + ++ ")" + putStrLn $ replicate (length reportHeader) '=' + putStrLn reportHeader + putStrLn $ replicate (length reportHeader) '-' + mapM_ (putStrLn . reportCell) results + +countVerdicts :: [CellResult] -> (Int, Int, Int) +countVerdicts = foldr step (0, 0, 0) + where + step CellResult{crVerdict = Just VPass} (!p, !f, !i) = (p+1, f, i) + step CellResult{crVerdict = Just VFail} (!p, !f, !i) = (p, f+1, i) + step CellResult{crVerdict = Just VInconclusive} + (!p, !f, !i) = (p, f, i+1) + step CellResult{crVerdict = Nothing} acc = acc + +reportSummary :: [CellResult] -> IO () +reportSummary results = do + let (!p, !f, !i) = countVerdicts results + putStrLn "" + printf "calibration summary: %d PASS / %d FAIL / %d INCONCLUSIVE\n" + p f i + unless (f == 0) $ + putStrLn "FAIL: empirical rejection rate exceeded alpha; investigate." + +-- CSV output ----------------------------------------------------------------- + +csvHeader :: String +csvHeader = intercalate "," + [ "scenario", "alpha", "budget", "batch", "trials" + , "rejects", "rate", "ci_lo", "ci_hi", "verdict" + ] + +csvRow :: CellResult -> String +csvRow CellResult{..} = intercalate "," + [ scName (cellScenario crCell) + , printf "%g" (C.cfgAlpha (cellCfg crCell)) + , show (C.cfgBudget (cellCfg crCell)) + , show (C.cfgBatch (cellCfg crCell)) + , show crTrials + , show crRejects + , printf "%g" (rate crRejects crTrials) + , printf "%g" (fst crCI) + , printf "%g" (snd crCI) + , maybe "-" renderVerdict crVerdict + ] + +writeCsv :: FilePath -> [CellResult] -> IO () +writeCsv !path results = do + let body = csvHeader : map csvRow results + writeFile path (unlines body) + putStrLn $ "csv written to " ++ path + +-- main ----------------------------------------------------------------------- + +data Opts = Opts + { optTrials :: !Int + , optCsv :: !(Maybe FilePath) + } + +defaultOpts :: Opts +defaultOpts = Opts { optTrials = 10000, optCsv = Nothing } + +parseArgs :: [String] -> Opts +parseArgs = go defaultOpts + where + go !o [] = o + go !o ("--csv":p:rest) = go (o { optCsv = Just p }) rest + go !o (s:rest) + | Just n <- readMaybe s = go (o { optTrials = n }) rest + | otherwise = go o rest + +main :: IO () +main = do + IO.hSetBuffering IO.stdout IO.LineBuffering + args <- Env.getArgs + if "--power-gain" `elem` args + then powerGainMain (filter (/= "--power-gain") args) + else sweepMain args + +sweepMain :: [String] -> IO () +sweepMain args = do + let Opts{..} = parseArgs args + cells = calibrationCells ++ edgeCaseCells + ++ marginCalibrationCells + ++ powerCells ++ marginPowerCells + gatedCount = length [ c | c <- calibrationCells ++ edgeCaseCells + ++ marginCalibrationCells + , isJust (cellGate c) ] + familyConf = 1 - 0.05 / fromIntegral gatedCount + -- Bonferroni over the gated cells. Ungated calibration and + -- power cells don't contribute to family-wise FAIL risk, so + -- they don't pay into the correction. + + putStrLn "censor-validate: empirical calibration sweep" + printf " trials per cell : %d\n" optTrials + printf " total cells : %d\n" (length cells) + printf " gated cells : %d\n" gatedCount + printf " per-cell conf : %.4f%% (Bonferroni)\n" (familyConf * 100) + putStrLn "" + + results <- forM cells $ \c -> do + let !ungated = case cellGate c of { Nothing -> True; _ -> False } + !conf = if ungated then 0.95 else familyConf + printf " ... %s\n" (scName (cellScenario c)) + runCell optTrials conf c + + let (calibR, rest1) = splitAt (length calibrationCells) results + (edgeR, rest2) = splitAt (length edgeCaseCells) rest1 + (mcalR, rest3) = splitAt (length marginCalibrationCells) rest2 + (powerR, mpowR) = splitAt (length powerCells) rest3 + + reportSection "calibration" optTrials familyConf calibR + reportSection "edge cases" optTrials familyConf edgeR + reportSection "margin calibration" optTrials familyConf mcalR + reportSection "power" optTrials 0.95 powerR + reportSection "margin power" optTrials 0.95 mpowR + reportSummary (calibR ++ edgeR ++ mcalR) + + forM_ optCsv $ \p -> writeCsv p results + + let (_, fails, _) = countVerdicts (calibR ++ edgeR ++ mcalR) + if fails > 0 + then Exit.exitWith (Exit.ExitFailure 1) + else Exit.exitSuccess + +-- host power-gain probe ------------------------------------------------------ + +-- A maximally power-asymmetric, cycle-identical positive control, +-- measured on the real host rather than a synthetic meter. Both +-- classes run the identical instruction stream -- two full rewrites +-- of a 64 KiB buffer per call -- and differ only in the data +-- written: class A writes zeros twice, so after the first call no +-- stored bit ever changes; class B alternates the all-01 and all-10 +-- patterns, so every bit of the buffer and the store datapath +-- toggles on each rewrite. Any class difference a timing meter +-- resolves is therefore carried by a power-mediated channel +-- (frequency scaling being the usual transducer), not by the +-- executed code. The probe measures the host's power-to-time +-- coupling gain at maximal switching activity -- an upper bound on +-- what any real fix-vs-random data asymmetry can induce through +-- that channel, and hence a principled floor for cfgMargin on this +-- host. Only the deterministic counters -- instructions, branches +-- -- are guaranteed to read clean, and their doing so is what +-- certifies the two classes really do execute the same code. A +-- cycle-meter rejection is a result rather than a malfunction: an +-- identical instruction stream can still cost different cycles +-- when the data changes memory-system behaviour, so cycles +-- rejecting while instructions stay clean localises the coupling +-- to microarchitectural latency instead of frequency. +-- +-- The A/A control (zeros vs zeros) runs first: it shares the +-- harness shape but not the content asymmetry, so a rejection +-- there indicts ambient instability rather than the power channel, +-- and the gain estimate is flagged as confounded. + +powerGainWords :: Int +powerGainWords = 8192 -- 64 KiB of Word64 + +fillBuf :: Ptr Word64 -> Word64 -> IO () +fillBuf !p !w = go 0 + where + go !i + | i >= powerGainWords = pure () + | otherwise = pokeElemOff p i w >> go (i + 1) + +powerGainHyp :: IO (C.Hypothesis (Word64, Word64)) +powerGainHyp = do + fp <- mallocForeignPtrBytes (powerGainWords * 8) + pure C.Hypothesis + { C.target = \(!w1, !w2) -> withForeignPtr fp $ \p -> do + fillBuf p w1 + fillBuf p w2 + , C.prepare = pure () + , C.sampleA = pure (0x0000000000000000, 0x0000000000000000) + , C.sampleB = pure (0x5555555555555555, 0xAAAAAAAAAAAAAAAA) + } + +data GainOpts = GainOpts + { goMeter :: !(Maybe String) + , goBudget :: !Int + , goBatch :: !Int + } + +parseGainArgs :: [String] -> GainOpts +parseGainArgs = + go GainOpts { goMeter = Nothing, goBudget = 100000, goBatch = 1 } + where + go !o [] = o + go !o ("--budget":v:rest) + | Just n <- readMaybe v = go o { goBudget = n } rest + go !o ("--batch":v:rest) + | Just n <- readMaybe v = go o { goBatch = n } rest + go !o (s:rest) + | take 2 s /= "--" = go o { goMeter = Just s } rest + | otherwise = go o rest + +powerGainMain :: [String] -> IO () +powerGainMain args = do + let GainOpts{..} = parseGainArgs args + -- alpha 1e-3, not the driver default 1e-6: the probe is a + -- measurement instrument, not a gate, and resEffect is a + -- 1 - alpha confidence sequence -- the looser alpha buys a + -- usefully tighter coupling bound at a confidence that is + -- ample for host calibration. + cfg = C.defaultConfig + { C.cfgAlpha = 1.0e-3 + , C.cfgBudget = goBudget + , C.cfgWarmup = 500 + , C.cfgBatch = goBatch + } + R.withMeterArg goMeter $ \mname meter -> do + putStrLn "censor-validate: host power-coupling probe" + printf " meter %s . buffer %d KiB . batch %d . budget %d . alpha %.1g\n" + mname (powerGainWords * 8 `div` 1024) goBatch goBudget + (C.cfgAlpha cfg) + putStrLn "" + hypC <- powerGainHyp + ctrl <- C.runAA meter cfg hypC + printf " control (zeros vs zeros) : %s\n" (R.summary ctrl) + hypP <- powerGainHyp + base <- C.baselineReading meter cfg hypP + probe <- C.runCT meter cfg hypP + printf " probe (zeros vs max-toggle) : %s\n" (R.summary probe) + putStrLn "" + let !med = fromIntegral (C.nsMedian base) :: Double + (!elo, !ehi) = C.resEffect probe + !mag = max (abs elo) (abs ehi) + printf " baseline: med=%d iqr=%d (meter units per batch)\n" + (C.nsMedian base) (C.nsIqr base) + if med <= 0 + then putStrLn + " baseline median is zero; raise --batch until it resolves" + else do + -- the effect interval covers the true coupling with + -- probability 1 - alpha, so its largest endpoint magnitude is + -- a valid upper bound on |coupling| at that level. + printf + " coupling bound: |effect| <= %.1f units/batch (%.2g of the reading)\n" + mag (mag / med) + let !rel4 = 4 * mag / med + if mname /= "wall" + then putStrLn $ + " no margin suggested: the counters are meant to support\n" + ++ " the sharp null, where a tolerance only gives away\n" + ++ " power. Read the bound as this meter's residual\n" + ++ " class-difference sensitivity instead." + else if rel4 < 0.05 + then printf + " suggested wall margin, 4x headroom: --margin %.1g\n" rel4 + else putStrLn $ + " bound too loose to derive a useful margin. The effect\n" + ++ " interval bottoms out near a tenth of the clip bound,\n" + ++ " which wall pair-noise sets, and more --budget barely\n" + ++ " moves it -- the lever is a quieter host. A bigger\n" + ++ " --batch does not tighten the bound either, but it is\n" + ++ " what resolves the channel at all on a noisy or\n" + ++ " virtualised host (see the README's batching note)." + case probe of + C.Reject{} -> do + putStrLn "" + putStrLn $ " the meter resolved the power channel: this host converts\n" + ++ " data switching activity into measurable timing differences." + unless (C.resPairs probe >= goBudget) $ putStrLn $ + " (halted early at " ++ show (C.resPairs probe) + ++ " pairs; detection outpaces estimation, so the bound\n" + ++ " above is loose -- repeat runs or a larger budget sharpen it.)" + C.Pass{} -> do + putStrLn "" + putStrLn $ " no coupling resolved at this budget; the bound above is\n" + ++ " what the run can exclude." + case ctrl of + C.Reject{} -> do + putStrLn "" + putStrLn $ " WARNING: the A/A control rejected. The harness or host is\n" + ++ " unstable and the gain estimate above is confounded; quiet the\n" + ++ " host and re-run." + C.Pass{} -> pure ()