Main.hs (25815B)
1 {-# LANGUAGE OverloadedStrings #-} 2 3 -- | 4 -- Module: Main 5 -- Copyright: (c) 2026 Jared Tobin 6 -- License: MIT 7 -- Maintainer: Jared Tobin <jared@ppad.tech> 8 -- 9 -- The vestigia command: run a harness under memcheck and report 10 -- where its execution depended on the bytes it marked secret. 11 12 module Main ( 13 main 14 ) where 15 16 import Control.Exception (IOException, try) 17 import Control.Monad (unless, when) 18 import qualified Data.List as L 19 import qualified Data.ByteString as BS 20 import Data.Char (toUpper) 21 import qualified Data.Map.Strict as M 22 import Data.Foldable (for_) 23 import Data.Version (showVersion) 24 import qualified GHC.Foreign as GF 25 import GHC.IO.Encoding (getFileSystemEncoding) 26 import Numeric (showHex) 27 import qualified Data.Text as T 28 import qualified Data.Text.Encoding as TE 29 import qualified Data.Text.Encoding.Error as TEE 30 import qualified Data.Text.IO as TIO 31 import System.Directory 32 (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, 33 doesFileExist, getTemporaryDirectory, removeFile) 34 import System.Environment (getArgs, getEnvironment, lookupEnv) 35 import System.Exit (ExitCode(..), exitWith) 36 import System.FilePath (takeFileName, (</>)) 37 import Text.Read (readMaybe) 38 import System.IO 39 (IOMode(..), hClose, hPutStrLn, openTempFile, stderr, withBinaryFile) 40 import System.Process 41 (proc, readCreateProcessWithExitCode, waitForProcess, withCreateProcess) 42 import qualified System.Process as P 43 44 import Paths_vestigia (version) 45 import Vestigia.Contract 46 (Contract(..), Line, contractIsa, contractName, readContract, 47 readDisassembly, watchSection) 48 import Vestigia.Diff 49 (Dump(..), Kind(..), Named(..), Run(..), diffDesigned, divergenceJson, 50 divergenceSummary, dvCallers, dvOrigins, dvOutside, inObject, inOffset, 51 inPc, layoutApart, readDump, restrictTo, runApart) 52 import Vestigia.Json (encode) 53 import Vestigia.Layout (fixLayout) 54 import Vestigia.Memcheck (Memcheck, readMemcheck) 55 import Vestigia.Symbol (symbolize) 56 import Vestigia.Trace 57 (Taint(..), readObjects, resolveObjects, sitesIn, trace, traceJson, 58 traceSummary) 59 60 data Opts = Opts { 61 oValgrind :: !(Maybe FilePath) 62 , oDir :: !(Maybe FilePath) 63 , oOut :: !(Maybe FilePath) 64 , oQemu :: !(Maybe FilePath) 65 , oPlugin :: !(Maybe FilePath) 66 , oDump :: !(Maybe FilePath) 67 , oAddr2line :: !(Maybe FilePath) 68 , oObjects :: ![T.Text] 69 , oControls :: ![FilePath] 70 , oDesigned :: ![FilePath] 71 , oContract :: !(Maybe T.Text) 72 , oObjdump :: !(Maybe FilePath) 73 , oWatch :: !(Maybe FilePath) 74 , oCpu :: !(Maybe String) 75 } 76 77 main :: IO () 78 main = do 79 args <- getArgs 80 case args of 81 ("run" : rest) -> case options rest of 82 Right (o, prog : progArgs) -> run o prog progArgs 83 Right (_, []) -> usage "run: no program given" 84 Left e -> usage e 85 ("read" : rest) -> case options rest of 86 Right (o, runs@(_ : _)) -> readRuns o runs 87 Right _ -> usage "read: a run or memcheck XML file expected" 88 Left e -> usage e 89 ("watch" : rest) -> case options rest of 90 Right (o, prog : progArgs) -> watch o prog progArgs 91 Right (_, []) -> usage "watch: no program given" 92 Left e -> usage e 93 ("record" : rest) -> case options rest of 94 Right (o, prog : progArgs) -> record o prog progArgs 95 Right (_, []) -> usage "record: no program given" 96 Left e -> usage e 97 ("diff" : rest) -> case options rest of 98 Right (o, dumps@(_ : _ : _)) -> diff o dumps 99 Right _ -> usage "diff: two or more dumps expected" 100 Left e -> usage e 101 [ "--version" ] -> putStrLn (showVersion version) 102 _ -> usage "expected a command" 103 104 usage :: String -> IO a 105 usage e = do 106 hPutStrLn stderr ("vestigia: " <> e) 107 hPutStrLn stderr $ unlines 108 [ "usage:" 109 , " vestigia run [--valgrind PATH] [--dir DIR] [--out FILE] \ 110 \[--object TEXT]... -- PROGRAM [ARG...]" 111 , " vestigia read [--out FILE] [--object TEXT]... RUN..." 112 , " vestigia record [--qemu PATH] [--plugin PATH] [--cpu MODEL] \ 113 \--dump FILE [--contract NAME [--watch FILE | [--objdump PATH] \ 114 \[--object TEXT]...]] -- PROGRAM [ARG...]" 115 , " vestigia watch [--qemu PATH] [--cpu MODEL] [--out FILE] \ 116 \--contract NAME [--objdump PATH] [--object TEXT]... -- PROGRAM \ 117 \[ARG...]" 118 , " vestigia diff [--out FILE] [--addr2line PATH] \ 119 \[--object TEXT]... [--control DUMP]... [--designed DUMP]... \ 120 \DUMP DUMP..." 121 , "" 122 , "run executes PROGRAM under memcheck, which reports every" 123 , "branch, address, and division that depended on bytes the" 124 , "program marked secret (vestigia.h), and writes the report" 125 , "(vestigia/trace-v2); --dir keeps the run in DIR. read reports" 126 , "on runs kept so, or memcheck XML files made elsewhere, as one." 127 , "valgrind is --valgrind, else $VESTIGIA_VALGRIND, else on PATH." 128 , "--object keeps sites in objects whose path contains TEXT." 129 , "" 130 , "record executes PROGRAM under QEMU with vestigia's plugin and" 131 , "dumps its leakage trace per instruction, with how it was run;" 132 , "diff compares dumps of runs that differ only in a secret and" 133 , "reports where they diverge (vestigia/diff-v4), naming sources" 134 , "with addr2line." 135 , "--contract (arm-dit or intel-doitm, the program's ISA's) has" 136 , "record also fingerprint the operands of every instruction" 137 , "outside that data-independent-timing contract, in the objects" 138 , "the program loads whose path contains an --object TEXT (all," 139 , "with none), read with objdump (--objdump, else" 140 , "$VESTIGIA_OBJDUMP, else llvm-objdump); diff reports those whose" 141 , "operands differed beside the origins. watch writes the list of" 142 , "those instructions once, for record --watch to read in runs of" 143 , "one program rather than make anew in each." 144 , "--cpu has QEMU emulate MODEL (its -cpu, with any properties)," 145 , "which the dump records; a program choosing its code by the" 146 , "CPU's features takes the path MODEL's features lead it to." 147 , "--object keeps origins in objects whose path contains TEXT;" 148 , "--control names a run repeating the first run's secret, and" 149 , "what differs in it is unsteady, not an origin." 150 , "QEMU is the one for PROGRAM's architecture: --qemu, else" 151 , "$VESTIGIA_QEMU_X86_64 or $VESTIGIA_QEMU_AARCH64, else" 152 , "qemu-x86_64 or qemu-aarch64 on PATH. The plugin and addr2line" 153 , "default to $VESTIGIA_PLUGIN and $VESTIGIA_ADDR2LINE." 154 ] 155 exitWith (ExitFailure 2) 156 157 -- options before the program; "--" ends them 158 options :: [String] -> Either String (Opts, [String]) 159 options = go (Opts Nothing Nothing Nothing Nothing Nothing Nothing 160 Nothing [] [] [] Nothing Nothing Nothing Nothing) 161 where 162 go o xs = case xs of 163 ("--" : rest) -> Right (o, rest) 164 ("--valgrind" : p : rest) -> go o { oValgrind = Just p } rest 165 ("--dir" : p : rest) -> go o { oDir = Just p } rest 166 ("--out" : p : rest) -> go o { oOut = Just p } rest 167 ("--qemu" : p : rest) -> go o { oQemu = Just p } rest 168 ("--plugin" : p : rest) -> go o { oPlugin = Just p } rest 169 ("--dump" : p : rest) -> go o { oDump = Just p } rest 170 ("--addr2line" : p : rest) -> go o { oAddr2line = Just p } rest 171 ("--object" : t : rest) -> 172 go o { oObjects = oObjects o <> [ T.pack t ] } rest 173 ("--control" : p : rest) -> 174 go o { oControls = oControls o <> [ p ] } rest 175 ("--designed" : p : rest) -> 176 go o { oDesigned = oDesigned o <> [ p ] } rest 177 ("--contract" : c : rest) -> go o { oContract = Just (T.pack c) } rest 178 ("--objdump" : p : rest) -> go o { oObjdump = Just p } rest 179 ("--watch" : p : rest) -> go o { oWatch = Just p } rest 180 ("--cpu" : c : rest) -> go o { oCpu = Just c } rest 181 (x : _) | take 2 x == "--" -> Left ("unknown option: " <> x) 182 _ -> Right (o, xs) 183 184 -- the settings every trace runs under: origins tracked so a 185 -- secret's descendants are known as such, no limit on contexts, 186 -- the precise definedness checks optimised code needs, every 187 -- register (the instruction pointer among them) brought up to date 188 -- at each instruction of a program's own code, so that a site that 189 -- touches no memory, a division by a register, is named by its own 190 -- address rather than the last memory access before it, and no leak 191 -- report 192 memcheckArgs :: FilePath -> [String] 193 memcheckArgs xml = 194 [ "--tool=memcheck" 195 , "--xml=yes" 196 , "--xml-file=" <> xml 197 , "--track-origins=yes" 198 , "--error-limit=no" 199 , "--num-callers=24" 200 , "--expensive-definedness-checks=yes" 201 , "--px-file-backed=allregs-at-each-insn" 202 , "--leak-check=no" 203 , "--child-silent-after-fork=yes" 204 ] 205 206 -- a run kept in a directory (run --dir): memcheck's XML, the objects 207 -- the harness's first mark wrote (vestigia.h), and the harness's 208 -- exit status 209 runXml, runObjects, runExit :: FilePath -> FilePath 210 runXml d = d </> "memcheck.xml" 211 runObjects d = d </> "objects" 212 runExit d = d </> "exit" 213 214 run :: Opts -> FilePath -> [String] -> IO () 215 run o prog progArgs = do 216 env <- lookupEnv "VESTIGIA_VALGRIND" 217 let valgrind = maybe (maybe "valgrind" id env) id (oValgrind o) 218 (xml, objects) <- case oDir o of 219 Just d -> do 220 createDirectoryIfMissing True d 221 writeFile (runObjects d) "" 222 pure (runXml d, runObjects d) 223 Nothing -> do 224 tmp <- getTemporaryDirectory 225 (p, h) <- openTempFile tmp "vestigia.xml" 226 hClose h 227 (q, oh) <- openTempFile tmp "vestigia-objects" 228 hClose oh 229 pure (p, q) 230 environment <- getEnvironment 231 r <- try (withCreateProcess 232 (proc valgrind (memcheckArgs xml <> (prog : progArgs))) 233 { P.env = Just (("VESTIGIA_OBJECTS", objects) 234 : filter ((/= "VESTIGIA_OBJECTS") . fst) 235 environment) } 236 (\_ _ _ ph -> waitForProcess ph)) 237 code <- case r of 238 Left e -> do 239 hPutStrLn stderr ("vestigia: cannot run " <> valgrind <> ": " 240 <> show (e :: IOException)) 241 exitWith (ExitFailure 2) 242 Right c -> pure c 243 t <- case oDir o of 244 Just d -> do 245 writeFile (runExit d) (show (exitStatus code) <> "\n") 246 readRun d 247 Nothing -> do 248 os <- markedObjects objects 249 mc <- readXml xml 250 removeFile objects 251 removeFile xml 252 pure (Taint "run" mc os (Just (exitStatus code))) 253 report o [ t ] 254 255 exitStatus :: ExitCode -> Int 256 exitStatus c = case c of 257 ExitSuccess -> 0 258 ExitFailure n -> n 259 260 -- runs kept by run --dir, or memcheck XML files made elsewhere, of 261 -- which nothing more is known 262 readRuns :: Opts -> [FilePath] -> IO () 263 readRuns o paths = do 264 ts <- traverse (\p -> do 265 kept <- doesDirectoryExist p 266 if kept 267 then readRun p 268 else do 269 mc <- readXml p 270 pure (Taint (T.pack (takeFileName p)) mc [] Nothing)) 271 paths 272 report o ts 273 274 readRun :: FilePath -> IO Taint 275 readRun d = do 276 os <- markedObjects (runObjects d) 277 mc <- readXml (runXml d) 278 known <- doesFileExist (runExit d) 279 exit <- if known 280 then fmap (readMaybe . takeWhile (/= '\n')) (readFile (runExit d)) 281 else pure Nothing 282 pure (Taint (T.pack (takeFileName d)) mc os exit) 283 284 -- the objects a run's harness reported where it marked its secret; 285 -- none written, no secret marked: a run that found nothing because 286 -- nothing was secret is no evidence, and is refused 287 markedObjects :: FilePath -> IO [(Integer, T.Text)] 288 markedObjects p = do 289 t <- TIO.readFile p 290 case readObjects t of 291 Left e -> do 292 hPutStrLn stderr ("vestigia: " <> p <> ": " <> e) 293 exitWith (ExitFailure 2) 294 Right [] -> do 295 hPutStrLn stderr ("vestigia: " <> p <> ": the harness marked \ 296 \no secret (vestigia_secret was never called on any bytes); \ 297 \its run says nothing") 298 exitWith (ExitFailure 2) 299 Right os -> resolveObjects os 300 301 readXml :: FilePath -> IO Memcheck 302 readXml xml = do 303 bytes <- BS.readFile xml 304 case readMemcheck (TE.decodeUtf8With TEE.lenientDecode bytes) of 305 Left e -> do 306 hPutStrLn stderr ("vestigia: " <> xml <> ": " <> e) 307 exitWith (ExitFailure 2) 308 Right mc -> pure mc 309 310 report :: Opts -> [Taint] -> IO () 311 report o ts = do 312 let tr = sitesIn (oObjects o) (trace ts) 313 doc = encode (traceJson (T.pack (showVersion version)) tr) 314 maybe (TIO.putStr doc) (\p -> TIO.writeFile p doc) (oOut o) 315 TIO.hPutStr stderr (traceSummary tr) 316 317 -- a tool named by its option, else its environment variable, else 318 -- the given default 319 tool :: Maybe FilePath -> String -> String -> IO FilePath 320 tool opt var dflt = do 321 env <- lookupEnv var 322 pure (maybe (maybe dflt id env) id opt) 323 324 record :: Opts -> FilePath -> [String] -> IO () 325 record o prog progArgs = do 326 dump <- maybe (usage "record: --dump FILE is needed") pure (oDump o) 327 -- runs to be compared must lay memory out alike, and draw the 328 -- same entropy: a hash table seeded from the operating system's 329 -- randomness is laid out anew in every process 330 fixed <- fixLayout 331 unless fixed $ do 332 hPutStrLn stderr "vestigia: address randomisation could not be \ 333 \turned off; runs would differ in layout, and so everywhere" 334 exitWith (ExitFailure 2) 335 -- QEMU's user mode runs the programs of one architecture 336 isa <- machineOf prog 337 qemu <- tool (oQemu o) ("VESTIGIA_QEMU_" <> fmap toUpper isa) 338 ("qemu-" <> isa) 339 plugin <- tool (oPlugin o) "VESTIGIA_PLUGIN" "libvestigia-qemu.so" 340 -- under a contract, the instructions outside it in the objects 341 -- under audit, for the plugin to watch: the list given, made once 342 -- for runs of one program, or one made here 343 contract <- traverse (contractFor isa prog) (oContract o) 344 watching <- case (contract, oWatch o) of 345 (Just _, Just w) -> pure (Just (w, False)) 346 (Just c, Nothing) -> do 347 t <- watchList o qemu c prog progArgs 348 tmp <- getTemporaryDirectory 349 (path, h) <- openTempFile tmp "vestigia.watch" 350 hClose h 351 TIO.writeFile path t 352 pure (Just (path, True)) 353 (Nothing, Just _) -> refuseRecord "a watch list is read under the \ 354 \contract it was made for: --watch needs --contract" 355 (Nothing, Nothing) -> pure Nothing 356 let watchFile = fmap fst watching 357 -- QEMU maps the guest's libraries and heap in its own address 358 -- space, wherever its own allocations leave room, and those vary 359 -- with how its threads run: a second malloc arena, or a large block 360 -- mapped rather than drawn from the heap, takes the room the 361 -- guest's next mapping would have had, and under load one run lays 362 -- out apart from another. One arena, and large blocks drawn from 363 -- the heap, keep QEMU's allocations off the guest's mappings. The 364 -- guest keeps its own setting of the variable, or has none 365 environment <- getEnvironment 366 let tunables = "GLIBC_TUNABLES" 367 host = "glibc.malloc.arena_max=1:glibc.malloc.mmap_threshold=" 368 <> "33554432" 369 own = lookup tunables environment 370 guest = maybe [ "-U", tunables ] 371 (\v -> [ "-E", tunables <> "=" <> v ]) own 372 others = filter ((/= tunables) . fst) environment 373 r <- try (withCreateProcess 374 ((proc qemu (guest 375 <> cpuArgs o 376 <> [ "-seed", "0" 377 , "-plugin", plugin <> ",out=" <> dump 378 <> maybe "" (",watch=" <>) watchFile 379 , prog ] 380 <> progArgs)) 381 { P.env = Just ((tunables, host) : others) }) 382 (\_ _ _ ph -> waitForProcess ph)) 383 for_ watching (\(w, made) -> when made (removeFile w)) 384 case r of 385 Left e -> do 386 hPutStrLn stderr ("vestigia: cannot run " <> qemu <> ": " 387 <> show (e :: IOException)) 388 exitWith (ExitFailure 2) 389 Right c -> do 390 -- how the run was made, by which diff tells runs that differ 391 -- in the secret alone from runs laid out apart: the guest's 392 -- environment is QEMU's, with its own tunables restored 393 appendRun dump (prog : progArgs) 394 (others <> [ (tunables, v) | Just v <- [ own ] ]) c isa contract 395 (oCpu o) 396 exitWith c 397 398 -- QEMU's -cpu, where a model is named 399 cpuArgs :: Opts -> [String] 400 cpuArgs o = maybe [] (\m -> [ "-cpu", m ]) (oCpu o) 401 402 refuseRecord :: String -> IO a 403 refuseRecord e = do 404 hPutStrLn stderr ("vestigia: " <> e) 405 exitWith (ExitFailure 2) 406 407 -- the contract named, for a program of the ISA it speaks to 408 contractFor :: String -> FilePath -> T.Text -> IO Contract 409 contractFor isa prog name = case readContract name of 410 Just c | contractIsa c == isa -> pure c 411 | otherwise -> refuseRecord (T.unpack name <> " speaks to " 412 <> contractIsa c <> ", and " <> prog <> " is " <> isa) 413 Nothing -> refuseRecord ("no contract named " <> T.unpack name 414 <> "; arm-dit and intel-doitm are known") 415 416 -- write a program's watch list under a contract, once, for runs of 417 -- it to read (record --watch) 418 watch :: Opts -> FilePath -> [String] -> IO () 419 watch o prog progArgs = do 420 isa <- machineOf prog 421 qemu <- tool (oQemu o) ("VESTIGIA_QEMU_" <> fmap toUpper isa) 422 ("qemu-" <> isa) 423 name <- maybe (usage "watch: --contract NAME is needed") pure 424 (oContract o) 425 c <- contractFor isa prog name 426 t <- watchList o qemu c prog progArgs 427 maybe (TIO.putStr t) (\p -> TIO.writeFile p t) (oOut o) 428 429 -- the plugin's watch list under a contract: every instruction outside 430 -- it in the objects the program loads (and the program's own) whose 431 -- path contains an --object text, all of them with none 432 watchList :: Opts -> FilePath -> Contract -> FilePath -> [String] 433 -> IO T.Text 434 watchList o qemu c prog progArgs = do 435 objdump <- tool (oObjdump o) "VESTIGIA_OBJDUMP" "llvm-objdump" 436 loaded <- loadedObjects qemu (cpuArgs o) prog progArgs 437 objects <- fmap L.nub (traverse canonicalizePath (prog : loaded)) 438 let kept = [ p | p <- objects 439 , null (oObjects o) 440 || any (`T.isInfixOf` T.pack p) (oObjects o) ] 441 sections <- traverse (\p -> do 442 ls <- disassemble objdump c p 443 pure (watchSection c p ls)) 444 kept 445 pure (T.concat sections) 446 447 -- the shared objects a program loads, as its dynamic loader resolves 448 -- them, run under QEMU so that any ISA's are found 449 loadedObjects :: FilePath -> [String] -> FilePath -> [String] 450 -> IO [FilePath] 451 loadedObjects qemu cpu prog progArgs = do 452 r <- try (readCreateProcessWithExitCode 453 (proc qemu (cpu <> [ "-E", "LD_TRACE_LOADED_OBJECTS=1", prog ] 454 <> progArgs)) "") 455 case r of 456 Left e -> refuseRecord ("cannot run " <> qemu <> ": " 457 <> show (e :: IOException)) 458 Right (ExitSuccess, out, _) -> pure (concatMap object (lines out)) 459 Right (ExitFailure n, _, err) -> refuseRecord ("the loader could not \ 460 \list what " <> prog <> " loads (exit " <> show n <> "): " <> err) 461 where 462 -- "\tNAME => PATH (0x...)" or "\tPATH (0x...)" 463 object l = case words l of 464 (_ : "=>" : p@('/' : _) : _) -> [ p ] 465 (p@('/' : _) : _) -> [ p ] 466 _ -> [] 467 468 -- an object's instructions, its executable sections disassembled 469 -- whole: GHC's LLVM backend gives its code the type of data, which a 470 -- disassembly by symbol would print as bytes 471 disassemble :: FilePath -> Contract -> FilePath -> IO [Line] 472 disassemble objdump c obj = do 473 headers <- objdumped [ "--section-headers", obj ] 474 let sections = [ name | l <- lines headers 475 , (_ : name : _ : _ : kinds) <- [ words l ] 476 , "TEXT" `elem` kinds ] 477 out <- objdumped ([ "-D" ] <> fmap ("--section=" <>) sections 478 <> [ "-M" | c == IntelDoitm ] <> [ "intel" | c == IntelDoitm ] 479 <> [ obj ]) 480 pure (readDisassembly (T.pack out)) 481 where 482 objdumped args = do 483 r <- try (readCreateProcessWithExitCode (proc objdump args) "") 484 case r of 485 Right (ExitSuccess, out, _) -> pure out 486 Right (ExitFailure n, _, err) -> refuseRecord (objdump <> " " 487 <> unwords args <> " failed (exit " <> show n <> "): " <> err) 488 Left e -> refuseRecord ("cannot run " <> objdump <> ": " 489 <> show (e :: IOException)) 490 491 -- the architecture an ELF program is built for, as QEMU names its 492 -- user-mode emulators: the header's machine, at byte 18 493 machineOf :: FilePath -> IO String 494 machineOf prog = do 495 r <- try (withBinaryFile prog ReadMode (\h -> BS.hGet h 20)) 496 case fmap BS.unpack r of 497 Right (0x7f : 0x45 : 0x4c : 0x46 : _ : 1 : rest) 498 | [ 0x3e, 0 ] <- drop 12 rest -> pure "x86_64" 499 | [ 0xb7, 0 ] <- drop 12 rest -> pure "aarch64" 500 Right _ -> unknown "not an x86_64 or aarch64 ELF program" 501 Left e -> unknown (show (e :: IOException)) 502 where 503 unknown why = do 504 hPutStrLn stderr ("vestigia: " <> prog <> ": " <> why 505 <> "; QEMU's user mode runs one") 506 exitWith (ExitFailure 2) 507 508 -- append a run's record to its dump (Vestigia.Diff.readDump): its 509 -- arguments' bytes, its environment's variables and the bytes they 510 -- take, its exit status, the guest's ISA, and any contract it was 511 -- recorded under and CPU model QEMU emulated 512 appendRun :: FilePath -> [String] -> [(String, String)] -> ExitCode 513 -> String -> Maybe Contract -> Maybe String -> IO () 514 appendRun dump args env code isa contract cpu = do 515 enc <- getFileSystemEncoding 516 let bytes s = GF.withCStringLen enc s BS.packCStringLen 517 as <- traverse bytes args 518 es <- traverse (\(k, v) -> bytes (k <> "=" <> v)) env 519 appendFile dump $ unlines $ 520 [ unwords ("A" : [ concatMap byte (BS.unpack a) | not (BS.null a) ]) 521 | a <- as ] 522 <> [ "N " <> showHex (length es) "" <> " " 523 <> showHex (sum (fmap ((+ 1) . BS.length) es)) "" 524 , "X " <> show (exitStatus code) 525 , "M " <> isa ] 526 <> [ "G " <> T.unpack (contractName c) | Just c <- [ contract ] ] 527 <> [ "P " <> m | Just m <- [ cpu ] ] 528 where 529 byte w = case showHex w "" of 530 [ d ] -> [ '0', d ] 531 ds -> ds 532 533 diff :: Opts -> [FilePath] -> IO () 534 diff o paths = do 535 addr2line <- tool (oAddr2line o) "VESTIGIA_ADDR2LINE" "addr2line" 536 dumps <- traverse readOne paths 537 controls <- traverse readOne (oControls o) 538 designed <- traverse readOne (oDesigned o) 539 -- every run with how it was made: the declared, the designed, then 540 -- the controls. Runs made apart differ by more than the secret, 541 -- and are refused, not compared 542 named <- traverse (\(p, k, d) -> case dpRun d of 543 Just r -> pure (p, Named (T.pack (takeFileName p)) k r) 544 Nothing -> refuse (p <> " holds no record of how it was run \ 545 \(vestigia record appends one), so nothing says what it ran")) 546 (zip3 (paths <> oDesigned o <> oControls o) 547 (fmap (const DeclaredRun) paths 548 <> fmap (const DesignedRun) (oDesigned o) 549 <> fmap (const ControlRun) (oControls o)) 550 (dumps <> designed <> controls)) 551 case named of 552 ((p0, first) : rest) -> for_ rest $ \(p, n) -> do 553 for_ (runApart (nmRun first) (nmRun n)) $ \why -> 554 refuse (p <> " " <> why <> " (" <> p0 <> "); runs compared \ 555 \must differ in the secret alone") 556 when (nmKind n == ControlRun 557 && rnArguments (nmRun n) /= rnArguments (nmRun first)) $ 558 refuse (p <> " is a control, but does not repeat the \ 559 \arguments of " <> p0 <> ", the run it controls") 560 [] -> pure () 561 -- runs recorded under other contracts watched other instructions 562 case zip (paths <> oDesigned o <> oControls o) 563 (dumps <> designed <> controls) of 564 ((p0, first) : rest) -> for_ rest $ \(p, d) -> 565 when (dpContract d /= dpContract first || dpIsa d /= dpIsa first) $ 566 refuse (p <> " was recorded for another ISA or under another \ 567 \contract than " <> p0 <> "; runs compared must watch the \ 568 \same instructions") 569 [] -> pure () 570 -- runs on other CPU models may take other code wherever a program 571 -- chooses its code by the CPU's features 572 case zip (paths <> oDesigned o <> oControls o) 573 (dumps <> designed <> controls) of 574 ((p0, first) : rest) -> for_ rest $ \(p, d) -> 575 when (dpCpu d /= dpCpu first) $ 576 refuse (p <> " was recorded on another CPU model than " <> p0 577 <> "; runs compared must run on the same one") 578 [] -> pure () 579 -- runs laid out apart differ wherever they touch memory, not by 580 -- the secret: such runs are refused, not compared 581 case zip paths dumps of 582 ((p0, first) : _) -> case 583 [ (p, obj, x, y) 584 | (p, d) <- zip (paths <> oControls o <> oDesigned o) 585 (dumps <> controls <> designed) 586 , (obj, x, y) <- take 1 (layoutApart first d) ] of 587 ((p, obj, x, y) : _) -> do 588 hPutStrLn stderr ("vestigia: " <> p <> " loaded " 589 <> T.unpack obj <> " at 0x" <> showHex y "" <> " where " 590 <> p0 <> " loaded it at 0x" 591 <> showHex x "" <> "; runs laid out apart differ wherever \ 592 \they touch memory, not by the secret, and are not compared") 593 exitWith (ExitFailure 2) 594 [] -> pure () 595 [] -> pure () 596 let dv = restrictTo (oObjects o) 597 (diffDesigned controls dumps designed) 598 let sites = fmap snd (dvOrigins dv) <> dvOutside dv 599 places <- symbolize addr2line $ 600 [ (obj, inOffset i) | i <- sites, Just obj <- [ inObject i ] ] 601 -- the calls that reached each origin 602 <> [ (obj, a) | i <- sites 603 , Just (stacks, _) <- [ M.lookup (inPc i) (dvCallers dv) ] 604 , calls <- stacks, (Just obj, a) <- calls ] 605 let doc = encode (divergenceJson (T.pack (showVersion version)) 606 (fmap snd named) places dv) 607 maybe (TIO.putStr doc) (\p -> TIO.writeFile p doc) (oOut o) 608 TIO.hPutStr stderr (divergenceSummary places dv) 609 where 610 readOne p = do 611 bytes <- BS.readFile p 612 case readDump (TE.decodeUtf8With TEE.lenientDecode bytes) of 613 Left e -> refuse (p <> ": " <> e) 614 Right d -> pure d 615 refuse e = do 616 hPutStrLn stderr ("vestigia: " <> e) 617 exitWith (ExitFailure 2)