commit 4996cc768b171c267a244dd3f36fa906d7dcf377
parent 4ba1739f51a97b26583712cd414c17129b9e9783
Author: James Eversole <james@eversole.co>
Date: Tue, 13 Oct 2026 18:02:12 -0500
Add read-only native interaction-tree inspection
Diffstat:
11 files changed, 764 insertions(+), 4 deletions(-)
diff --git a/demos/interaction-inspection.tri b/demos/interaction-inspection.tri
@@ -0,0 +1,12 @@
+-- A materialized IO tree for read-only bundle inspection. Compiling and
+-- inspecting this module does not read settings.txt. Running it with --io does.
+!export main
+!export afterRead
+
+pure value = t 0 value
+bind action resume = t 1 (t action resume)
+readFile path = t 20 path
+io action = t "tricuIO" (t 1 action)
+
+afterRead reply = pure reply
+main = io (bind (readFile "settings.txt") afterRead)
diff --git a/docs/tri-tools.md b/docs/tri-tools.md
@@ -85,6 +85,88 @@ Repeat/profiling markers retain their existing behavior. Observation phases stil
occur with `--no-result`, but do not render or force the suppressed return value.
Explicit `--profile-full-result` forcing remains independent of result rendering.
+## Read-only interaction-tree inspection
+
+Inspect a materialized host IO tree without applying it, running effects, importing
+it into a store, or loading a compiler:
+
+```sh
+result/bin/tricu arboricx inspect --file "$WORK/app.arboricx" --name main --as io
+result/bin/tricu arboricx inspect --file "$WORK/app.arboricx" --name main --as io --json
+```
+
+`--as io` is required and selects the `tricuIO` version 1 envelope and host action
+protocol, **not** the pure contract-effect layer. `--name` defaults to `main`.
+Inspection does not apply arguments: a function that would produce IO must first
+be materialized elsewhere. Only explicit child actions are followed; continuations
+and environment-transforming functions remain opaque, labeled by their roles.
+No original source names or future control flow are inferred.
+
+For a small example with a named continuation:
+
+```sh
+result/bin/tricu arboricx compile --file demos/interaction-inspection.tri \
+ --store "$WORK/application" --output "$WORK/inspection.arboricx"
+result/bin/tricu arboricx inspect --file "$WORK/inspection.arboricx" --as io
+```
+
+The outline includes these roles (node indices omitted here):
+
+```text
+root: tricuIO v1 aliases: "main"
+ root.action: Bind
+ root.action.action: ReadFile
+ root.action.action.path: "settings.txt"
+ root.action.resume: continuation (not applied) aliases: "afterRead"
+```
+
+The demo spells out the IO constructors so it needs no library imports. Compiling
+and inspecting it does not read `settings.txt`; running its IO tree would.
+
+### Identities, output, and limits
+
+The bundle's whole-file SHA-256 fingerprints the inspected bytes; it does not
+establish their provenance or authenticate them against an external expected
+hash. The complete indexed graph is structurally validated, including unused
+nodes. Export aliases are exact matches to displayed trees within that bundle.
+Several names may match one tree, and names lost through specialization cannot
+be recovered. `n123` identifies a **bundle-local tree node**, not a CAS address or
+an execution occurrence. A generated path such as `root.action.resume` identifies
+an occurrence; equal tree IDs do not imply an effect executes only once.
+
+`--json` emits `tricu.interaction-inspection.v1`: bundle fingerprint, selected
+export, supported protocol version, limits, stored-node count, and a depth-first
+`occurrences` array. Each occurrence includes its path, depth, role, tree ID,
+export aliases, omitted-alias count, display summary, status, and optional
+reference to a previously described action occurrence. Summaries are display
+text, not source or a stable payload serialization. Status is `decoded`, `opaque`,
+`invalid`, `unknown`, `truncated`, or `reference`. `opaque` is a deliberate boundary,
+not a certification that a continuation is callable or a value is well-typed.
+
+| Option | Default | Meaning |
+| --- | --- | --- |
+| `--max-bytes` | 67108864 | Input byte cap, adjustable downward to 1 byte. |
+| `--max-depth` | 24 | Occurrence depth, 0–256; root depth is 0. |
+| `--max-nodes` | 500 | Displayed occurrences, 1–100000; **not** stored nodes. |
+| `--preview-items` | 80 | Characters, bytes, or aliases per occurrence, 1–4096. |
+
+Numbers are inspected up to 64 encoded bits. String/byte previews do not certify
+unvisited suffixes. Depth and preview truncation appear on the affected occurrence;
+`occurrenceLimitReached` reports an omitted traversal remainder. Alias omission
+is reported separately. Payload previews may reveal secrets already present in
+the artifact; inspection output is not redacted.
+
+Input must be a regular file. Validation and name indexing process the stored
+DAG, never the exponentially larger unfolded tree. Output limits do not bound
+validation heap or elapsed time; the input byte cap is not a heap cap. Use external
+resource limits when inspecting untrusted artifacts.
+
+Unknown versions/tags and encountered malformed protocol shapes produce a report
+and a nonzero exit. Invalid bundles, missing exports, and input/option errors fail
+before a report. Deliberate opacity and budget truncation are successful reports,
+**not** proof that the complete program is valid or safe to execute. A global
+`--store` option is ignored by inspection; no store is read or created.
+
## IO and permissions
Select `--io` for interaction-tree execution. Grant file access with repeatable
diff --git a/docs/validation.md b/docs/validation.md
@@ -19,6 +19,28 @@ and have no verified native-support input route. Their CLIs fail before writes;
guard by trusting old support/cache stamps. No replacement benchmark route or new
measurements are claimed.
+### Interaction-tree inspection
+
+`nix flake check` includes the Haskell `Interaction inspection` unit group and
+`test/interaction_inspection.py` in the host-policy check. The CLI fixtures build
+indexed bundles independently of the inspector, check outline/JSON identities
+and exit behavior, retain malformed/unknown/oversized input controls, and verify
+that effectful trees neither mutate files nor create a store. The unit group
+covers all current host IO action tags, opaque continuations, exact export aliases,
+preview/depth/occurrence limits, and reachable exponentially shared values.
+
+For the focused CLI check after building the Haskell host:
+
+```sh
+nix build .#
+PYTHONDONTWRITEBYTECODE=1 python3 test/interaction_inspection.py result/bin/tricu
+```
+
+The compiled-source smoke example is in
+[read-only interaction-tree inspection](tri-tools.md.html#read-only-interaction-tree-inspection).
+It checks the native compiler-to-inspector path separately from independent wire
+fixtures; inspection itself never loads a compiler or executes an exported tree.
+
### Batch development loop
Agree on a substantial related module group, its intended interface/behavior
diff --git a/flake.nix b/flake.nix
@@ -308,6 +308,7 @@
python3 test/package_registry.py ${tricuPackage}/bin/tricu
python3 test/project_dependencies.py ${tricuPackage}/bin/tricu
python3 test/project_inspection.py ${tricuPackage}/bin/tricu
+ python3 test/interaction_inspection.py ${tricuPackage}/bin/tricu
python3 test/provenance.py ${tricuPackage}/bin/tricu
'';
installPhase = "mkdir -p $out";
diff --git a/src/InteractionInspection.hs b/src/InteractionInspection.hs
@@ -0,0 +1,284 @@
+{-# LANGUAGE BangPatterns #-}
+-- Read-only protocol interpretation of validated indexed nodes. No evaluator,
+-- tree reconstruction, content-store mutation, or IO driver is used here.
+module InteractionInspection
+ ( Limits(..), defaultLimits, Report(..), Occurrence(..)
+ , inspectBundle, renderOutline, reportJSON
+ ) where
+
+import qualified Wire as W
+import Control.Monad (when)
+import Data.Aeson (Value, object, (.=))
+import Data.Char (chr)
+import qualified Data.Map.Strict as M
+import qualified Data.Sequence as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Word (Word32)
+
+data Limits = Limits
+ { maxDepth :: Int, maxOccurrences :: Int, previewItems :: Int }
+ deriving (Eq, Show)
+
+defaultLimits :: Limits
+defaultLimits = Limits 24 500 80
+
+data Occurrence = Occurrence
+ { occurrencePath :: Text
+ , occurrenceDepth :: Int
+ , occurrenceNode :: Word32
+ , occurrenceAliases :: [Text]
+ , aliasesOmitted :: Int
+ , occurrenceRole :: Text
+ , occurrenceSummary :: Text
+ , occurrenceStatus :: Text
+ , occurrenceReference :: Maybe Text
+ } deriving (Eq, Show)
+
+data Report = Report
+ { selectedExport :: Text
+ , reportLimits :: Limits
+ , storedNodes :: Int
+ , occurrences :: [Occurrence]
+ , occurrenceLimitReached :: Bool
+ } deriving (Eq, Show)
+
+data View = Envelope | Action | Opaque Text | StringValue | BytesValue | Natural | Ignored
+ deriving (Eq, Ord, Show)
+
+data Decoded = Decoded Text Text [(Text, View, Word32)]
+type Nodes = S.Seq W.BundleNode
+
+-- verifyBundle rejects duplicate constructor/child tuples and forward edges.
+-- Thus node indices identify exact trees within this bundle, even if export
+-- names differ. They are NOT content-store hashes or execution identities.
+inspectBundle :: Limits -> Text -> W.Bundle -> Either String Report
+inspectBundle limits name bundle = do
+ when (maxDepth limits < 0 || maxDepth limits > 256) $ Left "max-depth must be between 0 and 256"
+ when (maxOccurrences limits < 1 || maxOccurrences limits > 100000) $ Left "max-nodes must be between 1 and 100000"
+ when (previewItems limits < 1 || previewItems limits > 4096) $ Left "preview-items must be between 1 and 4096"
+ W.verifyBundle bundle
+ root <- case filter ((== name) . W.exportName) exports of
+ [ex] -> Right (W.exportRoot ex)
+ _ -> Left "selected export not found"
+ let (rows, cut) = walk M.empty 0 [("root", 0, "export", Envelope, root)] []
+ pure (Report name limits (S.length nodes) rows cut)
+ where
+ nodes = W.bundleNodes bundle
+ exports = W.manifestExports (W.bundleManifest bundle)
+ aliases = M.map reverse $ foldl' (\m ex -> M.insertWith (++) (W.exportRoot ex) [W.exportName ex] m) M.empty exports
+ walk _ _ [] acc = (reverse acc, False)
+ walk _ count _ acc | count >= maxOccurrences limits = (reverse acc, True)
+ walk seen count ((path,depth,role,view,idx):pending) acc =
+ let names = M.findWithDefault [] idx aliases
+ base description state ref = Occurrence path depth idx (take (previewItems limits) names)
+ (max 0 (length names - previewItems limits)) role description state ref
+ Decoded summary status children = decode nodes limits view idx
+ shared = if view == Action then M.lookup idx seen else Nothing
+ in case shared of
+ Just first -> walk seen (count + 1) pending (base "shared action structure (not execution)" "reference" (Just first) : acc)
+ Nothing ->
+ let depthCut = depth >= maxDepth limits && not (null children)
+ row = if depthCut then base (summary <> "; depth limit")
+ (if status == "decoded" then "truncated" else status) Nothing
+ else base summary status Nothing
+ next = if depthCut then pending else
+ [(path <> "." <> field, depth + 1, field, childView, child) | (field,childView,child) <- children] ++ pending
+ seen' = if view == Action then M.insert idx path seen else seen
+ in walk seen' (count + 1) next (row : acc)
+
+node :: Nodes -> Word32 -> W.BundleNode
+node nodes i = S.index nodes (fromIntegral i)
+
+pair :: Nodes -> Word32 -> Either Text (Word32, Word32)
+pair nodes i = case node nodes i of
+ W.BNFork a b -> Right (a,b)
+ _ -> Left "expected pair"
+
+-- Bound number decoding independently of payload preview lengths. Match the
+-- host's binary-number decoder, including its acceptance of leading zero bits.
+-- No arbitrarily large Integer is constructed (at most 64 bits).
+natural :: Nodes -> Word32 -> Either Text Integer
+natural nodes = go 0 1 0
+ where
+ go :: Int -> Integer -> Integer -> Word32 -> Either Text Integer
+ go !bits !place !acc i = case node nodes i of
+ W.BNLeaf -> Right acc
+ W.BNFork b rest | bits < 64 -> do
+ bit <- case node nodes b of
+ W.BNLeaf -> Right 0
+ W.BNStem l | W.BNLeaf <- node nodes l -> Right 1
+ _ -> Left "invalid number bit"
+ go (bits + 1) (place * 2) (acc + bit * place) rest
+ W.BNFork _ _ -> Left "number exceeds 64-bit inspection limit"
+ _ -> Left "invalid number shape"
+
+-- Preview only; an unvisited suffix is not certified valid. The final tail is
+-- inspected to distinguish an exact-length list from a truncated prefix.
+listPreview :: Nodes -> Int -> (Integer -> Bool) -> Word32 -> Either Text ([Integer], Bool)
+listPreview nodes limit valid = go limit []
+ where
+ go remaining acc i = case node nodes i of
+ W.BNLeaf -> Right (reverse acc, False)
+ W.BNFork h rest
+ | remaining == 0 -> Right (reverse acc, True)
+ | otherwise -> do
+ n <- natural nodes h
+ if valid n then go (remaining - 1) (n:acc) rest else Left "element outside permitted range"
+ _ -> Left "expected proper list"
+
+scalar :: Integer -> Bool
+scalar n = n <= 0x10ffff && not (n >= 0xd800 && n <= 0xdfff)
+
+failure :: Text -> Decoded
+failure message = Decoded message "invalid" []
+
+boundedFailure :: Text -> Decoded
+boundedFailure message = Decoded message (if "limit" `T.isInfixOf` message then "truncated" else "invalid") []
+
+decode :: Nodes -> Limits -> View -> Word32 -> Decoded
+decode nodes limits view idx = case view of
+ Envelope -> case do
+ (sentinel, body) <- pair nodes idx
+ (chars, cut) <- listPreview nodes 7 scalar sentinel
+ when (cut || map (chr . fromInteger) chars /= "tricuIO") $ Left "expected tricuIO envelope; export is not decoded as IO (no application attempted)"
+ (version, action) <- pair nodes body
+ n <- natural nodes version
+ pure (n,action)
+ of
+ Left err -> boundedFailure err
+ Right (1, action) -> Decoded "tricuIO v1" "decoded" [("action",Action,action)]
+ Right (n, _) -> Decoded ("unsupported tricuIO version " <> tshow n) "unknown" []
+ Action -> case pair nodes idx of
+ Left _ -> failure "expected action pair (tag, payload)"
+ Right (tag,payload) -> case natural nodes tag of
+ Left err -> boundedFailure ("action tag: " <> err)
+ Right n -> case operation n of
+ Nothing -> Decoded ("unknown IO tag " <> tshow n) "unknown" [("payload",Opaque "uninterpreted payload",payload)]
+ Just (label, fields) -> case unpackFields payload fields of
+ Left err -> failure (label <> ": " <> err)
+ Right children -> Decoded label "decoded" children
+ Opaque label -> Decoded label "opaque" []
+ Ignored -> Decoded "ignored by host" "opaque" []
+ Natural -> case natural nodes idx of
+ Left err -> boundedFailure err
+ Right n -> Decoded (tshow n) "decoded" []
+ StringValue -> preview scalar (T.pack . show . map (chr . fromInteger))
+ BytesValue -> preview (<=255) (\ns -> "bytes " <> tshow ns)
+ where
+ unpackFields _ [] = Right []
+ unpackFields p [(field,v)] = Right [(field,v,p)]
+ unpackFields p ((field,v):rest) = do
+ (a,b) <- pair nodes p
+ others <- unpackFields b rest
+ pure ((field,v,a):others)
+ preview valid format = case listPreview nodes (previewItems limits) valid idx of
+ Left err -> boundedFailure err
+ Right (values,cut) -> Decoded
+ (format values <> if cut then " ... (suffix not inspected)" else "")
+ (if cut then "truncated" else "decoded") []
+
+-- The host IO v1 field layouts, not the incompatible pure contract-effect
+-- protocol. Keep independent fixture expectations in InteractionInspectionTests.
+-- Zero-argument operations deliberately expose their ignored payload: the host
+-- accepts any tree there, not only Leaf.
+operation :: Integer -> Maybe (Text, [(Text, View)])
+operation tag = lookup tag
+ [ (0, ("Pure", [("value",value)]))
+ , (1, ("Bind", [("action",Action),("resume",Opaque "continuation (not applied)")]))
+ , (2, ("Abort", [("diagnostic",value)]))
+ , (10, ("PutStr", [("text",StringValue)]))
+ , (11, ("GetLine", ignored))
+ , (12, ("PutBytes", [("bytes",BytesValue)]))
+ , (20, ("ReadFile", path))
+ , (21, ("WriteFile", path ++ [("contents",StringValue)]))
+ , (22, ("WriteBytes", path ++ [("bytes",BytesValue)]))
+ , (23, ("ListDirectory", path))
+ , (24, ("RenameFile", [("oldPath",StringValue),("newPath",StringValue)]))
+ , (25, ("CreateDirectory", path))
+ , (26, ("DeleteFile", path))
+ , (27, ("FileExists", path))
+ , (28, ("Sha256Hex", [("bytes",BytesValue)]))
+ , (29, ("CurrentTime", ignored))
+ , (30, ("Ask", ignored))
+ , (31, ("Local", [("transform",Opaque "environment function (not applied)"),("action",Action)]))
+ , (32, ("WriteBytesIfAbsent", path ++ [("bytes",BytesValue)]))
+ , (33, ("AtomicWriteBytes", path ++ [("bytes",BytesValue)]))
+ , (34, ("ReadTreeTerm", pathDigest))
+ , (35, ("HashTreeTerm", [("tree",value)]))
+ , (36, ("WriteTreeTermIfAbsent", pathDigest ++ [("tree",value)]))
+ , (37, ("ReadSourceFile", path))
+ , (38, ("EncodeSourceText", [("text",StringValue)]))
+ , (40, ("Get", ignored))
+ , (41, ("Put", [("state",value)]))
+ , (50, ("ReadIndexedTree", pathDigest))
+ , (51, ("HashIndexedTree", [("tree",value)]))
+ , (52, ("WriteIndexedTreeIfAbsent", pathDigest ++ [("tree",value)]))
+ , (60, ("Fork", [("action",Action)]))
+ , (61, ("Await", [("handle",value)]))
+ , (62, ("Yield", ignored))
+ , (63, ("Sleep", [("milliseconds",Natural)]))
+ , (70, ("Socket", ignored))
+ , (71, ("CloseSocket", sock))
+ , (72, ("BindSocket", sockAddress))
+ , (73, ("Listen", sock ++ [("backlog",Natural)]))
+ , (74, ("Accept", sock))
+ , (75, ("Connect", sockAddress))
+ , (76, ("Recv", sock ++ [("maxBytes",Natural)]))
+ , (77, ("Send", sock ++ [("bytes",BytesValue)]))
+ , (78, ("GetSocketName", sock))
+ ]
+ where
+ value = Opaque "tree value"
+ path = [("path",StringValue)]
+ pathDigest = path ++ [("digest",StringValue)]
+ sock = [("socket",value)]
+ sockAddress = sock ++ [("address",StringValue),("port",Natural)]
+ ignored = [("payload",Ignored)]
+
+tshow :: Show a => a -> Text
+tshow = T.pack . show
+
+nodeId :: Word32 -> Text
+nodeId n = "n" <> tshow n
+
+-- Show text fields as Haskell string literals so newlines, escape sequences,
+-- bidi/non-ASCII characters, etc. cannot inject terminal rows/control sequences.
+quoted :: Text -> Text
+quoted = tshow . T.unpack
+
+renderOutline :: Report -> Text
+renderOutline report = T.unlines $
+ ["export " <> quoted (selectedExport report) <> " [host IO v1; read-only]"
+ ,"tree IDs are bundle-local; aliases are exact exported-tree matches"]
+ ++ map row (occurrences report)
+ ++ ["... occurrence limit reached; remaining traversal omitted" | occurrenceLimitReached report]
+ where
+ row o = T.replicate (occurrenceDepth o) " " <> occurrencePath o <> ": "
+ <> occurrenceSummary o <> " [" <> nodeId (occurrenceNode o) <> "; " <> occurrenceStatus o <> "]"
+ <> (if null (occurrenceAliases o) then "" else " aliases: " <> T.intercalate ", " (map quoted (occurrenceAliases o)))
+ <> (if aliasesOmitted o == 0 then "" else " (+" <> tshow (aliasesOmitted o) <> " aliases omitted)")
+ <> maybe "" (" -> " <>) (occurrenceReference o)
+
+reportJSON :: Text -> Report -> Value
+reportJSON bundleSHA256 report = object
+ [ "schema" .= ("tricu.interaction-inspection.v1" :: Text)
+ , "protocol" .= ("tricuIO" :: Text)
+ , "supportedVersion" .= (1 :: Int)
+ , "bundleSha256" .= bundleSHA256
+ , "identityScope" .= ("bundle-local node indices; not CAS addresses" :: Text)
+ , "export" .= selectedExport report
+ , "storedNodes" .= storedNodes report
+ , "limits" .= object ["depth" .= maxDepth limits, "occurrences" .= maxOccurrences limits, "previewItems" .= previewItems limits]
+ , "occurrenceLimitReached" .= occurrenceLimitReached report
+ , "occurrences" .= map row (occurrences report)
+ ]
+ where
+ limits = reportLimits report
+ row o = object
+ [ "path" .= occurrencePath o, "depth" .= occurrenceDepth o
+ , "treeId" .= nodeId (occurrenceNode o), "aliases" .= occurrenceAliases o
+ , "aliasesOmitted" .= aliasesOmitted o, "role" .= occurrenceRole o
+ , "summary" .= occurrenceSummary o, "status" .= occurrenceStatus o
+ , "reference" .= occurrenceReference o
+ ]
diff --git a/src/Main.hs b/src/Main.hs
@@ -4,6 +4,7 @@ import ContentStore
import qualified Package
import qualified Module.Provenance as Provenance
import qualified Module.Inspection as Inspection
+import qualified InteractionInspection as Interaction
import qualified Project
import ContentStore.Bundle
import Module.Manifest
@@ -11,6 +12,7 @@ import System.Exit (die, exitFailure)
import IODriver (IOPermissions(..), runIO, YieldStats(..), runIOWithYieldStatsHook)
import REPL (portableRepl)
import Research (T(..), EvaluatedForm(..), formatT, exportDag, apply, ofString, ofNumber, toString)
+import qualified Wire
import Wire (encodeBundle, buildBundleShared, defaultExportNames, Bundle(..))
import TreeObservation (forceTreeShared)
@@ -40,7 +42,7 @@ import GHC.Clock (getMonotonicTimeNSec)
import GHC.Stats
import Data.IORef (newIORef, atomicModifyIORef')
import System.Mem (performGC)
-import System.Posix.Files (fileMode, getFileStatus, setFileMode)
+import System.Posix.Files (fileMode, getFileStatus, setFileMode, isRegularFile)
-- ---------------------------------------------------------------------------
-- CLI argument types
@@ -108,6 +110,7 @@ data TricuArgs
, compileNames :: [String]
, compileCompiler :: CompilerOptions
}
+ | ArboricxInspect FilePath String Bool Int Int Int Int
| ArboricxImport
{ importFile :: FilePath
, importStore :: Maybe FilePath
@@ -405,6 +408,18 @@ compileParser = ArboricxCompile
))
<*> compilerOptionsParser
+inspectParser :: Parser TricuArgs
+inspectParser = ArboricxInspect
+ <$> strOption (long "file" <> short 'f' <> metavar "FILE.arboricx" <> help "Indexed bundle to read (no store import)")
+ <*> strOption (long "name" <> short 'n' <> metavar "EXPORT" <> value "main" <> showDefault <> help "Already-materialized IO export to inspect")
+ <*> switch (long "json" <> help "Emit versioned JSON instead of a terminal outline")
+ <*> option auto (long "max-depth" <> value 24 <> showDefault <> help "Maximum occurrence depth (0..256)")
+ <*> option auto (long "max-nodes" <> value 500 <> showDefault <> help "Maximum displayed occurrences (1..100000); not a stored-node limit")
+ <*> option auto (long "preview-items" <> value 80 <> showDefault <> help "Maximum characters/bytes or aliases per occurrence (1..4096)")
+ <*> option auto (long "max-bytes" <> value (64 * 1024 * 1024) <> showDefault <> help "Input bundle byte limit (1..67108864); not a heap limit")
+ <* option (eitherReader (\s -> if s == "io" then Right () else Left "only --as io is supported"))
+ (long "as" <> metavar "io" <> help "Explicitly select the host IO protocol (required)")
+
importParser :: Parser TricuArgs
importParser = ArboricxImport
<$> option str
@@ -606,6 +621,8 @@ arboricxParser :: Parser TricuArgs
arboricxParser = subparser $ mconcat
[ command "compile" (info (compileParser <**> helper)
(progDesc "Compile a .tri file into a standalone Arboricx bundle"))
+ , command "inspect" (info (inspectParser <**> helper)
+ (progDesc "Inspect an exported IO tree without evaluation, effects, or store writes"))
, command "import" (info (importParser <**> helper)
(progDesc "Import an Arboricx bundle into the content store"))
, command "export" (info (exportParser <**> helper)
@@ -650,6 +667,7 @@ main = do
TreeWrite {} -> runTreeWrite args
TriFormat {} -> runTriFormat args
ArboricxCompile {} -> runCompile args
+ ArboricxInspect {} -> runInspect args
ArboricxImport {} -> runImport args
ArboricxExport {} -> runExport args
ArboricxRun {} -> runStored args
@@ -678,6 +696,7 @@ applyGlobalStore mGlobal args = case args of
TreeWrite {} -> args { treeStore = preferLocal (treeStore args) }
TriFormat {} -> args { triFormatStore = preferLocal (triFormatStore args) }
ArboricxCompile {} -> args { compileStore = preferLocal (compileStore args) }
+ ArboricxInspect {} -> args
ArboricxImport {} -> args { importStore = preferLocal (importStore args) }
ArboricxExport {} -> args { exportStore = preferLocal (exportStore args) }
ArboricxRun {} -> args { storedStore = preferLocal (storedStore args) }
@@ -1331,3 +1350,25 @@ writeOutput :: FilePath -> String -> IO ()
writeOutput path content
| null path = putStr content
| otherwise = writeFile path content
+
+-- Inspection reads only the selected artifact. The byte cap is enforced before
+-- decoding; output traversal limits do not pretend to bound validation heap.
+runInspect :: TricuArgs -> IO ()
+runInspect (ArboricxInspect file name json depth count preview byteLimit) =
+ (do
+ when (byteLimit < 1 || byteLimit > 64 * 1024 * 1024) $
+ die "max-bytes must be between 1 and 67108864"
+ status <- getFileStatus file
+ unless (isRegularFile status) $ die "inspection requires a regular file"
+ bytes <- withBinaryFile file ReadMode $ \h -> BS.hGet h (byteLimit + 1)
+ when (BS.length bytes > byteLimit) $ die "bundle exceeds max-bytes"
+ bundle <- either (die . T.unpack . Inspection.safeText . T.pack) pure (Wire.decodeBundle bytes)
+ report <- either (die . T.unpack . Inspection.safeText . T.pack) pure $
+ Interaction.inspectBundle (Interaction.Limits depth count preview) (T.pack name) bundle
+ let fingerprint = T.pack (show (hash bytes :: Digest SHA256))
+ if json then BL.putStr (JSON.encode (Interaction.reportJSON fingerprint report) <> "\n")
+ else putStrLn ("bundle sha256 " ++ T.unpack fingerprint) >>
+ putStr (T.unpack (Interaction.renderOutline report))
+ when (any (\o -> Interaction.occurrenceStatus o `elem` ["invalid", "unknown"]) (Interaction.occurrences report)) exitFailure
+ ) `catch` (\(e :: IOException) -> die (T.unpack (Inspection.safeText (T.pack (show e)))))
+runInspect _ = die "invalid inspection invocation"
diff --git a/test/InteractionInspectionTests.hs b/test/InteractionInspectionTests.hs
@@ -0,0 +1,151 @@
+module InteractionInspectionTests (interactionInspectionTests) where
+
+import InteractionInspection
+import Research (T(..), ofNumber, ofString, ofList)
+import qualified Wire as W
+import qualified Data.Sequence as S
+import qualified Data.Text as Text
+import qualified Data.ByteString.Lazy.Char8 as BL
+import Data.Aeson (encode, eitherDecode, Value)
+import Test.Tasty
+import Test.Tasty.HUnit
+
+-- Independent literal tags/layouts: do not derive expected values from the
+-- inspector's operation table. No source compiler/evaluator is involved.
+io :: T -> T
+io = Fork (ofString "tricuIO") . Fork (ofNumber 1)
+action :: Integer -> T -> T
+action = Fork . ofNumber
+
+inspect :: Limits -> [(Text.Text,T)] -> Report
+inspect limits exports = either error id $ inspectBundle limits "main" (W.buildBundle exports)
+
+rows :: T -> [Occurrence]
+rows t = occurrences (inspect defaultLimits [("main",io t)])
+
+interactionInspectionTests :: TestTree
+interactionInspectionTests = testGroup "Interaction inspection"
+ [ testCase "bind outline, exact continuation aliases and paths" $ do
+ let k = Stem (Fork Leaf Leaf)
+ r = inspect defaultLimits [("main",io (action 1 (Fork (action 20 (ofString "settings.txt")) k))), ("afterRead",k), ("alsoAfterRead",k)]
+ os = occurrences r
+ map occurrencePath os @?= ["root","root.action","root.action.action","root.action.action.path","root.action.resume"]
+ map occurrenceSummary os @?= ["tricuIO v1","Bind","ReadFile","\"settings.txt\"","continuation (not applied)"]
+ occurrenceAliases (last os) @?= ["afterRead","alsoAfterRead"]
+ occurrenceStatus (last os) @?= "opaque"
+ , testCase "continuations remain opaque even when shaped as actions" $ do
+ let os = rows (action 1 (Fork (action 11 Leaf) (action 26 (ofString "DO-NOT-DELETE"))))
+ assertBool "no interpreted continuation" (not (any ((== "DeleteFile") . occurrenceSummary) os))
+ occurrenceSummary (last os) @?= "continuation (not applied)"
+ , testCase "explicit Fork and Local child actions only" $ do
+ let os = rows (action 60 (action 31 (Fork (action 10 (ofString "not run")) (action 63 (ofNumber 25)))))
+ map occurrenceSummary os @?= ["tricuIO v1","Fork","Local","environment function (not applied)","Sleep","25"]
+ , testCase "all primitive tags and field roles" $ mapM_ checkPrimitive primitives
+ , testCase "tag 2 is terminal Abort, not a pure-layer exception" $
+ map occurrenceSummary (rows (action 2 (ofString "stop"))) @?= ["tricuIO v1","Abort","tree value"]
+ , testCase "bad envelope, unsupported version, unknown and malformed actions" $ do
+ let bad = inspect defaultLimits [("main",Leaf)]
+ occurrenceStatus (head (occurrences bad)) @?= "invalid"
+ let version = inspect defaultLimits [("main",Fork (ofString "tricuIO") (Fork (ofNumber 2) Leaf))]
+ occurrenceStatus (head (occurrences version)) @?= "unknown"
+ occurrenceStatus (rows (action 999 Leaf) !! 1) @?= "unknown"
+ let cutUnknown = inspect (Limits 1 100 80) [("main",io (action 999 Leaf))]
+ occurrenceStatus (last (occurrences cutUnknown)) @?= "unknown"
+ occurrenceStatus (rows (action 1 Leaf) !! 1) @?= "invalid"
+ occurrenceStatus (rows (action 72 (Fork Leaf Leaf)) !! 1) @?= "invalid"
+ occurrenceStatus (last (rows (action 20 (Stem Leaf)))) @?= "invalid"
+ occurrenceStatus (last (rows (action 12 (ofList [ofNumber 256])))) @?= "invalid"
+ occurrenceStatus (last (rows (action 10 (ofList [ofNumber 0xd800])))) @?= "invalid"
+ , testCase "ignored payload is not wrongly required to be Leaf" $
+ occurrenceStatus (last (rows (action 11 (Stem Leaf)))) @?= "opaque"
+ , testCase "noncanonical binary numbers follow host acceptance" $ do
+ let noncanonical = Fork Leaf Leaf
+ r = inspect defaultLimits [("main",io (Fork noncanonical Leaf))]
+ occurrenceSummary (occurrences r !! 1) @?= "Pure"
+ , testCase "bounded previews distinguish exact end, bad tail and unvisited suffix" $ do
+ let preview t = last $ occurrences $ inspect (Limits 24 500 2) [("main",io (action 10 t))]
+ occurrenceStatus (preview (ofString "ab")) @?= "decoded"
+ occurrenceStatus (preview (ofString "abc")) @?= "truncated"
+ occurrenceStatus (preview (Fork (ofNumber 97) (Stem Leaf))) @?= "invalid"
+ occurrenceStatus (preview (Fork (ofNumber 97) (Fork (ofNumber 98) (Fork (Stem Leaf) Leaf)))) @?= "truncated"
+ , testCase "depth, occurrence and alias limits are deterministic" $ do
+ let bundle = [("main",io (action 60 (action 60 (action 0 Leaf)))), ("alias",Leaf),("alias2",Leaf)]
+ deep = inspect (Limits 1 100 80) bundle
+ length (occurrences deep) @?= 2
+ occurrenceStatus (last (occurrences deep)) @?= "truncated"
+ let narrow = inspect (Limits 24 2 80) bundle
+ length (occurrences narrow) @?= 2
+ occurrenceLimitReached narrow @?= True
+ let aliases = inspect (Limits 24 100 1) bundle
+ aliasesOmitted (last (occurrences aliases)) @?= 1
+ inspect (Limits 24 2 80) bundle @?= narrow
+ , testCase "64-bit number inspection cap" $ do
+ let os = rows (action 63 (ofNumber (2^(65::Int))))
+ occurrenceStatus (last os) @?= "truncated"
+ , testCase "same tree can occupy distinct semantic roles" $ do
+ let a = action 11 Leaf
+ os = rows (action 1 (Fork a a))
+ act = os !! 2
+ resume = last os
+ occurrenceNode act @?= occurrenceNode resume
+ assertBool "distinct occurrences" (occurrencePath act /= occurrencePath resume)
+ occurrenceStatus act @?= "decoded"
+ occurrenceStatus resume @?= "opaque"
+ , testCase "large shared opaque DAG is never unfolded" $ do
+ let huge = iterate (\t -> Fork t t) Leaf !! 120
+ bundle <- W.buildBundleShared [("main",io (action 0 huge))]
+ case inspectBundle defaultLimits "main" bundle of
+ Left e -> assertFailure e
+ Right r -> do
+ length (occurrences r) @?= 3
+ assertBool "compact stored representation" (storedNodes r < 200)
+ , testCase "validate unused nodes and reject missing exports / bad limits" $ do
+ let b = W.buildBundle [("main",io (action 0 Leaf))]
+ malformed = b { W.bundleNodes = W.bundleNodes b S.|> W.BNStem 99999 }
+ isLeft (Left _) = True; isLeft _ = False
+ assertBool "unused invalid edge" (isLeft (inspectBundle defaultLimits "main" malformed))
+ assertBool "absent export" (isLeft (inspectBundle defaultLimits "missing" b))
+ assertBool "negative limit" (isLeft (inspectBundle (Limits (-1) 1 1) "main" b))
+ assertBool "zero limit" (isLeft (inspectBundle (Limits 1 0 1) "main" b))
+ , testCase "JSON schema and safe terminal quoting" $ do
+ let r = inspect defaultLimits [("main",io (action 10 (ofString "x\n\ESC[2J\x202e"))), ("unsafe\n\ESC",io (action 10 (ofString "x\n\ESC[2J\x202e")))]
+ output = renderOutline r
+ json = reportJSON "fingerprint" r
+ assertBool "no terminal escapes" (not (Text.any (== '\ESC') output))
+ assertBool "no bidi" (not (Text.any (== '\x202e') output))
+ (eitherDecode (encode json) :: Either String Value) @?= Right json
+ assertBool "schema" ("tricu.interaction-inspection.v1" `Text.isInfixOf` Text.pack (BL.unpack (encode json)))
+ ]
+ where
+ checkPrimitive (tag,label,fields) = do
+ let payload = case fields of
+ [] -> Leaf
+ _ -> foldr1 Fork (map snd fields)
+ os = rows (action tag payload)
+ occurrenceSummary (os !! 1) @?= label
+ map occurrenceRole (drop 2 os) @?= if null fields then ["payload"] else map fst fields
+ assertBool ("valid payloads for " ++ show tag) (all ((/= "invalid") . occurrenceStatus) os)
+ str = ofString "x"
+ n = ofNumber 3
+ p = ("path",str)
+ dg = ("digest",str)
+ bytes = ("bytes",ofList [ofNumber 0,ofNumber 255])
+ sock = ("socket",Leaf)
+ address = [("address",str),("port",n)]
+ primitives =
+ [ (0,"Pure",[("value",Leaf)]), (10,"PutStr",[("text",str)]), (11,"GetLine",[])
+ , (12,"PutBytes",[bytes]), (20,"ReadFile",[p]), (21,"WriteFile",[p,("contents",str)])
+ , (22,"WriteBytes",[p,bytes]), (23,"ListDirectory",[p]), (24,"RenameFile",[("oldPath",str),("newPath",str)])
+ , (25,"CreateDirectory",[p]), (26,"DeleteFile",[p]), (27,"FileExists",[p])
+ , (28,"Sha256Hex",[bytes]), (29,"CurrentTime",[]), (30,"Ask",[])
+ , (32,"WriteBytesIfAbsent",[p,bytes]), (33,"AtomicWriteBytes",[p,bytes])
+ , (34,"ReadTreeTerm",[p,dg]), (35,"HashTreeTerm",[("tree",Leaf)])
+ , (36,"WriteTreeTermIfAbsent",[p,dg,("tree",Leaf)]), (37,"ReadSourceFile",[p])
+ , (38,"EncodeSourceText",[("text",str)]), (40,"Get",[]), (41,"Put",[("state",Leaf)])
+ , (50,"ReadIndexedTree",[p,dg]), (51,"HashIndexedTree",[("tree",Leaf)])
+ , (52,"WriteIndexedTreeIfAbsent",[p,dg,("tree",Leaf)]), (61,"Await",[("handle",Leaf)])
+ , (62,"Yield",[]), (63,"Sleep",[("milliseconds",n)]), (70,"Socket",[])
+ , (71,"CloseSocket",[sock]), (72,"BindSocket",sock:address), (73,"Listen",[sock,("backlog",n)])
+ , (74,"Accept",[sock]), (75,"Connect",sock:address), (76,"Recv",[sock,("maxBytes",n)])
+ , (77,"Send",[sock,bytes]), (78,"GetSocketName",[sock])
+ ]
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -2,6 +2,7 @@ module Main where
import Eval
import PackageTests (packageTests)
+import InteractionInspectionTests (interactionInspectionTests)
import FileEval
import Lexer
import Parser
@@ -75,7 +76,8 @@ allTestLibsEnv = unsafePerformIO $ do
tests :: TestTree
tests = testGroup "Tricu Tests"
- [ packageTests
+ [ interactionInspectionTests
+ , packageTests
, lexer
, parser
, simpleEvaluation
diff --git a/test/interaction_inspection.py b/test/interaction_inspection.py
@@ -0,0 +1,161 @@
+#!/usr/bin/env python3
+"""Read-only IO inspection CLI against independently assembled indexed bundles."""
+import argparse
+import hashlib
+import json
+import os
+from pathlib import Path
+import struct
+import subprocess
+import tempfile
+
+from stable_bundle import assembled, sections
+
+ROOT = Path(__file__).resolve().parent.parent
+
+
+def main():
+ parser = argparse.ArgumentParser(description=__doc__)
+ parser.add_argument('tricu', type=Path)
+ exe = parser.parse_args().tricu.resolve()
+ manifest, _ = sections(ROOT / 'test/fixtures/id.arboricx')
+ at = 12
+ for _ in range(9):
+ size = struct.unpack_from('>I', manifest, at)[0]
+ at += 4 + size
+ assert struct.unpack_from('>I', manifest, at)[0] == 0
+ prefix = manifest[:at + 5]
+
+ def text(value):
+ data = value.encode()
+ return struct.pack('>I', len(data)) + data
+
+ nodes, indices = [], {}
+
+ def intern(*children):
+ if children not in indices:
+ indices[children] = len(nodes)
+ nodes.append(children)
+ return indices[children]
+
+ leaf = intern()
+ one = intern(leaf)
+
+ def number(n):
+ return intern(one if n % 2 else leaf, number(n // 2)) if n else leaf
+
+ def string(s):
+ result = leaf
+ for c in reversed(s):
+ result = intern(number(ord(c)), result)
+ return result
+
+ def action(tag, payload):
+ return intern(number(tag), payload)
+
+ def envelope(a, version=1):
+ return intern(string('tricuIO'), intern(number(version), a))
+
+ def bundle(exports, extra=()):
+ records = [bytes([len(cs)]) + b''.join(struct.pack('>I', c) for c in cs) for cs in nodes + list(extra)]
+ m = prefix + struct.pack('>I', len(exports))
+ for _, index in exports:
+ m += struct.pack('>I', index) + text('default')
+ m += struct.pack('>I', len(exports))
+ for name, index in exports:
+ m += text(name) + struct.pack('>I', index) + text('term') + text('arboricx.abi.tree.v1')
+ m += struct.pack('>II', 0, 0)
+ return assembled(m, struct.pack('>Q', len(records)) + b''.join(struct.pack('>I', len(r)) + r for r in records))
+
+ with tempfile.TemporaryDirectory(prefix='interaction-inspection-') as tmp:
+ root = Path(tmp)
+ artifact = root / 'input.arboricx'
+ victim = root / 'must-remain'
+ victim.write_text('untouched')
+ absent_store = root / 'must-not-create-store'
+ # If inspection accidentally executes effects, this deletes the victim.
+ dangerous = action(26, string(str(victim)))
+ k = action(10, string('MUST-NOT-PRINT')) # deliberately not a callable continuation
+ bind = action(1, intern(dangerous, k))
+ main_root = envelope(bind)
+ artifact.write_bytes(bundle([('main', main_root), ('resume\n\x1b[2J', k), ('alias', k)]))
+
+ def snapshot():
+ return {str(p.relative_to(root)): (p.read_bytes(), p.stat().st_mtime_ns)
+ for p in root.rglob('*') if p.is_file()}
+
+ def run(*args, ok=True):
+ before = snapshot()
+ reply = subprocess.run([str(exe), '--store', str(absent_store), 'arboricx', 'inspect',
+ '--file', str(artifact), *map(str, args), '+RTS', '-N1', '-M512m', '-RTS'],
+ cwd=root, capture_output=True, text=True, timeout=20)
+ assert (reply.returncode == 0) == ok, (reply.stdout, reply.stderr)
+ assert snapshot() == before, 'inspection mutated files'
+ assert not absent_store.exists(), 'inspection populated a store'
+ assert '\x1b' not in reply.stdout, 'terminal control injection'
+ return reply
+
+ output = run('--as', 'io').stdout
+ assert 'DeleteFile' in output and 'continuation (not applied)' in output
+ assert 'MUST-NOT-PRINT' not in output
+ assert '\\n\\ESC' in output
+ report = json.loads(run('--as', 'io', '--json').stdout)
+ assert report['schema'] == 'tricu.interaction-inspection.v1'
+ assert report['bundleSha256'] == hashlib.sha256(artifact.read_bytes()).hexdigest()
+ assert [o['path'] for o in report['occurrences']] == [
+ 'root', 'root.action', 'root.action.action', 'root.action.action.path', 'root.action.resume']
+ assert report['occurrences'][-1]['aliases'] == ['resume\n\x1b[2J', 'alias']
+ assert report == json.loads(run('--as', 'io', '--json').stdout)
+ narrow = json.loads(run('--as', 'io', '--json', '--max-nodes', 2).stdout)
+ assert len(narrow['occurrences']) == 2 and narrow['occurrenceLimitReached']
+ shallow = json.loads(run('--as', 'io', '--json', '--max-depth', 0).stdout)
+ assert shallow['occurrences'][0]['status'] == 'truncated'
+ run(ok=False) # protocol selection is required
+ run('--as', 'contract', ok=False)
+ run('--as', 'io', '--name', 'absent', ok=False)
+ run('--as', 'io', '--max-bytes', 1, ok=False)
+ run('--as', 'io', '--max-nodes', 0, ok=False)
+ run('--as', 'io', '--max-depth', 257, ok=False)
+ run('--as', 'io', '--preview-items', 0, ok=False)
+
+ for tree, expected in [(leaf, 'invalid'), (envelope(leaf, 2), 'unknown'),
+ (envelope(action(999, leaf)), 'unknown'),
+ (envelope(action(1, leaf)), 'invalid')]:
+ artifact.write_bytes(bundle([('main', tree)]))
+ failure = json.loads(run('--as', 'io', '--json', ok=False).stdout)
+ assert expected in [o['status'] for o in failure['occurrences']]
+
+ # Huge logical value is reachable, but remains an opaque DAG root.
+ huge = leaf
+ for _ in range(200):
+ huge = intern(huge, huge)
+ artifact.write_bytes(bundle([('main', envelope(action(0, huge)))]))
+ large = json.loads(run('--as', 'io', '--json').stdout)
+ assert len(large['occurrences']) == 3
+ assert large['storedNodes'] < 500
+ # Validate all stored nodes, not only those demanded by the outline.
+ artifact.write_bytes(bundle([('main', main_root)], extra=[(len(nodes),)]))
+ assert 'references child' in run('--as', 'io', ok=False).stderr
+ artifact.write_bytes(b'not a bundle')
+ assert 'invalid magic' in run('--as', 'io', ok=False).stderr
+ # Nonregular inputs must not block on FIFOs.
+ artifact.unlink()
+ os.mkfifo(artifact)
+ reply = subprocess.run([str(exe), 'arboricx', 'inspect', '--file', str(artifact), '--as', 'io',
+ '+RTS', '-N1', '-RTS'], capture_output=True, text=True, timeout=10)
+ assert reply.returncode != 0 and 'regular file' in reply.stderr
+ artifact.unlink()
+ # Native stable compiler smoke is separate from independent wire tests.
+ subprocess.run([str(exe), 'arboricx', 'compile', '--file',
+ str(ROOT / 'demos/interaction-inspection.tri'), '--store', str(root / 'compile-store'),
+ '--output', str(artifact), '+RTS', '-N1', '-M512m', '-RTS'],
+ cwd=root, capture_output=True, text=True, check=True, timeout=120)
+ compiled = json.loads(run('--as', 'io', '--json').stdout)
+ assert compiled['occurrences'][-1]['aliases'] == ['afterRead']
+ assert compiled['occurrences'][2]['summary'] == 'ReadFile'
+ assert compiled['occurrences'][3]['summary'] == '"settings.txt"'
+ print('PASS interaction inspection: independent bundle layouts, JSON/outline, no effects/store writes, limits and malformed inputs')
+
+
+if __name__ == '__main__':
+ main()
diff --git a/test/unit.py b/test/unit.py
@@ -360,11 +360,11 @@ class StandardMigrationTests(unittest.TestCase):
def test_application_demos_are_native(self):
demos = [*(ROOT / 'demos').glob('*.tri'), *(ROOT / 'demos/interactionTrees').glob('*.tri')]
- self.assertEqual(len(demos), 21)
+ self.assertEqual(len(demos), 22)
for path in demos:
with self.subTest(path=path):
self.assertFalse(legacy(path))
- self.assertIn('!export *', path.read_text().splitlines())
+ self.assertTrue(any(line.startswith('!export ') for line in path.read_text().splitlines()))
def test_demo_inputs_have_no_legacy_imports(self):
remaining = {str(path.relative_to(ROOT)) for path in (ROOT / 'demos').rglob('*.tri')
diff --git a/tricu.cabal b/tricu.cabal
@@ -74,6 +74,7 @@ executable tricu
Package
Project
Module.Inspection
+ InteractionInspection
Module.Provenance
ContentStore
ContentStore.Alias
@@ -167,6 +168,7 @@ test-suite tricu-tests
ScopedTypeVariables
build-depends:
base >=4.7
+ , aeson
, http-client
, http-client-tls
, http-types
@@ -202,8 +204,10 @@ test-suite tricu-tests
Package
Project
Module.Inspection
+ InteractionInspection
Module.Provenance
PackageTests
+ InteractionInspectionTests
ContentStore
ContentStore.Alias
ContentStore.Arboricx
