Provenance.hs (22043B)
1 -- Retain inputs around native receipts; never invent a second build receipt. 2 module Module.Provenance 3 ( capture, verifyPack, prepareRebuild, finishRebuild, Recipe(..) ) where 4 5 import Workspace (workspaceSources) 6 import ContentStore.Object 7 import ContentStore.Alias (ObjectRef(..)) 8 import ContentStore.Filesystem (objectPath, putObject) 9 import Module.Manifest 10 import qualified Module.Inspection as I 11 import qualified Package as P 12 import qualified Project as J 13 import Control.Exception (bracket) 14 import Control.Monad (unless, when, forM_, foldM) 15 import qualified Data.ByteString as BS 16 import Data.Text (Text) 17 import qualified Data.Text as T 18 import Data.Text.Encoding (encodeUtf8, decodeUtf8') 19 import qualified Data.Map.Strict as M 20 import qualified Data.Set as S 21 import Data.IORef 22 import System.Directory (createDirectory, createDirectoryIfMissing) 23 import System.FilePath ((</>), takeDirectory, takeBaseName, takeExtension) 24 import System.IO (openBinaryFile, IOMode(ReadMode), hClose) 25 import System.Posix.Files (getSymbolicLinkStatus, isRegularFile, isDirectory) 26 27 receiptDomain, sourceDomain, recipeDomain, optionsDomain :: Domain 28 receiptDomain = Domain "arboricx.build-receipt.v1" 29 sourceDomain = Domain "arboricx.source.v1" 30 recipeDomain = Domain "arboricx.build-inputs.v1" 31 optionsDomain = Domain "arboricx.build-options.v1" 32 profile :: BS.ByteString 33 profile = "source-module.stable.v1" 34 35 data Receipt = Receipt 36 { rSource :: Text, rCompiler :: Text, rOptions :: Text, rOutput :: Text 37 , rLocals :: [(Text,Text,Text)], rPins :: [(Text,Text,Text,Text)] 38 } deriving (Eq, Show) 39 data Recipe = Recipe 40 { recipeEntry :: Text, recipeReceipt :: Text, recipeCompiler :: Text 41 , recipeUnits :: [(Text,Text)], recipeProject :: Maybe (Text,Text) 42 } deriving (Eq, Show) 43 data Closure = Closure 44 { cRecipe :: Recipe, cObjects :: M.Map (Text,Text) BS.ByteString 45 , cReceipts :: M.Map Text (Text,Receipt), cExternal :: S.Set Text 46 } 47 48 bounded :: Int -> FilePath -> IO BS.ByteString 49 bounded limit file = do 50 status <- getSymbolicLinkStatus file 51 unless (isRegularFile status) $ fail "build inputs require regular files (no symlinks)" 52 bracket (openBinaryFile file ReadMode) hClose $ \h -> do 53 bytes <- BS.hGet h (limit + 1) 54 when (BS.length bytes > limit) $ fail "build input exceeds byte limit" 55 pure bytes 56 57 textRows :: Text -> BS.ByteString -> Either String [[Text]] 58 textRows header bytes = do 59 txt <- either (Left . show) Right (decodeUtf8' bytes) 60 case T.lines txt of 61 h:rest | h == header && encodeUtf8 (T.unlines (h:rest)) == bytes -> Right (map (T.splitOn "\t") rest) 62 _ -> Left "unsupported/noncanonical build metadata" 63 64 parseReceipt :: BS.ByteString -> Either String Receipt 65 parseReceipt bytes = do 66 rows <- textRows "arboricx.build-receipt.v1" bytes 67 case rows of 68 ["source",s]:["compiler",c]:["options",o]:["output",out]:rest -> do 69 mapM_ validateObjectHash [s,c,o,out] 70 let (locals,pins) = span (\row -> take 1 row == ["local"]) rest 71 ls <- mapM (\row -> case row of 72 ["local",n,m,r] | J.validBinding n -> mapM_ validateObjectHash [m,r] >> pure (n,m,r) 73 _ -> Left "invalid receipt local row") locals 74 ps <- mapM (\row -> case row of 75 ["pin",ref,m,n,t] -> mapM_ validateObjectHash [m,t] >> pure (ref,m,n,t) 76 _ -> Left "invalid receipt pin row") pins 77 unless (S.size (S.fromList [n | (n,_,_) <- ls]) == length ls) $ Left "duplicate receipt local" 78 unless (S.size (S.fromList [(ref,n) | (ref,_,n,_) <- ps]) == length ps) $ Left "duplicate receipt pin" 79 unless (o == hashObject optionsDomain profile) $ Left "unsupported build options; expected stable flat-workspace profile" 80 pure (Receipt s c o out ls ps) 81 _ -> Left "invalid native build receipt" 82 83 encodeRecipe :: Recipe -> BS.ByteString 84 encodeRecipe r = encodeUtf8 $ T.unlines $ 85 ["arboricx.build-inputs.v1", "entry\t" <> recipeEntry r, "receipt\t" <> recipeReceipt r, 86 "compiler\t" <> recipeCompiler r] ++ 87 ["unit\t" <> n <> "\t" <> p | (n,p) <- recipeUnits r] ++ 88 maybe [] (\(p,l) -> ["project\t" <> p <> "\t" <> l]) (recipeProject r) 89 90 decodeRecipe :: BS.ByteString -> Either String Recipe 91 decodeRecipe bytes = do 92 rows <- textRows "arboricx.build-inputs.v1" bytes 93 case rows of 94 ["entry",entry]:["receipt",receipt]:["compiler",compiler]:rest | J.validBinding entry -> do 95 let (units,context) = span (\row -> take 1 row == ["unit"]) rest 96 us <- mapM (\row -> case row of 97 ["unit",n,p] | J.validBinding n -> validateObjectHash p >> pure (n,p) 98 _ -> Left "invalid build source unit") units 99 unless (not (null us) && length us <= 128 && M.toAscList (M.fromList us) == us && 100 S.size (S.fromList (map (T.toCaseFold . fst) us)) == length us) $ Left "invalid/duplicate/unsorted source units" 101 mapM_ validateObjectHash [receipt,compiler] 102 ctx <- case context of 103 [] -> Right Nothing 104 [["project",p,l]] -> mapM_ validateObjectHash [p,l] >> pure (Just (p,l)) 105 _ -> Left "invalid project context" 106 unless (lookup entry us == Just receipt) $ Left "entry receipt not in source units" 107 let result = Recipe entry receipt compiler us ctx 108 unless (encodeRecipe result == bytes) $ Left "noncanonical build inputs" 109 pure result 110 _ -> Left "invalid build inputs" 111 112 -- Byte authentication is separate from the producer's claimed input/output link. 113 -- Collect only the referenced closure; never copy caches or ambient aliases. 114 collect :: Recipe -> (Domain -> Text -> IO BS.ByteString) -> (Text -> Text -> IO BS.ByteString) -> IO Closure 115 collect initial load source = do 116 objects <- newIORef M.empty 117 total <- newIORef (0 :: Int) 118 let retain d pin bytes = do 119 either fail pure (verifyObjectBytes d pin bytes) 120 old <- readIORef objects 121 unless (M.member (unDomain d,pin) old) $ do 122 size <- atomicModifyIORef' total (\n -> let next = n + BS.length bytes in (next,next)) 123 when (size > 256 * 1024 * 1024) $ fail "build input closure exceeds 256 MiB" 124 modifyIORef' objects (M.insert (unDomain d,pin) bytes) 125 pure bytes 126 get d p = do 127 known <- M.lookup (unDomain d,p) <$> readIORef objects 128 maybe (load d p >>= retain d p) pure known 129 moduleObjects p = do 130 bytes <- get manifestDomain p 131 m <- either fail pure (decodeManifest bytes) 132 unless (encodeManifest m == bytes) $ fail "noncanonical native manifest in build inputs" 133 unless (null (moduleManifestReferences m) && not (null (moduleManifestExports m))) $ fail "unsupported module profile in build inputs" 134 forM_ (moduleManifestExports m) $ \ex -> do 135 let ref = moduleExportObject ex 136 unless (objectRefKind ref == "arboricx.indexed-tree.v1" && moduleExportAbi ex == "arboricx.abi.tree.v1") $ 137 fail "unsupported executable in build inputs" 138 _ <- get (Domain (objectRefKind ref)) (objectRefHash ref) 139 pure () 140 pure m 141 compiler <- moduleObjects (recipeCompiler initial) 142 worker <- case [objectRefHash (moduleExportObject ex) | ex <- moduleManifestExports compiler, moduleExportName ex == "sourceBuildGraph"] of 143 [p] -> pure p 144 _ -> fail "compiler must export sourceBuildGraph" 145 let walk stack done name pin = do 146 when (name `elem` stack) $ fail "cyclic source receipt graph" 147 case M.lookup name done of 148 Just (previous,_) | previous == pin -> pure done 149 | otherwise -> fail "one workspace name refers to multiple receipts" 150 Nothing -> do 151 unless (J.validBinding name && M.size done + length stack < 128) $ fail "invalid/oversized source receipt graph" 152 receipt <- get receiptDomain pin >>= either fail pure . parseReceipt 153 unless (rCompiler receipt == worker) $ fail "receipt compiler identity differs from selected worker; this profile requires explicit --toolchain builds" 154 _ <- get optionsDomain (rOptions receipt) 155 _ <- source name (rSource receipt) >>= retain sourceDomain (rSource receipt) 156 _ <- moduleObjects (rOutput receipt) 157 children <- foldM (\acc (n,m,r) -> do 158 next <- walk (name:stack) acc n r 159 unless (maybe False ((== m) . rOutput . snd) (M.lookup n next)) $ fail "local receipt output mismatch" 160 pure next) done (rLocals receipt) 161 let groups = M.fromListWith (++) [(ref,[(m,n,t)]) | (ref,m,n,t) <- rPins receipt] 162 escape = T.replace "\r" "%0D" . T.replace "\n" "%0A" . T.replace "\t" "%09" . T.replace "%" "%25" 163 unless (all (\(n,_,_) -> M.member n groups) (rLocals receipt)) $ fail "receipt lacks local interface pins" 164 forM_ (M.toList groups) $ \(ref,ps) -> do 165 m <- case ps of 166 (p,_,_):_ -> pure p 167 [] -> fail "empty receipt pin group" 168 unless (all (\(p,_,_) -> p == m) ps) $ fail "conflicting pin group" 169 if ref == m then either fail pure (validateObjectHash ref) 170 else unless ((ref,m) `elem` [(n,p) | (n,p,_) <- rLocals receipt]) $ fail "unbound receipt pin group" 171 interface <- moduleObjects m 172 let expected = M.fromList [(escape (moduleExportName ex),objectRefHash (moduleExportObject ex)) | ex <- moduleManifestExports interface] 173 unless (M.fromList [(n,t) | (_,n,t) <- ps] == expected) $ fail "receipt pins differ from complete interface" 174 pure (M.insert name (pin,receipt) children) 175 receipts <- walk [] M.empty (recipeEntry initial) (recipeReceipt initial) 176 let actualUnits = [(n,p) | (n,(p,_)) <- M.toAscList receipts] 177 unless (null (recipeUnits initial) || recipeUnits initial == actualUnits) $ fail "recipe differs from reachable receipt graph" 178 case recipeProject initial of 179 Nothing -> pure () 180 Just (p,l) -> do 181 ds <- get (Domain "arboricx.project-declaration.v1") p >>= either fail pure . J.decodeProject 182 ls <- get (Domain "arboricx.project-lock.v1") l >>= either fail pure . J.decodeProjectLock 183 let selection (n,locked) = let r = P.lockRelease locked in J.Dependency n (P.lockRegistry locked) (P.releaseName r) (P.releaseVersion r) 184 unless (ds == map selection ls) $ fail "captured project declaration differs from lock" 185 forM_ ls $ \(n,locked) -> case M.lookup n receipts of 186 Nothing -> pure () -- unused project selections are context, not build inputs 187 Just (_,r) -> do 188 bytes <- get sourceDomain (rSource r) 189 unless (bytes == P.bindingBytes (P.releaseManifest (P.lockRelease locked))) $ fail "project binding snapshot differs from lock" 190 allObjects <- readIORef objects 191 let external = S.fromList [m | (_,r) <- M.elems receipts, (ref,m,_,_) <- rPins r, ref == m] 192 pure (Closure (initial {recipeUnits = actualUnits}) allObjects receipts external) 193 194 loadStore :: StorePath -> Domain -> Text -> IO BS.ByteString 195 loadStore store domain pin = do 196 either fail pure (validateObjectHash pin) 197 forM_ [unStorePath store, unStorePath store </> "objects", unStorePath store </> "objects" </> shardForHash pin] $ \dir -> do 198 status <- getSymbolicLinkStatus dir 199 unless (isDirectory status) $ fail "build inputs require real CAS directories (no symlinks)" 200 let limit | domain == receiptDomain || domain == sourceDomain = 1048576 201 | domain == manifestDomain || domain == Domain "arboricx.project-declaration.v1" || domain == Domain "arboricx.project-lock.v1" = 65536 202 | otherwise = 64 * 1024 * 1024 203 bytes <- bounded limit (objectPath store pin) 204 either fail pure (verifyObjectBytes domain pin bytes) 205 pure bytes 206 207 -- Decoding executable graphs is shared with the read-only inspection machinery. 208 validateExecutables :: StorePath -> Closure -> IO () 209 validateExecutables store c = forM_ [p | ((d,p),_) <- M.toList (cObjects c), d == unDomain manifestDomain] $ \p -> do 210 evidence <- I.inspectModule store p 211 unless (I.inspectionStatus evidence == "verified") $ fail ("unverified build module " ++ T.unpack p ++ ": " ++ T.unpack (I.inspectionStatus evidence)) 212 213 writeObjects :: StorePath -> M.Map (Text,Text) BS.ByteString -> IO () 214 writeObjects store objects = forM_ (M.toList objects) $ \((d,p),bytes) -> do 215 actual <- putObject store (Domain d) bytes 216 unless (actual == p) $ fail "internal object copy identity mismatch" 217 218 cacheReceipt :: StorePath -> Text -> IO Text 219 cacheReceipt (StorePath store) name = do 220 bytes <- bounded 4096 (store </> "cache/source-build" </> T.unpack name) 221 txt <- either (fail . show) pure (decodeUtf8' bytes) 222 case T.splitOn "\t" txt of 223 ["arboricx.source-build-cache.v1",key,out,receipt] -> do 224 mapM_ (either fail pure . validateObjectHash) [key,out,receipt] 225 receiptBytes <- loadStore (StorePath store) receiptDomain receipt 226 parsed <- either fail pure (parseReceipt receiptBytes) 227 txtReceipt <- either (fail . show) pure (decodeUtf8' receiptBytes) 228 let body = drop 1 (T.lines txtReceipt) 229 keyBytes = encodeUtf8 (T.unlines ("arboricx.source-build-key.v1" : take 3 body ++ drop 4 body)) 230 unless (rOutput parsed == out && hashObject (Domain "arboricx.source-build-key.v1") keyBytes == key) $ 231 fail "native cache locator differs from authenticated receipt" 232 pure receipt 233 _ -> fail "invalid native build cache locator" 234 235 capture :: FilePath -> StorePath -> StorePath -> Text -> Maybe Text -> Maybe (FilePath,FilePath) -> FilePath -> IO Text 236 capture file app tools compiler selectedReceipt project output = do 237 unless (takeExtension file == ".tri" && J.validBinding (T.pack (takeBaseName file))) $ fail "capture requires a native .tri entry" 238 let entry = T.pack (takeBaseName file) 239 sources <- workspaceSources file 240 receipt <- maybe (cacheReceipt app entry) (\p -> either fail pure (validateObjectHash p) >> pure p) selectedReceipt 241 context <- case project of 242 Nothing -> pure Nothing 243 Just (p,l) -> do 244 ds <- bounded 65536 p 245 ls <- bounded 65536 l 246 pure (Just (ds,ls)) 247 let ctx = fmap (\(d,l) -> (hashObject (Domain "arboricx.project-declaration.v1") d,hashObject (Domain "arboricx.project-lock.v1") l)) context 248 load d p | d == optionsDomain = pure profile 249 | d == Domain "arboricx.project-declaration.v1", Just (bytes,_) <- context = pure bytes 250 | d == Domain "arboricx.project-lock.v1", Just (_,bytes) <- context = pure bytes 251 | otherwise = loadStore app d p 252 -- Toolchain objects may live separately from application inputs. Copy them to 253 -- the closure through a typed lookup, never an ambient alias or source fallback. 254 toolManifestBytes <- loadStore tools manifestDomain compiler 255 toolManifest <- either fail pure (decodeManifest toolManifestBytes) 256 let toolPins = S.fromList ((unDomain manifestDomain,compiler) : [(objectRefKind r,objectRefHash r) | ex <- moduleManifestExports toolManifest, let r = moduleExportObject ex]) 257 combined d p = if S.member (unDomain d,p) toolPins then loadStore tools d p else load d p 258 c <- collect (Recipe entry receipt compiler [] ctx) combined (\name _ -> maybe (fail "receipt source absent from workspace") (bounded 1048576) (M.lookup (T.unpack name) sources)) 259 -- Publication is create-only; a failed capture may leave an incomplete directory 260 -- with no descriptor. Never replace or merge another pack. 261 createDirectoryIfMissing True (takeDirectory output) 262 createDirectory output 263 let packed = StorePath (output </> "store") 264 writeObjects packed (cObjects c) 265 validateExecutables packed c 266 let bytes = encodeRecipe (cRecipe c) 267 _ <- either fail pure (decodeRecipe bytes) 268 P.writeAtomic True (output </> "build-inputs") bytes 269 pure (hashObject recipeDomain bytes) 270 271 readPack :: FilePath -> Text -> IO Closure 272 readPack directory pin = do 273 bytes <- bounded 65536 (directory </> "build-inputs") 274 either fail pure (verifyObjectBytes recipeDomain pin bytes) 275 recipe <- either fail pure (decodeRecipe bytes) 276 let store = StorePath (directory </> "store") 277 c <- collect recipe (loadStore store) (\_ source -> loadStore store sourceDomain source) 278 validateExecutables store c 279 pure c 280 281 verifyPack :: FilePath -> Text -> IO Text 282 verifyPack directory pin = do 283 c <- readPack directory pin 284 pure ("Verified retained bytes and native receipt links (referenced closure only). Producer claims only; no build executed.\n" 285 <> "Inputs " <> pin <> "\nNative receipt " <> recipeReceipt (cRecipe c) 286 <> "\nCompiler " <> recipeCompiler (cRecipe c) <> "\n") 287 288 -- Prepare only explicitly needed executable inputs. Claimed outputs and receipts 289 -- remain in the pack, not the fresh build store. No producer caches are copied. 290 prepareRebuild :: FilePath -> Text -> Text -> FilePath -> IO Recipe 291 prepareRebuild directory pin trusted output = do 292 c <- readPack directory pin 293 let recipe = cRecipe c 294 unless (trusted == recipeCompiler recipe) $ fail "--trust-compiler must equal the retained compiler manifest; verification alone does not authorize execution" 295 createDirectoryIfMissing True (takeDirectory output) 296 createDirectory output 297 let workspace = output </> "workspace" 298 objects = cObjects c 299 obj d p = maybe (fail "missing retained object") pure (M.lookup (unDomain d,p) objects) 300 seed target manifest = do 301 bytes <- obj manifestDomain manifest 302 m <- either fail pure (decodeManifest bytes) 303 _ <- putObject target manifestDomain bytes 304 forM_ (moduleManifestExports m) $ \ex -> do 305 let ref = moduleExportObject ex; d = Domain (objectRefKind ref) 306 payload <- obj d (objectRefHash ref) 307 _ <- putObject target d payload 308 pure () 309 createDirectory workspace 310 -- Replay must never inherit source mappings from the output directory's ancestors. 311 BS.writeFile (workspace </> "tricu.workspace") "tricu.workspace.v1\n" 312 forM_ (M.toList (cReceipts c)) $ \(name,(_,r)) -> obj sourceDomain (rSource r) >>= BS.writeFile (workspace </> T.unpack name ++ ".tri") 313 case recipeProject recipe of 314 Nothing -> pure () 315 Just (p,l) -> do 316 obj (Domain "arboricx.project-declaration.v1") p >>= BS.writeFile (workspace </> "tricu.project") 317 obj (Domain "arboricx.project-lock.v1") l >>= BS.writeFile (workspace </> "tricu.lock") 318 seed (StorePath (output </> "tools")) (recipeCompiler recipe) 319 forM_ (S.toList (cExternal c)) (seed (StorePath (output </> "application"))) 320 pure recipe 321 322 finishRebuild :: FilePath -> Text -> FilePath -> Recipe -> Text -> Text -> IO (Text,Bool) 323 finishRebuild directory pin output recipe actual actualReceipt = do 324 c <- readPack directory pin 325 unless (recipe == cRecipe c) $ fail "build input pack changed during rebuild" 326 let expected = rOutput (snd (cReceipts c M.! recipeEntry recipe)) 327 app = StorePath (output </> "application") 328 receiptBytes <- loadStore app receiptDomain actualReceipt 329 r <- either fail pure (parseReceipt receiptBytes) 330 unless (rOutput r == actual) $ fail "rebuilt receipt/output mismatch" 331 -- Authenticate the returned receipt's entire newly produced local graph, 332 -- using fresh sources/stores, not the expected receipts retained in the pack. 333 let tools = StorePath (output </> "tools") 334 workspace = output </> "workspace" 335 toolBytes <- loadStore tools manifestDomain (recipeCompiler recipe) 336 toolManifest <- either fail pure (decodeManifest toolBytes) 337 let toolPins = S.fromList ((unDomain manifestDomain,recipeCompiler recipe) : 338 [(objectRefKind ref,objectRefHash ref) | ex <- moduleManifestExports toolManifest, let ref = moduleExportObject ex]) 339 load d p 340 | S.member (unDomain d,p) toolPins = loadStore tools d p 341 | d == optionsDomain = pure profile 342 | d == Domain "arboricx.project-declaration.v1" = bounded 65536 (workspace </> "tricu.project") 343 | d == Domain "arboricx.project-lock.v1" = bounded 65536 (workspace </> "tricu.lock") 344 | otherwise = loadStore app d p 345 actualClosure <- collect (recipe {recipeReceipt = actualReceipt, recipeUnits = []}) load 346 (\name _ -> bounded 1048576 (workspace </> T.unpack name ++ ".tri")) 347 forM_ (S.toList (cExternal actualClosure `S.union` S.fromList [rOutput unit | (_,unit) <- M.elems (cReceipts actualClosure)])) $ \m -> do 348 evidence <- I.inspectModule app m 349 unless (I.inspectionStatus evidence == "verified") $ fail "rebuilt receipt graph contains an unverified executable module" 350 before <- I.inspectModule (StorePath (directory </> "store")) expected 351 after <- I.inspectModule app actual 352 let names i = either (const M.empty) (M.fromList . map (\ex -> (moduleExportName ex,ex)) . moduleManifestExports) (I.inspectedManifest i) 353 left = names before; right = names after 354 rows = ["export " <> I.safeText name <> ": " <> compareExport name <> "\n" | name <- S.toAscList (M.keysSet left `S.union` M.keysSet right)] 355 compareExport name = case (M.lookup name left,M.lookup name right) of 356 (Nothing,_) -> "added" 357 (_,Nothing) -> "removed" 358 (Just a,Just b) | moduleExportAbi a /= moduleExportAbi b -> "ABI changed" 359 _ -> case (M.lookup name (I.inspectedExports before),M.lookup name (I.inspectedExports after)) of 360 (Just (Right a),Just (Right b)) -> either (const "unknown") (\same -> if same then "tree identical" else "tree different") (I.compareGraphs a b) 361 _ -> "unknown" 362 exact = actual == expected && actualReceipt == recipeReceipt recipe && I.inspectionStatus before == "verified" && I.inspectionStatus after == "verified" 363 report = (if exact then "Reproduced native module and receipt exactly.\n" else "Rebuild mismatch; not reproduced exactly.\n") 364 <> "Inputs " <> pin <> "\nExpected module " <> expected <> "\nActual module " <> actual 365 <> "\nExpected receipt " <> recipeReceipt recipe <> "\nActual receipt " <> actualReceipt <> "\n" <> T.concat rows 366 <> "Local observation, not publisher authentication or a signed attestation.\n" 367 P.writeAtomic True (output </> "rebuild.txt") (encodeUtf8 report) 368 pure (report,exact)