SupportFixture.hs (14121B)
1 -- Test-only mixed-origin fixture verification. No source compilation/evaluation: 2 -- complete provider identity, exact DAG interning and receipt authentication. 3 module SupportFixture (verifyMixedSupport, verifyReuseProviders, verifySupportSources, 4 verifySupportExports, verifySupportDependencies, verifyRelocatedSupportSources, canonicalEnvs, 5 readFixtureSourceBytes, readTestSource, readPinnedSource) where 6 7 import Wire 8 import ContentStore (hashObject, Domain(..)) 9 import Control.Monad (forM_, unless) 10 import Data.List (foldl', isPrefixOf) 11 import Data.Text (pack, unpack) 12 import Data.Text.Encoding (decodeUtf8) 13 import System.FilePath (normalise, (</>)) 14 import qualified Data.ByteString as BS 15 import qualified Data.Foldable as F 16 import qualified Data.Map.Strict as M 17 import qualified Data.Sequence as Q 18 import qualified Data.Set as S 19 20 -- Reference tests consume the source that belongs to their executable artifact, 21 -- not an edited working-tree body/header with old compiled dependencies. No 22 -- missing/corrupt registered source can fall back to the working directory. 23 -- Current-source freshness is a separate explicit acceptance check. 24 readPinnedSource :: FilePath -> String -> IO BS.ByteString 25 readPinnedSource root digest = do 26 unless (length digest == 64 && all (`elem` ("0123456789abcdef" :: String)) digest) $ 27 fail "invalid reference source digest" 28 bytes <- BS.readFile (root </> (digest ++ ".tri")) 29 unless (unpack (hashObject (Domain (pack "arboricx.source.v1")) bytes) == digest) $ 30 fail "reference source digest mismatch" 31 pure bytes 32 33 fixtureSourceDigest :: FilePath -> IO (Maybe String) 34 fixtureSourceDigest path = do 35 metadata <- concat <$> mapM (fmap lines . readFile) 36 ["test/fixtures/compiler-library.v1", "test/fixtures/support-library.v1"] 37 case [digest | ["module",_,_,source,digest] <- map words metadata, 38 normalise source == normalise path] of 39 [] -> pure Nothing 40 [digest] -> pure (Just digest) 41 _ -> fail ("duplicate fixture source: " ++ path) 42 43 readFixtureSourceBytes :: FilePath -> IO BS.ByteString 44 readFixtureSourceBytes path = do 45 digest <- fixtureSourceDigest path >>= maybe (fail ("unregistered fixture source: " ++ path)) pure 46 readPinnedSource "test/fixtures/reference-source" digest 47 48 -- Unmapped test programs remain live authored inputs; only registered library 49 -- implementations and their import headers come from the authenticated cohort. 50 readTestSource :: FilePath -> IO String 51 readTestSource path = do 52 digest <- fixtureSourceDigest path 53 case digest of 54 Nothing -> readFile path 55 Just pin -> unpack . decodeUtf8 <$> readPinnedSource "test/fixtures/reference-source" pin 56 57 type Kernels = M.Map String Int 58 59 -- IDs are deterministic constructor/child tuples, NOT probabilistic tree hashes. 60 -- All children must already exist; verifyBundle enforces this before interning. 61 canonicalEnvs :: [Bundle] -> [Kernels] 62 canonicalEnvs = snd . foldl' bundle (M.empty, []) 63 where 64 bundle (table, envs) b = 65 let (table', ids) = foldl' node (table, Q.empty) (F.toList (bundleNodes b)) 66 env = M.fromList [(unpack (exportName e), Q.index ids (fromIntegral (exportRoot e))) | 67 e <- manifestExports (bundleManifest b)] 68 in (table', envs ++ [env]) 69 node (table, ids) n = 70 let key = case n of 71 BNLeaf -> (0 :: Int, -1, -1) 72 BNStem c -> (1, Q.index ids (fromIntegral c), -1) 73 BNFork l r -> (2, Q.index ids (fromIntegral l), Q.index ids (fromIntegral r)) 74 ident = M.findWithDefault (M.size table) key table 75 in (M.insert key ident table, ids Q.|> ident) 76 77 -- A reuse proof, not a source validator: the caller authenticates unchanged 78 -- source/output against the accepted original cohort first. Identical complete 79 -- provider interfaces imply identical namespaces, collisions and bound trees, 80 -- regardless of which names the body uses or shadows. Even unused changes now 81 -- require rebuilding. IDs must come from one shared canonicalEnvs interning run. 82 -- 83 -- Recognize only the fixture's simple named-provider directives. Reexports 84 -- acquire a provider even without !import. Unsupported directives (including 85 -- build-only !source, whose input identity is not a runtime interface) fail 86 -- closed and require rebuilding; there is no body parsing or scope inference. 87 verifyReuseProviders :: Kernels -> Kernels -> String -> Either String () 88 verifyReuseProviders before after source = do 89 dependencies <- concat <$> mapM directive 90 [row | line <- lines source, let row = words line, 91 first : _ <- [row], "!" `isPrefixOf` first] 92 forM_ (S.toList (S.fromList dependencies)) $ \dep -> do 93 let old = owned before dep 94 new = owned after dep 95 require (not (M.null old)) ("missing original provider: " ++ dep) 96 require (M.keysSet old == M.keysSet new) ("full export set changed: " ++ dep) 97 require (old == new) ("provider kernels changed: " ++ dep) 98 where 99 owned env dep = M.filterWithKey (\name _ -> (dep ++ ".") `isPrefixOf` name) env 100 require ok message = if ok then Right () else Left message 101 directive ["!import", dep] = provider dep 102 directive ["!import", dep, "*"] = provider dep 103 directive ["!import", dep, "as", qualifier] 104 | identifier qualifier = provider dep 105 directive ["!export", "*", "from", dep] = provider dep 106 directive ["!export", name] 107 | name == "*" || identifier name = Right [] 108 directive _ = Left "unsupported conservative reuse directive; rebuild required" 109 provider dep 110 | identifier dep = Right [dep] 111 | otherwise = Left "unsupported conservative reuse provider; rebuild required" 112 identifier (first : rest) = letter first && all (\c -> letter c || c >= '0' && c <= '9') rest 113 identifier [] = False 114 letter c = c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z' || c == '_' 115 116 -- Recompiled bodies may change, but changing a retained fingerprint would 117 -- relabel an old executable. Cohort identity/membership is not a rewrite API. 118 verifySupportSources :: [[String]] -> [[String]] -> S.Set String -> Either String () 119 verifySupportSources original current rebuilt = do 120 let modules rows = [row | row <- rows, take 1 row == ["module"]] 121 old = modules original; new = modules current 122 identities = map (take 4) 123 aliases = [alias | [_,_,alias,_,_] <- new] 124 paths = [path | [_,_,_,path,_] <- new] 125 require (all ((== 5) . length) (old ++ new) && identities old == identities new && 126 length aliases == S.size (S.fromList aliases) && 127 length paths == S.size (S.fromList paths)) "support cohort identity changed" 128 forM_ (zip old new) $ \(before, after) -> case after of 129 [_,_,alias,_,_] -> require (alias `S.member` rebuilt || before == after) 130 ("retained source fingerprint changed: " ++ alias) 131 _ -> Left "invalid support source row" 132 where require ok message = if ok then Right () else Left message 133 134 -- One explicitly authorized cohort move. Ordinary identity/reuse validation 135 -- stays unchanged; the added module must have a genuine native rebuild receipt. 136 verifyRelocatedSupportSources :: [[String]] -> [[String]] -> S.Set String -> Either String () 137 verifyRelocatedSupportSources original current rebuilt = do 138 let added = [row | row@["module",_,"patterns",_,_] <- current] 139 declarations = [row | row <- current, take 1 row == ["relocated"]] 140 unless (declarations == [["relocated","compiler-library","patterns","patterns","lib/patterns.tri"]] && 141 "patterns" `S.member` rebuilt && 142 all (\row -> take 4 row /= ["module","patterns","patterns","lib/patterns.tri"]) original) $ 143 Left "invalid patterns cohort relocation" 144 case added of 145 [row@["module","patterns","patterns","lib/patterns.tri",_]] -> 146 verifySupportSources (original ++ [row]) current rebuilt 147 _ -> Left "invalid patterns cohort relocation" 148 149 -- The export set belongs to the new authenticated native manifest, not the 150 -- historical module. Do not lose the full-set check when allowing API changes. 151 verifySupportExports :: S.Set String -> String -> Either String () 152 verifySupportExports expected manifest = do 153 let rows = map words (lines manifest) 154 names = [name | ["export",name,kind,_,"arboricx.abi.tree.v1"] <- drop 1 rows, 155 kind `elem` ["arboricx.tree-term.v1", "arboricx.indexed-tree.v1"]] 156 kinds = S.fromList [kind | ["export",_,kind,_,_] <- drop 1 rows] 157 if take 1 rows == [["arboricx.module-manifest.v1"]] && 158 S.size kinds == 1 && length names == length (drop 1 rows) && 159 length names == S.size (S.fromList names) && 160 S.fromList names == expected 161 then Right () else Left "rebuilt manifest export set mismatch" 162 163 -- A previously built consumer is not current merely because its own source is 164 -- unchanged. Rebuild conservatively if any selected rebuilt support provider's 165 -- full manifest changed. Origin-reused modules keep verifyReuseProviders below. 166 verifySupportDependencies :: M.Map String String -> [[String]] -> Either String () 167 verifySupportDependencies providers rows = do 168 let locals = [dep | ["local",dep,_,_] <- rows] 169 unless (length locals == S.size (S.fromList locals)) (Left "duplicate local dependency") 170 forM_ rows $ \row -> case row of 171 ["local",dep,pin,_] -> check dep pin 172 ["pin",dep,pin,_,_] -> check dep pin 173 tag:_ | tag `elem` ["local", "pin"] -> Left "invalid support dependency row" 174 _ -> Right () 175 where 176 check dep pin = case M.lookup dep providers of 177 Just current | current /= pin -> Left ("stale support dependency: " ++ dep) 178 _ -> Right () 179 180 verifyMixedSupport :: [String] -> BS.ByteString -> BS.ByteString -> IO () 181 verifyMixedSupport metadata currentBytes compilerBytes = do 182 let base = "test/fixtures/" 183 hash domain b = unpack (hashObject (Domain (pack domain)) b) 184 checked label domain path = do 185 bytes <- BS.readFile (base ++ path) 186 unless ([label,hash domain bytes] `elem` map words metadata) $ 187 error ("mixed support evidence digest mismatch: " ++ label) 188 pure bytes 189 decode bytes = do 190 b <- either error pure (decodeBundle bytes) 191 either error pure (verifyBundle b) 192 pure b 193 originalMetadata <- checked "origin-metadata" "tricu.support-origin-metadata.v1" "support-origin.v1" 194 originalCompiler <- checked "origin-compiler" "tricu.compiler-library-fixture.v1" "support-origin-compiler.arboricx" 195 originalSupport <- checked "origin-support" "tricu.support-library-fixture.v1" "support-origin.arboricx" 196 rebuiltSupport <- checked "rebuilt-support" "tricu.support-library-fixture.v1" "support-rebuilt.arboricx" 197 let oldRows = map words (lines (map (toEnum . fromEnum) (BS.unpack originalMetadata))) 198 unless (take 1 oldRows == [["tricu.support-library-fixture.v1"]] && 199 ["compiler-fixture",hash "tricu.compiler-library-fixture.v1" originalCompiler] `elem` oldRows && 200 ["bundle",hash "tricu.support-library-fixture.v1" originalSupport] `elem` oldRows) $ 201 error "mixed support original cohort provenance changed" 202 bundles <- mapM decode [originalCompiler, originalSupport, compilerBytes, currentBytes, rebuiltSupport] 203 let [oc,os,nc,ns,rebuilt] = canonicalEnvs bundles 204 before = M.union oc os; after = M.union nc ns 205 aliases = S.fromList [alias | ["module",_,alias,_,_] <- map words metadata] 206 reusedRows = [alias | ["reuse",alias] <- map words metadata] 207 builtRows = [(alias,receipt,manifest,compiler) | 208 ["rebuilt",alias,receipt,manifest,compiler] <- map words metadata] 209 reused = S.fromList reusedRows; built = S.fromList [alias | (alias,_,_,_) <- builtRows] 210 owned env alias = M.filterWithKey (\name _ -> (alias ++ ".") `isPrefixOf` name) env 211 unless (length reusedRows == S.size reused && length builtRows == S.size built && 212 S.null (S.intersection reused built) && S.union reused built == aliases && 213 S.fromList [takeWhile (/= '.') name | name <- M.keys ns] == aliases && 214 S.fromList [takeWhile (/= '.') name | name <- M.keys rebuilt] == built) $ 215 error "invalid mixed support cohort partition/export set" 216 either error pure $ 217 if take 1 metadata == ["tricu.support-library-fixture.v3"] 218 then verifyRelocatedSupportSources oldRows (map words metadata) built 219 else verifySupportSources oldRows (map words metadata) built 220 forM_ [ (alias,path) | ["module",_,alias,path,_] <- map words metadata] $ \(alias,path) -> 221 if alias `S.member` reused then do 222 unless (owned ns alias == owned os alias) $ error ("retained output changed: " ++ alias) 223 source <- readTestSource path 224 either (error . (("unsafe support reuse " ++ alias ++ ": ") ++)) pure 225 (verifyReuseProviders before after source) 226 else unless (owned ns alias == owned rebuilt alias) $ 227 error ("rebuilt output mismatch: " ++ alias) 228 forM_ builtRows $ \(alias,receiptPin,manifestPin,compilerPin) -> do 229 receipt <- BS.readFile (base ++ "support-receipts/" ++ alias ++ ".receipt") 230 manifest <- BS.readFile (base ++ "support-receipts/" ++ alias ++ ".manifest") 231 let receiptRows = map words (lines (map (toEnum . fromEnum) (BS.unpack receipt))) 232 sourceDigest = head [digest | ["module",_,name,_,digest] <- map words metadata, name == alias] 233 sourceRows = [ ["source",sourceDigest], ["output",manifestPin], ["compiler",compilerPin], 234 ["options",hash "arboricx.build-options.v1" "source-module.stable.v1"] ] 235 unless (hash "arboricx.build-receipt.v1" receipt == receiptPin && 236 hash "arboricx.module-manifest.v1" manifest == manifestPin && 237 all (\wanted -> filter ((== take 1 wanted) . take 1) receiptRows == [wanted]) sourceRows) $ 238 error ("mixed support receipt mismatch: " ++ alias) 239 let exportNames = S.fromList [drop (length alias + 1) name | name <- M.keys (owned ns alias)] 240 providers = M.fromList [(name,pin) | (name,_,pin,_) <- builtRows] 241 either error pure (verifySupportExports exportNames (unpack (decodeUtf8 manifest))) 242 either error pure (verifySupportDependencies providers receiptRows)