vestigia

Detect where execution depends on secrets.
git clone git://git.ppad.tech/vestigia.git
Log | Files | Refs | README | LICENSE

Trace.hs (11538B)

      1 {-# OPTIONS_HADDOCK prune #-}
      2 {-# LANGUAGE OverloadedStrings #-}
      3 
      4 -- |
      5 -- Module: Vestigia.Trace
      6 -- Copyright: (c) 2026 Jared Tobin
      7 -- License: MIT
      8 -- Maintainer: Jared Tobin <jared@ppad.tech>
      9 --
     10 -- A run's leakage, read from what memcheck reported. An error
     11 -- whose undefined value was created by a client request descends
     12 -- from a byte the harness marked secret, so it is a site where the
     13 -- execution depended on the secret: a branch (`control`), an
     14 -- address computed from it (`address`), an integer division's
     15 -- operand (`operand`, from vestigia's patched memcheck), or a
     16 -- system call handed it (`syscall`). Every other uninitialised read
     17 -- is kept apart as `unrelated`, and memory errors as `faults`:
     18 -- neither says anything about the secret. Leak reports say nothing
     19 -- about the execution and are dropped.
     20 --
     21 -- memcheck sees the path a run took, so runs of one harness on
     22 -- several secrets are read together: a site is one instruction and
     23 -- class however many runs reached it, with the runs that did. Where
     24 -- a run's objects are known, a site is named by its address in its
     25 -- object, so runs that loaded an object apart still agree on it.
     26 
     27 module Vestigia.Trace (
     28     Class(..)
     29   , Taint(..)
     30   , Located(..)
     31   , Site(..)
     32   , Trace(..)
     33   , trace
     34   , sitesIn
     35   , readObjects
     36   , resolveObjects
     37   , objectOffset
     38   , traceJson
     39   , traceSummary
     40   , classText
     41   ) where
     42 
     43 import Control.Exception (IOException, try)
     44 import qualified Data.List as L
     45 import qualified Data.Map.Strict as M
     46 import qualified Data.Text as T
     47 import Numeric (readHex, showHex)
     48 import System.Directory (canonicalizePath, doesPathExist)
     49 
     50 import Vestigia.Json
     51 import Vestigia.Memcheck
     52 
     53 -- | How an execution depended on a secret at a site.
     54 data Class =
     55     Control
     56   | Address
     57   | Operand
     58   | Syscall
     59   deriving (Eq, Ord, Show)
     60 
     61 -- | One run under memcheck: its name, what memcheck reported, where
     62 --   the harness's loader put each object (its load bias and path,
     63 --   as the harness reported them; none for a report made
     64 --   elsewhere), and the harness's exit status, where known.
     65 data Taint = Taint {
     66     tnName :: !T.Text
     67   , tnMemcheck :: !Memcheck
     68   , tnObjects :: ![(Integer, T.Text)]
     69   , tnExit :: !(Maybe Int)
     70   } deriving (Eq, Show)
     71 
     72 -- | A frame, with its address in its object where its run's objects
     73 --   say.
     74 data Located = Located {
     75     lcFrame :: !Frame
     76   , lcOffset :: !(Maybe Integer)
     77   } deriving (Eq, Show)
     78 
     79 -- | One instruction that depended on a secret: where, as the first
     80 --   run to reach it saw it; how many times, over every run; the runs
     81 --   that reached it, as indices into the runs; and every stack that
     82 --   did.
     83 data Site = Site {
     84     siClass :: !Class
     85   , siAt :: !Located
     86   , siCount :: !Int
     87   , siRuns :: ![Int]
     88   , siStacks :: ![[Located]]
     89   } deriving (Eq, Show)
     90 
     91 -- | Runs' sites, in the order first reported, and what memcheck
     92 --   reported that says nothing about the secret, each with the
     93 --   index of the run that reported it.
     94 data Trace = Trace {
     95     trRuns :: ![Taint]
     96   , trSites :: ![Site]
     97   , trUnrelated :: ![(Int, MemError)]
     98   , trFaults :: ![(Int, MemError)]
     99   } deriving (Eq, Show)
    100 
    101 classText :: Class -> T.Text
    102 classText c = case c of
    103   Control -> "control"
    104   Address -> "address"
    105   Operand -> "operand"
    106   Syscall -> "syscall"
    107 
    108 -- what a secret-originated error says about the execution
    109 classify :: MemError -> Maybe Class
    110 classify e = case (meOrigin e, meKind e) of
    111   (ClientRequest _, "UninitCondition") -> Just Control
    112   (ClientRequest _, "UninitValue") -> Just Address
    113   (ClientRequest _, "UninitOperand") -> Just Operand
    114   (ClientRequest _, "SyscallParam") -> Just Syscall
    115   _ -> Nothing
    116 
    117 uninitialised :: MemError -> Bool
    118 uninitialised e = meKind e `elem`
    119   [ "UninitCondition", "UninitValue", "UninitOperand", "SyscallParam" ]
    120 
    121 -- | The runs' leakage. Sites are one per instruction and class:
    122 --   memcheck reports one context per distinct stack, and the
    123 --   instruction is what depended on the secret, whatever called it
    124 --   and in whichever run.
    125 trace :: [Taint] -> Trace
    126 trace ts = Trace {
    127     trRuns = ts
    128   , trSites =
    129       [ Site {
    130             siClass = c
    131           , siAt = at
    132           , siCount = sum [ meCount e | (_, e, _) <- xs ]
    133           , siRuns = L.nub [ k | (k, _, _) <- xs ]
    134           , siStacks = L.nubBy (\a b -> fmap ident a == fmap ident b)
    135               [ st | (_, _, st) <- xs ]
    136           }
    137       | key@(c, _) <- L.nub (fmap fst tagged)
    138       , Just xs@((_, _, at : _) : _) <- [ M.lookup key grouped ] ]
    139   , trUnrelated =
    140       [ (k, e) | (k, t) <- runs, e <- mcErrors (tnMemcheck t)
    141                , uninitialised e, classify e == Nothing ]
    142   , trFaults =
    143       [ (k, e) | (k, t) <- runs, e <- mcErrors (tnMemcheck t)
    144                , not (uninitialised e)
    145                , not ("Leak_" `T.isPrefixOf` meKind e) ]
    146   }
    147   where
    148     runs = zip [ 0 .. ] ts
    149     tagged =
    150       [ ((c, ident top), (k, e, st))
    151       | (k, t) <- runs
    152       , e <- mcErrors (tnMemcheck t)
    153       , Just c <- [ classify e ]
    154       , let st = fmap (locate (tnObjects t)) (meStack e)
    155       , (top : _) <- [ st ] ]
    156     grouped = M.fromListWith (flip (<>))
    157       [ (key, [ v ]) | (key, v) <- tagged ]
    158     -- an instruction is its address in its object where that is
    159     -- known, else its address in the run
    160     ident (Located f off) =
    161       ( frObj f, maybe (Left (frIp f)) Right off, frFn f, frFile f
    162       , frLine f )
    163 
    164 locate :: [(Integer, T.Text)] -> Frame -> Located
    165 locate os f = Located f (objectOffset os f)
    166 
    167 -- | Only the sites in objects whose path contains one of the given
    168 --   texts, as a differential run keeps its origins; every site when
    169 --   none is given.
    170 sitesIn :: [T.Text] -> Trace -> Trace
    171 sitesIn ts tr
    172   | null ts = tr
    173   | otherwise = tr { trSites = filter inside (trSites tr) }
    174   where
    175     inside s = case frObj (lcFrame (siAt s)) of
    176       Just o -> any (`T.isInfixOf` o) ts
    177       Nothing -> False
    178 
    179 -- | The objects file the harness's first mark writes: a load bias
    180 --   (hex) and a path per line.
    181 --
    182 -- >>> readObjects "7f0000 /lib/libc.so.6\n400000 /bin/harness\n"
    183 -- Right [(8323072,"/lib/libc.so.6"),(4194304,"/bin/harness")]
    184 readObjects :: T.Text -> Either String [(Integer, T.Text)]
    185 readObjects = traverse line . filter (not . T.null . T.strip) . T.lines
    186   where
    187     line l = case T.breakOn " " l of
    188       (b, p) | not (T.null p)
    189              , [ (v, "") ] <- readHex (T.unpack b) ->
    190           Right (v, T.drop 1 p)
    191       _ -> Left ("an unreadable object line: " <> T.unpack l)
    192 
    193 -- | A frame's address in its object, where the harness reported the
    194 --   object: by its path, else by its file name.
    195 -- | A run's objects, each path resolved to the file it names, as
    196 --   memcheck names a frame's object: a loader reaches a library by
    197 --   the link its soname names, memcheck by the file the link leads
    198 --   to. A path that names nothing here, as in a report made
    199 --   elsewhere, is kept as reported.
    200 resolveObjects :: [(Integer, T.Text)] -> IO [(Integer, T.Text)]
    201 resolveObjects = traverse resolve
    202   where
    203     resolve (b, p) = do
    204       let path = T.unpack p
    205       here <- doesPathExist path
    206       if not here then pure (b, p) else do
    207         r <- try (canonicalizePath path)
    208         pure (b, either (keep p) T.pack r)
    209     keep :: T.Text -> IOException -> T.Text
    210     keep p _ = p
    211 
    212 objectOffset :: [(Integer, T.Text)] -> Frame -> Maybe Integer
    213 objectOffset os f = do
    214   obj <- frObj f
    215   base <- case [ b | (b, p) <- os, p == obj ] of
    216     (b : _) -> Just b
    217     [] -> case [ b | (b, p) <- os, fileName p == fileName obj ] of
    218       (b : _) -> Just b
    219       [] -> Nothing
    220   if frIp f >= base then Just (frIp f - base) else Nothing
    221   where
    222     fileName p = case reverse (T.splitOn "/" p) of
    223       (x : _) -> x
    224       [] -> p
    225 
    226 -- | The report: @vestigia/trace-v2@.
    227 traceJson :: T.Text -> Trace -> Value
    228 traceJson version tr = Object
    229   [ ("schema", String "vestigia/trace-v2")
    230   , ("tool", Object [ ("name", String "vestigia")
    231                     , ("version", String version) ])
    232   , ("runs", Array
    233       [ Object
    234           [ ("name", String (tnName t))
    235           , ("valgrind", maybe Null String (mcVersion mc))
    236           , ("command", Array (fmap String (mcCommand mc)))
    237           , ("finished", Bool (mcFinished mc))
    238           , ("exit", maybe Null (Number . toInteger) (tnExit t))
    239           , ("objects", Array
    240               [ Object [ ("base", String (hex b)), ("path", String p) ]
    241               | (b, p) <- tnObjects t ])
    242           ]
    243       | t <- trRuns tr, let mc = tnMemcheck t ])
    244   , ("summary", Object
    245       [ ("control", count Control)
    246       , ("address", count Address)
    247       , ("operand", count Operand)
    248       , ("syscall", count Syscall)
    249       , ("unrelated", Number (toInteger (length (trUnrelated tr))))
    250       , ("faults", Number (toInteger (length (trFaults tr))))
    251       ])
    252   , ("sites", Array (fmap siteJson (trSites tr)))
    253   , ("unrelated", Array (fmap errorJson (trUnrelated tr)))
    254   , ("faults", Array (fmap errorJson (trFaults tr)))
    255   ]
    256   where
    257     count c = Number (toInteger (length
    258       [ () | s <- trSites tr, siClass s == c ]))
    259     name k = case drop k (trRuns tr) of
    260       (t : _) -> String (tnName t)
    261       [] -> String (T.pack (show k))
    262     objectsOf k = case drop k (trRuns tr) of
    263       (t : _) -> tnObjects t
    264       [] -> []
    265     siteJson s = Object $
    266       [ ("class", String (classText (siClass s))) ]
    267       <> locatedFields (siAt s)
    268       <> [ ("count", Number (toInteger (siCount s)))
    269          , ("runs", Array (fmap name (siRuns s)))
    270          , ("stacks", Array [ Array (fmap (Object . locatedFields) st)
    271                             | st <- siStacks s ])
    272          ]
    273     errorJson (k, e) = Object
    274       [ ("run", name k)
    275       , ("kind", String (meKind e))
    276       , ("what", String (meWhat e))
    277       , ("origin", case meOrigin e of
    278           ClientRequest _ -> String "client request"
    279           OtherOrigin w _ -> String w
    280           NoOrigin -> Null)
    281       , ("count", Number (toInteger (meCount e)))
    282       , ("stack", Array (fmap (Object . locatedFields
    283                                 . locate (objectsOf k)) (meStack e)))
    284       ]
    285 
    286 locatedFields :: Located -> [(T.Text, Value)]
    287 locatedFields (Located f off) =
    288   [ ("ip", String (hex (frIp f)))
    289   , ("object", maybe Null String (frObj f))
    290   , ("offset", maybe Null (String . hex) off)
    291   , ("function", maybe Null String (frFn f))
    292   , ("file", maybe Null String (frFile f))
    293   , ("line", maybe Null (Number . toInteger) (frLine f))
    294   ]
    295 
    296 hex :: Integer -> T.Text
    297 hex n = "0x" <> T.pack (showHex n "")
    298 
    299 -- | One line per site, for a reader at a terminal: with how many runs
    300 --   reached it, where there were several.
    301 traceSummary :: Trace -> T.Text
    302 traceSummary tr = T.unlines $
    303   [ T.intercalate "  " $
    304       [ classText (siClass s)
    305       , hex (frIp f)
    306       , maybe "?" id (frFn f)
    307       , location f
    308       , "x" <> T.pack (show (siCount s)) ]
    309       <> [ T.pack (show (length (siRuns s))) <> "/"
    310              <> T.pack (show runs) <> " runs"
    311          | runs > 1 ]
    312   | s <- trSites tr, let f = lcFrame (siAt s) ]
    313   <> [ T.pack (show (length (trSites tr))) <> " secret-dependent \
    314        \site(s) over " <> T.pack (show runs) <> " run(s); "
    315        <> T.pack (show (length (trUnrelated tr)))
    316        <> " unrelated; " <> T.pack (show (length (trFaults tr)))
    317        <> " fault(s)" ]
    318   where
    319     runs = length (trRuns tr)
    320     location f = case (frFile f, frLine f) of
    321       (Just p, Just l) -> base p <> ":" <> T.pack (show l)
    322       (Just p, Nothing) -> base p
    323       _ -> maybe "?" id (frObj f)
    324     base p = last' p (T.splitOn "/" p)
    325     last' d xs = case reverse xs of
    326       (x : _) -> x
    327       [] -> d