diff --git a/lib/arborix.tri b/lib/arborix.tri index 7ce6026..4873ac8 100644 --- 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 index ffa46b6..7ef77cf 100644 --- 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 - (matchList - t - (h r : pair h (self n (succ i) r)) - remaining) - (equal? i n)) + (h r : + matchBool + t + (pair h (self r n (succ i))) + (equal? i n)) + remaining) -bytesTake = n bytes : bytesTake_ n 0 bytes +bytesTake = n bytes : bytesTake_ bytes n 0 -bytesDrop_ = y (self n i remaining : - matchBool - remaining - (matchList - t - (_ r : self n (succ i) r) - remaining) - (equal? i n)) +bytesDrop_ = y (self remaining n i : + matchList + t + (_ r : + matchBool + remaining + (self r n (succ i)) + (equal? i n)) + remaining) -bytesDrop = n bytes : bytesDrop_ n 0 bytes +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 index ccddfa1..c2c8276 100644 --- 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 index fe813ba..8f3687d 100644 --- 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 deleted file mode 100644 index 3d4be33..0000000 Binary files a/test/fixtures/equalQ.tri.bundle and /dev/null differ diff --git a/test/fixtures/false.tri.bundle b/test/fixtures/false.tri.bundle deleted file mode 100644 index 13f2f31..0000000 Binary files a/test/fixtures/false.tri.bundle and /dev/null differ diff --git a/test/fixtures/id.tri.bundle b/test/fixtures/id.tri.bundle index acaae39..47589dc 100644 Binary files a/test/fixtures/id.tri.bundle and b/test/fixtures/id.tri.bundle differ diff --git a/test/fixtures/map.tri.bundle b/test/fixtures/map.tri.bundle new file mode 100644 index 0000000..e3014a4 Binary files /dev/null and b/test/fixtures/map.tri.bundle differ diff --git a/test/fixtures/notQ.tri b/test/fixtures/notQ.tri deleted file mode 100644 index 3665206..0000000 --- a/test/fixtures/notQ.tri +++ /dev/null @@ -1,2 +0,0 @@ -\!import "base.tri" _ -main = not? diff --git a/test/fixtures/notQ.tri.bundle b/test/fixtures/notQ.tri.bundle index fe5d327..2cbb59d 100644 Binary files a/test/fixtures/notQ.tri.bundle and b/test/fixtures/notQ.tri.bundle differ diff --git a/test/fixtures/true.tri.bundle b/test/fixtures/true.tri.bundle deleted file mode 100644 index 2b17a6e..0000000 Binary files a/test/fixtures/true.tri.bundle and /dev/null differ