vestigia

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

Xml.hs (4993B)

      1 {-# OPTIONS_HADDOCK prune #-}
      2 {-# LANGUAGE OverloadedStrings #-}
      3 
      4 -- |
      5 -- Module: Vestigia.Xml
      6 -- Copyright: (c) 2026 Jared Tobin
      7 -- License: MIT
      8 -- Maintainer: Jared Tobin <jared@ppad.tech>
      9 --
     10 -- A reader for the XML memcheck writes: elements and text, with
     11 -- the declaration, comments, and attributes skipped and the
     12 -- standard entities decoded. It is not a general XML parser, and
     13 -- refuses what it does not understand rather than guessing.
     14 
     15 module Vestigia.Xml (
     16     Node(..)
     17   , parseDocument
     18   , children
     19   , child
     20   , textOf
     21   ) where
     22 
     23 import Data.Char (chr, isAlphaNum, isDigit, isHexDigit, isSpace)
     24 import qualified Data.Text as T
     25 import Numeric (readDec, readHex)
     26 
     27 -- | An element (its name and contents) or a run of text.
     28 data Node =
     29     Element !T.Text ![Node]
     30   | Text !T.Text
     31   deriving (Eq, Show)
     32 
     33 -- | The document's root element.
     34 --
     35 -- >>> parseDocument "<?xml version=\"1.0\"?><a><b>x &amp; y</b></a>"
     36 -- Right (Element "a" [Element "b" [Text "x & y"]])
     37 parseDocument :: T.Text -> Either String Node
     38 parseDocument t = do
     39   (root, rest) <- element (misc t)
     40   if T.null (misc rest)
     41     then pure root
     42     else Left "trailing content after the root element"
     43 
     44 -- | The child elements of a node with the given name.
     45 children :: T.Text -> Node -> [Node]
     46 children name n = case n of
     47   Element _ cs -> [ c | c@(Element m _) <- cs, m == name ]
     48   Text _ -> []
     49 
     50 -- | The first child element with the given name.
     51 child :: T.Text -> Node -> Maybe Node
     52 child name n = case children name n of
     53   (c : _) -> Just c
     54   [] -> Nothing
     55 
     56 -- | The text a node holds, stripped.
     57 textOf :: Node -> T.Text
     58 textOf n = case n of
     59   Text t -> T.strip t
     60   Element _ cs -> T.strip (T.concat [ t | Text t <- cs ])
     61 
     62 -- whitespace, the declaration, comments, and a doctype
     63 misc :: T.Text -> T.Text
     64 misc t0 =
     65   let t = T.dropWhile isSpace t0
     66   in if "<?" `T.isPrefixOf` t then misc (after "?>" t)
     67      else if "<!--" `T.isPrefixOf` t then misc (after "-->" t)
     68      else if "<!" `T.isPrefixOf` t then misc (after ">" t)
     69      else t
     70 
     71 after :: T.Text -> T.Text -> T.Text
     72 after delim t = T.drop (T.length delim) (snd (T.breakOn delim t))
     73 
     74 element :: T.Text -> Either String (Node, T.Text)
     75 element t0 = case T.uncons t0 of
     76   Just ('<', t1) -> do
     77     let (name, t2) = T.span nameChar t1
     78     if T.null name then Left "an element without a name" else do
     79       let t3 = skipAttributes t2
     80       if "/>" `T.isPrefixOf` t3
     81         then pure (Element name [], T.drop 2 t3)
     82         else case T.uncons t3 of
     83           Just ('>', t4) -> do
     84             (cs, t5) <- content name t4 []
     85             pure (Element name (reverse cs), t5)
     86           _ -> Left ("malformed start tag: " <> T.unpack name)
     87   _ -> Left "expected an element"
     88 
     89 -- attributes carry nothing memcheck's reader needs
     90 skipAttributes :: T.Text -> T.Text
     91 skipAttributes t = case T.uncons (T.dropWhile isSpace t) of
     92   Just (c, _) | c == '>' || c == '/' -> T.dropWhile isSpace t
     93   Just _ ->
     94     let t1 = T.dropWhile (\c -> c /= '"' && c /= '>' && c /= '/')
     95                (T.dropWhile isSpace t)
     96     in case T.uncons t1 of
     97          Just ('"', t2) ->
     98            skipAttributes (T.drop 1 (T.dropWhile (/= '"') t2))
     99          _ -> t1
    100   Nothing -> t
    101 
    102 content
    103   :: T.Text -> T.Text -> [Node] -> Either String ([Node], T.Text)
    104 content name t acc
    105   | T.null t = Left ("unclosed element: " <> T.unpack name)
    106   | "</" `T.isPrefixOf` t =
    107       let (close, rest) = T.span nameChar (T.drop 2 t)
    108           rest' = T.dropWhile isSpace rest
    109       in if close /= name
    110            then Left ("mismatched close tag: " <> T.unpack close)
    111            else case T.uncons rest' of
    112              Just ('>', r) -> pure (acc, r)
    113              _ -> Left ("malformed close tag: " <> T.unpack close)
    114   | "<!--" `T.isPrefixOf` t = content name (after "-->" t) acc
    115   | "<" `T.isPrefixOf` t = do
    116       (n, rest) <- element t
    117       content name rest (n : acc)
    118   | otherwise = do
    119       let (raw, rest) = T.break (== '<') t
    120       txt <- entities raw
    121       content name rest (Text txt : acc)
    122 
    123 nameChar :: Char -> Bool
    124 nameChar c = isAlphaNum c || c == '_' || c == '-' || c == '.'
    125   || c == ':'
    126 
    127 entities :: T.Text -> Either String T.Text
    128 entities t = case T.breakOn "&" t of
    129   (pre, rest)
    130     | T.null rest -> pure pre
    131     | otherwise -> do
    132         let (ent, rest') = T.breakOn ";" (T.drop 1 rest)
    133         if T.null rest' then Left "an unterminated entity" else do
    134           c <- entity ent
    135           more <- entities (T.drop 1 rest')
    136           pure (pre <> T.singleton c <> more)
    137 
    138 entity :: T.Text -> Either String Char
    139 entity e = case T.unpack e of
    140   "amp" -> pure '&'
    141   "lt" -> pure '<'
    142   "gt" -> pure '>'
    143   "quot" -> pure '"'
    144   "apos" -> pure '\''
    145   ('#' : 'x' : hs) | not (null hs), all isHexDigit hs ->
    146     code (readHex hs)
    147   ('#' : ds) | not (null ds), all isDigit ds -> code (readDec ds)
    148   _ -> Left ("an unknown entity: &" <> T.unpack e <> ";")
    149   where
    150     code rs = case rs of
    151       [ (n, "") ] | n <= 0x10FFFF -> pure (chr n)
    152       _ -> Left ("a malformed character reference: " <> T.unpack e)