auditor

Main.hs (64974B)

---

 {-# LANGUAGE OverloadedStrings #-}
 
 module Main where
 
 import Audit.AArch64
 import Audit.AArch64.CallGraph
 import Audit.AArch64.Parser
 import Audit.AArch64.Runtime.GHC (ghcRuntime)
 import Audit.AArch64.Taint
 import Audit.AArch64.Types
 import Data.Aeson (eitherDecodeStrict')
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Text as T
 import Test.Tasty
 import Test.Tasty.HUnit
 
 -- | Runtime config used throughout tests.
 rt :: RuntimeConfig
 rt = ghcRuntime
 
 -- | Check if a violation is secret-derived
 -- (not unknown or structural).
 isSecretViolation :: ViolationReason -> Bool
 isSecretViolation r = case r of
   SecretBase _     -> True
   SecretIndex _    -> True
   UnknownBase _    -> False
   UnknownIndex _   -> False
   NonConstOffset   -> False
 
 main :: IO ()
 main = defaultMain $ testGroup "ppad-auditor" [
     parserTests
   , taintTests
   , auditTests
   , interprocTests
   , provenanceTests
   , taintConfigTests
   , nctTests
   , callGraphTests
   , tailCallTests
   ]
 
 -- Parser tests
 
 parserTests :: TestTree
 parserTests = testGroup "Parser" [
     testCase "parse label" $ do
       let src = "foo:\n"
       case parseAsm src of
         Left _ -> assertFailure "parse failed"
         Right lns -> do
           assertEqual "line count" 1 (length lns)
           assertEqual "label" (Just "foo")
             (lineLabel (head lns))
 
   , testCase "parse ldr base+imm" $ do
       let src = "ldr x0, [x20, #8]\n"
       case parseAsm src of
         Left _ -> assertFailure "parse failed"
         Right lns -> case lineInstr (head lns) of
           Just (Ldr X0 (BaseImm X20 8)) -> pure ()
           other -> assertFailure $
             "unexpected: " ++ show other
 
   , testCase "parse str base+reg" $ do
       let src = "str x1, [x21, x2]\n"
       case parseAsm src of
         Left _ -> assertFailure "parse failed"
         Right lns -> case lineInstr (head lns) of
           Just (Str X1 (BaseReg X21 X2)) -> pure ()
           other -> assertFailure $
             "unexpected: " ++ show other
 
   , testCase "parse add" $ do
       let src = "add x0, x1, x2\n"
       case parseAsm src of
         Left _ -> assertFailure "parse failed"
         Right lns -> case lineInstr (head lns) of
           Just (Add X0 X1 (OpReg X2)) -> pure ()
           other -> assertFailure $
             "unexpected: " ++ show other
 
   , testCase "parse adrp" $ do
       let src = "adrp x5, _symbol@PAGE\n"
       case parseAsm src of
         Left _ -> assertFailure "parse failed"
         Right lns -> case lineInstr (head lns) of
           Just (Adrp X5 _) -> pure ()
           other -> assertFailure $
             "unexpected: " ++ show other
 
   , testCase "skip directives" $ do
       let src = ".section __TEXT\n\
                 \.globl _foo\n_foo:\n  ret\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let instrs = filter
                 ((/= Nothing) . lineInstr) lns
           assertEqual "instruction count"
             1 (length instrs)
 
   , testCase "parse ldr base+symbol" $ do
       let src = "ldr x8, [x8, _foo@GOTPAGEOFF]\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns ->
           case lineInstr (safeHead lns) of
             Just (Ldr X8
               (BaseSymbol X8 "_foo@GOTPAGEOFF"))
               -> pure ()
             other -> assertFailure $
               "unexpected: " ++ show other
 
   , testCase "parse shifted register operand" $ do
       let src = "add x0, x1, x2, lsl #3\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns ->
           case lineInstr (safeHead lns) of
             Just (Add X0 X1
               (OpShiftedReg X2 (LSL 3))) -> pure ()
             other -> assertFailure $
               "unexpected: " ++ show other
 
   , testCase "parse shifted immediate operand" $ do
       -- regression: `cmp x8, #16, lsl #12` is the uimm12
       -- shifted-immediate form (16 << 12 = 65536). The
       -- parser must fold the shift into the literal.
       let src = "cmp x8, #16, lsl #12\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns ->
           case lineInstr (safeHead lns) of
             Just (Cmp X8 (OpImm 65536)) -> pure ()
             other -> assertFailure $
               "unexpected: " ++ show other
 
   , testCase "parse plain register operand" $ do
       let src = "add x0, x1, x2\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns ->
           case lineInstr (safeHead lns) of
             Just (Add X0 X1 (OpReg X2)) -> pure ()
             other -> assertFailure $
               "unexpected: " ++ show other
 
   , testCase "parse literal address" $ do
       let src = "ldr x0, =foo\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns ->
           case lineInstr (safeHead lns) of
             Just (Ldr X0 (Literal "foo")) -> pure ()
             other -> assertFailure $
               "unexpected: " ++ show other
 
   , testCase "parse all register types" $ do
       let src = T.unlines
             [ "mov x0, x1"
             , "mov w0, w1"
             , "mov d0, d1"
             , "mov s0, s1"
             , "mov q0, q1"
             , "mov x0, sp"
             , "mov x0, xzr"
             , "mov w0, wzr"
             , "mov x0, fp"
             , "mov x0, lr"
             ]
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns ->
           assertEqual "parsed all lines"
             10 (length lns)
 
   , testCase "parse label with instruction" $ do
       let src = "foo: mov x0, x1\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> case safeHead lns of
           Line _ (Just "foo")
             (Just (Mov X0 (OpReg X1))) -> pure ()
           other -> assertFailure $
             "unexpected: " ++ show other
 
   , testCase "parse instruction without label" $ do
       let src = "  mov x0, x1\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> case safeHead lns of
           Line _ Nothing
             (Just (Mov X0 (OpReg X1))) -> pure ()
           other -> assertFailure $
             "unexpected: " ++ show other
 
   -- Acquire/release and exclusive memory ops
   , testCase "parse ldar" $ do
       let src = "ldar x0, [x1]\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns ->
           case lineInstr (safeHead lns) of
             Just (Ldar X0 (BaseImm X1 0)) ->
               pure ()
             other -> assertFailure $
               "unexpected: " ++ show other
 
   , testCase "parse stlr" $ do
       let src = "stlr x0, [x1]\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns ->
           case lineInstr (safeHead lns) of
             Just (Stlr X0 (BaseImm X1 0)) ->
               pure ()
             other -> assertFailure $
               "unexpected: " ++ show other
 
   , testCase "parse stxr" $ do
       let src = "stxr w0, x1, [x2]\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns ->
           case lineInstr (safeHead lns) of
             Just (Stxr W0 X1 (BaseImm X2 0)) ->
               pure ()
             other -> assertFailure $
               "unexpected: " ++ show other
 
   , testCase "parse ldaxr" $ do
       let src = "ldaxr x0, [x1]\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns ->
           case lineInstr (safeHead lns) of
             Just (Ldaxr X0 (BaseImm X1 0)) ->
               pure ()
             other -> assertFailure $
               "unexpected: " ++ show other
 
   , testCase "parse stlxr" $ do
       let src = "stlxr w0, x1, [x2]\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns ->
           case lineInstr (safeHead lns) of
             Just (Stlxr W0 X1 (BaseImm X2 0)) ->
               pure ()
             other -> assertFailure $
               "unexpected: " ++ show other
   ]
 
 safeHead :: [a] -> a
 safeHead (x:_) = x
 safeHead []    = error "safeHead: empty list"
 
 -- Taint tests
 
 taintTests :: TestTree
 taintTests = testGroup "Taint" [
     testCase "public roots" $ do
       let st = initTaintState rt
       assertEqual "X20 is public"
         Public (getTaint X20 st)
       assertEqual "X21 is public"
         Public (getTaint X21 st)
       assertEqual "SP is public"
         Public (getTaint SP st)
 
   , testCase "unknown register" $ do
       let st = initTaintState rt
       assertEqual "X0 is unknown"
         Unknown (getTaint X0 st)
 
   , testCase "mov propagates taint" $ do
       let st = initTaintState rt
           l = Line 1 Nothing
                 (Just (Mov X0 (OpReg X20)))
           st' = analyzeLine rt l st
       assertEqual "X0 becomes public"
         Public (getTaint X0 st')
 
   , testCase "add joins taints" $ do
       let st = initTaintState rt
           l = Line 1 Nothing
                 (Just (Add X0 X20 (OpReg X1)))
           st' = analyzeLine rt l st
       assertEqual "result is unknown"
         Unknown (getTaint X0 st')
 
   , testCase "load makes unknown" $ do
       let st = initTaintStateWith rt False
           l = Line 1 Nothing
                 (Just (Ldr X0 (BaseImm X20 0)))
           st' = analyzeLine rt l st
       assertEqual "loaded value is unknown"
         Unknown (getTaint X0 st')
   ]
 
 -- Audit tests
 
 auditTests :: TestTree
 auditTests = testGroup "Audit" [
     testCase "good: public base" $ do
       let src = T.unlines
             [ "foo:"
             , "  ldr x0, [x20, #8]"
             , "  str x0, [x21]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "bad: unknown base" $ do
       let src = T.unlines
             [ "foo:"
             , "  ldr x0, [x0]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               UnknownBase X0 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "bad: secret-derived index" $ do
       let src = T.unlines
             [ "foo:"
             , "  ldr x0, [x21]"
             , "  ldr x1, [x20, x0]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               UnknownIndex X0 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "good: adrp+add pattern" $ do
       let src = T.unlines
             [ "foo:"
             , "  adrp x8, _const@PAGE"
             , "  add x8, x8, _const@PAGEOFF"
             , "  ldr x0, [x8]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "good: cross-block public taint" $ do
       let src = T.unlines
             [ "blockA:"
             , "  adrp x8, _const@PAGE"
             , "  cbz x0, blockB"
             , "blockB:"
             , "  ldr x1, [x8]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "bad: cross-block unknown taint" $ do
       let src = T.unlines
             [ "blockA:"
             , "  ldr x8, [x21]"
             , "  cbz x0, blockB"
             , "blockB:"
             , "  ldr x1, [x8]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               UnknownBase X8 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "call: no taint propagation to callee" $ do
       let src = T.unlines
             [ "caller:"
             , "  adrp x8, _const@PAGE"
             , "  bl callee"
             , "  ret"
             , "callee:"
             , "  ldr x0, [x8]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> do
               assertEqual "violation in callee"
                 "callee" (vSymbol v)
               case vReason v of
                 UnknownBase X8 -> pure ()
                 other -> assertFailure $
                   "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "call: caller-saved invalidation" $ do
       let src = T.unlines
             [ "foo:"
             , "  adrp x0, _const@PAGE"
             , "  bl bar"
             , "  ldr x1, [x0]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               UnknownBase X0 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "call: callee-saved preserved" $ do
       let src = T.unlines
             [ "foo:"
             , "  bl bar"
             , "  ldr x0, [x19]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "good: stack spill/reload preserves public" $ do
       let src = T.unlines
             [ "foo:"
             , "  stp x20, x21, [sp]"
             , "  ldr x8, [sp]"
             , "  ldr x9, [sp, #8]"
             , "  ldr x0, [x8]"
             , "  ldr x1, [x9]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "bad: stack spill/reload preserves unknown" $ do
       let src = T.unlines
             [ "foo:"
             , "  ldr x8, [x21]"
             , "  str x8, [sp, #16]"
             , "  ldr x9, [sp, #16]"
             , "  ldr x0, [x9]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               UnknownBase X9 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "good: pointer spill/reload preserves kind" $ do
       let src = T.unlines
             [ "foo:"
             , "  adrp x8, _const@PAGE"
             , "  str x8, [sp, #16]"
             , "  ldr x9, [sp, #16]"
             , "  ldr x0, [x9]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "bad: scalar spill/reload doesn't upgrade kind" $ do
       let src = T.unlines
             [ "foo:"
             , "  ldr x8, [x21]"
             , "  add x8, x20, x8"
             , "  str x8, [sp, #16]"
             , "  ldr x9, [sp, #16]"
             , "  ldr x0, [x9]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               UnknownBase X9 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   -- STG stack (x20-relative) spill/reload tests
   , testCase "good: STG stack spill/reload preserves public" $ do
       let src = T.unlines
             [ "foo:"
             , "  adrp x8, _const@PAGE"
             , "  str x8, [x20, #8]"
             , "  ldr x9, [x20, #8]"
             , "  ldr x0, [x9]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "bad: STG stack spill/reload preserves unknown" $ do
       let src = T.unlines
             [ "foo:"
             , "  ldr x8, [x21]"
             , "  str x8, [x20, #16]"
             , "  ldr x9, [x20, #16]"
             , "  ldr x0, [x9]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               UnknownBase X9 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "good: STG stack pointer spill preserves kind" $ do
       let src = T.unlines
             [ "foo:"
             , "  adrp x8, _const@PAGE"
             , "  str x8, [x20, #24]"
             , "  ldr x9, [x20, #24]"
             , "  ldr x0, [x9]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "good: STG stack pre-indexed load preserves taint" $ do
       let src = T.unlines
             [ "foo:"
             , "  adrp x8, _const@PAGE"
             , "  str x8, [x20, #16]"
             , "  ldr x9, [x20, #16]!"
             , "  ldr x0, [x9]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "good: GOT/PLT pattern" $ do
       let src = T.unlines
             [ "foo:"
             , "  adrp x8, _sym@GOTPAGE"
             , "  ldr x8, [x8, _sym@GOTPAGEOFF]"
             , "  ldr x0, [x8]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   -- Heap taint propagation tests
   , testCase "bad: heap store propagates secret to later load" $ do
       let src = T.unlines
             [ "_foo:"
             , "  str x0, [x21]"
             , "  ldr x9, [x21, #8]"
             , "  ldr x1, [x20, x9]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               SecretIndex X9 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "bad: heap taints join on multiple stores" $ do
       let src = T.unlines
             [ "_foo:"
             , "  adrp x8, _const@PAGE"
             , "  str x8, [x21]"
             , "  str x0, [x21, #8]"
             , "  ldr x9, [x21, #16]"
             , "  ldr x1, [x20, x9]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               SecretIndex X9 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   -- Refined heap slot tests
   , testCase "good: refined heap slot preserves public at different offset" $ do
       let src = T.unlines
             [ "_foo:"
             , "  adrp x8, _const@PAGE"
             , "  str x0, [x21]"
             , "  str x8, [x21, #8]"
             , "  ldr x9, [x21, #8]"
             , "  ldr x10, [x9]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "bad: refined heap slot preserves secret at its offset" $ do
       let src = T.unlines
             [ "_foo:"
             , "  adrp x8, _const@PAGE"
             , "  str x8, [x21]"
             , "  str x0, [x21, #8]"
             , "  ldr x9, [x21, #8]"
             , "  ldr x10, [x20, x9]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               SecretIndex X9 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "bad: refined heap slot falls back for unknown offset" $ do
       let src = T.unlines
             [ "_foo:"
             , "  str x0, [x21]"
             , "  ldr x9, [x21, #16]"
             , "  ldr x10, [x20, x9]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               SecretIndex X9 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   -- Acquire/release and exclusive memory ops
   , testCase "bad: ldar from unknown base" $ do
       let src = T.unlines
             [ "_foo:"
             , "  ldar x8, [x0]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               UnknownBase X0 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "good: stlr to stack preserves taint" $ do
       let src = T.unlines
             [ "_foo:"
             , "  adrp x8, _const@PAGE"
             , "  stlr x8, [sp]"
             , "  ldr x9, [sp]"
             , "  ldr x10, [x9]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "good: stxr status register is public" $ do
       let src = T.unlines
             [ "_foo:"
             , "  stxr w0, x1, [x21]"
             , "  ldr x8, [x20, w0]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "good: stlxr status register is public" $ do
       let src = T.unlines
             [ "_foo:"
             , "  stlxr w0, x1, [x21]"
             , "  ldr x8, [x20, w0]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
   ]
 
 -- Inter-procedural tests
 
 interprocTests :: TestTree
 interprocTests = testGroup "InterProc" [
     testCase "interproc: callee sets x0 public" $ do
       let src = T.unlines
             [ "_callee:"
             , "  adrp x0, _const@PAGE"
             , "  ret"
             , "_caller:"
             , "  bl _callee"
             , "  ldr x1, [x0]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "default: 1 violation"
           1 (length (arViolations ar))
       case auditInterProc rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "interproc: 0 violations"
           0 (length (arViolations ar))
 
   , testCase "interproc: callee leaves x0 unknown" $ do
       let src = T.unlines
             [ "_callee:"
             , "  ldr x0, [x21]"
             , "  ret"
             , "_caller:"
             , "  bl _callee"
             , "  ldr x1, [x0]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "default: 1 violation"
           1 (length (arViolations ar))
       case auditInterProc rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "interproc: 1 violation"
           1 (length (arViolations ar))
 
   , testCase "interproc: default mode unchanged" $ do
       let src = T.unlines
             [ "foo:"
             , "  adrp x8, _const@PAGE"
             , "  bl bar"
             , "  ldr x0, [x8]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "1 violation"
           1 (length (arViolations ar))
   ]
 
 -- Provenance tests
 
 provenanceTests :: TestTree
 provenanceTests = testGroup "Provenance" [
     testCase "good: mov from public root preserves provenance" $ do
       let src = T.unlines
             [ "foo:"
             , "  mov x8, x20"
             , "  ldr x0, [x8]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "good: add #imm preserves provenance" $ do
       let src = T.unlines
             [ "foo:"
             , "  add x8, x20, #16"
             , "  ldr x0, [x8]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "bad: load clears provenance" $ do
       let src = T.unlines
             [ "foo:"
             , "  mov x8, x20"
             , "  ldr x8, [x8]"
             , "  ldr x0, [x8]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               UnknownBase X8 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "good: orr with xzr preserves provenance" $ do
       let src = T.unlines
             [ "foo:"
             , "  mov x8, x20"
             , "  orr x9, x8, xzr"
             , "  ldr x0, [x9]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "good: pointer untagging preserves public provenance" $ do
       let src = T.unlines
             [ "foo:"
             , "  mov x8, x20"
             , "  and x8, x8, #0xfffffffffffffff8"
             , "  ldr x0, [x8]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "bad: pointer untagging doesn't upgrade unknown provenance" $ do
       let src = T.unlines
             [ "foo:"
             , "  ldr x8, [x21]"
             , "  and x8, x8, #-8"
             , "  ldr x0, [x8]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "one violation"
           1 (length (arViolations ar))
 
   , testCase "bad: scalar cannot be laundered via provenance" $ do
       let src = T.unlines
             [ "foo:"
             , "  ldr x8, [x21]"
             , "  add x9, x20, x8"
             , "  ldr x0, [x9]"
             , "  ret"
             ]
       case audit rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               UnknownBase X9 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
   ]
 
 -- Taint config tests
 
 taintConfigTests :: TestTree
 taintConfigTests = testGroup "TaintConfig" [
     testCase "parse valid config" $ do
       let json = B8.pack
             "{\"foo\": {\"secret\": [\"X0\"], \
             \\"public\": [\"X1\"]}}"
       case eitherDecodeStrict' json
              :: Either String TaintConfig of
         Left e -> assertFailure $
           "parse failed: " ++ e
         Right cfg -> do
           let policy =
                 Map.lookup "foo" (tcPolicies cfg)
           case policy of
             Nothing -> assertFailure
               "missing policy for 'foo'"
             Just p -> do
               assertEqual "secret regs"
                 (Set.singleton X0) (apSecret p)
               assertEqual "public regs"
                 (Set.singleton X1) (apPublic p)
 
   , testCase "parse invalid register" $ do
       let json = B8.pack
             "{\"foo\": {\"secret\": [\"INVALID\"]}}"
       case eitherDecodeStrict' json
              :: Either String TaintConfig of
         Left _ -> pure ()
         Right _ -> assertFailure
           "should have failed on invalid register"
 
   , testCase "seedArgs marks secret" $ do
       let policy = ArgPolicy (Set.singleton X0)
             Set.empty Set.empty
             Set.empty Set.empty
           st = seedArgs rt policy (initTaintState rt)
       assertEqual "X0 is secret"
         Secret (getTaint X0 st)
 
   , testCase "seedArgs marks public" $ do
       let policy = ArgPolicy Set.empty
             (Set.singleton X0) Set.empty
             Set.empty Set.empty
           st = seedArgs rt policy (initTaintState rt)
       assertEqual "X0 is public"
         Public (getTaint X0 st)
 
   , testCase "secret takes precedence over public" $ do
       let policy = ArgPolicy (Set.singleton X0)
             (Set.singleton X0) Set.empty
             Set.empty Set.empty
           st = seedArgs rt policy (initTaintState rt)
       assertEqual "X0 is secret"
         Secret (getTaint X0 st)
 
   , testCase "secret_pointee load with imm offset produces Secret" $ do
       let src = T.unlines
             [ "_foo:"
             , "  ldr x1, [x0, #8]"
             , "  ldr x2, [x21, x1]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy Set.empty Set.empty
               (Set.singleton X0)
               Set.empty Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> assertEqual "secret index"
               (SecretIndex X1) (vReason v)
             _ -> assertFailure
               "expected exactly one violation"
 
   , testCase "secret_pointee load with reg offset produces Secret" $ do
       let src = T.unlines
             [ "_foo:"
             , "  ldr x2, [x0, x1]"
             , "  ldr x3, [x21, x2]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy Set.empty Set.empty
               (Set.singleton X0)
               Set.empty Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "two violations"
             2 (length (arViolations ar))
           let reasons = map vReason (arViolations ar)
           assertBool "has secret index x2"
             (SecretIndex X2 `elem` reasons)
 
   , testCase "secret takes precedence over secret_pointee" $ do
       let policy = ArgPolicy (Set.singleton X0)
             Set.empty (Set.singleton X0)
             Set.empty Set.empty
           st = seedArgs rt policy (initTaintState rt)
       assertEqual "X0 is secret"
         Secret (getTaint X0 st)
       assertEqual "X0 provenance"
         ProvUnknown (getProvenance X0 st)
 
   , testCase "non-pointer arithmetic invalidates secret_pointee" $ do
       let src = T.unlines
             [ "_foo:"
             , "  mul x0, x0, x1"
             , "  ldr x2, [x0, #0]"
             , "  ldr x3, [x21, x2]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy Set.empty Set.empty
               (Set.singleton X0)
               Set.empty Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar ->
           assertEqual "no secret violations" 0
             (length $ filter isSecretViolation
               (map vReason (arViolations ar)))
 
   , testCase "pointer arithmetic preserves secret_pointee" $ do
       let src = T.unlines
             [ "_foo:"
             , "  add x0, x0, #8"
             , "  ldr x1, [x0, #0]"
             , "  ldr x2, [x21, x1]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy Set.empty Set.empty
               (Set.singleton X0)
               Set.empty Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar ->
           assertEqual "one secret violation" 1
             (length $ filter isSecretViolation
               (map vReason (arViolations ar)))
 
   , testCase "secret arg causes violation on indexed access" $ do
       let src = T.unlines
             [ "_mul_wnaf:"
             , "  ldr x8, [x20, x0]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_mul_wnaf"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               SecretIndex X0 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "public arg allows indexed access" $ do
       let src = T.unlines
             [ "_foo:"
             , "  ldr x8, [x20, x0]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy Set.empty (Set.singleton X0)
               Set.empty Set.empty Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "interproc with config" $ do
       let src = T.unlines
             [ "_mul_wnaf:"
             , "  ldr x8, [x20, x0]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_mul_wnaf"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditInterProcWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar ->
           assertEqual "one violation"
             1 (length (arViolations ar))
 
   -- STG stack slot seeding tests
   , testCase "parse stg_secret/stg_public in config" $ do
       let json = B8.pack $ unlines
             [ "{"
             , "  \"_foo\": {"
             , "    \"secret\": [\"X0\"],"
             , "    \"stg_secret\": [8, 152],"
             , "    \"stg_public\": [24]"
             , "  }"
             , "}"
             ]
       case eitherDecodeStrict' json
              :: Either String TaintConfig of
         Left e -> assertFailure $
           "parse failed: " ++ e
         Right cfg -> do
           let policy =
                 Map.lookup "_foo" (tcPolicies cfg)
           case policy of
             Nothing -> assertFailure
               "missing policy for '_foo'"
             Just p -> do
               assertEqual "stg_secret"
                 (Set.fromList [8, 152])
                 (apStgSecret p)
               assertEqual "stg_public"
                 (Set.singleton 24)
                 (apStgPublic p)
 
   , testCase "stg_secret seeds STG stack slot as secret" $ do
       let src = T.unlines
             [ "_foo:"
             , "  ldr x8, [x20, #8]"
             , "  ldr x9, [x21, x8]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy Set.empty Set.empty Set.empty
               (Set.singleton 8) Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               SecretIndex X8 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "stg_public seeds STG stack slot as public" $ do
       let src = T.unlines
             [ "_foo:"
             , "  ldr x8, [x20, #16]"
             , "  ldr x9, [x21, x8]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy Set.empty Set.empty Set.empty
               Set.empty (Set.singleton 16))) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "stg_secret takes precedence over stg_public" $ do
       let src = T.unlines
             [ "_foo:"
             , "  ldr x8, [x20, #8]"
             , "  ldr x9, [x21, x8]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy Set.empty Set.empty Set.empty
               (Set.singleton 8)
               (Set.singleton 8))) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               SecretIndex X8 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   -- STG stack delta tracking tests
   , testCase "stg_secret preserved after sub x20" $ do
       let src = T.unlines
             [ "_foo:"
             , "  sub x20, x20, #16"
             , "  ldr x8, [x20, #24]"
             , "  ldr x9, [x21, x8]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy Set.empty Set.empty Set.empty
               (Set.singleton 8) Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               SecretIndex X8 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "stg_secret preserved after add x20" $ do
       let src = T.unlines
             [ "_foo:"
             , "  add x20, x20, #16"
             , "  ldr x8, [x20, #8]"
             , "  ldr x9, [x21, x8]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy Set.empty Set.empty Set.empty
               (Set.singleton 24) Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> do
           assertEqual "one violation"
             1 (length (arViolations ar))
           case arViolations ar of
             [v] -> case vReason v of
               SecretIndex X8 -> pure ()
               other -> assertFailure $
                 "wrong reason: " ++ show other
             _ -> assertFailure
               "expected one violation"
 
   , testCase "stg slot cleared on non-constant x20 update" $ do
       let src = T.unlines
             [ "_foo:"
             , "  add x20, x20, x1"
             , "  ldr x8, [x20, #8]"
             , "  ldr x9, [x21, x8]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy Set.empty Set.empty Set.empty
               (Set.singleton 8) Set.empty)) True
       case auditWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar ->
           assertEqual "one violation"
             1 (length (arViolations ar))
   ]
 
 -- NCT scanner tests
 
 nctTests :: TestTree
 nctTests = testGroup "NCT" [
     testCase "cond branch: bcond" $ do
       let src = T.unlines
             [ "_foo:"
             , "  cmp x0, x1"
             , "  b.eq target"
             , "target:"
             , "  ret"
             ]
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           case Map.lookup "_foo" m of
             Nothing -> assertFailure
               "no findings for _foo"
             Just fs -> do
               assertEqual "one finding"
                 1 (length fs)
               case fs of
                 [f] -> assertEqual "reason"
                   CondBranch (nctReason f)
                 _ -> assertFailure
                   "expected one finding"
 
   , testCase "cond branch: cbz" $ do
       let src = "foo:\n  cbz x0, target\n\
                 \target:\n  ret\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           case Map.lookup "foo" m of
             Nothing -> assertFailure "no findings"
             Just fs -> case fs of
               [f] -> assertEqual "reason"
                 CondBranch (nctReason f)
               _ -> assertFailure $
                 "expected 1 finding, got "
                 ++ show (length fs)
 
   , testCase "cond branch: tbz" $ do
       let src = "foo:\n  tbz x0, #5, target\n\
                 \target:\n  ret\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           case Map.lookup "foo" m of
             Nothing -> assertFailure "no findings"
             Just fs -> case fs of
               [f] -> assertEqual "reason"
                 CondBranch (nctReason f)
               _ -> assertFailure "expected 1 finding"
 
   , testCase "indirect branch: br" $ do
       let src = "foo:\n  br x8\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           case Map.lookup "foo" m of
             Nothing -> assertFailure "no findings"
             Just fs -> case fs of
               [f] -> assertEqual "reason"
                 IndirectBranch (nctReason f)
               _ -> assertFailure "expected 1 finding"
 
   , testCase "indirect branch: blr" $ do
       let src = "foo:\n  blr x8\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           case Map.lookup "foo" m of
             Nothing -> assertFailure "no findings"
             Just fs -> case fs of
               [f] -> assertEqual "reason"
                 IndirectBranch (nctReason f)
               _ -> assertFailure "expected 1 finding"
 
   , testCase "div: udiv" $ do
       let src = "foo:\n  udiv x0, x1, x2\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           case Map.lookup "foo" m of
             Nothing -> assertFailure "no findings"
             Just fs -> case fs of
               [f] -> assertEqual "reason"
                 Div (nctReason f)
               _ -> assertFailure "expected 1 finding"
 
   , testCase "div: sdiv" $ do
       let src = "foo:\n  sdiv x0, x1, x2\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           case Map.lookup "foo" m of
             Nothing -> assertFailure "no findings"
             Just fs -> case fs of
               [f] -> assertEqual "reason"
                 Div (nctReason f)
               _ -> assertFailure "expected 1 finding"
 
   , testCase "no finding: mul (DIT)" $ do
       let src = "foo:\n  mul x0, x1, x2\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           assertEqual "no findings" Nothing
             (Map.lookup "foo" m)
 
   , testCase "no finding: madd (DIT)" $ do
       let src = "foo:\n  madd x0, x1, x2, x3\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           assertEqual "no findings" Nothing
             (Map.lookup "foo" m)
 
   , testCase "no finding: umulh (DIT)" $ do
       let src = "foo:\n  umulh x0, x1, x2\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           assertEqual "no findings" Nothing
             (Map.lookup "foo" m)
 
   , testCase "no finding: lsl with reg (DIT)" $ do
       let src = "foo:\n  lsl x0, x1, x2\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           assertEqual "no findings" Nothing
             (Map.lookup "foo" m)
 
   , testCase "no finding: lsr with reg (DIT)" $ do
       let src = "foo:\n  lsr x0, x1, x2\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           assertEqual "no findings" Nothing
             (Map.lookup "foo" m)
 
   , testCase "no finding: lsl with imm" $ do
       let src = "foo:\n  lsl x0, x1, #5\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           assertEqual "no findings" Nothing
             (Map.lookup "foo" m)
 
   , testCase "reg-index: ldr [xN, xM]" $ do
       let src = "foo:\n  ldr x0, [x1, x2]\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           case Map.lookup "foo" m of
             Nothing -> assertFailure "no findings"
             Just fs -> case fs of
               [f] -> assertEqual "reason"
                 RegIndexAddr (nctReason f)
               _ -> assertFailure "expected 1 finding"
 
   , testCase "reg-index: str [xN, xM, lsl #3]" $ do
       let src = "foo:\n  str x0, [x1, x2, lsl #3]\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           case Map.lookup "foo" m of
             Nothing -> assertFailure "no findings"
             Just fs -> case fs of
               [f] -> assertEqual "reason"
                 RegIndexAddr (nctReason f)
               _ -> assertFailure "expected 1 finding"
 
   , testCase "no finding: ldr [xN, #imm]" $ do
       let src = "foo:\n  ldr x0, [x1, #8]\n"
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           assertEqual "no findings" Nothing
             (Map.lookup "foo" m)
 
   , testCase "grouping by function symbol" $ do
       let src = T.unlines
             [ "_foo:"
             , "  cbz x0, L1"
             , "L1:"
             , "  ret"
             , "_bar:"
             , "  udiv x0, x1, x2"
             , "  br x8"
             , "  ret"
             ]
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let m = scanNct rt lns
           assertEqual "foo: 1 finding" (Just 1)
             (fmap length (Map.lookup "_foo" m))
           assertEqual "bar: 2 findings" (Just 2)
             (fmap length (Map.lookup "_bar" m))
           assertEqual "L1 not a key" Nothing
             (Map.lookup "L1" m)
   ]
 
 -- Call graph tests
 
 callGraphTests :: TestTree
 callGraphTests = testGroup "CallGraph" [
     testCase "symbolExists: existing symbol" $ do
       let src = T.unlines
             [ "_foo:"
             , "  ret"
             ]
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let cg = buildCallGraph rt lns
           assertEqual "symbol exists"
             True (symbolExists "_foo" cg)
 
   , testCase "symbolExists: missing symbol" $ do
       let src = T.unlines
             [ "_foo:"
             , "  ret"
             ]
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let cg = buildCallGraph rt lns
           assertEqual "symbol missing"
             False (symbolExists "_bar" cg)
 
   , testCase "reachableSymbols: direct call" $ do
       let src = T.unlines
             [ "_foo:"
             , "  bl _bar"
             , "  ret"
             , "_bar:"
             , "  ret"
             ]
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let cg = buildCallGraph rt lns
               reachable =
                 reachableSymbols "_foo" cg
           assertEqual "foo reachable" True
             (Set.member "_foo" reachable)
           assertEqual "bar reachable" True
             (Set.member "_bar" reachable)
           assertEqual "count" 2
             (Set.size reachable)
 
   , testCase "reachableSymbols: transitive call" $ do
       let src = T.unlines
             [ "_foo:"
             , "  bl _bar"
             , "  ret"
             , "_bar:"
             , "  bl _baz"
             , "  ret"
             , "_baz:"
             , "  ret"
             ]
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let cg = buildCallGraph rt lns
               reachable =
                 reachableSymbols "_foo" cg
           assertEqual "baz reachable from foo" True
             (Set.member "_baz" reachable)
           assertEqual "count" 3
             (Set.size reachable)
 
   , testCase "reachableSymbols: no callees" $ do
       let src = T.unlines
             [ "_foo:"
             , "  ret"
             , "_bar:"
             , "  ret"
             ]
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let cg = buildCallGraph rt lns
               reachable =
                 reachableSymbols "_foo" cg
           assertEqual "only foo reachable"
             (Set.singleton "_foo") reachable
 
   , testCase "reachableSymbols: missing root returns empty" $ do
       let src = T.unlines
             [ "_foo:"
             , "  ret"
             ]
       case parseAsm src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right lns -> do
           let cg = buildCallGraph rt lns
               reachable =
                 reachableSymbols "_missing" cg
           assertEqual "empty set"
             Set.empty reachable
   ]
 
 -- Tail call inter-procedural tests
 
 tailCallTests :: TestTree
 tailCallTests = testGroup "TailCall" [
 
     testCase "tail call propagates unknown taint" $ do
       let src = T.unlines
             [ "_caller:"
             , "  ldr x23, [x21]"
             , "  b _callee_info"
             , "_callee_info:"
             , "  ldr x0, [x20, x23]"
             , "  ret"
             ]
       case auditInterProc rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "one violation"
           1 (length (arViolations ar))
 
   , testCase "tail call propagates secret taint" $ do
       let src = T.unlines
             [ "_caller:"
             , "  mov x22, x0"
             , "  b _callee_info"
             , "_callee_info:"
             , "  ldr x1, [x20, x22]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_caller"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditInterProcWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar ->
           assertEqual "secret violation" 1
             (length $ filter isSecretViolation
               (map vReason (arViolations ar)))
 
   , testCase "local branch is intra-procedural" $ do
       let src = T.unlines
             [ "_foo:"
             , "  mov x0, x1"
             , "  b Llocal"
             , "Llocal:"
             , "  ldr x2, [x20, x0]"
             , "  ret"
             ]
       case auditInterProc rt "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "one unknown violation"
           1 (length (arViolations ar))
 
   , testCase "NCG local branch (Lc prefix) is intra-procedural" $ do
       let src = T.unlines
             [ "_foo:"
             , "  mov x22, x0"
             , "  b LcaB"
             , "LcaB:"
             , "  ldr x1, [x20, x22]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditInterProcWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar ->
           assertEqual "secret violation" 1
             (length $ filter isSecretViolation
               (map vReason (arViolations ar)))
 
   , testCase "chain of tail calls propagates taint" $ do
       let src = T.unlines
             [ "_a:"
             , "  mov x22, x0"
             , "  b _b_info"
             , "_b_info:"
             , "  mov x23, x22"
             , "  b _c_info"
             , "_c_info:"
             , "  ldr x1, [x20, x23]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_a"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditInterProcWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar ->
           assertEqual "secret violation" 1
             (length $ filter isSecretViolation
               (map vReason (arViolations ar)))
 
   , testCase "indirect call preserves callee-saved taint" $ do
       let src = T.unlines
             [ "_foo:"
             , "  mov x23, x0"
             , "  ldr x8, [x19]"
             , "  blr x8"
             , "  ldr x1, [x20, x23]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditInterProcWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar ->
           assertEqual "x23 secret preserved" 1
             (length $ filter isSecretViolation
               (map vReason (arViolations ar)))
 
   , testCase "tail call to unknown function is conservative" $ do
       let src = T.unlines
             [ "_foo:"
             , "  mov x22, x0"
             , "  b _unknown_info"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditInterProcWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar -> assertEqual "no violations"
           0 (length (arViolations ar))
 
   , testCase "secret_pointee propagates across tail call" $ do
       let src = T.unlines
             [ "_caller:"
             , "  mov x22, x0"
             , "  b _callee_info"
             , "_callee_info:"
             , "  ldr x1, [x22, #0]"
             , "  ldr x2, [x20, x1]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_caller"
             (ArgPolicy Set.empty Set.empty
               (Set.singleton X0)
               Set.empty Set.empty)) True
       case auditInterProcWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar ->
           assertEqual "secret violation" 1
             (length $ filter isSecretViolation
               (map vReason (arViolations ar)))
 
   , testCase "mutual tail calls reach fixpoint" $ do
       let src = T.unlines
             [ "_a_info:"
             , "  cbnz x0, Lskip"
             , "  b _b_info"
             , "Lskip:"
             , "  ret"
             , "_b_info:"
             , "  ldr x1, [x20, x22]"
             , "  b _a_info"
             ]
           cfg = TaintConfig (Map.singleton "_a_info"
             (ArgPolicy (Set.singleton X22)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditInterProcWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar ->
           assertEqual "secret violation in cycle" 1
             (length $ filter isSecretViolation
               (map vReason (arViolations ar)))
 
   , testCase "bl followed by tail call" $ do
       let src = T.unlines
             [ "_caller:"
             , "  mov x22, x0"
             , "  bl _helper"
             , "  b _callee_info"
             , "_helper:"
             , "  ret"
             , "_callee_info:"
             , "  ldr x1, [x20, x22]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_caller"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditInterProcWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar ->
           assertEqual "secret violation" 1
             (length $ filter isSecretViolation
               (map vReason (arViolations ar)))
 
   , testCase "tail call preserves x0 argument taint" $ do
       let src = T.unlines
             [ "_caller:"
             , "  b _callee_info"
             , "_callee_info:"
             , "  ldr x1, [x20, x0]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_caller"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditInterProcWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar ->
           assertEqual "x0 secret preserved" 1
             (length $ filter isSecretViolation
               (map vReason (arViolations ar)))
 
   , testCase "external bl preserves callee-saved taint" $ do
       let src = T.unlines
             [ "_foo:"
             , "  mov x23, x0"
             , "  bl _external_func"
             , "  ldr x1, [x20, x23]"
             , "  ret"
             ]
           cfg = TaintConfig (Map.singleton "_foo"
             (ArgPolicy (Set.singleton X0)
               Set.empty Set.empty
               Set.empty Set.empty)) True
       case auditInterProcWithConfig rt cfg "test" src of
         Left e -> assertFailure $
           "parse failed: " ++ show e
         Right ar ->
           assertEqual
             "x23 secret preserved across external call"
             1
             (length $ filter isSecretViolation
               (map vReason (arViolations ar)))
 
   ]