commit 6b4aabd9ec87d203e2e56a97b2878115e2e68000
parent 93f648715f4fbe4278a773dbe92b70d5637bd408
Author: James Eversole <james@eversole.co>
Date: Wed, 14 Oct 2026 19:39:09 -0500
Extract shared portable compiler supervision from CLI orchestration
Diffstat:
10 files changed, 361 insertions(+), 146 deletions(-)
diff --git a/docs/compiler.md b/docs/compiler.md
@@ -190,6 +190,20 @@ library tests may instead apply published trees directly.
The `ast` display format renders tree constructors directly, without constructing
source ASTs.
+`ContentStore.Executable` shares authenticated flat/indexed loading across host
+entrypoints. Object loading checks kind, identity and encoding; named export
+loading additionally authenticates the manifest and checks the export ABI.
+Whole-interface and selected-export loads authenticate the manifest once. The
+streaming flat-bundle packer remains separate: it must not reconstruct expanded
+trees just to reuse the executable loader.
+
+`PortableCompiler` supervises tool selection, loading, deadlines, restricted IO
+and publication verification for file compilation and interactive sessions. It
+owns no source semantics. Its failures are IO errors; CLI and REPL boundaries
+choose how to report them rather than library code terminating the process.
+REPL startup authenticates the selected worker under the compiler deadline,
+without applying it. Explicit toolchains never fall back to packaged data.
+
`Runtime.Tree.T` has lazy constructor fields, and `Runtime.Tree.apply` implements the
kernel rules without an explicit application/thunk node. Pending reductions
live in Haskell thunks. Constructor application returns an outer Stem/Fork without
diff --git a/docs/validation.md b/docs/validation.md
@@ -85,6 +85,29 @@ The compiled-source smoke example is in
It checks the native compiler-to-inspector path separately from independent wire
fixtures; inspection itself never loads a compiler or executes an exported tree.
+### Host loading and compiler supervision
+
+The default Haskell tests directly exercise the production loader with flat and
+indexed objects: digest and ABI rejection, malformed and missing objects,
+manifest rejection, retained sharing, profiling-stage order, and selected exports
+that do not read unrelated objects. Whole-interface loading retains manifest order.
+
+Supervisor tests use constructed ABI workers, not fresh compiler bootstraps.
+They check explicit selection, option validation, Result and publication
+validation, source-write denial, and a deadline that interrupts a sleeping worker.
+The default-frontend and portable-CLI probes additionally exercise real source
+compilation, REPL transactions, cache identities and compiler profiling:
+
+```sh
+nix build .#
+python3 test/executable_arguments.py result/bin/tricu
+python3 test/default_frontend.py result/bin/tricu
+python3 test/portable_cli.py result/bin/tricu \
+ --compiler-bundle bootstrap/build-stable.arboricx
+```
+
+These checks do not regenerate the compiler or publish fixtures.
+
### Current-source IO dependencies
```sh
diff --git a/src/ContentStore/Executable.hs b/src/ContentStore/Executable.hs
@@ -2,7 +2,7 @@
-- only a module export supplies an ABI. Failures are IO errors, not process exits.
module ContentStore.Executable
( loadVerifiedManifest, loadVerifiedExport, loadVerifiedExportWith
- , loadVerifiedExports, loadExecutableObject ) where
+ , loadVerifiedExports, loadVerifiedExportSelection, loadExecutableObject ) where
import ContentStore.Object
import ContentStore.Filesystem (getObject)
@@ -38,10 +38,22 @@ loadVerifiedExportWith sample store manifestHash name = do
loadVerifiedExports :: StorePath -> T.Text -> IO [(String, Tree.T)]
loadVerifiedExports store pin = do
+ exports <- loadVerifiedExportSelection store pin Nothing
+ pure [(T.unpack name, term) | (name, term) <- exports]
+
+-- Nothing selects the complete interface in manifest order. An explicit list
+-- loads only those names, in caller order; unrelated export objects stay unread.
+loadVerifiedExportSelection :: StorePath -> T.Text -> Maybe [T.Text] -> IO [(T.Text, Tree.T)]
+loadVerifiedExportSelection store pin selection = do
manifest <- loadVerifiedManifest store pin
- forM (moduleManifestExports manifest) $ \ex -> do
- (_, term) <- loadModuleExport (const $ pure ()) store ex
- pure (T.unpack (moduleExportName ex), term)
+ let sample = const $ pure ()
+ case selection of
+ Nothing -> forM (moduleManifestExports manifest) $ \ex -> do
+ (_, term) <- loadModuleExport sample store ex
+ pure (moduleExportName ex, term)
+ Just names -> forM names $ \name -> do
+ (_, term) <- loadManifestExport sample store manifest name
+ pure (name, term)
-- Internal: the manifest must have passed authentication and decoding above.
loadManifestExport :: (String -> IO ()) -> StorePath -> ModuleManifest -> T.Text -> IO (ObjectHash, Tree.T)
diff --git a/src/ContentStore/Filesystem.hs b/src/ContentStore/Filesystem.hs
@@ -3,6 +3,7 @@ module ContentStore.Filesystem
, getVerifiedObject
, getObject
, objectPath
+ , resolveStorePath
, ensureStore
) where
@@ -10,7 +11,7 @@ import ContentStore.Object
import Control.Monad (unless, when)
import Data.Text (unpack)
-import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile, renameFile)
+import System.Directory (getHomeDirectory, createDirectoryIfMissing, doesFileExist, removeFile, renameFile)
import System.FilePath ((</>))
import System.IO (hClose, openBinaryTempFile)
@@ -73,3 +74,9 @@ getVerifiedObject store domain h = do
Just bytes -> do
either fail pure (verifyObjectBytes domain h bytes)
pure (Just bytes)
+
+resolveStorePath :: Maybe FilePath -> IO StorePath
+resolveStorePath (Just path) = return (StorePath path)
+resolveStorePath Nothing = do
+ home <- getHomeDirectory
+ return (StorePath (home </> ".tricu" </> "store"))
diff --git a/src/Main.hs b/src/Main.hs
@@ -13,7 +13,8 @@ import System.IO.Error (ioeGetErrorString)
import System.Exit (die, exitFailure)
import IODriver (IOPermissions(..), runIO, YieldStats(..), runIOWithYieldStatsHook)
import REPL (portableRepl)
-import Runtime (T(..), EvaluatedForm(..), formatT, exportDag, apply, ofString, ofNumber, toString)
+import PortableCompiler
+import Runtime (T(..), EvaluatedForm(..), formatT, exportDag, apply, ofString, toString)
import qualified Wire
import Wire (encodeBundle, buildBundleShared, defaultExportNames, Bundle(..))
import TreeObservation (forceTreeShared)
@@ -25,7 +26,7 @@ import Data.List (sortOn)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Version (showVersion)
-import Paths_tricu (version, getDataFileName)
+import Paths_tricu (version)
import Crypto.Hash (hash, Digest, SHA256)
import System.IO.Temp (withSystemTempDirectory, withTempFile)
import Options.Applicative
@@ -34,9 +35,9 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Sequence as Seq
import qualified Data.Map as Map
-import System.Directory (createDirectoryIfMissing, getHomeDirectory, getCurrentDirectory,
+import System.Directory (createDirectoryIfMissing, getCurrentDirectory,
renameFile, removeFile, pathIsSymbolicLink, doesPathExist, doesFileExist, canonicalizePath)
-import System.FilePath (takeBaseName, takeDirectory, takeExtension, (</>))
+import System.FilePath (takeBaseName, takeDirectory, (</>))
import System.Timeout (timeout)
import System.IO (openBinaryTempFile, hClose, hFlush, hPutStrLn, stdout, stderr, withBinaryFile, IOMode(ReadMode))
import qualified Data.Aeson as JSON
@@ -63,15 +64,6 @@ data StoredArgument
| ExportArgument String
deriving (Show)
--- Explicit artifact selection; absence selects the packaged stable compiler.
--- Tool stores are never populated by implicit source loading.
-data CompilerOptions = CompilerOptions
- { compilerManifest :: Maybe String
- , compilerToolStore :: Maybe FilePath
- , compilerSeconds :: Int
- , compilerProfile :: Bool
- } deriving (Show)
-
data TricuArgs
= PackageCommand PackageArgs
| ProjectCommand ProjectArgs
@@ -725,13 +717,7 @@ runReplWithOptions mStore options = do
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
-- Fail at startup, even for an empty session, if the installation is broken.
store <- resolveStorePath mStore
- case compilerManifest options of
- Nothing -> do
- _ <- packagedCompiler store
- pure ()
- Just pin -> do
- _ <- loadVerifiedExport (maybe store StorePath $ compilerToolStore options) (T.pack pin) "sourceBuildGraph"
- pure ()
+ checkPortableCompiler options store
portableRepl store (\active source -> do
directory <- getCurrentDirectory
withTempFile directory "tricu_repl.tri" $ \path handle -> do
@@ -858,16 +844,11 @@ runCompile opts = do
target <- canonicalizePath out
when (source == target) $ die "Bundle output must not replace its source"
(store, manifestHash) <- buildPortableModule (compileCompiler opts) (compileStore opts) input
- manifest <- loadVerifiedManifest store manifestHash
- let selected = if null names
- then map moduleExportName (moduleManifestExports manifest)
- else nameTexts
- when (null selected) $ die "Portable module has no exports"
- when (length selected /= Map.size (Map.fromList [(name, ()) | name <- selected])) $
+ when (length nameTexts /= Map.size (Map.fromList [(name, ()) | name <- nameTexts])) $
die "Duplicate --name selection"
- terms <- forM selected $ \name -> do
- (_, term) <- loadVerifiedExport store manifestHash name
- pure (name, term)
+ terms <- loadVerifiedExportSelection store manifestHash
+ (if null names then Nothing else Just nameTexts)
+ when (null terms) $ die "Portable module has no exports"
bundle <- buildBundleShared terms
BS.writeFile out (encodeBundle bundle)
@@ -967,111 +948,6 @@ runStored opts = do
putStrLn "RUN_DONE"
-- One digest/kind/ABI-verified boundary for runtime execution and tooling.
--- 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.
-packagedCompilerSha256 :: String
-packagedCompilerSha256 = "5d36d069562ca9b208cfd0aa8df9f0d3b5c39f8b13e070fb892e21b38e32ffb4"
-
-packagedCompiler :: StorePath -> IO T.Text
-packagedCompiler store = do
- path <- getDataFileName "bootstrap/build-stable.arboricx"
- bytes <- BS.readFile path `catch` (\(err :: IOException) ->
- die $ "Packaged stable compiler unavailable at " ++ path ++ ": " ++ show err)
- unless (show (hash bytes :: Digest SHA256) == packagedCompilerSha256) $
- die "Packaged stable compiler SHA256 mismatch; reinstall or select --toolchain explicitly"
- roots <- unpackIndexedBundleToStore store bytes
- putManifest store (ModuleManifest []
- [ModuleExport name (ObjectRef (unDomain indexedTreeDomain) root)
- "arboricx.abi.tree.v1" | (name, root) <- roots])
-
-portableExports :: CompilerOptions -> Maybe FilePath -> FilePath -> IO [(String, Runtime.T)]
-portableExports options selected path = do
- (store, pin) <- buildPortableModule options selected path
- loadVerifiedExports store pin
-
-validateCompilerOptions :: CompilerOptions -> IO ()
-validateCompilerOptions options = do
- when (compilerManifest options == Nothing && compilerToolStore options /= Nothing) $
- die "--tool-store requires --toolchain"
- unless (compilerSeconds options >= 1 && compilerSeconds options <= 86400) $
- die "--compile-timeout must be between 1 and 86400 seconds"
-
--- Native flat-workspace profile: the selected file supplies the directory and
--- target name; local import/re-export edges select NAME.tri within that explicit base.
--- All header staging, scope, compilation, publication and cache policy is tricu.
-buildPortableModule :: CompilerOptions -> Maybe FilePath -> FilePath -> IO (StorePath, T.Text)
-buildPortableModule options appStore input = do
- (store,manifest,_) <- buildPortableResult options appStore input
- pure (store,manifest)
-
--- Keep the compiler-returned receipt available to reproduction tooling instead
--- of recovering execution evidence from a mutable cache locator afterward.
-buildPortableResult :: CompilerOptions -> Maybe FilePath -> FilePath -> IO (StorePath, T.Text, T.Text)
-buildPortableResult options appStore input = do
- when (compilerProfile options) $ do
- enabled <- getRTSStatsEnabled
- unless enabled $ die "--compile-profile requires +RTS -T"
- let sample label = when (compilerProfile options) (compilerSample label)
- sample "begin"
- source <- canonicalizePath input
- unless (takeExtension source == ".tri") $ die "Portable compilation requires a .tri module file"
- store0 <- resolveStorePath appStore
- createDirectoryIfMissing True (unStorePath store0)
- root <- canonicalizePath (unStorePath store0)
- let store = StorePath root
- directory = takeDirectory source
- name = takeBaseName source
- tools <- maybe (pure store) (pure . StorePath) (compilerToolStore options)
- built <- timeout (compilerSeconds options * 1000000) $ do
- pin <- case compilerManifest options of
- Just selected -> pure (T.pack selected)
- Nothing -> packagedCompiler tools
- (identity, worker) <- loadVerifiedExportWith sample tools pin "sourceBuildGraph"
- let compilerIdentity = case compilerManifest options of
- Nothing -> packagedCompilerSha256
- Just _ -> T.unpack identity
- action = foldl apply worker (map ofString
- [directory, root, compilerIdentity, name])
- permissions = IOPermissions [directory, root] [root] False False
- -- sourceBuildGraph returns a bare v1 action; this is transport framing,
- -- not source compilation or a source-loaded IO adapter.
- let envelope = Fork (ofString "tricuIO") (Fork (ofNumber 1) action)
- output <- runIO permissions envelope >>= either (die . ("Compiler IO error: " ++)) pure
- sample "build-returned"
- case output of
- Fork (Stem Leaf) (Fork (Fork manifest receipt) _) -> do
- manifestHash <- either (die . ("Invalid compiler manifest output: " ++)) (pure . T.pack)
- (toString manifest)
- receiptHash <- either (die . ("Invalid compiler receipt output: " ++)) (pure . T.pack)
- (toString receipt)
- _ <- loadVerifiedManifest store manifestHash
- either (die . ("Invalid compiler receipt hash: " ++)) pure (textToHashBytes receiptHash)
- receiptBytes <- getObject store receiptHash >>= maybe (die "Compiler receipt missing") pure
- unless (hashObject (Domain "arboricx.build-receipt.v1") receiptBytes == receiptHash) $
- die "Compiler receipt digest mismatch"
- pure (manifestHash,receiptHash)
- Fork Leaf (Fork problem _) -> die $ "Portable compilation failed: " ++ formatT Decode problem
- _ -> die "Invalid portable compiler Result"
- (manifest,receipt) <- maybe (die "Portable compiler load/build deadline exceeded") pure built
- sample "publication-verified"
- pure (store, manifest,receipt)
-
--- Lightweight stage samples: no forced collection or expanded-tree traversal.
--- Allocation/live counters reflect the most recent RTS collection.
-compilerSample :: String -> IO ()
-compilerSample label = do
- wall <- getMonotonicTimeNSec
- stats <- getRTSStats
- BL.hPutStr stderr (JSON.encode (JSON.object
- [ "compiler_stage" JSON..= label
- , "wall_ns" JSON..= wall
- , "allocated_bytes" JSON..= allocated_bytes stats
- , "live_bytes" JSON..= gcdetails_live_bytes (gc stats)
- , "gc_elapsed_ns" JSON..= gc_elapsed_ns stats
- ]))
- BL.hPutStr stderr "\n"
-
-- Each sample forces a major collection. Deltas include sampling overhead;
-- yielded samples retain the scheduler's pending work. Rendering follows timing.
profileSample :: String -> Maybe YieldStats -> IO ()
@@ -1219,12 +1095,6 @@ runExportDag opts = do
-- Helpers
-- ---------------------------------------------------------------------------
-resolveStorePath :: Maybe FilePath -> IO StorePath
-resolveStorePath (Just path) = return (StorePath path)
-resolveStorePath Nothing = do
- home <- getHomeDirectory
- return (StorePath (home </> ".tricu" </> "store"))
-
treeTermRef :: ObjectHash -> ObjectRef
treeTermRef = ObjectRef (unDomain treeTermDomain)
diff --git a/src/PortableCompiler.hs b/src/PortableCompiler.hs
@@ -0,0 +1,159 @@
+-- Host supervision of an authenticated portable compiler, not source semantics.
+-- Errors are IO failures so CLI, REPL and tests choose their own presentation.
+module PortableCompiler
+ ( CompilerOptions(..), validateCompilerOptions, checkPortableCompiler
+ , buildPortableModule, buildPortableResult, portableExports
+ ) where
+
+import ContentStore
+import ContentStore.Bundle (unpackIndexedBundleToStore, indexedTreeDomain)
+import ContentStore.Executable
+import Module.Manifest
+import Runtime (T(..), EvaluatedForm(Decode), apply, ofString, ofNumber, toString, formatT)
+import IODriver (IOPermissions(..), runIO)
+import Paths_tricu (getDataFileName)
+import Crypto.Hash (Digest, SHA256, hash)
+import Control.Exception (IOException, catch)
+import Control.Monad (when, unless)
+import System.Directory (canonicalizePath, createDirectoryIfMissing)
+import System.FilePath (takeExtension, takeDirectory, takeBaseName)
+import System.Timeout (timeout)
+import System.IO (stderr)
+import GHC.Clock (getMonotonicTimeNSec)
+import GHC.Stats
+import qualified Data.Text as T
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Aeson as JSON
+
+-- Explicit artifact selection; absence selects the packaged stable compiler.
+-- Tool stores are never populated by implicit source loading.
+data CompilerOptions = CompilerOptions
+ { compilerManifest :: Maybe String
+ , compilerToolStore :: Maybe FilePath
+ , compilerSeconds :: Int
+ , compilerProfile :: Bool
+ } deriving (Show)
+
+-- Startup and actual compilation use the same artifact selection, validation
+-- and load deadline. Neither path may fall back from an explicit toolchain.
+checkPortableCompiler :: CompilerOptions -> StorePath -> IO ()
+checkPortableCompiler options store = do
+ validateCompilerOptions options
+ compilerDeadline options $ do
+ _ <- loadCompiler (const $ pure ()) options store
+ pure ()
+
+compilerDeadline :: CompilerOptions -> IO a -> IO a
+compilerDeadline options action = do
+ result <- timeout (compilerSeconds options * 1000000) action
+ maybe (fail "Portable compiler load/build deadline exceeded") pure result
+
+loadCompiler :: (String -> IO ()) -> CompilerOptions -> StorePath -> IO (String, Runtime.T)
+loadCompiler sample options store = do
+ let tools = maybe store StorePath (compilerToolStore options)
+ pin <- maybe (packagedCompiler tools) (pure . T.pack) (compilerManifest options)
+ (identity, worker) <- loadVerifiedExportWith sample tools pin "sourceBuildGraph"
+ pure (case compilerManifest options of
+ Nothing -> packagedCompilerSha256
+ Just _ -> T.unpack identity, worker)
+
+-- 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.
+packagedCompilerSha256 :: String
+packagedCompilerSha256 = "5d36d069562ca9b208cfd0aa8df9f0d3b5c39f8b13e070fb892e21b38e32ffb4"
+
+packagedCompiler :: StorePath -> IO T.Text
+packagedCompiler store = do
+ path <- getDataFileName "bootstrap/build-stable.arboricx"
+ bytes <- BS.readFile path `catch` (\(err :: IOException) ->
+ fail $ "Packaged stable compiler unavailable at " ++ path ++ ": " ++ show err)
+ unless (show (hash bytes :: Digest SHA256) == packagedCompilerSha256) $
+ fail "Packaged stable compiler SHA256 mismatch; reinstall or select --toolchain explicitly"
+ roots <- unpackIndexedBundleToStore store bytes
+ putManifest store (ModuleManifest []
+ [ModuleExport name (ObjectRef (unDomain indexedTreeDomain) root)
+ "arboricx.abi.tree.v1" | (name, root) <- roots])
+
+portableExports :: CompilerOptions -> Maybe FilePath -> FilePath -> IO [(String, Runtime.T)]
+portableExports options selected path = do
+ (store, pin) <- buildPortableModule options selected path
+ loadVerifiedExports store pin
+
+validateCompilerOptions :: CompilerOptions -> IO ()
+validateCompilerOptions options = do
+ when (compilerManifest options == Nothing && compilerToolStore options /= Nothing) $
+ fail "--tool-store requires --toolchain"
+ unless (compilerSeconds options >= 1 && compilerSeconds options <= 86400) $
+ fail "--compile-timeout must be between 1 and 86400 seconds"
+
+-- Native flat-workspace profile: the selected file supplies the directory and
+-- target name; local import/re-export edges select NAME.tri within that explicit base.
+-- All header staging, scope, compilation, publication and cache policy is tricu.
+buildPortableModule :: CompilerOptions -> Maybe FilePath -> FilePath -> IO (StorePath, T.Text)
+buildPortableModule options appStore input = do
+ (store,manifest,_) <- buildPortableResult options appStore input
+ pure (store,manifest)
+
+-- Keep the compiler-returned receipt available to reproduction tooling instead
+-- of recovering execution evidence from a mutable cache locator afterward.
+buildPortableResult :: CompilerOptions -> Maybe FilePath -> FilePath -> IO (StorePath, T.Text, T.Text)
+buildPortableResult options appStore input = do
+ validateCompilerOptions options
+ when (compilerProfile options) $ do
+ enabled <- getRTSStatsEnabled
+ unless enabled $ fail "--compile-profile requires +RTS -T"
+ let sample label = when (compilerProfile options) (compilerSample label)
+ sample "begin"
+ source <- canonicalizePath input
+ unless (takeExtension source == ".tri") $ fail "Portable compilation requires a .tri module file"
+ store0 <- resolveStorePath appStore
+ createDirectoryIfMissing True (unStorePath store0)
+ root <- canonicalizePath (unStorePath store0)
+ let store = StorePath root
+ directory = takeDirectory source
+ name = takeBaseName source
+ built <- compilerDeadline options $ do
+ (compilerIdentity, worker) <- loadCompiler sample options store
+ let action = foldl apply worker (map ofString
+ [directory, root, compilerIdentity, name])
+ permissions = IOPermissions [directory, root] [root] False False
+ -- sourceBuildGraph returns a bare v1 action; this is transport framing,
+ -- not source compilation or a source-loaded IO adapter.
+ let envelope = Fork (ofString "tricuIO") (Fork (ofNumber 1) action)
+ output <- runIO permissions envelope >>= either (fail . ("Compiler IO error: " ++)) pure
+ sample "build-returned"
+ case output of
+ Fork (Stem Leaf) (Fork (Fork manifest receipt) _) -> do
+ manifestHash <- either (fail . ("Invalid compiler manifest output: " ++)) (pure . T.pack)
+ (toString manifest)
+ receiptHash <- either (fail . ("Invalid compiler receipt output: " ++)) (pure . T.pack)
+ (toString receipt)
+ _ <- loadVerifiedManifest store manifestHash
+ either (fail . ("Invalid compiler receipt hash: " ++)) pure (textToHashBytes receiptHash)
+ receiptBytes <- getObject store receiptHash >>= maybe (fail "Compiler receipt missing") pure
+ unless (hashObject (Domain "arboricx.build-receipt.v1") receiptBytes == receiptHash) $
+ fail "Compiler receipt digest mismatch"
+ pure (manifestHash,receiptHash)
+ Fork Leaf (Fork problem _) -> fail $ "Portable compilation failed: " ++ formatT Decode problem
+ _ -> fail "Invalid portable compiler Result"
+ let (manifest,receipt) = built
+ sample "publication-verified"
+ pure (store, manifest,receipt)
+
+-- Lightweight stage samples: no forced collection or expanded-tree traversal.
+-- Allocation/live counters reflect the most recent RTS collection.
+compilerSample :: String -> IO ()
+compilerSample label = do
+ wall <- getMonotonicTimeNSec
+ stats <- getRTSStats
+ BL.hPutStr stderr (JSON.encode (JSON.object
+ [ "compiler_stage" JSON..= label
+ , "wall_ns" JSON..= wall
+ , "allocated_bytes" JSON..= allocated_bytes stats
+ , "live_bytes" JSON..= gcdetails_live_bytes (gc stats)
+ , "gc_elapsed_ns" JSON..= gc_elapsed_ns stats
+ ]))
+ BL.hPutStr stderr "\n"
+
diff --git a/test/ExecutableLoadingTests.hs b/test/ExecutableLoadingTests.hs
@@ -42,6 +42,12 @@ executableLoadingTests = testGroup "shared production executable loader" $
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 "selection preserves caller order and does not read unselected objects" $ fresh $ \store -> do
+ ref <- publish store Leaf
+ pin <- putManifest store (ModuleManifest []
+ [export "x" ref, export "missing" (ref {objectRefHash = missing}), export "y" ref])
+ loadVerifiedExportSelection store pin (Just ["y", "x"]) >>= (@?= [("y", Leaf), ("x", Leaf)])
+ rejected "not found" (loadVerifiedExports store pin)
, testCase "tampering fails before decoding; correct digest is not enough" $ fresh $ \store -> do
ref <- publish store Leaf
pin <- putManifest store (ModuleManifest [] [export "main" ref])
diff --git a/test/PortableCompilerTests.hs b/test/PortableCompilerTests.hs
@@ -0,0 +1,119 @@
+-- Artifact-only supervisor controls. These workers are constructed ABI trees,
+-- not compilations of either the test source or the compiler implementation.
+module PortableCompilerTests (portableCompilerTests) where
+
+import PortableCompiler
+import ContentStore
+import Module.Manifest
+import Runtime
+import Control.Exception (IOException, try)
+import Control.Monad (forM_)
+import Data.List (isInfixOf)
+import qualified Data.ByteString as BS
+import qualified Data.Text as Text
+import System.Directory (canonicalizePath)
+import System.FilePath ((</>))
+import System.IO.Temp (withSystemTempDirectory)
+import qualified System.Timeout as Timeout
+import Test.Tasty
+import Test.Tasty.HUnit
+
+portableCompilerTests :: TestTree
+portableCompilerTests = testGroup "portable compiler supervision"
+ [ testCase "valid publication and explicit selection work without source interpretation" $ fresh $ \store source -> do
+ manifest <- putManifest store (ModuleManifest [] [])
+ receipt <- putObject store receiptDomain "independent receipt bytes"
+ options <- worker store (pureAction (success manifest receipt))
+ checkPortableCompiler options store
+ canonical <- canonicalizePath (unStorePath store)
+ buildPortableResult options (Just (unStorePath store)) source >>=
+ (@?= (StorePath canonical, manifest, receipt))
+ portableExports options (Just (unStorePath store)) source >>= (@?= [])
+ , testCase "invalid options fail at API entry" $ fresh $ \store source -> do
+ forM_ [0, -1, 86401, maxBound] $ \seconds ->
+ rejected "--compile-timeout" (buildPortableModule (defaults {compilerSeconds = seconds}) Nothing source)
+ let invalid = defaults {compilerToolStore = Just (unStorePath store)}
+ rejected "--tool-store requires --toolchain" (checkPortableCompiler invalid store)
+ , testCase "explicit missing compiler never falls back to packaged data" $ fresh $ \store source -> do
+ let options = defaults {compilerManifest = Just (Text.unpack missing)}
+ rejected "Module manifest not found" (checkPortableCompiler options store)
+ rejected "Module manifest not found" (buildPortableModule options (Just (unStorePath store)) source)
+ , testCase "startup verifies the worker export ABI" $ fresh $ \store _ -> do
+ root <- putTreeTerm store Leaf
+ pin <- putManifest store (ModuleManifest [] [ModuleExport "sourceBuildGraph"
+ (ObjectRef (unDomain treeTermDomain) root) "unsupported"])
+ rejected "Unsupported module export ABI" (checkPortableCompiler
+ (defaults {compilerManifest = Just (Text.unpack pin)}) store)
+ , testCase "compiler Results and malformed actions are checked" $ fresh $ \store source -> do
+ forM_ [(pureAction Leaf, "Invalid portable compiler Result"),
+ (pureAction (Fork Leaf (Fork (ofString "test failure") Leaf)), "Portable compilation failed"),
+ (Leaf, "invalid action")] $ \(action, diagnostic) -> do
+ options <- worker store action
+ rejected diagnostic (buildPortableModule options (Just (unStorePath store)) source)
+ , testCase "returned manifest and receipt are authenticated" $ fresh $ \store source -> do
+ manifest <- putManifest store (ModuleManifest [] [])
+ receipt <- putObject store receiptDomain "receipt"
+ let check m r diagnostic = do
+ options <- worker store (pureAction (success m r))
+ rejected diagnostic (buildPortableModule options (Just (unStorePath store)) source)
+ check missing receipt "Module manifest not found"
+ check manifest missing "Compiler receipt missing"
+ check manifest "../escape" "Invalid compiler receipt hash"
+ BS.writeFile (objectPath store receipt) "tampered receipt"
+ check manifest receipt "Compiler receipt digest mismatch"
+ BS.writeFile (objectPath store manifest) "tampered manifest"
+ check manifest receipt "Module manifest digest mismatch"
+ , testCase "compiler cannot overwrite source files" $ fresh $ \store source -> do
+ before <- BS.readFile source
+ options <- worker store (Fork (ofNumber 21)
+ (Fork (ofString source) (ofString "overwritten")))
+ rejected "permission denied" (buildPortableModule options (Just (unStorePath store)) source)
+ BS.readFile source >>= (@?= before)
+ , testCase "compiler execution remains inside the deadline" $ fresh $ \store source -> do
+ -- Sleep 60 seconds: scheduler effects are interrupted, not just loading.
+ options <- worker store (Fork (ofNumber 63) (ofNumber 60000))
+ -- Startup verifies an inert worker; it must not execute this sleep.
+ ready <- Timeout.timeout 5000000 (checkPortableCompiler options store)
+ ready @?= Just ()
+ completed <- Timeout.timeout 5000000 $ rejected "deadline exceeded"
+ (buildPortableModule (options {compilerSeconds = 1}) (Just (unStorePath store)) source)
+ completed @?= Just ()
+ ]
+
+fresh :: (StorePath -> FilePath -> IO a) -> IO a
+fresh action = withSystemTempDirectory "portable-supervisor" $ \dir -> do
+ let source = dir </> "module.tri"
+ -- A supervisor must not interpret this input; only the selected worker may.
+ BS.writeFile source "deliberately not tricu source"
+ action (StorePath (dir </> "store")) source
+
+defaults :: CompilerOptions
+defaults = CompilerOptions Nothing Nothing 10 False
+
+missing :: Text.Text
+missing = Text.replicate 64 "0"
+
+receiptDomain :: Domain
+receiptDomain = Domain "arboricx.build-receipt.v1"
+
+pureAction :: T -> T
+pureAction = Fork Leaf
+
+success :: Text.Text -> Text.Text -> T
+success manifest receipt = Fork (Stem Leaf)
+ (Fork (Fork (ofString (Text.unpack manifest)) (ofString (Text.unpack receipt))) Leaf)
+
+worker :: StorePath -> T -> IO CompilerOptions
+worker store action = do
+ -- Four ignored build arguments, followed by the bare IO action.
+ root <- putTreeTerm store (iterate (Fork Leaf) action !! 4)
+ pin <- putManifest store (ModuleManifest [] [ModuleExport "sourceBuildGraph"
+ (ObjectRef (unDomain treeTermDomain) root) "arboricx.abi.tree.v1"])
+ pure defaults {compilerManifest = Just (Text.unpack pin)}
+
+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 PortableCompilerTests (portableCompilerTests)
import ExecutableLoadingTests (executableLoadingTests)
import ScriptedEffects (runScriptedEffects)
import IODriverTests (ioDriverTests)
@@ -56,7 +57,8 @@ main = do
tests :: TestTree
tests = testGroup "Tricu Tests"
- [ executableLoadingTests
+ [ portableCompilerTests
+ , executableLoadingTests
, runtimePresentationTests
, interactionInspectionTests
, packageTests
diff --git a/tricu.cabal b/tricu.cabal
@@ -86,6 +86,7 @@ executable tricu
Module.Manifest
Paths_tricu
REPL
+ PortableCompiler
Runtime
Runtime.Tree
Runtime.Value
@@ -178,6 +179,7 @@ test-suite tricu-tests
Module.Provenance
PackageTests
ExecutableLoadingTests
+ PortableCompilerTests
InteractionInspectionTests
ContentStore
ContentStore.Alias
@@ -193,6 +195,7 @@ test-suite tricu-tests
Module.Manifest
Paths_tricu
REPL
+ PortableCompiler
Runtime
Runtime.Tree
Runtime.Value
