tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

PortableCompilerTests.hs (6383B)

      1 -- Artifact-only supervisor controls. These workers are constructed ABI trees,
      2 -- not compilations of either the test source or the compiler implementation.
      3 module PortableCompilerTests (portableCompilerTests) where
      4 
      5 import PortableCompiler
      6 import ContentStore
      7 import Module.Manifest
      8 import Runtime
      9 import Control.Exception (IOException, try)
     10 import Control.Monad (forM_)
     11 import Data.List (isInfixOf)
     12 import qualified Data.ByteString as BS
     13 import qualified Data.Text as Text
     14 import System.Directory (canonicalizePath)
     15 import System.FilePath ((</>))
     16 import System.IO.Temp (withSystemTempDirectory)
     17 import qualified System.Timeout as Timeout
     18 import Test.Tasty
     19 import Test.Tasty.HUnit
     20 
     21 portableCompilerTests :: TestTree
     22 portableCompilerTests = testGroup "portable compiler supervision"
     23   [ testCase "valid publication and explicit selection work without source interpretation" $ fresh $ \store source -> do
     24       manifest <- putManifest store (ModuleManifest [] [])
     25       receipt <- putObject store receiptDomain "independent receipt bytes"
     26       options <- worker store (pureAction (success manifest receipt))
     27       checkPortableCompiler options store
     28       canonical <- canonicalizePath (unStorePath store)
     29       buildPortableResult options (Just (unStorePath store)) source >>=
     30         (@?= (StorePath canonical, manifest, receipt))
     31       portableExports options (Just (unStorePath store)) source >>= (@?= [])
     32   , testCase "invalid options fail at API entry" $ fresh $ \store source -> do
     33       forM_ [0, -1, 86401, maxBound] $ \seconds ->
     34         rejected "--compile-timeout" (buildPortableModule (defaults {compilerSeconds = seconds}) Nothing source)
     35       let invalid = defaults {compilerToolStore = Just (unStorePath store)}
     36       rejected "--tool-store requires --toolchain" (checkPortableCompiler invalid store)
     37   , testCase "explicit missing compiler never falls back to packaged data" $ fresh $ \store source -> do
     38       let options = defaults {compilerManifest = Just (Text.unpack missing)}
     39       rejected "Module manifest not found" (checkPortableCompiler options store)
     40       rejected "Module manifest not found" (buildPortableModule options (Just (unStorePath store)) source)
     41   , testCase "startup verifies the worker export ABI" $ fresh $ \store _ -> do
     42       root <- putTreeTerm store Leaf
     43       pin <- putManifest store (ModuleManifest [] [ModuleExport "sourceBuildGraph"
     44         (ObjectRef (unDomain treeTermDomain) root) "unsupported"])
     45       rejected "Unsupported module export ABI" (checkPortableCompiler
     46         (defaults {compilerManifest = Just (Text.unpack pin)}) store)
     47   , testCase "compiler Results and malformed actions are checked" $ fresh $ \store source -> do
     48       forM_ [(pureAction Leaf, "Invalid portable compiler Result"),
     49              (pureAction (Fork Leaf (Fork (ofString "test failure") Leaf)), "Portable compilation failed"),
     50              (Leaf, "invalid action")] $ \(action, diagnostic) -> do
     51         options <- worker store action
     52         rejected diagnostic (buildPortableModule options (Just (unStorePath store)) source)
     53   , testCase "returned manifest and receipt are authenticated" $ fresh $ \store source -> do
     54       manifest <- putManifest store (ModuleManifest [] [])
     55       receipt <- putObject store receiptDomain "receipt"
     56       let check m r diagnostic = do
     57             options <- worker store (pureAction (success m r))
     58             rejected diagnostic (buildPortableModule options (Just (unStorePath store)) source)
     59       check missing receipt "Module manifest not found"
     60       check manifest missing "Compiler receipt missing"
     61       check manifest "../escape" "Invalid compiler receipt hash"
     62       BS.writeFile (objectPath store receipt) "tampered receipt"
     63       check manifest receipt "Compiler receipt digest mismatch"
     64       BS.writeFile (objectPath store manifest) "tampered manifest"
     65       check manifest receipt "Module manifest digest mismatch"
     66   , testCase "compiler cannot overwrite source files" $ fresh $ \store source -> do
     67       before <- BS.readFile source
     68       options <- worker store (Fork (ofNumber 21)
     69         (Fork (ofString source) (ofString "overwritten")))
     70       rejected "permission denied" (buildPortableModule options (Just (unStorePath store)) source)
     71       BS.readFile source >>= (@?= before)
     72   , testCase "compiler execution remains inside the deadline" $ fresh $ \store source -> do
     73       -- Sleep 60 seconds: scheduler effects are interrupted, not just loading.
     74       options <- worker store (Fork (ofNumber 63) (ofNumber 60000))
     75       -- Startup verifies an inert worker; it must not execute this sleep.
     76       ready <- Timeout.timeout 5000000 (checkPortableCompiler options store)
     77       ready @?= Just ()
     78       completed <- Timeout.timeout 5000000 $ rejected "deadline exceeded"
     79         (buildPortableModule (options {compilerSeconds = 1}) (Just (unStorePath store)) source)
     80       completed @?= Just ()
     81   ]
     82 
     83 fresh :: (StorePath -> FilePath -> IO a) -> IO a
     84 fresh action = withSystemTempDirectory "portable-supervisor" $ \dir -> do
     85   let source = dir </> "module.tri"
     86   -- A supervisor must not interpret this input; only the selected worker may.
     87   BS.writeFile source "deliberately not tricu source"
     88   action (StorePath (dir </> "store")) source
     89 
     90 defaults :: CompilerOptions
     91 defaults = CompilerOptions Nothing Nothing 10 False
     92 
     93 missing :: Text.Text
     94 missing = Text.replicate 64 "0"
     95 
     96 receiptDomain :: Domain
     97 receiptDomain = Domain "arboricx.build-receipt.v1"
     98 
     99 pureAction :: T -> T
    100 pureAction = Fork Leaf
    101 
    102 success :: Text.Text -> Text.Text -> T
    103 success manifest receipt = Fork (Stem Leaf)
    104   (Fork (Fork (ofString (Text.unpack manifest)) (ofString (Text.unpack receipt))) Leaf)
    105 
    106 worker :: StorePath -> T -> IO CompilerOptions
    107 worker store action = do
    108   -- Four ignored build arguments, followed by the bare IO action.
    109   root <- putTreeTerm store (iterate (Fork Leaf) action !! 4)
    110   pin <- putManifest store (ModuleManifest [] [ModuleExport "sourceBuildGraph"
    111     (ObjectRef (unDomain treeTermDomain) root) "arboricx.abi.tree.v1"])
    112   pure defaults {compilerManifest = Just (Text.unpack pin)}
    113 
    114 rejected :: String -> IO a -> Assertion
    115 rejected needle action = do
    116   result <- try (action >> pure ()) :: IO (Either IOException ())
    117   case result of
    118     Left problem -> assertBool (show problem) (needle `isInfixOf` show problem)
    119     Right () -> assertFailure ("accepted invalid input; expected " ++ needle)