InteractionInspection.hs (16952B)
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 | ActionV2 | 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 `elem` [Action, ActionV2] then M.lookup (view,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 `elem` [Action, ActionV2] then M.insert (view,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 -- HostIO and envelope numbers are canonical and independently bounded. 117 canonicalNatural :: Nodes -> Int -> Word32 -> Either Text Integer 118 canonicalNatural nodes = go 119 where 120 go _ i | W.BNLeaf <- node nodes i = Right 0 121 go 0 _ = Left "canonical number exceeds bit bound" 122 go depth i = case node nodes i of 123 W.BNFork bit rest -> do 124 b <- case node nodes bit of 125 W.BNLeaf -> Right 0 126 W.BNStem l | W.BNLeaf <- node nodes l -> Right 1 127 _ -> Left "invalid canonical number bit" 128 n <- go (depth-1) rest 129 if b == 0 && n == 0 then Left "noncanonical number" else Right (b + 2*n) 130 _ -> Left "invalid canonical number shape" 131 132 facilityName :: Nodes -> Word32 -> Either Text Text 133 facilityName nodes root = do 134 chars <- go (64 :: Int) root 135 case chars of c:_ | c >= 'a' && c <= 'z' -> Right (T.pack chars); _ -> Left "invalid facility name" 136 where 137 go _ i | W.BNLeaf <- node nodes i = Right [] 138 go 0 _ = Left "facility name exceeds 64 characters" 139 go left i = do 140 (h,r) <- pair nodes i 141 n <- canonicalNatural nodes 7 h 142 if (n >= 97 && n <= 122) || (n >= 48 && n <= 57) || n == 45 143 then (chr (fromInteger n) :) <$> go (left-1) r 144 else Left "invalid facility name character" 145 146 sentinelName :: Nodes -> Word32 -> Either Text () 147 sentinelName nodes = go "tricuIO" 148 where 149 go [] i | W.BNLeaf <- node nodes i = Right () 150 go (c:cs) i = do 151 (h,r) <- pair nodes i 152 n <- canonicalNatural nodes 7 h 153 if n == toInteger (fromEnum c) then go cs r else Left "expected canonical tricuIO envelope" 154 go _ _ = Left "expected canonical tricuIO envelope" 155 156 -- Preview only; an unvisited suffix is not certified valid. The final tail is 157 -- inspected to distinguish an exact-length list from a truncated prefix. 158 listPreview :: Nodes -> Int -> (Integer -> Bool) -> Word32 -> Either Text ([Integer], Bool) 159 listPreview nodes limit valid = go limit [] 160 where 161 go remaining acc i = case node nodes i of 162 W.BNLeaf -> Right (reverse acc, False) 163 W.BNFork h rest 164 | remaining == 0 -> Right (reverse acc, True) 165 | otherwise -> do 166 n <- natural nodes h 167 if valid n then go (remaining - 1) (n:acc) rest else Left "element outside permitted range" 168 _ -> Left "expected proper list" 169 170 scalar :: Integer -> Bool 171 scalar n = n <= 0x10ffff && not (n >= 0xd800 && n <= 0xdfff) 172 173 failure :: Text -> Decoded 174 failure message = Decoded message "invalid" [] 175 176 boundedFailure :: Text -> Decoded 177 boundedFailure message = Decoded message (if "limit" `T.isInfixOf` message then "truncated" else "invalid") [] 178 179 decode :: Nodes -> Limits -> View -> Word32 -> Decoded 180 decode nodes limits view idx = case view of 181 Envelope -> case do 182 (sentinel, body) <- pair nodes idx 183 sentinelName nodes sentinel 184 (version, action) <- pair nodes body 185 n <- canonicalNatural nodes 16 version 186 pure (n,action) 187 of 188 Left err -> boundedFailure err 189 Right (1, action) -> Decoded "tricuIO v1" "decoded" [("action",Action,action)] 190 Right (2, action) -> Decoded "tricuIO v2" "decoded" [("action",ActionV2,action)] 191 Right (n, _) -> Decoded ("unsupported tricuIO version " <> tshow n) "unknown" [] 192 Action -> case pair nodes idx of 193 Left _ -> failure "expected action pair (tag, payload)" 194 Right (tag,payload) -> case natural nodes tag of 195 Left err -> boundedFailure ("action tag: " <> err) 196 Right n -> case operation n of 197 Nothing -> Decoded ("unknown IO tag " <> tshow n) "unknown" [("payload",Opaque "uninterpreted payload",payload)] 198 Just (label, fields) -> case unpackFields payload fields of 199 Left err -> failure (label <> ": " <> err) 200 Right children -> Decoded label "decoded" children 201 ActionV2 -> case pair nodes idx of 202 Left err -> failure err 203 Right (tag,payload) -> case canonicalNatural nodes 8 tag of 204 Left err -> boundedFailure err 205 Right 10 -> case do 206 (g,rest) <- pair nodes payload 207 (v,body) <- pair nodes rest 208 (op,args) <- pair nodes body 209 group <- facilityName nodes g 210 revision <- canonicalNatural nodes 16 v 211 when (revision == 0) (Left "zero facility revision") 212 operationName <- facilityName nodes op 213 pure (group,revision,operationName,args) 214 of 215 Left err -> boundedFailure err 216 Right (g,v,op,args) -> Decoded ("Facility " <> g <> "@" <> tshow v <> "/" <> op) 217 "decoded" [("arguments",Opaque "arguments (not validated; backend availability not inferred)",args)] 218 Right n -> case lookup n coreV2 of 219 Nothing -> Decoded ("unknown IO constructor " <> tshow n) "unknown" [] 220 Just (label,fields) -> case unpackFields payload fields of 221 Left err -> failure (label <> ": " <> err) 222 Right children -> Decoded label "decoded" children 223 Opaque label -> Decoded label "opaque" [] 224 Ignored -> Decoded "ignored by host" "opaque" [] 225 Natural -> case natural nodes idx of 226 Left err -> boundedFailure err 227 Right n -> Decoded (tshow n) "decoded" [] 228 StringValue -> preview scalar (T.pack . show . map (chr . fromInteger)) 229 BytesValue -> preview (<=255) (\ns -> "bytes " <> tshow ns) 230 where 231 unpackFields _ [] = Right [] 232 unpackFields p [(field,v)] = Right [(field,v,p)] 233 unpackFields p ((field,v):rest) = do 234 (a,b) <- pair nodes p 235 others <- unpackFields b rest 236 pure ((field,v,a):others) 237 preview valid format = case listPreview nodes (previewItems limits) valid idx of 238 Left err -> boundedFailure err 239 Right (values,cut) -> Decoded 240 (format values <> if cut then " ... (suffix not inspected)" else "") 241 (if cut then "truncated" else "decoded") [] 242 243 -- Scope/spawn callbacks and cancellation reasons stay opaque. Only bind's 244 -- explicit first action is traversed; this never applies a continuation. 245 coreV2 :: [(Integer, (Text, [(Text, View)]))] 246 coreV2 = 247 [ (0,("Pure",[("value",opaque)])) 248 , (1,("Bind",[("action",ActionV2),("resume",Opaque "continuation (not applied)")])) 249 , (2,("Fail",[("diagnostic",opaque)])) 250 , (3,("Scope",[("callback",Opaque "scope callback (not applied)")])) 251 , (4,("CurrentScope",[("payload",Ignored)])) 252 , (5,("Spawn",[("supervised",opaque),("keepResult",opaque),("handles",opaque),("callback",Opaque "child callback (not applied)")])) 253 , (6,("Join",[("ticket",opaque)])), (7,("Discard",[("ticket",opaque)])) 254 , (8,("Cancel",[("task",opaque),("reason",opaque)])) 255 , (9,("Cancelled",[("reason",opaque)])) 256 ] 257 where opaque = Opaque "tree value (not validated)" 258 259 -- The host IO v1 field layouts, not the incompatible pure contract-effect 260 -- protocol. Keep independent fixture expectations in InteractionInspectionTests. 261 -- Zero-argument operations deliberately expose their ignored payload: the host 262 -- accepts any tree there, not only Leaf. 263 operation :: Integer -> Maybe (Text, [(Text, View)]) 264 operation tag = lookup tag 265 [ (0, ("Pure", [("value",value)])) 266 , (1, ("Bind", [("action",Action),("resume",Opaque "continuation (not applied)")])) 267 , (2, ("Abort", [("diagnostic",value)])) 268 , (10, ("PutStr", [("text",StringValue)])) 269 , (11, ("GetLine", ignored)) 270 , (12, ("PutBytes", [("bytes",BytesValue)])) 271 , (20, ("ReadFile", path)) 272 , (21, ("WriteFile", path ++ [("contents",StringValue)])) 273 , (22, ("WriteBytes", path ++ [("bytes",BytesValue)])) 274 , (23, ("ListDirectory", path)) 275 , (24, ("RenameFile", [("oldPath",StringValue),("newPath",StringValue)])) 276 , (25, ("CreateDirectory", path)) 277 , (26, ("DeleteFile", path)) 278 , (27, ("FileExists", path)) 279 , (28, ("Sha256Hex", [("bytes",BytesValue)])) 280 , (29, ("CurrentTime", ignored)) 281 , (30, ("Ask", ignored)) 282 , (31, ("Local", [("transform",Opaque "environment function (not applied)"),("action",Action)])) 283 , (32, ("WriteBytesIfAbsent", path ++ [("bytes",BytesValue)])) 284 , (33, ("AtomicWriteBytes", path ++ [("bytes",BytesValue)])) 285 , (34, ("ReadTreeTerm", pathDigest)) 286 , (35, ("HashTreeTerm", [("tree",value)])) 287 , (36, ("WriteTreeTermIfAbsent", pathDigest ++ [("tree",value)])) 288 , (37, ("ReadSourceFile", path)) 289 , (38, ("EncodeSourceText", [("text",StringValue)])) 290 , (40, ("Get", ignored)) 291 , (41, ("Put", [("state",value)])) 292 , (50, ("ReadIndexedTree", pathDigest)) 293 , (51, ("HashIndexedTree", [("tree",value)])) 294 , (52, ("WriteIndexedTreeIfAbsent", pathDigest ++ [("tree",value)])) 295 , (60, ("Fork", [("action",Action)])) 296 , (61, ("Await", [("handle",value)])) 297 , (62, ("Yield", ignored)) 298 , (63, ("Sleep", [("milliseconds",Natural)])) 299 , (70, ("Socket", ignored)) 300 , (71, ("CloseSocket", sock)) 301 , (72, ("BindSocket", sockAddress)) 302 , (73, ("Listen", sock ++ [("backlog",Natural)])) 303 , (74, ("Accept", sock)) 304 , (75, ("Connect", sockAddress)) 305 , (76, ("Recv", sock ++ [("maxBytes",Natural)])) 306 , (77, ("Send", sock ++ [("bytes",BytesValue)])) 307 , (78, ("GetSocketName", sock)) 308 -- Native experimental upload layouts. Previews do not validate session 309 -- ownership, state, exact length, or the complete bounded chunk contract. 310 , (90, ("UploadBegin", [("directory",StringValue),("expected",Natural)])) 311 , (91, ("UploadAppend", [("handle",value),("chunk",BytesValue)])) 312 , (92, ("UploadSeal", [("handle",value)])) 313 , (93, ("UploadCommit", [("handle",value),("destination",StringValue)])) 314 , (94, ("UploadAbort", [("handle",value)])) 315 ] 316 where 317 value = Opaque "tree value" 318 path = [("path",StringValue)] 319 pathDigest = path ++ [("digest",StringValue)] 320 sock = [("socket",value)] 321 sockAddress = sock ++ [("address",StringValue),("port",Natural)] 322 ignored = [("payload",Ignored)] 323 324 tshow :: Show a => a -> Text 325 tshow = T.pack . show 326 327 nodeId :: Word32 -> Text 328 nodeId n = "n" <> tshow n 329 330 -- Show text fields as Haskell string literals so newlines, escape sequences, 331 -- bidi/non-ASCII characters, etc. cannot inject terminal rows/control sequences. 332 quoted :: Text -> Text 333 quoted = tshow . T.unpack 334 335 renderOutline :: Report -> Text 336 renderOutline report = T.unlines $ 337 ["export " <> quoted (selectedExport report) <> " [host IO v1/v2; read-only]" 338 ,"tree IDs are bundle-local; aliases are exact exported-tree matches"] 339 ++ map row (occurrences report) 340 ++ ["... occurrence limit reached; remaining traversal omitted" | occurrenceLimitReached report] 341 where 342 row o = T.replicate (occurrenceDepth o) " " <> occurrencePath o <> ": " 343 <> occurrenceSummary o <> " [" <> nodeId (occurrenceNode o) <> "; " <> occurrenceStatus o <> "]" 344 <> (if null (occurrenceAliases o) then "" else " aliases: " <> T.intercalate ", " (map quoted (occurrenceAliases o))) 345 <> (if aliasesOmitted o == 0 then "" else " (+" <> tshow (aliasesOmitted o) <> " aliases omitted)") 346 <> maybe "" (" -> " <>) (occurrenceReference o) 347 348 reportJSON :: Text -> Report -> Value 349 reportJSON bundleSHA256 report = object 350 [ "schema" .= ("tricu.interaction-inspection.v2" :: Text) 351 , "protocol" .= ("tricuIO" :: Text) 352 , "supportedVersions" .= ([1,2] :: [Int]) 353 , "bundleSha256" .= bundleSHA256 354 , "identityScope" .= ("bundle-local node indices; not CAS addresses" :: Text) 355 , "export" .= selectedExport report 356 , "storedNodes" .= storedNodes report 357 , "limits" .= object ["depth" .= maxDepth limits, "occurrences" .= maxOccurrences limits, "previewItems" .= previewItems limits] 358 , "occurrenceLimitReached" .= occurrenceLimitReached report 359 , "occurrences" .= map row (occurrences report) 360 ] 361 where 362 limits = reportLimits report 363 row o = object 364 [ "path" .= occurrencePath o, "depth" .= occurrenceDepth o 365 , "treeId" .= nodeId (occurrenceNode o), "aliases" .= occurrenceAliases o 366 , "aliasesOmitted" .= aliasesOmitted o, "role" .= occurrenceRole o 367 , "summary" .= occurrenceSummary o, "status" .= occurrenceStatus o 368 , "reference" .= occurrenceReference o 369 ]