Wire prepped and basics tested
This commit is contained in:
283
test/Spec.hs
283
test/Spec.hs
@@ -6,16 +6,24 @@ import Lexer
|
||||
import Parser
|
||||
import REPL
|
||||
import Research
|
||||
import Wire
|
||||
import ContentStore
|
||||
|
||||
import Control.Exception (evaluate, try, SomeException)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Bits (xor)
|
||||
import Data.List (isInfixOf)
|
||||
import Data.Text (Text, unpack)
|
||||
import Data.Word (Word8)
|
||||
import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
import Text.Megaparsec (runParser)
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Database.SQLite.Simple (close, Connection)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain tests
|
||||
@@ -36,6 +44,7 @@ tests = testGroup "Tricu Tests"
|
||||
, decoding
|
||||
, elimLambdaSingle
|
||||
, stressElimLambda
|
||||
, wireTests
|
||||
]
|
||||
|
||||
lexer :: TestTree
|
||||
@@ -640,3 +649,277 @@ stressElimLambda = testCase "stress elimLambda on wide list under deep curried l
|
||||
let before = result (evalTricu Map.empty prog)
|
||||
after = result (evalTricu Map.empty out)
|
||||
after @?= before
|
||||
|
||||
-- --------------------------------------------------------------------------
|
||||
-- Wire module tests
|
||||
-- --------------------------------------------------------------------------
|
||||
|
||||
-- | Helper: create a temporary file-backed DB, store a term, return the
|
||||
-- connection and the term (so callers can compare after round-trip).
|
||||
storeTermInTempDB :: String -> IO (Connection, Text, T)
|
||||
storeTermInTempDB src = do
|
||||
conn <- newContentStore
|
||||
let asts = parseTricu src
|
||||
finalEnv = evalTricu Map.empty asts
|
||||
term = result finalEnv
|
||||
-- storeMerkleNodes returns MerkleHash as Text; storeTerm expects [String]
|
||||
_ <- storeTerm conn [] term
|
||||
return (conn, hashTerm term, term)
|
||||
|
||||
-- | Load a term from a DB by its stored hash Text.
|
||||
loadTermByHash :: Connection -> Text -> IO T
|
||||
loadTermByHash conn h = do
|
||||
maybeTerm <- loadTree conn h
|
||||
case maybeTerm of
|
||||
Just t -> return t
|
||||
Nothing -> errorWithoutStackTrace $ "hash not found in store: " ++ Data.Text.unpack h
|
||||
|
||||
-- | Flip one byte in a ByteString at the given index.
|
||||
corruptByte :: ByteString -> Int -> ByteString
|
||||
corruptByte bs i = BS.take i bs <> BS.pack [(BS.index bs i `xor` 0x01)] <> BS.drop (i + 1) bs
|
||||
|
||||
wireTests :: TestTree
|
||||
wireTests = testGroup "Wire Tests"
|
||||
[ testCase "Portable bundle: header and manifest declare Tree Calculus object format" $ do
|
||||
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
||||
[ "id = a : a"
|
||||
, "main = id t"
|
||||
]
|
||||
wireData <- exportBundle srcConn [termHash]
|
||||
BS.take 8 wireData @?= BS.pack [0x54, 0x52, 0x49, 0x43, 0x55, 0x42, 0x4e, 0x44]
|
||||
case decodeBundle wireData of
|
||||
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
||||
Right bundle -> do
|
||||
let manifest = bundleManifest bundle
|
||||
tree = manifestTree manifest
|
||||
hashSpec = treeNodeHash tree
|
||||
runtime = manifestRuntime manifest
|
||||
manifestSchema manifest @?= "tricu.bundle.manifest.v1"
|
||||
manifestBundleType manifest @?= "tree-calculus-executable-object"
|
||||
manifestClosure manifest @?= ClosureComplete
|
||||
treeCalculus tree @?= "tree-calculus.v1"
|
||||
treeNodePayload tree @?= "tricu.merkle.payload.v1"
|
||||
nodeHashAlgorithm hashSpec @?= "sha256"
|
||||
nodeHashDomain hashSpec @?= "tricu.merkle.node.v1"
|
||||
runtimeSemantics runtime @?= "tree-calculus.v1"
|
||||
runtimeAbi runtime @?= "tricu.abi.tree.v1"
|
||||
runtimeCapabilities runtime @?= []
|
||||
bundleRoots bundle @?= [termHash]
|
||||
map exportRoot (manifestExports manifest) @?= [termHash]
|
||||
close srcConn
|
||||
|
||||
, testCase "Portable bundle: named exports are manifest aliases for Merkle roots" $ do
|
||||
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
||||
[ "validateEmail = a : a"
|
||||
, "main = validateEmail t"
|
||||
]
|
||||
wireData <- exportNamedBundle srcConn [("validateEmail", termHash)]
|
||||
case decodeBundle wireData of
|
||||
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
||||
Right bundle -> do
|
||||
bundleRoots bundle @?= [termHash]
|
||||
case manifestExports (bundleManifest bundle) of
|
||||
[exported] -> do
|
||||
exportName exported @?= "validateEmail"
|
||||
exportRoot exported @?= termHash
|
||||
exportKind exported @?= "term"
|
||||
exportAbi exported @?= "tricu.abi.tree.v1"
|
||||
exports -> assertFailure $ "Expected one export, got: " ++ show exports
|
||||
close srcConn
|
||||
|
||||
, testCase "Portable bundle: renaming an export changes bundle bytes but not tree identity" $ do
|
||||
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
||||
[ "f = a : a"
|
||||
, "main = f t"
|
||||
]
|
||||
mainBundleData <- exportNamedBundle srcConn [("main", termHash)]
|
||||
renamedBundleData <- exportNamedBundle srcConn [("validate", termHash)]
|
||||
assertBool "Renaming an export should change the manifest/bundle bytes"
|
||||
(mainBundleData /= renamedBundleData)
|
||||
case (decodeBundle mainBundleData, decodeBundle renamedBundleData) of
|
||||
(Right mainBundle, Right renamedBundle) -> do
|
||||
bundleRoots mainBundle @?= [termHash]
|
||||
bundleRoots renamedBundle @?= [termHash]
|
||||
map exportRoot (manifestExports $ bundleManifest mainBundle)
|
||||
@?= map exportRoot (manifestExports $ bundleManifest renamedBundle)
|
||||
map exportName (manifestExports $ bundleManifest mainBundle) @?= ["main"]
|
||||
map exportName (manifestExports $ bundleManifest renamedBundle) @?= ["validate"]
|
||||
(Left err, _) -> assertFailure $ "decodeBundle main failed: " ++ err
|
||||
(_, Left err) -> assertFailure $ "decodeBundle renamed failed: " ++ err
|
||||
close srcConn
|
||||
|
||||
, testCase "Portable bundle: exact byte export is deterministic" $ do
|
||||
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
||||
[ "x = t t"
|
||||
, "main = t x"
|
||||
]
|
||||
first <- exportBundle srcConn [termHash]
|
||||
second <- exportBundle srcConn [termHash]
|
||||
first @?= second
|
||||
close srcConn
|
||||
|
||||
, testCase "Portable bundle: raw section tampering is rejected by digest verification" $ do
|
||||
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
||||
[ "x = t"
|
||||
, "main = t x"
|
||||
]
|
||||
wireData <- exportBundle srcConn [termHash]
|
||||
let tampered = corruptByte wireData (BS.length wireData - 1)
|
||||
case decodeBundle tampered of
|
||||
Left err -> assertBool ("Expected section digest mismatch, got: " ++ err)
|
||||
("digest mismatch" `isInfixOf` err)
|
||||
Right _ -> assertFailure "Expected decodeBundle to reject tampered section bytes"
|
||||
close srcConn
|
||||
|
||||
, testCase "Portable bundle: unsupported manifest semantics are rejected" $ do
|
||||
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
||||
[ "x = t"
|
||||
, "main = t x"
|
||||
]
|
||||
wireData <- exportBundle srcConn [termHash]
|
||||
case decodeBundle wireData of
|
||||
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
||||
Right bundle -> do
|
||||
let manifest = bundleManifest bundle
|
||||
partialBundle = bundle
|
||||
{ bundleManifest = manifest { manifestClosure = ClosurePartial }
|
||||
, bundleManifestBytes = BS.empty
|
||||
}
|
||||
capabilityBundle = bundle
|
||||
{ bundleManifest = manifest
|
||||
{ manifestRuntime = (manifestRuntime manifest)
|
||||
{ runtimeCapabilities = ["host.io"]
|
||||
}
|
||||
}
|
||||
, bundleManifestBytes = BS.empty
|
||||
}
|
||||
wrongHashBundle = bundle
|
||||
{ bundleManifest = manifest
|
||||
{ manifestTree = (manifestTree manifest)
|
||||
{ treeNodeHash = (treeNodeHash $ manifestTree manifest)
|
||||
{ nodeHashAlgorithm = "blake3" }
|
||||
}
|
||||
}
|
||||
, bundleManifestBytes = BS.empty
|
||||
}
|
||||
case verifyBundle partialBundle of
|
||||
Left err -> assertBool ("Expected closure error, got: " ++ err) ("closure = complete" `isInfixOf` err)
|
||||
Right () -> assertFailure "Expected partial closure to be rejected"
|
||||
case verifyBundle capabilityBundle of
|
||||
Left err -> assertBool ("Expected capability error, got: " ++ err) ("capabilities" `isInfixOf` err)
|
||||
Right () -> assertFailure "Expected runtime capabilities to be rejected"
|
||||
case verifyBundle wrongHashBundle of
|
||||
Left err -> assertBool ("Expected hash algorithm error, got: " ++ err) ("node hash algorithm" `isInfixOf` err)
|
||||
Right () -> assertFailure "Expected unsupported node hash algorithm to be rejected"
|
||||
close srcConn
|
||||
|
||||
, testCase "Portable bundle: import registers manifest export names in fresh content store" $ do
|
||||
(srcConn, termHash, originalTerm) <- storeTermInTempDB $ unlines
|
||||
[ "validateEmail = a : a"
|
||||
, "main = validateEmail t"
|
||||
]
|
||||
wireData <- exportNamedBundle srcConn [("validateEmail", termHash)]
|
||||
dstConn <- newContentStore
|
||||
_ <- importBundle dstConn wireData
|
||||
loadedByHash <- loadTermByHash dstConn termHash
|
||||
loadedByName <- loadTerm dstConn "validateEmail"
|
||||
loadedByHash @?= originalTerm
|
||||
loadedByName @?= Just originalTerm
|
||||
close srcConn
|
||||
close dstConn
|
||||
|
||||
, testCase "Round-trip: store, export, import, load" $ do
|
||||
-- Store a term
|
||||
(srcConn, termHash, originalTerm) <- storeTermInTempDB $ unlines
|
||||
[ "x = t"
|
||||
, "y = t x"
|
||||
, "z = t y"
|
||||
, "main = z"
|
||||
]
|
||||
-- Export by root hash
|
||||
wireData <- exportBundle srcConn [termHash]
|
||||
-- Import into a fresh DB
|
||||
dstConn <- newContentStore
|
||||
_ <- importBundle dstConn wireData
|
||||
-- Load the term back and compare
|
||||
loadedTerm <- loadTermByHash dstConn termHash
|
||||
loadedTerm @?= originalTerm
|
||||
-- Cleanup
|
||||
close srcConn
|
||||
close dstConn
|
||||
|
||||
, testCase "Round-trip: evaluate from original, export, import, load root" $ do
|
||||
(srcConn, termHash, originalTerm) <- storeTermInTempDB $ unlines
|
||||
[ "add = a b : t (t a) b"
|
||||
, "val = add (t t) (t)"
|
||||
, "main = val"
|
||||
]
|
||||
-- Export
|
||||
wireData <- exportBundle srcConn [termHash]
|
||||
-- Import into fresh DB
|
||||
dstConn <- newContentStore
|
||||
_ <- importBundle dstConn wireData
|
||||
-- Load the root term by hash and compare
|
||||
loadedTerm <- loadTermByHash dstConn termHash
|
||||
loadedTerm @?= originalTerm
|
||||
close srcConn
|
||||
close dstConn
|
||||
|
||||
, testCase "Negative: corrupt payload byte causes import to fail" $ do
|
||||
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
||||
[ "x = t"
|
||||
, "y = t x"
|
||||
, "z = t y"
|
||||
, "main = z"
|
||||
]
|
||||
wireData <- exportBundle srcConn [termHash]
|
||||
-- Decode, mutate one node's payload byte, re-encode
|
||||
case decodeBundle wireData of
|
||||
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
||||
Right bundle -> do
|
||||
let (h, payload) =
|
||||
head
|
||||
[ (h', p)
|
||||
| (h', p) <- Map.toList (bundleNodes bundle)
|
||||
, BS.length p > 0
|
||||
]
|
||||
payload' = BS.pack [(BS.head payload `xor` 0x01)] <> BS.tail payload
|
||||
bundle' = bundle { bundleNodes = Map.insert h payload' (bundleNodes bundle) }
|
||||
wireData' = encodeBundle bundle'
|
||||
dstConn <- newContentStore
|
||||
result <- try (importBundle dstConn wireData') :: IO (Either SomeException [MerkleHash])
|
||||
case result of
|
||||
Left e ->
|
||||
assertBool ("Expected hash mismatch or invalid payload, got: " ++ show e)
|
||||
$ "mismatch" `isInfixOf` show e || "invalid" `isInfixOf` show e
|
||||
Right _ ->
|
||||
assertFailure "Expected import to fail on corrupted payload"
|
||||
close dstConn
|
||||
close srcConn
|
||||
|
||||
, testCase "Negative: missing child node causes import to fail" $ do
|
||||
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
||||
[ "x = t"
|
||||
, "y = t x"
|
||||
, "z = t y"
|
||||
, "main = z"
|
||||
]
|
||||
wireData <- exportBundle srcConn [termHash]
|
||||
-- Decode, remove a node, re-encode
|
||||
case decodeBundle wireData of
|
||||
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
||||
Right bundle -> do
|
||||
let nodeList = Map.toList (bundleNodes bundle)
|
||||
trimmed = Map.fromList (tail nodeList)
|
||||
newBundle = bundle { bundleNodes = trimmed }
|
||||
newWire = encodeBundle newBundle
|
||||
dstConn <- newContentStore
|
||||
result <- try (importBundle dstConn newWire) :: IO (Either SomeException [MerkleHash])
|
||||
case result of
|
||||
Left e ->
|
||||
assertBool ("Expected verify error, got: " ++ show e) True
|
||||
Right _ ->
|
||||
assertFailure "Expected import to fail on missing child node"
|
||||
close dstConn
|
||||
close srcConn
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user