{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module: Vestigia.Trace
-- Copyright: (c) 2026 Jared Tobin
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- A run's leakage, read from what memcheck reported. An error
-- whose undefined value was created by a client request descends
-- from a byte the harness marked secret, so it is a site where the
-- execution depended on the secret: a branch (`control`), an
-- address computed from it (`address`), an integer division's
-- operand (`operand`, from vestigia's patched memcheck), or a
-- system call handed it (`syscall`). Every other uninitialised read
-- is kept apart as `unrelated`, and memory errors as `faults`:
-- neither says anything about the secret. Leak reports say nothing
-- about the execution and are dropped.
--
-- memcheck sees the path a run took, so runs of one harness on
-- several secrets are read together: a site is one instruction and
-- class however many runs reached it, with the runs that did. Where
-- a run's objects are known, a site is named by its address in its
-- object, so runs that loaded an object apart still agree on it.

module Vestigia.Trace (
    Class(..)
  , Taint(..)
  , Located(..)
  , Site(..)
  , Trace(..)
  , trace
  , sitesIn
  , readObjects
  , resolveObjects
  , objectOffset
  , traceJson
  , traceSummary
  , classText
  ) where

import Control.Exception (IOException, try)
import qualified Data.List as L
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Numeric (readHex, showHex)
import System.Directory (canonicalizePath, doesPathExist)

import Vestigia.Json
import Vestigia.Memcheck

-- | How an execution depended on a secret at a site.
data Class =
    Control
  | Address
  | Operand
  | Syscall
  deriving (Class -> Class -> Bool
(Class -> Class -> Bool) -> (Class -> Class -> Bool) -> Eq Class
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Class -> Class -> Bool
== :: Class -> Class -> Bool
$c/= :: Class -> Class -> Bool
/= :: Class -> Class -> Bool
Eq, Eq Class
Eq Class =>
(Class -> Class -> Ordering)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Class)
-> (Class -> Class -> Class)
-> Ord Class
Class -> Class -> Bool
Class -> Class -> Ordering
Class -> Class -> Class
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Class -> Class -> Ordering
compare :: Class -> Class -> Ordering
$c< :: Class -> Class -> Bool
< :: Class -> Class -> Bool
$c<= :: Class -> Class -> Bool
<= :: Class -> Class -> Bool
$c> :: Class -> Class -> Bool
> :: Class -> Class -> Bool
$c>= :: Class -> Class -> Bool
>= :: Class -> Class -> Bool
$cmax :: Class -> Class -> Class
max :: Class -> Class -> Class
$cmin :: Class -> Class -> Class
min :: Class -> Class -> Class
Ord, Int -> Class -> ShowS
[Class] -> ShowS
Class -> String
(Int -> Class -> ShowS)
-> (Class -> String) -> ([Class] -> ShowS) -> Show Class
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Class -> ShowS
showsPrec :: Int -> Class -> ShowS
$cshow :: Class -> String
show :: Class -> String
$cshowList :: [Class] -> ShowS
showList :: [Class] -> ShowS
Show)

-- | One run under memcheck: its name, what memcheck reported, where
--   the harness's loader put each object (its load bias and path,
--   as the harness reported them; none for a report made
--   elsewhere), and the harness's exit status, where known.
data Taint = Taint {
    Taint -> Text
tnName :: !T.Text
  , Taint -> Memcheck
tnMemcheck :: !Memcheck
  , Taint -> [(Integer, Text)]
tnObjects :: ![(Integer, T.Text)]
  , Taint -> Maybe Int
tnExit :: !(Maybe Int)
  } deriving (Taint -> Taint -> Bool
(Taint -> Taint -> Bool) -> (Taint -> Taint -> Bool) -> Eq Taint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Taint -> Taint -> Bool
== :: Taint -> Taint -> Bool
$c/= :: Taint -> Taint -> Bool
/= :: Taint -> Taint -> Bool
Eq, Int -> Taint -> ShowS
[Taint] -> ShowS
Taint -> String
(Int -> Taint -> ShowS)
-> (Taint -> String) -> ([Taint] -> ShowS) -> Show Taint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Taint -> ShowS
showsPrec :: Int -> Taint -> ShowS
$cshow :: Taint -> String
show :: Taint -> String
$cshowList :: [Taint] -> ShowS
showList :: [Taint] -> ShowS
Show)

-- | A frame, with its address in its object where its run's objects
--   say.
data Located = Located {
    Located -> Frame
lcFrame :: !Frame
  , Located -> Maybe Integer
lcOffset :: !(Maybe Integer)
  } deriving (Located -> Located -> Bool
(Located -> Located -> Bool)
-> (Located -> Located -> Bool) -> Eq Located
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Located -> Located -> Bool
== :: Located -> Located -> Bool
$c/= :: Located -> Located -> Bool
/= :: Located -> Located -> Bool
Eq, Int -> Located -> ShowS
[Located] -> ShowS
Located -> String
(Int -> Located -> ShowS)
-> (Located -> String) -> ([Located] -> ShowS) -> Show Located
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Located -> ShowS
showsPrec :: Int -> Located -> ShowS
$cshow :: Located -> String
show :: Located -> String
$cshowList :: [Located] -> ShowS
showList :: [Located] -> ShowS
Show)

-- | One instruction that depended on a secret: where, as the first
--   run to reach it saw it; how many times, over every run; the runs
--   that reached it, as indices into the runs; and every stack that
--   did.
data Site = Site {
    Site -> Class
siClass :: !Class
  , Site -> Located
siAt :: !Located
  , Site -> Int
siCount :: !Int
  , Site -> [Int]
siRuns :: ![Int]
  , Site -> [[Located]]
siStacks :: ![[Located]]
  } deriving (Site -> Site -> Bool
(Site -> Site -> Bool) -> (Site -> Site -> Bool) -> Eq Site
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Site -> Site -> Bool
== :: Site -> Site -> Bool
$c/= :: Site -> Site -> Bool
/= :: Site -> Site -> Bool
Eq, Int -> Site -> ShowS
[Site] -> ShowS
Site -> String
(Int -> Site -> ShowS)
-> (Site -> String) -> ([Site] -> ShowS) -> Show Site
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Site -> ShowS
showsPrec :: Int -> Site -> ShowS
$cshow :: Site -> String
show :: Site -> String
$cshowList :: [Site] -> ShowS
showList :: [Site] -> ShowS
Show)

-- | Runs' sites, in the order first reported, and what memcheck
--   reported that says nothing about the secret, each with the
--   index of the run that reported it.
data Trace = Trace {
    Trace -> [Taint]
trRuns :: ![Taint]
  , Trace -> [Site]
trSites :: ![Site]
  , Trace -> [(Int, MemError)]
trUnrelated :: ![(Int, MemError)]
  , Trace -> [(Int, MemError)]
trFaults :: ![(Int, MemError)]
  } deriving (Trace -> Trace -> Bool
(Trace -> Trace -> Bool) -> (Trace -> Trace -> Bool) -> Eq Trace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Trace -> Trace -> Bool
== :: Trace -> Trace -> Bool
$c/= :: Trace -> Trace -> Bool
/= :: Trace -> Trace -> Bool
Eq, Int -> Trace -> ShowS
[Trace] -> ShowS
Trace -> String
(Int -> Trace -> ShowS)
-> (Trace -> String) -> ([Trace] -> ShowS) -> Show Trace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Trace -> ShowS
showsPrec :: Int -> Trace -> ShowS
$cshow :: Trace -> String
show :: Trace -> String
$cshowList :: [Trace] -> ShowS
showList :: [Trace] -> ShowS
Show)

classText :: Class -> T.Text
classText :: Class -> Text
classText Class
c = case Class
c of
  Class
Control -> Text
"control"
  Class
Address -> Text
"address"
  Class
Operand -> Text
"operand"
  Class
Syscall -> Text
"syscall"

-- what a secret-originated error says about the execution
classify :: MemError -> Maybe Class
classify :: MemError -> Maybe Class
classify MemError
e = case (MemError -> Origin
meOrigin MemError
e, MemError -> Text
meKind MemError
e) of
  (ClientRequest [Frame]
_, Text
"UninitCondition") -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
Control
  (ClientRequest [Frame]
_, Text
"UninitValue") -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
Address
  (ClientRequest [Frame]
_, Text
"UninitOperand") -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
Operand
  (ClientRequest [Frame]
_, Text
"SyscallParam") -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
Syscall
  (Origin, Text)
_ -> Maybe Class
forall a. Maybe a
Nothing

uninitialised :: MemError -> Bool
uninitialised :: MemError -> Bool
uninitialised MemError
e = MemError -> Text
meKind MemError
e Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
  [ Text
"UninitCondition", Text
"UninitValue", Text
"UninitOperand", Text
"SyscallParam" ]

-- | The runs' leakage. Sites are one per instruction and class:
--   memcheck reports one context per distinct stack, and the
--   instruction is what depended on the secret, whatever called it
--   and in whichever run.
trace :: [Taint] -> Trace
trace :: [Taint] -> Trace
trace [Taint]
ts = Trace {
    trRuns :: [Taint]
trRuns = [Taint]
ts
  , trSites :: [Site]
trSites =
      [ Site {
            siClass :: Class
siClass = Class
c
          , siAt :: Located
siAt = Located
at
          , siCount :: Int
siCount = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ MemError -> Int
meCount MemError
e | (Int
_, MemError
e, [Located]
_) <- [(Int, MemError, [Located])]
xs ]
          , siRuns :: [Int]
siRuns = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
L.nub [ Int
k | (Int
k, MemError
_, [Located]
_) <- [(Int, MemError, [Located])]
xs ]
          , siStacks :: [[Located]]
siStacks = ([Located] -> [Located] -> Bool) -> [[Located]] -> [[Located]]
forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (\[Located]
a [Located]
b -> (Located
 -> (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
     Maybe Int))
-> [Located]
-> [(Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
     Maybe Int)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located
-> (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
    Maybe Int)
ident [Located]
a [(Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
  Maybe Int)]
-> [(Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
     Maybe Int)]
-> Bool
forall a. Eq a => a -> a -> Bool
== (Located
 -> (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
     Maybe Int))
-> [Located]
-> [(Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
     Maybe Int)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located
-> (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
    Maybe Int)
ident [Located]
b)
              [ [Located]
st | (Int
_, MemError
_, [Located]
st) <- [(Int, MemError, [Located])]
xs ]
          }
      | key :: (Class,
 (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
  Maybe Int))
key@(Class
c, (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
 Maybe Int)
_) <- [(Class,
  (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
   Maybe Int))]
-> [(Class,
     (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
      Maybe Int))]
forall a. Eq a => [a] -> [a]
L.nub ((((Class,
   (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
    Maybe Int)),
  (Int, MemError, [Located]))
 -> (Class,
     (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
      Maybe Int)))
-> [((Class,
      (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
       Maybe Int)),
     (Int, MemError, [Located]))]
-> [(Class,
     (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
      Maybe Int))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Class,
  (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
   Maybe Int)),
 (Int, MemError, [Located]))
-> (Class,
    (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
     Maybe Int))
forall a b. (a, b) -> a
fst [((Class,
   (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
    Maybe Int)),
  (Int, MemError, [Located]))]
tagged)
      , Just xs :: [(Int, MemError, [Located])]
xs@((Int
_, MemError
_, Located
at : [Located]
_) : [(Int, MemError, [Located])]
_) <- [ (Class,
 (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
  Maybe Int))
-> Map
     (Class,
      (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
       Maybe Int))
     [(Int, MemError, [Located])]
-> Maybe [(Int, MemError, [Located])]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Class,
 (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
  Maybe Int))
key Map
  (Class,
   (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
    Maybe Int))
  [(Int, MemError, [Located])]
grouped ] ]
  , trUnrelated :: [(Int, MemError)]
trUnrelated =
      [ (Int
k, MemError
e) | (Int
k, Taint
t) <- [(Int, Taint)]
runs, MemError
e <- Memcheck -> [MemError]
mcErrors (Taint -> Memcheck
tnMemcheck Taint
t)
               , MemError -> Bool
uninitialised MemError
e, MemError -> Maybe Class
classify MemError
e Maybe Class -> Maybe Class -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Class
forall a. Maybe a
Nothing ]
  , trFaults :: [(Int, MemError)]
trFaults =
      [ (Int
k, MemError
e) | (Int
k, Taint
t) <- [(Int, Taint)]
runs, MemError
e <- Memcheck -> [MemError]
mcErrors (Taint -> Memcheck
tnMemcheck Taint
t)
               , Bool -> Bool
not (MemError -> Bool
uninitialised MemError
e)
               , Bool -> Bool
not (Text
"Leak_" Text -> Text -> Bool
`T.isPrefixOf` MemError -> Text
meKind MemError
e) ]
  }
  where
    runs :: [(Int, Taint)]
runs = [Int] -> [Taint] -> [(Int, Taint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ Int
0 .. ] [Taint]
ts
    tagged :: [((Class,
   (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
    Maybe Int)),
  (Int, MemError, [Located]))]
tagged =
      [ ((Class
c, Located
-> (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
    Maybe Int)
ident Located
top), (Int
k, MemError
e, [Located]
st))
      | (Int
k, Taint
t) <- [(Int, Taint)]
runs
      , MemError
e <- Memcheck -> [MemError]
mcErrors (Taint -> Memcheck
tnMemcheck Taint
t)
      , Just Class
c <- [ MemError -> Maybe Class
classify MemError
e ]
      , let st :: [Located]
st = (Frame -> Located) -> [Frame] -> [Located]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Integer, Text)] -> Frame -> Located
locate (Taint -> [(Integer, Text)]
tnObjects Taint
t)) (MemError -> [Frame]
meStack MemError
e)
      , (Located
top : [Located]
_) <- [ [Located]
st ] ]
    grouped :: Map
  (Class,
   (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
    Maybe Int))
  [(Int, MemError, [Located])]
grouped = ([(Int, MemError, [Located])]
 -> [(Int, MemError, [Located])] -> [(Int, MemError, [Located])])
-> [((Class,
      (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
       Maybe Int)),
     [(Int, MemError, [Located])])]
-> Map
     (Class,
      (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
       Maybe Int))
     [(Int, MemError, [Located])]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith (([(Int, MemError, [Located])]
 -> [(Int, MemError, [Located])] -> [(Int, MemError, [Located])])
-> [(Int, MemError, [Located])]
-> [(Int, MemError, [Located])]
-> [(Int, MemError, [Located])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(Int, MemError, [Located])]
-> [(Int, MemError, [Located])] -> [(Int, MemError, [Located])]
forall a. Semigroup a => a -> a -> a
(<>))
      [ ((Class,
 (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
  Maybe Int))
key, [ (Int, MemError, [Located])
v ]) | ((Class,
 (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
  Maybe Int))
key, (Int, MemError, [Located])
v) <- [((Class,
   (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
    Maybe Int)),
  (Int, MemError, [Located]))]
tagged ]
    -- an instruction is its address in its object where that is
    -- known, else its address in the run
    ident :: Located
-> (Maybe Text, Either Integer Integer, Maybe Text, Maybe Text,
    Maybe Int)
ident (Located Frame
f Maybe Integer
off) =
      ( Frame -> Maybe Text
frObj Frame
f, Either Integer Integer
-> (Integer -> Either Integer Integer)
-> Maybe Integer
-> Either Integer Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Integer -> Either Integer Integer
forall a b. a -> Either a b
Left (Frame -> Integer
frIp Frame
f)) Integer -> Either Integer Integer
forall a b. b -> Either a b
Right Maybe Integer
off, Frame -> Maybe Text
frFn Frame
f, Frame -> Maybe Text
frFile Frame
f
      , Frame -> Maybe Int
frLine Frame
f )

locate :: [(Integer, T.Text)] -> Frame -> Located
locate :: [(Integer, Text)] -> Frame -> Located
locate [(Integer, Text)]
os Frame
f = Frame -> Maybe Integer -> Located
Located Frame
f ([(Integer, Text)] -> Frame -> Maybe Integer
objectOffset [(Integer, Text)]
os Frame
f)

-- | Only the sites in objects whose path contains one of the given
--   texts, as a differential run keeps its origins; every site when
--   none is given.
sitesIn :: [T.Text] -> Trace -> Trace
sitesIn :: [Text] -> Trace -> Trace
sitesIn [Text]
ts Trace
tr
  | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
ts = Trace
tr
  | Bool
otherwise = Trace
tr { trSites = filter inside (trSites tr) }
  where
    inside :: Site -> Bool
inside Site
s = case Frame -> Maybe Text
frObj (Located -> Frame
lcFrame (Site -> Located
siAt Site
s)) of
      Just Text
o -> (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isInfixOf` Text
o) [Text]
ts
      Maybe Text
Nothing -> Bool
False

-- | The objects file the harness's first mark writes: a load bias
--   (hex) and a path per line.
--
-- >>> readObjects "7f0000 /lib/libc.so.6\n400000 /bin/harness\n"
-- Right [(8323072,"/lib/libc.so.6"),(4194304,"/bin/harness")]
readObjects :: T.Text -> Either String [(Integer, T.Text)]
readObjects :: Text -> Either String [(Integer, Text)]
readObjects = (Text -> Either String (Integer, Text))
-> [Text] -> Either String [(Integer, Text)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Text -> Either String (Integer, Text)
forall {a}. (Eq a, Num a) => Text -> Either String (a, Text)
line ([Text] -> Either String [(Integer, Text)])
-> (Text -> [Text]) -> Text -> Either String [(Integer, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
  where
    line :: Text -> Either String (a, Text)
line Text
l = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
" " Text
l of
      (Text
b, Text
p) | Bool -> Bool
not (Text -> Bool
T.null Text
p)
             , [ (a
v, String
"") ] <- ReadS a
forall a. (Eq a, Num a) => ReadS a
readHex (Text -> String
T.unpack Text
b) ->
          (a, Text) -> Either String (a, Text)
forall a b. b -> Either a b
Right (a
v, Int -> Text -> Text
T.drop Int
1 Text
p)
      (Text, Text)
_ -> String -> Either String (a, Text)
forall a b. a -> Either a b
Left (String
"an unreadable object line: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
l)

-- | A frame's address in its object, where the harness reported the
--   object: by its path, else by its file name.
-- | A run's objects, each path resolved to the file it names, as
--   memcheck names a frame's object: a loader reaches a library by
--   the link its soname names, memcheck by the file the link leads
--   to. A path that names nothing here, as in a report made
--   elsewhere, is kept as reported.
resolveObjects :: [(Integer, T.Text)] -> IO [(Integer, T.Text)]
resolveObjects :: [(Integer, Text)] -> IO [(Integer, Text)]
resolveObjects = ((Integer, Text) -> IO (Integer, Text))
-> [(Integer, Text)] -> IO [(Integer, Text)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Integer, Text) -> IO (Integer, Text)
forall {a}. (a, Text) -> IO (a, Text)
resolve
  where
    resolve :: (a, Text) -> IO (a, Text)
resolve (a
b, Text
p) = do
      let path :: String
path = Text -> String
T.unpack Text
p
      here <- String -> IO Bool
doesPathExist String
path
      if not here then pure (b, p) else do
        r <- try (canonicalizePath path)
        pure (b, either (keep p) T.pack r)
    keep :: T.Text -> IOException -> T.Text
    keep :: Text -> IOException -> Text
keep Text
p IOException
_ = Text
p

objectOffset :: [(Integer, T.Text)] -> Frame -> Maybe Integer
objectOffset :: [(Integer, Text)] -> Frame -> Maybe Integer
objectOffset [(Integer, Text)]
os Frame
f = do
  obj <- Frame -> Maybe Text
frObj Frame
f
  base <- case [ b | (b, p) <- os, p == obj ] of
    (Integer
b : [Integer]
_) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
b
    [] -> case [ Integer
b | (Integer
b, Text
p) <- [(Integer, Text)]
os, Text -> Text
fileName Text
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
fileName Text
obj ] of
      (Integer
b : [Integer]
_) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
b
      [] -> Maybe Integer
forall a. Maybe a
Nothing
  if frIp f >= base then Just (frIp f - base) else Nothing
  where
    fileName :: Text -> Text
fileName Text
p = case [Text] -> [Text]
forall a. [a] -> [a]
reverse (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
p) of
      (Text
x : [Text]
_) -> Text
x
      [] -> Text
p

-- | The report: @vestigia/trace-v2@.
traceJson :: T.Text -> Trace -> Value
traceJson :: Text -> Trace -> Value
traceJson Text
version Trace
tr = [(Text, Value)] -> Value
Object
  [ (Text
"schema", Text -> Value
String Text
"vestigia/trace-v2")
  , (Text
"tool", [(Text, Value)] -> Value
Object [ (Text
"name", Text -> Value
String Text
"vestigia")
                    , (Text
"version", Text -> Value
String Text
version) ])
  , (Text
"runs", [Value] -> Value
Array
      [ [(Text, Value)] -> Value
Object
          [ (Text
"name", Text -> Value
String (Taint -> Text
tnName Taint
t))
          , (Text
"valgrind", Value -> (Text -> Value) -> Maybe Text -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null Text -> Value
String (Memcheck -> Maybe Text
mcVersion Memcheck
mc))
          , (Text
"command", [Value] -> Value
Array ((Text -> Value) -> [Text] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Value
String (Memcheck -> [Text]
mcCommand Memcheck
mc)))
          , (Text
"finished", Bool -> Value
Bool (Memcheck -> Bool
mcFinished Memcheck
mc))
          , (Text
"exit", Value -> (Int -> Value) -> Maybe Int -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null (Integer -> Value
Number (Integer -> Value) -> (Int -> Integer) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger) (Taint -> Maybe Int
tnExit Taint
t))
          , (Text
"objects", [Value] -> Value
Array
              [ [(Text, Value)] -> Value
Object [ (Text
"base", Text -> Value
String (Integer -> Text
hex Integer
b)), (Text
"path", Text -> Value
String Text
p) ]
              | (Integer
b, Text
p) <- Taint -> [(Integer, Text)]
tnObjects Taint
t ])
          ]
      | Taint
t <- Trace -> [Taint]
trRuns Trace
tr, let mc :: Memcheck
mc = Taint -> Memcheck
tnMemcheck Taint
t ])
  , (Text
"summary", [(Text, Value)] -> Value
Object
      [ (Text
"control", Class -> Value
count Class
Control)
      , (Text
"address", Class -> Value
count Class
Address)
      , (Text
"operand", Class -> Value
count Class
Operand)
      , (Text
"syscall", Class -> Value
count Class
Syscall)
      , (Text
"unrelated", Integer -> Value
Number (Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([(Int, MemError)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Trace -> [(Int, MemError)]
trUnrelated Trace
tr))))
      , (Text
"faults", Integer -> Value
Number (Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([(Int, MemError)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Trace -> [(Int, MemError)]
trFaults Trace
tr))))
      ])
  , (Text
"sites", [Value] -> Value
Array ((Site -> Value) -> [Site] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Site -> Value
siteJson (Trace -> [Site]
trSites Trace
tr)))
  , (Text
"unrelated", [Value] -> Value
Array (((Int, MemError) -> Value) -> [(Int, MemError)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, MemError) -> Value
errorJson (Trace -> [(Int, MemError)]
trUnrelated Trace
tr)))
  , (Text
"faults", [Value] -> Value
Array (((Int, MemError) -> Value) -> [(Int, MemError)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, MemError) -> Value
errorJson (Trace -> [(Int, MemError)]
trFaults Trace
tr)))
  ]
  where
    count :: Class -> Value
count Class
c = Integer -> Value
Number (Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
      [ () | Site
s <- Trace -> [Site]
trSites Trace
tr, Site -> Class
siClass Site
s Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
c ]))
    name :: Int -> Value
name Int
k = case Int -> [Taint] -> [Taint]
forall a. Int -> [a] -> [a]
drop Int
k (Trace -> [Taint]
trRuns Trace
tr) of
      (Taint
t : [Taint]
_) -> Text -> Value
String (Taint -> Text
tnName Taint
t)
      [] -> Text -> Value
String (String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
k))
    objectsOf :: Int -> [(Integer, Text)]
objectsOf Int
k = case Int -> [Taint] -> [Taint]
forall a. Int -> [a] -> [a]
drop Int
k (Trace -> [Taint]
trRuns Trace
tr) of
      (Taint
t : [Taint]
_) -> Taint -> [(Integer, Text)]
tnObjects Taint
t
      [] -> []
    siteJson :: Site -> Value
siteJson Site
s = [(Text, Value)] -> Value
Object ([(Text, Value)] -> Value) -> [(Text, Value)] -> Value
forall a b. (a -> b) -> a -> b
$
      [ (Text
"class", Text -> Value
String (Class -> Text
classText (Site -> Class
siClass Site
s))) ]
      [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> Located -> [(Text, Value)]
locatedFields (Site -> Located
siAt Site
s)
      [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
"count", Integer -> Value
Number (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Site -> Int
siCount Site
s)))
         , (Text
"runs", [Value] -> Value
Array ((Int -> Value) -> [Int] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Value
name (Site -> [Int]
siRuns Site
s)))
         , (Text
"stacks", [Value] -> Value
Array [ [Value] -> Value
Array ((Located -> Value) -> [Located] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Text, Value)] -> Value
Object ([(Text, Value)] -> Value)
-> (Located -> [(Text, Value)]) -> Located -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located -> [(Text, Value)]
locatedFields) [Located]
st)
                            | [Located]
st <- Site -> [[Located]]
siStacks Site
s ])
         ]
    errorJson :: (Int, MemError) -> Value
errorJson (Int
k, MemError
e) = [(Text, Value)] -> Value
Object
      [ (Text
"run", Int -> Value
name Int
k)
      , (Text
"kind", Text -> Value
String (MemError -> Text
meKind MemError
e))
      , (Text
"what", Text -> Value
String (MemError -> Text
meWhat MemError
e))
      , (Text
"origin", case MemError -> Origin
meOrigin MemError
e of
          ClientRequest [Frame]
_ -> Text -> Value
String Text
"client request"
          OtherOrigin Text
w [Frame]
_ -> Text -> Value
String Text
w
          Origin
NoOrigin -> Value
Null)
      , (Text
"count", Integer -> Value
Number (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (MemError -> Int
meCount MemError
e)))
      , (Text
"stack", [Value] -> Value
Array ((Frame -> Value) -> [Frame] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Text, Value)] -> Value
Object ([(Text, Value)] -> Value)
-> (Frame -> [(Text, Value)]) -> Frame -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located -> [(Text, Value)]
locatedFields
                                (Located -> [(Text, Value)])
-> (Frame -> Located) -> Frame -> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Integer, Text)] -> Frame -> Located
locate (Int -> [(Integer, Text)]
objectsOf Int
k)) (MemError -> [Frame]
meStack MemError
e)))
      ]

locatedFields :: Located -> [(T.Text, Value)]
locatedFields :: Located -> [(Text, Value)]
locatedFields (Located Frame
f Maybe Integer
off) =
  [ (Text
"ip", Text -> Value
String (Integer -> Text
hex (Frame -> Integer
frIp Frame
f)))
  , (Text
"object", Value -> (Text -> Value) -> Maybe Text -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null Text -> Value
String (Frame -> Maybe Text
frObj Frame
f))
  , (Text
"offset", Value -> (Integer -> Value) -> Maybe Integer -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null (Text -> Value
String (Text -> Value) -> (Integer -> Text) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Text
hex) Maybe Integer
off)
  , (Text
"function", Value -> (Text -> Value) -> Maybe Text -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null Text -> Value
String (Frame -> Maybe Text
frFn Frame
f))
  , (Text
"file", Value -> (Text -> Value) -> Maybe Text -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null Text -> Value
String (Frame -> Maybe Text
frFile Frame
f))
  , (Text
"line", Value -> (Int -> Value) -> Maybe Int -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null (Integer -> Value
Number (Integer -> Value) -> (Int -> Integer) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger) (Frame -> Maybe Int
frLine Frame
f))
  ]

hex :: Integer -> T.Text
hex :: Integer -> Text
hex Integer
n = Text
"0x" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Integer -> ShowS
forall a. Integral a => a -> ShowS
showHex Integer
n String
"")

-- | One line per site, for a reader at a terminal: with how many runs
--   reached it, where there were several.
traceSummary :: Trace -> T.Text
traceSummary :: Trace -> Text
traceSummary Trace
tr = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
  [ Text -> [Text] -> Text
T.intercalate Text
"  " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
      [ Class -> Text
classText (Site -> Class
siClass Site
s)
      , Integer -> Text
hex (Frame -> Integer
frIp Frame
f)
      , Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"?" Text -> Text
forall a. a -> a
id (Frame -> Maybe Text
frFn Frame
f)
      , Frame -> Text
location Frame
f
      , Text
"x" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Site -> Int
siCount Site
s)) ]
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Site -> [Int]
siRuns Site
s))) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
runs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" runs"
         | Int
runs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 ]
  | Site
s <- Trace -> [Site]
trSites Trace
tr, let f :: Frame
f = Located -> Frame
lcFrame (Site -> Located
siAt Site
s) ]
  [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show ([Site] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Trace -> [Site]
trSites Trace
tr))) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" secret-dependent \
       \site(s) over " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
runs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" run(s); "
       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show ([(Int, MemError)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Trace -> [(Int, MemError)]
trUnrelated Trace
tr)))
       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" unrelated; " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show ([(Int, MemError)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Trace -> [(Int, MemError)]
trFaults Trace
tr)))
       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" fault(s)" ]
  where
    runs :: Int
runs = [Taint] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Trace -> [Taint]
trRuns Trace
tr)
    location :: Frame -> Text
location Frame
f = case (Frame -> Maybe Text
frFile Frame
f, Frame -> Maybe Int
frLine Frame
f) of
      (Just Text
p, Just Int
l) -> Text -> Text
base Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
l)
      (Just Text
p, Maybe Int
Nothing) -> Text -> Text
base Text
p
      (Maybe Text, Maybe Int)
_ -> Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"?" Text -> Text
forall a. a -> a
id (Frame -> Maybe Text
frObj Frame
f)
    base :: Text -> Text
base Text
p = Text -> [Text] -> Text
forall {a}. a -> [a] -> a
last' Text
p (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
p)
    last' :: a -> [a] -> a
last' a
d [a]
xs = case [a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs of
      (a
x : [a]
_) -> a
x
      [] -> a
d