SupportFixture.hs (20899B)
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, verifyIOSupportSources, verifyCompilerIOSupportSources, verifyCanonicalIOSupportSources, verifyBinary64SupportSources, 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 -- Explicit closed IO cohort growth, not an ordinary membership rewrite. 150 -- All additions must be rebuilt; the immutable origin and patterns move retain 151 -- their original checks. No arbitrary added/reused alias is admitted. 152 verifyIOSupportSources :: [[String]] -> [[String]] -> S.Set String -> Either String () 153 verifyIOSupportSources = verifyExpandedSupportSources historicalIOAdditions 154 155 historicalIOAdditions :: [(String, String)] 156 historicalIOAdditions = 157 [("arboricx_handlers", "lib/arboricx/handlers.tri"), 158 ("arboricx_streaming_v2", "lib/arboricx/streaming-v2.tri"), 159 ("handler_artifacts", "lib/handlers/artifacts.tri"), 160 ("handler_log", "lib/handlers/log.tri"), 161 ("handlers", "lib/handlers.tri"), 162 ("io_v2", "lib/io-v2.tri"), 163 ("io_v2_artifacts", "lib/io-v2/artifacts.tri"), 164 ("io_v2_http", "lib/io-v2/http-transport.tri"), 165 ("io_v2_storage", "lib/io-v2/storage.tri"), 166 ("io_v2_text", "lib/io-v2/text.tri")] 167 168 -- The compiler owns its v2 core/text/storage providers; general IO belongs to 169 -- support. This closed layout preserves every source, with no duplicate owners. 170 verifyCompilerIOSupportSources :: [[String]] -> [[String]] -> [[String]] -> S.Set String -> Either String () 171 verifyCompilerIOSupportSources compiler original current rebuilt = do 172 let moved = [("io_v2", "lib/io-v2.tri"), ("io_v2_storage", "lib/io-v2/storage.tri"), 173 ("io_v2_text", "lib/io-v2/text.tri")] 174 required = moved ++ [("compiler_io", "lib/source/io-v2.tri")] 175 owns (name,path) = case [p | ["module",_,alias,p,_] <- compiler, alias == name] of 176 [p] -> p == path 177 _ -> False 178 additions = filter ((`notElem` map fst moved) . fst) historicalIOAdditions ++ [("io", "lib/io.tri")] 179 unless (all owns required && null [() | ["module",_,"io",_,_] <- compiler] && 180 filter ((== ["compiler-provider"]) . take 1) current == 181 [["compiler-provider",name,path] | (name,path) <- moved]) $ 182 Left "invalid compiler IO cohort ownership" 183 verifyExpandedSupportSources additions original current rebuilt 184 185 -- Current names have one canonical IO owner; historical cohort schemas above 186 -- retain their exact authenticated membership contracts. 187 verifyCanonicalIOSupportSources :: [[String]] -> [[String]] -> [[String]] -> S.Set String -> Either String () 188 verifyCanonicalIOSupportSources compiler original current rebuilt = do 189 let moved = [("io", "lib/io.tri"), ("io_storage", "lib/io/storage.tri"), 190 ("io_text", "lib/io/text.tri")] 191 required = moved ++ [("compiler_io", "lib/source/io.tri")] 192 additions = [("arboricx_handlers", "lib/arboricx/handlers.tri"), 193 ("arboricx_streaming", "lib/arboricx/streaming.tri"), 194 ("handler_artifacts", "lib/handlers/artifacts.tri"), 195 ("handler_log", "lib/handlers/log.tri"), 196 ("handlers", "lib/handlers.tri"), 197 ("io_artifacts", "lib/io/artifacts.tri"), 198 ("io_http", "lib/io/http-transport.tri")] 199 owns (name,path) = [p | ["module",_,alias,p,_] <- compiler, alias == name] == [path] 200 unless (all owns required && 201 filter ((== ["compiler-provider"]) . take 1) current == 202 [["compiler-provider",name,path] | (name,path) <- moved]) $ 203 Left "invalid canonical IO cohort ownership" 204 verifyExpandedSupportSources additions original current rebuilt 205 206 -- V7 adds a fixed arithmetic cohort while retaining the V6 ownership checks. 207 verifyBinary64SupportSources :: [[String]] -> [[String]] -> [[String]] -> S.Set String -> Either String () 208 verifyBinary64SupportSources compiler original current rebuilt = do 209 let additions = [("binary64","binary64","lib/math/binary64.tri")] ++ 210 [("binary64_" ++ name,"binary64_" ++ name,"lib/math/binary64/" ++ name ++ ".tri") | 211 name <- ["adders","chains","fast","finite","ieee","kernels","layouts", 212 "near","product_quotient","quantize","working"]] ++ 213 [("demos.binary64","demos_binary64","demos/binary64.tri")] 214 names = S.fromList [name | (_,name,_) <- additions] 215 paths = S.fromList [path | (_,_,path) <- additions] 216 isModule ["module",_,name,_,_] = name `S.member` names 217 isModule _ = False 218 isDeclaration ["added",_,name,_] = name `S.member` names 219 isDeclaration _ = False 220 collision ["module",_,name,path,_] = name `S.member` names || path `S.member` paths 221 collision _ = False 222 modules = filter isModule current 223 unless (map (take 4) modules == [["module",legacy,name,path] | (legacy,name,path) <- additions] && 224 all ((== 5) . length) modules && 225 filter isDeclaration current == [["added",legacy,name,path] | (legacy,name,path) <- additions] && 226 names `S.isSubsetOf` rebuilt && not (any collision (compiler ++ original))) $ 227 Left "invalid binary64 support expansion" 228 verifyCanonicalIOSupportSources compiler original 229 (filter (\row -> not (isModule row || isDeclaration row)) current) rebuilt 230 231 232 verifyExpandedSupportSources :: [(String, String)] -> [[String]] -> [[String]] -> S.Set String -> Either String () 233 verifyExpandedSupportSources additions original current rebuilt = do 234 let names = S.fromList (map fst additions) 235 declarations = [["added",name,name,path] | (name,path) <- additions] 236 isNew ["module",_,name,_,_] = name `S.member` names 237 isNew _ = False 238 added = filter isNew current 239 patternsRow = [row | row@["module",_,"patterns",_,_] <- current] 240 unless (filter ((== ["added"]) . take 1) current == declarations && 241 map (take 4) added == [["module",name,name,path] | (name,path) <- additions] && 242 names `S.isSubsetOf` rebuilt && not (any isNew original)) $ 243 Left "invalid IO support expansion" 244 verifyRelocatedSupportSources original (filter (not . isNew) current) rebuilt 245 verifySupportSources (original ++ patternsRow ++ added) current rebuilt 246 247 -- The export set belongs to the new authenticated native manifest, not the 248 -- historical module. Do not lose the full-set check when allowing API changes. 249 verifySupportExports :: S.Set String -> String -> Either String () 250 verifySupportExports expected manifest = do 251 let rows = map words (lines manifest) 252 names = [name | ["export",name,kind,_,"arboricx.abi.tree.v1"] <- drop 1 rows, 253 kind `elem` ["arboricx.tree-term.v1", "arboricx.indexed-tree.v1"]] 254 kinds = S.fromList [kind | ["export",_,kind,_,_] <- drop 1 rows] 255 if take 1 rows == [["arboricx.module-manifest.v1"]] && 256 S.size kinds == 1 && length names == length (drop 1 rows) && 257 length names == S.size (S.fromList names) && 258 S.fromList names == expected 259 then Right () else Left "rebuilt manifest export set mismatch" 260 261 -- A previously built consumer is not current merely because its own source is 262 -- unchanged. Rebuild conservatively if any selected rebuilt support provider's 263 -- full manifest changed. Origin-reused modules keep verifyReuseProviders below. 264 verifySupportDependencies :: M.Map String String -> [[String]] -> Either String () 265 verifySupportDependencies providers rows = do 266 let locals = [dep | ["local",dep,_,_] <- rows] 267 unless (length locals == S.size (S.fromList locals)) (Left "duplicate local dependency") 268 forM_ rows $ \row -> case row of 269 ["local",dep,pin,_] -> check dep pin 270 ["pin",dep,pin,_,_] -> check dep pin 271 tag:_ | tag `elem` ["local", "pin"] -> Left "invalid support dependency row" 272 _ -> Right () 273 where 274 check dep pin = case M.lookup dep providers of 275 Just current | current /= pin -> Left ("stale support dependency: " ++ dep) 276 _ -> Right () 277 278 verifyMixedSupport :: [String] -> BS.ByteString -> BS.ByteString -> IO () 279 verifyMixedSupport metadata currentBytes compilerBytes = do 280 let base = "test/fixtures/" 281 hash domain b = unpack (hashObject (Domain (pack domain)) b) 282 checked label domain path = do 283 bytes <- BS.readFile (base ++ path) 284 unless ([label,hash domain bytes] `elem` map words metadata) $ 285 error ("mixed support evidence digest mismatch: " ++ label) 286 pure bytes 287 decode bytes = do 288 b <- either error pure (decodeBundle bytes) 289 either error pure (verifyBundle b) 290 pure b 291 originalMetadata <- checked "origin-metadata" "tricu.support-origin-metadata.v1" "support-origin.v1" 292 originalCompiler <- checked "origin-compiler" "tricu.compiler-library-fixture.v1" "support-origin-compiler.arboricx" 293 originalSupport <- checked "origin-support" "tricu.support-library-fixture.v1" "support-origin.arboricx" 294 rebuiltSupport <- checked "rebuilt-support" "tricu.support-library-fixture.v1" "support-rebuilt.arboricx" 295 let oldRows = map words (lines (map (toEnum . fromEnum) (BS.unpack originalMetadata))) 296 unless (take 1 oldRows == [["tricu.support-library-fixture.v1"]] && 297 ["compiler-fixture",hash "tricu.compiler-library-fixture.v1" originalCompiler] `elem` oldRows && 298 ["bundle",hash "tricu.support-library-fixture.v1" originalSupport] `elem` oldRows) $ 299 error "mixed support original cohort provenance changed" 300 bundles <- mapM decode [originalCompiler, originalSupport, compilerBytes, currentBytes, rebuiltSupport] 301 let [oc,os,nc,ns,rebuilt] = canonicalEnvs bundles 302 before = M.union oc os; after = M.union nc ns 303 aliases = S.fromList [alias | ["module",_,alias,_,_] <- map words metadata] 304 reusedRows = [alias | ["reuse",alias] <- map words metadata] 305 builtRows = [(alias,receipt,manifest,compiler) | 306 ["rebuilt",alias,receipt,manifest,compiler] <- map words metadata] 307 reused = S.fromList reusedRows; built = S.fromList [alias | (alias,_,_,_) <- builtRows] 308 owned env alias = M.filterWithKey (\name _ -> (alias ++ ".") `isPrefixOf` name) env 309 unless (length reusedRows == S.size reused && length builtRows == S.size built && 310 S.null (S.intersection reused built) && S.union reused built == aliases && 311 S.fromList [takeWhile (/= '.') name | name <- M.keys ns] == aliases && 312 S.fromList [takeWhile (/= '.') name | name <- M.keys rebuilt] == built) $ 313 error "invalid mixed support cohort partition/export set" 314 compilerRows <- map words . lines <$> readFile "test/fixtures/compiler-library.v1" 315 either error pure $ 316 if take 1 metadata == ["tricu.support-library-fixture.v7"] 317 then verifyBinary64SupportSources compilerRows oldRows (map words metadata) built 318 else if take 1 metadata == ["tricu.support-library-fixture.v6"] 319 then verifyCanonicalIOSupportSources compilerRows oldRows (map words metadata) built 320 else if take 1 metadata == ["tricu.support-library-fixture.v5"] 321 then verifyCompilerIOSupportSources compilerRows oldRows (map words metadata) built 322 else if take 1 metadata == ["tricu.support-library-fixture.v4"] 323 then verifyIOSupportSources oldRows (map words metadata) built 324 else if take 1 metadata == ["tricu.support-library-fixture.v3"] 325 then verifyRelocatedSupportSources oldRows (map words metadata) built 326 else verifySupportSources oldRows (map words metadata) built 327 forM_ [ (alias,path) | ["module",_,alias,path,_] <- map words metadata] $ \(alias,path) -> 328 if alias `S.member` reused then do 329 unless (owned ns alias == owned os alias) $ error ("retained output changed: " ++ alias) 330 source <- readTestSource path 331 either (error . (("unsafe support reuse " ++ alias ++ ": ") ++)) pure 332 (verifyReuseProviders before after source) 333 else unless (owned ns alias == owned rebuilt alias) $ 334 error ("rebuilt output mismatch: " ++ alias) 335 forM_ builtRows $ \(alias,receiptPin,manifestPin,compilerPin) -> do 336 receipt <- BS.readFile (base ++ "support-receipts/" ++ alias ++ ".receipt") 337 manifest <- BS.readFile (base ++ "support-receipts/" ++ alias ++ ".manifest") 338 let receiptRows = map words (lines (map (toEnum . fromEnum) (BS.unpack receipt))) 339 sourceDigest = head [digest | ["module",_,name,_,digest] <- map words metadata, name == alias] 340 sourceRows = [ ["source",sourceDigest], ["output",manifestPin], ["compiler",compilerPin], 341 ["options",hash "arboricx.build-options.v1" "source-module.stable.v1"] ] 342 unless (hash "arboricx.build-receipt.v1" receipt == receiptPin && 343 hash "arboricx.module-manifest.v1" manifest == manifestPin && 344 all (\wanted -> filter ((== take 1 wanted) . take 1) receiptRows == [wanted]) sourceRows) $ 345 error ("mixed support receipt mismatch: " ++ alias) 346 let exportNames = S.fromList [drop (length alias + 1) name | name <- M.keys (owned ns alias)] 347 providers = M.fromList [(name,pin) | (name,_,pin,_) <- builtRows] 348 either error pure (verifySupportExports exportNames (unpack (decodeUtf8 manifest))) 349 either error pure (verifySupportDependencies providers receiptRows)