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

-- |
-- Module: Vestigia.Memcheck
-- Copyright: (c) 2026 Jared Tobin
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- What a memcheck run reported, read from its XML (protocol
-- version 4 and later): each error context with its kind, its
-- stack, the origin of the undefined value where memcheck tracked
-- one, and how many times it occurred.

module Vestigia.Memcheck (
    Frame(..)
  , Origin(..)
  , MemError(..)
  , Memcheck(..)
  , readMemcheck
  ) where

import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Numeric (readHex)
import Text.Read (readMaybe)

import Vestigia.Xml

-- | One stack frame: the instruction address, and what debug
--   information says of it.
data Frame = Frame {
    Frame -> Integer
frIp :: !Integer
  , Frame -> Maybe Text
frObj :: !(Maybe T.Text)
  , Frame -> Maybe Text
frFn :: !(Maybe T.Text)
  , Frame -> Maybe Text
frFile :: !(Maybe T.Text)
  , Frame -> Maybe Int
frLine :: !(Maybe Int)
  } deriving (Frame -> Frame -> Bool
(Frame -> Frame -> Bool) -> (Frame -> Frame -> Bool) -> Eq Frame
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Frame -> Frame -> Bool
== :: Frame -> Frame -> Bool
$c/= :: Frame -> Frame -> Bool
/= :: Frame -> Frame -> Bool
Eq, Int -> Frame -> ShowS
[Frame] -> ShowS
Frame -> String
(Int -> Frame -> ShowS)
-> (Frame -> String) -> ([Frame] -> ShowS) -> Show Frame
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Frame -> ShowS
showsPrec :: Int -> Frame -> ShowS
$cshow :: Frame -> String
show :: Frame -> String
$cshowList :: [Frame] -> ShowS
showList :: [Frame] -> ShowS
Show)

-- | Where an undefined value came from: a client request (the
--   harness's mark on a secret), something else memcheck named
--   (an allocation, an uninitialised stack slot), or nothing
--   tracked.
data Origin =
    ClientRequest ![Frame]
  | OtherOrigin !T.Text ![Frame]
  | NoOrigin
  deriving (Origin -> Origin -> Bool
(Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool) -> Eq Origin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Origin -> Origin -> Bool
== :: Origin -> Origin -> Bool
$c/= :: Origin -> Origin -> Bool
/= :: Origin -> Origin -> Bool
Eq, Int -> Origin -> ShowS
[Origin] -> ShowS
Origin -> String
(Int -> Origin -> ShowS)
-> (Origin -> String) -> ([Origin] -> ShowS) -> Show Origin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Origin -> ShowS
showsPrec :: Int -> Origin -> ShowS
$cshow :: Origin -> String
show :: Origin -> String
$cshowList :: [Origin] -> ShowS
showList :: [Origin] -> ShowS
Show)

-- | One error context.
data MemError = MemError {
    MemError -> Text
meKind :: !T.Text
  , MemError -> Text
meWhat :: !T.Text
  , MemError -> [Frame]
meStack :: ![Frame]
  , MemError -> Origin
meOrigin :: !Origin
  , MemError -> Int
meCount :: !Int
  } deriving (MemError -> MemError -> Bool
(MemError -> MemError -> Bool)
-> (MemError -> MemError -> Bool) -> Eq MemError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MemError -> MemError -> Bool
== :: MemError -> MemError -> Bool
$c/= :: MemError -> MemError -> Bool
/= :: MemError -> MemError -> Bool
Eq, Int -> MemError -> ShowS
[MemError] -> ShowS
MemError -> String
(Int -> MemError -> ShowS)
-> (MemError -> String) -> ([MemError] -> ShowS) -> Show MemError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MemError -> ShowS
showsPrec :: Int -> MemError -> ShowS
$cshow :: MemError -> String
show :: MemError -> String
$cshowList :: [MemError] -> ShowS
showList :: [MemError] -> ShowS
Show)

-- | A run: the tool's version, the command it ran, whether it
--   finished, and its errors in the order reported.
data Memcheck = Memcheck {
    Memcheck -> Maybe Text
mcVersion :: !(Maybe T.Text)
  , Memcheck -> [Text]
mcCommand :: ![T.Text]
  , Memcheck -> Bool
mcFinished :: !Bool
  , Memcheck -> [MemError]
mcErrors :: ![MemError]
  } deriving (Memcheck -> Memcheck -> Bool
(Memcheck -> Memcheck -> Bool)
-> (Memcheck -> Memcheck -> Bool) -> Eq Memcheck
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Memcheck -> Memcheck -> Bool
== :: Memcheck -> Memcheck -> Bool
$c/= :: Memcheck -> Memcheck -> Bool
/= :: Memcheck -> Memcheck -> Bool
Eq, Int -> Memcheck -> ShowS
[Memcheck] -> ShowS
Memcheck -> String
(Int -> Memcheck -> ShowS)
-> (Memcheck -> String) -> ([Memcheck] -> ShowS) -> Show Memcheck
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Memcheck -> ShowS
showsPrec :: Int -> Memcheck -> ShowS
$cshow :: Memcheck -> String
show :: Memcheck -> String
$cshowList :: [Memcheck] -> ShowS
showList :: [Memcheck] -> ShowS
Show)

-- | Read a memcheck XML document.
readMemcheck :: T.Text -> Either String Memcheck
readMemcheck :: Text -> Either String Memcheck
readMemcheck Text
t = do
  root <- Text -> Either String Node
parseDocument Text
t
  case root of
    Element Text
"valgrindoutput" [Node]
_ -> () -> Either String ()
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Node
_ -> String -> Either String ()
forall a b. a -> Either a b
Left String
"not a valgrind XML document"
  case fmap textOf (child "protocoltool" root) of
    Just Text
"memcheck" -> () -> Either String ()
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe Text
other -> String -> Either String ()
forall a b. a -> Either a b
Left (String
"not a memcheck run: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> String
forall a. Show a => a -> String
show Maybe Text
other)
  let counts = [(Text, Int)] -> Map Text Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
        [ (Node -> Text
textOf Node
u, Int
n)
        | Node
ec <- Text -> Node -> [Node]
children Text
"errorcounts" Node
root
        , Node
p <- Text -> Node -> [Node]
children Text
"pair" Node
ec
        , Just Node
u <- [ Text -> Node -> Maybe Node
child Text
"unique" Node
p ]
        , Just Node
c <- [ Text -> Node -> Maybe Node
child Text
"count" Node
p ]
        , Just Int
n <- [ String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack (Node -> Text
textOf Node
c)) ]
        ]
  errs <- traverse (memError counts) (children "error" root)
  pure Memcheck {
      mcVersion = version root
    , mcCommand =
        [ textOf x
        | as <- children "args" root
        , av <- children "argv" as
        , x <- elementsOf av ]
    , mcFinished = any ((== "FINISHED") . textOf)
        [ s | st <- children "status" root
            , s <- children "state" st ]
    , mcErrors = errs
    }
  where
    elementsOf :: Node -> [Node]
elementsOf Node
n = case Node
n of
      Element Text
_ [Node]
cs -> [ Node
c | c :: Node
c@(Element Text
m [Node]
_) <- [Node]
cs
                          , Text
m Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"exe" Bool -> Bool -> Bool
|| Text
m Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"arg" ]
      Text Text
_ -> []

    -- "Using Valgrind-3.26.0 and LibVEX; ..."
    version :: Node -> Maybe Text
version Node
root = case
      [ Text
v
      | Node
pre <- Text -> Node -> [Node]
children Text
"preamble" Node
root
      , Node
l <- Text -> Node -> [Node]
children Text
"line" Node
pre
      , let w :: Text
w = Node -> Text
textOf Node
l
      , Text
"Using Valgrind-" Text -> Text -> Bool
`T.isPrefixOf` Text
w
      , let v :: Text
v = (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') (Int -> Text -> Text
T.drop Int
15 Text
w) ] of
        (Text
v : [Text]
_) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
v
        [] -> Maybe Text
forall a. Maybe a
Nothing

memError :: M.Map T.Text Int -> Node -> Either String MemError
memError :: Map Text Int -> Node -> Either String MemError
memError Map Text Int
counts Node
n = do
  kind <- Text -> Either String Text
need Text
"kind"
  let what = Text -> (Node -> Text) -> Maybe Node -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Node -> Text
textOf (Text -> Node -> Maybe Node
child Text
"what" Node
n)
      stacks = Text -> Node -> [Node]
children Text
"stack" Node
n
      unique = Text -> (Node -> Text) -> Maybe Node -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Node -> Text
textOf (Text -> Node -> Maybe Node
child Text
"unique" Node
n)
  stack <- case stacks of
    (Node
s : [Node]
_) -> (Node -> Either String Frame) -> [Node] -> Either String [Frame]
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 Node -> Either String Frame
frame (Text -> Node -> [Node]
children Text
"frame" Node
s)
    [] -> [Frame] -> Either String [Frame]
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  -- the origin is the auxwhat that names it, and the stack that
  -- follows it
  origin <- case (originText, drop 1 stacks) of
    (Just Text
w, (Node
s : [Node]
_)) -> do
      fs <- (Node -> Either String Frame) -> [Node] -> Either String [Frame]
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 Node -> Either String Frame
frame (Text -> Node -> [Node]
children Text
"frame" Node
s)
      pure (if "client request" `T.isInfixOf` w
              then ClientRequest fs
              else OtherOrigin w fs)
    (Just Text
w, []) -> Origin -> Either String Origin
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Frame] -> Origin
OtherOrigin Text
w [])
    (Maybe Text
Nothing, [Node]
_) -> Origin -> Either String Origin
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Origin
NoOrigin
  pure MemError {
      meKind = kind
    , meWhat = what
    , meStack = stack
    , meOrigin = origin
    , meCount = fromMaybe 1 (M.lookup unique counts)
    }
  where
    need :: Text -> Either String Text
need Text
k = Either String Text
-> (Node -> Either String Text) -> Maybe Node -> Either String Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String Text
forall a b. a -> Either a b
Left (String
"an error without " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
k)) (Text -> Either String Text
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Text -> Either String Text)
-> (Node -> Text) -> Node -> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Text
textOf) (Text -> Node -> Maybe Node
child Text
k Node
n)
    originText :: Maybe Text
originText = case
      [ Text
w | Node
a <- Text -> Node -> [Node]
children Text
"auxwhat" Node
n
          , let w :: Text
w = Node -> Text
textOf Node
a
          , Text
"was created by" Text -> Text -> Bool
`T.isInfixOf` Text
w ] of
        (Text
w : [Text]
_) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
w
        [] -> Maybe Text
forall a. Maybe a
Nothing

frame :: Node -> Either String Frame
frame :: Node -> Either String Frame
frame Node
n = do
  ip <- case (Node -> Text) -> Maybe Node -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> Text
textOf (Text -> Node -> Maybe Node
child Text
"ip" Node
n) of
    Just Text
t | Just Integer
v <- Text -> Maybe Integer
forall {a}. (Eq a, Num a) => Text -> Maybe a
hex Text
t -> Integer -> Either String Integer
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
v
    Maybe Text
other -> String -> Either String Integer
forall a b. a -> Either a b
Left (String
"a frame without an address: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> String
forall a. Show a => a -> String
show Maybe Text
other)
  pure Frame {
      frIp = ip
    , frObj = field "obj"
    , frFn = field "fn"
    , frFile = case (field "dir", field "file") of
        (Just Text
d, Just Text
f) -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
d Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f)
        (Maybe Text
Nothing, Just Text
f) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
f
        (Maybe Text, Maybe Text)
_ -> Maybe Text
forall a. Maybe a
Nothing
    , frLine = field "line" >>= readMaybe . T.unpack
    }
  where
    field :: Text -> Maybe Text
field Text
k = (Node -> Text) -> Maybe Node -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> Text
textOf (Text -> Node -> Maybe Node
child Text
k Node
n)
    hex :: Text -> Maybe a
hex Text
t = case ReadS a
forall a. (Eq a, Num a) => ReadS a
readHex (Text -> String
T.unpack (Text -> Text
stripPrefix0x Text
t)) of
      [ (a
v, String
"") ] -> a -> Maybe a
forall a. a -> Maybe a
Just a
v
      [(a, String)]
_ -> Maybe a
forall a. Maybe a
Nothing
    stripPrefix0x :: Text -> Text
stripPrefix0x Text
t = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t (Text -> Text -> Maybe Text
T.stripPrefix Text
"0x" Text
t)