Diff.hs (32218B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE OverloadedStrings #-} 3 4 -- | 5 -- Module: Vestigia.Diff 6 -- Copyright: (c) 2026 Jared Tobin 7 -- License: MIT 8 -- Maintainer: Jared Tobin <jared@ppad.tech> 9 -- 10 -- Where runs that differ only in a secret differ. Each run is a 11 -- leakage trace summarised per instruction (the QEMU plugin's 12 -- dump): how often each instruction ran, how often it transferred 13 -- to each target, a fingerprint of the addresses it touched, and, 14 -- for an integer division, a fingerprint of its operands. 15 -- 16 -- A branch whose outcome did not depend on the secret takes each 17 -- of its transfers in the same proportion however often it runs; a 18 -- branch whose outcomes differ in proportion between runs had its 19 -- own condition depend on the secret, and is a `control` origin 20 -- (a loop whose trip count the secret sets is one, though it also 21 -- runs a different number of times). So is a branch run as often, 22 -- taking each transfer as often, in another order: the plugin keeps 23 -- an order-sensitive fingerprint of what followed each instruction. 24 -- An instruction run equally often in every run whose addresses 25 -- differ computed one from the secret: an `address` origin. A 26 -- division, whose time depends on its operands, run equally often 27 -- on other operands is an `operand` origin. Every 28 -- other instruction run a different number of times sits where 29 -- control had already diverged: it is downstream. So is a return 30 -- whose transfers differ, however often it ran: it goes where the 31 -- call before it sent it, so its outcomes differ only because 32 -- control had diverged before the call. 33 -- 34 -- Unlike memcheck's taint, this sees what control flow does to 35 -- data as well as what data does: a value chosen by a secret 36 -- branch and then used as an index differs between runs, though 37 -- no undefined bit ever reached it. It sees only what the chosen 38 -- secrets actually varied. 39 -- 40 -- A difference means the secret only if nothing else differs 41 -- between runs. Controls are runs repeating the first run's secret: 42 -- an instruction that differs between the first run and a control 43 -- differs without the secret (an entropy source, a clock) and is 44 -- `unsteady`, counted and excluded from the origins. 45 -- 46 -- Runs designed to reach a particular path are compared beside these 47 -- but not alike: they differ from the others in where they go, not 48 -- only in the secret, so an instruction's addresses differing in one 49 -- of them says nothing about the secret. A designed run counts toward 50 -- the control origins (a branch whose outcomes shift under it chose 51 -- by the secret) and what was executed, never toward the address or 52 -- operand origins, which only runs alike in all but the secret can 53 -- show. 54 -- 55 -- What every run executed, per object, is reported beside: the 56 -- instructions the chosen secrets exercised, and so, against what 57 -- a function could execute, the part of it the comparison saw. 58 -- 59 -- Each origin names how the runs behaved there: the runs alike at 60 -- it, grouped (taking each transfer in the same proportion, at a 61 -- control origin; touching the same addresses, at an address 62 -- origin; dividing the same operands, at an operand origin), and the 63 -- runs that never reached it. Whether two runs 64 -- that differed there both had their secrets accepted is the 65 -- reader's to say, from what each run returned. 66 -- 67 -- Runs recorded under a data-independent-timing contract 68 -- (Vestigia.Contract) also fingerprint the operands of every 69 -- instruction outside it. One run equally often on other operands 70 -- in some declared run is outside the contract on the secret: not an 71 -- origin, since the contract says nothing either way of its time, 72 -- but reported beside them, as is how many such instructions ran. 73 74 module Vestigia.Diff ( 75 Insn(..) 76 , Run(..) 77 , Dump(..) 78 , readDump 79 , callsOf 80 , runApart 81 , Kind(..) 82 , Named(..) 83 , Origin(..) 84 , Divergence(..) 85 , diffDumps 86 , diffControlled 87 , diffDesigned 88 , restrictTo 89 , loadBases 90 , layoutApart 91 , divergenceJson 92 , divergenceSummary 93 ) where 94 95 import Control.Monad (foldM, unless) 96 import qualified Data.ByteString as BS 97 import qualified Data.List as L 98 import qualified Data.Map.Strict as M 99 import qualified Data.Set as S 100 import qualified Data.Text as T 101 import qualified Data.Text.Encoding as TE 102 import qualified Data.Text.Encoding.Error as TEE 103 import Numeric (readHex, showHex) 104 import Text.Read (readMaybe) 105 106 import Vestigia.Contract (contractSource, readContract) 107 import Vestigia.Json 108 import Vestigia.Symbol (Place(..)) 109 110 -- | One instruction of a run: its run-time address, and its object 111 -- and address there, where the object's program headers place it. 112 data Insn = Insn { 113 inPc :: !Integer 114 , inCount :: !Integer 115 , inAccesses :: !Integer 116 , inFingerprint :: !T.Text 117 -- | what followed it, in order, fingerprinted 118 , inOrder :: !T.Text 119 , inObject :: !(Maybe T.Text) 120 , inOffset :: !Integer 121 } deriving (Eq, Show) 122 123 -- | How a run was made, as `vestigia record` appends it to the 124 -- plugin's dump: the program and its arguments, as the bytes it 125 -- passed them; the variables of the environment the guest was 126 -- given, and the bytes they take; and the run's exit status. 127 data Run = Run { 128 rnArguments :: ![BS.ByteString] 129 , rnEnvironment :: !(Integer, Integer) 130 , rnStatus :: !Integer 131 } deriving (Eq, Show) 132 133 -- | One run: its instructions by address, its transfers by source, 134 -- each a count per target, the instructions that return, the 135 -- divisions' operands, fingerprinted, the contexts calls made (each 136 -- by the context it was made in and the call's address, 0 being 137 -- the program's own), the contexts each instruction ran in (with 138 -- whether it ran in more than the plugin kept), and how the run 139 -- was made, where its dump says. 140 data Dump = Dump { 141 dpInsns :: !(M.Map Integer Insn) 142 , dpTransfers :: !(M.Map Integer (M.Map Integer Integer)) 143 , dpReturns :: !(S.Set Integer) 144 , dpOperands :: !(M.Map Integer T.Text) 145 , dpContexts :: !(M.Map Integer (Integer, Integer)) 146 , dpCallers :: !(M.Map Integer (Bool, [Integer])) 147 , dpRun :: !(Maybe Run) 148 -- | the operands, fingerprinted, of the instructions outside the 149 -- contract the run was recorded under 150 , dpOutside :: !(M.Map Integer T.Text) 151 -- | the text of each instruction the watch list named 152 , dpTexts :: !(M.Map Integer T.Text) 153 -- | the guest's ISA, the contract, and the CPU model QEMU 154 -- emulated, as `vestigia record` appends them 155 , dpIsa :: !(Maybe T.Text) 156 , dpContract :: !(Maybe T.Text) 157 , dpCpu :: !(Maybe T.Text) 158 } deriving (Eq, Show) 159 160 -- | Read a plugin dump. A dump in which no instruction ran records 161 -- no run (the plugin writes every instruction the guest executed), 162 -- and is refused rather than compared as one that did nothing, as 163 -- is the dump of a guest the plugin stopped for starting a second 164 -- thread, or one whose contexts do not chain back to the 165 -- program's own. The record `vestigia record` appends (an @A@ line 166 -- per argument, its bytes in hex; @N@, the environment's variables 167 -- and bytes, in hex; @X@, the exit status, in decimal) is read 168 -- whole or not at all. Beside it, @M@ names the guest's ISA, @G@ 169 -- the contract the run was recorded under, and @P@ the CPU model 170 -- QEMU emulated, where one was named. 171 readDump :: T.Text -> Either String Dump 172 readDump t = do 173 d <- foldM line (Dump M.empty M.empty S.empty M.empty M.empty M.empty 174 Nothing M.empty M.empty Nothing Nothing Nothing, [] 175 , Nothing 176 , Nothing) (T.lines t) 177 let (dump, as, env, st) = d 178 cx = dpContexts dump 179 unless (any ((> 0) . inCount) (M.elems (dpInsns dump))) $ 180 Left "no instruction ran: the run was not recorded" 181 -- each context made in one made before it, so that its calls end 182 unless (and [ c' < c && (c' == 0 || M.member c' cx) 183 | (c, (c', _)) <- M.toList cx ]) $ 184 Left "a context made in one not made before it" 185 unless (and [ c == 0 || M.member c cx 186 | (_, cs) <- M.elems (dpCallers dump), c <- cs ]) $ 187 Left "an instruction run in a context the dump does not make" 188 r <- record (reverse as) env st 189 pure dump { dpRun = r } 190 where 191 line (d, as, env, st) l = case T.words l of 192 [ "I", pc, n, a, fp, ord, obj, off ] -> do 193 i <- Insn <$> unhex pc <*> unhex n <*> unhex a <*> pure fp 194 <*> pure ord 195 <*> pure (if obj == "-" then Nothing else Just obj) 196 <*> unhex off 197 pure (d { dpInsns = M.insert (inPc i) i (dpInsns d) }, as, env 198 , st) 199 [ "E", from, to, n ] -> do 200 f <- unhex from 201 k <- unhex to 202 c <- unhex n 203 pure (d { dpTransfers = M.insertWith M.union f (M.singleton k c) 204 (dpTransfers d) }, as, env, st) 205 [ "R", pc ] -> do 206 r <- unhex pc 207 pure (d { dpReturns = S.insert r (dpReturns d) }, as, env, st) 208 [ "D", pc, fp ] -> do 209 k <- unhex pc 210 pure (d { dpOperands = M.insert k fp (dpOperands d) }, as, env 211 , st) 212 [ "U", pc, fp ] -> do 213 k <- unhex pc 214 pure (d { dpOutside = M.insert k fp (dpOutside d) }, as, env 215 , st) 216 ("W" : pc : text@(_ : _)) -> do 217 k <- unhex pc 218 pure (d { dpTexts = M.insert k (T.unwords text) (dpTexts d) }, as 219 , env, st) 220 [ "M", isa ] -> pure (d { dpIsa = Just isa }, as, env, st) 221 [ "G", c ] -> pure (d { dpContract = Just c }, as, env, st) 222 [ "P", c ] -> pure (d { dpCpu = Just c }, as, env, st) 223 [ "C", c, caller, call ] -> do 224 v <- (,) <$> unhex caller <*> unhex call 225 k <- unhex c 226 pure (d { dpContexts = M.insert k v (dpContexts d) }, as, env 227 , st) 228 ("K" : pc : partial : cs@(_ : _)) -> do 229 k <- unhex pc 230 p <- case partial of 231 "0" -> pure False 232 "1" -> pure True 233 _ -> Left ("an unreadable dump line: " <> T.unpack l) 234 xs <- traverse unhex cs 235 pure (d { dpCallers = M.insert k (p, xs) (dpCallers d) }, as 236 , env, st) 237 [ "T", _ ] -> 238 Left "the guest started a second thread, which a trace \ 239 \cannot record: the run was stopped" 240 [ "A" ] -> pure (d, BS.empty : as, env, st) 241 [ "A", h ] -> do 242 b <- unhexBytes h 243 pure (d, b : as, env, st) 244 [ "N", n, b ] -> do 245 v <- (,) <$> unhex n <*> unhex b 246 pure (d, as, Just v, st) 247 [ "X", x ] -> case readMaybe (T.unpack x) of 248 Just v -> pure (d, as, env, Just v) 249 Nothing -> Left ("not an exit status: " <> T.unpack x) 250 [] -> pure (d, as, env, st) 251 _ -> Left ("an unreadable dump line: " <> T.unpack l) 252 record as env st = case (as, env, st) of 253 ([], Nothing, Nothing) -> pure Nothing 254 (_ : _, Just e, Just x) -> pure (Just (Run as e x)) 255 _ -> Left "an incomplete record of the run" 256 unhex x = case readHex (T.unpack x) of 257 [ (v, "") ] -> pure v 258 _ -> Left ("not hexadecimal: " <> T.unpack x) 259 unhexBytes h 260 | odd (T.length h) = Left ("not hexadecimal bytes: " <> T.unpack h) 261 | otherwise = 262 BS.pack <$> traverse (fmap fromInteger . unhex) (T.chunksOf 2 h) 263 264 -- | The calls that made a context, innermost first, at most 24 of 265 -- them (as memcheck keeps): each by its object and address there, 266 -- or by its run-time address where the run names no object for it. 267 callsOf :: Dump -> Integer -> [(Maybe T.Text, Integer)] 268 callsOf d = go (24 :: Int) 269 where 270 go n c 271 | n <= 0 || c == 0 = [] 272 | otherwise = case M.lookup c (dpContexts d) of 273 Just (caller, pc) -> site pc : go (n - 1) caller 274 Nothing -> [] 275 site pc = case M.lookup pc (dpInsns d) of 276 Just i | Just o <- inObject i -> (Just o, inOffset i) 277 _ -> (Nothing, pc) 278 279 -- | Why a run cannot be set beside the first as differing from it in 280 -- the secret alone, if it cannot: it ran another program, its 281 -- arguments differ from the first run's in number or length, or it 282 -- was given an environment of another size. Each lays the guest's 283 -- stack out apart, and so every address on it. 284 runApart :: Run -> Run -> Maybe String 285 runApart first r 286 | take 1 (rnArguments r) /= take 1 (rnArguments first) = 287 Just "ran another program than the first run" 288 | fmap BS.length (rnArguments r) 289 /= fmap BS.length (rnArguments first) = 290 Just "has arguments that differ from the first run's in number \ 291 \or length" 292 | rnEnvironment r /= rnEnvironment first = 293 Just "was given an environment of another size than the first \ 294 \run's" 295 | otherwise = Nothing 296 297 -- | What a run is to a comparison: declared, designed for a path, or 298 -- a control repeating the first run's secret. 299 data Kind = 300 DeclaredRun 301 | DesignedRun 302 | ControlRun 303 deriving (Eq, Show) 304 305 -- | A run as the report names it: by its dump's file name, with what 306 -- it is to the comparison and how it was made. 307 data Named = Named { 308 nmName :: !T.Text 309 , nmKind :: !Kind 310 , nmRun :: !Run 311 } deriving (Eq, Show) 312 313 -- | Where a run loaded each object it executed: any of its 314 -- instructions' run-time addresses less its address in the object. 315 loadBases :: Dump -> M.Map T.Text Integer 316 loadBases d = M.fromList 317 [ (o, inPc i - inOffset i) 318 | i <- M.elems (dpInsns d), Just o <- [ inObject i ] ] 319 320 -- | The objects two runs both executed but loaded at different 321 -- addresses, each with where the first run put it and where the 322 -- second did. Runs laid out apart touch other addresses wherever 323 -- they touch memory, so comparing them says nothing of the 324 -- secret. 325 layoutApart :: Dump -> Dump -> [(T.Text, Integer, Integer)] 326 layoutApart a b = 327 [ (o, x, y) 328 | (o, (x, y)) <- M.toList 329 (M.intersectionWith (,) (loadBases a) (loadBases b)) 330 , x /= y ] 331 332 -- | How an origin depended on the secret. 333 data Origin = 334 ControlOrigin 335 | AddressOrigin 336 | OperandOrigin 337 deriving (Eq, Ord, Show) 338 339 -- | Where the runs differ: the origins, each an instruction run 340 -- equally often everywhere, and how many instructions ran a 341 -- different number of times. 342 data Divergence = Divergence { 343 dvOrigins :: ![(Origin, Insn)] 344 -- | at each origin, the runs alike there, grouped, and the runs 345 -- that never reached it, as indices into the declared runs 346 -- then the designed (an address or operand origin's, the 347 -- declared alone) 348 , dvBehaviour :: !(M.Map (Origin, Integer) ([[Int]], [Int])) 349 , dvDownstream :: ![Insn] 350 , dvUnsteady :: ![Insn] 351 , dvRuns :: !Int 352 , dvControls :: !Int 353 , dvDesigned :: !Int 354 -- | the offsets some run, control or not, executed, by object 355 , dvExecuted :: !(M.Map T.Text (S.Set Integer)) 356 -- | at each origin, the distinct chains of calls that reached it 357 -- in the declared and designed runs, at most 16 of them, and 358 -- whether there were more than those 359 , dvCallers :: !(M.Map Integer ([[(Maybe T.Text, Integer)]], Bool)) 360 -- | the instructions outside the contract run equally often in 361 -- every declared run, on other operands in one, each with the 362 -- runs alike there and those that never ran it 363 , dvOutside :: ![Insn] 364 , dvOutsideBehaviour :: !(M.Map Integer ([[Int]], [Int])) 365 -- | the instructions outside the contract some run executed, by 366 -- object 367 , dvWatched :: !(M.Map T.Text (S.Set Integer)) 368 -- | the text of each instruction the watch list named 369 , dvTexts :: !(M.Map Integer T.Text) 370 -- | the guest's ISA, the contract, and the CPU model, as the 371 -- declared runs name them 372 , dvIsa :: !(Maybe T.Text) 373 , dvContract :: !(Maybe T.Text) 374 , dvCpu :: !(Maybe T.Text) 375 } deriving (Eq, Show) 376 377 -- | Compare runs, uncontrolled. 378 diffDumps :: [Dump] -> Divergence 379 diffDumps = diffControlled [] 380 381 -- | Compare runs, given controls repeating the first run's secret. 382 -- Every run is set against every other, so an origin is any 383 -- instruction at which some two runs differ, and which no control 384 -- shows differing without the secret. 385 diffControlled :: [Dump] -> [Dump] -> Divergence 386 diffControlled cs ds = diffDesigned cs ds [] 387 388 -- | Compare runs, given controls and runs designed to reach particular 389 -- paths. The address and operand origins are the declared runs' 390 -- alone; the control origins and what was executed are every 391 -- run's. 392 diffDesigned :: [Dump] -> [Dump] -> [Dump] -> Divergence 393 diffDesigned cs ds xs = Divergence { 394 dvOrigins = L.sortOn (inPc . snd) origins 395 , dvBehaviour = M.fromList 396 [ ((o, inPc i), behaviourAt o (inPc i)) | (o, i) <- origins ] 397 , dvDownstream = [ i | pc <- S.toAscList downstream 398 , not (pc `S.member` unsteady) 399 , Just i <- [ firstInsn pc ] ] 400 , dvUnsteady = [ i | pc <- S.toAscList unsteady 401 , Just i <- [ firstInsn pc ] ] 402 , dvRuns = length ds 403 , dvControls = length cs 404 , dvDesigned = length xs 405 , dvExecuted = M.fromListWith S.union 406 [ (obj, S.singleton (inOffset i)) 407 | d <- ds <> xs <> cs 408 , i <- M.elems (dpInsns d) 409 , inCount i > 0 410 , Just obj <- [ inObject i ] ] 411 , dvCallers = M.fromList 412 [ (inPc i, callersAt (inPc i)) 413 | i <- fmap snd origins <> outside ] 414 , dvOutside = outside 415 , dvOutsideBehaviour = M.fromList 416 [ ( inPc i 417 , ( classes (==) [ (k, M.lookup (inPc i) (dpOutside d)) 418 | (k, d) <- ranIn' ds (inPc i) ] 419 , [ k | (k, d) <- zip [ 0 .. ] ds 420 , maybe True ((== 0) . inCount) 421 (M.lookup (inPc i) (dpInsns d)) ] ) ) 422 | i <- outside ] 423 , dvWatched = M.fromListWith S.union 424 [ (obj, S.singleton (inOffset i)) 425 | d <- ds <> xs <> cs 426 , pc <- M.keys (dpOutside d) 427 , Just i <- [ M.lookup pc (dpInsns d) ] 428 , inCount i > 0 429 , Just obj <- [ inObject i ] ] 430 , dvTexts = M.unions (fmap dpTexts (ds <> xs <> cs)) 431 , dvIsa = case ds of 432 (d : _) -> dpIsa d 433 [] -> Nothing 434 , dvContract = case ds of 435 (d : _) -> dpContract d 436 [] -> Nothing 437 , dvCpu = case ds of 438 (d : _) -> dpCpu d 439 [] -> Nothing 440 } 441 where 442 ranIn' rs pc = [ (k, d) | (k, d) <- zip [ 0 .. ] rs 443 , Just i <- [ M.lookup pc (dpInsns d) ] 444 , inCount i > 0 ] 445 callersAt pc = 446 let found = [ (partial, fmap (callsOf d) ks) 447 | d <- runs 448 , Just (partial, ks) <- [ M.lookup pc (dpCallers d) ] ] 449 stacks = L.nub (concatMap snd found) 450 in (take 16 stacks, any fst found || length stacks > 16) 451 452 -- what differs between the first run and a repeat of its secret 453 unsteady = case ds of 454 (d : _) -> S.unions (fmap (differing d) cs) 455 [] -> S.empty 456 differing a b = S.fromList 457 [ pc 458 | pc <- S.toList (M.keysSet (dpInsns a) 459 `S.union` M.keysSet (dpInsns b)) 460 , let ia = M.lookup pc (dpInsns a) 461 ib = M.lookup pc (dpInsns b) 462 ta = M.lookup pc (dpTransfers a) 463 tb = M.lookup pc (dpTransfers b) 464 , fmap sig ia /= fmap sig ib || ta /= tb 465 || M.lookup pc (dpOperands a) /= M.lookup pc (dpOperands b) 466 || M.lookup pc (dpOutside a) /= M.lookup pc (dpOutside b) ] 467 sig i = (inCount i, inFingerprint i, inOrder i) 468 469 origins = [ o | o@(_, i) <- controls <> addresses <> operands 470 , not (inPc i `S.member` unsteady) ] 471 472 -- every run, the declared first 473 runs = ds <> xs 474 475 -- how the runs behaved at an origin: those that ran it, grouped 476 -- by what they did there, and those that never ran it. Only the 477 -- declared runs speak to an address or an operand. 478 behaviourAt o pc = case o of 479 ControlOrigin -> 480 ( classes outcomesAlike 481 [ (k, (inCount i, M.findWithDefault M.empty pc 482 (dpTransfers d), inOrder i)) 483 | (k, d, i) <- ranIn runs ] 484 , absentIn runs ) 485 AddressOrigin -> 486 ( classes (==) [ (k, inFingerprint i) | (k, _, i) <- ranIn ds ] 487 , absentIn ds ) 488 OperandOrigin -> 489 ( classes (==) 490 [ (k, M.lookup pc (dpOperands d)) | (k, d, _) <- ranIn ds ] 491 , absentIn ds ) 492 where 493 ranIn rs = [ (k, d, i) | (k, d) <- zip [ 0 .. ] rs 494 , Just i <- [ M.lookup pc (dpInsns d) ] 495 , inCount i > 0 ] 496 absentIn rs = [ k | (k, d) <- zip [ 0 .. ] rs 497 , maybe True ((== 0) . inCount) 498 (M.lookup pc (dpInsns d)) ] 499 500 pcs = S.unions (fmap (M.keysSet . dpInsns) runs) 501 firstInsn pc = case [ i | d <- runs 502 , Just i <- [ M.lookup pc (dpInsns d) ] ] of 503 (i : _) -> Just i 504 [] -> Nothing 505 506 -- run counts per run, absent counted as never run 507 countsIn rs pc = 508 [ maybe 0 inCount (M.lookup pc (dpInsns d)) | d <- rs ] 509 alike ys = case ys of 510 [] -> True 511 (y : rest) -> all (== y) rest 512 513 -- run equally often in every run, and in every declared run 514 steady = S.filter (alike . countsIn runs) pcs 515 steadyDeclared = S.filter (alike . countsIn ds) 516 (S.unions (fmap (M.keysSet . dpInsns) ds)) 517 518 -- an instruction's run count, transfers, and the order of what 519 -- followed it, in each run that ran it 520 ranAt pc = 521 [ ( inCount i, M.findWithDefault M.empty pc (dpTransfers d) 522 , inOrder i ) 523 | d <- runs, Just i <- [ M.lookup pc (dpInsns d) ] 524 , inCount i > 0 ] 525 transferSources = S.unions (fmap (M.keysSet . dpTransfers) runs) 526 527 -- outcomes in the same proportion: each target taken as often, 528 -- relative to the run count, in both 529 proportional (c, ts) (c', ts') = 530 M.keysSet ts == M.keysSet ts' 531 && and (M.elems (M.intersectionWith (\e e' -> e * c' == e' * c) 532 ts ts')) 533 -- outcomes alike: each target taken in the same proportion and, 534 -- where it ran as often, in the same order 535 outcomesAlike (c, ts, o) (c', ts', o') = 536 proportional (c, ts) (c', ts') && (c /= c' || o == o') 537 divergent pc = case ranAt pc of 538 (r : rest) -> not (all (outcomesAlike r) rest) 539 [] -> False 540 541 -- a return goes where its call sent it: downstream, never an 542 -- origin, whatever its outcomes 543 returns = S.unions (fmap dpReturns runs) 544 divergentPcs = S.filter divergent transferSources 545 controlPcs = divergentPcs `S.difference` returns 546 -- the address and operand origins 547 dataPcs = S.fromList [ inPc i | (_, i) <- addresses <> operands ] 548 downstream = 549 ((((pcs `S.difference` steady) 550 `S.union` (divergentPcs `S.intersection` returns)) 551 `S.difference` controlPcs) 552 `S.difference` dataPcs) 553 `S.difference` S.fromList (fmap inPc outside) 554 555 controls = 556 [ (ControlOrigin, i) 557 | pc <- S.toAscList controlPcs 558 , Just i <- [ firstInsn pc ] ] 559 560 addresses = 561 [ (AddressOrigin, i) 562 | pc <- S.toAscList steadyDeclared 563 , let fps = [ fmap inFingerprint (M.lookup pc (dpInsns d)) 564 | d <- ds ] 565 , not (alike fps) 566 , Just i <- [ firstInsn pc ] 567 , inAccesses i > 0 ] 568 569 -- an instruction outside the contract run equally often in 570 -- every declared run, on other operands in one, where it is not 571 -- an origin already 572 outside = 573 [ i 574 | pc <- S.toAscList steadyDeclared 575 , not (pc `S.member` unsteady) 576 , not (pc `S.member` controlPcs) 577 , not (pc `S.member` dataPcs) 578 , let fps = [ M.lookup pc (dpOutside d) | d <- ds ] 579 , any (/= Nothing) fps 580 , not (alike fps) 581 , Just i <- [ firstInsn pc ] ] 582 583 -- a division run equally often in every declared run, on other 584 -- operands in one 585 operands = 586 [ (OperandOrigin, i) 587 | pc <- S.toAscList steadyDeclared 588 , let fps = [ M.lookup pc (dpOperands d) | d <- ds ] 589 , any (/= Nothing) fps 590 , not (alike fps) 591 , Just i <- [ firstInsn pc ] ] 592 593 -- | Only the origins, what was executed, and what ran downstream, in 594 -- objects whose path contains one of the given texts. 595 restrictTo :: [T.Text] -> Divergence -> Divergence 596 restrictTo ps dv 597 | null ps = dv 598 | otherwise = dv { 599 dvOrigins = filter (inside . inObject . snd) (dvOrigins dv) 600 , dvDownstream = filter (inside . inObject) (dvDownstream dv) 601 , dvExecuted = M.filterWithKey (\o _ -> inside (Just o)) 602 (dvExecuted dv) 603 , dvOutside = filter (inside . inObject) (dvOutside dv) 604 , dvWatched = M.filterWithKey (\o _ -> inside (Just o)) 605 (dvWatched dv) 606 } 607 where 608 inside mo = case mo of 609 Just o -> any (`T.isInfixOf` o) ps 610 Nothing -> False 611 612 originText :: Origin -> T.Text 613 originText o = case o of 614 ControlOrigin -> "control" 615 AddressOrigin -> "address" 616 OperandOrigin -> "operand" 617 618 -- | The report: @vestigia/diff-v4@. Runs are given the declared, 619 -- then the designed, then the controls, and an origin names the 620 -- runs alike at it by the first two. An origin's stacks are its own 621 -- frames then its calls', innermost first, each frame with the 622 -- object and address of the instruction it names, as memcheck's 623 -- are in a taint report. The ISA, contract, and CPU model the runs 624 -- were recorded under head it; the instructions outside the contract 625 -- whose operands differed are given as origins are, and those that 626 -- ran, by object, as what was executed is. 627 divergenceJson 628 :: T.Text -> [Named] -> M.Map (T.Text, Integer) [Place] -> Divergence 629 -> Value 630 divergenceJson version runs places dv = Object 631 [ ("schema", String "vestigia/diff-v4") 632 , ("tool", Object [ ("name", String "vestigia") 633 , ("version", String version) ]) 634 , ("isa", maybe Null String (dvIsa dv)) 635 , ("contract", case dvContract dv of 636 Just n -> Object 637 [ ("name", String n) 638 , ("source", maybe Null (String . contractSource) 639 (readContract n)) ] 640 Nothing -> Null) 641 , ("cpu", maybe Null String (dvCpu dv)) 642 , ("runs", Array 643 [ Object 644 [ ("name", String (nmName r)) 645 , ("kind", String (kindText (nmKind r))) 646 , ("arguments", Array 647 [ String (TE.decodeUtf8With TEE.lenientDecode a) 648 | a <- rnArguments (nmRun r) ]) 649 , ("status", Number (rnStatus (nmRun r))) 650 ] 651 | r <- runs ]) 652 , ("summary", Object 653 [ ("control", count ControlOrigin) 654 , ("address", count AddressOrigin) 655 , ("operand", count OperandOrigin) 656 , ("downstream", Number (toInteger (length (dvDownstream dv)))) 657 , ("unsteady", Number (toInteger (length (dvUnsteady dv)))) 658 , ("outside", Number (toInteger (length (dvOutside dv)))) 659 , ("watched", Number (toInteger (sum (fmap S.size 660 (M.elems (dvWatched dv)))))) 661 ]) 662 , ("origins", Array 663 [ site (originText o) i 664 (M.findWithDefault ([], []) (o, inPc i) (dvBehaviour dv)) 665 | (o, i) <- dvOrigins dv ]) 666 , ("outside", Array 667 [ site "outside" i 668 (M.findWithDefault ([], []) (inPc i) (dvOutsideBehaviour dv)) 669 | i <- dvOutside dv ]) 670 , ("downstream", Object 671 [ (obj, Array (fmap (String . hex) (S.toAscList offs))) 672 | (obj, offs) <- M.toList (M.fromListWith S.union 673 [ (obj, S.singleton (inOffset i)) 674 | i <- dvDownstream dv, Just obj <- [ inObject i ] ]) ]) 675 , ("unsteady", byObject (dvUnsteady dv)) 676 , ("executed", Object 677 [ (o, Array (fmap (String . hex) (S.toAscList xs))) 678 | (o, xs) <- M.toList (dvExecuted dv) ]) 679 , ("watched", Object 680 [ (o, Array (fmap (String . hex) (S.toAscList xs))) 681 | (o, xs) <- M.toList (dvWatched dv) ]) 682 ] 683 where 684 site cls i (groups, absent) = 685 let (stacks, partial) = M.findWithDefault ([], False) (inPc i) 686 (dvCallers dv) 687 in Object 688 [ ("class", String cls) 689 , ("pc", String (hex (inPc i))) 690 , ("object", maybe Null String (inObject i)) 691 , ("offset", String (hex (inOffset i))) 692 , ("count", Number (inCount i)) 693 , ("instruction", maybe Null String 694 (M.lookup (inPc i) (dvTexts dv))) 695 , ("frames", Array (fmap placeJson (placesOf i))) 696 , ("stacks", Array 697 [ Array (located (inObject i, inOffset i) 698 <> concatMap located calls) 699 | calls <- stacks ]) 700 , ("partial", Bool partial) 701 , ("groups", Array (fmap (Array . fmap named) groups)) 702 , ("absent", Array (fmap named absent)) 703 ] 704 names = [ nmName r | r <- runs, nmKind r /= ControlRun ] 705 kindText k = case k of 706 DeclaredRun -> "declared" 707 DesignedRun -> "designed" 708 ControlRun -> "control" 709 count o = Number (toInteger (length 710 [ () | (o', _) <- dvOrigins dv, o' == o ])) 711 named k = case drop k names of 712 (n : _) -> String n 713 [] -> String (T.pack (show k)) 714 byObject is = Object 715 [ (o, Number (toInteger n)) 716 | (o, n) <- M.toList (M.fromListWith (+) 717 [ (maybe "-" id (inObject i), 1 :: Int) | i <- is ]) ] 718 placesOf i = case inObject i of 719 Just obj -> M.findWithDefault [] (obj, inOffset i) places 720 Nothing -> [] 721 placeJson p = Object 722 [ ("function", maybe Null String (plFunction p)) 723 , ("file", maybe Null String (plFile p)) 724 , ("line", maybe Null (Number . toInteger) (plLine p)) 725 ] 726 -- an instruction's frames, innermost first, each with where the 727 -- instruction is; one unnamed frame where nothing names it 728 located (mo, a) = 729 let at = [ ("object", maybe Null String mo) 730 , ("offset", String (hex a)) ] 731 ps = case mo of 732 Just obj -> M.findWithDefault [] (obj, a) places 733 Nothing -> [] 734 in case ps of 735 [] -> [ Object (at <> [ ("function", Null), ("file", Null) 736 , ("line", Null) ]) ] 737 _ -> [ case placeJson p of 738 Object kvs -> Object (at <> kvs) 739 other -> other 740 | p <- ps ] 741 742 -- | One line per origin, innermost frame first, for a terminal. 743 divergenceSummary 744 :: M.Map (T.Text, Integer) [Place] -> Divergence -> T.Text 745 divergenceSummary places dv = T.unlines $ 746 [ T.intercalate " " 747 [ cls 748 , hex (inOffset i) 749 , maybe "?" id (plFunction =<< innermost i) 750 , maybe "?" location (innermost i) 751 , maybe "-" base (inObject i) ] 752 | (cls, i) <- [ (originText o, i) | (o, i) <- dvOrigins dv ] 753 <> [ ("outside", i) | i <- dvOutside dv ] ] 754 <> [ T.pack (show (length (dvOrigins dv))) <> " origin(s) over " 755 <> T.pack (show (dvRuns dv)) <> " run(s)" 756 <> (if dvDesigned dv == 0 then "" 757 else " and " <> T.pack (show (dvDesigned dv)) <> " designed") 758 <> "; " 759 <> T.pack (show (length (dvDownstream dv))) 760 <> " instruction(s) downstream; " 761 <> T.pack (show (length (dvUnsteady dv))) 762 <> " unsteady over " <> T.pack (show (dvControls dv)) 763 <> " control(s)" 764 <> maybe "" 765 (\c -> "; " <> T.pack (show watched) 766 <> " instruction(s) outside " <> c <> " ran, " 767 <> T.pack (show (length (dvOutside dv))) 768 <> " on operands that differed") 769 (dvContract dv) ] 770 where 771 watched = sum (fmap S.size (M.elems (dvWatched dv))) 772 innermost i = case inObject i of 773 Just obj -> case M.findWithDefault [] (obj, inOffset i) places of 774 (p : _) -> Just p 775 [] -> Nothing 776 Nothing -> Nothing 777 location p = case (plFile p, plLine p) of 778 (Just f, Just l) -> base f <> ":" <> T.pack (show l) 779 (Just f, Nothing) -> base f 780 _ -> "?" 781 base p = case reverse (T.splitOn "/" p) of 782 (x : _) -> x 783 [] -> p 784 785 hex :: Integer -> T.Text 786 hex n = "0x" <> T.pack (showHex n "") 787 788 -- keys grouped by an equivalence on their values, each group in 789 -- order and the groups by their first member 790 classes :: (a -> a -> Bool) -> [(Int, a)] -> [[Int]] 791 classes eq ys = case ys of 792 [] -> [] 793 ((k, y) : rest) -> 794 let (same, other) = L.partition (eq y . snd) rest 795 in (k : fmap fst same) : classes eq other