commit 93f648715f4fbe4278a773dbe92b70d5637bd408
parent a2dba24c0fa291cceb0b4e7e82ae70fe5afa4a6c
Author: James Eversole <james@eversole.co>
Date: Wed, 14 Oct 2026 19:20:47 -0500
Share authenticated executable loading across host entrypoints
Diffstat:
7 files changed, 246 insertions(+), 87 deletions(-)
diff --git a/src/ContentStore/Bundle.hs b/src/ContentStore/Bundle.hs
@@ -14,10 +14,12 @@ module ContentStore.Bundle
, unpackIndexedBundleToStore
) where
+import ContentStore.Executable (loadExecutableObject)
+import ContentStore.Indexed
import ContentStore.Arboricx
import ContentStore.Alias (ObjectRef(..))
import ContentStore.Object
-import ContentStore.Filesystem (putObject, objectPath, getVerifiedObject)
+import ContentStore.Filesystem (putObject, objectPath)
import Runtime (T)
import Wire
@@ -33,28 +35,6 @@ import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
import qualified Data.Foldable as Foldable
--- A single name-neutral root in the existing indexed Arboricx wire format.
--- This is a distinct object kind, not a new encoding under tree-term hashes.
-indexedTreeDomain :: Domain
-indexedTreeDomain = Domain "arboricx.indexed-tree.v1"
-
--- The same name-neutral canonical object emitted by indexed bundle import.
--- Preserve sharing before serialization, without applying the supplied tree.
-encodeIndexedTree :: T -> IO ByteString
-encodeIndexedTree tree = encodeBundle <$> buildBundleShared [("root", tree)]
-
-decodeIndexedTree :: ByteString -> Either String T
-decodeIndexedTree payload = do
- bundle <- decodeBundle payload
- verifyBundle bundle
- root <- case (bundleRoots bundle, manifestExports $ bundleManifest bundle) of
- ([index], [exported])
- | exportName exported == "root" && exportRoot exported == index
- , exportKind exported == "term", exportAbi exported == "arboricx.abi.tree.v1" -> Right index
- _ -> Left "indexed tree requires one root named root with the tree ABI"
- let terms = reconstructBundleTerms (bundleNodes bundle)
- pure (terms V.! fromIntegral root)
-
-- | Import without reconstructing/flattening T. Extraction works on graph
-- indices, strips unrelated roots/metadata, and makes identity alias-neutral.
unpackIndexedBundleToStore :: StorePath -> ByteString -> IO [(Text, ObjectHash)]
@@ -81,17 +61,6 @@ packExecutableBundleFromStore store exports
pure (name, tree)
buildBundleShared trees
-loadExecutableObject :: StorePath -> ObjectRef -> IO T
-loadExecutableObject store ref = do
- let kind = objectRefKind ref
- pin = objectRefHash ref
- decoder <- if kind == unDomain indexedTreeDomain then pure decodeIndexedTree
- else if kind == unDomain treeTermDomain then pure decodeTreeTermShared
- else fail "unsupported executable object kind"
- payload <- getVerifiedObject store (Domain kind) pin >>= maybe
- (fail "executable object not found") pure
- either fail pure (decoder payload)
-
-- | Pack verified canonical CAS bytes directly into the indexed DAG. Read one
-- export at a time in bounded chunks; never retain all payloads or construct
-- expanded Haskell trees. Sharing is global across exports. Memory still scales
diff --git a/src/ContentStore/Executable.hs b/src/ContentStore/Executable.hs
@@ -0,0 +1,88 @@
+-- Authenticated executable loading. Object references establish kind and content;
+-- only a module export supplies an ABI. Failures are IO errors, not process exits.
+module ContentStore.Executable
+ ( loadVerifiedManifest, loadVerifiedExport, loadVerifiedExportWith
+ , loadVerifiedExports, loadExecutableObject ) where
+
+import ContentStore.Object
+import ContentStore.Filesystem (getObject)
+import ContentStore.Arboricx (treeTermDomain, decodeTreeTermShared)
+import ContentStore.Indexed
+import ContentStore.Alias (ObjectRef(..))
+import Module.Manifest
+import qualified Runtime as Tree
+import qualified Data.Text as T
+import Control.Exception (evaluate)
+import Control.Monad (forM, unless)
+
+loadVerifiedManifest :: StorePath -> T.Text -> IO ModuleManifest
+loadVerifiedManifest store manifestHash = do
+ either (fail . ("Invalid module manifest hash: " ++)) pure
+ (textToHashBytes manifestHash)
+ manifestPayload <- getObject store manifestHash >>= maybe
+ (fail $ "Module manifest not found in store: " ++ T.unpack manifestHash) pure
+ unless (hashObject manifestDomain manifestPayload == manifestHash) $
+ fail "Module manifest digest mismatch"
+ manifest <- either (fail . ("Invalid module manifest: " ++)) pure
+ (decodeManifest manifestPayload)
+ pure manifest
+
+loadVerifiedExport :: StorePath -> T.Text -> T.Text -> IO (ObjectHash, Tree.T)
+loadVerifiedExport = loadVerifiedExportWith (const $ pure ())
+
+loadVerifiedExportWith :: (String -> IO ()) -> StorePath -> T.Text -> T.Text -> IO (ObjectHash, Tree.T)
+loadVerifiedExportWith sample store manifestHash name = do
+ manifest <- loadVerifiedManifest store manifestHash
+ sample "manifest-verified"
+ loadManifestExport sample store manifest name
+
+loadVerifiedExports :: StorePath -> T.Text -> IO [(String, Tree.T)]
+loadVerifiedExports store pin = do
+ manifest <- loadVerifiedManifest store pin
+ forM (moduleManifestExports manifest) $ \ex -> do
+ (_, term) <- loadModuleExport (const $ pure ()) store ex
+ pure (T.unpack (moduleExportName ex), term)
+
+-- Internal: the manifest must have passed authentication and decoding above.
+loadManifestExport :: (String -> IO ()) -> StorePath -> ModuleManifest -> T.Text -> IO (ObjectHash, Tree.T)
+loadManifestExport sample store manifest name = do
+ let matches = filter ((== name) . moduleExportName)
+ (moduleManifestExports manifest)
+ ex <- case matches of
+ [single] -> pure single
+ [] -> fail $ "Module export not found: " ++ T.unpack name
+ _ -> fail $ "Duplicate module export: " ++ T.unpack name
+ loadModuleExport sample store ex
+
+loadModuleExport :: (String -> IO ()) -> StorePath -> ModuleExport -> IO (ObjectHash, Tree.T)
+loadModuleExport sample store ex = do
+ let ref = moduleExportObject ex
+ unless (moduleExportAbi ex == "arboricx.abi.tree.v1") $
+ fail $ "Unsupported module export ABI: " ++ T.unpack (moduleExportAbi ex)
+ term <- loadExecutableObjectWith sample store ref
+ pure (objectRefHash ref, term)
+
+loadExecutableObject :: StorePath -> ObjectRef -> IO Tree.T
+loadExecutableObject = loadExecutableObjectWith (const $ pure ())
+
+loadExecutableObjectWith :: (String -> IO ()) -> StorePath -> ObjectRef -> IO Tree.T
+loadExecutableObjectWith sample store ref = do
+ domain <- if objectRefKind ref == unDomain treeTermDomain
+ then pure treeTermDomain
+ else if objectRefKind ref == unDomain indexedTreeDomain
+ then pure indexedTreeDomain
+ else fail $ "Unsupported module export object kind: " ++ T.unpack (objectRefKind ref)
+ either (fail . ("Invalid executable tree hash: " ++)) pure
+ (textToHashBytes $ objectRefHash ref)
+ treePayload <- getObject store (objectRefHash ref) >>= maybe
+ (fail $ "Executable tree not found: " ++ T.unpack (objectRefHash ref)) pure
+ sample "executable-read"
+ unless (hashObject domain treePayload == objectRefHash ref) $
+ fail "Executable tree digest mismatch"
+ sample "executable-digest-verified"
+ term <- either (fail . ("Invalid executable tree: " ++)) pure
+ ((if domain == indexedTreeDomain then decodeIndexedTree else decodeTreeTermShared) treePayload)
+ _ <- evaluate term
+ sample "executable-decoded"
+ pure term
+
diff --git a/src/ContentStore/Indexed.hs b/src/ContentStore/Indexed.hs
@@ -0,0 +1,32 @@
+-- Name-neutral indexed object codec, shared by import, loading and publication.
+module ContentStore.Indexed
+ ( indexedTreeDomain, encodeIndexedTree, decodeIndexedTree ) where
+
+import ContentStore.Object
+import Runtime (T)
+import Wire
+import Data.ByteString (ByteString)
+import qualified Data.Vector as V
+
+-- A single name-neutral root in the existing indexed Arboricx wire format.
+-- This is a distinct object kind, not a new encoding under tree-term hashes.
+indexedTreeDomain :: Domain
+indexedTreeDomain = Domain "arboricx.indexed-tree.v1"
+
+-- The same name-neutral canonical object emitted by indexed bundle import.
+-- Preserve sharing before serialization, without applying the supplied tree.
+encodeIndexedTree :: T -> IO ByteString
+encodeIndexedTree tree = encodeBundle <$> buildBundleShared [("root", tree)]
+
+decodeIndexedTree :: ByteString -> Either String T
+decodeIndexedTree payload = do
+ bundle <- decodeBundle payload
+ verifyBundle bundle
+ root <- case (bundleRoots bundle, manifestExports $ bundleManifest bundle) of
+ ([index], [exported])
+ | exportName exported == "root" && exportRoot exported == index
+ , exportKind exported == "term", exportAbi exported == "arboricx.abi.tree.v1" -> Right index
+ _ -> Left "indexed tree requires one root named root with the tree ABI"
+ let terms = reconstructBundleTerms (bundleNodes bundle)
+ pure (terms V.! fromIntegral root)
+
diff --git a/src/Main.hs b/src/Main.hs
@@ -1,6 +1,7 @@
module Main where
import ContentStore
+import ContentStore.Executable hiding (loadExecutableObject)
import qualified Package
import qualified Module.Provenance as Provenance
import qualified Module.Inspection as Inspection
@@ -8,6 +9,7 @@ import qualified InteractionInspection as Interaction
import qualified Project
import ContentStore.Bundle
import Module.Manifest
+import System.IO.Error (ioeGetErrorString)
import System.Exit (die, exitFailure)
import IODriver (IOPermissions(..), runIO, YieldStats(..), runIOWithYieldStatsHook)
import REPL (portableRepl)
@@ -650,7 +652,10 @@ storeAliasParser = subparser $ mconcat
-- ---------------------------------------------------------------------------
main :: IO ()
-main = do
+main = runMain `catch` (\(err :: IOException) -> die (ioeGetErrorString err))
+
+runMain :: IO ()
+runMain = do
appArgs <- execParser $ info (tricuParser <**> helper)
( fullDesc
<> progDesc "Exploring Tree Calculus"
@@ -962,53 +967,6 @@ runStored opts = do
putStrLn "RUN_DONE"
-- One digest/kind/ABI-verified boundary for runtime execution and tooling.
-loadVerifiedManifest :: StorePath -> T.Text -> IO ModuleManifest
-loadVerifiedManifest store manifestHash = do
- either (die . ("Invalid module manifest hash: " ++)) pure
- (textToHashBytes manifestHash)
- manifestPayload <- getObject store manifestHash >>= maybe
- (die $ "Module manifest not found in store: " ++ T.unpack manifestHash) pure
- unless (hashObject manifestDomain manifestPayload == manifestHash) $
- die "Module manifest digest mismatch"
- manifest <- either (die . ("Invalid module manifest: " ++)) pure
- (decodeManifest manifestPayload)
- pure manifest
-
-loadVerifiedExport :: StorePath -> T.Text -> T.Text -> IO (ObjectHash, Runtime.T)
-loadVerifiedExport = loadVerifiedExportWith (const $ pure ())
-
-loadVerifiedExportWith :: (String -> IO ()) -> StorePath -> T.Text -> T.Text -> IO (ObjectHash, Runtime.T)
-loadVerifiedExportWith sample store manifestHash name = do
- manifest <- loadVerifiedManifest store manifestHash
- sample "manifest-verified"
- let matches = filter ((== name) . moduleExportName)
- (moduleManifestExports manifest)
- ex <- case matches of
- [single] -> pure single
- [] -> die $ "Module export not found: " ++ T.unpack name
- _ -> die $ "Duplicate module export: " ++ T.unpack name
- let ref = moduleExportObject ex
- domain <- if objectRefKind ref == unDomain treeTermDomain
- then pure treeTermDomain
- else if objectRefKind ref == unDomain indexedTreeDomain
- then pure indexedTreeDomain
- else die $ "Unsupported module export object kind: " ++ T.unpack (objectRefKind ref)
- unless (moduleExportAbi ex == "arboricx.abi.tree.v1") $
- die $ "Unsupported module export ABI: " ++ T.unpack (moduleExportAbi ex)
- either (die . ("Invalid executable tree hash: " ++)) pure
- (textToHashBytes $ objectRefHash ref)
- treePayload <- getObject store (objectRefHash ref) >>= maybe
- (die $ "Executable tree not found: " ++ T.unpack (objectRefHash ref)) pure
- sample "executable-read"
- unless (hashObject domain treePayload == objectRefHash ref) $
- die "Executable tree digest mismatch"
- sample "executable-digest-verified"
- term <- either (die . ("Invalid executable tree: " ++)) pure
- ((if domain == indexedTreeDomain then decodeIndexedTree else decodeTreeTermShared) treePayload)
- _ <- evaluate term
- sample "executable-decoded"
- pure (objectRefHash ref, term)
-
-- Cabal records an installation-relative data directory. Nix-built binaries
-- retain their data closure when invoked outside the checkout. An explicit
-- tricu_datadir override is useful for relocatable distributions and diagnostics.
@@ -1030,10 +988,7 @@ packagedCompiler store = do
portableExports :: CompilerOptions -> Maybe FilePath -> FilePath -> IO [(String, Runtime.T)]
portableExports options selected path = do
(store, pin) <- buildPortableModule options selected path
- manifest <- loadVerifiedManifest store pin
- forM (moduleManifestExports manifest) $ \ex -> do
- (_, value) <- loadVerifiedExport store pin (moduleExportName ex)
- pure (T.unpack $ moduleExportName ex, value)
+ loadVerifiedExports store pin
validateCompilerOptions :: CompilerOptions -> IO ()
validateCompilerOptions options = do
diff --git a/test/ExecutableLoadingTests.hs b/test/ExecutableLoadingTests.hs
@@ -0,0 +1,108 @@
+module ExecutableLoadingTests (executableLoadingTests) where
+
+import ContentStore
+import ContentStore.Indexed
+import ContentStore.Executable
+import Module.Manifest
+import Runtime
+import Control.Exception (IOException, try, evaluate)
+import Control.Monad (forM_)
+import Data.IORef
+import Data.List (isInfixOf)
+import qualified Data.ByteString as BS
+import qualified Data.Text as Text
+import System.IO.Temp (withSystemTempDirectory)
+import System.Mem.StableName (makeStableName)
+import Test.Tasty
+import Test.Tasty.HUnit
+
+executableLoadingTests :: TestTree
+executableLoadingTests = testGroup "shared production executable loader" $
+ [ testGroup label
+ [ testCase "object and named export retain value and stage order" $ fresh $ \store -> do
+ ref <- publish store (Fork (Stem Leaf) (Stem Leaf))
+ pin <- putManifest store (ModuleManifest [] [export "main" ref])
+ stages <- newIORef []
+ (identity, value) <- loadVerifiedExportWith (\s -> modifyIORef' stages (++ [s])) store pin "main"
+ identity @?= objectRefHash ref
+ value @?= Fork (Stem Leaf) (Stem Leaf)
+ loadExecutableObject store ref >>= (@?= value)
+ readIORef stages >>= (@?= ["manifest-verified", "executable-read", "executable-digest-verified", "executable-decoded"])
+ -- Both decoders must retain physical sharing, not expand equal branches.
+ case value of
+ Fork a b -> do
+ _ <- evaluate a
+ _ <- evaluate b
+ x <- makeStableName a
+ y <- makeStableName b
+ assertBool "decoded sharing lost" (x == y)
+ _ -> assertFailure "unexpected decoded root"
+ , testCase "whole interface preserves manifest order and names" $ fresh $ \store -> do
+ ref <- publish store (Stem Leaf)
+ pin <- putManifest store (ModuleManifest [] [export "z" ref, export "a" ref])
+ loadVerifiedExports store pin >>= (@?= [("z", Stem Leaf), ("a", Stem Leaf)])
+ rejected "Module export not found" (loadVerifiedExport store pin "absent")
+ , testCase "tampering fails before decoding; correct digest is not enough" $ fresh $ \store -> do
+ ref <- publish store Leaf
+ pin <- putManifest store (ModuleManifest [] [export "main" ref])
+ BS.writeFile (objectPath store (objectRefHash ref)) "invalid bytes"
+ stages <- newIORef []
+ rejected "Executable tree digest mismatch" $
+ loadVerifiedExportWith (\s -> modifyIORef' stages (++ [s])) store pin "main"
+ readIORef stages >>= (@?= ["manifest-verified", "executable-read"])
+ rejected "Executable tree digest mismatch" (loadExecutableObject store ref)
+ bad <- putObject store (Domain (objectRefKind ref)) "invalid bytes"
+ rejected "Invalid executable tree" (loadExecutableObject store (ref {objectRefHash = bad}))
+ , testCase "export ABI checked even when its object is valid" $ fresh $ \store -> do
+ ref <- publish store Leaf
+ pin <- putManifest store (ModuleManifest [] [(export "main" ref) {moduleExportAbi = "unsupported"}])
+ -- Objects have no export ABI; an object-only success must not bless an export.
+ loadExecutableObject store ref >>= (@?= Leaf)
+ rejected "Unsupported module export ABI" (loadVerifiedExport store pin "main")
+ rejected "Unsupported module export ABI" (loadVerifiedExports store pin)
+ ]
+ | (label, publish) <- [("flat", flat), ("indexed", indexed)]
+ ] ++ [manifestTests]
+ where
+ -- testGroup combines the format matrix with independent manifest controls.
+ manifestTests = testGroup "manifest and object identity controls"
+ [ testCase "missing, malformed and tampered manifest" $ fresh $ \store -> do
+ rejected "not found" (loadVerifiedManifest store missing)
+ rejected "Invalid module manifest hash" (loadVerifiedManifest store "../escape")
+ malformed <- putObject store manifestDomain "not a manifest"
+ rejected "Invalid module manifest" (loadVerifiedManifest store malformed)
+ pin <- putManifest store (ModuleManifest [] [])
+ BS.writeFile (objectPath store pin) "tampered"
+ rejected "Module manifest digest mismatch" (loadVerifiedExports store pin)
+ , testCase "duplicate exports rejected by manifest decoding" $ fresh $ \store -> do
+ ref <- flat store Leaf
+ pin <- putManifest store (ModuleManifest [] [export "main" ref, export "main" ref])
+ rejected "duplicate" (loadVerifiedExports store pin)
+ , testCase "missing objects, invalid hashes and unsupported kinds" $ fresh $ \store -> do
+ rejected "not found" (loadExecutableObject store (ObjectRef (unDomain treeTermDomain) missing))
+ forM_ ["../escape", Text.replicate 64 "A"] $ \bad ->
+ rejected "hash" (loadExecutableObject store (ObjectRef (unDomain treeTermDomain) bad))
+ rejected "Unsupported" (loadExecutableObject store (ObjectRef "unknown" missing))
+ ]
+
+fresh :: (StorePath -> IO a) -> IO a
+fresh action = withSystemTempDirectory "executable-loader" (action . StorePath)
+
+missing :: Text.Text
+missing = Text.replicate 64 "0"
+
+export :: Text.Text -> ObjectRef -> ModuleExport
+export name ref = ModuleExport name ref "arboricx.abi.tree.v1"
+
+flat, indexed :: StorePath -> T -> IO ObjectRef
+flat store tree = ObjectRef (unDomain treeTermDomain) <$> putTreeTerm store tree
+indexed store tree = do
+ bytes <- encodeIndexedTree tree
+ ObjectRef (unDomain indexedTreeDomain) <$> putObject store indexedTreeDomain bytes
+
+rejected :: String -> IO a -> Assertion
+rejected needle action = do
+ result <- try (action >> pure ()) :: IO (Either IOException ())
+ case result of
+ Left problem -> assertBool (show problem) (needle `isInfixOf` show problem)
+ Right () -> assertFailure ("accepted invalid input; expected " ++ needle)
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -1,5 +1,6 @@
module Main where
+import ExecutableLoadingTests (executableLoadingTests)
import ScriptedEffects (runScriptedEffects)
import IODriverTests (ioDriverTests)
import LibraryProgramTests (maybeTests, providedLibraries, contractsTests, arithmetic)
@@ -55,7 +56,8 @@ main = do
tests :: TestTree
tests = testGroup "Tricu Tests"
- [ runtimePresentationTests
+ [ executableLoadingTests
+ , runtimePresentationTests
, interactionInspectionTests
, packageTests
, evaluationDemandTests
diff --git a/tricu.cabal b/tricu.cabal
@@ -77,6 +77,8 @@ executable tricu
ContentStore.Arboricx
NodeTable
ContentStore.Bundle
+ ContentStore.Indexed
+ ContentStore.Executable
ContentStore.Filesystem
ContentStore.Object
ContentStore.Resolver
@@ -175,12 +177,15 @@ test-suite tricu-tests
InteractionInspection
Module.Provenance
PackageTests
+ ExecutableLoadingTests
InteractionInspectionTests
ContentStore
ContentStore.Alias
ContentStore.Arboricx
NodeTable
ContentStore.Bundle
+ ContentStore.Indexed
+ ContentStore.Executable
ContentStore.Filesystem
ContentStore.Object
ContentStore.Resolver
