Project.hs (21145B)
1 -- Explicit project dependency preparation, never called by the compiler. 2 module Project 3 ( Dependency(..), ProjectLock, Update(..), encodeProject, decodeProject 4 , encodeProjectLock, decodeProjectLock, validBinding 5 , resolveProject, fetchProject, bindProject, checkProject, explainProject, diffProject 6 ) where 7 8 import qualified Package as P 9 import qualified Module.Inspection as I 10 import qualified Module.Manifest as MM 11 import ContentStore.Alias (ObjectRef(..)) 12 import ContentStore.Object (StorePath, validateObjectHash) 13 import Control.Exception (catch, IOException) 14 import Control.Monad (unless, when, forM_, foldM) 15 import qualified Data.ByteString as BS 16 import qualified Data.Text as T 17 import Data.Text (Text) 18 import Data.Text.Encoding (encodeUtf8, decodeUtf8') 19 import qualified Data.Map.Strict as Map 20 import qualified Data.Set as Set 21 import Data.List (sortOn) 22 import System.Directory (removeFile) 23 import System.FilePath ((</>)) 24 import System.IO.Error (isDoesNotExistError) 25 import System.Posix.Files (getSymbolicLinkStatus, isRegularFile) 26 27 -- Aliases are flat workspace module names, not package names or filesystem paths. 28 data Dependency = Dependency 29 { dependencyAlias :: Text, dependencyRegistry :: Text 30 , dependencyName :: Text, dependencyVersion :: Text 31 } deriving (Eq, Show) 32 type ProjectLock = [(Text, P.PackageLock)] 33 data Update = Frozen | Selected [Text] | All deriving (Eq, Show) 34 35 validBinding :: Text -> Bool 36 validBinding name = not (T.null name) && T.length name <= 128 37 && start (T.head name) && T.all (\c -> start c || digit c || c == '-') name 38 && not (T.length name == 64 && T.all (\c -> digit c || c `elem` ("abcdef" :: String)) name) 39 where 40 digit c = c >= '0' && c <= '9' 41 start c = c == '_' || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') 42 43 aliasesValid :: [Text] -> Either String () 44 aliasesValid names = do 45 unless (length names <= 128 && all validBinding names) $ Left "invalid workspace binding name or more than 128 dependencies" 46 unless (Set.size (Set.fromList (map T.toCaseFold names)) == length names) $ Left "duplicate/case-colliding workspace binding" 47 48 rows :: Text -> BS.ByteString -> Either String [Text] 49 rows header bytes = do 50 when (BS.length bytes > 65536) $ Left "project metadata exceeds 64 KiB" 51 txt <- either (Left . show) Right (decodeUtf8' bytes) 52 case T.lines txt of 53 h:rest | h == header && encodeUtf8 (T.unlines (h:rest)) == bytes -> Right rest 54 _ -> Left "unsupported/noncanonical project metadata" 55 56 encodeProject :: [Dependency] -> BS.ByteString 57 encodeProject ds = encodeUtf8 $ T.unlines ("arboricx.project.v1" : map row ds) 58 where row d = T.intercalate "\t" [dependencyAlias d, dependencyRegistry d, dependencyName d, dependencyVersion d] 59 decodeProject :: BS.ByteString -> Either String [Dependency] 60 decodeProject bytes = do 61 rs <- rows "arboricx.project.v1" bytes 62 ds <- mapM (\r -> case T.splitOn "\t" r of 63 [a,g,n,v] | all P.validComponent [g,n,v] -> Right (Dependency a g n v) 64 _ -> Left "project rows require binding, registry, package and exact version (tabs)") rs 65 aliasesValid (map dependencyAlias ds) 66 pure (sortOn dependencyAlias ds) 67 68 encodeProjectLock :: ProjectLock -> BS.ByteString 69 encodeProjectLock ls = encodeUtf8 $ T.unlines ("arboricx.project-lock.v1" : map row (sortOn fst ls)) 70 where row (a,l) = let r = P.lockRelease l in T.intercalate "\t" 71 [a,P.lockRegistry l,P.lockURL l,P.releaseName r,P.releaseVersion r,P.releaseManifest r,P.releaseBundle r] 72 decodeProjectLock :: BS.ByteString -> Either String ProjectLock 73 decodeProjectLock bytes = do 74 rs <- rows "arboricx.project-lock.v1" bytes 75 ls <- mapM (\r -> case T.splitOn "\t" r of 76 [a,g,u,n,v,m,b] -> do 77 l <- P.decodeLock (P.encodeLock (P.PackageLock g u (P.Release n v m b))) 78 pure (a,l) 79 _ -> Left "invalid project lock row") rs 80 aliasesValid (map fst ls) 81 unless (encodeProjectLock ls == bytes) $ Left "project lock must be canonical and sorted" 82 _ <- foldM remember Map.empty (map snd ls) 83 pure ls 84 85 -- Registry labels are configuration handles. The immutable claim is identified 86 -- by origin/name/version, even if the same origin has two configured labels. 87 type Claim = (Text, Text, Text) 88 type Bindings = [(Text, Text)] 89 90 claim :: P.PackageLock -> Claim 91 claim l = let r = P.lockRelease l in (P.lockURL l,P.releaseName r,P.releaseVersion r) 92 remember :: Map.Map Claim P.Release -> P.PackageLock -> Either String (Map.Map Claim P.Release) 93 remember seen l = case Map.lookup (claim l) seen of 94 Just old | old /= P.lockRelease l -> Left "published version changed; refusing registry equivocation" 95 _ -> Right (Map.insert (claim l) (P.lockRelease l) seen) 96 selection :: (Text, P.PackageLock) -> Dependency 97 selection (a,l) = let r = P.lockRelease l in Dependency a (P.lockRegistry l) (P.releaseName r) (P.releaseVersion r) 98 99 readProject :: FilePath -> IO [Dependency] 100 readProject file = P.readSmall file >>= either fail pure . decodeProject 101 readLock :: FilePath -> IO ProjectLock 102 readLock file = P.readSmall file >>= either fail pure . decodeProjectLock 103 trusted :: [(Text, Text)] -> Text -> IO Text 104 trusted entries name = maybe (fail ("registry is not explicitly trusted: " ++ T.unpack name)) pure (lookup name entries) 105 consistent :: [Dependency] -> ProjectLock -> IO () 106 consistent ds ls = unless (ds == map selection ls) $ fail "project declaration differs from lock; resolve/update explicitly" 107 108 -- Only regular files may be managed; dangling links and directories are errors. 109 optionalFile :: FilePath -> IO (Maybe BS.ByteString) 110 optionalFile path = (do 111 status <- getSymbolicLinkStatus path 112 unless (isRegularFile status) $ fail ("expected regular file, refusing symlink/directory: " ++ path) 113 Just <$> P.readSmall path) `catch` (\(e :: IOException) -> if isDoesNotExistError e then pure Nothing else ioError e) 114 115 resolveProject :: FilePath -> FilePath -> FilePath -> Update -> IO Text 116 resolveProject project lock config update = do 117 P.distinctFiles project lock 118 P.distinctFiles config lock 119 ds <- readProject project 120 previous <- optionalFile lock 121 old <- maybe (pure []) (either fail pure . decodeProjectLock) previous 122 entries <- P.readRegistries config 123 wanted <- mapM (\d -> do u <- trusted entries (dependencyRegistry d); pure (dependencyAlias d,(d,u))) ds 124 let oldMap = Map.fromList old 125 wantedMap = Map.fromList wanted 126 names = Set.toAscList (Map.keysSet oldMap `Set.union` Map.keysSet wantedMap) 127 selected <- case (previous,update) of 128 (Nothing,Frozen) -> pure names 129 (Nothing,_) -> fail "project lock missing; resolve first" 130 (Just _,Frozen) -> pure [] 131 (Just _,All) -> pure names 132 (Just _,Selected ns) -> do 133 unless (not (null ns) && length ns == Set.size (Set.fromList ns) && all (`elem` names) ns) $ 134 fail "update requires unique known --dependency bindings (or --all)" 135 pure ns 136 -- Reject every unintended addition/removal/change before any network request. 137 forM_ names $ \a -> unless (a `elem` selected) $ case (Map.lookup a wantedMap, Map.lookup a oldMap) of 138 (Just (d,u),Just l) | d == selection (a,l) && u == P.lockURL l -> pure () 139 _ -> fail ("unselected dependency changed: " ++ T.unpack a ++ "; use project update --dependency " ++ T.unpack a) 140 known <- either fail pure (foldM remember Map.empty (map snd old)) 141 (new,_,_) <- foldM (resolveOne selected oldMap) ([],known,Map.empty) wanted 142 let next = sortOn fst new 143 bytes = encodeProjectLock next 144 _ <- either fail pure (decodeProjectLock bytes) 145 when (previous /= Just bytes) $ P.writeAtomic (previous == Nothing) lock bytes 146 pure (describeChanges old next) 147 where 148 resolveOne selected oldMap (acc,known,fetched) (a,(d,u)) 149 | a `notElem` selected = case Map.lookup a oldMap of 150 Just l -> pure ((a,l):acc,known,fetched) 151 Nothing -> fail "internal missing frozen dependency" 152 | otherwise = do 153 let key = (u,dependencyName d,dependencyVersion d) 154 r <- case Map.lookup key fetched of 155 Just release -> pure release 156 Nothing -> P.lockRelease <$> P.resolveSelection (dependencyRegistry d) u (dependencyName d) (dependencyVersion d) 157 let l = P.PackageLock (dependencyRegistry d) u r 158 known' <- either fail pure (remember known l) 159 pure ((a,l):acc,known',Map.insert key r fetched) 160 161 -- Human-readable selection diff: metadata/label changes do not imply code changed. 162 describeChanges :: ProjectLock -> ProjectLock -> Text 163 describeChanges old new = if null differences then "Project lock unchanged.\n" else T.concat differences 164 where 165 before = Map.fromList old; after = Map.fromList new 166 names = Set.toAscList (Map.keysSet before `Set.union` Map.keysSet after) 167 details label l = let r = P.lockRelease l in 168 " " <> label <> ": " <> P.lockRegistry l <> " (" <> P.lockURL l <> ") " <> P.releaseName r <> "@" <> P.releaseVersion r 169 <> "\n module " <> P.releaseManifest r <> "\n bundle " <> P.releaseBundle r <> "\n" 170 identity x y = if x == y then "unchanged" else "changed" 171 differences = [render a b c | a <- names, let b = Map.lookup a before, let c = Map.lookup a after, b /= c] 172 render a Nothing (Just n) = "Added " <> a <> "\n" <> details "after" n 173 render a (Just o) Nothing = "Removed " <> a <> "\n" <> details "before" o 174 render a (Just o) (Just n) = "Updated " <> a <> "\n" <> details "before" o <> details "after" n 175 <> " module " <> identity (P.releaseManifest (P.lockRelease o)) (P.releaseManifest (P.lockRelease n)) 176 <> "; bundle " <> identity (P.releaseBundle (P.lockRelease o)) (P.releaseBundle (P.lockRelease n)) <> "\n" 177 render _ _ _ = "" 178 179 fetchProject :: FilePath -> FilePath -> FilePath -> StorePath -> IO () 180 fetchProject project lock config store = do 181 ds <- readProject project 182 ls <- readLock lock 183 consistent ds ls 184 entries <- P.readRegistries config 185 urls <- mapM (\(_,l) -> do 186 u <- trusted entries (P.lockRegistry l) 187 unless (u == P.lockURL l) $ fail "configured registry origin differs from project lock" 188 pure (u,l)) ls 189 -- Complete preflight before importing even the first immutable object. 190 forM_ urls $ \(u,l) -> P.fetchSelection u l store 191 192 bindingState :: FilePath 193 bindingState = ".arboricx-project-bindings" 194 encodeBindings :: Bindings -> BS.ByteString 195 encodeBindings bs = encodeUtf8 $ T.unlines ("arboricx.project-bindings.v1" : [a <> "\t" <> m | (a,m) <- sortOn fst bs]) 196 decodeBindings :: BS.ByteString -> Either String Bindings 197 decodeBindings bytes = do 198 rs <- rows "arboricx.project-bindings.v1" bytes 199 bs <- mapM (\row -> case T.splitOn "\t" row of 200 [a,m] -> validateObjectHash m >> pure (a,m) 201 _ -> Left "invalid project binding state") rs 202 aliasesValid (map fst bs) 203 unless (encodeBindings bs == bytes) $ Left "noncanonical project binding state" 204 pure bs 205 readBindings :: FilePath -> IO Bindings 206 readBindings path = optionalFile path >>= maybe (pure []) (either fail pure . decodeBindings) 207 bindings :: ProjectLock -> Bindings 208 bindings ls = [(a,P.releaseManifest (P.lockRelease l)) | (a,l) <- ls] 209 verifyModules :: StorePath -> ProjectLock -> IO () 210 verifyModules store ls = forM_ ls $ \(a,l) -> do 211 found <- P.verifyLocal store (P.lockRelease l) 212 unless found $ fail ("locked module missing for " ++ T.unpack a ++ "; fetch explicitly first") 213 214 -- Trusted, exclusively owned workspaces. Batch writes are NOT atomic. A pending 215 -- journal records ownership before touching files, enabling safe roll-forward 216 -- after interruption and making `check` fail closed until binding completes. 217 bindProject :: FilePath -> FilePath -> FilePath -> StorePath -> IO () 218 bindProject project lock directory store = do 219 ds <- readProject project 220 ls <- readLock lock 221 consistent ds ls 222 let state = directory </> bindingState 223 pending = state ++ ".pending" 224 target a = directory </> T.unpack a ++ ".tri" 225 next = bindings ls 226 old <- readBindings state 227 interrupted <- readBindings pending 228 let owned = old ++ interrupted 229 names = Set.toAscList (Set.fromList (map fst (owned ++ next))) 230 unless (Set.size (Set.fromList (map T.toCaseFold names)) == length names) $ 231 fail "case-colliding old/new binding names; remove the old dependency and bind before adding the new name" 232 forM_ (state:pending:map target names) $ \output -> do 233 P.distinctFiles project output 234 P.distinctFiles lock output 235 verifyModules store ls 236 -- Never adopt or overwrite authored files, even if they match generated bytes. 237 forM_ names $ \a -> do 238 current <- optionalFile (target a) 239 case current of 240 Nothing -> pure () 241 Just bytes -> unless (any (\(b,m) -> b == a && bytes == P.bindingBytes m) owned) $ 242 fail ("unmanaged or edited binding; refusing overwrite/removal: " ++ target a) 243 -- Preserve ownership of all in-flight files if a second update interrupts a 244 -- recovery. Finish the earlier transaction first rather than losing its pins. 245 pendingBytes <- optionalFile pending 246 when (pendingBytes /= Nothing && interrupted /= next) $ 247 fail "unfinished binding transaction; restore its project/lock and bind before another update" 248 P.writeAtomic False pending (encodeBindings next) 249 forM_ next $ \(a,m) -> P.writeAtomic False (target a) (P.bindingBytes m) 250 forM_ names $ \a -> unless (a `elem` map fst next) $ 251 removeFile (target a) `catch` (\(e :: IOException) -> unless (isDoesNotExistError e) (ioError e)) 252 P.writeAtomic False state (encodeBindings next) 253 removeFile pending 254 255 checkProject :: FilePath -> FilePath -> FilePath -> StorePath -> IO () 256 checkProject project lock directory store = do 257 ds <- readProject project 258 ls <- readLock lock 259 consistent ds ls 260 let state = directory </> bindingState 261 next = bindings ls 262 pending <- optionalFile (state ++ ".pending") 263 when (pending /= Nothing) $ fail "unfinished binding transaction; run project bind" 264 actual <- optionalFile state 265 unless (actual == Just (encodeBindings next)) $ fail "project binding state differs from lock; run project bind" 266 forM_ next $ \(a,m) -> do 267 bytes <- optionalFile (directory </> T.unpack a ++ ".tri") 268 unless (bytes == Just (P.bindingBytes m)) $ fail ("missing/changed project binding: " ++ T.unpack a) 269 verifyModules store ls 270 271 -- Reports never initialize a store, fetch objects or evaluate executable terms. 272 explainProject :: FilePath -> FilePath -> FilePath -> StorePath -> IO (Text, Bool) 273 explainProject project lock directory store = do 274 ds <- readProject project 275 ls <- readLock lock 276 state <- diagnosticFile (directory </> bindingState) 277 pending <- diagnosticFile (directory </> bindingState ++ ".pending") 278 let owned = state == Right (Just (encodeBindings (bindings ls))) 279 settled = pending == Right Nothing 280 ledger = if owned then "matches lock" else "missing, changed or unreadable" 281 transaction = if settled then "none" else "pending or unreadable; finish project bind" 282 declared = Map.fromList [(dependencyAlias d,d) | d <- ds] 283 locked = Map.fromList ls 284 names = Set.toAscList (Map.keysSet declared `Set.union` Map.keysSet locked) 285 reports <- mapM (explainOne declared locked) names 286 pure ("Offline project explanation (locked claims, not registry/provenance verification)\n" 287 <> "Ownership ledger: " <> ledger <> "\nBinding transaction: " <> transaction <> "\n" 288 <> T.concat (map fst reports), owned && settled && and (map snd reports)) 289 where 290 explainOne declared locked a = case Map.lookup a locked of 291 Nothing -> pure ("Binding " <> a <> ": declared but not locked\n" <> declaredLine (Map.lookup a declared),False) 292 Just l -> do 293 evidence <- I.inspectModule store (P.releaseManifest (P.lockRelease l)) 294 actual <- diagnosticFile (directory </> T.unpack a ++ ".tri") 295 let matches = actual == Right (Just (P.bindingBytes (P.releaseManifest (P.lockRelease l)))) 296 selectionMatches = Map.lookup a declared == Just (selection (a,l)) 297 sourceStatus = case actual of 298 Left err -> "unavailable: " <> I.safeText err 299 Right Nothing -> "missing" 300 Right (Just _) -> if matches then "matches lock" else "differs from lock" 301 exportLines = [" export " <> I.safeText n <> ": " <> either I.safeText (const "verified") v <> "\n" 302 | (n,v) <- Map.toAscList (I.inspectedExports evidence)] 303 finishReport ("Binding " <> a <> "\n" <> declaredLine (Map.lookup a declared) <> selectionDetails l 304 <> " declaration: " <> (if selectionMatches then "matches lock" else "differs from lock or absent") 305 <> "\n generated binding: " <> sourceStatus <> "\n local module: " <> I.safeText (I.inspectionStatus evidence) <> "\n" 306 <> T.concat exportLines, matches && selectionMatches && I.inspectionStatus evidence == "verified") 307 308 declaredLine Nothing = " declared: absent\n" 309 declaredLine (Just d) = " declared: " <> dependencyRegistry d <> " " <> dependencyName d <> "@" <> dependencyVersion d <> "\n" 310 311 diagnosticFile :: FilePath -> IO (Either Text (Maybe BS.ByteString)) 312 diagnosticFile path = (Right <$> optionalFile path) `catch` (\(e :: IOException) -> pure (Left (T.pack (show e)))) 313 314 selectionDetails :: P.PackageLock -> Text 315 selectionDetails l = let r = P.lockRelease l in 316 " selection: " <> P.lockRegistry l <> " (" <> P.lockURL l <> ") " <> P.releaseName r <> "@" <> P.releaseVersion r 317 <> "\n module: " <> P.releaseManifest r <> "\n bundle: " <> P.releaseBundle r <> "\n" 318 319 diffProject :: FilePath -> FilePath -> StorePath -> IO (Text, Bool) 320 diffProject before after store = do 321 old <- readLock before 322 new <- readLock after 323 let om = Map.fromList old; nm = Map.fromList new 324 names = Set.toAscList (Map.keysSet om `Set.union` Map.keysSet nm) 325 reports <- mapM (diffOne om nm) names 326 pure ("Offline project comparison; structural differences do not prove behavioral differences.\n" 327 <> describeChanges old new <> T.concat (map fst reports), and (map snd reports)) 328 where 329 diffOne om nm a = do 330 left <- traverse (I.inspectModule store . P.releaseManifest . P.lockRelease) (Map.lookup a om) 331 right <- traverse (I.inspectModule store . P.releaseManifest . P.lockRelease) (Map.lookup a nm) 332 let status Nothing = "not selected" 333 status (Just e) = I.inspectionStatus e 334 complete Nothing = True 335 complete (Just e) = I.inspectionStatus e == "verified" 336 heading = "Binding " <> a <> "\n selection: " <> (if Map.lookup a om == Map.lookup a nm then "unchanged" else "changed") <> "\n before evidence: " <> I.safeText (status left) 337 <> "\n after evidence: " <> I.safeText (status right) <> "\n" 338 interface Nothing = Just Map.empty 339 interface (Just e) = either (const Nothing) (Just . Map.fromList . map (\ex -> (MM.moduleExportName ex,ex)) . MM.moduleManifestExports) (I.inspectedManifest e) 340 detail = case (interface left,interface right) of 341 (Just l,Just r) -> T.concat [exportChange left right n (Map.lookup n l) (Map.lookup n r) 342 | n <- Set.toAscList (Map.keysSet l `Set.union` Map.keysSet r)] 343 _ -> " interface/structure: unknown (module evidence unavailable)\n" 344 finishReport (heading <> detail, complete left && complete right) 345 exportChange _ right n Nothing (Just _) = " export " <> I.safeText n <> ": added; evidence " <> exportStatus right n <> "\n" 346 exportChange left _ n (Just _) Nothing = " export " <> I.safeText n <> ": removed; evidence " <> exportStatus left n <> "\n" 347 exportChange left right n (Just l) (Just r) = 348 let same x y = if x == y then "unchanged" else "changed" 349 ref ex = MM.moduleExportObject ex 350 evidence item = item >>= Map.lookup n . I.inspectedExports 351 structure = case (evidence left,evidence right) of 352 (Just (Right x),Just (Right y)) -> either (\err -> "unknown: " <> I.safeText (T.pack err)) 353 (\equal -> if equal then "identical" else "different") (I.compareGraphs x y) 354 (x,y) -> "unknown (before: " <> reason x <> "; after: " <> reason y <> ")" 355 reason Nothing = "unavailable" 356 reason (Just (Left err)) = I.safeText err 357 reason (Just (Right _)) = "verified" 358 in " export " <> I.safeText n <> ": ABI " <> same (MM.moduleExportAbi l) (MM.moduleExportAbi r) 359 <> " [" <> I.safeText (MM.moduleExportAbi l) <> " -> " <> I.safeText (MM.moduleExportAbi r) <> "]" 360 <> "; kind " <> same (objectRefKind (ref l)) (objectRefKind (ref r)) 361 <> "; object " <> same (objectRefHash (ref l)) (objectRefHash (ref r)) 362 <> "; tree " <> structure <> "\n" 363 exportChange _ _ _ _ _ = "" 364 exportStatus item n = case item >>= Map.lookup n . I.inspectedExports of 365 Just (Right _) -> "verified" 366 Just (Left err) -> I.safeText err 367 Nothing -> "unknown" 368 369 -- Materialize each strict Text report before visiting the next dependency, so 370 -- lazy report construction does not retain every dependency's parsed graphs. 371 finishReport :: (Text, Bool) -> IO (Text, Bool) 372 finishReport (report, complete) = report `seq` complete `seq` pure (report, complete)