ExecutableLoadingTests.hs (6370B)
1 module ExecutableLoadingTests (executableLoadingTests) where 2 3 import ContentStore 4 import ContentStore.Indexed 5 import ContentStore.Executable 6 import Module.Manifest 7 import Runtime 8 import Control.Exception (IOException, try, evaluate) 9 import Control.Monad (forM_) 10 import Data.IORef 11 import Data.List (isInfixOf) 12 import qualified Data.ByteString as BS 13 import qualified Data.Text as Text 14 import System.IO.Temp (withSystemTempDirectory) 15 import System.Mem.StableName (makeStableName) 16 import Test.Tasty 17 import Test.Tasty.HUnit 18 19 executableLoadingTests :: TestTree 20 executableLoadingTests = testGroup "shared production executable loader" $ 21 [ testGroup label 22 [ testCase "object and named export retain value and stage order" $ fresh $ \store -> do 23 ref <- publish store (Fork (Stem Leaf) (Stem Leaf)) 24 pin <- putManifest store (ModuleManifest [] [export "main" ref]) 25 stages <- newIORef [] 26 (identity, value) <- loadVerifiedExportWith (\s -> modifyIORef' stages (++ [s])) store pin "main" 27 identity @?= objectRefHash ref 28 value @?= Fork (Stem Leaf) (Stem Leaf) 29 loadExecutableObject store ref >>= (@?= value) 30 readIORef stages >>= (@?= ["manifest-verified", "executable-read", "executable-digest-verified", "executable-decoded"]) 31 -- Both decoders must retain physical sharing, not expand equal branches. 32 case value of 33 Fork a b -> do 34 _ <- evaluate a 35 _ <- evaluate b 36 x <- makeStableName a 37 y <- makeStableName b 38 assertBool "decoded sharing lost" (x == y) 39 _ -> assertFailure "unexpected decoded root" 40 , testCase "whole interface preserves manifest order and names" $ fresh $ \store -> do 41 ref <- publish store (Stem Leaf) 42 pin <- putManifest store (ModuleManifest [] [export "z" ref, export "a" ref]) 43 loadVerifiedExports store pin >>= (@?= [("z", Stem Leaf), ("a", Stem Leaf)]) 44 rejected "Module export not found" (loadVerifiedExport store pin "absent") 45 , testCase "selection preserves caller order and does not read unselected objects" $ fresh $ \store -> do 46 ref <- publish store Leaf 47 pin <- putManifest store (ModuleManifest [] 48 [export "x" ref, export "missing" (ref {objectRefHash = missing}), export "y" ref]) 49 loadVerifiedExportSelection store pin (Just ["y", "x"]) >>= (@?= [("y", Leaf), ("x", Leaf)]) 50 rejected "not found" (loadVerifiedExports store pin) 51 , testCase "tampering fails before decoding; correct digest is not enough" $ fresh $ \store -> do 52 ref <- publish store Leaf 53 pin <- putManifest store (ModuleManifest [] [export "main" ref]) 54 BS.writeFile (objectPath store (objectRefHash ref)) "invalid bytes" 55 stages <- newIORef [] 56 rejected "Executable tree digest mismatch" $ 57 loadVerifiedExportWith (\s -> modifyIORef' stages (++ [s])) store pin "main" 58 readIORef stages >>= (@?= ["manifest-verified", "executable-read"]) 59 rejected "Executable tree digest mismatch" (loadExecutableObject store ref) 60 bad <- putObject store (Domain (objectRefKind ref)) "invalid bytes" 61 rejected "Invalid executable tree" (loadExecutableObject store (ref {objectRefHash = bad})) 62 , testCase "export ABI checked even when its object is valid" $ fresh $ \store -> do 63 ref <- publish store Leaf 64 pin <- putManifest store (ModuleManifest [] [(export "main" ref) {moduleExportAbi = "unsupported"}]) 65 -- Objects have no export ABI; an object-only success must not bless an export. 66 loadExecutableObject store ref >>= (@?= Leaf) 67 rejected "Unsupported module export ABI" (loadVerifiedExport store pin "main") 68 rejected "Unsupported module export ABI" (loadVerifiedExports store pin) 69 ] 70 | (label, publish) <- [("flat", flat), ("indexed", indexed)] 71 ] ++ [manifestTests] 72 where 73 -- testGroup combines the format matrix with independent manifest controls. 74 manifestTests = testGroup "manifest and object identity controls" 75 [ testCase "missing, malformed and tampered manifest" $ fresh $ \store -> do 76 rejected "not found" (loadVerifiedManifest store missing) 77 rejected "Invalid module manifest hash" (loadVerifiedManifest store "../escape") 78 malformed <- putObject store manifestDomain "not a manifest" 79 rejected "Invalid module manifest" (loadVerifiedManifest store malformed) 80 pin <- putManifest store (ModuleManifest [] []) 81 BS.writeFile (objectPath store pin) "tampered" 82 rejected "Module manifest digest mismatch" (loadVerifiedExports store pin) 83 , testCase "duplicate exports rejected by manifest decoding" $ fresh $ \store -> do 84 ref <- flat store Leaf 85 pin <- putManifest store (ModuleManifest [] [export "main" ref, export "main" ref]) 86 rejected "duplicate" (loadVerifiedExports store pin) 87 , testCase "missing objects, invalid hashes and unsupported kinds" $ fresh $ \store -> do 88 rejected "not found" (loadExecutableObject store (ObjectRef (unDomain treeTermDomain) missing)) 89 forM_ ["../escape", Text.replicate 64 "A"] $ \bad -> 90 rejected "hash" (loadExecutableObject store (ObjectRef (unDomain treeTermDomain) bad)) 91 rejected "Unsupported" (loadExecutableObject store (ObjectRef "unknown" missing)) 92 ] 93 94 fresh :: (StorePath -> IO a) -> IO a 95 fresh action = withSystemTempDirectory "executable-loader" (action . StorePath) 96 97 missing :: Text.Text 98 missing = Text.replicate 64 "0" 99 100 export :: Text.Text -> ObjectRef -> ModuleExport 101 export name ref = ModuleExport name ref "arboricx.abi.tree.v1" 102 103 flat, indexed :: StorePath -> T -> IO ObjectRef 104 flat store tree = ObjectRef (unDomain treeTermDomain) <$> putTreeTerm store tree 105 indexed store tree = do 106 bytes <- encodeIndexedTree tree 107 ObjectRef (unDomain indexedTreeDomain) <$> putObject store indexedTreeDomain bytes 108 109 rejected :: String -> IO a -> Assertion 110 rejected needle action = do 111 result <- try (action >> pure ()) :: IO (Either IOException ()) 112 case result of 113 Left problem -> assertBool (show problem) (needle `isInfixOf` show problem) 114 Right () -> assertFailure ("accepted invalid input; expected " ++ needle)