Main.hs (28533B)
1 {-# LANGUAGE OverloadedStrings #-} 2 3 module Main ( 4 main 5 ) where 6 7 import qualified Data.ByteString as BS 8 import qualified Data.Map.Strict as M 9 import qualified Data.Set as S 10 import qualified Data.Text as T 11 import qualified Data.Text.Encoding as TE 12 import System.Directory 13 import System.FilePath ((</>)) 14 import Test.Tasty 15 import Test.Tasty.HUnit 16 17 import Vestigia.Contract 18 import Vestigia.Diff 19 import Vestigia.Json 20 import Vestigia.Memcheck 21 import Vestigia.Symbol 22 import Vestigia.Trace 23 import Vestigia.Xml 24 25 main :: IO () 26 main = defaultMain $ testGroup "vestigia" 27 [ xmlTests 28 , memcheckTests 29 , traceTests 30 , contractTests 31 , diffTests 32 , symbolTests 33 , jsonTests 34 ] 35 36 xmlTests :: TestTree 37 xmlTests = testGroup "xml" 38 [ testCase "elements, text, and entities" $ 39 parseDocument "<?xml version=\"1.0\"?>\n<a>\n <b>x & \ 40 \<y> AB</b><c/></a>" 41 @?= Right (Element "a" 42 [ Text "\n ", Element "b" [ Text "x & <y> AB" ] 43 , Element "c" [] ]) 44 45 , testCase "attributes and comments are skipped" $ 46 parseDocument "<!-- head --><a k=\"v>\" j='w'><!-- c --><b/></a>" 47 @?= Right (Element "a" [ Element "b" [] ]) 48 49 , testCase "a mismatched close tag is refused" $ 50 isLeft (parseDocument "<a><b></a></b>") @? "accepted" 51 52 , testCase "an unclosed element is refused" $ 53 isLeft (parseDocument "<a><b>text") @? "accepted" 54 55 , testCase "an unknown entity is refused" $ 56 isLeft (parseDocument "<a> </a>") @? "accepted" 57 ] 58 59 memcheckTests :: TestTree 60 memcheckTests = testGroup "memcheck" 61 [ testCase "the probe run reads whole" $ do 62 mc <- fixture "probe.xml" 63 mcVersion mc @?= Just "3.26.0" 64 mcFinished mc @?= True 65 mcCommand mc @?= [ "./probe" ] 66 fmap meKind (mcErrors mc) @?= [ "UninitValue", "UninitValue" ] 67 fmap meCount (mcErrors mc) @?= [ 1, 1 ] 68 case mcErrors mc of 69 (e : _) -> do 70 fmap frFn (meStack e) @?= [ Just "lookup", Just "main" ] 71 fmap frLine (meStack e) @?= [ Just 16, Just 31 ] 72 case meOrigin e of 73 ClientRequest (o : _) -> frLine o @?= Just 30 74 other -> assertFailure ("origin: " <> show other) 75 [] -> assertFailure "no errors read" 76 77 , testCase "a document from another tool is refused" $ 78 isLeft (readMemcheck "<valgrindoutput><protocoltool>helgrind\ 79 \</protocoltool></valgrindoutput>") 80 @? "accepted" 81 ] 82 83 traceTests :: TestTree 84 traceTests = testGroup "trace" 85 [ testCase "the probe's secret addresses are its sites" $ do 86 tr <- one <$> fixture "probe.xml" 87 fmap (\s -> (siClass s, frFn (at s), frLine (at s))) (trSites tr) 88 @?= [ (Address, Just "lookup", Just 16) 89 , (Address, Just "main", Just 33) ] 90 trUnrelated tr @?= [] 91 trFaults tr @?= [] 92 93 , testCase "only a secret's descendants are sites" $ do 94 tr <- one <$> either assertFailure pure (readMemcheck mixed) 95 fmap (\s -> (siClass s, frIp (at s), siCount s)) (trSites tr) 96 @?= [ (Control, 0x10, 5) ] 97 fmap (meKind . snd) (trUnrelated tr) @?= [ "UninitValue" ] 98 fmap (meKind . snd) (trFaults tr) @?= [ "InvalidRead" ] 99 100 , testCase "a frame is named by its address in its object" $ do 101 os <- either assertFailure pure 102 (readObjects "4000000 /nix/store/x-lib/lib/liba.so\n\ 103 \0 /nix/store/y-h/bin/harness\n") 104 let f o i = Frame i (Just o) Nothing Nothing Nothing 105 objectOffset os (f "/nix/store/x-lib/lib/liba.so" 0x4001234) 106 @?= Just 0x1234 107 -- the same file reached by another path 108 objectOffset os (f "/other/liba.so" 0x4000010) @?= Just 0x10 109 objectOffset os (f "/nix/store/y-h/bin/harness" 0x401000) 110 @?= Just 0x401000 111 objectOffset os (f "/lib/libc.so.6" 0x7000) @?= Nothing 112 113 , testCase "an object reached by a link is named by its file" $ do 114 tmp <- getTemporaryDirectory 115 let dir = tmp </> "vestigia-resolve-objects" 116 file = dir </> "liba.so.1.2.3" 117 link = dir </> "liba.so.1" 118 removePathForcibly dir 119 createDirectoryIfMissing True dir 120 writeFile file "" 121 createFileLink "liba.so.1.2.3" link 122 real <- T.pack <$> canonicalizePath file 123 os <- resolveObjects 124 [ (0x4000000, T.pack link), (0, "/nowhere/bin/harness") ] 125 removePathForcibly dir 126 os @?= [ (0x4000000, real), (0, "/nowhere/bin/harness") ] 127 objectOffset os (Frame 0x4000010 (Just real) Nothing Nothing Nothing) 128 @?= Just 0x10 129 130 , testCase "a site is kept to the objects named" $ do 131 tr <- one <$> fixture "probe.xml" 132 length (trSites (sitesIn [ "probe" ] tr)) @?= 2 133 trSites (sitesIn [ "libc" ] tr) @?= [] 134 length (trSites (sitesIn [] tr)) @?= 2 135 136 , testCase "one site per instruction, whatever called it" $ do 137 tr <- one <$> either assertFailure pure (readMemcheck twoCallers) 138 fmap (\s -> (frIp (at s), siCount s, length (siStacks s))) 139 (trSites tr) 140 @?= [ (0x10, 7, 2) ] 141 142 , testCase "runs' sites are one per instruction, with their runs" $ do 143 a <- either assertFailure pure (readMemcheck mixed) 144 b <- either assertFailure pure (readMemcheck twoCallers) 145 -- the same object loaded 0x100 higher in the second run: its 146 -- branch at 0x110 is the first run's at 0x10 147 let obj = "/lib.so" 148 inObj mc = mc { mcErrors = 149 [ e { meStack = [ f { frObj = Just obj } 150 | f <- meStack e ] } 151 | e <- mcErrors mc ] } 152 moved mc = mc { mcErrors = 153 [ e { meStack = [ f { frIp = frIp f + 0x100 } 154 | f <- meStack e ] } 155 | e <- mcErrors mc ] } 156 tr = trace 157 [ Taint "a" (inObj a) [ (0, obj) ] (Just 0) 158 , Taint "b" (moved (inObj b)) [ (0x100, obj) ] (Just 1) ] 159 fmap (\s -> (siClass s, lcOffset (siAt s), siCount s, siRuns s 160 , length (siStacks s))) 161 (trSites tr) 162 @?= [ (Control, Just 0x10, 5 + 7, [ 0, 1 ], 1 + 2) ] 163 fmap fst (trUnrelated tr) @?= [ 0 ] 164 ] 165 166 contractTests :: TestTree 167 contractTests = testGroup "contract" 168 [ testCase "AArch64: a division, and what DIT covers" $ do 169 classify ArmDit (word 0x1ac20820) @?= Division -- udiv w0 170 classify ArmDit (word 0x9ac20c20) @?= Division -- sdiv x0 171 classify ArmDit (word 0x8b020020) @?= Inside -- add x0 172 classify ArmDit (word 0x9bc27c20) @?= Inside -- umulh x0 173 classify ArmDit (word 0xdac00c20) @?= Inside -- rev x0 174 classify ArmDit (word 0xd65f03c0) @?= Excluded -- ret 175 classify ArmDit (word 0x90000420) @?= Excluded -- adrp x0 176 177 , testCase "AArch64: outside DIT, with the registers read" $ do 178 -- fdiv d0, d1, d2 179 classify ArmDit (word 0x1e621820) 180 @?= Watched [ Register "v1" 0 64, Register "v2" 0 64 ] False 181 -- fmov x0, d1 182 classify ArmDit (word 0x9e660020) 183 @?= Watched [ Register "v1" 0 64 ] False 184 -- fadd v0.4s, v1.4s, v2.4s, and its 64-bit arrangement 185 classify ArmDit (word 0x4e22d420) 186 @?= Watched [ Register "v1" 0 128, Register "v2" 0 128 ] False 187 classify ArmDit (word 0x0e22d420) 188 @?= Watched [ Register "v1" 0 64, Register "v2" 0 64 ] False 189 190 , testCase "x86_64: a division, and what DOITM covers" $ do 191 classify IntelDoitm (x86 [ 0x48, 0xf7, 0xf6 ] "div" "rsi") 192 @?= Division 193 classify IntelDoitm (x86 [ 0xc1, 0xc0, 0x07 ] "rol" "eax, 0x7") 194 @?= Inside 195 classify IntelDoitm (x86 [ 0x48, 0x0f, 0xc8 ] "bswap" "rax") 196 @?= Inside 197 classify IntelDoitm (x86 [ 0x48, 0x0f, 0x44, 0xc3 ] "cmove" 198 "rax, rbx") @?= Inside 199 classify IntelDoitm (x86 [ 0x48, 0xb8, 1, 0, 0, 0, 0, 0, 0, 0 ] 200 "movabs" "rax, 0x1") @?= Inside 201 classify IntelDoitm (x86 [ 0xc5, 0xf5, 0xd4, 0xc2 ] "vpaddq" 202 "ymm0, ymm1, ymm2") @?= Inside 203 classify IntelDoitm (x86 [ 0x75, 0x02 ] "jne" "0x10") @?= Excluded 204 classify IntelDoitm (x86 [ 0x90 ] "nop" "") @?= Excluded 205 206 , testCase "x86_64: outside DOITM, with the registers read" $ do 207 -- popcnt only writes its destination 208 classify IntelDoitm (x86 [ 0xf3, 0x48, 0x0f, 0xb8, 0xc3 ] "popcnt" 209 "rax, rbx") 210 @?= Watched [ Register "rbx" 0 64 ] False 211 classify IntelDoitm (x86 [ 0x92 ] "xchg" "eax, edx") 212 @?= Watched [ Register "rax" 0 32, Register "rdx" 0 32 ] False 213 -- a legacy SSE division reads its destination too 214 classify IntelDoitm (x86 [ 0xf2, 0x0f, 0x5e, 0xc1 ] "divsd" 215 "xmm0, xmm1") 216 @?= Watched [ Register "xmm0" 0 128, Register "xmm1" 0 128 ] False 217 classify IntelDoitm (x86 [ 0x98 ] "cwde" "") 218 @?= Watched [ Register "rax" 0 16 ] False 219 -- a memory operand's registers are its address's, not its data 220 classify IntelDoitm (x86 [ 0x0f, 0x54, 0x07 ] "andps" 221 "xmm0, xmmword ptr [rdi]") 222 @?= Watched [ Register "xmm0" 0 128 ] True 223 224 , testCase "llvm-objdump's lines are read" $ do 225 readDisassembly (T.unlines 226 [ "0000000000001000 <f>:" 227 , " 1000: 48 89 e5 \tmov\trbp, rsp" 228 , " 1003: f3 48 ab \trep\t\tstosq\tqword \ 229 \ptr es:[rdi], rax" 230 , " 1006: 48 8b 05 4d b5 06 00 \tmov\trax, qword ptr \ 231 \[rip + 0x6b54d] # 0x86d58 <x>" 232 , "\t\t..." 233 , " 1b824: 9112a000 \tadd\tx0, x0, #0x4a8" ]) 234 @?= [ Line 0x1000 [ 0x48, 0x89, 0xe5 ] [] "mov" "rbp, rsp" 235 , Line 0x1003 [ 0xf3, 0x48, 0xab ] [ "rep" ] "stosq" 236 "qword ptr es:[rdi], rax" 237 , Line 0x1006 [ 0x48, 0x8b, 0x05, 0x4d, 0xb5, 0x06, 0x00 ] [] 238 "mov" "rax, qword ptr [rip + 0x6b54d]" 239 , Line 0x1b824 [ 0x9112a000 ] [] "add" "x0, x0, #0x4a8" ] 240 241 , testCase "the watch list names what lies outside" $ 242 watchSection IntelDoitm "/lib.so" 243 [ x86 [ 0x48, 0xf7, 0xf6 ] "div" "rsi" 244 , x86 [ 0x48, 0x01, 0xd8 ] "add" "rax, rbx" 245 , x86 [ 0x92 ] "xchg" "eax, edx" ] 246 @?= T.unlines 247 [ "O /lib.so", "D 0 div rsi" 248 , "U 0 0 2 rax:0:32 rdx:0:32 xchg eax, edx" ] 249 ] 250 where 251 word w = Line 0 [ w ] [] "" "" 252 x86 bs m ops = Line 0 bs [] m ops 253 254 diffTests :: TestTree 255 diffTests = testGroup "diff" 256 [ testCase "a dump reads whole" $ do 257 d <- either assertFailure pure (readDump dumpA) 258 fmap inCount (dpInsns d) @?= M.fromList 259 [ (0x10, 4), (0x20, 4), (0x30, 2), (0x40, 1) ] 260 M.lookup 0x10 (fmap inObject (dpInsns d)) @?= Just (Just "/lib.so") 261 dpTransfers d @?= M.fromList 262 [ (0x10, M.fromList [ (0x30, 2) ]) ] 263 264 , testCase "a run's objects are where its instructions put them" $ do 265 a <- either assertFailure pure (readDump dumpA) 266 loadBases a @?= M.fromList [ ("/lib.so", 0) ] 267 -- the same run with /lib.so loaded 0x1000 higher 268 b <- either assertFailure pure (readDump (T.unlines 269 [ "I 1010 4 0 aaaa 0 /lib.so 10", "E 1010 1030 2" 270 , "I 1020 4 4 bbbb 0 /lib.so 20", "I 1030 2 0 cccc 0 /lib.so 30" 271 , "I 1040 1 1 dddd 0 /lib.so 40" ])) 272 loadBases b @?= M.fromList [ ("/lib.so", 0x1000) ] 273 layoutApart a b @?= [ ("/lib.so", 0, 0x1000) ] 274 layoutApart a a @?= [] 275 276 , testCase "origins are where steady instructions differ" $ do 277 a <- either assertFailure pure (readDump dumpA) 278 b <- either assertFailure pure (readDump dumpB) 279 let dv = diffDumps [ a, b ] 280 fmap (\(o, i) -> (o, inPc i)) (dvOrigins dv) 281 @?= [ (ControlOrigin, 0x10), (AddressOrigin, 0x20) ] 282 fmap inPc (dvDownstream dv) @?= [ 0x30 ] 283 284 , testCase "a loop the secret sets is an origin" $ do 285 a <- either assertFailure pure (readDump loopA) 286 b <- either assertFailure pure (readDump loopB) 287 let dv = diffDumps [ a, b ] 288 fmap (\(o, i) -> (o, inPc i)) (dvOrigins dv) 289 @?= [ (ControlOrigin, 0x10) ] 290 fmap inPc (dvDownstream dv) @?= [ 0x14, 0x18 ] 291 292 , testCase "a branch downstream, always taken, is no origin" $ do 293 a <- either assertFailure pure (readDump loopA) 294 b <- either assertFailure pure (readDump loopB) 295 let dv = diffDumps [ a, b ] 296 notElem 0x18 (fmap (inPc . snd) (dvOrigins dv)) 297 @? "a branch that always jumps is not secret-dependent" 298 299 , testCase "what differs without the secret is unsteady" $ do 300 a <- either assertFailure pure (readDump dumpA) 301 b <- either assertFailure pure (readDump dumpB) 302 -- a repeat of A whose 0x20 touched other addresses: an 303 -- entropy source, not the secret 304 c <- either assertFailure pure (readDump (T.unlines 305 [ "I 10 4 0 aaaa 0 /lib.so 10", "E 10 30 2" 306 , "I 20 4 4 ffff 0 /lib.so 20", "I 30 2 0 cccc 0 /lib.so 30" 307 , "I 40 1 1 dddd 0 /lib.so 40" ])) 308 let dv = diffControlled [ c ] [ a, b ] 309 fmap (\(o, i) -> (o, inPc i)) (dvOrigins dv) 310 @?= [ (ControlOrigin, 0x10) ] 311 fmap inPc (dvUnsteady dv) @?= [ 0x20 ] 312 313 , testCase "a designed run moves control, not addresses" $ do 314 a <- either assertFailure pure (readDump dumpA) 315 b <- either assertFailure pure (readDump dumpB) 316 -- a run designed onto another path: 0x10 taken every time, and 317 -- 0x20's addresses its own 318 x <- either assertFailure pure (readDump (T.unlines 319 [ "I 10 4 0 aaaa 0 /lib.so 10", "E 10 30 4" 320 , "I 20 4 4 9999 0 /lib.so 20", "I 30 4 0 cccc 0 /lib.so 30" 321 , "I 50 1 0 eeee 0 /lib.so 50" ])) 322 let dv = diffDesigned [] [ a, a ] [ x ] 323 fmap (\(o, i) -> (o, inPc i)) (dvOrigins dv) 324 @?= [ (ControlOrigin, 0x10) ] 325 dvDesigned dv @?= 1 326 M.lookup "/lib.so" (dvExecuted dv) 327 @?= Just (S.fromList [ 0x10, 0x20, 0x30, 0x40, 0x50 ]) 328 -- a declared run differing there is still an address origin 329 fmap (\(o, i) -> (o, inPc i)) (dvOrigins (diffDesigned [] [ a, b ] 330 [ x ])) @?= [ (ControlOrigin, 0x10), (AddressOrigin, 0x20) ] 331 332 , testCase "an origin names the runs alike at it" $ do 333 a <- either assertFailure pure (readDump dumpA) 334 b <- either assertFailure pure (readDump dumpB) 335 x <- either assertFailure pure (readDump (T.unlines 336 [ "I 10 4 0 aaaa 0 /lib.so 10", "E 10 30 4" 337 , "I 20 4 4 9999 0 /lib.so 20", "I 30 4 0 cccc 0 /lib.so 30" ])) 338 -- at the branch, the first and third runs alike; the designed 339 -- run is a control origin's to group, and the address origin 340 -- speaks only of the declared runs 341 let dv = diffDesigned [] [ a, b, a ] [ x ] 342 M.lookup (ControlOrigin, 0x10) (dvBehaviour dv) 343 @?= Just ([ [ 0, 2 ], [ 1 ], [ 3 ] ], []) 344 M.lookup (AddressOrigin, 0x20) (dvBehaviour dv) 345 @?= Just ([ [ 0, 2 ], [ 1 ] ], []) 346 -- the designed run never reaches 0x40 347 M.lookup (ControlOrigin, 0x10) 348 (dvBehaviour (diffDesigned [] [ a, a ] [ x ])) 349 @?= Just ([ [ 0, 1 ], [ 2 ] ], []) 350 351 , testCase "downstream is kept to the objects under audit" $ do 352 a <- either assertFailure pure (readDump dumpA) 353 b <- either assertFailure pure (readDump (T.unlines 354 [ "I 10 4 0 aaaa 0 /lib.so 10", "E 10 30 3" 355 , "I 20 4 4 bbbb 0 /lib.so 20", "I 30 3 0 cccc 0 /lib.so 30" 356 , "I 40 1 1 dddd 0 /lib.so 40", "I 60 2 0 ffff 0 /libc.so 60" ])) 357 let dv = diffDumps [ a, b ] 358 fmap inPc (dvDownstream dv) @?= [ 0x30, 0x60 ] 359 fmap inPc (dvDownstream (restrictTo [ "lib.so" ] dv)) 360 @?= [ 0x30 ] 361 362 , testCase "a branch taken as often, in another order, is an origin" $ do 363 -- 0x10 runs twice and falls through once and jumps once in both 364 -- runs, but in the other order 365 a <- either assertFailure pure (readDump (T.unlines 366 [ "I 10 2 0 aaaa 1111 /lib.so 10", "E 10 30 1" 367 , "I 20 1 0 bbbb 0 /lib.so 20", "I 30 1 0 cccc 0 /lib.so 30" ])) 368 b <- either assertFailure pure (readDump (T.unlines 369 [ "I 10 2 0 aaaa 2222 /lib.so 10", "E 10 30 1" 370 , "I 20 1 0 bbbb 0 /lib.so 20", "I 30 1 0 cccc 0 /lib.so 30" ])) 371 fmap (\(o, i) -> (o, inPc i)) (dvOrigins (diffDumps [ a, b ])) 372 @?= [ (ControlOrigin, 0x10) ] 373 M.lookup (ControlOrigin, 0x10) (dvBehaviour (diffDumps [ a, b, a ])) 374 @?= Just ([ [ 0, 2 ], [ 1 ] ], []) 375 -- in the same order, nothing 376 dvOrigins (diffDumps [ a, a ]) @?= [] 377 378 , testCase "a return goes where its call sent it: downstream" $ do 379 -- 0x50 returns four times in each run, to 0x30 twice in A and 380 -- three times in B, as the branch at 0x10 sent it 381 a <- either assertFailure pure (readDump (dumpA <> T.unlines 382 [ "I 50 4 0 aaaa 0 /lib.so 50", "R 50", "E 50 30 2" 383 , "E 50 60 2" ])) 384 b <- either assertFailure pure (readDump (dumpB <> T.unlines 385 [ "I 50 4 0 aaaa 0 /lib.so 50", "R 50", "E 50 30 3" 386 , "E 50 60 1" ])) 387 let dv = diffDumps [ a, b ] 388 fmap (\(o, i) -> (o, inPc i)) (dvOrigins dv) 389 @?= [ (ControlOrigin, 0x10), (AddressOrigin, 0x20) ] 390 fmap inPc (dvDownstream dv) @?= [ 0x30, 0x50 ] 391 392 , testCase "a division on other operands is an operand origin" $ do 393 -- 0x40 divides once in every run, on other operands in B; in a 394 -- designed run, on others again 395 a <- either assertFailure pure (readDump (dumpA <> "D 40 1111\n")) 396 b <- either assertFailure pure (readDump (dumpB <> "D 40 2222\n")) 397 x <- either assertFailure pure (readDump (dumpA <> "D 40 3333\n")) 398 let dv = diffDumps [ a, b ] 399 fmap (\(o, i) -> (o, inPc i)) (dvOrigins dv) 400 @?= [ (ControlOrigin, 0x10), (AddressOrigin, 0x20) 401 , (OperandOrigin, 0x40) ] 402 M.lookup (OperandOrigin, 0x40) (dvBehaviour (diffDumps [ a, b, a ])) 403 @?= Just ([ [ 0, 2 ], [ 1 ] ], []) 404 notElem 0x40 (fmap inPc (dvDownstream dv)) @? "downstream" 405 -- a designed run's operands say nothing of the secret 406 fmap (\(o, i) -> (o, inPc i)) (dvOrigins (diffDesigned [] [ a, a ] 407 [ x ])) @?= [] 408 -- a control dividing other operands sets it apart as unsteady 409 fmap inPc (dvUnsteady (diffControlled [ x ] [ a, b ])) @?= [ 0x40 ] 410 411 , testCase "an instruction outside the contract is reported apart" $ do 412 -- 0x40 runs once in every run, outside the contract, on other 413 -- operands in B; 0x30 is watched too, on the same operands 414 let under d = d <> "U 30 7777\nW 30 popcnt rax, rbx\nU 40 " 415 a <- either assertFailure pure 416 (readDump (under dumpA <> "1111\nM x86_64\nG intel-doitm\n")) 417 b <- either assertFailure pure 418 (readDump (under dumpB <> "2222\nM x86_64\nG intel-doitm\n")) 419 x <- either assertFailure pure 420 (readDump (under dumpA <> "3333\nM x86_64\nG intel-doitm\n")) 421 dpIsa a @?= Just "x86_64" 422 dpContract a @?= Just "intel-doitm" 423 dpCpu a @?= Nothing 424 c <- either assertFailure pure 425 (readDump (dumpA <> "M aarch64\nP max,crypto=off\n")) 426 dpCpu c @?= Just "max,crypto=off" 427 dvCpu (diffDumps [ c, c ]) @?= Just "max,crypto=off" 428 M.lookup 0x30 (dpTexts a) @?= Just "popcnt rax, rbx" 429 let dv = diffDumps [ a, b ] 430 -- not an origin: the contract says nothing either way of it 431 fmap (\(o, i) -> (o, inPc i)) (dvOrigins dv) 432 @?= [ (ControlOrigin, 0x10), (AddressOrigin, 0x20) ] 433 fmap inPc (dvOutside dv) @?= [ 0x40 ] 434 M.lookup 0x40 (dvOutsideBehaviour (diffDumps [ a, b, a ])) 435 @?= Just ([ [ 0, 2 ], [ 1 ] ], []) 436 dvWatched dv @?= M.fromList [ ("/lib.so", S.fromList [ 0x30, 0x40 ]) ] 437 notElem 0x40 (fmap inPc (dvDownstream dv)) @? "downstream" 438 -- runs alike in their operands show nothing outside 439 dvOutside (diffDumps [ a, a ]) @?= [] 440 -- a control on other operands sets it apart as unsteady 441 dvOutside (diffControlled [ x ] [ a, b ]) @?= [] 442 fmap inPc (dvUnsteady (diffControlled [ x ] [ a, b ])) @?= [ 0x40 ] 443 -- and the objects kept are the objects reported 444 dvOutside (restrictTo [ "/other.so" ] dv) @?= [] 445 446 , testCase "an origin is given the calls that reached it" $ do 447 -- 0x10 ran in context 2 (the call at 0x40 made in context 1, 448 -- the call at 0x30 made in the program's own) in A, and in the 449 -- program's own context too in B 450 let calls = T.unlines 451 [ "C 1 0 30", "C 2 1 40" ] 452 a <- either assertFailure pure (readDump (dumpA <> calls 453 <> "K 10 0 2\n")) 454 b <- either assertFailure pure (readDump (dumpB <> calls 455 <> "K 10 1 2 0\n")) 456 callsOf a 2 @?= [ (Just "/lib.so", 0x40), (Just "/lib.so", 0x30) ] 457 callsOf a 0 @?= [] 458 M.lookup 0x10 (dvCallers (diffDumps [ a, b ])) 459 @?= Just ([ [ (Just "/lib.so", 0x40), (Just "/lib.so", 0x30) ] 460 , [] ], True) 461 M.lookup 0x10 (dvCallers (diffDumps [ a, a ])) 462 @?= Nothing 463 464 , testCase "contexts that do not chain back are refused" $ do 465 isLeft (readDump (dumpA <> "C 1 2 30\nC 2 1 40\n")) 466 @? "a context made in a later one" 467 isLeft (readDump (dumpA <> "K 10 0 5\n")) 468 @? "a context never made" 469 470 , testCase "identical runs have no origins" $ do 471 a <- either assertFailure pure (readDump dumpA) 472 let dv = diffDumps [ a, a ] 473 dvOrigins dv @?= [] 474 dvDownstream dv @?= [] 475 476 , testCase "what any run executed is kept per object" $ do 477 a <- either assertFailure pure (readDump dumpA) 478 b <- either assertFailure pure (readDump (T.unlines 479 [ "I 10 4 0 aaaa 0 /lib.so 10", "I 50 1 0 eeee 0 /lib.so 50" 480 , "I 60 1 0 ffff 0 /libc.so 60", "I 70 0 0 0000 0 /lib.so 70" ])) 481 let dv = diffDumps [ a, b ] 482 dvExecuted dv @?= M.fromList 483 [ ("/lib.so", S.fromList [ 0x10, 0x20, 0x30, 0x40, 0x50 ]) 484 , ("/libc.so", S.fromList [ 0x60 ]) ] 485 M.keys (dvExecuted (restrictTo [ "lib.so" ] dv)) 486 @?= [ "/lib.so" ] 487 488 , testCase "a dump in which nothing ran is refused" $ do 489 isLeft (readDump "") @? "an empty dump accepted" 490 isLeft (readDump "I 10 0 0 aaaa 0 /lib.so 10\n") 491 @? "a dump of instructions never run accepted" 492 493 , testCase "an unreadable line is refused" $ 494 isLeft (readDump "I 10 zz 0 f 0 /lib.so 0\n") @? "accepted" 495 496 , testCase "a guest stopped for a second thread is refused" $ 497 isLeft (readDump "T 2\n") @? "accepted" 498 499 , testCase "a run's record reads whole" $ do 500 d <- either assertFailure pure (readDump (dumpA <> T.unlines 501 [ "A 2f62696e2f70", "A", "A 3035", "N 2 1a", "X -9" ])) 502 dpRun d @?= Just (Run [ "/bin/p", "", "05" ] (2, 0x1a) (-9)) 503 fmap dpRun (readDump dumpA) @?= Right Nothing 504 505 , testCase "an incomplete record is refused" $ do 506 isLeft (readDump (dumpA <> "A 3035\nN 2 1a\n")) @? "no status" 507 isLeft (readDump (dumpA <> "N 2 1a\nX 0\n")) @? "no arguments" 508 isLeft (readDump (dumpA <> "A 305\nN 2 1a\nX 0\n")) 509 @? "half a byte" 510 511 , testCase "runs made apart are told apart" $ do 512 let r = Run [ "/bin/p", "05" ] (2, 0x1a) 0 513 runApart r r { rnArguments = [ "/bin/p", "3a" ], rnStatus = 1 } 514 @?= Nothing 515 isJust (runApart r r { rnArguments = [ "/bin/q", "05" ] }) 516 @? "another program" 517 isJust (runApart r r { rnArguments = [ "/bin/p", "005" ] }) 518 @? "a longer argument" 519 isJust (runApart r r { rnArguments = [ "/bin/p", "05", "x" ] }) 520 @? "another argument" 521 isJust (runApart r r { rnEnvironment = (2, 0x1b) }) 522 @? "a larger environment" 523 ] 524 where 525 -- 0x10 is a branch run four times, taken twice in A and three 526 -- times in B; 0x20 reads other addresses in B; 0x30, inside the 527 -- branch, runs a different number of times; 0x40 is the same 528 dumpA = T.unlines 529 [ "I 10 4 0 aaaa 0 /lib.so 10", "E 10 30 2" 530 , "I 20 4 4 bbbb 0 /lib.so 20", "I 30 2 0 cccc 0 /lib.so 30" 531 , "I 40 1 1 dddd 0 /lib.so 40" ] 532 dumpB = T.unlines 533 [ "I 10 4 0 aaaa 0 /lib.so 10", "E 10 30 3" 534 , "I 20 4 4 eeee 0 /lib.so 20", "I 30 3 0 cccc 0 /lib.so 30" 535 , "I 40 1 1 dddd 0 /lib.so 40" ] 536 -- a loop at 0x10 the secret runs 5 or 9 times, its back edge to 537 -- 0x14 taken every time but the last; 0x18, in the body, always 538 -- jumps back to 0x10 539 loopA = T.unlines 540 [ "I 10 5 0 aaaa 0 /lib.so 10", "E 10 14 4" 541 , "I 14 4 0 bbbb 0 /lib.so 14" 542 , "I 18 4 0 cccc 0 /lib.so 18", "E 18 10 4" ] 543 loopB = T.unlines 544 [ "I 10 9 0 aaaa 0 /lib.so 10", "E 10 14 8" 545 , "I 14 8 0 bbbb 0 /lib.so 14" 546 , "I 18 8 0 cccc 0 /lib.so 18", "E 18 10 8" ] 547 548 symbolTests :: TestTree 549 symbolTests = testGroup "symbol" 550 [ testCase "addr2line's inlined frames and discriminators" $ 551 parseAddr2line (T.unlines 552 [ "0x0000000000001234", "inner", "/src/a.rs:12 (discriminator 3)" 553 , "outer", "/src/b.rs:40", "0x0000000000005678", "??", "??:0" ]) 554 @?= [ (0x1234, [ Place (Just "inner") (Just "/src/a.rs") (Just 12) 555 , Place (Just "outer") (Just "/src/b.rs") (Just 40) ]) 556 , (0x5678, [ Place Nothing Nothing Nothing ]) ] 557 558 , testCase "a legacy Rust name's escapes and hash undone" $ do 559 rustLegacy "decaf377::ark_curve::encoding::_$LT$impl$u20$decaf377\ 560 \..ark_curve..element..projective..Element$GT$::vartime\ 561 \_compress_to_field::h346fee1681a4f34f" 562 @?= "decaf377::ark_curve::encoding::<impl decaf377::ark_curve::\ 563 \element::projective::Element>::vartime_compress_to_field" 564 rustLegacy "_$LT$$RF$T$u20$as$u20$core..fmt..Debug$GT$::fmt::\ 565 \h0123456789abcdef" 566 @?= "<&T as core::fmt::Debug>::fmt" 567 -- a C++ name, or one without a hash, is left as it is 568 rustLegacy "std::vector<int>::size" @?= "std::vector<int>::size" 569 rustLegacy "a::b$LT$c" @?= "a::b$LT$c" 570 ] 571 572 jsonTests :: TestTree 573 jsonTests = testGroup "json" 574 [ testCase "objects keep their order and strings escape" $ 575 encode (Object [ ("b", Number 1) 576 , ("a", String "q\"\n\1") ]) 577 @?= "{\n \"b\": 1,\n \"a\": \"q\\\"\\n\\u0001\"\n}\n" 578 ] 579 580 -- a trace of one run, of which memcheck's report is all that is 581 -- known 582 one :: Memcheck -> Trace 583 one mc = trace [ Taint "run" mc [] Nothing ] 584 585 at :: Site -> Frame 586 at = lcFrame . siAt 587 588 fixture :: FilePath -> IO Memcheck 589 fixture f = do 590 b <- BS.readFile ("test/fixtures/" <> f) 591 either assertFailure pure (readMemcheck (TE.decodeUtf8 b)) 592 593 isLeft :: Either a b -> Bool 594 isLeft e = case e of 595 Left _ -> True 596 Right _ -> False 597 598 isJust :: Maybe a -> Bool 599 isJust m = case m of 600 Just _ -> True 601 Nothing -> False 602 603 -- a secret branch, an uninitialised heap read, a bad read, and a 604 -- leak report 605 mixed :: T.Text 606 mixed = doc 607 [ err "0x0" "UninitCondition" "0x10" 608 (Just "Uninitialised value was created by a client request") 609 , err "0x1" "UninitValue" "0x20" 610 (Just "Uninitialised value was created by a heap allocation") 611 , err "0x2" "InvalidRead" "0x30" Nothing 612 , err "0x3" "Leak_PossiblyLost" "0x40" Nothing 613 ] 614 [ ("0x0", 5), ("0x1", 1), ("0x2", 1) ] 615 616 -- one secret branch reached by two callers 617 twoCallers :: T.Text 618 twoCallers = doc 619 [ errStack "0x0" "UninitCondition" [ "0x10", "0x40" ] 620 , errStack "0x1" "UninitCondition" [ "0x10", "0x50" ] 621 ] 622 [ ("0x0", 3), ("0x1", 4) ] 623 where 624 errStack u k ips = T.concat 625 [ "<error><unique>", u, "</unique><kind>", k, "</kind>" 626 , "<what>w</what><stack>" 627 , T.concat [ "<frame><ip>" <> ip <> "</ip></frame>" | ip <- ips ] 628 , "</stack><auxwhat>Uninitialised value was created by a \ 629 \client request</auxwhat><stack><frame><ip>0x1</ip>\ 630 \</frame></stack></error>" ] 631 632 doc :: [T.Text] -> [(T.Text, Int)] -> T.Text 633 doc errs counts = T.concat $ 634 [ "<?xml version=\"1.0\"?><valgrindoutput>" 635 , "<protocolversion>6</protocolversion>" 636 , "<protocoltool>memcheck</protocoltool>" ] 637 <> errs 638 <> [ "<errorcounts>" ] 639 <> [ "<pair><count>" <> T.pack (show n) <> "</count><unique>" <> u 640 <> "</unique></pair>" | (u, n) <- counts ] 641 <> [ "</errorcounts></valgrindoutput>" ] 642 643 err :: T.Text -> T.Text -> T.Text -> Maybe T.Text -> T.Text 644 err u k ip morigin = T.concat $ 645 [ "<error><unique>", u, "</unique><kind>", k, "</kind>" 646 , "<what>w</what><stack><frame><ip>", ip, "</ip></frame></stack>" ] 647 <> case morigin of 648 Just o -> [ "<auxwhat>", o, "</auxwhat><stack><frame><ip>0x1" 649 , "</ip></frame></stack>" ] 650 Nothing -> [] 651 <> [ "</error>" ]