InteractionInspection.hs (12896B)
1 {-# LANGUAGE BangPatterns #-} 2 -- Read-only protocol interpretation of validated indexed nodes. No evaluator, 3 -- tree reconstruction, content-store mutation, or IO driver is used here. 4 module InteractionInspection 5 ( Limits(..), defaultLimits, Report(..), Occurrence(..) 6 , inspectBundle, renderOutline, reportJSON 7 ) where 8 9 import qualified Wire as W 10 import Control.Monad (when) 11 import Data.Aeson (Value, object, (.=)) 12 import Data.Char (chr) 13 import qualified Data.Map.Strict as M 14 import qualified Data.Sequence as S 15 import Data.Text (Text) 16 import qualified Data.Text as T 17 import Data.Word (Word32) 18 19 data Limits = Limits 20 { maxDepth :: Int, maxOccurrences :: Int, previewItems :: Int } 21 deriving (Eq, Show) 22 23 defaultLimits :: Limits 24 defaultLimits = Limits 24 500 80 25 26 data Occurrence = Occurrence 27 { occurrencePath :: Text 28 , occurrenceDepth :: Int 29 , occurrenceNode :: Word32 30 , occurrenceAliases :: [Text] 31 , aliasesOmitted :: Int 32 , occurrenceRole :: Text 33 , occurrenceSummary :: Text 34 , occurrenceStatus :: Text 35 , occurrenceReference :: Maybe Text 36 } deriving (Eq, Show) 37 38 data Report = Report 39 { selectedExport :: Text 40 , reportLimits :: Limits 41 , storedNodes :: Int 42 , occurrences :: [Occurrence] 43 , occurrenceLimitReached :: Bool 44 } deriving (Eq, Show) 45 46 data View = Envelope | Action | Opaque Text | StringValue | BytesValue | Natural | Ignored 47 deriving (Eq, Ord, Show) 48 49 data Decoded = Decoded Text Text [(Text, View, Word32)] 50 type Nodes = S.Seq W.BundleNode 51 52 -- verifyBundle rejects duplicate constructor/child tuples and forward edges. 53 -- Thus node indices identify exact trees within this bundle, even if export 54 -- names differ. They are NOT content-store hashes or execution identities. 55 inspectBundle :: Limits -> Text -> W.Bundle -> Either String Report 56 inspectBundle limits name bundle = do 57 when (maxDepth limits < 0 || maxDepth limits > 256) $ Left "max-depth must be between 0 and 256" 58 when (maxOccurrences limits < 1 || maxOccurrences limits > 100000) $ Left "max-nodes must be between 1 and 100000" 59 when (previewItems limits < 1 || previewItems limits > 4096) $ Left "preview-items must be between 1 and 4096" 60 W.verifyBundle bundle 61 root <- case filter ((== name) . W.exportName) exports of 62 [ex] -> Right (W.exportRoot ex) 63 _ -> Left "selected export not found" 64 let (rows, cut) = walk M.empty 0 [("root", 0, "export", Envelope, root)] [] 65 pure (Report name limits (S.length nodes) rows cut) 66 where 67 nodes = W.bundleNodes bundle 68 exports = W.manifestExports (W.bundleManifest bundle) 69 aliases = M.map reverse $ foldl' (\m ex -> M.insertWith (++) (W.exportRoot ex) [W.exportName ex] m) M.empty exports 70 walk _ _ [] acc = (reverse acc, False) 71 walk _ count _ acc | count >= maxOccurrences limits = (reverse acc, True) 72 walk seen count ((path,depth,role,view,idx):pending) acc = 73 let names = M.findWithDefault [] idx aliases 74 base description state ref = Occurrence path depth idx (take (previewItems limits) names) 75 (max 0 (length names - previewItems limits)) role description state ref 76 Decoded summary status children = decode nodes limits view idx 77 shared = if view == Action then M.lookup idx seen else Nothing 78 in case shared of 79 Just first -> walk seen (count + 1) pending (base "shared action structure (not execution)" "reference" (Just first) : acc) 80 Nothing -> 81 let depthCut = depth >= maxDepth limits && not (null children) 82 row = if depthCut then base (summary <> "; depth limit") 83 (if status == "decoded" then "truncated" else status) Nothing 84 else base summary status Nothing 85 next = if depthCut then pending else 86 [(path <> "." <> field, depth + 1, field, childView, child) | (field,childView,child) <- children] ++ pending 87 seen' = if view == Action then M.insert idx path seen else seen 88 in walk seen' (count + 1) next (row : acc) 89 90 node :: Nodes -> Word32 -> W.BundleNode 91 node nodes i = S.index nodes (fromIntegral i) 92 93 pair :: Nodes -> Word32 -> Either Text (Word32, Word32) 94 pair nodes i = case node nodes i of 95 W.BNFork a b -> Right (a,b) 96 _ -> Left "expected pair" 97 98 -- Bound number decoding independently of payload preview lengths. Match the 99 -- host's binary-number decoder, including its acceptance of leading zero bits. 100 -- No arbitrarily large Integer is constructed (at most 64 bits). 101 natural :: Nodes -> Word32 -> Either Text Integer 102 natural nodes = go 0 1 0 103 where 104 go :: Int -> Integer -> Integer -> Word32 -> Either Text Integer 105 go !bits !place !acc i = case node nodes i of 106 W.BNLeaf -> Right acc 107 W.BNFork b rest | bits < 64 -> do 108 bit <- case node nodes b of 109 W.BNLeaf -> Right 0 110 W.BNStem l | W.BNLeaf <- node nodes l -> Right 1 111 _ -> Left "invalid number bit" 112 go (bits + 1) (place * 2) (acc + bit * place) rest 113 W.BNFork _ _ -> Left "number exceeds 64-bit inspection limit" 114 _ -> Left "invalid number shape" 115 116 -- Preview only; an unvisited suffix is not certified valid. The final tail is 117 -- inspected to distinguish an exact-length list from a truncated prefix. 118 listPreview :: Nodes -> Int -> (Integer -> Bool) -> Word32 -> Either Text ([Integer], Bool) 119 listPreview nodes limit valid = go limit [] 120 where 121 go remaining acc i = case node nodes i of 122 W.BNLeaf -> Right (reverse acc, False) 123 W.BNFork h rest 124 | remaining == 0 -> Right (reverse acc, True) 125 | otherwise -> do 126 n <- natural nodes h 127 if valid n then go (remaining - 1) (n:acc) rest else Left "element outside permitted range" 128 _ -> Left "expected proper list" 129 130 scalar :: Integer -> Bool 131 scalar n = n <= 0x10ffff && not (n >= 0xd800 && n <= 0xdfff) 132 133 failure :: Text -> Decoded 134 failure message = Decoded message "invalid" [] 135 136 boundedFailure :: Text -> Decoded 137 boundedFailure message = Decoded message (if "limit" `T.isInfixOf` message then "truncated" else "invalid") [] 138 139 decode :: Nodes -> Limits -> View -> Word32 -> Decoded 140 decode nodes limits view idx = case view of 141 Envelope -> case do 142 (sentinel, body) <- pair nodes idx 143 (chars, cut) <- listPreview nodes 7 scalar sentinel 144 when (cut || map (chr . fromInteger) chars /= "tricuIO") $ Left "expected tricuIO envelope; export is not decoded as IO (no application attempted)" 145 (version, action) <- pair nodes body 146 n <- natural nodes version 147 pure (n,action) 148 of 149 Left err -> boundedFailure err 150 Right (1, action) -> Decoded "tricuIO v1" "decoded" [("action",Action,action)] 151 Right (n, _) -> Decoded ("unsupported tricuIO version " <> tshow n) "unknown" [] 152 Action -> case pair nodes idx of 153 Left _ -> failure "expected action pair (tag, payload)" 154 Right (tag,payload) -> case natural nodes tag of 155 Left err -> boundedFailure ("action tag: " <> err) 156 Right n -> case operation n of 157 Nothing -> Decoded ("unknown IO tag " <> tshow n) "unknown" [("payload",Opaque "uninterpreted payload",payload)] 158 Just (label, fields) -> case unpackFields payload fields of 159 Left err -> failure (label <> ": " <> err) 160 Right children -> Decoded label "decoded" children 161 Opaque label -> Decoded label "opaque" [] 162 Ignored -> Decoded "ignored by host" "opaque" [] 163 Natural -> case natural nodes idx of 164 Left err -> boundedFailure err 165 Right n -> Decoded (tshow n) "decoded" [] 166 StringValue -> preview scalar (T.pack . show . map (chr . fromInteger)) 167 BytesValue -> preview (<=255) (\ns -> "bytes " <> tshow ns) 168 where 169 unpackFields _ [] = Right [] 170 unpackFields p [(field,v)] = Right [(field,v,p)] 171 unpackFields p ((field,v):rest) = do 172 (a,b) <- pair nodes p 173 others <- unpackFields b rest 174 pure ((field,v,a):others) 175 preview valid format = case listPreview nodes (previewItems limits) valid idx of 176 Left err -> boundedFailure err 177 Right (values,cut) -> Decoded 178 (format values <> if cut then " ... (suffix not inspected)" else "") 179 (if cut then "truncated" else "decoded") [] 180 181 -- The host IO v1 field layouts, not the incompatible pure contract-effect 182 -- protocol. Keep independent fixture expectations in InteractionInspectionTests. 183 -- Zero-argument operations deliberately expose their ignored payload: the host 184 -- accepts any tree there, not only Leaf. 185 operation :: Integer -> Maybe (Text, [(Text, View)]) 186 operation tag = lookup tag 187 [ (0, ("Pure", [("value",value)])) 188 , (1, ("Bind", [("action",Action),("resume",Opaque "continuation (not applied)")])) 189 , (2, ("Abort", [("diagnostic",value)])) 190 , (10, ("PutStr", [("text",StringValue)])) 191 , (11, ("GetLine", ignored)) 192 , (12, ("PutBytes", [("bytes",BytesValue)])) 193 , (20, ("ReadFile", path)) 194 , (21, ("WriteFile", path ++ [("contents",StringValue)])) 195 , (22, ("WriteBytes", path ++ [("bytes",BytesValue)])) 196 , (23, ("ListDirectory", path)) 197 , (24, ("RenameFile", [("oldPath",StringValue),("newPath",StringValue)])) 198 , (25, ("CreateDirectory", path)) 199 , (26, ("DeleteFile", path)) 200 , (27, ("FileExists", path)) 201 , (28, ("Sha256Hex", [("bytes",BytesValue)])) 202 , (29, ("CurrentTime", ignored)) 203 , (30, ("Ask", ignored)) 204 , (31, ("Local", [("transform",Opaque "environment function (not applied)"),("action",Action)])) 205 , (32, ("WriteBytesIfAbsent", path ++ [("bytes",BytesValue)])) 206 , (33, ("AtomicWriteBytes", path ++ [("bytes",BytesValue)])) 207 , (34, ("ReadTreeTerm", pathDigest)) 208 , (35, ("HashTreeTerm", [("tree",value)])) 209 , (36, ("WriteTreeTermIfAbsent", pathDigest ++ [("tree",value)])) 210 , (37, ("ReadSourceFile", path)) 211 , (38, ("EncodeSourceText", [("text",StringValue)])) 212 , (40, ("Get", ignored)) 213 , (41, ("Put", [("state",value)])) 214 , (50, ("ReadIndexedTree", pathDigest)) 215 , (51, ("HashIndexedTree", [("tree",value)])) 216 , (52, ("WriteIndexedTreeIfAbsent", pathDigest ++ [("tree",value)])) 217 , (60, ("Fork", [("action",Action)])) 218 , (61, ("Await", [("handle",value)])) 219 , (62, ("Yield", ignored)) 220 , (63, ("Sleep", [("milliseconds",Natural)])) 221 , (70, ("Socket", ignored)) 222 , (71, ("CloseSocket", sock)) 223 , (72, ("BindSocket", sockAddress)) 224 , (73, ("Listen", sock ++ [("backlog",Natural)])) 225 , (74, ("Accept", sock)) 226 , (75, ("Connect", sockAddress)) 227 , (76, ("Recv", sock ++ [("maxBytes",Natural)])) 228 , (77, ("Send", sock ++ [("bytes",BytesValue)])) 229 , (78, ("GetSocketName", sock)) 230 ] 231 where 232 value = Opaque "tree value" 233 path = [("path",StringValue)] 234 pathDigest = path ++ [("digest",StringValue)] 235 sock = [("socket",value)] 236 sockAddress = sock ++ [("address",StringValue),("port",Natural)] 237 ignored = [("payload",Ignored)] 238 239 tshow :: Show a => a -> Text 240 tshow = T.pack . show 241 242 nodeId :: Word32 -> Text 243 nodeId n = "n" <> tshow n 244 245 -- Show text fields as Haskell string literals so newlines, escape sequences, 246 -- bidi/non-ASCII characters, etc. cannot inject terminal rows/control sequences. 247 quoted :: Text -> Text 248 quoted = tshow . T.unpack 249 250 renderOutline :: Report -> Text 251 renderOutline report = T.unlines $ 252 ["export " <> quoted (selectedExport report) <> " [host IO v1; read-only]" 253 ,"tree IDs are bundle-local; aliases are exact exported-tree matches"] 254 ++ map row (occurrences report) 255 ++ ["... occurrence limit reached; remaining traversal omitted" | occurrenceLimitReached report] 256 where 257 row o = T.replicate (occurrenceDepth o) " " <> occurrencePath o <> ": " 258 <> occurrenceSummary o <> " [" <> nodeId (occurrenceNode o) <> "; " <> occurrenceStatus o <> "]" 259 <> (if null (occurrenceAliases o) then "" else " aliases: " <> T.intercalate ", " (map quoted (occurrenceAliases o))) 260 <> (if aliasesOmitted o == 0 then "" else " (+" <> tshow (aliasesOmitted o) <> " aliases omitted)") 261 <> maybe "" (" -> " <>) (occurrenceReference o) 262 263 reportJSON :: Text -> Report -> Value 264 reportJSON bundleSHA256 report = object 265 [ "schema" .= ("tricu.interaction-inspection.v1" :: Text) 266 , "protocol" .= ("tricuIO" :: Text) 267 , "supportedVersion" .= (1 :: Int) 268 , "bundleSha256" .= bundleSHA256 269 , "identityScope" .= ("bundle-local node indices; not CAS addresses" :: Text) 270 , "export" .= selectedExport report 271 , "storedNodes" .= storedNodes report 272 , "limits" .= object ["depth" .= maxDepth limits, "occurrences" .= maxOccurrences limits, "previewItems" .= previewItems limits] 273 , "occurrenceLimitReached" .= occurrenceLimitReached report 274 , "occurrences" .= map row (occurrences report) 275 ] 276 where 277 limits = reportLimits report 278 row o = object 279 [ "path" .= occurrencePath o, "depth" .= occurrenceDepth o 280 , "treeId" .= nodeId (occurrenceNode o), "aliases" .= occurrenceAliases o 281 , "aliasesOmitted" .= aliasesOmitted o, "role" .= occurrenceRole o 282 , "summary" .= occurrenceSummary o, "status" .= occurrenceStatus o 283 , "reference" .= occurrenceReference o 284 ]