tricu

PortableCompilerTests.hs (8431B)

---

 -- 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, doesFileExist)
 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 "compiler protocol selection rejects unsupported versions and packaged relabeling" $ fresh $ \store source -> do
       forM_ [0,3,-1,maxBound] $ \version ->
         rejected "--toolchain-io-version must be" (buildPortableResult
           (defaults {compilerIOVersion = version}) (Just (unStorePath store)) source)
       rejected "IO v1 compilers require a retained v1 runtime" (checkPortableCompiler
         (defaults {compilerIOVersion = 1}) store)
   , testCase "explicit v2 compiler uses OS authority without v1 grants or fallback" $ fresh $ \store source -> do
       manifest <- putManifest store (ModuleManifest [] [])
       receipt <- putObject store receiptDomain "v2 independent receipt"
       let remove = Fork (ofNumber 10) (Fork (ofString "path")
             (Fork (ofNumber 1) (Fork (ofString "remove-file") (ofString source))))
           action = Fork (ofNumber 1) (Fork remove (Fork Leaf (pureAction (success manifest receipt))))
       options <- worker store action
       rejected "retained v1 runtime" (buildPortableResult
         (options {compilerIOVersion = 1}) (Just (unStorePath store)) source)
       doesFileExist source >>= (@?= True)
       checkPortableCompiler (options {compilerIOVersion = 2}) store
       doesFileExist source >>= (@?= True) -- startup verification is inert
       (_,actual,actualReceipt) <- buildPortableResult (options {compilerIOVersion = 2})
         (Just (unStorePath store)) source
       (actual,actualReceipt) @?= (manifest,receipt)
       doesFileExist source >>= (@?= False)
   , testCase "v2 framing never retries retired v1 operations" $ fresh $ \store source -> do
       options <- worker store (Fork (ofNumber 20) (ofString source))
       rejected "Compiler IO error" (buildPortableResult (options {compilerIOVersion = 2})
         (Just (unStorePath store)) source)
       doesFileExist source >>= (@?= True)
   , 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, "IO task failed")] $ \(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 "retained v1 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 "retained v1 runtime" (buildPortableModule (options {compilerIOVersion = 1}) (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 10) (Fork (ofString "clock")
         (Fork (ofNumber 1) (Fork (ofString "sleep") (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 2
 
 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), compilerIOVersion = 2}
 
 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)