Arboricx bundle format 1.1

We don't need SHA verification or Merkle dags in our transport bundle. Content stores can handle both bundle and term verification and hashing.
2026-05-11 19:53:37 -05:00
parent e0b1e95729
commit 31bf7094f4
45 changed files with 4032 additions and 7127 deletions
--- a/lib/arboricx-common.tri
+++ b/lib/arboricx-common.tri
@@ -61,22 +61,22 @@ readSectionRecord = (bs :
              bindResult (readBytes 2 afterSectionFlags)
                (compression afterCompression :
                  bindResult (readBytes 2 afterCompression)
-                    (digestAlgorithm afterDigestAlgorithm :
-                      bindResult (readBytes 8 afterDigestAlgorithm)
+                    (reserved1 afterReserved1 :
+                      bindResult (readBytes 8 afterReserved1)
                        (offset afterOffset :
                          bindResult (readBytes 8 afterOffset)
                            (length afterLength :
-                              bindResult (readBytes 32 afterLength)
-                                (digest afterDigest :
+                              bindResult (readBytes 4 afterLength)
+                                (reserved2 afterReserved2 :
                                  ok
                                    (pair sectionId
                                      (pair sectionVersion
                                        (pair sectionFlags
                                          (pair compression
-                                            (pair digestAlgorithm
+                                            (pair reserved1
                                              (pair offset
-                                                (pair length digest)))))))
-                                    afterDigest)))))))))
+                                                (pair length reserved2)))))))
+                                    afterReserved2)))))))))

 readSectionDirectory_ = y (self bs sectionCount i acc :
  matchBool
@@ -126,7 +126,7 @@ sectionRecordCompression = (sectionRecord :
        payload)
    sectionRecord)

-sectionRecordDigestAlgorithm = (sectionRecord :
+sectionRecordReserved1 = (sectionRecord :
  matchPair
    (_ payload :
      matchPair
@@ -136,7 +136,7 @@ sectionRecordDigestAlgorithm = (sectionRecord :
              matchPair
                (_ payload4 :
                  matchPair
-                    (digestAlgorithm _ : digestAlgorithm)
+                    (reserved1 _ : reserved1)
                    payload4)
                payload3)
            payload2)
@@ -186,7 +186,7 @@ sectionRecordLength = (sectionRecord :
        payload)
    sectionRecord)

-sectionRecordDigest = (sectionRecord :
+sectionRecordReserved2 = (sectionRecord :
  matchPair
    (_ payload :
      matchPair
@@ -200,7 +200,7 @@ sectionRecordDigest = (sectionRecord :
                      matchPair
                        (_ payload6 :
                          matchPair
-                            (_ digest : digest)
+                            (_ reserved2 : reserved2)
                            payload6)
                        payload5)
                    payload4)
--- a/lib/arboricx-dispatch.tri
+++ b/lib/arboricx-dispatch.tri
@@ -1,23 +1,6 @@
 !import "arboricx.tri" !Local
-!import "patterns.tri" !Local

 -- Multi-purpose kernel dispatch.
--
 -- runArboricxTyped tag bundleBytes args
--   tag 0 → hostTree   (runArboricxToTree)
--   tag 1 → hostString (runArboricxToString)
--   tag 2 → hostNumber (runArboricxToNumber)
--   tag 3 → hostBool   (runArboricxToBool)
--   tag 4 → hostList   (runArboricxToList)
--   tag 5 → hostBytes  (runArboricxToBytes)
--   otherwise → err 99 bundleBytes
-
 runArboricxTyped = (tag bs args :
-  match tag
-    [[(equal? hostTreeTag)   (_ : runArboricxToTree bs args)]
-     [(equal? hostStringTag) (_ : runArboricxToString bs args)]
-     [(equal? hostNumberTag) (_ : runArboricxToNumber bs args)]
-     [(equal? hostBoolTag)   (_ : runArboricxToBool bs args)]
-     [(equal? hostListTag)   (_ : runArboricxToList bs args)]
-     [(equal? hostBytesTag)  (_ : runArboricxToBytes bs args)]
-     [otherwise              (_ : err 99 bs)]])
+  runArboricxByNameToTyped tag [] bs args)
--- a/lib/arboricx-manifest.tri
+++ b/lib/arboricx-manifest.tri
@@ -29,13 +29,13 @@ readCapabilities_ = y (self bs count i acc :
 readCapabilities = (count bs :
  readCapabilities_ bs count 0 t)

-- Helper: read a single root entry (32-byte raw hash + length-prefixed role)
+-- Helper: read a single root entry (4-byte u32 BE index + length-prefixed role)
 readRootEntry = (bs :
-  bindResult (readBytes 32 bs)
-    (hashRaw afterHash :
-      bindResult (readLengthPrefixedString afterHash)
+  bindResult (readBytes 4 bs)
+    (indexRaw afterIndex :
+      bindResult (readLengthPrefixedString afterIndex)
        (role afterRole :
-          ok (pair hashRaw role) afterRole)))
+          ok (pair indexRaw role) afterRole)))

 -- Helper worker: read N root entries (counts up from 0)
 readRoots_ = y (self bs count i acc :
@@ -54,13 +54,13 @@ readRoots = (count bs :
 readExportEntry = (bs :
  bindResult (readLengthPrefixedString bs)
    (name afterName :
-      bindResult (readBytes 32 afterName)
-        (rootHashRaw afterRootHash :
-          bindResult (readLengthPrefixedString afterRootHash)
+      bindResult (readBytes 4 afterName)
+        (rootIndexRaw afterRootIndex :
+          bindResult (readLengthPrefixedString afterRootIndex)
            (kind afterKind :
              bindResult (readLengthPrefixedString afterKind)
                (abi afterAbi :
-                  ok (pair name (pair rootHashRaw (pair kind abi))) afterAbi)))))
+                  ok (pair name (pair rootIndexRaw (pair kind abi))) afterAbi)))))

 -- Helper worker: read N export entries (counts up from 0)
 readExports_ = y (self bs count i acc :
@@ -200,7 +200,7 @@ lookupMetadata_ = y (self tlvs tag :
 lookupMetadata = (tlvs tag :
  lookupMetadata_ tlvs tag)

-- Get export name from an export entry (pair name (pair rootHash (pair kind abi)))
+-- Get export name from an export entry (pair name (pair rootIndex (pair kind abi)))
 exportName = (exp :
  matchPair
    (name _ : name)
@@ -284,9 +284,9 @@ selectExportOpt = (exports optNameBytes :
 expectedSchema = "arboricx.bundle.manifest.v1"
 expectedBundleType = "tree-calculus-executable-object"
 expectedTreeCalculus = "tree-calculus.v1"
-expectedTreeHashAlgorithm = "sha256"
-expectedTreeHashDomain = "arboricx.merkle.node.v1"
-expectedTreeNodePayload = "arboricx.merkle.payload.v1"
+expectedTreeHashAlgorithm = "indexed"
+expectedTreeHashDomain = "arboricx.indexed.node.v1"
+expectedTreeNodePayload = "arboricx.indexed.payload.v1"
 expectedRuntimeSemantics = "tree-calculus.v1"
 expectedRuntimeEvaluation = "normal-order"
 expectedRuntimeAbi = "arboricx.abi.tree.v1"
--- a/lib/arboricx-nodes.tri
+++ b/lib/arboricx-nodes.tri
@@ -1,37 +1,21 @@
 !import "arboricx-common.tri" !Local

+-- Indexed Arboricx node section reader.
+--
+-- Node records in the indexed format are just length-prefixed payloads:
+--   u32 payloadLength || payload
+-- A payload is one of:
+--   0x00
+--   0x01 || childIndex:u32be
+--   0x02 || leftIndex:u32be || rightIndex:u32be
+-- Child indices must point strictly backward in the node array.
+
 readNodeRecord = (bs :
-  bindResult (readBytes 32 bs)
-    (nodeHash afterNodeHash :
-      bindResult (readBytes 4 afterNodeHash)
-        (payloadLength afterPayloadLength :
-          bindResult (readBytes (u32BEBytesToNat payloadLength) afterPayloadLength)
-            (payload afterPayload :
-              ok
-                (pair nodeHash
-                  (pair payloadLength payload))
-                afterPayload))))
-
-nodeRecordHash = (nodeRecord :
-  matchPair
-    (nodeHash _ : nodeHash)
-    nodeRecord)
-
-nodeRecordPayloadLength = (nodeRecord :
-  matchPair
-    (_ payload :
-      matchPair
-        (payloadLength _ : payloadLength)
-        payload)
-    nodeRecord)
-
-nodeRecordPayload = (nodeRecord :
-  matchPair
-    (_ payload :
-      matchPair
-        (_ nodePayload : nodePayload)
-        payload)
-    nodeRecord)
+  bindResult (readBytes 4 bs)
+    (payloadLength afterPayloadLength :
+      bindResult (readBytes (u32BEBytesToNat payloadLength) afterPayloadLength)
+        (payload afterPayload :
+          ok payload afterPayload)))

 nodePayloadKind = (nodePayload : bytesHead nodePayload)

@@ -42,17 +26,18 @@ nodePayloadHasTag? = (tag nodePayload :
    (_ _ : false)
    (nodePayloadKind nodePayload))

-nodePayloadLeaf? = (nodePayload : bytesEq? [(0)] nodePayload)
+nodePayloadLeaf? = (nodePayload :
+  bytesEq? [(0)] nodePayload)

 nodePayloadStem? = (nodePayload :
  and?
    (nodePayloadHasTag? nodePayloadStemTag nodePayload)
-    (equal? (bytesLength nodePayload) 33))
+    (equal? (bytesLength nodePayload) 5))

 nodePayloadFork? = (nodePayload :
  and?
    (nodePayloadHasTag? nodePayloadForkTag nodePayload)
-    (equal? (bytesLength nodePayload) 65))
+    (equal? (bytesLength nodePayload) 9))

 nodePayloadValid? = (nodePayload :
  or?
@@ -61,96 +46,87 @@ nodePayloadValid? = (nodePayload :
      (nodePayloadStem? nodePayload)
      (nodePayloadFork? nodePayload)))

-nodePayloadStemChildHash = (nodePayload : bytesTake 32 (bytesDrop 1 nodePayload))
-nodePayloadForkLeftHash = (nodePayload : bytesTake 32 (bytesDrop 1 nodePayload))
-nodePayloadForkRightHash = (nodePayload : bytesTake 32 (bytesDrop 33 nodePayload))
+nodePayloadStemChildIndex = (nodePayload :
+  u32BEBytesToNat (bytesTake 4 (bytesDrop 1 nodePayload)))

-nodeRecordPayloadValid? = (nodeRecord : nodePayloadValid? (nodeRecordPayload nodeRecord))
+nodePayloadForkLeftIndex = (nodePayload :
+  u32BEBytesToNat (bytesTake 4 (bytesDrop 1 nodePayload)))
+
+nodePayloadForkRightIndex = (nodePayload :
+  u32BEBytesToNat (bytesTake 4 (bytesDrop 5 nodePayload)))

 nodeRecordsHaveInvalidPayload? = y (self nodeRecords :
  matchList
    false
-    (nodeRecord rest :
+    (nodePayload rest :
      or?
-        (not? (nodeRecordPayloadValid? nodeRecord))
+        (not? (nodePayloadValid? nodePayload))
        (self rest))
    nodeRecords)

-nodeRecordsHaveHash? = y (self nodeRecords nodeHash :
-  matchList
-    false
-    (nodeRecord rest :
-      or?
-        (bytesEq? nodeHash (nodeRecordHash nodeRecord))
-        (self rest nodeHash))
-    nodeRecords)
+nodePayloadChildIndices = (nodePayload :
+  matchBool
+    t
+    (matchBool
+      (pair (nodePayloadStemChildIndex nodePayload) t)
+      (pair (nodePayloadForkLeftIndex nodePayload)
+        (pair (nodePayloadForkRightIndex nodePayload) t))
+      (nodePayloadStem? nodePayload))
+    (nodePayloadLeaf? nodePayload))

-nodeRecordsHaveDuplicateHashes? = y (self nodeRecords :
-  matchList
+-- True iff index n names an element before limit in records.
+-- For topologically sorted indexed bundles, every child of record i must
+-- satisfy childIndex < i, so searching only the prefix [0, i) validates both
+-- bounds and acyclicity.
+nodeIndexInPrefix? = y (self n records i limit :
+  matchBool
    false
-    (nodeRecord rest :
-      or?
-        (nodeRecordsHaveHash? rest (nodeRecordHash nodeRecord))
-        (self rest))
-    nodeRecords)
+    (matchList
+      false
+      (_ rest :
+        matchBool
+          true
+          (self n rest (succ i) limit)
+          (equal? i n))
+      records)
+    (equal? i limit))

-lookupNodeRecord_ = y (self nodeRecords nodeHash :
+nodeChildIndicesInPrefix? = y (self childIndices records limit :
  matchList
-    nothing
-    (nodeRecord rest :
+    true
+    (childIndex rest :
      matchBool
-        (just nodeRecord)
-        (self rest nodeHash)
-        (bytesEq? nodeHash (nodeRecordHash nodeRecord)))
-    nodeRecords)
+        (self rest records limit)
+        false
+        (nodeIndexInPrefix? childIndex records 0 limit))
+    childIndices)

-lookupNodeRecord = (nodeHash nodeRecords : lookupNodeRecord_ nodeRecords nodeHash)
+nodePayloadIndicesValid? = (nodePayload i records :
+  nodeChildIndicesInPrefix?
+    (nodePayloadChildIndices nodePayload)
+    records
+    i)

-nodeRecordChildHashes = (nodeRecord :
-  (nodePayload :
-    matchBool
-      t
-      (matchBool
-        (pair (nodePayloadStemChildHash nodePayload) t)
-        (pair (nodePayloadForkLeftHash nodePayload)
-          (pair (nodePayloadForkRightHash nodePayload) t))
-        (nodePayloadStem? nodePayload))
-      (nodePayloadLeaf? nodePayload))
-    (nodeRecordPayload nodeRecord))
-
-nodeHashPresent? = (nodeHash nodeRecords : nodeRecordsHaveHash? nodeRecords nodeHash)
-
-nodeChildHashesPresent? = y (self childHashes nodeRecords :
+nodeRecordsValidIndicesFrom? = y (self allRecords remainingRecords i :
  matchList
    true
-    (childHash rest :
-      and?
-        (nodeHashPresent? childHash nodeRecords)
-        (self rest nodeRecords))
-    childHashes)
+    (nodePayload rest :
+      matchBool
+        (self allRecords rest (succ i))
+        false
+        (nodePayloadIndicesValid? nodePayload i allRecords))
+    remainingRecords)

-nodeRecordChildrenPresent? = (nodeRecord nodeRecords :
-  nodeChildHashesPresent? (nodeRecordChildHashes nodeRecord) nodeRecords)
-
-nodeRecordsClosed? = y (self nodeRecords allNodeRecords :
-  matchList
-    true
-    (nodeRecord rest :
-      and?
-        (nodeRecordChildrenPresent? nodeRecord allNodeRecords)
-        (self rest allNodeRecords))
-    nodeRecords)
+nodeRecordsValidIndices? = (nodeRecords i :
+  nodeRecordsValidIndicesFrom? nodeRecords nodeRecords i)

 validateNodeRecords = (nodeRecords rest :
  matchBool
    (err errInvalidNodePayload rest)
    (matchBool
-      (err errDuplicateNode rest)
-      (matchBool
-        (ok nodeRecords rest)
-        (err errMissingNode rest)
-        (nodeRecordsClosed? nodeRecords nodeRecords))
-      (nodeRecordsHaveDuplicateHashes? nodeRecords))
+      (ok nodeRecords rest)
+      (err errMissingNode rest)
+      (nodeRecordsValidIndices? nodeRecords 0))
    (nodeRecordsHaveInvalidPayload? nodeRecords))

 readNodeRecords_ = y (self bs nodeCount i acc :
@@ -161,7 +137,8 @@ readNodeRecords_ = y (self bs nodeCount i acc :
        self afterNodeRecord nodeCount (succ i) (pair nodeRecord acc)))
    (equal? i nodeCount))

-readNodeRecords = (nodeCount bs : readNodeRecords_ bs nodeCount 0 t)
+readNodeRecords = (nodeCount bs :
+  readNodeRecords_ bs nodeCount 0 t)

 readNodesSection = (bs :
  bindResult (readBytes 8 bs)
@@ -201,32 +178,31 @@ nodesSectionRecords = (nodesSection :
    (_ nodeRecords : nodeRecords)
    nodesSection)

-nodeRecordToTreeWith = (self nodeRecords nodeRecord :
+nodePayloadToTreeWith = (self nodeRecords nodePayload :
+  matchBool
+    (ok t t)
+    (matchBool
+      (bindResult (self (nodePayloadStemChildIndex nodePayload) nodeRecords)
+        (child _ : ok (t child) t))
+      (bindResult (self (nodePayloadForkLeftIndex nodePayload) nodeRecords)
+        (left _ :
+          bindResult (self (nodePayloadForkRightIndex nodePayload) nodeRecords)
+            (right _ : ok (pair left right) t)))
+      (nodePayloadStem? nodePayload))
+    (nodePayloadLeaf? nodePayload))
+
+nodeIndexToTree = y (self nodeIndex nodeRecords :
  (nodePayload :
    matchBool
-      (ok t t)
-      (matchBool
-        (bindResult (self (nodePayloadStemChildHash nodePayload) nodeRecords)
-          (child _ : ok (t child) t))
-        (bindResult (self (nodePayloadForkLeftHash nodePayload) nodeRecords)
-          (left _ :
-            bindResult (self (nodePayloadForkRightHash nodePayload) nodeRecords)
-              (right _ : ok (pair left right) t)))
-        (nodePayloadStem? nodePayload))
-      (nodePayloadLeaf? nodePayload))
-    (nodeRecordPayload nodeRecord))
+      (nodePayloadToTreeWith self nodeRecords nodePayload)
+      (err errMissingNode t)
+      (not? (equal? nodePayload t)))
+    (nth nodeIndex nodeRecords))

-nodeHashToTree = y (self nodeHash nodeRecords :
-  triage
-    (err errMissingNode t)
-    (nodeRecord : nodeRecordToTreeWith self nodeRecords nodeRecord)
-    (_ _ : err errMissingNode t)
-    (lookupNodeRecord nodeHash nodeRecords))
-
-readArboricxTreeFromHash = (rootHash bs :
+readArboricxTreeFromIndex = (rootIndexBytes bs :
  bindResult (readArboricxNodesSection bs)
    (nodesSection afterContainer :
-      bindResult (nodeHashToTree rootHash (nodesSectionRecords nodesSection))
+      bindResult (nodeIndexToTree (u32BEBytesToNat rootIndexBytes) (nodesSectionRecords nodesSection))
        (tree _ : ok tree afterContainer)))

-readArboricxExecutableFromHash = readArboricxTreeFromHash
+readArboricxExecutableFromIndex = readArboricxTreeFromIndex
--- a/lib/arboricx.tri
+++ b/lib/arboricx.tri
@@ -26,7 +26,7 @@ readArboricxExecutableByName = (nameBytes bs :
        (validCore _ :
          bindResult (selectExport (manifestExports validCore) nameBytes)
            (selectedExport _ :
-              readArboricxTreeFromHash (exportRoot selectedExport) bs))
+              readArboricxTreeFromIndex (exportRoot selectedExport) bs))
        bundleResult))

 readArboricxExecutable = (bs :
@@ -104,33 +104,52 @@ wrapHostValue = (validator wrapper resultValue rest :
    (err errHostCodecFailed resultValue)
    (validator resultValue))

-runArboricxByNameToTree = (nameBytes bs args :
+wrapHostValueByTag = (tag value rest :
+  matchBool
+    (ok (hostTree value) rest)
+    (matchBool
+      (wrapHostValue hostString? hostString value rest)
+      (matchBool
+        (wrapHostValue hostNumber? hostNumber value rest)
+        (matchBool
+          (wrapHostValue hostBool? hostBool value rest)
+          (matchBool
+            (wrapHostValue hostList? hostList value rest)
+            (matchBool
+              (wrapHostValue hostBytes? hostBytes value rest)
+              (err errHostCodecFailed value)
+              (equal? tag hostBytesTag))
+            (equal? tag hostListTag))
+          (equal? tag hostBoolTag))
+        (equal? tag hostNumberTag))
+      (equal? tag hostStringTag))
+    (equal? tag hostTreeTag))
+
+runArboricxByNameToTyped = (tag nameBytes bs args :
  bindResult (runArboricxArgsByName nameBytes bs args)
-    (value rest : ok (hostTree value) rest))
+    (value rest : wrapHostValueByTag tag value rest))
+
+runArboricxByNameToTree = (nameBytes bs args :
+  runArboricxByNameToTyped hostTreeTag nameBytes bs args)

 runArboricxByNameToString = (nameBytes bs args :
-  bindResult (runArboricxArgsByName nameBytes bs args)
-    (value rest : wrapHostValue hostString? hostString value rest))
+  runArboricxByNameToTyped hostStringTag nameBytes bs args)

 runArboricxByNameToNumber = (nameBytes bs args :
-  bindResult (runArboricxArgsByName nameBytes bs args)
-    (value rest : wrapHostValue hostNumber? hostNumber value rest))
+  runArboricxByNameToTyped hostNumberTag nameBytes bs args)

 runArboricxByNameToBool = (nameBytes bs args :
-  bindResult (runArboricxArgsByName nameBytes bs args)
-    (value rest : wrapHostValue hostBool? hostBool value rest))
+  runArboricxByNameToTyped hostBoolTag nameBytes bs args)

 runArboricxByNameToList = (nameBytes bs args :
-  bindResult (runArboricxArgsByName nameBytes bs args)
-    (value rest : wrapHostValue hostList? hostList value rest))
+  runArboricxByNameToTyped hostListTag nameBytes bs args)

 runArboricxByNameToBytes = (nameBytes bs args :
-  bindResult (runArboricxArgsByName nameBytes bs args)
-    (value rest : wrapHostValue hostBytes? hostBytes value rest))
+  runArboricxByNameToTyped hostBytesTag nameBytes bs args)

-runArboricxToTree = (bs args : runArboricxByNameToTree [] bs args)
-runArboricxToString = (bs args : runArboricxByNameToString [] bs args)
-runArboricxToNumber = (bs args : runArboricxByNameToNumber [] bs args)
-runArboricxToBool = (bs args : runArboricxByNameToBool [] bs args)
-runArboricxToList = (bs args : runArboricxByNameToList [] bs args)
-runArboricxToBytes = (bs args : runArboricxByNameToBytes [] bs args)
+runArboricxToTree = (bs args : runArboricxByNameToTyped hostTreeTag [] bs args)
+runArboricxToString = (bs args : runArboricxByNameToTyped hostStringTag [] bs args)
+runArboricxToNumber = (bs args : runArboricxByNameToTyped hostNumberTag [] bs args)
+runArboricxToBool = (bs args : runArboricxByNameToTyped hostBoolTag [] bs args)
+runArboricxToList = (bs args : runArboricxByNameToTyped hostListTag [] bs args)
+runArboricxToBytes = (bs args : runArboricxByNameToTyped hostBytesTag [] bs args)
--- a/lib/list.tri
+++ b/lib/list.tri
@@ -68,3 +68,15 @@ any? = y (self pred : matchList
  (h z : or? (pred h) (self pred z)))

 intersect = xs ys : filter (x : lExist? x ys) xs
+
+nth_ = y (self n xs i :
+  matchList
+    t
+    (h r :
+      matchBool
+        h
+        (self n r (succ i))
+        (equal? i n))
+    xs)
+
+nth = n xs : nth_ n xs 0