commit 9974d38f5b097410c7c5415e57b2301349cb0872
parent 693b42b8545855fc153b50045e183ddd17d6335e
Author: James Eversole <james@eversole.co>
Date: Thu, 7 May 2026 14:21:24 -0500
Add Arborix bundle parsing and reconstruction
Diffstat:
11 files changed, 1179 insertions(+), 91 deletions(-)
diff --git a/lib/arborix.tri b/lib/arborix.tri
@@ -4,6 +4,21 @@
!import "binary.tri" !Local
arborixMagic = [(65) (82) (66) (79) (82) (73) (88) (0)]
+arborixMajorVersion = [(0) (1)]
+arborixMinorVersion = [(0) (0)]
+arborixManifestSectionId = [(0) (0) (0) (1)]
+arborixNodesSectionId = [(0) (0) (0) (2)]
+
+errMissingSection = 4
+errUnsupportedVersion = 5
+errDuplicateSection = 6
+errDuplicateNode = 7
+errInvalidNodePayload = 8
+errMissingNode = 9
+
+nodePayloadLeafTag = 0
+nodePayloadStemTag = 1
+nodePayloadForkTag = 2
readArborixMagic = (bs : expectBytes arborixMagic bs)
@@ -16,43 +31,126 @@ readArborixHeader = (bs :
(minorVersion afterMinor :
bindResult (readBytes 4 afterMinor)
(sectionCount afterSectionCount :
- ok
- (pair majorVersion
- (pair minorVersion sectionCount))
- afterSectionCount)))))
+ bindResult (readBytes 8 afterSectionCount)
+ (flags afterFlags :
+ bindResult (readBytes 8 afterFlags)
+ (dirOffset afterDirOffset :
+ ok
+ (pair majorVersion
+ (pair minorVersion
+ (pair sectionCount
+ (pair flags dirOffset))))
+ afterDirOffset)))))))
readSectionRecord = (bs :
- bindResult (readBytes 2 bs)
+ bindResult (readBytes 4 bs)
(sectionId afterSectionId :
- bindResult (readBytes 4 afterSectionId)
- (offset afterOffset :
- bindResult (readBytes 4 afterOffset)
- (length afterLength :
- ok
- (pair sectionId
- (pair offset length))
- afterLength))))
+ bindResult (readBytes 2 afterSectionId)
+ (sectionVersion afterSectionVersion :
+ bindResult (readBytes 2 afterSectionVersion)
+ (sectionFlags afterSectionFlags :
+ bindResult (readBytes 2 afterSectionFlags)
+ (compression afterCompression :
+ bindResult (readBytes 2 afterCompression)
+ (digestAlgorithm afterDigestAlgorithm :
+ bindResult (readBytes 8 afterDigestAlgorithm)
+ (offset afterOffset :
+ bindResult (readBytes 8 afterOffset)
+ (length afterLength :
+ bindResult (readBytes 32 afterLength)
+ (digest afterDigest :
+ ok
+ (pair sectionId
+ (pair sectionVersion
+ (pair sectionFlags
+ (pair compression
+ (pair digestAlgorithm
+ (pair offset
+ (pair length digest)))))))
+ afterDigest)))))))))
-readSectionDirectory_ = y (self sectionCount i bs acc :
+readSectionDirectory_ = y (self bs sectionCount i acc :
matchBool
(ok (reverse acc) bs)
(bindResult (readSectionRecord bs)
(sectionRecord afterSectionRecord :
- self sectionCount (succ i) afterSectionRecord (pair sectionRecord acc)))
+ self afterSectionRecord sectionCount (succ i) (pair sectionRecord acc)))
(equal? i sectionCount))
-readSectionDirectory = (sectionCount bs : readSectionDirectory_ sectionCount 0 bs t)
+readSectionDirectory = (sectionCount bs : readSectionDirectory_ bs sectionCount 0 t)
sectionRecordId = (sectionRecord :
matchPair
(sectionId _ : sectionId)
sectionRecord)
+sectionRecordVersion = (sectionRecord :
+ matchPair
+ (_ payload :
+ matchPair
+ (sectionVersion _ : sectionVersion)
+ payload)
+ sectionRecord)
+
+sectionRecordFlags = (sectionRecord :
+ matchPair
+ (_ payload :
+ matchPair
+ (_ payload2 :
+ matchPair
+ (sectionFlags _ : sectionFlags)
+ payload2)
+ payload)
+ sectionRecord)
+
+sectionRecordCompression = (sectionRecord :
+ matchPair
+ (_ payload :
+ matchPair
+ (_ payload2 :
+ matchPair
+ (_ payload3 :
+ matchPair
+ (compression _ : compression)
+ payload3)
+ payload2)
+ payload)
+ sectionRecord)
+
+sectionRecordDigestAlgorithm = (sectionRecord :
+ matchPair
+ (_ payload :
+ matchPair
+ (_ payload2 :
+ matchPair
+ (_ payload3 :
+ matchPair
+ (_ payload4 :
+ matchPair
+ (digestAlgorithm _ : digestAlgorithm)
+ payload4)
+ payload3)
+ payload2)
+ payload)
+ sectionRecord)
+
sectionRecordOffset = (sectionRecord :
matchPair
(_ payload :
matchPair
- (offset _ : offset)
+ (_ payload2 :
+ matchPair
+ (_ payload3 :
+ matchPair
+ (_ payload4 :
+ matchPair
+ (_ payload5 :
+ matchPair
+ (offset _ : offset)
+ payload5)
+ payload4)
+ payload3)
+ payload2)
payload)
sectionRecord)
@@ -60,18 +158,497 @@ sectionRecordLength = (sectionRecord :
matchPair
(_ payload :
matchPair
- (_ length : length)
+ (_ payload2 :
+ matchPair
+ (_ payload3 :
+ matchPair
+ (_ payload4 :
+ matchPair
+ (_ payload5 :
+ matchPair
+ (_ payload6 :
+ matchPair
+ (length _ : length)
+ payload6)
+ payload5)
+ payload4)
+ payload3)
+ payload2)
payload)
sectionRecord)
-lookupSectionRecord = y (self sectionId directory :
+sectionRecordDigest = (sectionRecord :
+ matchPair
+ (_ payload :
+ matchPair
+ (_ payload2 :
+ matchPair
+ (_ payload3 :
+ matchPair
+ (_ payload4 :
+ matchPair
+ (_ payload5 :
+ matchPair
+ (_ payload6 :
+ matchPair
+ (_ digest : digest)
+ payload6)
+ payload5)
+ payload4)
+ payload3)
+ payload2)
+ payload)
+ sectionRecord)
+
+lookupSectionRecord_ = y (self directory sectionId :
matchList
nothing
(sectionRecord rest :
matchBool
(just sectionRecord)
- (self sectionId rest)
+ (self rest sectionId)
(bytesEq? sectionId (sectionRecordId sectionRecord)))
directory)
+lookupSectionRecord = (sectionId directory : lookupSectionRecord_ directory sectionId)
+
+sectionDirectoryHasId?_ = y (self directory sectionId :
+ matchList
+ false
+ (sectionRecord rest :
+ or?
+ (bytesEq? sectionId (sectionRecordId sectionRecord))
+ (self rest sectionId))
+ directory)
+
+sectionDirectoryHasId? = (sectionId directory : sectionDirectoryHasId?_ directory sectionId)
+
+sectionDirectoryHasDuplicateIds? = y (self directory :
+ matchList
+ false
+ (sectionRecord rest :
+ or?
+ (sectionDirectoryHasId?_ rest (sectionRecordId sectionRecord))
+ (self rest))
+ directory)
+
+validateSectionDirectory = (directory rest :
+ matchBool
+ (err errDuplicateSection rest)
+ (ok directory rest)
+ (sectionDirectoryHasDuplicateIds? directory))
+
byteSlice = (offset length bytes : bytesTake length (bytesDrop offset bytes))
+
+natMake = (bit rest :
+ matchBool
+ 0
+ (pair bit rest)
+ (and? (equal? bit 0) (equal? rest 0)))
+
+natAdd = y (self a b :
+ triage
+ b
+ (_ : b)
+ (aBit aRest :
+ triage
+ a
+ (_ : a)
+ (bBit bRest :
+ matchBool
+ (natMake 0 (succ (self aRest bRest)))
+ (natMake (matchBool (matchBool 0 1 bBit) (matchBool 1 0 bBit) aBit)
+ (self aRest bRest))
+ (and? (equal? aBit 1) (equal? bBit 1)))
+ b)
+ a)
+
+natDouble = (n : matchBool 0 (pair 0 n) (equal? n 0))
+
+natTimes256 = (n :
+ natDouble
+ (natDouble
+ (natDouble
+ (natDouble
+ (natDouble
+ (natDouble
+ (natDouble
+ (natDouble n))))))))
+
+byteNatShiftAppend_ = y (self byte acc i :
+ matchBool
+ acc
+ (triage
+ (natMake 0 (self 0 acc (succ i)))
+ (_ : acc)
+ (bit rest : natMake bit (self rest acc (succ i)))
+ byte)
+ (equal? i 8))
+
+byteNatShiftAppend = (byte acc : byteNatShiftAppend_ byte acc 0)
+
+beBytesToNat = (bytes :
+ foldl
+ (acc byte : byteNatShiftAppend byte acc)
+ 0
+ bytes)
+
+u32BEBytesToNat = beBytesToNat
+u64BEBytesToNat = beBytesToNat
+
+arborixHeaderMajorVersion = (header :
+ matchPair
+ (majorVersion _ : majorVersion)
+ header)
+
+arborixHeaderMinorVersion = (header :
+ matchPair
+ (_ payload :
+ matchPair
+ (minorVersion _ : minorVersion)
+ payload)
+ header)
+
+arborixHeaderSectionCount = (header :
+ matchPair
+ (_ payload :
+ matchPair
+ (_ payload2 :
+ matchPair
+ (sectionCount _ : sectionCount)
+ payload2)
+ payload)
+ header)
+
+arborixHeaderFlags = (header :
+ matchPair
+ (_ payload :
+ matchPair
+ (_ payload2 :
+ matchPair
+ (_ payload3 :
+ matchPair
+ (flags _ : flags)
+ payload3)
+ payload2)
+ payload)
+ header)
+
+arborixHeaderDirOffset = (header :
+ matchPair
+ (_ payload :
+ matchPair
+ (_ payload2 :
+ matchPair
+ (_ payload3 :
+ matchPair
+ (_ dirOffset : dirOffset)
+ payload3)
+ payload2)
+ payload)
+ header)
+
+validateArborixHeader = (header rest :
+ matchBool
+ (ok header rest)
+ (err errUnsupportedVersion rest)
+ (and?
+ (bytesEq? arborixMajorVersion (arborixHeaderMajorVersion header))
+ (bytesEq? arborixMinorVersion (arborixHeaderMinorVersion header))))
+
+readArborixContainer = (bs :
+ bindResult (readArborixHeader bs)
+ (header afterHeader :
+ bindResult (validateArborixHeader header afterHeader)
+ (validHeader afterValidHeader :
+ bindResult (readSectionDirectory
+ (u32BEBytesToNat (arborixHeaderSectionCount validHeader))
+ (bytesDrop (u64BEBytesToNat (arborixHeaderDirOffset validHeader)) bs))
+ (directory afterDirectory :
+ bindResult (validateSectionDirectory directory afterDirectory)
+ (validDirectory afterValidDirectory :
+ ok (pair validHeader validDirectory) afterValidDirectory)))))
+
+sectionRecordOffsetNat = (sectionRecord :
+ u64BEBytesToNat (sectionRecordOffset sectionRecord))
+
+sectionRecordLengthNat = (sectionRecord :
+ u64BEBytesToNat (sectionRecordLength sectionRecord))
+
+extractSectionBytes = (sectionRecord containerBytes :
+ byteSlice
+ (sectionRecordOffsetNat sectionRecord)
+ (sectionRecordLengthNat sectionRecord)
+ containerBytes)
+
+extractSectionBytesResult = (sectionRecord containerBytes rest :
+ (sectionBytes :
+ matchBool
+ (ok sectionBytes rest)
+ (err errUnexpectedEof rest)
+ (equal? (bytesLength sectionBytes) (sectionRecordLengthNat sectionRecord)))
+ (extractSectionBytes sectionRecord containerBytes))
+
+lookupSectionBytes = (sectionId directory containerBytes :
+ triage
+ nothing
+ (sectionRecord : just (extractSectionBytes sectionRecord containerBytes))
+ (_ _ : nothing)
+ (lookupSectionRecord sectionId directory))
+
+sectionBytesOrErr = (sectionId directory containerBytes rest :
+ triage
+ (err errMissingSection rest)
+ (sectionRecord : extractSectionBytesResult sectionRecord containerBytes rest)
+ (_ _ : err errMissingSection rest)
+ (lookupSectionRecord sectionId directory))
+
+readArborixSectionBytes = (sectionId bs :
+ bindResult (readArborixContainer bs)
+ (container afterContainer :
+ matchPair
+ (_ directory : sectionBytesOrErr sectionId directory bs afterContainer)
+ container))
+
+readArborixRequiredSections = (bs :
+ bindResult (readArborixContainer bs)
+ (container afterContainer :
+ matchPair
+ (_ directory :
+ bindResult (sectionBytesOrErr arborixManifestSectionId directory bs afterContainer)
+ (manifestBytes _ :
+ bindResult (sectionBytesOrErr arborixNodesSectionId directory bs afterContainer)
+ (nodesBytes _ :
+ ok (pair manifestBytes nodesBytes) afterContainer)))
+ container))
+
+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)
+
+nodePayloadKind = (nodePayload : bytesHead nodePayload)
+
+nodePayloadHasTag? = (tag nodePayload :
+ triage
+ false
+ (actualTag : byteEq? actualTag tag)
+ (_ _ : false)
+ (nodePayloadKind nodePayload))
+
+nodePayloadLeaf? = (nodePayload : bytesEq? [(0)] nodePayload)
+
+nodePayloadStem? = (nodePayload :
+ and?
+ (nodePayloadHasTag? nodePayloadStemTag nodePayload)
+ (equal? (bytesLength nodePayload) 33))
+
+nodePayloadFork? = (nodePayload :
+ and?
+ (nodePayloadHasTag? nodePayloadForkTag nodePayload)
+ (equal? (bytesLength nodePayload) 65))
+
+nodePayloadValid? = (nodePayload :
+ or?
+ (nodePayloadLeaf? nodePayload)
+ (or?
+ (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))
+
+nodeRecordPayloadValid? = (nodeRecord : nodePayloadValid? (nodeRecordPayload nodeRecord))
+
+nodeRecordsHaveInvalidPayload? = y (self nodeRecords :
+ matchList
+ false
+ (nodeRecord rest :
+ or?
+ (not? (nodeRecordPayloadValid? nodeRecord))
+ (self rest))
+ nodeRecords)
+
+nodeRecordsHaveHash? = y (self nodeRecords nodeHash :
+ matchList
+ false
+ (nodeRecord rest :
+ or?
+ (bytesEq? nodeHash (nodeRecordHash nodeRecord))
+ (self rest nodeHash))
+ nodeRecords)
+
+nodeRecordsHaveDuplicateHashes? = y (self nodeRecords :
+ matchList
+ false
+ (nodeRecord rest :
+ or?
+ (nodeRecordsHaveHash? rest (nodeRecordHash nodeRecord))
+ (self rest))
+ nodeRecords)
+
+lookupNodeRecord_ = y (self nodeRecords nodeHash :
+ matchList
+ nothing
+ (nodeRecord rest :
+ matchBool
+ (just nodeRecord)
+ (self rest nodeHash)
+ (bytesEq? nodeHash (nodeRecordHash nodeRecord)))
+ nodeRecords)
+
+lookupNodeRecord = (nodeHash nodeRecords : lookupNodeRecord_ nodeRecords nodeHash)
+
+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 :
+ matchList
+ true
+ (childHash rest :
+ and?
+ (nodeHashPresent? childHash nodeRecords)
+ (self rest nodeRecords))
+ childHashes)
+
+nodeRecordChildrenPresent? = (nodeRecord nodeRecords :
+ nodeChildHashesPresent? (nodeRecordChildHashes nodeRecord) nodeRecords)
+
+nodeRecordsClosed? = y (self nodeRecords allNodeRecords :
+ matchList
+ true
+ (nodeRecord rest :
+ and?
+ (nodeRecordChildrenPresent? nodeRecord allNodeRecords)
+ (self rest allNodeRecords))
+ nodeRecords)
+
+validateNodeRecords = (nodeRecords rest :
+ matchBool
+ (err errInvalidNodePayload rest)
+ (matchBool
+ (err errDuplicateNode rest)
+ (matchBool
+ (ok nodeRecords rest)
+ (err errMissingNode rest)
+ (nodeRecordsClosed? nodeRecords nodeRecords))
+ (nodeRecordsHaveDuplicateHashes? nodeRecords))
+ (nodeRecordsHaveInvalidPayload? nodeRecords))
+
+readNodeRecords_ = y (self bs nodeCount i acc :
+ matchBool
+ (ok (reverse acc) bs)
+ (bindResult (readNodeRecord bs)
+ (nodeRecord afterNodeRecord :
+ self afterNodeRecord nodeCount (succ i) (pair nodeRecord acc)))
+ (equal? i nodeCount))
+
+readNodeRecords = (nodeCount bs : readNodeRecords_ bs nodeCount 0 t)
+
+readNodesSection = (bs :
+ bindResult (readBytes 8 bs)
+ (nodeCount afterNodeCount :
+ bindResult (readNodeRecords (u64BEBytesToNat nodeCount) afterNodeCount)
+ (nodeRecords afterNodeRecords :
+ bindResult (validateNodeRecords nodeRecords afterNodeRecords)
+ (validNodeRecords afterValidNodeRecords :
+ ok (pair nodeCount validNodeRecords) afterValidNodeRecords))))
+
+readNodesSectionComplete = (bs :
+ bindResult (readNodesSection bs)
+ (nodesSection afterNodesSection :
+ matchBool
+ (ok nodesSection afterNodesSection)
+ (err errUnexpectedBytes afterNodesSection)
+ (bytesNil? afterNodesSection)))
+
+readArborixNodesSection = (bs :
+ bindResult (readArborixContainer bs)
+ (container afterContainer :
+ matchPair
+ (_ directory :
+ bindResult (sectionBytesOrErr arborixNodesSectionId directory bs afterContainer)
+ (nodesBytes _ :
+ bindResult (readNodesSectionComplete nodesBytes)
+ (nodesSection _ : ok nodesSection afterContainer)))
+ container))
+
+nodesSectionCount = (nodesSection :
+ matchPair
+ (nodeCount _ : nodeCount)
+ nodesSection)
+
+nodesSectionRecords = (nodesSection :
+ matchPair
+ (_ nodeRecords : nodeRecords)
+ nodesSection)
+
+nodeRecordToTreeWith = (self nodeRecords nodeRecord :
+ (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))
+
+nodeHashToTree = y (self nodeHash nodeRecords :
+ triage
+ (err errMissingNode t)
+ (nodeRecord : nodeRecordToTreeWith self nodeRecords nodeRecord)
+ (_ _ : err errMissingNode t)
+ (lookupNodeRecord nodeHash nodeRecords))
+
+readArborixTreeFromHash = (rootHash bs :
+ bindResult (readArborixNodesSection bs)
+ (nodesSection afterContainer :
+ bindResult (nodeHashToTree rootHash (nodesSectionRecords nodesSection))
+ (tree _ : ok tree afterContainer)))
+
+readArborixExecutableFromHash = readArborixTreeFromHash
diff --git a/lib/bytes.tri b/lib/bytes.tri
@@ -14,27 +14,29 @@ byteEq? = equal?
bytesLength = length
bytesAppend = append
-bytesTake_ = y (self n i remaining :
- matchBool
+bytesTake_ = y (self remaining n i :
+ matchList
+ t
+ (h r :
+ matchBool
+ t
+ (pair h (self r n (succ i)))
+ (equal? i n))
+ remaining)
+
+bytesTake = n bytes : bytesTake_ bytes n 0
+
+bytesDrop_ = y (self remaining n i :
+ matchList
t
- (matchList
- t
- (h r : pair h (self n (succ i) r))
- remaining)
- (equal? i n))
-
-bytesTake = n bytes : bytesTake_ n 0 bytes
-
-bytesDrop_ = y (self n i remaining :
- matchBool
- remaining
- (matchList
- t
- (_ r : self n (succ i) r)
- remaining)
- (equal? i n))
-
-bytesDrop = n bytes : bytesDrop_ n 0 bytes
+ (_ r :
+ matchBool
+ remaining
+ (self r n (succ i))
+ (equal? i n))
+ remaining)
+
+bytesDrop = n bytes : bytesDrop_ bytes n 0
bytesSplitAt = n bytes : pair (bytesTake n bytes) (bytesDrop n bytes)
diff --git a/lib/list.tri b/lib/list.tri
@@ -27,11 +27,11 @@ filter_ = y (self : matchList
(head tail f : matchBool (t head) id (f head) (self tail f)))
filter = f l : filter_ l f
-foldl_ = y (self f l x : matchList (acc : acc) (head tail acc : self f tail (f acc head)) l x)
-foldl = f x l : foldl_ f l x
+foldl_ = y (self l f x : matchList (acc : acc) (head tail acc : self tail f (f acc head)) l x)
+foldl = f x l : foldl_ l f x
-foldr_ = y (self x f l : matchList x (head tail : f (self x f tail) head) l)
-foldr = f x l : foldr_ x f l
+foldr_ = y (self l f x : matchList x (head tail : f (self tail f x) head) l)
+foldr = f x l : foldr_ l f x
length = y (self : matchList
0
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -12,6 +12,7 @@ import ContentStore
import Control.Exception (evaluate, try, SomeException)
import Control.Monad.IO.Class (liftIO)
import Data.Bits (xor)
+import Data.Char (digitToInt)
import Data.List (isInfixOf)
import Data.Text (Text, unpack)
import Data.Word (Word8)
@@ -1051,6 +1052,104 @@ byteT = ofNumber
bytesT :: [Integer] -> T
bytesT = ofList . fmap byteT
+bytesExpr :: [Integer] -> String
+bytesExpr xs = "[" ++ unwords (map (\n -> "(" ++ show n ++ ")") xs) ++ "]"
+
+u16 :: Integer -> [Integer]
+u16 n = [0,n]
+
+u32 :: Integer -> [Integer]
+u32 n = [0,0,0,n]
+
+u64 :: Integer -> [Integer]
+u64 n = [0,0,0,0,0,0,0,n]
+
+arborixHeaderBytes :: Integer -> [Integer]
+arborixHeaderBytes sectionCount =
+ [65,82,66,79,82,73,88,0]
+ ++ u16 1
+ ++ u16 0
+ ++ u32 sectionCount
+ ++ u64 0
+ ++ u64 32
+
+sectionEntryBytes :: [Integer] -> Integer -> Integer -> [Integer]
+sectionEntryBytes sectionType offset lengthBytes =
+ sectionType
+ ++ u16 1
+ ++ u16 1
+ ++ u16 0
+ ++ u16 1
+ ++ u64 offset
+ ++ u64 lengthBytes
+ ++ replicate 32 0
+
+manifestSectionIdBytes :: [Integer]
+manifestSectionIdBytes = [0,0,0,1]
+
+nodesSectionIdBytes :: [Integer]
+nodesSectionIdBytes = [0,0,0,2]
+
+hexTextBytes :: Text -> [Integer]
+hexTextBytes h = go (unpack h)
+ where
+ go [] = []
+ go (a:b:rest) = toInteger (digitToInt a * 16 + digitToInt b) : go rest
+ go _ = error "odd-length hex text"
+
+manifestEntryBytes :: Integer -> Integer -> [Integer]
+manifestEntryBytes = sectionEntryBytes manifestSectionIdBytes
+
+nodesEntryBytes :: Integer -> Integer -> [Integer]
+nodesEntryBytes = sectionEntryBytes nodesSectionIdBytes
+
+simpleContainerBytes :: [Integer] -> [Integer] -> [Integer]
+simpleContainerBytes manifestBytes nodesBytes =
+ let manifestOffset = 152
+ nodesOffset = manifestOffset + fromIntegral (length manifestBytes)
+ in arborixHeaderBytes 2
+ ++ manifestEntryBytes manifestOffset (fromIntegral $ length manifestBytes)
+ ++ nodesEntryBytes nodesOffset (fromIntegral $ length nodesBytes)
+ ++ manifestBytes
+ ++ nodesBytes
+
+singleSectionContainerBytes :: [Integer] -> [Integer] -> [Integer]
+singleSectionContainerBytes sectionType sectionBytes =
+ arborixHeaderBytes 1
+ ++ sectionEntryBytes sectionType 92 (fromIntegral $ length sectionBytes)
+ ++ sectionBytes
+
+arborixHeaderT :: Integer -> T
+arborixHeaderT sectionCount =
+ pairT (bytesT [0,1])
+ (pairT (bytesT [0,0])
+ (pairT (bytesT $ u32 sectionCount)
+ (pairT (bytesT $ u64 0)
+ (bytesT $ u64 32))))
+
+sectionRecordT :: [Integer] -> Integer -> Integer -> T
+sectionRecordT sectionType offset lengthBytes =
+ pairT (bytesT sectionType)
+ (pairT (bytesT [0,1])
+ (pairT (bytesT [0,1])
+ (pairT (bytesT [0,0])
+ (pairT (bytesT [0,1])
+ (pairT (bytesT $ u64 offset)
+ (pairT (bytesT $ u64 lengthBytes)
+ (bytesT $ replicate 32 0)))))))
+
+sectionRecordExpr :: [Integer] -> Integer -> Integer -> String
+sectionRecordExpr sectionType offset lengthBytes =
+ "(pair " ++ bytesExpr sectionType
+ ++ " (pair " ++ bytesExpr [0,1]
+ ++ " (pair " ++ bytesExpr [0,1]
+ ++ " (pair " ++ bytesExpr [0,0]
+ ++ " (pair " ++ bytesExpr [0,1]
+ ++ " (pair " ++ bytesExpr (u64 offset)
+ ++ " (pair " ++ bytesExpr (u64 lengthBytes)
+ ++ " " ++ bytesExpr (replicate 32 0)
+ ++ ")))))))"
+
byteListUtilities :: TestTree
byteListUtilities = testGroup "Byte List Utility Tests"
[ testCase "isNil: empty list is nil" $ do
@@ -1249,6 +1348,24 @@ unexpectedBytesT = byteT 2
unexpectedByteT :: T
unexpectedByteT = byteT 3
+missingSectionT :: T
+missingSectionT = byteT 4
+
+unsupportedVersionT :: T
+unsupportedVersionT = byteT 5
+
+duplicateSectionT :: T
+duplicateSectionT = byteT 6
+
+duplicateNodeT :: T
+duplicateNodeT = byteT 7
+
+invalidNodePayloadT :: T
+invalidNodePayloadT = byteT 8
+
+missingNodeT :: T
+missingNodeT = byteT 9
+
binaryReaderTests :: TestTree
binaryReaderTests = testGroup "Binary Reader Tests"
[ testCase "readU8: empty input returns err" $ do
@@ -1523,25 +1640,17 @@ binaryReaderTests = testGroup "Binary Reader Tests"
-- Arborix header parsing
-- ------------------------------------------------------------------------
- , testCase "readArborixHeader: parses version and section count" $ do
- let input = "readArborixHeader [(65) (82) (66) (79) (82) (73) (88) (0) (0) (1) (0) (0) (0) (0) (0) (0)]"
+ , testCase "readArborixHeader: parses portable header" $ do
+ let input = "readArborixHeader " ++ bytesExpr (arborixHeaderBytes 0)
library <- evaluateFile "./lib/arborix.tri"
let env = evalTricu library (parseTricu input)
- result env @?= okT
- (pairT (bytesT [0,1])
- (pairT (bytesT [0,0])
- (bytesT [0,0,0,0])))
- (bytesT [])
+ result env @?= okT (arborixHeaderT 0) (bytesT [])
, testCase "readArborixHeader: preserves trailing bytes" $ do
- let input = "readArborixHeader [(65) (82) (66) (79) (82) (73) (88) (0) (0) (1) (0) (0) (0) (0) (0) (0) (9) (8)]"
+ let input = "readArborixHeader " ++ bytesExpr (arborixHeaderBytes 0 ++ [9,8])
library <- evaluateFile "./lib/arborix.tri"
let env = evalTricu library (parseTricu input)
- result env @?= okT
- (pairT (bytesT [0,1])
- (pairT (bytesT [0,0])
- (bytesT [0,0,0,0])))
- (bytesT [9,8])
+ result env @?= okT (arborixHeaderT 0) (bytesT [9,8])
, testCase "readArborixHeader: rejects wrong magic preserving input" $ do
let input = "readArborixHeader [(65) (82) (66) (79) (82) (73) (88) (1) (0) (1)]"
@@ -1559,25 +1668,17 @@ binaryReaderTests = testGroup "Binary Reader Tests"
-- Arborix section directory record parsing
-- ------------------------------------------------------------------------
- , testCase "readSectionRecord: parses raw section id offset and length" $ do
- let input = "readSectionRecord [(0) (2) (0) (0) (0) (16) (0) (0) (0) (32)]"
+ , testCase "readSectionRecord: parses portable section entry" $ do
+ let input = "readSectionRecord " ++ bytesExpr (nodesEntryBytes 16 32)
library <- evaluateFile "./lib/arborix.tri"
let env = evalTricu library (parseTricu input)
- result env @?= okT
- (pairT (bytesT [0,2])
- (pairT (bytesT [0,0,0,16])
- (bytesT [0,0,0,32])))
- (bytesT [])
+ result env @?= okT (sectionRecordT nodesSectionIdBytes 16 32) (bytesT [])
, testCase "readSectionRecord: preserves trailing bytes" $ do
- let input = "readSectionRecord [(0) (2) (0) (0) (0) (16) (0) (0) (0) (32) (9) (8)]"
+ let input = "readSectionRecord " ++ bytesExpr (nodesEntryBytes 16 32 ++ [9,8])
library <- evaluateFile "./lib/arborix.tri"
let env = evalTricu library (parseTricu input)
- result env @?= okT
- (pairT (bytesT [0,2])
- (pairT (bytesT [0,0,0,16])
- (bytesT [0,0,0,32])))
- (bytesT [9,8])
+ result env @?= okT (sectionRecordT nodesSectionIdBytes 16 32) (bytesT [9,8])
, testCase "readSectionRecord: empty input returns EOF" $ do
let input = "readSectionRecord []"
@@ -1591,17 +1692,17 @@ binaryReaderTests = testGroup "Binary Reader Tests"
let env = evalTricu library (parseTricu input)
result env @?= errT eofT (bytesT [0])
- , testCase "readSectionRecord: missing offset returns EOF preserving unread offset bytes" $ do
+ , testCase "readSectionRecord: missing section version returns EOF preserving unread bytes" $ do
let input = "readSectionRecord [(0) (2)]"
library <- evaluateFile "./lib/arborix.tri"
let env = evalTricu library (parseTricu input)
- result env @?= errT eofT (bytesT [])
+ result env @?= errT eofT (bytesT [0,2])
- , testCase "readSectionRecord: short offset returns EOF preserving unread offset bytes" $ do
+ , testCase "readSectionRecord: short section version returns EOF preserving unread bytes" $ do
let input = "readSectionRecord [(0) (2) (0) (0) (0)]"
library <- evaluateFile "./lib/arborix.tri"
let env = evalTricu library (parseTricu input)
- result env @?= errT eofT (bytesT [0,0,0])
+ result env @?= errT eofT (bytesT [0])
, testCase "readSectionRecord: missing length returns EOF preserving unread length bytes" $ do
let input = "readSectionRecord [(0) (2) (0) (0) (0) (16)]"
@@ -1609,11 +1710,11 @@ binaryReaderTests = testGroup "Binary Reader Tests"
let env = evalTricu library (parseTricu input)
result env @?= errT eofT (bytesT [])
- , testCase "readSectionRecord: short length returns EOF preserving unread length bytes" $ do
+ , testCase "readSectionRecord: short section flags returns EOF preserving unread bytes" $ do
let input = "readSectionRecord [(0) (2) (0) (0) (0) (16) (0) (0) (0)]"
library <- evaluateFile "./lib/arborix.tri"
let env = evalTricu library (parseTricu input)
- result env @?= errT eofT (bytesT [0,0,0])
+ result env @?= errT eofT (bytesT [0])
-- ------------------------------------------------------------------------
-- Arborix section directory parsing
@@ -1626,17 +1727,13 @@ binaryReaderTests = testGroup "Binary Reader Tests"
result env @?= okT (ofList []) (bytesT [9,8])
, testCase "readSectionDirectory: reads requested records and preserves trailing bytes" $ do
- let input = "readSectionDirectory 2 [(0) (1) (0) (0) (0) (10) (0) (0) (0) (20) (0) (2) (0) (0) (0) (30) (0) (0) (0) (40) (9)]"
+ let input = "readSectionDirectory 2 " ++ bytesExpr (manifestEntryBytes 10 20 ++ nodesEntryBytes 30 40 ++ [9])
library <- evaluateFile "./lib/arborix.tri"
let env = evalTricu library (parseTricu input)
result env @?= okT
(ofList
- [ pairT (bytesT [0,1])
- (pairT (bytesT [0,0,0,10])
- (bytesT [0,0,0,20]))
- , pairT (bytesT [0,2])
- (pairT (bytesT [0,0,0,30])
- (bytesT [0,0,0,40]))
+ [ sectionRecordT manifestSectionIdBytes 10 20
+ , sectionRecordT nodesSectionIdBytes 30 40
])
(bytesT [9])
@@ -1651,16 +1748,13 @@ binaryReaderTests = testGroup "Binary Reader Tests"
-- ------------------------------------------------------------------------
, testCase "lookupSectionRecord: finds record by raw section id" $ do
- let input = "lookupSectionRecord [(0) (2)] [(pair [(0) (1)] (pair [(0) (0) (0) (10)] [(0) (0) (0) (20)])) (pair [(0) (2)] (pair [(0) (0) (0) (30)] [(0) (0) (0) (40)]))]"
+ let input = "lookupSectionRecord " ++ bytesExpr nodesSectionIdBytes ++ " [(" ++ "pair " ++ bytesExpr manifestSectionIdBytes ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,0] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr (u64 10) ++ " (pair " ++ bytesExpr (u64 20) ++ " " ++ bytesExpr (replicate 32 0) ++ "))))))" ++ ") (" ++ "pair " ++ bytesExpr nodesSectionIdBytes ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,0] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr (u64 30) ++ " (pair " ++ bytesExpr (u64 40) ++ " " ++ bytesExpr (replicate 32 0) ++ "))))))" ++ ")]"
library <- evaluateFile "./lib/arborix.tri"
let env = evalTricu library (parseTricu input)
- result env @?= justT
- (pairT (bytesT [0,2])
- (pairT (bytesT [0,0,0,30])
- (bytesT [0,0,0,40])))
+ result env @?= justT (sectionRecordT nodesSectionIdBytes 30 40)
, testCase "lookupSectionRecord: missing section id returns nothing" $ do
- let input = "lookupSectionRecord [(0) (3)] [(pair [(0) (1)] (pair [(0) (0) (0) (10)] [(0) (0) (0) (20)])) (pair [(0) (2)] (pair [(0) (0) (0) (30)] [(0) (0) (0) (40)]))]"
+ let input = "lookupSectionRecord " ++ bytesExpr [0,0,0,3] ++ " [(" ++ "pair " ++ bytesExpr manifestSectionIdBytes ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,0] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr (u64 10) ++ " (pair " ++ bytesExpr (u64 20) ++ " " ++ bytesExpr (replicate 32 0) ++ "))))))" ++ ") (" ++ "pair " ++ bytesExpr nodesSectionIdBytes ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,0] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr (u64 30) ++ " (pair " ++ bytesExpr (u64 40) ++ " " ++ bytesExpr (replicate 32 0) ++ "))))))" ++ ")]"
library <- evaluateFile "./lib/arborix.tri"
let env = evalTricu library (parseTricu input)
result env @?= nothingT
@@ -1676,4 +1770,421 @@ binaryReaderTests = testGroup "Binary Reader Tests"
library <- evaluateFile "./lib/arborix.tri"
let env = evalTricu library (parseTricu input)
result env @?= bytesT [14,15]
+
+ -- ------------------------------------------------------------------------
+ -- Arborix minimal container parsing foundation
+ -- ------------------------------------------------------------------------
+
+ , testCase "u32BEBytesToNat: decodes zero" $ do
+ let input = "u32BEBytesToNat [(0) (0) (0) (0)]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofNumber 0
+
+ , testCase "u32BEBytesToNat: decodes small section count" $ do
+ let input = "u32BEBytesToNat [(0) (0) (0) (2)]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofNumber 2
+
+ , testCase "u64BEBytesToNat: decodes small node count" $ do
+ let input = "u64BEBytesToNat [(0) (0) (0) (0) (0) (0) (0) (2)]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofNumber 2
+
+ , testCase "u64BEBytesToNat: decodes fixture-scale offset" $ do
+ let input = "u64BEBytesToNat [(0) (0) (0) (0) (0) (0) (3) (214)]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofNumber 982
+
+ , testCase "readArborixContainer: reads header directory and preserves payload" $ do
+ let input = "readArborixContainer " ++ bytesExpr (simpleContainerBytes [101,102,103] [201,202,203,204])
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= okT
+ (pairT
+ (arborixHeaderT 2)
+ (ofList
+ [ sectionRecordT manifestSectionIdBytes 152 3
+ , sectionRecordT nodesSectionIdBytes 155 4
+ ]))
+ (bytesT [101,102,103,201,202,203,204])
+
+ , testCase "readArborixContainer: truncated directory returns EOF" $ do
+ let input = "readArborixContainer " ++ bytesExpr (arborixHeaderBytes 1 ++ [0,0])
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= errT eofT (bytesT [0,0])
+
+ , testCase "readArborixContainer: rejects unsupported major version" $ do
+ let badHeader = [65,82,66,79,82,73,88,0] ++ u16 2 ++ u16 0 ++ u32 0 ++ u64 0 ++ u64 32
+ input = "readArborixContainer " ++ bytesExpr badHeader
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= errT unsupportedVersionT (bytesT [])
+
+ , testCase "readArborixContainer: rejects unsupported minor version" $ do
+ let badHeader = [65,82,66,79,82,73,88,0] ++ u16 1 ++ u16 1 ++ u32 0 ++ u64 0 ++ u64 32
+ input = "readArborixContainer " ++ bytesExpr badHeader
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= errT unsupportedVersionT (bytesT [])
+
+ , testCase "readArborixContainer: rejects duplicate section ids" $ do
+ let input = "readArborixContainer " ++ bytesExpr (arborixHeaderBytes 2 ++ manifestEntryBytes 152 1 ++ manifestEntryBytes 153 1 ++ [9])
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= errT duplicateSectionT (bytesT [9])
+
+ , testCase "extractSectionBytes: uses raw offset and length fields" $ do
+ let input = "extractSectionBytes " ++ sectionRecordExpr nodesSectionIdBytes 3 4 ++ " " ++ bytesExpr [10,11,12,13,14,15,16,17]
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= bytesT [13,14,15,16]
+
+ , testCase "lookupSectionBytes: finds section and extracts raw bytes" $ do
+ let input = "lookupSectionBytes " ++ bytesExpr nodesSectionIdBytes ++ " [" ++ sectionRecordExpr manifestSectionIdBytes 1 2 ++ " " ++ sectionRecordExpr nodesSectionIdBytes 4 3 ++ "] " ++ bytesExpr [10,11,12,13,14,15,16,17]
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= justT (bytesT [14,15,16])
+
+ , testCase "lookupSectionBytes: missing section returns nothing" $ do
+ let input = "lookupSectionBytes " ++ bytesExpr [0,0,0,3] ++ " [" ++ sectionRecordExpr manifestSectionIdBytes 1 2 ++ " " ++ sectionRecordExpr nodesSectionIdBytes 4 3 ++ "] " ++ bytesExpr [10,11,12,13,14,15,16,17]
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= nothingT
+
+ , testCase "extractSectionBytesResult: rejects out-of-bounds section" $ do
+ let input = "extractSectionBytesResult " ++ sectionRecordExpr nodesSectionIdBytes 6 4 ++ " " ++ bytesExpr [10,11,12,13,14,15,16,17] ++ " []"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= errT eofT (bytesT [])
+
+ , testCase "readArborixSectionBytes: extracts requested section from container" $ do
+ let input = "readArborixSectionBytes " ++ bytesExpr nodesSectionIdBytes ++ " " ++ bytesExpr (simpleContainerBytes [101,102,103] [201,202,203,204])
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= okT (bytesT [201,202,203,204]) (bytesT [101,102,103,201,202,203,204])
+
+ , testCase "readArborixSectionBytes: missing section returns missing-section err" $ do
+ let input = "readArborixSectionBytes " ++ bytesExpr nodesSectionIdBytes ++ " " ++ bytesExpr (singleSectionContainerBytes manifestSectionIdBytes [101,102,103])
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= errT missingSectionT (bytesT [101,102,103])
+
+ , testCase "readArborixRequiredSections: extracts manifest and nodes bytes" $ do
+ let input = "readArborixRequiredSections " ++ bytesExpr (simpleContainerBytes [101,102,103] [201,202,203,204])
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= okT
+ (pairT (bytesT [101,102,103]) (bytesT [201,202,203,204]))
+ (bytesT [101,102,103,201,202,203,204])
+
+ , testCase "readArborixRequiredSections: missing nodes section returns missing-section err" $ do
+ let input = "readArborixRequiredSections " ++ bytesExpr (singleSectionContainerBytes manifestSectionIdBytes [101,102,103])
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= errT missingSectionT (bytesT [101,102,103])
+
+ , testCase "readArborixRequiredSections: out-of-bounds section returns EOF" $ do
+ let manifestBytes = [101,102,103]
+ nodesBytes = [201,202,203,204]
+ badContainer = arborixHeaderBytes 2 ++ manifestEntryBytes 152 3 ++ nodesEntryBytes 155 9 ++ manifestBytes ++ nodesBytes
+ input = "readArborixRequiredSections " ++ bytesExpr badContainer
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= errT eofT (bytesT [101,102,103,201,202,203,204])
+
+ -- ------------------------------------------------------------------------
+ -- Arborix raw nodes section parsing
+ -- ------------------------------------------------------------------------
+
+ , testCase "readNodeRecord: parses hash length and raw payload" $ do
+ let input = "readNodeRecord [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (3) (101) (102) (103) (9)]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= okT
+ (pairT (bytesT [1..32])
+ (pairT (bytesT [0,0,0,3])
+ (bytesT [101,102,103])))
+ (bytesT [9])
+
+ , testCase "readNodeRecord: truncated payload returns EOF preserving unread payload" $ do
+ let input = "readNodeRecord [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (3) (101) (102)]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= errT eofT (bytesT [101,102])
+
+ , testCase "readNodesSection: parses node count and records" $ do
+ let input = "readNodesSection [(0) (0) (0) (0) (0) (0) (0) (1) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (1) (0) (9)]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= okT
+ (pairT (bytesT [0,0,0,0,0,0,0,1])
+ (ofList
+ [ pairT (bytesT [1..32])
+ (pairT (bytesT [0,0,0,1])
+ (bytesT [0]))
+ ]))
+ (bytesT [9])
+
+ , testCase "readNodesSectionComplete: rejects trailing bytes inside nodes section" $ do
+ let input = "readNodesSectionComplete [(0) (0) (0) (0) (0) (0) (0) (0) (9)]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= errT unexpectedBytesT (bytesT [9])
+
+ , testCase "readNodesSection: rejects duplicate node hashes" $ do
+ let input = "readNodesSection [(0) (0) (0) (0) (0) (0) (0) (2) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (1) (0) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (1) (0) (9)]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= errT duplicateNodeT (bytesT [9])
+
+ , testCase "nodePayloadValid?: accepts leaf stem and fork payload shapes" $ do
+ let input = "[(nodePayloadValid? [(0)]) (nodePayloadValid? [(1) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)]) (nodePayloadValid? [(2) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)])]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofList [trueT, trueT, trueT]
+
+ , testCase "nodePayloadValid?: rejects invalid payload shapes" $ do
+ let input = "[(nodePayloadValid? []) (nodePayloadValid? [(9)]) (nodePayloadValid? [(1) (1)]) (nodePayloadValid? [(2) (1) (2)])]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofList [falseT, falseT, falseT, falseT]
+
+ , testCase "node payload child accessors expose raw hashes" $ do
+ let input = "[(nodePayloadStemChildHash [(1) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)]) (nodePayloadForkLeftHash [(2) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)]) (nodePayloadForkRightHash [(2) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)])]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofList [bytesT [1..32], bytesT [1..32], bytesT [33..64]]
+
+ , testCase "lookupNodeRecord: finds record by raw node hash" $ do
+ let input = "lookupNodeRecord [(33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)] [(pair [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] (pair [(0) (0) (0) (1)] [(0)])) (pair [(33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)] (pair [(0) (0) (0) (1)] [(0)]))]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= justT
+ (pairT (bytesT [33..64])
+ (pairT (bytesT [0,0,0,1])
+ (bytesT [0])))
+
+ , testCase "nodeRecordChildHashes: extracts stem and fork references" $ do
+ let input = "[(nodeRecordChildHashes (pair [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] (pair [(0) (0) (0) (33)] [(1) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)]))) (nodeRecordChildHashes (pair [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] (pair [(0) (0) (0) (65)] [(2) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64) (65) (66) (67) (68) (69) (70) (71) (72) (73) (74) (75) (76) (77) (78) (79) (80) (81) (82) (83) (84) (85) (86) (87) (88) (89) (90) (91) (92) (93) (94) (95) (96)])))]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofList
+ [ ofList [bytesT [33..64]]
+ , ofList [bytesT [33..64], bytesT [65..96]]
+ ]
+
+ , testCase "readNodesSection: rejects invalid node payload shape" $ do
+ let input = "readNodesSection [(0) (0) (0) (0) (0) (0) (0) (1) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (1) (9)]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= errT invalidNodePayloadT (bytesT [])
+
+ , testCase "readNodesSection: rejects missing child node" $ do
+ let input = "readNodesSection [(0) (0) (0) (0) (0) (0) (0) (1) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (33) (1) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64) (9)]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= errT missingNodeT (bytesT [9])
+
+ , testCase "readArborixNodesSection: extracts and parses raw nodes section" $ do
+ let nodesBytes = u64 1 ++ [1..32] ++ u32 1 ++ [0]
+ input = "readArborixNodesSection " ++ bytesExpr (simpleContainerBytes [101,102,103] nodesBytes)
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= okT
+ (pairT (bytesT [0,0,0,0,0,0,0,1])
+ (ofList
+ [ pairT (bytesT [1..32])
+ (pairT (bytesT [0,0,0,1])
+ (bytesT [0]))
+ ]))
+ (bytesT ([101,102,103] ++ nodesBytes))
+
+ -- ------------------------------------------------------------------------
+ -- Arborix node DAG reconstruction
+ -- ------------------------------------------------------------------------
+
+ , testCase "nodeHashToTree: reconstructs leaf node" $ do
+ let input = "nodeHashToTree [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] [(pair [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] (pair [(0) (0) (0) (1)] [(0)]))]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= okT Leaf Leaf
+
+ , testCase "nodeHashToTree: reconstructs stem node" $ do
+ let input = "nodeHashToTree [(33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)] [(pair [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] (pair [(0) (0) (0) (1)] [(0)])) (pair [(33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)] (pair [(0) (0) (0) (33)] [(1) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)]))]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= okT (Stem Leaf) Leaf
+
+ , testCase "nodeHashToTree: reconstructs fork node" $ do
+ let input = "nodeHashToTree [(65) (66) (67) (68) (69) (70) (71) (72) (73) (74) (75) (76) (77) (78) (79) (80) (81) (82) (83) (84) (85) (86) (87) (88) (89) (90) (91) (92) (93) (94) (95) (96)] [(pair [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] (pair [(0) (0) (0) (1)] [(0)])) (pair [(33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)] (pair [(0) (0) (0) (1)] [(0)])) (pair [(65) (66) (67) (68) (69) (70) (71) (72) (73) (74) (75) (76) (77) (78) (79) (80) (81) (82) (83) (84) (85) (86) (87) (88) (89) (90) (91) (92) (93) (94) (95) (96)] (pair [(0) (0) (0) (65)] [(2) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)]))]"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= okT (Fork Leaf Leaf) Leaf
+
+ , testCase "readArborixTreeFromHash: reconstructs tree from bundle bytes" $ do
+ let nodesBytes = u64 1 ++ [1..32] ++ u32 1 ++ [0]
+ input = "readArborixTreeFromHash " ++ bytesExpr [1..32] ++ " " ++ bytesExpr (simpleContainerBytes [101,102,103] nodesBytes)
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= okT Leaf (bytesT ([101,102,103] ++ nodesBytes))
+
+ , testCase "readArborixExecutableFromHash: alias reconstructs tree" $ do
+ let nodesBytes = u64 1 ++ [1..32] ++ u32 1 ++ [0]
+ input = "readArborixExecutableFromHash " ++ bytesExpr [1..32] ++ " " ++ bytesExpr (simpleContainerBytes [101,102,103] nodesBytes)
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= okT Leaf (bytesT ([101,102,103] ++ nodesBytes))
+
+ , testCase "readArborixNodesSection: reads id fixture bundle" $ do
+ fixtureBytes <- BS.readFile "test/fixtures/id.tri.bundle"
+ case decodeBundle fixtureBytes of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right _ -> do
+ let input = "matchResult (code rest : code) (nodes rest : 0) (readArborixNodesSection "
+ ++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
+ ++ ")"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofNumber 0
+
+ , testCase "readArborixNodesSection: reads notQ fixture bundle" $ do
+ fixtureBytes <- BS.readFile "test/fixtures/notQ.tri.bundle"
+ case decodeBundle fixtureBytes of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right _ -> do
+ let input = "matchResult (code rest : code) (nodes rest : 0) (readArborixNodesSection "
+ ++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
+ ++ ")"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofNumber 0
+
+ , testCase "readArborixNodesSection: reads map fixture bundle" $ do
+ fixtureBytes <- BS.readFile "test/fixtures/map.tri.bundle"
+ case decodeBundle fixtureBytes of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right _ -> do
+ let input = "matchResult (code rest : code) (nodes rest : 0) (readArborixNodesSection "
+ ++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
+ ++ ")"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofNumber 0
+
+ , testCase "readArborixExecutableFromHash: reconstructs id fixture root" $ do
+ fixtureBytes <- BS.readFile "test/fixtures/id.tri.bundle"
+ case decodeBundle fixtureBytes of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right bundle -> case bundleRoots bundle of
+ [] -> assertFailure "fixture has no roots"
+ (rootHash:_) -> do
+ let input = "matchResult (code rest : code) (tree rest : 0) (readArborixExecutableFromHash "
+ ++ bytesExpr (hexTextBytes rootHash)
+ ++ " "
+ ++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
+ ++ ")"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofNumber 0
+
+ , testCase "readArborixExecutableFromHash: reconstructs notQ fixture root" $ do
+ fixtureBytes <- BS.readFile "test/fixtures/notQ.tri.bundle"
+ case decodeBundle fixtureBytes of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right bundle -> case bundleRoots bundle of
+ [] -> assertFailure "fixture has no roots"
+ (rootHash:_) -> do
+ let input = "matchResult (code rest : code) (tree rest : 0) (readArborixExecutableFromHash "
+ ++ bytesExpr (hexTextBytes rootHash)
+ ++ " "
+ ++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
+ ++ ")"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofNumber 0
+
+ , testCase "readArborixExecutableFromHash: reconstructs map fixture root" $ do
+ fixtureBytes <- BS.readFile "test/fixtures/map.tri.bundle"
+ case decodeBundle fixtureBytes of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right bundle -> case bundleRoots bundle of
+ [] -> assertFailure "fixture has no roots"
+ (rootHash:_) -> do
+ let input = "matchResult (code rest : code) (tree rest : 0) (readArborixExecutableFromHash "
+ ++ bytesExpr (hexTextBytes rootHash)
+ ++ " "
+ ++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
+ ++ ")"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofNumber 0
+
+ , testCase "readArborixExecutableFromHash: executes id fixture root" $ do
+ fixtureBytes <- BS.readFile "test/fixtures/id.tri.bundle"
+ case decodeBundle fixtureBytes of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right bundle -> case bundleRoots bundle of
+ [] -> assertFailure "fixture has no roots"
+ (rootHash:_) -> do
+ let input = "matchResult (code rest : code) (tree rest : tree 42) (readArborixExecutableFromHash "
+ ++ bytesExpr (hexTextBytes rootHash)
+ ++ " "
+ ++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
+ ++ ")"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= ofNumber 42
+
+ , testCase "readArborixExecutableFromHash: executes notQ fixture on true" $ do
+ fixtureBytes <- BS.readFile "test/fixtures/notQ.tri.bundle"
+ case decodeBundle fixtureBytes of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right bundle -> case bundleRoots bundle of
+ [] -> assertFailure "fixture has no roots"
+ (rootHash:_) -> do
+ let input = "matchResult (code rest : code) (tree rest : tree true) (readArborixExecutableFromHash "
+ ++ bytesExpr (hexTextBytes rootHash)
+ ++ " "
+ ++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
+ ++ ")"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= falseT
+
+ , testCase "readArborixExecutableFromHash: executes notQ fixture on false" $ do
+ fixtureBytes <- BS.readFile "test/fixtures/notQ.tri.bundle"
+ case decodeBundle fixtureBytes of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right bundle -> case bundleRoots bundle of
+ [] -> assertFailure "fixture has no roots"
+ (rootHash:_) -> do
+ let input = "matchResult (code rest : code) (tree rest : tree false) (readArborixExecutableFromHash "
+ ++ bytesExpr (hexTextBytes rootHash)
+ ++ " "
+ ++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
+ ++ ")"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= trueT
+
+ , testCase "readArborixExecutableFromHash: executes map fixture root" $ do
+ fixtureBytes <- BS.readFile "test/fixtures/map.tri.bundle"
+ case decodeBundle fixtureBytes of
+ Left err -> assertFailure $ "decodeBundle failed: " ++ err
+ Right bundle -> case bundleRoots bundle of
+ [] -> assertFailure "fixture has no roots"
+ (rootHash:_) -> do
+ let input = "matchResult (code rest : code) (tree rest : head (tail (tree (a : (t t t)) [(t) (t) (t)]))) (readArborixExecutableFromHash "
+ ++ bytesExpr (hexTextBytes rootHash)
+ ++ " "
+ ++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
+ ++ ")"
+ library <- evaluateFile "./lib/arborix.tri"
+ let env = evalTricu library (parseTricu input)
+ result env @?= Fork Leaf Leaf
]
diff --git a/test/fixtures/equalQ.tri.bundle b/test/fixtures/equalQ.tri.bundle
Binary files differ.
diff --git a/test/fixtures/false.tri.bundle b/test/fixtures/false.tri.bundle
Binary files differ.
diff --git a/test/fixtures/id.tri.bundle b/test/fixtures/id.tri.bundle
Binary files differ.
diff --git a/test/fixtures/map.tri.bundle b/test/fixtures/map.tri.bundle
Binary files differ.
diff --git a/test/fixtures/notQ.tri b/test/fixtures/notQ.tri
@@ -1,2 +0,0 @@
-\!import "base.tri" _
-main = not?
diff --git a/test/fixtures/notQ.tri.bundle b/test/fixtures/notQ.tri.bundle
Binary files differ.
diff --git a/test/fixtures/true.tri.bundle b/test/fixtures/true.tri.bundle
Binary files differ.
