ReferenceFixtures.hs (5343B)
1 -- Authenticated retained library artifacts. This module does not compile source 2 -- or recreate source import scopes. SupportFixture proves conservative reuse 3 -- by complete provider identity, without recovery parsing or scope analysis. 4 module ReferenceFixtures 5 ( compilerFixture, supportFixture, compiledLibraries, fixtureExports ) where 6 7 import Runtime (Env) 8 import Wire 9 import ContentStore (hashObject, Domain(..)) 10 import SupportFixture (verifyMixedSupport, readFixtureSourceBytes) 11 import Control.Exception (evaluate) 12 import Control.Monad (forM_, unless) 13 import Data.List (isPrefixOf) 14 import Data.Text (pack, unpack) 15 import System.IO.Unsafe (unsafePerformIO) 16 import qualified Data.ByteString as BS 17 import qualified Data.Map as Map 18 import qualified Data.Vector as V 19 20 -- The fast gate executes self-built library trees rather than asking the old 21 -- recovery frontend to parse compiler sources. Every mapped reference source is 22 -- authenticated independently of working-tree edits. The explicit freshness gate 23 -- rejects stale cohorts at batch acceptance; these are reference-artifact tests. 24 compilerFixture :: ([(String, String, FilePath)], Env) 25 compilerFixture = unsafePerformIO $ do 26 metadata <- lines <$> readFile "./test/fixtures/compiler-library.v1" 27 bytes <- BS.readFile "./test/fixtures/compiler-library.arboricx" 28 unless (take 1 metadata == ["tricu.compiler-library-fixture.v1"]) $ 29 error "invalid compiler fixture metadata" 30 let rows = [ (legacy, alias, path, digest) 31 | row <- tail metadata 32 , ["module", legacy, alias, path, digest] <- [words row] ] 33 bundleHash = unpack (hashObject (Domain (pack "tricu.compiler-library-fixture.v1")) bytes) 34 unless (["bundle", bundleHash] `elem` map words metadata) $ 35 error "compiler fixture bundle digest mismatch" 36 forM_ rows $ \(_, _, path, digest) -> do 37 source <- readFixtureSourceBytes path 38 unless (unpack (hashObject (Domain (pack "arboricx.source.v1")) source) == digest) $ 39 error ("mismatched compiler reference source for " ++ path ++ 40 "; authenticate the fixture source snapshot") 41 bundle <- either error pure (decodeBundle bytes) 42 either error pure (verifyBundle bundle) 43 let terms = reconstructBundleTerms (bundleNodes bundle) 44 env = Map.fromList 45 [ (unpack (exportName entry), terms V.! fromIntegral (exportRoot entry)) 46 | entry <- manifestExports (bundleManifest bundle) ] 47 pure ([(legacy, alias, path) | (legacy, alias, path, _) <- rows], env) 48 {-# NOINLINE compilerFixture #-} 49 50 -- Real portable builds own these unmapped general-purpose libraries. Loading 51 -- verifies authored inputs and the dependency compiler fixture; no body compiler. 52 supportFixture :: ([(String, String, FilePath)], Env) 53 supportFixture = unsafePerformIO $ do 54 metadata <- lines <$> readFile "./test/fixtures/support-library.v1" 55 bytes <- BS.readFile "./test/fixtures/support-library.arboricx" 56 compilerBytes <- BS.readFile "./test/fixtures/compiler-library.arboricx" 57 unless (take 1 metadata `elem` [["tricu.support-library-fixture.v1"], ["tricu.support-library-fixture.v2"], ["tricu.support-library-fixture.v3"]]) $ 58 error "invalid support fixture metadata" 59 let rows = [(legacy, alias, path, digest) | row <- tail metadata, 60 ["module", legacy, alias, path, digest] <- [words row]] 61 objectHash domain value = unpack (hashObject (Domain (pack domain)) value) 62 unless (["bundle", objectHash "tricu.support-library-fixture.v1" bytes] `elem` map words metadata) $ 63 error "support fixture bundle digest mismatch" 64 unless (["compiler-fixture", objectHash "tricu.compiler-library-fixture.v1" compilerBytes] `elem` map words metadata) $ 65 error "support fixture dependency mismatch" 66 if take 1 metadata `elem` [["tricu.support-library-fixture.v2"], ["tricu.support-library-fixture.v3"]] 67 then verifyMixedSupport metadata bytes compilerBytes 68 else pure () 69 _ <- evaluate (length (fst compilerFixture)) 70 forM_ rows $ \(_, _, path, digest) -> do 71 source <- readFixtureSourceBytes path 72 unless (objectHash "arboricx.source.v1" source == digest) $ 73 error ("mismatched support reference source for " ++ path) 74 bundle <- either error pure (decodeBundle bytes) 75 either error pure (verifyBundle bundle) 76 let terms = reconstructBundleTerms (bundleNodes bundle) 77 env = Map.fromList [(unpack (exportName entry), terms V.! fromIntegral (exportRoot entry)) 78 | entry <- manifestExports (bundleManifest bundle)] 79 pure ([(legacy, alias, path) | (legacy, alias, path, _) <- rows], env) 80 {-# NOINLINE supportFixture #-} 81 82 compiledLibraries :: ([(String, String, FilePath)], Env) 83 compiledLibraries = (fst compilerFixture ++ fst supportFixture, 84 Map.union (snd compilerFixture) (snd supportFixture)) 85 86 -- Select only the published interface, not imported names or recovery kernels. 87 -- The existing cohort loaders still authenticate sources/receipts/reuse proofs. 88 fixtureExports :: String -> Env 89 fixtureExports legacy = 90 let (rows, exports) = compiledLibraries 91 in case [alias | (name, alias, _) <- rows, name == legacy] of 92 [alias] -> Map.fromList 93 [(drop (length alias + 1) name, tree) | (name, tree) <- Map.toList exports, 94 (alias ++ ".") `isPrefixOf` name] 95 _ -> error ("missing or ambiguous fixture module: " ++ legacy) 96