commit d46bfe999c7d30bc3eb120bbab1f68471653a533
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 17 Oct 2026 19:40:19 +0400
vestigia: memcheck's report of where an execution depended on a secret
Diffstat:
19 files changed, 1607 insertions(+), 0 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -0,0 +1,2 @@
+dist-newstyle/
+result*
diff --git a/CHANGELOG b/CHANGELOG
@@ -0,0 +1,8 @@
+# Changelog
+
+- 0.1.0 (unreleased)
+ * Initial version: `vestigia run` runs a harness under memcheck
+ with the bytes it marked secret made undefined, and reports each
+ branch and address computed from them (vestigia/trace-v1);
+ `vestigia read` reports from memcheck's XML; `vestigia.h` holds
+ the harness's two marks.
diff --git a/LICENSE b/LICENSE
@@ -0,0 +1,20 @@
+Copyright (c) 2026 Jared Tobin
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/app/Main.hs b/app/Main.hs
@@ -0,0 +1,143 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module: Main
+-- Copyright: (c) 2026 Jared Tobin
+-- License: MIT
+-- Maintainer: Jared Tobin <jared@ppad.tech>
+--
+-- The vestigia command: run a harness under memcheck and report
+-- where its execution depended on the bytes it marked secret.
+
+module Main (
+ main
+ ) where
+
+import Control.Exception (IOException, try)
+import qualified Data.ByteString as BS
+import Data.Version (showVersion)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Encoding.Error as TEE
+import qualified Data.Text.IO as TIO
+import System.Directory (getTemporaryDirectory, removeFile)
+import System.Environment (getArgs, lookupEnv)
+import System.Exit (ExitCode(..), exitWith)
+import System.IO (hClose, hPutStrLn, openTempFile, stderr)
+import System.Process (proc, waitForProcess, withCreateProcess)
+
+import Paths_vestigia (version)
+import Vestigia.Json (encode)
+import Vestigia.Memcheck (readMemcheck)
+import Vestigia.Trace (trace, traceJson, traceSummary)
+
+data Opts = Opts {
+ oValgrind :: !(Maybe FilePath)
+ , oXml :: !(Maybe FilePath)
+ , oOut :: !(Maybe FilePath)
+ }
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ ("run" : rest) -> case options rest of
+ Right (o, prog : progArgs) -> run o prog progArgs
+ Right (_, []) -> usage "run: no program given"
+ Left e -> usage e
+ ("read" : rest) -> case options rest of
+ Right (o, [ xml ]) -> readXml o xml
+ Right _ -> usage "read: one XML file expected"
+ Left e -> usage e
+ [ "--version" ] -> putStrLn (showVersion version)
+ _ -> usage "expected a command"
+
+usage :: String -> IO a
+usage e = do
+ hPutStrLn stderr ("vestigia: " <> e)
+ hPutStrLn stderr $ unlines
+ [ "usage:"
+ , " vestigia run [--valgrind PATH] [--xml FILE] [--out FILE] \
+ \-- PROGRAM [ARG...]"
+ , " vestigia read [--out FILE] FILE.xml"
+ , ""
+ , "run executes PROGRAM under memcheck, which reports every"
+ , "branch and address that depended on bytes the program marked"
+ , "secret (vestigia.h), and writes the report (vestigia/trace-v1)."
+ , "valgrind is --valgrind, else $VESTIGIA_VALGRIND, else on PATH."
+ ]
+ exitWith (ExitFailure 2)
+
+-- options before the program; "--" ends them
+options :: [String] -> Either String (Opts, [String])
+options = go (Opts Nothing Nothing Nothing)
+ where
+ go o xs = case xs of
+ ("--" : rest) -> Right (o, rest)
+ ("--valgrind" : p : rest) -> go o { oValgrind = Just p } rest
+ ("--xml" : p : rest) -> go o { oXml = Just p } rest
+ ("--out" : p : rest) -> go o { oOut = Just p } rest
+ (x : _) | take 2 x == "--" -> Left ("unknown option: " <> x)
+ _ -> Right (o, xs)
+
+-- the settings every trace runs under: origins tracked so a
+-- secret's descendants are known as such, no limit on contexts,
+-- the precise definedness checks optimised code needs, and no
+-- leak report
+memcheckArgs :: FilePath -> [String]
+memcheckArgs xml =
+ [ "--tool=memcheck"
+ , "--xml=yes"
+ , "--xml-file=" <> xml
+ , "--track-origins=yes"
+ , "--error-limit=no"
+ , "--num-callers=24"
+ , "--expensive-definedness-checks=yes"
+ , "--leak-check=no"
+ , "--child-silent-after-fork=yes"
+ ]
+
+run :: Opts -> FilePath -> [String] -> IO ()
+run o prog progArgs = do
+ env <- lookupEnv "VESTIGIA_VALGRIND"
+ let valgrind = maybe (maybe "valgrind" id env) id (oValgrind o)
+ (xml, temporary) <- case oXml o of
+ Just p -> pure (p, False)
+ Nothing -> do
+ tmp <- getTemporaryDirectory
+ (p, h) <- openTempFile tmp "vestigia.xml"
+ hClose h
+ pure (p, True)
+ r <- try (withCreateProcess
+ (proc valgrind (memcheckArgs xml <> (prog : progArgs)))
+ (\_ _ _ ph -> waitForProcess ph))
+ code <- case r of
+ Left e -> do
+ hPutStrLn stderr ("vestigia: cannot run " <> valgrind <> ": "
+ <> show (e :: IOException))
+ exitWith (ExitFailure 2)
+ Right c -> pure c
+ report o (Just (exitCode code)) xml
+ if temporary then removeFile xml else pure ()
+ where
+ exitCode c = case c of
+ ExitSuccess -> 0
+ ExitFailure n -> n
+
+readXml :: Opts -> FilePath -> IO ()
+readXml o xml = report o Nothing xml
+
+report :: Opts -> Maybe Int -> FilePath -> IO ()
+report o exit xml = do
+ bytes <- BS.readFile xml
+ let txt = TE.decodeUtf8With TEE.lenientDecode bytes
+ case readMemcheck txt of
+ Left e -> do
+ hPutStrLn stderr ("vestigia: " <> xml <> ": " <> e)
+ exitWith (ExitFailure 2)
+ Right mc -> do
+ let tr = trace mc
+ doc = encode
+ (traceJson (T.pack (showVersion version)) exit tr)
+ maybe (TIO.putStr doc) (\p -> TIO.writeFile p doc) (oOut o)
+ TIO.hPutStr stderr (traceSummary tr)
diff --git a/etc/probe/probe.c b/etc/probe/probe.c
@@ -0,0 +1,37 @@
+/* A secret that reaches a branch, a load address, and a store
+ * address, and a public value that reaches none: memcheck should
+ * report the first three with a client-request origin. */
+#include <stdio.h>
+#include <string.h>
+#include <valgrind/memcheck.h>
+
+static unsigned char table[256];
+
+__attribute__((noinline)) int branchy(unsigned char s) {
+ if (s & 1) return 7;
+ return 3;
+}
+
+__attribute__((noinline)) int lookup(unsigned char s) {
+ return table[s];
+}
+
+__attribute__((noinline)) unsigned char ct(unsigned char s,
+ unsigned char p) {
+ unsigned char m = (unsigned char)(-(p & 1));
+ return (unsigned char)((s & m) | (s ^ m));
+}
+
+int main(void) {
+ unsigned char secret[4] = { 1, 2, 3, 4 };
+ unsigned char out[4];
+ memset(table, 5, sizeof table);
+ VALGRIND_MAKE_MEM_UNDEFINED(secret, sizeof secret);
+ out[0] = (unsigned char)branchy(secret[0]);
+ out[1] = (unsigned char)lookup(secret[1]);
+ out[2] = ct(secret[2], 1);
+ table[secret[3]] = 9;
+ VALGRIND_MAKE_MEM_DEFINED(out, sizeof out);
+ printf("%d %d %d\n", out[0], out[1], out[2]);
+ return 0;
+}
diff --git a/etc/probe/probe.nix b/etc/probe/probe.nix
@@ -0,0 +1,17 @@
+# memcheck's XML for a known program, captured on x86_64-linux
+let
+ f = builtins.getFlake "git+file:///Users/jtobin/src/ppad/censor";
+ pkgs = import f.inputs.nixpkgs { system = "x86_64-linux"; };
+in
+pkgs.runCommandCC "vestigia-probe" {
+ nativeBuildInputs = [ pkgs.valgrind ];
+ buildInputs = [ pkgs.valgrind.dev ];
+} ''
+ mkdir -p $out
+ cc -O2 -g -o probe ${./probe.c}
+ valgrind --tool=memcheck --xml=yes --xml-file=$out/memcheck.xml \
+ --track-origins=yes --error-limit=no --num-callers=12 \
+ --expensive-definedness-checks=yes ./probe > $out/stdout 2> $out/stderr
+ echo $? > $out/exit
+ objdump -d probe > $out/probe.dis
+''
diff --git a/etc/spike/penumbra/default.nix b/etc/spike/penumbra/default.nix
@@ -0,0 +1,51 @@
+# Spike 1: Penumbra's audit library under vestigia, on x86_64-linux.
+#
+# nix build --impure -f etc/spike/penumbra traces
+#
+# Two builds are traced. `audited` is the engagement's own library:
+# the exact machine code audited, whose sites carry function names
+# but no source lines. `lines` is the same build with line tables
+# kept, so its sites name source lines. Keeping them perturbs the
+# crate's symbol hashes and a few inlining decisions (16 of 546
+# functions differ once names and addresses are normalised), so the
+# two are compared by function.
+let
+ system = "x86_64-linux";
+ vestigia = builtins.getFlake (toString ../../..);
+ penumbra = builtins.getFlake
+ "path:/Users/jtobin/src/ppad/research/corpus/penumbra/harness";
+ pkgs = import vestigia.inputs.nixpkgs { inherit system; };
+
+ audited = penumbra.packages.${system}.audit;
+
+ lines = audited.overrideAttrs (o: {
+ pname = "penumbra-audit-lines";
+ CARGO_PROFILE_RELEASE_DEBUG = "line-tables-only";
+ dontStrip = true;
+ });
+
+ harnessFor = lib: pkgs.runCommandCC "penumbra-vestigia-harness" { } ''
+ mkdir -p $out/bin
+ cc -O2 -g -o $out/bin/harness ${./harness.c} \
+ -I${vestigia.packages.${system}.include}/include \
+ -I${vestigia.lib.${system}.valgrindDev}/include \
+ -L${lib}/lib -lpenumbra_audit -Wl,-rpath,${lib}/lib
+ '';
+
+ traceOf = build: lib: root: vestigia.lib.${system}.traceOf {
+ name = "penumbra-${build}-${root}";
+ harness = "${harnessFor lib}/bin/harness";
+ args = [ root "4" ];
+ };
+
+ roots = [ "public_key" "key_agreement" "spend_auth_sign" ];
+in
+{
+ inherit audited lines;
+
+ traces = pkgs.linkFarm "penumbra-traces" (
+ map (r: { name = "audited/${r}"; path = traceOf "audited" audited r; })
+ roots
+ ++ map (r: { name = "lines/${r}"; path = traceOf "lines" lines r; })
+ roots);
+}
diff --git a/etc/spike/penumbra/harness.c b/etc/spike/penumbra/harness.c
@@ -0,0 +1,89 @@
+/*
+ * Penumbra's three secret-key roots under vestigia: each call takes
+ * fresh random secrets, marked secret before the call, with the
+ * outputs Penumbra reveals marked public after it.
+ *
+ * usage: harness ROOT [RUNS]
+ * ROOT is public_key, key_agreement, or spend_auth_sign
+ */
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "vestigia.h"
+
+void penumbra_audit_public_key(uint8_t *ws);
+void penumbra_audit_key_agreement(uint8_t *ws);
+void penumbra_audit_spend_auth_sign(uint8_t *ws);
+
+static uint64_t state = 0x9e3779b97f4a7c15ULL;
+
+static uint64_t splitmix(void) {
+ uint64_t z = (state += 0x9e3779b97f4a7c15ULL);
+ z = (z ^ (z >> 30)) * 0xbf58476d1ce4e5b9ULL;
+ z = (z ^ (z >> 27)) * 0x94d049bb133111ebULL;
+ return z ^ (z >> 31);
+}
+
+static void fill(uint8_t *p, size_t n) {
+ for (size_t i = 0; i < n; i++) p[i] = (uint8_t)splitmix();
+}
+
+/* a canonical scalar: random little-endian bytes with the top byte
+ * cleared, below the decaf377 scalar modulus */
+static void scalar(uint8_t *p) {
+ fill(p, 32);
+ p[31] = 0;
+}
+
+static void public_key(void) {
+ uint8_t ws[64];
+ scalar(ws);
+ vestigia_secret(ws, 32);
+ penumbra_audit_public_key(ws);
+ vestigia_public(ws + 32, 32);
+}
+
+static void key_agreement(void) {
+ uint8_t peer[64];
+ uint8_t ws[96];
+ scalar(peer);
+ penumbra_audit_public_key(peer);
+ scalar(ws);
+ memcpy(ws + 32, peer + 32, 32);
+ vestigia_secret(ws, 32);
+ penumbra_audit_key_agreement(ws);
+}
+
+static void spend_auth_sign(void) {
+ uint8_t ws[208];
+ scalar(ws);
+ fill(ws + 32, 80);
+ fill(ws + 112, 32);
+ /* the key and the signing randomness are secret; the message is
+ * public */
+ vestigia_secret(ws, 112);
+ penumbra_audit_spend_auth_sign(ws);
+ vestigia_public(ws + 144, 64);
+}
+
+int main(int argc, char **argv) {
+ if (argc < 2) {
+ fprintf(stderr, "usage: harness ROOT [RUNS]\n");
+ return 2;
+ }
+ int runs = argc > 2 ? atoi(argv[2]) : 4;
+ void (*root)(void) = NULL;
+ if (strcmp(argv[1], "public_key") == 0) root = public_key;
+ else if (strcmp(argv[1], "key_agreement") == 0) root = key_agreement;
+ else if (strcmp(argv[1], "spend_auth_sign") == 0)
+ root = spend_auth_sign;
+ if (root == NULL) {
+ fprintf(stderr, "unknown root: %s\n", argv[1]);
+ return 2;
+ }
+ for (int i = 0; i < runs; i++) root();
+ printf("%s: %d run(s)\n", argv[1], runs);
+ return 0;
+}
diff --git a/flake.lock b/flake.lock
@@ -0,0 +1,88 @@
+{
+ "nodes": {
+ "flake-utils": {
+ "inputs": {
+ "systems": "systems"
+ },
+ "locked": {
+ "lastModified": 1731533236,
+ "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "nixpkgs": {
+ "locked": {
+ "lastModified": 1766840161,
+ "narHash": "sha256-Ss/LHpJJsng8vz1Pe33RSGIWUOcqM1fjrehjUkdrWio=",
+ "owner": "NixOS",
+ "repo": "nixpkgs",
+ "rev": "3edc4a30ed3903fdf6f90c837f961fa6b49582d1",
+ "type": "github"
+ },
+ "original": {
+ "owner": "NixOS",
+ "ref": "nixpkgs-unstable",
+ "repo": "nixpkgs",
+ "type": "github"
+ }
+ },
+ "ppad-nixpkgs": {
+ "inputs": {
+ "flake-utils": "flake-utils",
+ "nixpkgs": "nixpkgs"
+ },
+ "locked": {
+ "lastModified": 1766932084,
+ "narHash": "sha256-GvVsbTfW+B7IQ9K/QP2xcXJAm1lhBin1jYZWNjOzT+o=",
+ "ref": "master",
+ "rev": "353e61763b959b960a55321a85423501e3e9ed7a",
+ "revCount": 2,
+ "type": "git",
+ "url": "git://git.ppad.tech/nixpkgs.git"
+ },
+ "original": {
+ "ref": "master",
+ "type": "git",
+ "url": "git://git.ppad.tech/nixpkgs.git"
+ }
+ },
+ "root": {
+ "inputs": {
+ "flake-utils": [
+ "ppad-nixpkgs",
+ "flake-utils"
+ ],
+ "nixpkgs": [
+ "ppad-nixpkgs",
+ "nixpkgs"
+ ],
+ "ppad-nixpkgs": "ppad-nixpkgs"
+ }
+ },
+ "systems": {
+ "locked": {
+ "lastModified": 1681028828,
+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+ "owner": "nix-systems",
+ "repo": "default",
+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-systems",
+ "repo": "default",
+ "type": "github"
+ }
+ }
+ },
+ "root": "root",
+ "version": 7
+}
diff --git a/flake.nix b/flake.nix
@@ -0,0 +1,94 @@
+{
+ description = "Where an execution depended on a secret.";
+
+ inputs = {
+ ppad-nixpkgs = {
+ type = "git";
+ url = "git://git.ppad.tech/nixpkgs.git";
+ ref = "master";
+ };
+ flake-utils.follows = "ppad-nixpkgs/flake-utils";
+ nixpkgs.follows = "ppad-nixpkgs/nixpkgs";
+ };
+
+ outputs = { self, nixpkgs, flake-utils, ppad-nixpkgs }:
+ flake-utils.lib.eachDefaultSystem (system:
+ let
+ pkgs = import nixpkgs { inherit system; };
+ lib = pkgs.lib;
+
+ hpkgs = pkgs.haskell.packages.ghc910.extend (new: old: {
+ vestigia = new.callCabal2nix "vestigia" ./. { };
+ });
+
+ # memcheck runs on Linux only; elsewhere the command can still
+ # read a run's XML
+ linux = pkgs.stdenv.hostPlatform.isLinux;
+ valgrind = pkgs.valgrind;
+
+ # the harness-side header; a harness build also needs
+ # valgrind's own (valgrindDev)
+ include = pkgs.runCommand "vestigia-include" { } ''
+ mkdir -p $out/include
+ cp ${./include/vestigia.h} $out/include/vestigia.h
+ '';
+
+ # the command, with the valgrind it was built against baked in
+ vestigia = pkgs.runCommand "vestigia" {
+ nativeBuildInputs = [ pkgs.makeWrapper ];
+ } ''
+ mkdir -p $out/bin
+ makeWrapper ${hpkgs.vestigia}/bin/vestigia $out/bin/vestigia \
+ ${lib.optionalString linux
+ "--set-default VESTIGIA_VALGRIND ${valgrind}/bin/valgrind"}
+ ln -s ${include}/include $out/include
+ '';
+
+ # one harness run under memcheck, as a derivation: its report,
+ # memcheck's XML, and what the harness printed. A harness that
+ # fails still leaves a report of what ran; a run vestigia could
+ # not read fails the build.
+ traceOf = { name, harness, args ? [ ] }:
+ pkgs.runCommand "vestigia-trace-${name}" { } ''
+ mkdir -p $out
+ set +e
+ ${vestigia}/bin/vestigia run \
+ --xml $out/memcheck.xml --out $out/trace.json \
+ -- ${harness} ${lib.escapeShellArgs args} \
+ > $out/stdout 2> $out/stderr
+ echo $? > $out/status
+ set -e
+ test -s $out/trace.json || {
+ cat $out/stderr >&2
+ exit 1
+ }
+ '';
+ in
+ {
+ packages.default = vestigia;
+ packages.include = include;
+
+ lib = {
+ inherit traceOf;
+ valgrindDev = valgrind.dev;
+ };
+
+ checks.default = hpkgs.vestigia;
+
+ devShells.default = hpkgs.shellFor {
+ packages = p: [ p.vestigia ];
+ buildInputs = [
+ hpkgs.cabal-install
+ pkgs.stdenv.cc
+ ] ++ lib.optional linux valgrind;
+
+ shellHook = ''
+ PS1="[vestigia] \w$ "
+ echo "entering ${system} shell, using"
+ echo "ghc: $(${hpkgs.ghc}/bin/ghc --version)"
+ echo "cabal: $(${hpkgs.cabal-install}/bin/cabal --version)"
+ '';
+ };
+ }
+ );
+}
diff --git a/include/vestigia.h b/include/vestigia.h
@@ -0,0 +1,31 @@
+/*
+ * vestigia.h: the two marks a vestigia harness makes.
+ *
+ * Copyright (c) 2026 Jared Tobin
+ * License: MIT
+ *
+ * vestigia_secret marks n bytes at p as secret: under memcheck they
+ * become undefined, so every branch and address computed from them
+ * is reported, with this mark as the origin. vestigia_public marks
+ * n bytes at p as public again: outputs the function is meant to
+ * reveal (a signature, a public key), so that writing them out is
+ * not reported. Outside valgrind both are no-ops.
+ *
+ * Mark a secret after writing it and before the call; mark the
+ * outputs after the call.
+ */
+#ifndef VESTIGIA_H
+#define VESTIGIA_H
+
+#include <stddef.h>
+#include <valgrind/memcheck.h>
+
+static inline void vestigia_secret(void *p, size_t n) {
+ (void)VALGRIND_MAKE_MEM_UNDEFINED(p, n);
+}
+
+static inline void vestigia_public(void *p, size_t n) {
+ (void)VALGRIND_MAKE_MEM_DEFINED(p, n);
+}
+
+#endif
diff --git a/lib/Vestigia/Json.hs b/lib/Vestigia/Json.hs
@@ -0,0 +1,69 @@
+{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module: Vestigia.Json
+-- Copyright: (c) 2026 Jared Tobin
+-- License: MIT
+-- Maintainer: Jared Tobin <jared@ppad.tech>
+--
+-- A JSON value and its encoding: enough to write a report, with
+-- object keys in the order given.
+
+module Vestigia.Json (
+ Value(..)
+ , encode
+ ) where
+
+import Data.Char (ord)
+import qualified Data.Text as T
+import Numeric (showHex)
+
+-- | A JSON value. An object keeps its keys in the order given.
+data Value =
+ Null
+ | Bool !Bool
+ | Number !Integer
+ | String !T.Text
+ | Array ![Value]
+ | Object ![(T.Text, Value)]
+ deriving (Eq, Show)
+
+-- | The value's encoding, indented two spaces per level.
+--
+-- >>> encode (Object [("a", Array [Number 1, Null])])
+-- "{\n \"a\": [\n 1,\n null\n ]\n}\n"
+encode :: Value -> T.Text
+encode v = go 0 v <> "\n"
+ where
+ go :: Int -> Value -> T.Text
+ go d x = case x of
+ Null -> "null"
+ Bool b -> if b then "true" else "false"
+ Number n -> T.pack (show n)
+ String s -> str s
+ Array [] -> "[]"
+ Array xs -> "[\n" <> T.intercalate ",\n"
+ [ pad (d + 1) <> go (d + 1) y | y <- xs ]
+ <> "\n" <> pad d <> "]"
+ Object [] -> "{}"
+ Object kvs -> "{\n" <> T.intercalate ",\n"
+ [ pad (d + 1) <> str k <> ": " <> go (d + 1) y
+ | (k, y) <- kvs ]
+ <> "\n" <> pad d <> "}"
+
+ pad d = T.replicate (2 * d) " "
+
+str :: T.Text -> T.Text
+str s = "\"" <> T.concatMap esc s <> "\""
+ where
+ esc c = case c of
+ '"' -> "\\\""
+ '\\' -> "\\\\"
+ '\n' -> "\\n"
+ '\r' -> "\\r"
+ '\t' -> "\\t"
+ _ | ord c < 0x20 ->
+ let h = showHex (ord c) ""
+ in T.pack ("\\u" <> replicate (4 - length h) '0' <> h)
+ | otherwise -> T.singleton c
diff --git a/lib/Vestigia/Memcheck.hs b/lib/Vestigia/Memcheck.hs
@@ -0,0 +1,173 @@
+{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module: Vestigia.Memcheck
+-- Copyright: (c) 2026 Jared Tobin
+-- License: MIT
+-- Maintainer: Jared Tobin <jared@ppad.tech>
+--
+-- What a memcheck run reported, read from its XML (protocol
+-- version 4 and later): each error context with its kind, its
+-- stack, the origin of the undefined value where memcheck tracked
+-- one, and how many times it occurred.
+
+module Vestigia.Memcheck (
+ Frame(..)
+ , Origin(..)
+ , MemError(..)
+ , Memcheck(..)
+ , readMemcheck
+ ) where
+
+import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Numeric (readHex)
+import Text.Read (readMaybe)
+
+import Vestigia.Xml
+
+-- | One stack frame: the instruction address, and what debug
+-- information says of it.
+data Frame = Frame {
+ frIp :: !Integer
+ , frObj :: !(Maybe T.Text)
+ , frFn :: !(Maybe T.Text)
+ , frFile :: !(Maybe T.Text)
+ , frLine :: !(Maybe Int)
+ } deriving (Eq, Show)
+
+-- | Where an undefined value came from: a client request (the
+-- harness's mark on a secret), something else memcheck named
+-- (an allocation, an uninitialised stack slot), or nothing
+-- tracked.
+data Origin =
+ ClientRequest ![Frame]
+ | OtherOrigin !T.Text ![Frame]
+ | NoOrigin
+ deriving (Eq, Show)
+
+-- | One error context.
+data MemError = MemError {
+ meKind :: !T.Text
+ , meWhat :: !T.Text
+ , meStack :: ![Frame]
+ , meOrigin :: !Origin
+ , meCount :: !Int
+ } deriving (Eq, Show)
+
+-- | A run: the tool's version, the command it ran, whether it
+-- finished, and its errors in the order reported.
+data Memcheck = Memcheck {
+ mcVersion :: !(Maybe T.Text)
+ , mcCommand :: ![T.Text]
+ , mcFinished :: !Bool
+ , mcErrors :: ![MemError]
+ } deriving (Eq, Show)
+
+-- | Read a memcheck XML document.
+readMemcheck :: T.Text -> Either String Memcheck
+readMemcheck t = do
+ root <- parseDocument t
+ case root of
+ Element "valgrindoutput" _ -> pure ()
+ _ -> Left "not a valgrind XML document"
+ case fmap textOf (child "protocoltool" root) of
+ Just "memcheck" -> pure ()
+ other -> Left ("not a memcheck run: " <> show other)
+ let counts = M.fromList
+ [ (textOf u, n)
+ | ec <- children "errorcounts" root
+ , p <- children "pair" ec
+ , Just u <- [ child "unique" p ]
+ , Just c <- [ child "count" p ]
+ , Just n <- [ readMaybe (T.unpack (textOf c)) ]
+ ]
+ errs <- traverse (memError counts) (children "error" root)
+ pure Memcheck {
+ mcVersion = version root
+ , mcCommand =
+ [ textOf x
+ | as <- children "args" root
+ , av <- children "argv" as
+ , x <- elementsOf av ]
+ , mcFinished = any ((== "FINISHED") . textOf)
+ [ s | st <- children "status" root
+ , s <- children "state" st ]
+ , mcErrors = errs
+ }
+ where
+ elementsOf n = case n of
+ Element _ cs -> [ c | c@(Element m _) <- cs
+ , m == "exe" || m == "arg" ]
+ Text _ -> []
+
+ -- "Using Valgrind-3.26.0 and LibVEX; ..."
+ version root = case
+ [ v
+ | pre <- children "preamble" root
+ , l <- children "line" pre
+ , let w = textOf l
+ , "Using Valgrind-" `T.isPrefixOf` w
+ , let v = T.takeWhile (/= ' ') (T.drop 15 w) ] of
+ (v : _) -> Just v
+ [] -> Nothing
+
+memError :: M.Map T.Text Int -> Node -> Either String MemError
+memError counts n = do
+ kind <- need "kind"
+ let what = maybe "" textOf (child "what" n)
+ stacks = children "stack" n
+ unique = maybe "" textOf (child "unique" n)
+ stack <- case stacks of
+ (s : _) -> traverse frame (children "frame" s)
+ [] -> pure []
+ -- the origin is the auxwhat that names it, and the stack that
+ -- follows it
+ origin <- case (originText, drop 1 stacks) of
+ (Just w, (s : _)) -> do
+ fs <- traverse frame (children "frame" s)
+ pure (if "client request" `T.isInfixOf` w
+ then ClientRequest fs
+ else OtherOrigin w fs)
+ (Just w, []) -> pure (OtherOrigin w [])
+ (Nothing, _) -> pure NoOrigin
+ pure MemError {
+ meKind = kind
+ , meWhat = what
+ , meStack = stack
+ , meOrigin = origin
+ , meCount = fromMaybe 1 (M.lookup unique counts)
+ }
+ where
+ need k = maybe (Left ("an error without " <> T.unpack k)) (pure
+ . textOf) (child k n)
+ originText = case
+ [ w | a <- children "auxwhat" n
+ , let w = textOf a
+ , "was created by" `T.isInfixOf` w ] of
+ (w : _) -> Just w
+ [] -> Nothing
+
+frame :: Node -> Either String Frame
+frame n = do
+ ip <- case fmap textOf (child "ip" n) of
+ Just t | Just v <- hex t -> pure v
+ other -> Left ("a frame without an address: " <> show other)
+ pure Frame {
+ frIp = ip
+ , frObj = field "obj"
+ , frFn = field "fn"
+ , frFile = case (field "dir", field "file") of
+ (Just d, Just f) -> Just (d <> "/" <> f)
+ (Nothing, Just f) -> Just f
+ _ -> Nothing
+ , frLine = field "line" >>= readMaybe . T.unpack
+ }
+ where
+ field k = fmap textOf (child k n)
+ hex t = case readHex (T.unpack (stripPrefix0x t)) of
+ [ (v, "") ] -> Just v
+ _ -> Nothing
+ stripPrefix0x t = fromMaybe t (T.stripPrefix "0x" t)
diff --git a/lib/Vestigia/Trace.hs b/lib/Vestigia/Trace.hs
@@ -0,0 +1,198 @@
+{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module: Vestigia.Trace
+-- Copyright: (c) 2026 Jared Tobin
+-- License: MIT
+-- Maintainer: Jared Tobin <jared@ppad.tech>
+--
+-- A run's leakage, read from what memcheck reported. An error
+-- whose undefined value was created by a client request descends
+-- from a byte the harness marked secret, so it is a site where the
+-- execution depended on the secret: a branch (`control`), an
+-- address computed from it (`address`), or a system call handed
+-- it (`syscall`). Every other uninitialised read is kept apart as
+-- `unrelated`, and memory errors as `faults`: neither says
+-- anything about the secret. Leak reports say nothing about the
+-- execution and are dropped.
+
+module Vestigia.Trace (
+ Class(..)
+ , Site(..)
+ , Trace(..)
+ , trace
+ , traceJson
+ , traceSummary
+ , classText
+ ) where
+
+import qualified Data.List as L
+import qualified Data.Map.Strict as M
+import qualified Data.Text as T
+import Numeric (showHex)
+
+import Vestigia.Json
+import Vestigia.Memcheck
+
+-- | How an execution depended on a secret at a site.
+data Class =
+ Control
+ | Address
+ | Syscall
+ deriving (Eq, Ord, Show)
+
+-- | One instruction that depended on a secret, with every stack
+-- that reached it.
+data Site = Site {
+ siClass :: !Class
+ , siFrame :: !Frame
+ , siCount :: !Int
+ , siStacks :: ![[Frame]]
+ } deriving (Eq, Show)
+
+-- | A run's sites, in the order first reported, and what memcheck
+-- reported that says nothing about the secret.
+data Trace = Trace {
+ trRun :: !Memcheck
+ , trSites :: ![Site]
+ , trUnrelated :: ![MemError]
+ , trFaults :: ![MemError]
+ } deriving (Eq, Show)
+
+classText :: Class -> T.Text
+classText c = case c of
+ Control -> "control"
+ Address -> "address"
+ Syscall -> "syscall"
+
+-- what a secret-originated error says about the execution
+classify :: MemError -> Maybe Class
+classify e = case (meOrigin e, meKind e) of
+ (ClientRequest _, "UninitCondition") -> Just Control
+ (ClientRequest _, "UninitValue") -> Just Address
+ (ClientRequest _, "SyscallParam") -> Just Syscall
+ _ -> Nothing
+
+uninitialised :: MemError -> Bool
+uninitialised e =
+ meKind e `elem` [ "UninitCondition", "UninitValue", "SyscallParam" ]
+
+-- | The run's leakage. Sites are one per instruction and class:
+-- memcheck reports one context per distinct stack, and the
+-- instruction is what depended on the secret, whatever called
+-- it.
+trace :: Memcheck -> Trace
+trace mc = Trace {
+ trRun = mc
+ , trSites =
+ [ Site {
+ siClass = c
+ , siFrame = top
+ , siCount = sum (fmap (meCount . snd) xs)
+ , siStacks = L.nub (fmap (meStack . snd) xs)
+ }
+ | k@(c, _) <- order
+ , Just xs@((top, _) : _) <- [ M.lookup k grouped ] ]
+ , trUnrelated =
+ [ e | e <- mcErrors mc, uninitialised e
+ , classify e == Nothing ]
+ , trFaults =
+ [ e | e <- mcErrors mc, not (uninitialised e)
+ , not ("Leak_" `T.isPrefixOf` meKind e) ]
+ }
+ where
+ tagged =
+ [ ((c, top), e)
+ | e <- mcErrors mc
+ , Just c <- [ classify e ]
+ , (top : _) <- [ meStack e ] ]
+ order = L.nub (fmap (\((c, top), _) -> (c, frIp top)) tagged)
+ grouped = M.fromListWith (flip (<>))
+ [ ((c, frIp top), [ (top, e) ]) | ((c, top), e) <- tagged ]
+
+-- | The report: @vestigia/trace-v1@.
+traceJson :: T.Text -> Maybe Int -> Trace -> Value
+traceJson version exit tr = Object
+ [ ("schema", String "vestigia/trace-v1")
+ , ("tool", Object [ ("name", String "vestigia")
+ , ("version", String version) ])
+ , ("valgrind", maybe Null String (mcVersion mc))
+ , ("command", Array (fmap String (mcCommand mc)))
+ , ("finished", Bool (mcFinished mc))
+ , ("exit", maybe Null (Number . toInteger) exit)
+ , ("summary", Object
+ [ ("control", count Control)
+ , ("address", count Address)
+ , ("syscall", count Syscall)
+ , ("unrelated", Number (toInteger (length (trUnrelated tr))))
+ , ("faults", Number (toInteger (length (trFaults tr))))
+ ])
+ , ("sites", Array (fmap siteJson (trSites tr)))
+ , ("unrelated", Array (fmap errorJson (trUnrelated tr)))
+ , ("faults", Array (fmap errorJson (trFaults tr)))
+ ]
+ where
+ mc = trRun tr
+ count c = Number (toInteger (length
+ [ () | s <- trSites tr, siClass s == c ]))
+
+siteJson :: Site -> Value
+siteJson s = Object $
+ [ ("class", String (classText (siClass s))) ]
+ <> frameFields (siFrame s)
+ <> [ ("count", Number (toInteger (siCount s)))
+ , ("stacks", Array [ Array (fmap frameJson st)
+ | st <- siStacks s ])
+ ]
+
+errorJson :: MemError -> Value
+errorJson e = Object
+ [ ("kind", String (meKind e))
+ , ("what", String (meWhat e))
+ , ("origin", case meOrigin e of
+ ClientRequest _ -> String "client request"
+ OtherOrigin w _ -> String w
+ NoOrigin -> Null)
+ , ("count", Number (toInteger (meCount e)))
+ , ("stack", Array (fmap frameJson (meStack e)))
+ ]
+
+frameJson :: Frame -> Value
+frameJson = Object . frameFields
+
+frameFields :: Frame -> [(T.Text, Value)]
+frameFields f =
+ [ ("ip", String (hex (frIp f)))
+ , ("object", maybe Null String (frObj f))
+ , ("function", maybe Null String (frFn f))
+ , ("file", maybe Null String (frFile f))
+ , ("line", maybe Null (Number . toInteger) (frLine f))
+ ]
+
+hex :: Integer -> T.Text
+hex n = "0x" <> T.pack (showHex n "")
+
+-- | One line per site, for a reader at a terminal.
+traceSummary :: Trace -> T.Text
+traceSummary tr = T.unlines $
+ [ T.intercalate " "
+ [ classText (siClass s)
+ , hex (frIp (siFrame s))
+ , maybe "?" id (frFn (siFrame s))
+ , location (siFrame s)
+ , "x" <> T.pack (show (siCount s)) ]
+ | s <- trSites tr ]
+ <> [ T.pack (show (length (trSites tr))) <> " secret-dependent \
+ \site(s); " <> T.pack (show (length (trUnrelated tr)))
+ <> " unrelated; " <> T.pack (show (length (trFaults tr)))
+ <> " fault(s)" ]
+ where
+ location f = case (frFile f, frLine f) of
+ (Just p, Just l) -> base p <> ":" <> T.pack (show l)
+ (Just p, Nothing) -> base p
+ _ -> maybe "?" id (frObj f)
+ base p = last' p (T.splitOn "/" p)
+ last' d xs = case reverse xs of
+ (x : _) -> x
+ [] -> d
diff --git a/lib/Vestigia/Xml.hs b/lib/Vestigia/Xml.hs
@@ -0,0 +1,152 @@
+{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module: Vestigia.Xml
+-- Copyright: (c) 2026 Jared Tobin
+-- License: MIT
+-- Maintainer: Jared Tobin <jared@ppad.tech>
+--
+-- A reader for the XML memcheck writes: elements and text, with
+-- the declaration, comments, and attributes skipped and the
+-- standard entities decoded. It is not a general XML parser, and
+-- refuses what it does not understand rather than guessing.
+
+module Vestigia.Xml (
+ Node(..)
+ , parseDocument
+ , children
+ , child
+ , textOf
+ ) where
+
+import Data.Char (chr, isAlphaNum, isDigit, isHexDigit, isSpace)
+import qualified Data.Text as T
+import Numeric (readDec, readHex)
+
+-- | An element (its name and contents) or a run of text.
+data Node =
+ Element !T.Text ![Node]
+ | Text !T.Text
+ deriving (Eq, Show)
+
+-- | The document's root element.
+--
+-- >>> parseDocument "<?xml version=\"1.0\"?><a><b>x & y</b></a>"
+-- Right (Element "a" [Element "b" [Text "x & y"]])
+parseDocument :: T.Text -> Either String Node
+parseDocument t = do
+ (root, rest) <- element (misc t)
+ if T.null (misc rest)
+ then pure root
+ else Left "trailing content after the root element"
+
+-- | The child elements of a node with the given name.
+children :: T.Text -> Node -> [Node]
+children name n = case n of
+ Element _ cs -> [ c | c@(Element m _) <- cs, m == name ]
+ Text _ -> []
+
+-- | The first child element with the given name.
+child :: T.Text -> Node -> Maybe Node
+child name n = case children name n of
+ (c : _) -> Just c
+ [] -> Nothing
+
+-- | The text a node holds, stripped.
+textOf :: Node -> T.Text
+textOf n = case n of
+ Text t -> T.strip t
+ Element _ cs -> T.strip (T.concat [ t | Text t <- cs ])
+
+-- whitespace, the declaration, comments, and a doctype
+misc :: T.Text -> T.Text
+misc t0 =
+ let t = T.dropWhile isSpace t0
+ in if "<?" `T.isPrefixOf` t then misc (after "?>" t)
+ else if "<!--" `T.isPrefixOf` t then misc (after "-->" t)
+ else if "<!" `T.isPrefixOf` t then misc (after ">" t)
+ else t
+
+after :: T.Text -> T.Text -> T.Text
+after delim t = T.drop (T.length delim) (snd (T.breakOn delim t))
+
+element :: T.Text -> Either String (Node, T.Text)
+element t0 = case T.uncons t0 of
+ Just ('<', t1) -> do
+ let (name, t2) = T.span nameChar t1
+ if T.null name then Left "an element without a name" else do
+ let t3 = skipAttributes t2
+ if "/>" `T.isPrefixOf` t3
+ then pure (Element name [], T.drop 2 t3)
+ else case T.uncons t3 of
+ Just ('>', t4) -> do
+ (cs, t5) <- content name t4 []
+ pure (Element name (reverse cs), t5)
+ _ -> Left ("malformed start tag: " <> T.unpack name)
+ _ -> Left "expected an element"
+
+-- attributes carry nothing memcheck's reader needs
+skipAttributes :: T.Text -> T.Text
+skipAttributes t = case T.uncons (T.dropWhile isSpace t) of
+ Just (c, _) | c == '>' || c == '/' -> T.dropWhile isSpace t
+ Just _ ->
+ let t1 = T.dropWhile (\c -> c /= '"' && c /= '>' && c /= '/')
+ (T.dropWhile isSpace t)
+ in case T.uncons t1 of
+ Just ('"', t2) ->
+ skipAttributes (T.drop 1 (T.dropWhile (/= '"') t2))
+ _ -> t1
+ Nothing -> t
+
+content
+ :: T.Text -> T.Text -> [Node] -> Either String ([Node], T.Text)
+content name t acc
+ | T.null t = Left ("unclosed element: " <> T.unpack name)
+ | "</" `T.isPrefixOf` t =
+ let (close, rest) = T.span nameChar (T.drop 2 t)
+ rest' = T.dropWhile isSpace rest
+ in if close /= name
+ then Left ("mismatched close tag: " <> T.unpack close)
+ else case T.uncons rest' of
+ Just ('>', r) -> pure (acc, r)
+ _ -> Left ("malformed close tag: " <> T.unpack close)
+ | "<!--" `T.isPrefixOf` t = content name (after "-->" t) acc
+ | "<" `T.isPrefixOf` t = do
+ (n, rest) <- element t
+ content name rest (n : acc)
+ | otherwise = do
+ let (raw, rest) = T.break (== '<') t
+ txt <- entities raw
+ content name rest (Text txt : acc)
+
+nameChar :: Char -> Bool
+nameChar c = isAlphaNum c || c == '_' || c == '-' || c == '.'
+ || c == ':'
+
+entities :: T.Text -> Either String T.Text
+entities t = case T.breakOn "&" t of
+ (pre, rest)
+ | T.null rest -> pure pre
+ | otherwise -> do
+ let (ent, rest') = T.breakOn ";" (T.drop 1 rest)
+ if T.null rest' then Left "an unterminated entity" else do
+ c <- entity ent
+ more <- entities (T.drop 1 rest')
+ pure (pre <> T.singleton c <> more)
+
+entity :: T.Text -> Either String Char
+entity e = case T.unpack e of
+ "amp" -> pure '&'
+ "lt" -> pure '<'
+ "gt" -> pure '>'
+ "quot" -> pure '"'
+ "apos" -> pure '\''
+ ('#' : 'x' : hs) | not (null hs), all isHexDigit hs ->
+ code (readHex hs)
+ ('#' : ds) | not (null ds), all isDigit ds -> code (readDec ds)
+ _ -> Left ("an unknown entity: &" <> T.unpack e <> ";")
+ where
+ code rs = case rs of
+ [ (n, "") ] | n <= 0x10FFFF -> pure (chr n)
+ _ -> Left ("a malformed character reference: " <> T.unpack e)
diff --git a/plans/IMPL1.md b/plans/IMPL1.md
@@ -0,0 +1,56 @@
+# IMPL1: vestigia, the leakage trace in act
+
+## End
+
+Decide, for an execution of an audited function, which of its
+instructions branched on a secret or computed an address from one,
+and say where each sits in the source. This is the constant-time
+discipline read off a running program: exact on the paths executed,
+free of timing noise, and localised to the instruction. (synthesis
+`plans/REDESIGN.md` gives the reasons.)
+
+## Means
+
+valgrind's memcheck already tracks, bit by bit, which values are
+defined. A harness marks the secret's bytes undefined before calling
+the function (`VALGRIND_MAKE_MEM_UNDEFINED`, a no-op outside
+valgrind) and marks its outputs defined after. memcheck then reports
+every conditional branch whose condition, and every load or store
+whose address, depends on a marked byte, and `--track-origins` names
+the client request as the origin. This is the ctgrind technique.
+
+vestigia supplies:
+
+- `include/vestigia.h`: `vestigia_secret` and `vestigia_public`, the
+ two marks, for harness writers.
+- `vestigia run -- PROGRAM ARGS`: runs the harness under memcheck
+ with fixed settings and writes a report.
+- `vestigia read FILE.xml`: the same report from memcheck's XML.
+- The report (`vestigia/trace-v1`, JSON): secret-dependent sites,
+ one per instruction and class (`control`, `address`, `syscall`),
+ with function, file, line, count, and caller stacks; errors whose
+ origin is not a secret, kept apart; and the run's provenance.
+- A nix function that runs a harness as a derivation, so a trace
+ for x86_64-linux runs on whatever builds for it.
+
+## Spikes
+
+The tool earns its place only if it reproduces known results:
+
+1. Penumbra on x86_64-linux: the audit library rebuilt with line
+ tables (its `.text` checked identical to the audited build), a C
+ harness calling the three roots on random secrets. Do the
+ findings cover elenchus's leaks (ark-ff modulus compares,
+ decaf377 invsqrt table lookups, the double-and-add)?
+2. ppad-poly1305 with the planted mutants, and ppad-secp256k1 as a
+ constant-time control: are the planted leaks found, and does
+ the GHC runtime stay quiet once origins are filtered?
+
+## Constraints
+
+- Haskell2010, boot libraries only (base, bytestring, containers,
+ text, process, directory, filepath); tasty for tests.
+- memcheck XML is parsed by a small reader of our own; JSON is
+ written by a small encoder of our own.
+- valgrind enters through nix as a tool. It does not run on Darwin;
+ traces there need a Linux cell.
diff --git a/test/Main.hs b/test/Main.hs
@@ -0,0 +1,165 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (
+ main
+ ) where
+
+import qualified Data.ByteString as BS
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Vestigia.Json
+import Vestigia.Memcheck
+import Vestigia.Trace
+import Vestigia.Xml
+
+main :: IO ()
+main = defaultMain $ testGroup "vestigia"
+ [ xmlTests
+ , memcheckTests
+ , traceTests
+ , jsonTests
+ ]
+
+xmlTests :: TestTree
+xmlTests = testGroup "xml"
+ [ testCase "elements, text, and entities" $
+ parseDocument "<?xml version=\"1.0\"?>\n<a>\n <b>x & \
+ \<y> AB</b><c/></a>"
+ @?= Right (Element "a"
+ [ Text "\n ", Element "b" [ Text "x & <y> AB" ]
+ , Element "c" [] ])
+
+ , testCase "attributes and comments are skipped" $
+ parseDocument "<!-- head --><a k=\"v>\" j='w'><!-- c --><b/></a>"
+ @?= Right (Element "a" [ Element "b" [] ])
+
+ , testCase "a mismatched close tag is refused" $
+ isLeft (parseDocument "<a><b></a></b>") @? "accepted"
+
+ , testCase "an unclosed element is refused" $
+ isLeft (parseDocument "<a><b>text") @? "accepted"
+
+ , testCase "an unknown entity is refused" $
+ isLeft (parseDocument "<a> </a>") @? "accepted"
+ ]
+
+memcheckTests :: TestTree
+memcheckTests = testGroup "memcheck"
+ [ testCase "the probe run reads whole" $ do
+ mc <- fixture "probe.xml"
+ mcVersion mc @?= Just "3.26.0"
+ mcFinished mc @?= True
+ mcCommand mc @?= [ "./probe" ]
+ fmap meKind (mcErrors mc) @?= [ "UninitValue", "UninitValue" ]
+ fmap meCount (mcErrors mc) @?= [ 1, 1 ]
+ case mcErrors mc of
+ (e : _) -> do
+ fmap frFn (meStack e) @?= [ Just "lookup", Just "main" ]
+ fmap frLine (meStack e) @?= [ Just 16, Just 31 ]
+ case meOrigin e of
+ ClientRequest (o : _) -> frLine o @?= Just 30
+ other -> assertFailure ("origin: " <> show other)
+ [] -> assertFailure "no errors read"
+
+ , testCase "a document from another tool is refused" $
+ isLeft (readMemcheck "<valgrindoutput><protocoltool>helgrind\
+ \</protocoltool></valgrindoutput>")
+ @? "accepted"
+ ]
+
+traceTests :: TestTree
+traceTests = testGroup "trace"
+ [ testCase "the probe's secret addresses are its sites" $ do
+ tr <- trace <$> fixture "probe.xml"
+ fmap (\s -> (siClass s, frFn (siFrame s), frLine (siFrame s)))
+ (trSites tr)
+ @?= [ (Address, Just "lookup", Just 16)
+ , (Address, Just "main", Just 33) ]
+ trUnrelated tr @?= []
+ trFaults tr @?= []
+
+ , testCase "only a secret's descendants are sites" $ do
+ tr <- trace <$> either assertFailure pure (readMemcheck mixed)
+ fmap (\s -> (siClass s, frIp (siFrame s), siCount s))
+ (trSites tr)
+ @?= [ (Control, 0x10, 5) ]
+ fmap meKind (trUnrelated tr) @?= [ "UninitValue" ]
+ fmap meKind (trFaults tr) @?= [ "InvalidRead" ]
+
+ , testCase "one site per instruction, whatever called it" $ do
+ tr <- trace <$> either assertFailure pure (readMemcheck twoCallers)
+ fmap (\s -> (frIp (siFrame s), siCount s, length (siStacks s)))
+ (trSites tr)
+ @?= [ (0x10, 7, 2) ]
+ ]
+
+jsonTests :: TestTree
+jsonTests = testGroup "json"
+ [ testCase "objects keep their order and strings escape" $
+ encode (Object [ ("b", Number 1)
+ , ("a", String "q\"\n\1") ])
+ @?= "{\n \"b\": 1,\n \"a\": \"q\\\"\\n\\u0001\"\n}\n"
+ ]
+
+fixture :: FilePath -> IO Memcheck
+fixture f = do
+ b <- BS.readFile ("test/fixtures/" <> f)
+ either assertFailure pure (readMemcheck (TE.decodeUtf8 b))
+
+isLeft :: Either a b -> Bool
+isLeft e = case e of
+ Left _ -> True
+ Right _ -> False
+
+-- a secret branch, an uninitialised heap read, a bad read, and a
+-- leak report
+mixed :: T.Text
+mixed = doc
+ [ err "0x0" "UninitCondition" "0x10"
+ (Just "Uninitialised value was created by a client request")
+ , err "0x1" "UninitValue" "0x20"
+ (Just "Uninitialised value was created by a heap allocation")
+ , err "0x2" "InvalidRead" "0x30" Nothing
+ , err "0x3" "Leak_PossiblyLost" "0x40" Nothing
+ ]
+ [ ("0x0", 5), ("0x1", 1), ("0x2", 1) ]
+
+-- one secret branch reached by two callers
+twoCallers :: T.Text
+twoCallers = doc
+ [ errStack "0x0" "UninitCondition" [ "0x10", "0x40" ]
+ , errStack "0x1" "UninitCondition" [ "0x10", "0x50" ]
+ ]
+ [ ("0x0", 3), ("0x1", 4) ]
+ where
+ errStack u k ips = T.concat
+ [ "<error><unique>", u, "</unique><kind>", k, "</kind>"
+ , "<what>w</what><stack>"
+ , T.concat [ "<frame><ip>" <> ip <> "</ip></frame>" | ip <- ips ]
+ , "</stack><auxwhat>Uninitialised value was created by a \
+ \client request</auxwhat><stack><frame><ip>0x1</ip>\
+ \</frame></stack></error>" ]
+
+doc :: [T.Text] -> [(T.Text, Int)] -> T.Text
+doc errs counts = T.concat $
+ [ "<?xml version=\"1.0\"?><valgrindoutput>"
+ , "<protocolversion>6</protocolversion>"
+ , "<protocoltool>memcheck</protocoltool>" ]
+ <> errs
+ <> [ "<errorcounts>" ]
+ <> [ "<pair><count>" <> T.pack (show n) <> "</count><unique>" <> u
+ <> "</unique></pair>" | (u, n) <- counts ]
+ <> [ "</errorcounts></valgrindoutput>" ]
+
+err :: T.Text -> T.Text -> T.Text -> Maybe T.Text -> T.Text
+err u k ip morigin = T.concat $
+ [ "<error><unique>", u, "</unique><kind>", k, "</kind>"
+ , "<what>w</what><stack><frame><ip>", ip, "</ip></frame></stack>" ]
+ <> case morigin of
+ Just o -> [ "<auxwhat>", o, "</auxwhat><stack><frame><ip>0x1"
+ , "</ip></frame></stack>" ]
+ Nothing -> []
+ <> [ "</error>" ]
diff --git a/test/fixtures/probe.xml b/test/fixtures/probe.xml
@@ -0,0 +1,144 @@
+<?xml version="1.0"?>
+
+<valgrindoutput>
+
+<protocolversion>6</protocolversion>
+<protocoltool>memcheck</protocoltool>
+
+<preamble>
+ <line>Memcheck, a memory error detector</line>
+ <line>Copyright (C) 2002-2024, and GNU GPL'd, by Julian Seward et al.</line>
+ <line>Using Valgrind-3.26.0 and LibVEX; rerun with -h for copyright info</line>
+ <line>Command: ./probe</line>
+</preamble>
+
+<pid>18</pid>
+<ppid>1</ppid>
+<tool>memcheck</tool>
+
+<args>
+ <vargv>
+ <exe>/nix/store/fp56mavabdv7v67y5j3b0ga3v6ygpyha-valgrind-3.26.0/bin/valgrind</exe>
+ <arg>--tool=memcheck</arg>
+ <arg>--xml=yes</arg>
+ <arg>--xml-file=/nix/store/hk357yxizs27h53q9m2ng9n86i7bg8ka-vestigia-probe/memcheck.xml</arg>
+ <arg>--track-origins=yes</arg>
+ <arg>--error-limit=no</arg>
+ <arg>--num-callers=12</arg>
+ <arg>--expensive-definedness-checks=yes</arg>
+ </vargv>
+ <argv>
+ <exe>./probe</exe>
+ </argv>
+</args>
+
+<status>
+ <state>RUNNING</state>
+ <time>00:00:00:00.138 </time>
+</status>
+
+<error>
+ <unique>0x0</unique>
+ <tid>1</tid>
+ <kind>UninitValue</kind>
+ <what>Use of uninitialised value of size 8</what>
+ <stack>
+ <frame>
+ <ip>0x400134B</ip>
+ <obj>/build/probe</obj>
+ <fn>lookup</fn>
+ <dir>/nix/store</dir>
+ <file>z0czkymlici75rf52ivnhrvnx455aafj-probe.c</file>
+ <line>16</line>
+ </frame>
+ <frame>
+ <ip>0x400116D</ip>
+ <obj>/build/probe</obj>
+ <fn>main</fn>
+ <dir>/nix/store</dir>
+ <file>z0czkymlici75rf52ivnhrvnx455aafj-probe.c</file>
+ <line>31</line>
+ </frame>
+ </stack>
+ <auxwhat>Uninitialised value was created by a client request</auxwhat>
+ <stack>
+ <frame>
+ <ip>0x400114B</ip>
+ <obj>/build/probe</obj>
+ <fn>main</fn>
+ <dir>/nix/store</dir>
+ <file>z0czkymlici75rf52ivnhrvnx455aafj-probe.c</file>
+ <line>30</line>
+ </frame>
+ </stack>
+</error>
+
+<error>
+ <unique>0x1</unique>
+ <tid>1</tid>
+ <kind>UninitValue</kind>
+ <what>Use of uninitialised value of size 8</what>
+ <stack>
+ <frame>
+ <ip>0x4001195</ip>
+ <obj>/build/probe</obj>
+ <fn>main</fn>
+ <dir>/nix/store</dir>
+ <file>z0czkymlici75rf52ivnhrvnx455aafj-probe.c</file>
+ <line>33</line>
+ </frame>
+ </stack>
+ <auxwhat>Uninitialised value was created by a client request</auxwhat>
+ <stack>
+ <frame>
+ <ip>0x400114B</ip>
+ <obj>/build/probe</obj>
+ <fn>main</fn>
+ <dir>/nix/store</dir>
+ <file>z0czkymlici75rf52ivnhrvnx455aafj-probe.c</file>
+ <line>30</line>
+ </frame>
+ </stack>
+</error>
+
+<status>
+ <state>FINISHED</state>
+ <time>00:00:00:00.563 </time>
+</status>
+
+<heap_summary>
+ <memory_in_use_at_exit>
+ <bytes>0</bytes>
+ <blocks>0</blocks>
+ </memory_in_use_at_exit>
+ <total_heap_usage>
+ <allocs>1</allocs>
+ <frees>1</frees>
+ <bytes_allocated>4,096</bytes_allocated>
+ </total_heap_usage>
+</heap_summary>
+
+<all_heap_blocks_freed>true</all_heap_blocks_freed>
+
+<errorcounts>
+ <pair>
+ <count>1</count>
+ <unique>0x1</unique>
+ </pair>
+ <pair>
+ <count>1</count>
+ <unique>0x0</unique>
+ </pair>
+</errorcounts>
+
+<suppcounts>
+</suppcounts>
+
+<error_summary>
+ <errors>2</errors>
+ <error_contexts>2</error_contexts>
+ <suppressed>0</suppressed>
+ <suppressed_contexts>0</suppressed_contexts>
+</error_summary>
+
+</valgrindoutput>
diff --git a/vestigia.cabal b/vestigia.cabal
@@ -0,0 +1,70 @@
+cabal-version: 3.0
+name: vestigia
+version: 0.1.0
+synopsis: Where an execution depended on a secret.
+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:
+ vestigia runs a harness under valgrind's memcheck, with the bytes
+ the harness marked secret made undefined, and reports every branch
+ and address the execution computed from them, with its source
+ line. It reads the constant-time discipline off a running program:
+ exact on the paths executed, and free of timing noise.
+
+source-repository head
+ type: git
+ location: git.ppad.tech/vestigia.git
+
+library
+ default-language: Haskell2010
+ hs-source-dirs: lib
+ ghc-options:
+ -Wall -Werror
+ exposed-modules:
+ Vestigia.Json
+ , Vestigia.Memcheck
+ , Vestigia.Trace
+ , Vestigia.Xml
+ build-depends:
+ base >= 4.9 && < 5
+ , containers
+ , text
+
+executable vestigia
+ default-language: Haskell2010
+ hs-source-dirs: app
+ main-is: Main.hs
+ ghc-options:
+ -Wall -Werror -rtsopts
+ other-modules:
+ Paths_vestigia
+ autogen-modules:
+ Paths_vestigia
+ build-depends:
+ base
+ , bytestring
+ , directory
+ , process
+ , text
+ , vestigia
+
+test-suite vestigia-tests
+ type: exitcode-stdio-1.0
+ default-language: Haskell2010
+ hs-source-dirs: test
+ main-is: Main.hs
+ ghc-options:
+ -Wall -Werror -rtsopts
+ build-depends:
+ base
+ , bytestring
+ , tasty
+ , tasty-hunit
+ , text
+ , vestigia
