ppad-censor (empty) → 0.5.1
raw patch · 22 files changed
+7612/−0 lines, 22 filesdep +basedep +bytestringdep +criterion
Dependencies added: base, bytestring, criterion, deepseq, ppad-censor, ppad-eproc, primitive, process, tasty, tasty-hunit, weigh
Files
- CHANGELOG +461/−0
- LICENSE +20/−0
- bench/Main.hs +79/−0
- bench/Weight.hs +62/−0
- cbits/censor_clock.c +22/−0
- cbits/censor_dl.c +23/−0
- cbits/censor_env.c +72/−0
- cbits/censor_perf.c +79/−0
- lib/Censor.hs +1269/−0
- lib/Censor/FFI.hs +102/−0
- lib/Censor/Meter.hs +194/−0
- lib/Censor/Rng.hs +112/−0
- lib/Censor/Runner.hs +205/−0
- lib/Censor/Runner/DL.hs +105/−0
- lib/Censor/Runner/Env.hs +190/−0
- lib/Censor/Runner/Manifest.hs +366/−0
- lib/Censor/Runner/Report.hs +1004/−0
- ppad-censor.cabal +189/−0
- run/Main.hs +606/−0
- test-integration/Main.hs +135/−0
- test/Main.hs +1483/−0
- validate/Main.hs +834/−0
+ CHANGELOG view
@@ -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.
+ LICENSE view
@@ -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.
+ bench/Main.hs view
@@ -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)+ ]
+ bench/Weight.hs view
@@ -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
+ cbits/censor_clock.c view
@@ -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 <stdint.h>+#include <time.h>++uint64_t censor_monotonic_ns(void) {+ return clock_gettime_nsec_np(CLOCK_UPTIME_RAW);+}++#endif
+ cbits/censor_dl.c view
@@ -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 <dlfcn.h>++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();+}
+ cbits/censor_env.c view
@@ -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 <stddef.h>++#if !defined(_WIN32)++#include <stdio.h>+#include <stdlib.h>+#include <time.h>+#include <unistd.h>+#include <sys/utsname.h>++#if defined(__APPLE__)+#include <sys/sysctl.h>+#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
+ cbits/censor_perf.c view
@@ -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 <stdint.h>+#include <string.h>+#include <errno.h>+#include <unistd.h>+#include <sys/types.h>+#include <sys/ioctl.h>+#include <sys/syscall.h>+#include <linux/perf_event.h>+#include <asm/unistd.h>++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);+}
+ lib/Censor.hs view
@@ -0,0 +1,1269 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Module: Censor+-- Copyright: (c) 2026 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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
+ lib/Censor/FFI.hs view
@@ -0,0 +1,102 @@+{-# OPTIONS_HADDOCK prune #-}++-- |+-- Module: Censor.FFI+-- Copyright: (c) 2026 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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+ }
+ lib/Censor/Meter.hs view
@@ -0,0 +1,194 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}++-- |+-- Module: Censor.Meter+-- Copyright: (c) 2026 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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
+ lib/Censor/Rng.hs view
@@ -0,0 +1,112 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}++-- |+-- Module: Censor.Rng+-- Copyright: (c) 2026 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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)
+ lib/Censor/Runner.hs view
@@ -0,0 +1,205 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}++-- |+-- Module: Censor.Runner+-- Copyright: (c) 2026 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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"
+ lib/Censor/Runner/DL.hs view
@@ -0,0 +1,105 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}++-- |+-- Module: Censor.Runner.DL+-- Copyright: (c) 2026 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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
+ lib/Censor/Runner/Env.hs view
@@ -0,0 +1,190 @@+{-# OPTIONS_HADDOCK prune #-}++-- |+-- Module: Censor.Runner.Env+-- Copyright: (c) 2026 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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
+ lib/Censor/Runner/Manifest.hs view
@@ -0,0 +1,366 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}++-- |+-- Module: Censor.Runner.Manifest+-- Copyright: (c) 2026 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- 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
+ lib/Censor/Runner/Report.hs view
@@ -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 <jared@ppad.tech>+--+-- 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\<VER\>@) 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+-- @\<progName\>-\<meter\>.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 ()
+ ppad-censor.cabal view
@@ -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
+ run/Main.hs view
@@ -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 <libpath> --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 <libpath> --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 <libpath>"+ -- 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 }
+ test-integration/Main.hs view
@@ -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 <stdint.h>"+ , ""+ , "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+ }
+ test/Main.hs view
@@ -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)
+ validate/Main.hs view
@@ -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 ()