diff --git a/seihou-core.cabal b/seihou-core.cabal --- a/seihou-core.cabal +++ b/seihou-core.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-core -version: 0.9.0.0 +version: 0.10.0.0 synopsis: Core library for Seihou project scaffolding description: Core library for Seihou, a composable project scaffolding system. @@ -44,6 +44,7 @@ Seihou.Core.ArtifactOriginDetect Seihou.Core.ArtifactRef Seihou.Core.Blueprint + Seihou.Core.Checkout Seihou.Core.CommandFingerprint Seihou.Core.CommandVar Seihou.Core.Context @@ -56,6 +57,7 @@ Seihou.Core.Registry Seihou.Core.Scaffold Seihou.Core.SchemaUpgrade + Seihou.Core.Seed Seihou.Core.Status Seihou.Core.Types Seihou.Core.Variable @@ -89,6 +91,7 @@ Seihou.Effect.ProcessInterp Seihou.Effect.ProcessPure Seihou.Engine.Baseline + Seihou.Engine.Checkout Seihou.Engine.Conflict Seihou.Engine.DhallJSON Seihou.Engine.Diff @@ -107,11 +110,13 @@ Seihou.Interaction.Confirm Seihou.Interaction.Prompt Seihou.Manifest.Hash + Seihou.Manifest.JSON Seihou.Manifest.Types + Seihou.Manifest.Upgrade Seihou.Prelude build-depends: - aeson >=2.1 && <3, + aeson >=2.1.2 && <3, aeson-pretty >=0.8 && <1, base >=4.18 && <5, base16-bytestring >=1.0 && <2, @@ -152,9 +157,11 @@ Seihou.Composition.ResolveSpec Seihou.Core.AgentPromptSpec Seihou.Core.ApplicationSpec + Seihou.Core.ArtifactIdentitySpec Seihou.Core.ArtifactOriginDetectSpec Seihou.Core.ArtifactRefSpec Seihou.Core.BlueprintSpec + Seihou.Core.CheckoutSpec Seihou.Core.CommandFingerprintSpec Seihou.Core.CommandVarSpec Seihou.Core.ContextSpec @@ -170,6 +177,7 @@ Seihou.Core.RegistrySyncSpec Seihou.Core.ScaffoldSpec Seihou.Core.SchemaUpgradeSpec + Seihou.Core.SeedSpec Seihou.Core.StatusSpec Seihou.Core.TypesSpec Seihou.Core.VariableSpec @@ -184,6 +192,7 @@ Seihou.Effect.LoggerSpec Seihou.Effect.ManifestStoreSpec Seihou.Engine.BaselineSpec + Seihou.Engine.CheckoutSpec Seihou.Engine.ConflictSpec Seihou.Engine.DiffSpec Seihou.Engine.ExecuteSpec @@ -208,9 +217,10 @@ Seihou.Interaction.ConfirmSpec Seihou.Interaction.PromptSpec Seihou.Manifest.TypesSpec + Seihou.Manifest.UpgradeSpec build-depends: - aeson >=2.1 && <3, + aeson >=2.1.2 && <3, base >=4.18 && <5, bytestring >=0.11 && <1, containers >=0.6 && <1, @@ -221,6 +231,7 @@ generic-lens >=2.2 && <3, hspec >=2.11 && <3, lens >=5.2 && <6, + process >=1.6 && <1.7, seihou-core, tasty >=1.4 && <2, tasty-hspec >=1.2 && <2, diff --git a/src/Seihou/Composition/Plan.hs b/src/Seihou/Composition/Plan.hs --- a/src/Seihou/Composition/Plan.hs +++ b/src/Seihou/Composition/Plan.hs @@ -18,6 +18,7 @@ import Data.Text.Lazy.Encoding qualified as TLE import Data.Yaml qualified as Yaml import Seihou.Composition.Instance (ModuleInstance, qualifiedName) +import Seihou.Core.Checkout (CheckoutError (..), checkoutClaims, pathsOverlap) import Seihou.Core.Types import Seihou.Engine.Plan (compilePlan) import Seihou.Engine.Section (applyTextPatch) @@ -40,7 +41,15 @@ results <- mapM compileOne modules let (errs, opsPerModule) = partitionResults results if null errs - then pure (Right (mergeOperations opsPerModule)) + then do + let ops = concatMap snd opsPerModule + links = [dest | CheckoutOutputOp {dest} <- ops] + bytes = [dest | op <- ops, Just dest <- [destOfOp op]] + overlaps = ["checkout output '" <> T.pack link <> "' overlaps byte-writing output '" <> T.pack path <> "'" | link <- links, path <- bytes, pathsOverlap link path] + pure $ case checkoutClaims (ApplicationId "composition") ops of + Left err -> Left [err ^. #message] + Right _ | not (null overlaps) -> Left overlaps + Right _ -> Right (mergeOperations opsPerModule) else pure (Left (concat errs)) where compileOne (inst, m, dir, vars) = do @@ -83,6 +92,7 @@ go [] fileOwner _ opsAcc warningsAcc = (opsAcc, warningsAcc, fileOwner) go ((name, op) : rest) fileOwner seenDirs opsAcc warningsAcc = case op of + CheckoutOutputOp {} -> go rest fileOwner seenDirs (op : opsAcc) warningsAcc CreateDirOp p | Set.member p seenDirs -> go rest fileOwner seenDirs opsAcc warningsAcc | otherwise -> go rest fileOwner (Set.insert p seenDirs) (op : opsAcc) warningsAcc diff --git a/src/Seihou/Core/Application.hs b/src/Seihou/Core/Application.hs --- a/src/Seihou/Core/Application.hs +++ b/src/Seihou/Core/Application.hs @@ -93,7 +93,8 @@ -- The current record's baseline is preserved: EP-65 captures the exact -- post-execution generated content before ownership is attached. -- --- @additiveOnly@ can only be weakened here, never strengthened. This run +-- The shared-write mode can only be kept or weakened here, never +-- strengthened ('mergeSharedWriteMode'). This run -- executed only its own application's operations, so its answer covers only -- its own contributions; when a prior owner survives outside this run, the -- prior record is the only evidence about that owner's write mode, and a @@ -105,12 +106,15 @@ attachApplication applicationId previous current = current & #applicationIds .~ Set.insert applicationId (Set.union (current ^. #applicationIds) priorApplications) - & #additiveOnly .~ ((current ^. #additiveOnly) && (not partial || priorAdditive)) + & #sharedWriteMode + .~ mergeSharedWriteMode + partial + ((^. #sharedWriteMode) <$> previous) + (current ^. #sharedWriteMode == SharedWriteAdditiveOnly) where priorApplications = maybe Set.empty (^. #applicationIds) previous retainedOwners = Set.delete applicationId priorApplications partial = not (Set.null retainedOwners) - priorAdditive = maybe False (^. #additiveOnly) previous varValueToText :: VarValue -> Text varValueToText (VText value) = value diff --git a/src/Seihou/Core/ArtifactIdentity.hs b/src/Seihou/Core/ArtifactIdentity.hs --- a/src/Seihou/Core/ArtifactIdentity.hs +++ b/src/Seihou/Core/ArtifactIdentity.hs @@ -20,9 +20,11 @@ ( sameArtifactIdentity, normalizeOriginUrl, normalizeProjectPath, + isMachineLocalOriginUrl, ) where +import Data.Char (isAsciiLower, isAsciiUpper) import Data.Maybe (fromMaybe) import Data.Text qualified as T import Seihou.Core.Types (ArtifactOrigin (..)) @@ -75,3 +77,31 @@ then Just (drop (length prefix) path) else Nothing dropWhileEnd' p = reverse . dropWhile p . reverse + +-- | Whether a recorded origin URL is a path on the machine that recorded it +-- rather than a location every developer can reach. +-- +-- @seihou install@ accepts a local checkout, and before plan 98 it stored +-- that path verbatim as the installed copy's @sourceUrl@, which then reached +-- the manifest as a 'RemoteOrigin'. A path means nothing on another machine +-- (docs\/adr\/0001-manifest-is-a-checked-in-machine-independent-artifact.md) +-- and turns into a false origin mismatch on this one as soon as the artifact +-- is reinstalled from its real remote. +-- +-- True for text that, once stripped, starts with @\/@, @.\/@, @..\/@, @~@ +-- or @file:@, is exactly @.@ or @..@, or is a Windows drive path +-- (@C:\\@ or @C:\/@). False for URLs with a network scheme +-- (@https:\/\/@, @ssh:\/\/@, @git:\/\/@) and for scp-style +-- @user\@host:path@. +isMachineLocalOriginUrl :: Text -> Bool +isMachineLocalOriginUrl raw = + any (`T.isPrefixOf` url) ["/", "./", "../", "~", "file:"] + || url == "." + || url == ".." + || isDrivePath url + where + url = T.strip raw + isDrivePath text = case T.unpack (T.take 3 text) of + [letter, ':', sep] -> isDriveLetter letter && (sep == '\\' || sep == '/') + _ -> False + isDriveLetter c = isAsciiLower c || isAsciiUpper c diff --git a/src/Seihou/Core/ArtifactOriginDetect.hs b/src/Seihou/Core/ArtifactOriginDetect.hs --- a/src/Seihou/Core/ArtifactOriginDetect.hs +++ b/src/Seihou/Core/ArtifactOriginDetect.hs @@ -26,6 +26,7 @@ import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels () import Data.Text qualified as T +import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl) import Seihou.Core.Types (ArtifactOrigin (..)) import Seihou.Prelude import System.Directory (canonicalizePath, doesFileExist) @@ -69,11 +70,18 @@ -- 'ProjectOrigin' holding the path relative to @projectRoot@ with -- forward slashes. -- 2. Otherwise, if @artifactDir@ contains a readable --- @.seihou-origin.json@ with a @sourceUrl@, the result is a --- 'RemoteOrigin' carrying that URL, the directory's base name, and --- the recorded @repoName@. +-- @.seihou-origin.json@ with a @sourceUrl@ that is not a machine-local +-- path, the result is a 'RemoteOrigin' carrying that URL, the +-- directory's base name, and the recorded @repoName@. -- 3. Otherwise the result is a 'LocalOrigin' holding the directory's --- base name. +-- base name. This includes a @sourceUrl@ that +-- 'isMachineLocalOriginUrl' recognises as a path (an install from a +-- local checkout whose commit seihou could not trace to a published +-- remote): the path is meaningful only on this machine, so recording it +-- would break the manifest for everyone else and turn into a false +-- origin mismatch here once the artifact is reinstalled from its real +-- remote. 'LocalOrigin' says what is actually known — the provenance +-- is not portable. detectArtifactOrigin :: FilePath -> FilePath -> IO ArtifactOrigin detectArtifactOrigin projectRoot artifactDir = do root <- canonicalizeOr projectRoot @@ -84,8 +92,10 @@ originInfo <- readOriginInfo dir let name = T.pack (takeFileName dir) pure $ case originInfo of - Just info -> RemoteOrigin (info ^. #sourceUrl) name (info ^. #repoName) - Nothing -> LocalOrigin name + Just info + | not (isMachineLocalOriginUrl (info ^. #sourceUrl)) -> + RemoteOrigin (info ^. #sourceUrl) name (info ^. #repoName) + _ -> LocalOrigin name -- | 'canonicalizePath' throws when an intermediate component does not -- exist, which happens in tests and for artifacts that were removed between diff --git a/src/Seihou/Core/Checkout.hs b/src/Seihou/Core/Checkout.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Checkout.hs @@ -0,0 +1,202 @@ +module Seihou.Core.Checkout + ( CheckoutError (..), + checkoutError, + validateCheckoutPaths, + validateCheckoutRecords, + mergeCheckoutRecord, + dropCheckoutOwners, + checkoutClaims, + checkoutSource, + replaceCheckoutApplications, + CheckoutIntent (..), + CheckoutPolicy (..), + CheckoutObservation (..), + CheckoutAction (..), + CheckoutEntry (..), + CheckoutPlan (..), + planCheckoutOutputs, + checkoutApplicable, + expectedTarget, + pathsOverlap, + ) +where + +import Control.Monad (foldM, forM_, unless, when) +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust, maybeToList) +import Data.Set qualified as Set +import Data.Text qualified as T +import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName) +import Seihou.Core.Path (validateCanonicalProjectPath) +import Seihou.Core.Types +import Seihou.Effect.Filesystem (PathEntry (..)) +import Seihou.Prelude +import System.FilePath.Posix qualified as P + +-- | Stable machine code and an actionable human explanation. +data CheckoutError = CheckoutError {code :: !Text, message :: !Text} + deriving stock (Eq, Show, Generic) + +checkoutError :: Text -> Text -> CheckoutError +checkoutError = CheckoutError + +checkoutSource :: CheckoutOutputSpec -> FilePath +checkoutSource (DirectorySymlink source) = source + +pathsOverlap :: FilePath -> FilePath -> Bool +pathsOverlap a b = a == b || (a <> "/") `isPrefixOf` b || (b <> "/") `isPrefixOf` a + where + isPrefixOf x y = T.pack x `T.isPrefixOf` T.pack y + +validateCheckoutPaths :: FilePath -> FilePath -> Either CheckoutError () +validateCheckoutPaths source dest = do + forM_ [source, dest] $ \path -> first (checkoutError "checkout_path_invalid") (validateCanonicalProjectPath (T.pack path)) + when (pathsOverlap source dest) $ Left (checkoutError "checkout_path_overlap" "source and destination must not overlap") + +-- | Validate the entire candidate, including application-local instance ownership. +validateCheckoutRecords :: Manifest -> [FilePath] -> Either CheckoutError () +validateCheckoutRecords manifest pending = do + let outputs = manifest ^. #checkoutOutputs + bytePaths = Map.keys (manifest ^. #files) <> Map.keys (manifest ^. #seeds) <> pending + forM_ (Map.toAscList outputs) $ \(dest, record) -> do + validateCheckoutPaths (checkoutSource (record ^. #spec)) dest + when (Map.null (record ^. #owners)) $ bad dest "has no owners" + forM_ (Map.toAscList (record ^. #owners)) $ \(appId, names) -> do + when (Set.null names) $ bad dest "has an empty instance owner set" + case filter ((== appId) . (^. #applicationId)) (manifest ^. #applications) of + [app] -> unless (names `Set.isSubsetOf` Set.fromList [qualifiedName (ModuleInstance (state ^. #name) (state ^. #parentVars)) | state <- app ^. #instances]) $ bad dest "names an instance outside its owning application" + _ -> bad dest "names an unknown or duplicate application owner" + forM_ bytePaths $ \path -> when (pathsOverlap dest path) $ bad dest ("overlaps managed or seed output '" <> T.pack path <> "'; resolve the lifecycle transition manually") + forM_ (Map.keys outputs) $ \other -> do + when (dest /= other && pathsOverlap dest other) $ bad dest ("overlaps checkout destination '" <> T.pack other <> "'") + when (pathsOverlap (checkoutSource (record ^. #spec)) other) $ bad dest ("source overlaps checkout destination '" <> T.pack other <> "'") + where + bad dest reason = Left (checkoutError "checkout_declaration_invalid" ("checkout output '" <> T.pack dest <> "' " <> reason)) + +mergeCheckoutRecord :: FilePath -> CheckoutOutputRecord -> Map FilePath CheckoutOutputRecord -> Either CheckoutError (Map FilePath CheckoutOutputRecord) +mergeCheckoutRecord dest record records = case Map.lookup dest records of + Nothing -> Right (Map.insert dest record records) + Just old | old ^. #spec == record ^. #spec -> Right (Map.insert dest (old & #owners %~ Map.unionWith Set.union (record ^. #owners)) records) + Just _ -> Left (checkoutError "checkout_owner_conflict" ("checkout owners disagree on '" <> T.pack dest <> "'")) + +-- | Replace the selected claims; preserve all unselected application/instance owners. +dropCheckoutOwners :: Map ApplicationId (Set ModuleName) -> Map FilePath CheckoutOutputRecord -> Map FilePath CheckoutOutputRecord +dropCheckoutOwners selected = Map.mapMaybe $ \record -> + let retained = Map.mapMaybeWithKey (\app names -> let rest = names `Set.difference` Map.findWithDefault Set.empty app selected in if Set.null rest then Nothing else Just rest) (record ^. #owners) + in if Map.null retained then Nothing else Just (record & #owners .~ retained) + +checkoutClaims :: ApplicationId -> [Operation] -> Either CheckoutError (Map FilePath CheckoutOutputRecord) +checkoutClaims app = foldM add Map.empty + where + add records CheckoutOutputOp {dest, spec, moduleName} = mergeCheckoutRecord dest (CheckoutOutputRecord spec (Map.singleton app (Set.singleton moduleName))) records + add records _ = Right records + +data CheckoutIntent = Rebuild | Reconcile deriving stock (Eq, Show, Generic) + +data CheckoutPolicy = SyncIgnoredOnly | ApplyDeclaration deriving stock (Eq, Show, Generic) + +data CheckoutObservation = CheckoutObservation + { entry :: !PathEntry, + sourceDirectory :: !Bool, + problems :: ![CheckoutError], + gitAvailable :: !Bool, + ignored :: !Bool + } + deriving stock (Eq, Show, Generic) + +data CheckoutAction = CreateLink | ReplaceLink | RetireLink | UnchangedLink | AlreadyAbsent | PreserveModified | RefusedLink + deriving stock (Eq, Ord, Show, Generic) + +data CheckoutEntry = CheckoutEntry + { dest :: !FilePath, + previous :: !(Maybe CheckoutOutputSpec), + candidate :: !(Maybe CheckoutOutputSpec), + observation :: !CheckoutObservation, + action :: !CheckoutAction, + errors :: ![CheckoutError], + warnings :: ![Text] + } + deriving stock (Eq, Show, Generic) + +newtype CheckoutPlan = CheckoutPlan {entries :: [CheckoutEntry]} + deriving stock (Eq, Show, Generic) + +checkoutApplicable :: CheckoutPlan -> Bool +checkoutApplicable = all (null . (^. #errors)) . (^. #entries) + +expectedTarget :: FilePath -> CheckoutOutputSpec -> FilePath +expectedTarget dest (DirectorySymlink source) = + let parent = P.takeDirectory dest + depth = if parent == "." then 0 else length (P.splitDirectories parent) + in P.joinPath (replicate depth ".." <> [source]) + +planCheckoutOutputs :: CheckoutIntent -> CheckoutPolicy -> Map FilePath CheckoutOutputRecord -> Map FilePath CheckoutOutputRecord -> Map FilePath CheckoutObservation -> CheckoutPlan +planCheckoutOutputs intent policy prior candidate observations = CheckoutPlan (map plan (Set.toAscList (Map.keysSet prior <> Map.keysSet candidate))) + where + plan dest = + let old = (^. #spec) <$> Map.lookup dest prior + new = (^. #spec) <$> Map.lookup dest candidate + obs = Map.findWithDefault (CheckoutObservation EntryMissing False [checkoutError "checkout_observation_missing" "output was not observed"] False False) dest observations + unchanged = intent == Reconcile && old == new + active = isJust new + syntax = [err | spec <- maybeToList new <> maybeToList old, Left err <- [validateCheckoutPaths (checkoutSource spec) dest]] + policyErrors = + [checkoutError "checkout_git_required" "sync requires a Git working tree" | policy == SyncIgnoredOnly, not (obs ^. #gitAvailable)] + <> [checkoutError "checkout_not_ignored" "destination must be ignored; add it to .gitignore before running seihou sync" | policy == SyncIgnoredOnly, active, not (obs ^. #ignored)] + preconditions = + if unchanged + then [] + else + obs ^. #problems + <> policyErrors + <> [checkoutError "checkout_source_missing" "source must be an existing real project directory; restore it before retrying" | active, not (obs ^. #sourceDirectory)] + contract = [checkoutError "checkout_rebuild_contract" "rebuild requires identical prior and candidate declarations" | intent == Rebuild, prior /= candidate] + (proposed, collisions) = classify dest old new (obs ^. #entry) unchanged + errs = contract <> syntax <> preconditions <> collisions + warnings = + ["preserved a modified checkout entry; released its declaration" | proposed == PreserveModified] + <> ["Git evidence unavailable; applying a declaration before git-init" | not unchanged, policy == ApplyDeclaration, not (obs ^. #gitAvailable)] + <> ["checkout destination is not ignored; clones require ignore rules for seihou sync" | not unchanged, policy == ApplyDeclaration, obs ^. #gitAvailable, active, not (obs ^. #ignored)] + in CheckoutEntry dest old new obs (if null errs then proposed else RefusedLink) errs warnings + classify _ _ _ _ True = (UnchangedLink, []) + classify dest old Nothing entry _ = case entry of + EntryMissing -> (AlreadyAbsent, []) + EntrySymlink target | Just spec <- old, target == expectedTarget dest spec -> (RetireLink, []) + _ -> (PreserveModified, []) + classify dest old (Just spec) entry _ = case entry of + EntryMissing -> (CreateLink, []) + EntrySymlink target + | target == expectedTarget dest spec -> (UnchangedLink, []) + | intent == Rebuild || maybe False ((== target) . expectedTarget dest) old -> (ReplaceLink, []) + | otherwise -> (RefusedLink, [checkoutError "checkout_link_modified" "link target changed locally; move it aside or restore its recorded target"]) + _ -> (RefusedLink, [checkoutError "checkout_destination_occupied" "destination is a real file or directory; move it aside manually"]) + +-- | Re-evaluation replaces a selected application's complete declaration set, +-- including dependencies that disappeared or whose conditions became false. +replaceCheckoutApplications :: Manifest -> [(AppliedComposition, [Operation])] -> Either CheckoutError Manifest +replaceCheckoutApplications prior applications = do + let selected = Set.fromList [app ^. #applicationId | (app, _) <- applications] + departing = Map.unionsWith Set.union [Map.restrictKeys (record ^. #owners) selected | record <- Map.elems (prior ^. #checkoutOutputs)] + retained = dropCheckoutOwners departing (prior ^. #checkoutOutputs) + updateApps apps (app, _) = app : filter ((/= app ^. #applicationId) . (^. #applicationId)) apps + outputs <- foldM add retained applications + let candidate = prior & #checkoutOutputs .~ outputs & #applications .~ foldl updateApps (prior ^. #applications) applications + pending = + [ dest + | (_, ops) <- applications, + op <- ops, + dest <- case op of + WriteFileOp {dest} -> [dest] + CopyFileOp {dest} -> [dest] + PatchFileOp {dest} -> [dest] + _ -> [] + ] + validateCheckoutRecords candidate pending + forM_ pending $ \path -> forM_ (Map.keys (prior ^. #checkoutOutputs)) $ \old -> + when (pathsOverlap path old) $ Left (checkoutError "checkout_lifecycle_transition" ("output '" <> T.pack path <> "' overlaps a previous checkout declaration; remove that declaration and resolve the transition manually")) + pure candidate + where + add records (app, ops) = do + claims <- checkoutClaims (app ^. #applicationId) ops + foldM (\acc (dest, record) -> mergeCheckoutRecord dest record acc) records (Map.toAscList claims) diff --git a/src/Seihou/Core/Module.hs b/src/Seihou/Core/Module.hs --- a/src/Seihou/Core/Module.hs +++ b/src/Seihou/Core/Module.hs @@ -25,6 +25,8 @@ checkSafeDestinations, checkDestVarRefs, checkCommandSafety, + checkSeedSteps, + checkCheckoutSteps, isValidModuleName, extractPlaceholders, validateProjectRelativePath, @@ -33,8 +35,10 @@ import Data.Generics.Labels () import Data.Map.Strict qualified as Map +import Data.Maybe (isJust, maybeToList) import Data.Set qualified as Set import Data.Text qualified as T +import Seihou.Core.Checkout (CheckoutError (..), validateCheckoutPaths) import Seihou.Core.Path (validateProjectRelativePath) import Seihou.Core.Types import Seihou.Dhall.Eval (evalAgentPromptFromFile, evalBlueprintFromFile, evalModuleFromFile, evalRecipeFromFile) @@ -177,6 +181,8 @@ <> checkSafeDestinations m <> checkDestVarRefs m <> checkCommandSafety m + <> checkSeedSteps m + <> checkCheckoutSteps m allErrors = pureErrors <> fileErrors pure $ if null allErrors @@ -235,13 +241,16 @@ checkFileExistence baseDir m = concat <$> mapM - ( \s -> do - let p = baseDir "files" (s ^. #src) - exists <- doesFileExist p - pure $ - if exists - then [] - else ["step source file not found: " <> T.pack (s ^. #src)] + ( \s -> + if s ^. #strategy == Symlink + then pure [] + else do + let p = baseDir "files" (s ^. #src) + exists <- doesFileExist p + pure $ + if exists + then [] + else ["step source file not found: " <> T.pack (s ^. #src)] ) (m ^. #steps) @@ -563,3 +572,39 @@ briefLoadError (MissingSourceFile _ _) = "missing source file" briefLoadError (CircularDependency _) = "circular dependency" briefLoadError (RegistryEvalError _ _) = "registry eval failed" + +-- | A seed creates an entire file and must never be subject to automatic removal. +checkSeedSteps :: Module -> [Text] +checkSeedSteps m = concatMap checkStep seedSteps <> mixed <> removals + where + seedSteps = filter ((== Seed) . (^. #lifecycle)) (m ^. #steps) + checkStep s = + ["step writing '" <> s ^. #dest <> "' is a seed but has a patch; a seed creates a whole file once and cannot patch one" | isJust (s ^. #patch)] + <> ["step writing '" <> s ^. #dest <> "' is a seed but uses the structured strategy; seeds support copy, template, and dhall-text" | s ^. #strategy == Structured] + mixed = + [ "steps writing '" <> dest <> "' mix the seed and managed lifecycles; use one lifecycle per destination" + | dest <- Set.toAscList (Set.fromList (map (^. #dest) seedSteps)), + any (\s -> s ^. #dest == dest && s ^. #lifecycle == Managed) (m ^. #steps) + ] + removals = + [ "removal step deletes '" <> s ^. #dest <> "', which a seed step creates; seihou never deletes seed files" + | removal <- maybeToList (m ^. #removal), + r <- removal ^. #steps, + r ^. #action == RemoveFileAction, + s <- seedSteps, + s ^. #dest == r ^. #dest + ] + +-- | Directory links are declarations about the consuming project, not cached files. +checkCheckoutSteps :: Module -> [Text] +checkCheckoutSteps m = concatMap check (m ^. #steps) + where + check s + | s ^. #strategy /= Symlink && s ^. #lifecycle /= Checkout = [] + | otherwise = + [label s <> "requires strategy symlink and lifecycle checkout together" | s ^. #strategy /= Symlink || s ^. #lifecycle /= Checkout] + <> [label s <> "cannot carry a patch" | isJust (s ^. #patch)] + <> [label s <> err ^. #message | Left err <- [validateCheckoutPaths (s ^. #src) (T.unpack (s ^. #dest))]] + <> [label s <> "source references undeclared variable: " <> name | name <- extractPlaceholders (T.pack (s ^. #src)), name `notElem` map (^. #name . #unVarName) (m ^. #vars)] + <> [label s <> "has malformed placeholders" | path <- [T.pack (s ^. #src), s ^. #dest], T.count "{{" path /= T.count "}}" path] + label s = "step writing '" <> s ^. #dest <> "' " diff --git a/src/Seihou/Core/Path.hs b/src/Seihou/Core/Path.hs --- a/src/Seihou/Core/Path.hs +++ b/src/Seihou/Core/Path.hs @@ -1,5 +1,6 @@ module Seihou.Core.Path ( validateProjectRelativePath, + validateCanonicalProjectPath, ) where @@ -27,3 +28,15 @@ pathSegments = filter (not . T.null) . T.split (\c -> c == '/' || c == '\\') + +-- | Checkout declarations use a canonical, portable spelling and reserve metadata. +-- This deliberately strengthens rather than changes the legacy validator above. +validateCanonicalProjectPath :: Text -> Either Text () +validateCanonicalProjectPath raw = do + _ <- validateProjectRelativePath raw + if T.null raw + || raw /= T.strip raw + || T.any (\c -> c == '\\' || c == '\0' || c == ':') raw + || any (\part -> T.null part || part == "." || part == ".." || T.toCaseFold part `elem` [".git", ".seihou"]) (T.splitOn "/" raw) + then Left ("path must use canonical project-relative components outside .git and .seihou: " <> raw) + else Right () diff --git a/src/Seihou/Core/Seed.hs b/src/Seihou/Core/Seed.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Seed.hs @@ -0,0 +1,39 @@ +module Seihou.Core.Seed + ( mergeSeedRecord, + dropSeedOwner, + seedsOwnedByModule, + ManifestInvariantError (..), + validateManifestInvariants, + ) +where + +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Seihou.Core.Types +import Seihou.Prelude + +-- | Keep the first settlement; callers must check the final manifest's invariants. +-- Never create a receipt for a managed path. +mergeSeedRecord :: FilePath -> SeedRecord -> Manifest -> Manifest +mergeSeedRecord path receipt = #seeds %~ Map.insertWith merge path receipt + where + merge new old = old & #applicationIds %~ Set.union (new ^. #applicationIds) + +dropSeedOwner :: Set ApplicationId -> FilePath -> Manifest -> Manifest +dropSeedOwner departing path = #seeds %~ Map.update dropOwners path + where + dropOwners record = + let retained = (record ^. #applicationIds) `Set.difference` departing + in if Set.null retained then Nothing else Just (record & #applicationIds .~ retained) + +seedsOwnedByModule :: ModuleName -> Manifest -> Map FilePath SeedRecord +seedsOwnedByModule name manifest = Map.filter ((== name) . (^. #moduleName)) (manifest ^. #seeds) + +data ManifestInvariantError = PathBothManagedAndSeeded FilePath + deriving stock (Eq, Show, Generic) + +validateManifestInvariants :: Manifest -> Either ManifestInvariantError () +validateManifestInvariants manifest = case Map.keys (Map.intersection (manifest ^. #files) (manifest ^. #seeds)) of + path : _ -> Left (PathBothManagedAndSeeded path) + [] -> Right () diff --git a/src/Seihou/Core/Types.hs b/src/Seihou/Core/Types.hs --- a/src/Seihou/Core/Types.hs +++ b/src/Seihou/Core/Types.hs @@ -9,6 +9,12 @@ Prompt (..), Expr (..), Strategy (..), + StepLifecycle (..), + CheckoutOutputSpec (..), + CheckoutOutputRecord (..), + lifecycleToText, + SeedOutcome (..), + SeedRecord (..), PatchOp (..), isAdditivePatchOp, Step (..), @@ -37,6 +43,11 @@ isAdditiveOperation, ModuleLoadError (..), Manifest (..), + ManifestSchemaVersion (..), + ManifestCapability (..), + SharedWriteMode (..), + knownSharedWriteMode, + mergeSharedWriteMode, ApplicationId (..), ArtifactOrigin (..), AppliedTarget (..), @@ -74,6 +85,7 @@ import Control.Lens ((^.)) import Data.Generics.Labels () import Data.Map.Strict (Map) +import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.String (IsString) import Data.Text (Text) @@ -162,6 +174,7 @@ | Template | DhallText | Structured + | Symlink deriving stock (Eq, Show, Generic) -- | Patch operations for modifying existing files during composition. @@ -194,13 +207,23 @@ isAdditivePatchOp AppendFile = False isAdditivePatchOp PrependFile = False +-- | Ownership of an output, independent of its materialization strategy. +data StepLifecycle = Managed | Seed | Checkout + deriving stock (Eq, Ord, Show, Generic) + +lifecycleToText :: StepLifecycle -> Text +lifecycleToText Managed = "managed" +lifecycleToText Seed = "seed" +lifecycleToText Checkout = "checkout" + -- | A generation step within a module. data Step = Step { strategy :: !Strategy, src :: !FilePath, dest :: !Text, condition :: !(Maybe Expr), - patch :: !(Maybe PatchOp) + patch :: !(Maybe PatchOp), + lifecycle :: !StepLifecycle } deriving stock (Eq, Show, Generic) @@ -419,8 +442,13 @@ -- | Filesystem operations produced by the generation engine. data Operation - = WriteFileOp + = CheckoutOutputOp { dest :: !FilePath, + spec :: !CheckoutOutputSpec, + moduleName :: !ModuleName + } + | WriteFileOp + { dest :: !FilePath, content :: !Text, strategy :: !Strategy } @@ -457,6 +485,7 @@ -- never ask. isAdditiveOperation :: Operation -> Bool isAdditiveOperation (PatchFileOp _ _ op' _ _) = isAdditivePatchOp op' +isAdditiveOperation CheckoutOutputOp {} = False isAdditiveOperation WriteFileOp {} = False isAdditiveOperation CopyFileOp {} = False isAdditiveOperation CreateDirOp {} = False @@ -521,11 +550,18 @@ -- | Tracks the state of generated files for incremental re-generation -- and conflict detection. Stored at @.seihou/manifest.json@. data Manifest = Manifest - { version :: !Int, + { -- | The schema the document was read as, or the schema a producer + -- asserts it can fully express. Decoding an older supported schema + -- keeps its version here so 'Seihou.Manifest.Types.manifestSupports' + -- can tell what the file actually proves; the encoder emits the + -- representation that belongs to this version. + version :: !ManifestSchemaVersion, genAt :: !UTCTime, modules :: ![AppliedModule], vars :: !(Map VarName Text), files :: !(Map FilePath FileRecord), + seeds :: !(Map FilePath SeedRecord), + checkoutOutputs :: !(Map FilePath CheckoutOutputRecord), applications :: ![AppliedComposition], recipe :: !(Maybe AppliedRecipe), blueprint :: !(Maybe AppliedBlueprint), @@ -533,6 +569,74 @@ } deriving stock (Eq, Show, Generic) +-- | The numeric schema of @.seihou/manifest.json@. Every semantic change to +-- the serialized manifest advances it (see +-- docs/adr/0014-every-semantic-manifest-change-advances-the-schema-version.md). +-- It is serialized as a bare integer. +newtype ManifestSchemaVersion = ManifestSchemaVersion {unManifestSchemaVersion :: Int} + deriving stock (Eq, Ord, Show, Generic) + +-- | A feature whose behaviour depends on facts only some manifest schemas +-- can express. Each capability names its minimum schema in exactly one +-- place, 'Seihou.Manifest.Types.minimumManifestVersion', so no command +-- carries its own numeric version comparison. +data ManifestCapability + = -- | A targeted update may leave an unselected co-owner of a path out of + -- the selection when the path is certified additive-only. Requires the + -- explicit shared-write evidence introduced by schema 7. + TargetedAdditiveSharedPathUpdate + | SeedReceipts + | CheckoutLocalOutputs + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +-- | What the manifest knows about how the owners of a path write it. +-- +-- Schema 6 recorded this as an optional Boolean whose absence meant both +-- "an owner rewrites the whole file" and "this manifest predates the +-- question". Schema 7 keeps the two apart, so the ownership gate can fail +-- closed on 'SharedWriteUnknown' while still knowing the evidence can be +-- established on demand. +data SharedWriteMode + = -- | Nobody has established the answer yet. Every path decoded from a + -- schema-6 record without @additiveOnly: true@ starts here. + SharedWriteUnknown + | -- | Every contribution to the path goes through an additive, + -- non-overlapping patch ('isAdditivePatchOp'), so reconciling one + -- owner cannot disturb another's bytes. + SharedWriteAdditiveOnly + | -- | At least one contribution rewrites or repositions the file, so every + -- owner must be part of any update that touches the path. + SharedWriteRequiresOwnershipClosure + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +-- | The mode a plan with complete knowledge of every contribution to a path +-- records. +knownSharedWriteMode :: Bool -> SharedWriteMode +knownSharedWriteMode True = SharedWriteAdditiveOnly +knownSharedWriteMode False = SharedWriteRequiresOwnershipClosure + +-- | Combine this run's answer for a path with what the manifest held. +-- +-- A run that executed every current owner (@partial = False@) knows the +-- whole answer and records it. A run that left a prior owner out knows only +-- its own contributions: a non-additive contribution of its own settles the +-- path as closure-required, but an additive one says nothing about the +-- retained owners, so the prior mode stands. The prior mode can therefore +-- only be kept or weakened here, never strengthened, and an unknown prior +-- stays unknown rather than being guessed. +mergeSharedWriteMode :: + -- | Did a prior owner survive outside this run? + Bool -> + -- | The prior record's mode, if the path had one. + Maybe SharedWriteMode -> + -- | Is every contribution this run made additive? + Bool -> + SharedWriteMode +mergeSharedWriteMode partial prior candidateAdditive + | not candidateAdditive = SharedWriteRequiresOwnershipClosure + | not partial = SharedWriteAdditiveOnly + | otherwise = fromMaybe SharedWriteUnknown prior + -- | Stable identity for one top-level module or recipe application. newtype ApplicationId = ApplicationId {unApplicationId :: Text} deriving stock (Eq, Ord, Show, Generic) @@ -753,12 +857,10 @@ generatedAt :: !UTCTime, baseline :: !(Maybe BaselineRef), applicationIds :: !(Set ApplicationId), - -- | Does /every/ contribution to this path go through an additive, - -- non-overlapping patch ('isAdditivePatchOp')? When true, reconciling - -- one owner provably cannot disturb another's bytes, so a targeted - -- update need not name every owner. Absent from older manifests, where - -- it decodes as 'False' and the closure keeps being enforced. - additiveOnly :: !Bool + -- | How the owners of this path write it. Only + -- 'SharedWriteAdditiveOnly' lets a targeted update leave a co-owner out + -- of its selection; the other two keep the ownership closure enforced. + sharedWriteMode :: !SharedWriteMode } deriving stock (Eq, Show, Generic) @@ -867,5 +969,27 @@ { path :: !FilePath, moduleName :: !ModuleName, status :: !TrackedFileStatus + } + deriving stock (Eq, Show, Generic) + +-- | A seed's first settlement, with no content tracking. +data SeedOutcome = SeedCreated | SeedFoundExisting | SeedReleasedFromManaged + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +data SeedRecord = SeedRecord + { moduleName :: !ModuleName, + applicationIds :: !(Set ApplicationId), + outcome :: !SeedOutcome, + settledAt :: !UTCTime + } + deriving stock (Eq, Show, Generic) + +-- | A typed, portable specification reconstructed in each working copy. +data CheckoutOutputSpec = DirectorySymlink FilePath + deriving stock (Eq, Ord, Show, Generic) + +data CheckoutOutputRecord = CheckoutOutputRecord + { spec :: !CheckoutOutputSpec, + owners :: !(Map ApplicationId (Set ModuleName)) } deriving stock (Eq, Show, Generic) diff --git a/src/Seihou/Dhall/Eval.hs b/src/Seihou/Dhall/Eval.hs --- a/src/Seihou/Dhall/Eval.hs +++ b/src/Seihou/Dhall/Eval.hs @@ -98,7 +98,7 @@ Success m -> do -- Force lazy decoder thunks that may contain 'error' calls mapM_ (\v -> evaluate (v ^. #type_)) (m ^. #vars) - mapM_ (\s -> evaluate (s ^. #strategy) >> evaluate (s ^. #condition) >> mapM_ evaluate (s ^. #patch)) (m ^. #steps) + mapM_ (\s -> evaluate (s ^. #lifecycle) >> evaluate (s ^. #strategy) >> evaluate (s ^. #condition) >> mapM_ evaluate (s ^. #patch)) (m ^. #steps) mapM_ (\c -> mapM_ evaluate (c ^. #condition)) (m ^. #commands) mapM_ (\p -> evaluate (p ^. #condition)) (m ^. #prompts) pure m @@ -562,8 +562,9 @@ "template" -> Template "dhall-text" -> DhallText "structured" -> Structured + "symlink" -> Symlink -- Caught by 'try' in 'evalModuleFromFile' - other -> error ("Unknown strategy \"" <> T.unpack other <> "\"; expected one of: copy, template, dhall-text, structured") + other -> error ("Unknown strategy \"" <> T.unpack other <> "\"; expected one of: copy, template, dhall-text, structured, symlink") -- | Decoder for VarDecl from a Dhall record. -- @@ -676,23 +677,31 @@ -- The @patch@ field is an optional patch operation string. stepDecoder :: Decoder Step stepDecoder = - record - ( mkStep - <$> field "strategy" strategyDecoder - <*> field "src" string - <*> field "dest" strictText - <*> field "when" (maybe strictText) - <*> field "patch" (maybe strictText) - ) + withDefaults [("lifecycle", noneText)] $ + record + ( mkStep + <$> field "strategy" strategyDecoder + <*> field "src" string + <*> field "dest" strictText + <*> field "when" (maybe strictText) + <*> field "patch" (maybe strictText) + <*> field "lifecycle" (maybe strictText) + ) where - mkStep strat src dest whenText patchText = + mkStep strat src dest whenText patchText lifecycleText = Step { strategy = strat, src = src, dest = dest, condition = parseWhen whenText, - patch = fmap parsePatchOp patchText + patch = fmap parsePatchOp patchText, + lifecycle = parseLifecycle lifecycleText } + parseLifecycle Nothing = Managed + parseLifecycle (Just "managed") = Managed + parseLifecycle (Just "seed") = Seed + parseLifecycle (Just "checkout") = Checkout + parseLifecycle (Just other) = error ("Unknown step lifecycle " <> T.unpack other <> "; expected one of: managed, seed, checkout") parsePatchOp "append-file" = AppendFile parsePatchOp "prepend-file" = PrependFile parsePatchOp "append-section" = AppendSection diff --git a/src/Seihou/Effect/Filesystem.hs b/src/Seihou/Effect/Filesystem.hs --- a/src/Seihou/Effect/Filesystem.hs +++ b/src/Seihou/Effect/Filesystem.hs @@ -1,5 +1,10 @@ module Seihou.Effect.Filesystem ( Filesystem (..), + PathEntry (..), + inspectPath, + createLink, + removeLink, + normalizePath, readFileText, writeFileText, copyFile, @@ -17,7 +22,15 @@ import Seihou.Prelude +-- | A filesystem entry, observed without following its final component. +data PathEntry = EntryMissing | EntryFile | EntryDirectory | EntrySymlink FilePath + deriving stock (Eq, Show, Generic) + data Filesystem :: Effect where + InspectPath :: FilePath -> Filesystem m PathEntry + CreateDirectoryLink :: FilePath -> FilePath -> Filesystem m () + RemoveLink :: FilePath -> Filesystem m () + NormalizePath :: FilePath -> Filesystem m FilePath ReadFileText :: FilePath -> Filesystem m Text WriteFileText :: FilePath -> Text -> Filesystem m () CopyFile :: FilePath -> FilePath -> Filesystem m () @@ -73,3 +86,15 @@ removeDirectoryRecursive :: (Filesystem :> es) => FilePath -> Eff es () removeDirectoryRecursive path = send (RemoveDirectoryRecursive path) + +inspectPath :: (Filesystem :> es) => FilePath -> Eff es PathEntry +inspectPath = send . InspectPath + +createLink :: (Filesystem :> es) => FilePath -> FilePath -> Eff es () +createLink target path = send (CreateDirectoryLink target path) + +removeLink :: (Filesystem :> es) => FilePath -> Eff es () +removeLink = send . RemoveLink + +normalizePath :: (Filesystem :> es) => FilePath -> Eff es FilePath +normalizePath = send . NormalizePath diff --git a/src/Seihou/Effect/FilesystemInterp.hs b/src/Seihou/Effect/FilesystemInterp.hs --- a/src/Seihou/Effect/FilesystemInterp.hs +++ b/src/Seihou/Effect/FilesystemInterp.hs @@ -3,16 +3,31 @@ ) where +import Control.Exception (IOException, catch, throwIO) import Control.Monad (when) import Data.Text.IO qualified as TIO -import Seihou.Effect.Filesystem (Filesystem (..)) +import Seihou.Effect.Filesystem (Filesystem (..), PathEntry (..)) import Seihou.Prelude import System.Directory qualified as Dir +import System.IO.Error (isDoesNotExistError) -- | Real IO interpreter for the Filesystem effect. -- Delegates to System.Directory and Data.Text.IO. runFilesystem :: (IOE :> es) => Eff (Filesystem : es) a -> Eff es a runFilesystem = interpret $ \_ -> \case + InspectPath path -> liftIO $ do + linked <- Dir.pathIsSymbolicLink path `catch` \(err :: IOException) -> if isDoesNotExistError err then pure False else throwIO err + if linked + then EntrySymlink <$> Dir.getSymbolicLinkTarget path + else do + directory <- Dir.doesDirectoryExist path + file <- Dir.doesFileExist path + pure (if directory then EntryDirectory else if file then EntryFile else EntryMissing) + CreateDirectoryLink target path -> liftIO (Dir.createDirectoryLink target path) + RemoveLink path -> liftIO $ do + linked <- Dir.pathIsSymbolicLink path + if linked then Dir.removeDirectoryLink path else ioError (userError "refusing to unlink a regular entry") + NormalizePath path -> liftIO (Dir.canonicalizePath path) ReadFileText path -> liftIO (TIO.readFile path) WriteFileText path content -> liftIO (TIO.writeFile path content) CopyFile src dest -> liftIO (Dir.copyFile src dest) diff --git a/src/Seihou/Effect/FilesystemPure.hs b/src/Seihou/Effect/FilesystemPure.hs --- a/src/Seihou/Effect/FilesystemPure.hs +++ b/src/Seihou/Effect/FilesystemPure.hs @@ -9,19 +9,20 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Effectful.State.Static.Local (State, get, modify, put, runState) -import Seihou.Effect.Filesystem (Filesystem (..)) +import Seihou.Effect.Filesystem (Filesystem (..), PathEntry (..)) import Seihou.Prelude -- | In-memory filesystem state for testing. data PureFS = PureFS { files :: !(Map FilePath Text), - dirs :: !(Set FilePath) + dirs :: !(Set FilePath), + links :: !(Map FilePath FilePath) } deriving stock (Eq, Generic, Show) -- | An empty in-memory filesystem. emptyFS :: PureFS -emptyFS = PureFS Map.empty Set.empty +emptyFS = PureFS Map.empty Set.empty Map.empty -- | Pure in-memory interpreter for the Filesystem effect. -- Useful for testing without touching the real filesystem. @@ -30,6 +31,21 @@ where handler :: (State PureFS :> es') => EffectHandler Filesystem es' handler _ = \case + InspectPath path -> do + fs <- get @PureFS + pure $ case Map.lookup path (fs ^. #links) of + Just target -> EntrySymlink target + Nothing + | Map.member path (fs ^. #files) -> EntryFile + | Set.member path (fs ^. #dirs) -> EntryDirectory + | otherwise -> EntryMissing + CreateDirectoryLink target path -> do + fs <- get @PureFS + if Map.member path (fs ^. #links) || Map.member path (fs ^. #files) || Set.member path (fs ^. #dirs) + then error ("runFilesystemPure: destination exists: " <> path) + else modify @PureFS (#links %~ Map.insert path target) + RemoveLink path -> modify @PureFS (#links %~ Map.delete path) + NormalizePath path -> pure path ReadFileText path -> do fs <- get @PureFS case Map.lookup path (fs ^. #files) of @@ -48,7 +64,7 @@ let prefix = if null path then "" else path <> "/" filesInDir = [ drop (length prefix) fp - | fp <- Map.keys (fs ^. #files), + | fp <- Map.keys (fs ^. #files) <> Map.keys (fs ^. #links), isDirectChild prefix fp ] dirsInDir = @@ -114,6 +130,8 @@ .~ renamedFiles & #dirs .~ renamedDirs + & #links + %~ Map.mapKeys (renameKey src dest) where renameKey s d k | k == s = d @@ -129,6 +147,8 @@ keepDir d = d /= path && not (prefix `isPrefixOfPath` d) in fs & #files + %~ Map.filterWithKey (\k _ -> keepFile k) + & #links %~ Map.filterWithKey (\k _ -> keepFile k) & #dirs %~ Set.filter keepDir diff --git a/src/Seihou/Engine/Checkout.hs b/src/Seihou/Engine/Checkout.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/Checkout.hs @@ -0,0 +1,239 @@ +module Seihou.Engine.Checkout + ( observeCheckoutOutputs, + prepareCheckoutPlan, + prepareCheckoutApplication, + applyCheckoutPlan, + applyCheckoutPlanWithHook, + rollbackCheckout, + CheckoutExecution (..), + CheckoutUndo (..), + checkoutGitRoot, + safeCheckoutManifest, + ) +where + +import Control.Exception (IOException) +import Control.Monad (foldM, forM, forM_, unless, when) +import Data.Generics.Labels () +import Data.List (sortOn) +import Data.Map.Strict qualified as Map +import Data.Maybe (maybeToList) +import Data.Set qualified as Set +import Data.Text qualified as T +import Effectful.Exception qualified as E +import Seihou.Core.Checkout +import Seihou.Core.Types +import Seihou.Effect.Filesystem +import Seihou.Effect.Process +import Seihou.Prelude +import System.Exit (ExitCode (..)) +import System.FilePath.Posix qualified as P + +checkoutGitRoot :: (Filesystem :> es, Process :> es, IOE :> es) => FilePath -> Eff es (Maybe FilePath) +checkoutGitRoot root = do + result <- E.try @IOException (runProcess "git" ["rev-parse", "--show-toplevel"] (Just root)) + case result of + Right (ExitSuccess, path, _) -> Just <$> normalizePath (T.unpack (T.stripEnd path)) + _ -> pure Nothing + +-- | Inspect metadata before opening it; a manifest must be a real file. +safeCheckoutManifest :: (Filesystem :> es) => FilePath -> Eff es (Either CheckoutError ()) +safeCheckoutManifest root = do + dir <- inspectPath (root ".seihou") + file <- if dir == EntryDirectory then inspectPath (root ".seihou/manifest.json") else pure EntryMissing + pure $ + if dir == EntryDirectory && file == EntryFile + then Right () + else Left (checkoutError "checkout_manifest_unsafe" "require a real .seihou directory and manifest.json file; run seihou run to record declarations, or move symlinked metadata aside") + +ancestors :: FilePath -> [FilePath] +ancestors path = reverse (go (P.takeDirectory path)) + where + go "." = []; go "" = []; go p = p : go (P.takeDirectory p) + +-- | Observe entries themselves, never the targets of destination symlinks. +observeCheckoutOutputs :: (Filesystem :> es, Process :> es, IOE :> es) => FilePath -> Map FilePath CheckoutOutputRecord -> Map FilePath CheckoutOutputRecord -> Eff es (Map FilePath CheckoutObservation) +observeCheckoutOutputs root prior candidate = do + gitRoot <- checkoutGitRoot root + indexed <- case gitRoot of + Nothing -> pure (Right []) + Just _ -> do + (code, out, _) <- runProcess "git" ["ls-files", "--cached", "-z"] (Just root) + pure $ if code == ExitSuccess then Right (map T.unpack (filter (not . T.null) (T.splitOn "\0" out))) else Left (checkoutError "checkout_git_unavailable" "cannot inspect Git's index") + metadataAlias <- inspectPath (root ".GIT") + let nativeOverlap a b = pathsOverlap a b || (metadataAlias /= EntryMissing && pathsOverlap (T.unpack (T.toCaseFold (T.pack a))) (T.unpack (T.toCaseFold (T.pack b)))) + pairs <- forM allPaths $ \dest -> do + let active = Map.lookup dest candidate + record = case active of Just r -> r; Nothing -> prior Map.! dest + source = checkoutSource (record ^. #spec) + result <- E.try @IOException $ do + parentProblems <- (<>) <$> checkAncestors (ancestors dest) <*> (if active == Nothing then pure [] else checkAncestors (ancestors source)) + entry <- if null parentProblems then inspectPath (root dest) else pure EntryMissing + sourceEntry <- if active == Nothing || not (null parentProblems) then pure EntryMissing else inspectPath (root source) + sourceAlias <- if active == Nothing || not (null parentProblems) then pure [] else checkSpelling source + destAlias <- if null parentProblems then checkSpelling dest else pure [] + (ignored, ignoreProblems) <- + if gitRoot == Nothing + then pure (False, []) + else do + (code, _, _) <- runProcess "git" ["check-ignore", "-q", "--", "./" <> T.pack dest] (Just root) + pure $ case code of + ExitSuccess -> (True, []) + ExitFailure 1 -> (False, []) + _ -> (False, [checkoutError "checkout_git_unavailable" "cannot inspect ignore rules; check Git configuration"]) + + let trackedProblems = case indexed of + Left err -> [err] + Right paths -> [checkoutError "checkout_path_tracked" "destination overlaps a tracked path (including an indexed ancestor); change the declaration or untrack it explicitly" | any (nativeOverlap dest) paths] + aliasClaims = + [ checkoutError "checkout_native_alias" "checkout declarations have ambiguous case spellings; use distinct portable destinations" + | any (\other -> other /= dest && T.toCaseFold (T.pack other) == T.toCaseFold (T.pack dest)) allPaths + ] + pure (CheckoutObservation entry (sourceEntry == EntryDirectory) (parentProblems <> trackedProblems <> ignoreProblems <> sourceAlias <> destAlias <> aliasClaims <> [checkoutError "checkout_source_not_directory" "source is not a real directory; move the object aside" | active /= Nothing, sourceEntry `notElem` [EntryMissing, EntryDirectory]]) (gitRoot /= Nothing) ignored) + pure + ( dest, + case result of + Right obs -> obs + Left err -> CheckoutObservation EntryMissing False [checkoutError "checkout_path_inaccessible" ("cannot inspect '" <> T.pack dest <> "': " <> T.pack (show err))] (gitRoot /= Nothing) False + ) + pure (Map.fromList pairs) + where + allPaths = Set.toAscList (Map.keysSet prior <> Map.keysSet candidate) + checkAncestors [] = pure [] + checkAncestors (path : rest) = + inspectPath (root path) >>= \case + EntrySymlink _ -> pure [checkoutError "checkout_parent_symlink" ("ancestor '" <> T.pack path <> "' is a symlink; replace it with a real directory")] + EntryFile -> pure [checkoutError "checkout_parent_not_directory" ("ancestor '" <> T.pack path <> "' is a file; move it aside")] + EntryMissing -> pure [] + EntryDirectory -> checkAncestors rest + -- Native path lookup may accept a different spelling on case-insensitive volumes. + checkSpelling path = fmap concat $ forM (ancestors path <> [path]) $ \part -> do + parent <- inspectPath (root P.takeDirectory part) + if parent /= EntryDirectory + then pure [] + else do + names <- listDirectory (root P.takeDirectory part) + exists <- inspectPath (root part) + pure [checkoutError "checkout_native_alias" ("path '" <> T.pack part <> "' resolves through a different native spelling") | exists /= EntryMissing, P.takeFileName part `notElem` names] + +prepareCheckoutPlan :: (Filesystem :> es, Process :> es, IOE :> es) => CheckoutIntent -> CheckoutPolicy -> FilePath -> Manifest -> Manifest -> [FilePath] -> Eff es (Either CheckoutError CheckoutPlan) +prepareCheckoutPlan intent policy root prior candidate pending = case validateCheckoutRecords candidate pending of + Left err -> pure (Left err) + Right () -> do + observations <- observeCheckoutOutputs root (prior ^. #checkoutOutputs) (candidate ^. #checkoutOutputs) + pure (Right (planCheckoutOutputs intent policy (prior ^. #checkoutOutputs) (candidate ^. #checkoutOutputs) observations)) + +-- | An undo entry describes only this attempt's own writes. +data CheckoutUndo = CheckoutUndo + {dest :: !FilePath, before :: !PathEntry, after :: !PathEntry, parents :: ![FilePath]} + deriving stock (Eq, Show, Generic) + +data CheckoutExecution = CheckoutExecution + {outcomes :: !(Map FilePath Text), undo :: ![CheckoutUndo], failure :: !(Maybe CheckoutError)} + deriving stock (Eq, Show, Generic) + +rollbackCheckout :: (Filesystem :> es, IOE :> es) => FilePath -> [CheckoutUndo] -> Eff es (Map FilePath Text) +rollbackCheckout root writes = + Map.fromList + <$> forM + writes + ( \write -> do + result <- E.try @IOException $ do + let path = root (write ^. #dest) + parentsSafe <- and <$> mapM (\p -> (== EntryDirectory) <$> inspectPath (root p)) (ancestors (write ^. #dest)) + current <- if parentsSafe then inspectPath path else pure EntryFile + if current /= write ^. #after + then pure "rollback-conflicted" + else do + case current of EntrySymlink _ -> removeLink path; _ -> pure () + case write ^. #before of EntrySymlink target -> createLink target path; _ -> pure () + forM_ (reverse (write ^. #parents)) (\p -> inspectPath (root p) >>= \kind -> when (kind == EntryDirectory) (removeDirectoryIfEmpty (root p))) + pure "rolled-back" + pure (write ^. #dest, either (const "rollback-conflicted") id result) + ) + +-- | Recheck immediately before mutation. Supports a single cooperating writer; +-- portable path checks do not protect against hostile concurrent substitution. +applyCheckoutPlan :: (Filesystem :> es, Process :> es, IOE :> es) => CheckoutPolicy -> FilePath -> CheckoutPlan -> Eff es CheckoutExecution +applyCheckoutPlan = applyCheckoutPlanWithHook (const (pure ())) + +-- | Failure injection after each completed link mutation, for rollback contract tests. +applyCheckoutPlanWithHook :: (Filesystem :> es, Process :> es, IOE :> es) => (Int -> Eff es ()) -> CheckoutPolicy -> FilePath -> CheckoutPlan -> Eff es CheckoutExecution +applyCheckoutPlanWithHook afterMutation policy root plan + | not (checkoutApplicable plan) = pure (CheckoutExecution Map.empty [] (Just (checkoutError "checkout_preflight_refused" "checkout preflight refused; no outputs were changed"))) + | otherwise = go Map.empty [] (plan ^. #entries) + where + go outcomes writes [] = pure (CheckoutExecution outcomes writes Nothing) + go outcomes writes (entry : rest) + | entry ^. #action `notElem` [CreateLink, ReplaceLink, RetireLink] = go (Map.insert (entry ^. #dest) "unchanged" outcomes) writes rest + | otherwise = do + let dest = entry ^. #dest + toMap spec = Map.singleton dest (CheckoutOutputRecord spec Map.empty) + old = maybe Map.empty toMap (entry ^. #previous) + new = maybe Map.empty toMap (entry ^. #candidate) + expected = maybe EntryMissing (EntrySymlink . expectedTarget dest) (entry ^. #candidate) + result <- E.try @IOException $ do + observations <- observeCheckoutOutputs root old new + let observed = observations Map.! dest + changed = observed ^. #entry /= entry ^. #observation . #entry + errors = + observed ^. #problems + <> [checkoutError "checkout_source_missing" "source directory disappeared" | entry ^. #candidate /= Nothing, not (observed ^. #sourceDirectory)] + <> [checkoutError "checkout_not_ignored" "destination is no longer ignored" | policy == SyncIgnoredOnly, entry ^. #candidate /= Nothing, not (observed ^. #ignored)] + <> [checkoutError "checkout_git_required" "Git evidence disappeared" | policy == SyncIgnoredOnly, not (observed ^. #gitAvailable)] + when (changed || not (null errors)) $ E.throwIO (userError ("checkout precondition changed for " <> dest)) + missingParents <- filterM (\p -> (== EntryMissing) <$> inspectPath (root p)) (ancestors dest) + -- Record and undo even a failure after unlink or during parent creation. + let write = CheckoutUndo dest (observed ^. #entry) expected missingParents + mutate <- E.try @IOException $ do + forM_ missingParents (createDirectoryIfMissing False . (root )) + case entry ^. #action of + CreateLink -> createLink (linkText entry) (root dest) + ReplaceLink -> do + removeLink (root dest) + createLink (linkText entry) (root dest) `E.onException` createLink (oldText observed) (root dest) + RetireLink -> removeLink (root dest) + _ -> pure () + case mutate of + Left err -> do + forM_ (reverse missingParents) (\p -> inspectPath (root p) >>= \kind -> when (kind == EntryDirectory) (removeDirectoryIfEmpty (root p))) + E.throwIO err + Right () -> pure write + case result of + Right write -> do + hooked <- E.try @IOException (afterMutation (length writes + 1)) + case hooked of + Right () -> go (Map.insert dest "applied" outcomes) (write : writes) rest + Left err -> do + reverted <- rollbackCheckout root (write : writes) + pure (CheckoutExecution (Map.union reverted outcomes) [] (Just (checkoutError "checkout_apply_failed" (T.pack (show err))))) + Left err -> do + reverted <- rollbackCheckout root writes + pure (CheckoutExecution (Map.insert dest "failed" (Map.union reverted outcomes)) [] (Just (checkoutError "checkout_apply_failed" ("cannot apply '" <> T.pack dest <> "': " <> T.pack (show err) <> "; check symlink permissions and retry")))) + linkText entry = case entry ^. #candidate of Just spec -> expectedTarget (entry ^. #dest) spec; Nothing -> "" + oldText observed = case observed ^. #entry of EntrySymlink target -> target; _ -> "" + +filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a] +filterM predicate = foldM (\acc x -> predicate x >>= \keep -> pure (if keep then acc <> [x] else acc)) [] + +-- | Before ordinary generation, a source directory may be scheduled to appear +-- through deterministic file output. Shell commands cannot satisfy this dependency. +prepareCheckoutApplication :: (Filesystem :> es, Process :> es, IOE :> es) => FilePath -> Manifest -> Manifest -> [Operation] -> Eff es (Either CheckoutError CheckoutPlan) +prepareCheckoutApplication root prior candidate operations = case validateCheckoutRecords candidate bytePaths of + Left err -> pure (Left err) + Right () -> do + observed <- observeCheckoutOutputs root (prior ^. #checkoutOutputs) (candidate ^. #checkoutOutputs) + let allowGenerated dest obs = case Map.lookup dest (candidate ^. #checkoutOutputs) of + Just record | any (\path -> T.pack (checkoutSource (record ^. #spec) <> "/") `T.isPrefixOf` T.pack path) bytePaths -> obs & #sourceDirectory .~ True + _ -> obs + pure (Right (planCheckoutOutputs Reconcile ApplyDeclaration (prior ^. #checkoutOutputs) (candidate ^. #checkoutOutputs) (Map.mapWithKey allowGenerated observed))) + where + bytePaths = + [ dest + | op <- operations, + dest <- case op of + WriteFileOp {dest} -> [dest] + CopyFileOp {dest} -> [dest] + PatchFileOp {dest} -> [dest] + _ -> [] + ] diff --git a/src/Seihou/Engine/Execute.hs b/src/Seihou/Engine/Execute.hs --- a/src/Seihou/Engine/Execute.hs +++ b/src/Seihou/Engine/Execute.hs @@ -22,10 +22,12 @@ -- map fall back to the default @moduleName'@ — this preserves single- -- module call-sites and test usage that do not build an ownership map. -- --- Each record's @additiveOnly@ is folded across /every/ operation that +-- Each record's shared-write mode is folded across /every/ operation that -- targets the same destination, so a path a module both writes and patches --- records 'False'. Only a path reached exclusively through additive patches --- records 'True'. +-- records 'SharedWriteRequiresOwnershipClosure'. Only a path reached +-- exclusively through additive patches records 'SharedWriteAdditiveOnly'. +-- The answer covers this plan's operations only; callers that retain prior +-- owners merge it with 'mergeSharedWriteMode'. executePlan :: (Filesystem :> es) => FilePath -> @@ -36,8 +38,8 @@ Eff es (Map FilePath FileRecord) executePlan targetDir ops ownerMap moduleName' now = do let ownerFor dest = Map.findWithDefault moduleName' dest ownerMap - additiveFor dest = Map.findWithDefault False dest additiveMap - records <- mapM (executeOp targetDir ownerFor additiveFor now) ops + modeFor dest = knownSharedWriteMode (Map.findWithDefault False dest additiveMap) + records <- mapM (executeOp targetDir ownerFor modeFor now) ops pure (Map.fromList [(k, v) | Just (k, v) <- records]) where additiveMap = @@ -53,6 +55,7 @@ operationDestination (WriteFileOp dest _ _) = Just dest operationDestination (CopyFileOp _ dest) = Just dest operationDestination (PatchFileOp dest _ _ _ _) = Just dest +operationDestination CheckoutOutputOp {} = Nothing operationDestination CreateDirOp {} = Nothing operationDestination RunCommandOp {} = Nothing @@ -61,11 +64,12 @@ (Filesystem :> es) => FilePath -> (FilePath -> ModuleName) -> - (FilePath -> Bool) -> + (FilePath -> SharedWriteMode) -> UTCTime -> Operation -> Eff es (Maybe (FilePath, FileRecord)) -executeOp targetDir ownerFor additiveFor now op = case op of +executeOp targetDir ownerFor modeFor now op = case op of + CheckoutOutputOp {} -> pure Nothing WriteFileOp dest content strat -> do let fullPath = targetDir dest writeFileText fullPath content @@ -77,7 +81,7 @@ generatedAt = now, baseline = Nothing, applicationIds = mempty, - additiveOnly = additiveFor dest + sharedWriteMode = modeFor dest } pure (Just (dest, record)) CreateDirOp path -> do @@ -96,7 +100,7 @@ generatedAt = now, baseline = Nothing, applicationIds = mempty, - additiveOnly = additiveFor dest + sharedWriteMode = modeFor dest } pure (Just (dest, record)) RunCommandOp {} -> do @@ -123,7 +127,7 @@ generatedAt = now, baseline = Nothing, applicationIds = mempty, - additiveOnly = additiveFor dest + sharedWriteMode = modeFor dest } pure (Just (dest, record)) @@ -136,6 +140,7 @@ where formatOp :: Operation -> Text formatOp (WriteFileOp dest _ _) = " write " <> T.pack dest + formatOp (CheckoutOutputOp dest (DirectorySymlink source) _) = " link " <> T.pack dest <> " -> " <> T.pack source formatOp (CreateDirOp path) = " mkdir " <> T.pack path formatOp (CopyFileOp src dest) = " copy " <> T.pack src <> " -> " <> T.pack dest formatOp RunCommandOp {command = cmd} = " run " <> cmd diff --git a/src/Seihou/Engine/Plan.hs b/src/Seihou/Engine/Plan.hs --- a/src/Seihou/Engine/Plan.hs +++ b/src/Seihou/Engine/Plan.hs @@ -20,7 +20,9 @@ import Dhall qualified import Dhall.Core qualified as DhallCore import Dhall.Src (Src) +import Seihou.Core.Checkout (CheckoutError (..), validateCheckoutPaths) import Seihou.Core.Expr (evalExpr) +import Seihou.Core.Module (checkCheckoutSteps, checkSeedSteps) import Seihou.Core.Path (validateProjectRelativePath) import Seihou.Core.Types import Seihou.Engine.DhallJSON (dhallExprToJSON) @@ -38,7 +40,10 @@ IO (Either [Text] [Operation]) compilePlan baseDir modul vars = do let modName = (modul ^. #name) - results <- mapM (compileStep baseDir modName vars) (modul ^. #steps) + results <- + if null (checkSeedSteps modul <> checkCheckoutSteps modul) + then mapM (compileStep baseDir modName vars) (modul ^. #steps) + else pure [Left (checkSeedSteps modul <> checkCheckoutSteps modul)] let (allErrors, allOps) = partitionResults results if null allErrors then case compileCommands modName vars (modul ^. #commands) of @@ -115,6 +120,12 @@ Template -> compileTemplateStep baseDir vars step DhallText -> compileDhallTextStep baseDir vars step Structured -> compileStructuredStep baseDir vars step + Symlink -> pure $ case (renderCommand (T.pack (step ^. #src)) vars, renderCommand (step ^. #dest) vars) of + (Right source, Right dest) -> case validateCheckoutPaths (T.unpack source) (T.unpack dest) of + Left err -> Left [err ^. #message] + Right () -> Right [CheckoutOutputOp (T.unpack dest) (DirectorySymlink (T.unpack source)) modName] + (Left errors, _) -> Left (map formatPlaceholderError errors) + (_, Left errors) -> Left (map formatPlaceholderError errors) -- | Compile a Copy step: read the source file and write it to the destination. compileCopyStep :: diff --git a/src/Seihou/Engine/Preview.hs b/src/Seihou/Engine/Preview.hs --- a/src/Seihou/Engine/Preview.hs +++ b/src/Seihou/Engine/Preview.hs @@ -32,6 +32,7 @@ annotation :: !Text, module_ :: !(Maybe ModuleName) } + | LinkPreview FilePath FilePath | DirPreview FilePath | CommandPreview Text (Maybe ModuleName) | OrphanPreview FilePath ModuleName @@ -72,6 +73,7 @@ annotation = strategyName strat, module_ = Map.lookup dest ownerMap } +opToPreview _ _ _ (CheckoutOutputOp dest (DirectorySymlink source) _) = LinkPreview dest source opToPreview _ _ _ (CreateDirOp path) = DirPreview path opToPreview mDiff ownerMap _ (CopyFileOp _ dest) = FilePreview @@ -128,6 +130,7 @@ renderPlainLine _ other = renderNonFileLine other renderNonFileLine :: PreviewLine -> Text +renderNonFileLine (LinkPreview dest source) = " link " <> T.pack dest <> " -> " <> T.pack source renderNonFileLine (DirPreview path) = " mkdir " <> T.pack path renderNonFileLine (CommandPreview cmd mOwner) = @@ -155,6 +158,7 @@ strategyName Template = "template" strategyName DhallText = "dhall-text" strategyName Structured = "structured" +strategyName Symlink = "symlink" -- | Format a complete plan view with header, variables, operations, and summary. formatPlanView :: [ModuleName] -> Map VarName VarValue -> [PreviewLine] -> DiffResult -> Text diff --git a/src/Seihou/Engine/Reconcile.hs b/src/Seihou/Engine/Reconcile.hs --- a/src/Seihou/Engine/Reconcile.hs +++ b/src/Seihou/Engine/Reconcile.hs @@ -18,6 +18,7 @@ reconciliationSummary, reconciliationMutationPaths, unresolvedPaths, + recordedSharedWriteMode, ) where @@ -121,6 +122,25 @@ } deriving stock (Eq, Generic, Show) +-- | The shared-write mode an update records for a desired path, given the +-- applications it selected and the path's prior record. +-- +-- Owners outside the selection are retained, and when any survive this run +-- knows only its own contributions, so the prior mode can be kept or +-- weakened but never strengthened ('mergeSharedWriteMode'). Both the +-- manifest writer ('Seihou.Engine.UpdateTransaction') and the no-op checks +-- use this one function so they cannot disagree about whether a plan would +-- change the record. +recordedSharedWriteMode :: Set ApplicationId -> DesiredFile -> Maybe FileRecord -> SharedWriteMode +recordedSharedWriteMode selected desired prior = + mergeSharedWriteMode partial ((^. #sharedWriteMode) <$> prior) (desired ^. #additiveOnly) + where + -- Subtracting the /selection/ rather than the desired set matters: a + -- selected application that stopped writing the path must genuinely lose + -- ownership, while an unselected one must keep it. + retainedOwners = maybe Set.empty (^. #applicationIds) prior Set.\\ selected + partial = not (Set.null retainedOwners) + data ReconciliationError = InvalidReconciliationPath FilePath Text | MissingDesiredOwner FilePath @@ -289,7 +309,7 @@ Nothing -> Right () Just record | Set.null ((record ^. #applicationIds) Set.\\ selected) -> Right () - | record ^. #additiveOnly && all isAdditiveOperation pathOperations -> Right () + | record ^. #sharedWriteMode == SharedWriteAdditiveOnly && all isAdditiveOperation pathOperations -> Right () | otherwise -> Left (SharedPathRequiresApplications path (record ^. #applicationIds)) validateManagedPath :: FilePath -> Either ReconciliationError () diff --git a/src/Seihou/Engine/Remove.hs b/src/Seihou/Engine/Remove.hs --- a/src/Seihou/Engine/Remove.hs +++ b/src/Seihou/Engine/Remove.hs @@ -5,6 +5,8 @@ RemovalOp (..), RemovalFileStatus (..), ExecutedRemovalPlan (..), + CheckoutRemovalSelection (..), + selectCheckoutRemoval, computeRemovalPlan, executeRemoval, buildRemovalOps, @@ -16,11 +18,14 @@ import Data.Generics.Labels () import Data.List (nub, sortBy) import Data.Map.Strict qualified as Map +import Data.Maybe (listToMaybe, mapMaybe, maybeToList) import Data.Ord (Down (..)) import Data.Set (Set) import Data.Set qualified as Set import Data.Text qualified as T import Data.Time (UTCTime) +import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName) +import Seihou.Core.Checkout import Seihou.Core.Path (validateProjectRelativePath) import Seihou.Core.Types import Seihou.Effect.Filesystem (Filesystem, doesFileExist, readFileText, removeDirectoryIfEmpty, removeFile, writeFileText) @@ -109,7 +114,10 @@ case findApplied manifest modName of Nothing -> pure (Left (ModuleNotApplied modName)) Just am - | Nothing <- am ^. #removal -> pure (Left (ModuleNotRemovable modName)) + | Nothing <- am ^. #removal -> + if any (\record -> any (Set.member modName) (Map.elems (record ^. #owners))) (Map.elems (manifest ^. #checkoutOutputs)) + then pure (Right (RemovalPlan modName [])) + else pure (Left (ModuleNotRemovable modName)) | otherwise -> do let ownedFiles = moduleFiles manifest modName classified <- mapM classifyForRemoval ownedFiles @@ -357,3 +365,56 @@ %~ Map.filter (\rec -> rec ^. #moduleName /= modName) & #genAt .~ now + +-- | A single recorded application/instance selected for checkout cleanup. +data CheckoutRemovalSelection = CheckoutRemovalSelection + { applicationId :: !ApplicationId, + instanceName :: !ModuleName, + moduleName :: !ModuleName, + removal :: !(Maybe Removal), + candidateManifest :: !Manifest + } + deriving stock (Eq, Show, Generic) + +-- | Resolve a name against recorded qualified instances, never installed modules. +-- Ambiguous bare names and application choices require explicit selection. +selectCheckoutRemoval :: Manifest -> ModuleName -> Maybe ApplicationId -> Either CheckoutError (Maybe CheckoutRemovalSelection) +selectCheckoutRemoval manifest requested selectedApplication = case candidates of + [] + | selectedApplication /= Nothing -> Left (checkoutError "checkout_remove_selection" "no matching checkout-owning instance in the selected application") + | otherwise -> Right Nothing + [(app, state, qualified)] -> do + let appId = app ^. #applicationId + selected = Map.singleton appId (Set.singleton qualified) + outputs = dropCheckoutOwners selected (manifest ^. #checkoutOutputs) + keepFile record + | record ^. #moduleName /= qualified || not (Set.member appId (record ^. #applicationIds)) = Just record + | otherwise = + let retained = Set.delete appId (record ^. #applicationIds) + in if Set.null retained then Nothing else Just (record & #applicationIds .~ retained) + keepApplication other + | other ^. #applicationId /= appId = Just other + | otherwise = + let retained = filter (\instanceState -> qualifiedName (ModuleInstance (instanceState ^. #name) (instanceState ^. #parentVars)) /= qualified) (other ^. #instances) + in if null retained then Nothing else Just (other & #instances .~ retained & #commandReceipts %~ Map.filter ((/= qualified) . (^. #moduleName))) + applications = mapMaybe keepApplication (manifest ^. #applications) + files = Map.mapMaybe keepFile (manifest ^. #files) + stillNeeded applied = + any (\other -> any (\instanceState -> instanceState ^. #name == applied ^. #name && instanceState ^. #parentVars == applied ^. #parentVars) (other ^. #instances)) applications + || any ((== qualifiedName (ModuleInstance (applied ^. #name) (applied ^. #parentVars))) . (^. #moduleName)) (Map.elems files) + removeSelected applied = applied ^. #name /= state ^. #name || applied ^. #parentVars /= state ^. #parentVars || stillNeeded applied + candidate = manifest & #checkoutOutputs .~ outputs & #applications .~ applications & #files .~ files & #modules %~ filter removeSelected + custom = listToMaybe [spec | applied <- manifest ^. #modules, applied ^. #name == state ^. #name, applied ^. #parentVars == state ^. #parentVars, spec <- maybeToList (applied ^. #removal)] + validateCheckoutRecords candidate [] + pure (Just (CheckoutRemovalSelection appId qualified (state ^. #name) custom candidate)) + matches -> Left (checkoutError "checkout_remove_ambiguous" ("checkout removal is ambiguous; select one recorded instance/application: " <> T.intercalate "; " ["seihou remove " <> qualified ^. #unModuleName <> " --application " <> app ^. #applicationId . #unApplicationId | (app, _, qualified) <- matches])) + where + candidates = + [ (app, state, qualified) + | app <- manifest ^. #applications, + maybe True (== app ^. #applicationId) selectedApplication, + state <- app ^. #instances, + let qualified = qualifiedName (ModuleInstance (state ^. #name) (state ^. #parentVars)), + requested == qualified || requested == state ^. #name, + any (\record -> Set.member qualified (Map.findWithDefault Set.empty (app ^. #applicationId) (record ^. #owners))) (Map.elems (manifest ^. #checkoutOutputs)) + ] diff --git a/src/Seihou/Engine/UpdateTransaction.hs b/src/Seihou/Engine/UpdateTransaction.hs --- a/src/Seihou/Engine/UpdateTransaction.hs +++ b/src/Seihou/Engine/UpdateTransaction.hs @@ -15,6 +15,7 @@ import Control.Monad (foldM, forM, forM_, unless, when) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson import Data.ByteString.Lazy qualified as LBS import Data.Foldable (traverse_) import Data.Generics.Labels () @@ -28,6 +29,7 @@ import Seihou.Core.Types import Seihou.Effect.BaselineStore (putBaseline) import Seihou.Effect.BaselineStoreInterp (runBaselineStore) +import Seihou.Effect.Filesystem (PathEntry (..), inspectPath) import Seihou.Effect.FilesystemInterp (runFilesystem) import Seihou.Engine.Reconcile import Seihou.Manifest.Hash (hashContent) @@ -59,7 +61,8 @@ data JournalEntry = JournalEntry { targetPath :: !FilePath, - backupFile :: !(Maybe FilePath) + backupFile :: !(Maybe FilePath), + linkTarget :: !(Maybe FilePath) } deriving stock (Eq, Generic, Show) @@ -76,12 +79,30 @@ toJSON entry = Aeson.object [ "path" .= (entry ^. #targetPath), - "backup" .= (entry ^. #backupFile) + "backup" .= (entry ^. #backupFile), + "target" .= (entry ^. #linkTarget), + "kind" + .= ( case (entry ^. #backupFile, entry ^. #linkTarget) of + (_, Just _) -> "symlink" :: Text + (Just _, _) -> "file" + _ -> "absent" + ) ] -instance FromJSON JournalEntry where - parseJSON = Aeson.withObject "JournalEntry" $ \object -> - JournalEntry <$> object .: "path" <*> object .:? "backup" +parseJournalEntry :: Int -> Aeson.Value -> Aeson.Parser JournalEntry +parseJournalEntry version = Aeson.withObject "JournalEntry" $ \object -> do + path <- object .: "path" + backup <- object .:? "backup" + if version == 1 + then pure (JournalEntry path backup Nothing) + else do + kind <- object .: "kind" :: Aeson.Parser Text + target <- object .:? "target" + case (kind, backup, target) of + ("absent", Nothing, Nothing) -> pure (JournalEntry path Nothing Nothing) + ("file", Just _, Nothing) -> pure (JournalEntry path backup Nothing) + ("symlink", Nothing, Just _) -> pure (JournalEntry path Nothing target) + _ -> fail "unknown or malformed transaction entry kind" instance ToJSON JournalMetadata where toJSON metadata = @@ -96,11 +117,11 @@ instance FromJSON JournalMetadata where parseJSON = Aeson.withObject "JournalMetadata" $ \object -> do version <- object .: "version" - unless (version == 1) (fail "unsupported transaction journal version") + unless (version `elem` [1, 2]) (fail "unsupported transaction journal version") JournalMetadata <$> pure version <*> object .: "createdAt" - <*> object .: "entries" + <*> (mapM (parseJournalEntry version) =<< object .: "entries") <*> object .: "newDirectories" <*> object .:? "expectedManifest" @@ -125,18 +146,21 @@ let fullPath = transaction ^. #projectRoot relativePath backupName = show index <> ".txt" backupPath = backupDirectory backupName - exists <- Directory.doesFileExist fullPath - if exists - then do + verifySafeParents (transaction ^. #projectRoot) relativePath + entry <- runEff $ runFilesystem $ inspectPath fullPath + case entry of + EntrySymlink target -> pure (JournalEntry relativePath Nothing (Just target)) + EntryFile -> do TIO.readFile fullPath >>= TIO.writeFile backupPath - pure (JournalEntry relativePath (Just backupName)) - else pure (JournalEntry relativePath Nothing) + pure (JournalEntry relativePath (Just backupName) Nothing) + EntryMissing -> pure (JournalEntry relativePath Nothing Nothing) + EntryDirectory -> ioError (userError ("transaction target is a directory: " <> relativePath)) missingDirectories <- missingParentDirectories (transaction ^. #projectRoot) safeTargets now <- getCurrentTime writeJournal (transaction ^. #transactionDirectory) JournalMetadata - { journalVersion = 1, + { journalVersion = 2, createdAt = now, entries = entries, newDirectories = missingDirectories, @@ -255,9 +279,6 @@ -- while an unselected one must keep it. retainedOwners = maybe Set.empty (^. #applicationIds) prior Set.\\ selected partial = not (Set.null retainedOwners) - -- The prior flag summarises every owner, including the ones absent - -- from this run, so a partial update can only weaken it. - priorAdditive = maybe False (^. #additiveOnly) prior record = FileRecord { hash = state ^. #recordedHash, @@ -273,7 +294,10 @@ generatedAt = manifest ^. #genAt, baseline = Just baseline, applicationIds = (desired ^. #applicationIds) `Set.union` retainedOwners, - additiveOnly = (desired ^. #additiveOnly) && (not partial || priorAdditive) + -- The prior mode summarises every owner, including the ones + -- absent from this run, so a partial update can only keep or + -- weaken it. + sharedWriteMode = recordedSharedWriteMode selected desired prior } pure (Map.insert path record files) Nothing -> pure (applyOrphanManifestAction selected reconciliation files) @@ -318,7 +342,7 @@ generatedAt = record ^. #generatedAt, baseline = record ^. #baseline, applicationIds = owners, - additiveOnly = record ^. #additiveOnly + sharedWriteMode = record ^. #sharedWriteMode } replaceManifestFiles :: Manifest -> Map FilePath FileRecord -> Manifest @@ -332,6 +356,8 @@ applications = manifest ^. #applications, recipe = manifest ^. #recipe, blueprint = manifest ^. #blueprint, + seeds = manifest ^. #seeds, + checkoutOutputs = manifest ^. #checkoutOutputs, blueprintMigrations = manifest ^. #blueprintMigrations } @@ -411,6 +437,7 @@ Left err -> pure (Left err) Right metadata -> do result <- try @SomeException $ do + forM_ (metadata ^. #entries) (verifySafeParents (transaction ^. #projectRoot) . (^. #targetPath)) forM_ (metadata ^. #entries) (restoreEntry transaction) removeNewDirectories (transaction ^. #projectRoot) (metadata ^. #newDirectories) cleanupDirectory (transaction ^. #transactionDirectory) @@ -418,23 +445,49 @@ restoreEntry :: UpdateTransaction -> JournalEntry -> IO () restoreEntry transaction entry = do - let target = transaction ^. #projectRoot (entry ^. #targetPath) - case entry ^. #backupFile of - Nothing -> do - exists <- Directory.doesFileExist target - when exists (Directory.removeFile target) - Just backupName -> do + let root = transaction ^. #projectRoot + target = root (entry ^. #targetPath) + verifySafeParents root (entry ^. #targetPath) + current <- runEff $ runFilesystem $ inspectPath target + -- Never follow a current link while restoring a file snapshot or a link. + case current of + EntrySymlink _ -> Directory.removeDirectoryLink target + EntryDirectory -> ioError (userError ("refusing to restore over directory: " <> target)) + _ -> pure () + case (entry ^. #linkTarget, entry ^. #backupFile) of + (Just link, _) -> do + when (current == EntryFile) (ioError (userError ("refusing to restore link over a regular file: " <> target))) + Directory.createDirectoryIfMissing True (takeDirectory target) + Directory.createDirectoryLink link target + (_, Just backupName) -> do let backupPath = transaction ^. #transactionDirectory "backups" backupName + backupEntry <- runEff $ runFilesystem $ inspectPath backupPath + unless (backupEntry == EntryFile) (ioError (userError "transaction backup is not a real file")) content <- TIO.readFile backupPath atomicWriteText target content + _ -> when (current == EntryFile) (Directory.removeFile target) +-- | Recovery must not traverse a substituted parent. Check from the root down. +verifySafeParents :: FilePath -> FilePath -> IO () +verifySafeParents root path = go (reverse (relativeParents path)) + where + go [] = pure () + go (parent : rest) = do + entry <- runEff $ runFilesystem $ inspectPath (root parent) + case entry of + EntrySymlink _ -> ioError (userError ("transaction parent is a symlink: " <> parent)) + EntryFile -> ioError (userError ("transaction parent is not a directory: " <> parent)) + EntryMissing -> pure () + EntryDirectory -> go rest + removeNewDirectories :: FilePath -> [FilePath] -> IO () removeNewDirectories projectRoot = mapM_ removeIfEmpty . reverse . sortOn pathDepth where removeIfEmpty relativePath = do let fullPath = projectRoot relativePath - exists <- Directory.doesDirectoryExist fullPath - when exists $ do + verifySafeParents projectRoot relativePath + entry <- runEff $ runFilesystem $ inspectPath fullPath + when (entry == EntryDirectory) $ do contents <- Directory.listDirectory fullPath when (null contents) (Directory.removeDirectory fullPath) @@ -537,7 +590,7 @@ validateJournal :: JournalMetadata -> Either Text JournalMetadata validateJournal metadata = do traverse_ (validateJournalEntry . (^. #targetPath)) (metadata ^. #entries) - traverse_ validateBackupName [name | JournalEntry _ (Just name) <- metadata ^. #entries] + traverse_ validateBackupName [name | JournalEntry _ (Just name) _ <- metadata ^. #entries] traverse_ (first renderTransactionPathError . validateTransactionPath) (metadata ^. #newDirectories) pure metadata where diff --git a/src/Seihou/Engine/Validate.hs b/src/Seihou/Engine/Validate.hs --- a/src/Seihou/Engine/Validate.hs +++ b/src/Seihou/Engine/Validate.hs @@ -3,6 +3,7 @@ DiagCheck (..), ValidateReport (..), buildReport, + checkSeedSteps, renderReportPlain, reportHasErrors, ) @@ -16,7 +17,8 @@ import Data.Text.IO qualified as TIO import Seihou.Core.Expr (exprRefs, parseExpr) import Seihou.Core.Module - ( checkCommandSafety, + ( checkCheckoutSteps, + checkCommandSafety, checkDependencyNames, checkDestVarRefs, checkExportRefs, @@ -24,6 +26,7 @@ checkNameFormat, checkPromptRefs, checkSafeDestinations, + checkSeedSteps, checkUniqueVars, checkVersionPresent, extractPlaceholders, @@ -75,6 +78,8 @@ DiagCheck "Source file existence" DiagError fileErrors, DiagCheck "Dependency names" DiagError (checkDependencyNames m), DiagCheck "Safe step destinations" DiagError (checkSafeDestinations m), + DiagCheck "Checkout steps" DiagError (checkCheckoutSteps m), + DiagCheck "Seed steps" DiagError (checkSeedSteps m), DiagCheck "Destination variable references" DiagError (checkDestVarRefs m), DiagCheck "Command safety" DiagError (checkCommandSafety m) ] @@ -212,7 +217,7 @@ lintDuplicateDestinations m = let nonPatchDests = [s ^. #dest | s <- m ^. #steps, isNothing (s ^. #patch)] dupes = findDuplicates Set.empty Set.empty nonPatchDests - in map (\d -> "multiple steps write to '" <> d <> "'") dupes + in map (\d -> "multiple steps write to '" <> d <> "'") [d | d <- dupes, Set.size (Set.fromList [s ^. #lifecycle | s <- m ^. #steps, s ^. #dest == d]) == 1] findDuplicates :: Set.Set Text -> Set.Set Text -> [Text] -> [Text] findDuplicates _ _ [] = [] diff --git a/src/Seihou/Manifest/JSON.hs b/src/Seihou/Manifest/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Manifest/JSON.hs @@ -0,0 +1,30 @@ +-- | The raw-byte boundary shared by manifest readers and explicit upgrades. +-- Check multiplicity before Aeson turns object members into a map. +module Seihou.Manifest.JSON (decodeManifestValue) where + +import Data.Aeson qualified as Aeson +import Data.Aeson.Decoding.ByteString.Lazy (lbsToTokens) +import Data.Aeson.Decoding.Tokens +import Data.Aeson.Key qualified as Key +import Data.ByteString.Lazy qualified as LBS +import Data.Set qualified as Set + +-- | Reject duplicate keys, including escaped-equivalent spellings, at any depth. +decodeManifestValue :: LBS.ByteString -> Either String Aeson.Value +decodeManifestValue bytes = check (lbsToTokens bytes) >> Aeson.eitherDecode bytes + where + check :: Tokens k String -> Either String k + check (TkLit _ rest) = Right rest + check (TkText _ rest) = Right rest + check (TkNumber _ rest) = Right rest + check (TkErr err) = Left err + check (TkArrayOpen array) = checkArray array + check (TkRecordOpen record) = checkRecord Set.empty record + checkArray (TkItem value) = check value >>= checkArray + checkArray (TkArrayEnd rest) = Right rest + checkArray (TkArrayErr err) = Left err + checkRecord seen (TkPair key value) + | Set.member key seen = Left ("duplicate manifest JSON key: " <> show (Key.toText key)) + | otherwise = check value >>= checkRecord (Set.insert key seen) + checkRecord _ (TkRecordEnd rest) = Right rest + checkRecord _ (TkRecordErr err) = Left err diff --git a/src/Seihou/Manifest/Types.hs b/src/Seihou/Manifest/Types.hs --- a/src/Seihou/Manifest/Types.hs +++ b/src/Seihou/Manifest/Types.hs @@ -1,6 +1,12 @@ module Seihou.Manifest.Types ( emptyManifest, + manifestEncodingLoss, currentManifestVersion, + oldestDecodableManifestVersion, + minimumManifestVersion, + manifestSupports, + sharedWriteModeToText, + sharedWriteModeFromText, manifestToJSON, manifestFromJSON, writeAppliedBlueprint, @@ -10,8 +16,11 @@ ) where +import Control.Monad (unless) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KM import Data.Aeson.Types qualified as Aeson import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels () @@ -21,8 +30,11 @@ import Data.Text qualified as T import Data.Time (UTCTime) import Seihou.Core.ArtifactIdentity (sameArtifactIdentity) +import Seihou.Core.Checkout (CheckoutError (..), validateCheckoutRecords) +import Seihou.Core.Seed (ManifestInvariantError (..), validateManifestInvariants) import Seihou.Core.Types import Seihou.Manifest.Hash (baselineRefFromText) +import Seihou.Manifest.JSON (decodeManifestValue) import Seihou.Prelude hiding ((.=)) import System.FilePath (takeFileName) @@ -53,16 +65,42 @@ -- Version-5-and-earlier manifests are not readable directly; see -- docs/plans/79-upgrade-legacy-absolute-path-manifests-in-place.md. -- --- Deliberately /not/ bumped from 6 to 7 when 'FileRecord' gained --- @additiveOnly@. The field is emitted only when true, so a manifest with no --- additive-only paths is byte-identical to one written before it existed, and --- a reader that predates it treats every path as requiring the full ownership --- closure -- the conservative reading. Bumping would make every manifest this --- release writes unreadable to 0.8.x binaries in exchange for nothing. See --- docs/plans/90-exempt-additive-patch-paths-from-the-shared-ownership-closure.md. -currentManifestVersion :: Int -currentManifestVersion = 6 +-- Bumped from 6 to 7 when every 'FileRecord' gained a required +-- @sharedWriteMode@ (see +-- docs/plans/92-define-manifest-schema-capabilities-and-ordered-upgrade-steps.md). +-- Schema 6 carried the same fact as an optional @additiveOnly@ Boolean that +-- was emitted only when true, so an absent key meant both "an owner rewrites +-- the whole file" and "this manifest predates the question". Schema 6 still +-- decodes directly: @additiveOnly: true@ becomes 'SharedWriteAdditiveOnly' +-- and anything else becomes 'SharedWriteUnknown'. The adjacent raw-document +-- step lives in "Seihou.Manifest.Upgrade"; the rule that every semantic +-- change advances this number is +-- docs/adr/0014-every-semantic-manifest-change-advances-the-schema-version.md. +currentManifestVersion :: ManifestSchemaVersion +currentManifestVersion = ManifestSchemaVersion 9 +-- | The oldest schema the ordinary decoder reads. Anything older records +-- machine-specific absolute paths and must go through the explicit +-- @seihou manifest upgrade@ conversion first. +oldestDecodableManifestVersion :: ManifestSchemaVersion +oldestDecodableManifestVersion = ManifestSchemaVersion 6 + +-- | The oldest schema that can express the facts a capability relies on. +-- This is the only place a feature's manifest requirement is written down; +-- commands ask 'manifestSupports' instead of comparing version numbers. +minimumManifestVersion :: ManifestCapability -> ManifestSchemaVersion +minimumManifestVersion TargetedAdditiveSharedPathUpdate = ManifestSchemaVersion 7 +minimumManifestVersion SeedReceipts = ManifestSchemaVersion 8 +minimumManifestVersion CheckoutLocalOutputs = ManifestSchemaVersion 9 + +-- | Whether a manifest's schema can express everything a capability needs. +-- A decoded schema-6 manifest answers 'False' for +-- 'TargetedAdditiveSharedPathUpdate' even though its records carry an +-- explicit 'SharedWriteUnknown', because the file itself does not say so. +manifestSupports :: ManifestCapability -> Manifest -> Bool +manifestSupports capability manifest = + manifest ^. #version >= minimumManifestVersion capability + -- | Create an empty manifest with the given timestamp. emptyManifest :: UTCTime -> Manifest emptyManifest now = @@ -75,6 +113,8 @@ applications = [], recipe = Nothing, blueprint = Nothing, + seeds = Map.empty, + checkoutOutputs = Map.empty, blueprintMigrations = [] } @@ -93,6 +133,8 @@ applications = m ^. #applications, recipe = m ^. #recipe, blueprint = Just ab, + seeds = m ^. #seeds, + checkoutOutputs = m ^. #checkoutOutputs, blueprintMigrations = m ^. #blueprintMigrations } @@ -115,6 +157,8 @@ applications = manifest ^. #applications, recipe = manifest ^. #recipe, blueprint = manifest ^. #blueprint, + seeds = manifest ^. #seeds, + checkoutOutputs = manifest ^. #checkoutOutputs, blueprintMigrations = upsert (manifest ^. #blueprintMigrations) } where @@ -159,7 +203,7 @@ -- | Decode a manifest from JSON bytes. manifestFromJSON :: LBS.ByteString -> Either String Manifest -manifestFromJSON = Aeson.eitherDecode +manifestFromJSON bytes = decodeManifestValue bytes >>= Aeson.parseEither parseJSON -- JSON instances @@ -170,50 +214,66 @@ "generatedAt" .= (m ^. #genAt), "modules" .= (m ^. #modules), "variables" .= varsToJSON (m ^. #vars), - "files" .= filesToJSON (m ^. #files), + "files" .= filesToJSON (m ^. #version) (m ^. #files), "applications" .= (m ^. #applications), "blueprintMigrations" .= (m ^. #blueprintMigrations) ] + ++ ["checkoutOutputs" .= Map.map checkoutToJSON (m ^. #checkoutOutputs) | m ^. #version >= ManifestSchemaVersion 9] + ++ ["seeds" .= Map.map seedToJSON (m ^. #seeds) | m ^. #version >= ManifestSchemaVersion 8] ++ maybe [] (\r -> ["recipe" .= r]) (m ^. #recipe) ++ maybe [] (\b -> ["blueprint" .= b]) (m ^. #blueprint) +-- | The version is read and checked before anything else, because the +-- file-record representation depends on it. instance FromJSON Manifest where parseJSON = Aeson.withObject "Manifest" $ \o -> do v <- o .: "version" checkManifestVersion v - Manifest - <$> pure v - <*> o .: "generatedAt" - <*> o .: "modules" - <*> (varsFromJSON =<< o .: "variables") - <*> (filesFromJSON =<< o .: "files") - <*> o Aeson..:? "applications" Aeson..!= [] - <*> o Aeson..:? "recipe" - <*> o Aeson..:? "blueprint" - <*> o Aeson..:? "blueprintMigrations" Aeson..!= [] + manifest <- + Manifest + <$> pure v + <*> o .: "generatedAt" + <*> o .: "modules" + <*> (varsFromJSON =<< o .: "variables") + <*> (filesFromJSON v =<< o .: "files") + <*> (if v >= ManifestSchemaVersion 8 then Map.traverseWithKey (\_ -> parseSeed) =<< o .: "seeds" else pure Map.empty) + <*> (if v >= ManifestSchemaVersion 9 then Map.traverseWithKey (\_ -> parseCheckout) =<< o .: "checkoutOutputs" else pure Map.empty) + <*> o Aeson..:? "applications" Aeson..!= [] + <*> o Aeson..:? "recipe" + <*> o Aeson..:? "blueprint" + <*> o Aeson..:? "blueprintMigrations" Aeson..!= [] + case validateManifestInvariants manifest of + Left (PathBothManagedAndSeeded path) -> fail ("path " <> path <> " is recorded both as a tracked file and as a seed") + Right () -> case validateCheckoutRecords manifest [] of + Left err -> fail (T.unpack (err ^. #message)) + Right () -> pure manifest -- | Reject a manifest this build cannot read, naming the remedy. -- --- Compatibility seam: schema-5-and-earlier manifests carry an absolute --- @source@ path in place of the portable @origin@. Decoding those is owned --- by docs/plans/79-upgrade-legacy-absolute-path-manifests-in-place.md; until --- that plan lands an older manifest fails here with a clear message rather --- than being silently misread. The @seihou manifest upgrade@ command the --- message names is delivered by that same plan, so the remedy does not exist --- yet. -checkManifestVersion :: Int -> Aeson.Parser () +-- Schema-5-and-earlier manifests carry an absolute @source@ path in place of +-- the portable @origin@; converting them is an inference that stays behind +-- the explicit @seihou manifest upgrade@ command +-- (docs/adr/0005-legacy-manifests-convert-through-an-explicit-command.md), +-- so they fail here rather than being silently misread. +checkManifestVersion :: ManifestSchemaVersion -> Aeson.Parser () checkManifestVersion v | v > currentManifestVersion = fail "manifest was created by a newer version of seihou" - | v < 6 = + | v < oldestDecodableManifestVersion = fail ( "this manifest uses schema version " - <> show v + <> show (v ^. #unManifestSchemaVersion) <> ", which records machine-specific absolute paths; run " <> "'seihou manifest upgrade' to convert it" ) | otherwise = pure () +instance ToJSON ManifestSchemaVersion where + toJSON (ManifestSchemaVersion v) = toJSON v + +instance FromJSON ManifestSchemaVersion where + parseJSON value = ManifestSchemaVersion <$> parseJSON value + instance ToJSON AppliedTarget where toJSON (AppliedModuleTarget name) = Aeson.object ["kind" .= ("module" :: Text), "name" .= (name ^. #unModuleName)] @@ -564,47 +624,77 @@ <*> o Aeson..:? "workDir" <*> pure Nothing -instance ToJSON FileRecord where - toJSON fr = - Aeson.object $ - [ "hash" .= (fr ^. #hash . #unSHA256), - "module" .= (fr ^. #moduleName . #unModuleName), - "strategy" .= strategyToText (fr ^. #strategy), - "generatedAt" .= (fr ^. #generatedAt) - ] - ++ maybe [] (\ref -> ["baseline" .= (ref ^. #unBaselineRef . #unSHA256)]) (fr ^. #baseline) - ++ applicationIdsField (fr ^. #applicationIds) - ++ additiveOnlyField (fr ^. #additiveOnly) - where - applicationIdsField ids - | Set.null ids = [] - | otherwise = ["applications" .= map (^. #unApplicationId) (Set.toAscList ids)] - -- Emitted only when true, so a manifest with no additive-only paths is - -- byte-identical to one written before the field existed. A reader that - -- predates the field ignores it and keeps enforcing the ownership - -- closure everywhere, which is the conservative behaviour; that is why - -- 'currentManifestVersion' does not move for this field. - additiveOnlyField additive - | additive = ["additiveOnly" .= True] - | otherwise = [] +-- | Encode a file record in the representation of the given schema. +-- +-- Schema 7 always emits @sharedWriteMode@, including @unknown@, so absence +-- can never again stand for a value. Schema 6 can only say +-- @additiveOnly: true@; a closure-required path is written without the key +-- and reads back as unknown, which is the fail-closed direction. +fileRecordToJSON :: ManifestSchemaVersion -> FileRecord -> Aeson.Value +fileRecordToJSON schema fr = + Aeson.object $ + [ "hash" .= (fr ^. #hash . #unSHA256), + "module" .= (fr ^. #moduleName . #unModuleName), + "strategy" .= strategyToText (fr ^. #strategy), + "generatedAt" .= (fr ^. #generatedAt) + ] + ++ maybe [] (\ref -> ["baseline" .= (ref ^. #unBaselineRef . #unSHA256)]) (fr ^. #baseline) + ++ applicationIdsField (fr ^. #applicationIds) + ++ sharedWriteField (fr ^. #sharedWriteMode) + where + applicationIdsField ids + | Set.null ids = [] + | otherwise = ["applications" .= map (^. #unApplicationId) (Set.toAscList ids)] + sharedWriteField mode + | schema >= ManifestSchemaVersion 7 = ["sharedWriteMode" .= sharedWriteModeToText mode] + | mode == SharedWriteAdditiveOnly = ["additiveOnly" .= True] + | otherwise = [] -instance FromJSON FileRecord where - parseJSON = Aeson.withObject "FileRecord" $ \o -> do - baselineText <- o Aeson..:? "baseline" - baseline <- traverse parseBaselineRef baselineText - FileRecord - <$> (SHA256 <$> o .: "hash") - <*> (ModuleName <$> o .: "module") - <*> (strategyFromText =<< o .: "strategy") - <*> o .: "generatedAt" - <*> pure baseline - <*> (Set.fromList . map ApplicationId <$> o Aeson..:? "applications" Aeson..!= []) - <*> (o Aeson..:? "additiveOnly" Aeson..!= False) - where - parseBaselineRef value = case baselineRefFromText value of - Just ref -> pure ref - Nothing -> fail "baseline must be a 64-character hexadecimal SHA-256 digest" +-- | Decode a file record in the representation of the given schema. +parseFileRecord :: ManifestSchemaVersion -> Aeson.Value -> Aeson.Parser FileRecord +parseFileRecord schema = Aeson.withObject "FileRecord" $ \o -> do + baselineText <- o Aeson..:? "baseline" + baseline <- traverse parseBaselineRef baselineText + FileRecord + <$> (SHA256 <$> o .: "hash") + <*> (ModuleName <$> o .: "module") + <*> (strategyFromText =<< o .: "strategy") + <*> o .: "generatedAt" + <*> pure baseline + <*> (Set.fromList . map ApplicationId <$> o Aeson..:? "applications" Aeson..!= []) + <*> parseSharedWrite o + where + parseBaselineRef value = case baselineRefFromText value of + Just ref -> pure ref + Nothing -> fail "baseline must be a 64-character hexadecimal SHA-256 digest" + parseSharedWrite o + | schema >= ManifestSchemaVersion 7 = do + raw <- o Aeson..:? "sharedWriteMode" + case raw of + Nothing -> fail "missing required key \"sharedWriteMode\" (schema 7 records it on every file)" + Just text -> case sharedWriteModeFromText text of + Just mode -> pure mode + Nothing -> + fail + ( "invalid \"sharedWriteMode\" value " + <> show text + <> "; expected \"unknown\", \"additive-only\", or \"requires-ownership-closure\"" + ) + | otherwise = do + -- Version 6 omitted false, so only an explicit true proves anything. + additive <- o Aeson..:? "additiveOnly" Aeson..!= False + pure (if additive then SharedWriteAdditiveOnly else SharedWriteUnknown) +-- | The schema-7 wire spelling of a shared-write mode. +sharedWriteModeToText :: SharedWriteMode -> Text +sharedWriteModeToText SharedWriteUnknown = "unknown" +sharedWriteModeToText SharedWriteAdditiveOnly = "additive-only" +sharedWriteModeToText SharedWriteRequiresOwnershipClosure = "requires-ownership-closure" + +sharedWriteModeFromText :: Text -> Maybe SharedWriteMode +sharedWriteModeFromText text = + lookup text [(sharedWriteModeToText mode, mode) | mode <- [minBound .. maxBound]] + instance ToJSON SHA256 where toJSON (SHA256 t) = toJSON t @@ -634,13 +724,23 @@ -- Helpers for FilePath-keyed maps -filesToJSON :: Map FilePath FileRecord -> Aeson.Value -filesToJSON = toJSON . Map.mapKeys T.pack +filesToJSON :: ManifestSchemaVersion -> Map FilePath FileRecord -> Aeson.Value +filesToJSON schema = toJSON . Map.map (fileRecordToJSON schema) . Map.mapKeys T.pack -filesFromJSON :: Aeson.Value -> Aeson.Parser (Map FilePath FileRecord) -filesFromJSON v = do - m <- parseJSON v :: Aeson.Parser (Map Text FileRecord) - pure (Map.mapKeys T.unpack m) +-- | Each record is parsed under its path, so a malformed record's error +-- names the file it belongs to. +filesFromJSON :: ManifestSchemaVersion -> Aeson.Value -> Aeson.Parser (Map FilePath FileRecord) +filesFromJSON schema v = do + m <- parseJSON v :: Aeson.Parser (Map Text Aeson.Value) + records <- + Map.traverseWithKey + ( \path value -> + Aeson.modifyFailure + (\err -> "file record " <> show path <> ": " <> err) + (parseFileRecord schema value Aeson. Aeson.Key (Key.fromText path)) + ) + m + pure (Map.mapKeys T.unpack records) -- Strategy serialization @@ -649,10 +749,70 @@ strategyToText Template = "template" strategyToText DhallText = "dhall-text" strategyToText Structured = "structured" +strategyToText Symlink = "symlink" strategyFromText :: Text -> Aeson.Parser Strategy strategyFromText "copy" = pure Copy strategyFromText "template" = pure Template strategyFromText "dhall-text" = pure DhallText strategyFromText "structured" = pure Structured +strategyFromText "symlink" = fail "checkout symlinks cannot be managed file records" strategyFromText other = fail ("unknown strategy: " <> T.unpack other) + +seedToJSON :: SeedRecord -> Aeson.Value +seedToJSON record = + Aeson.object + [ "module" .= (record ^. #moduleName . #unModuleName), + "applications" .= map (^. #unApplicationId) (Set.toAscList (record ^. #applicationIds)), + "outcome" .= seedOutcomeToText (record ^. #outcome), + "settledAt" .= (record ^. #settledAt) + ] + +seedOutcomeToText :: SeedOutcome -> Text +seedOutcomeToText SeedCreated = "created" +seedOutcomeToText SeedFoundExisting = "found-existing" +seedOutcomeToText SeedReleasedFromManaged = "released-from-managed" + +parseSeed :: Aeson.Value -> Aeson.Parser SeedRecord +parseSeed = Aeson.withObject "seed receipt" $ \o -> do + outcome <- + o .: "outcome" >>= \case + "created" -> pure SeedCreated + "found-existing" -> pure SeedFoundExisting + "released-from-managed" -> pure SeedReleasedFromManaged + (other :: Text) -> fail ("unknown seed outcome: " <> T.unpack other <> "; expected created, found-existing, released-from-managed") + SeedRecord + <$> (ModuleName <$> o .: "module") + <*> (Set.fromList . map ApplicationId <$> o .: "applications") + <*> pure outcome + <*> o .: "settledAt" + +-- | Facts that would be lost if a caller encoded a value at its stated schema. +manifestEncodingLoss :: Manifest -> [Text] +manifestEncodingLoss manifest = + ["checkout outputs require manifest schema 9" | manifest ^. #version < ManifestSchemaVersion 9, not (Map.null (manifest ^. #checkoutOutputs))] + <> ["seed receipts require manifest schema 8" | manifest ^. #version < ManifestSchemaVersion 8, not (Map.null (manifest ^. #seeds))] + +checkoutToJSON :: CheckoutOutputRecord -> Aeson.Value +checkoutToJSON record = + Aeson.object + [ "spec" .= case record ^. #spec of + DirectorySymlink source -> Aeson.object ["kind" .= ("directory-symlink" :: Text), "source" .= source], + "owners" .= Map.mapKeys (^. #unApplicationId) (Map.map (map (^. #unModuleName) . Set.toAscList) (record ^. #owners)) + ] + +parseCheckout :: Aeson.Value -> Aeson.Parser CheckoutOutputRecord +parseCheckout = Aeson.withObject "checkout output" $ \o -> do + unless (Set.fromList (KM.keys o) == Set.fromList ["spec", "owners"]) $ fail "checkout output requires exactly spec and owners" + spec <- + o .: "spec" + >>= Aeson.withObject + "checkout spec" + ( \fields -> do + kind <- fields .: "kind" :: Aeson.Parser Text + unless (kind == "directory-symlink") $ fail ("unknown checkout output kind: " <> T.unpack kind) + unless (Set.fromList (KM.keys fields) == Set.fromList ["kind", "source"]) $ fail "directory-symlink requires exactly kind and source" + DirectorySymlink <$> fields .: "source" + ) + owners <- o .: "owners" :: Aeson.Parser (Map Text [Text]) + pure (CheckoutOutputRecord spec (Map.mapKeys ApplicationId (Map.map (Set.fromList . map ModuleName) owners))) diff --git a/src/Seihou/Manifest/Upgrade.hs b/src/Seihou/Manifest/Upgrade.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Manifest/Upgrade.hs @@ -0,0 +1,282 @@ +-- | The ordered, adjacent schema steps that take a raw +-- @.seihou/manifest.json@ document from any supported schema to a newer one. +-- +-- Every semantic manifest change advances the schema and adds exactly one +-- @N -> N + 1@ step here +-- (docs/adr/0014-every-semantic-manifest-change-advances-the-schema-version.md). +-- A path is planned one adjacent step at a time, so a missing step is an +-- error rather than a silent jump, and a document's @version@ only ever +-- names the last step that actually ran. +-- +-- Steps work on 'Aeson.Value' rather than 'Manifest' so that keys this build +-- does not model survive. Each step is classified: a lossless step is a +-- deterministic transform implemented here and may be staged by any command +-- that needs it; an inference-bearing step consults machine-local state and +-- is implemented only by the explicit @seihou manifest upgrade@ command in +-- @seihou-cli@ (docs/adr/0005-legacy-manifests-convert-through-an-explicit-command.md). +module Seihou.Manifest.Upgrade + ( UpgradeStepAction (..), + UpgradeStepKind (..), + ManifestUpgradeStep (..), + ManifestUpgradeError (..), + oldestUpgradableManifestVersion, + manifestUpgradeSteps, + upgradeStepKind, + planManifestUpgrade, + planUpgradeWith, + documentSchemaVersion, + setDocumentSchemaVersion, + applyLosslessUpgradeStep, + upgradeDocumentLosslessly, + makeSharedWriteEvidenceExplicit, + renderManifestUpgradeError, + ) +where + +import Control.Monad (foldM, unless) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Generics.Labels () +import Data.Text qualified as T +import Seihou.Core.Types +import Seihou.Manifest.Types (currentManifestVersion, sharedWriteModeToText) +import Seihou.Prelude + +-- | What a step does to the document. The kind of each action is fixed by +-- 'upgradeStepKind', so a step cannot be declared lossless while doing +-- inference. +data UpgradeStepAction + = -- | Only the version changes: every field the newer schema added decodes + -- from its absence to the same default the older reader assumed. + StampVersion + | -- | Schema 5 to 6: machine-local @source@ and @targetSource@ paths + -- become portable artifact origins. Implemented by the CLI. + ConvertMachineLocalPaths + | -- | Schema 6 to 7: the optional @additiveOnly@ Boolean becomes a + -- required @sharedWriteMode@ on every file record. + MakeSharedWriteEvidenceExplicit + | AddEmptySeedReceipts + | AddEmptyCheckoutOutputs + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +-- | Whether a step may be staged automatically. +data UpgradeStepKind + = -- | Deterministic and loses nothing; may be staged by a command that + -- requires the newer schema and committed atomically with its result. + LosslessUpgrade + | -- | Consults machine-local state or chooses among plausible answers; + -- only the explicit, reviewable @seihou manifest upgrade@ runs it. + InferenceBearingUpgrade + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +-- | One adjacent schema step. +data ManifestUpgradeStep = ManifestUpgradeStep + { fromVersion :: !ManifestSchemaVersion, + toVersion :: !ManifestSchemaVersion, + action :: !UpgradeStepAction, + -- | A short description for upgrade reports. + summary :: !Text + } + deriving stock (Eq, Show, Generic) + +data ManifestUpgradeError + = -- | The document has no integer @version@, or is not an object. + UnreadableSchemaVersion Text + | -- | Older than any schema this build knows how to upgrade. + SourceVersionUnsupported ManifestSchemaVersion + | -- | Written by a newer seihou than this one. + SourceNewerThanBinary ManifestSchemaVersion + | -- | Asked for a schema this build does not know. + TargetAboveCurrent ManifestSchemaVersion + | -- | Asked to go backwards: source, then requested target. + TargetBelowSource ManifestSchemaVersion ManifestSchemaVersion + | -- | No step starts at this version. + MissingUpgradeStep ManifestSchemaVersion + | -- | A lossless run reached a step only the explicit command may run. + StepRequiresInference ManifestUpgradeStep + | -- | A step was applied to a document at a different version. + StepVersionMismatch ManifestUpgradeStep ManifestSchemaVersion + | -- | The document did not have the shape its version promises. + MalformedDocument ManifestSchemaVersion Text + deriving stock (Eq, Show, Generic) + +-- | The oldest schema any step starts from. +oldestUpgradableManifestVersion :: ManifestSchemaVersion +oldestUpgradableManifestVersion = ManifestSchemaVersion 1 + +-- | Every adjacent step, oldest first. Adding a schema version means adding +-- exactly one entry here; the test suite plans a path from every supported +-- version to 'currentManifestVersion', so a forgotten step fails it. +manifestUpgradeSteps :: [ManifestUpgradeStep] +manifestUpgradeSteps = + [ step 1 StampVersion "per-instance parent variables", + step 2 StampVersion "applied blueprint record", + step 3 StampVersion "reproducible applications and generated baselines", + step 4 StampVersion "blueprint migration receipts", + step 5 ConvertMachineLocalPaths "portable artifact origins", + step 6 MakeSharedWriteEvidenceExplicit "explicit shared-write evidence", + step 7 AddEmptySeedReceipts "seed receipts", + step 8 AddEmptyCheckoutOutputs "checkout outputs" + ] + where + step from stepAction = + ManifestUpgradeStep (ManifestSchemaVersion from) (ManifestSchemaVersion (from + 1)) stepAction + +upgradeStepKind :: UpgradeStepAction -> UpgradeStepKind +upgradeStepKind StampVersion = LosslessUpgrade +upgradeStepKind ConvertMachineLocalPaths = InferenceBearingUpgrade +upgradeStepKind MakeSharedWriteEvidenceExplicit = LosslessUpgrade +upgradeStepKind AddEmptySeedReceipts = LosslessUpgrade +upgradeStepKind AddEmptyCheckoutOutputs = LosslessUpgrade + +-- | The contiguous steps from @source@ to @target@. Planning from a version +-- to itself is an empty path. +planManifestUpgrade :: + ManifestSchemaVersion -> + ManifestSchemaVersion -> + Either ManifestUpgradeError [ManifestUpgradeStep] +planManifestUpgrade = planUpgradeWith manifestUpgradeSteps currentManifestVersion + +-- | 'planManifestUpgrade' over an explicit step table and current version, +-- so the gap check itself can be tested. +planUpgradeWith :: + [ManifestUpgradeStep] -> + ManifestSchemaVersion -> + ManifestSchemaVersion -> + ManifestSchemaVersion -> + Either ManifestUpgradeError [ManifestUpgradeStep] +planUpgradeWith steps current source target + | source > current = Left (SourceNewerThanBinary source) + | source < oldestUpgradableManifestVersion = Left (SourceVersionUnsupported source) + | target > current = Left (TargetAboveCurrent target) + | target < source = Left (TargetBelowSource source target) + | otherwise = walk source + where + walk version + | version == target = Right [] + | otherwise = case [candidate | candidate <- steps, candidate ^. #fromVersion == version] of + [found] + | found ^. #toVersion == nextVersion version -> (found :) <$> walk (nextVersion version) + _ -> Left (MissingUpgradeStep version) + nextVersion (ManifestSchemaVersion v) = ManifestSchemaVersion (v + 1) + +-- | Read a raw document's top-level @version@. +documentSchemaVersion :: Aeson.Value -> Either ManifestUpgradeError ManifestSchemaVersion +documentSchemaVersion (Aeson.Object fields) = case KeyMap.lookup "version" fields of + Just value | Aeson.Success v <- Aeson.fromJSON value -> Right (ManifestSchemaVersion v) + Just _ -> Left (UnreadableSchemaVersion "the \"version\" field is not an integer") + Nothing -> Left (UnreadableSchemaVersion "the manifest has no \"version\" field") +documentSchemaVersion _ = Left (UnreadableSchemaVersion "the manifest is not a JSON object") + +-- | Replace a raw document's top-level @version@, keeping every other key. +setDocumentSchemaVersion :: ManifestSchemaVersion -> Aeson.Value -> Aeson.Value +setDocumentSchemaVersion version (Aeson.Object fields) = + Aeson.Object (KeyMap.insert "version" (Aeson.toJSON (version ^. #unManifestSchemaVersion)) fields) +setDocumentSchemaVersion _ other = other + +-- | Run one lossless step. The document must be at the step's source +-- version; the version is advanced only after the transform succeeds. +applyLosslessUpgradeStep :: ManifestUpgradeStep -> Aeson.Value -> Either ManifestUpgradeError Aeson.Value +applyLosslessUpgradeStep upgradeStep document = do + actual <- documentSchemaVersion document + unless (actual == upgradeStep ^. #fromVersion) $ + Left (StepVersionMismatch upgradeStep actual) + transformed <- case upgradeStep ^. #action of + StampVersion -> Right document + AddEmptyCheckoutOutputs -> case document of + Aeson.Object fields -> case KeyMap.lookup "checkoutOutputs" fields of + Nothing -> Right (Aeson.Object (KeyMap.insert "checkoutOutputs" (Aeson.object []) fields)) + Just (Aeson.Object _) -> Right document + _ -> Left (MalformedDocument actual "checkoutOutputs must be an object") + _ -> Left (MalformedDocument actual "manifest must be an object") + AddEmptySeedReceipts -> case document of + Aeson.Object fields -> case KeyMap.lookup "seeds" fields of + Nothing -> Right (Aeson.Object (KeyMap.insert "seeds" (Aeson.object []) fields)) + Just (Aeson.Object _) -> Right document + _ -> Left (MalformedDocument actual "seeds must be an object") + _ -> Left (MalformedDocument actual "cannot add empty seeds: field already exists or document is not an object") + MakeSharedWriteEvidenceExplicit -> + first (MalformedDocument actual) (makeSharedWriteEvidenceExplicit document) + ConvertMachineLocalPaths -> Left (StepRequiresInference upgradeStep) + pure (setDocumentSchemaVersion (upgradeStep ^. #toVersion) transformed) + +-- | Upgrade a raw document to @target@ using lossless steps only. Stops with +-- 'StepRequiresInference' before changing anything if the path crosses an +-- inference-bearing step. Returns the steps that ran with the result. +upgradeDocumentLosslessly :: + ManifestSchemaVersion -> + Aeson.Value -> + Either ManifestUpgradeError ([ManifestUpgradeStep], Aeson.Value) +upgradeDocumentLosslessly target document = do + source <- documentSchemaVersion document + steps <- planManifestUpgrade source target + case [s | s <- steps, upgradeStepKind (s ^. #action) == InferenceBearingUpgrade] of + blocked : _ -> Left (StepRequiresInference blocked) + [] -> (steps,) <$> foldM (flip applyLosslessUpgradeStep) document steps + +-- | The schema 6 to 7 transform. Every file record gains a required +-- @sharedWriteMode@: an explicit @additiveOnly: true@ becomes +-- @additive-only@, and anything else becomes @unknown@, because schema 6 +-- omitted @false@ and absence therefore proves nothing. The old key is +-- removed; every other member at every level is kept. +makeSharedWriteEvidenceExplicit :: Aeson.Value -> Either Text Aeson.Value +makeSharedWriteEvidenceExplicit (Aeson.Object fields) = case KeyMap.lookup "files" fields of + Just (Aeson.Object records) -> do + converted <- KeyMap.traverseWithKey convertRecord records + Right (Aeson.Object (KeyMap.insert "files" (Aeson.Object converted) fields)) + Just _ -> Left "\"files\" is not an object" + Nothing -> Left "the manifest has no \"files\" object" + where + convertRecord path (Aeson.Object record) = do + mode <- case KeyMap.lookup "additiveOnly" record of + Nothing -> Right SharedWriteUnknown + Just (Aeson.Bool True) -> Right SharedWriteAdditiveOnly + Just (Aeson.Bool False) -> Right SharedWriteUnknown + Just _ -> Left ("file record " <> Key.toText path <> ": \"additiveOnly\" is not a Boolean") + Right + ( Aeson.Object + ( KeyMap.insert "sharedWriteMode" (Aeson.String (sharedWriteModeToText mode)) $ + KeyMap.delete "additiveOnly" record + ) + ) + convertRecord path _ = Left ("file record " <> Key.toText path <> " is not an object") +makeSharedWriteEvidenceExplicit _ = Left "the manifest is not a JSON object" + +renderManifestUpgradeError :: ManifestUpgradeError -> Text +renderManifestUpgradeError err = case err of + UnreadableSchemaVersion reason -> "cannot read the manifest schema version: " <> reason + SourceVersionUnsupported v -> "manifest schema " <> showVersion v <> " is older than any schema seihou can upgrade" + SourceNewerThanBinary v -> + "manifest schema " + <> showVersion v + <> " was written by a newer seihou; this build understands up to schema " + <> showVersion currentManifestVersion + TargetAboveCurrent v -> + "schema " + <> showVersion v + <> " is newer than this build supports (up to " + <> showVersion currentManifestVersion + <> ")" + TargetBelowSource source target -> + "cannot upgrade from schema " <> showVersion source <> " to the older schema " <> showVersion target + MissingUpgradeStep v -> "no upgrade step is defined from schema " <> showVersion v + StepRequiresInference s -> + "upgrading from schema " + <> showVersion (s ^. #fromVersion) + <> " to " + <> showVersion (s ^. #toVersion) + <> " (" + <> s ^. #summary + <> ") needs review; run 'seihou manifest upgrade'" + StepVersionMismatch s actual -> + "the " + <> showVersion (s ^. #fromVersion) + <> " -> " + <> showVersion (s ^. #toVersion) + <> " step cannot run on a schema-" + <> showVersion actual + <> " document" + MalformedDocument v reason -> "the schema-" <> showVersion v <> " manifest is malformed: " <> reason + where + showVersion (ManifestSchemaVersion v) = T.pack (show v) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -7,9 +7,11 @@ import Seihou.Composition.ResolveSpec qualified as ResolveSpec import Seihou.Core.AgentPromptSpec qualified as AgentPromptSpec import Seihou.Core.ApplicationSpec qualified as ApplicationSpec +import Seihou.Core.ArtifactIdentitySpec qualified as ArtifactIdentitySpec import Seihou.Core.ArtifactOriginDetectSpec qualified as ArtifactOriginDetectSpec import Seihou.Core.ArtifactRefSpec qualified as ArtifactRefSpec import Seihou.Core.BlueprintSpec qualified as BlueprintSpec +import Seihou.Core.CheckoutSpec qualified as CheckoutSpec import Seihou.Core.CommandFingerprintSpec qualified as CommandFingerprintSpec import Seihou.Core.CommandVarSpec qualified as CommandVarSpec import Seihou.Core.ContextSpec qualified as ContextSpec @@ -25,6 +27,7 @@ import Seihou.Core.RegistrySyncSpec qualified as RegistrySyncSpec import Seihou.Core.ScaffoldSpec qualified as ScaffoldSpec import Seihou.Core.SchemaUpgradeSpec qualified as SchemaUpgradeSpec +import Seihou.Core.SeedSpec qualified as SeedSpec import Seihou.Core.StatusSpec qualified as StatusSpec import Seihou.Core.TypesSpec qualified as TypesSpec import Seihou.Core.VariableSpec qualified as VariableSpec @@ -39,6 +42,7 @@ import Seihou.Effect.LoggerSpec qualified as LoggerSpec import Seihou.Effect.ManifestStoreSpec qualified as ManifestStoreSpec import Seihou.Engine.BaselineSpec qualified as BaselineSpec +import Seihou.Engine.CheckoutSpec qualified as CheckoutEngineSpec import Seihou.Engine.ConflictSpec qualified as ConflictSpec import Seihou.Engine.DiffSpec qualified as DiffSpec import Seihou.Engine.ExecuteSpec qualified as ExecuteSpec @@ -63,6 +67,7 @@ import Seihou.Interaction.ConfirmSpec qualified as ConfirmSpec import Seihou.Interaction.PromptSpec qualified as PromptSpec import Seihou.Manifest.TypesSpec qualified as ManifestTypesSpec +import Seihou.Manifest.UpgradeSpec qualified as ManifestUpgradeSpec import Test.Tasty main :: IO () @@ -74,6 +79,7 @@ resolveTests <- ResolveSpec.tests agentPromptTests <- AgentPromptSpec.tests applicationTests <- ApplicationSpec.tests + artifactIdentityTests <- ArtifactIdentitySpec.tests artifactOriginDetectTests <- ArtifactOriginDetectSpec.tests artifactRefTests <- ArtifactRefSpec.tests blueprintTests <- BlueprintSpec.tests @@ -92,6 +98,9 @@ registryEmitTests <- RegistryEmitSpec.tests registrySyncTests <- RegistrySyncSpec.tests scaffoldTests <- ScaffoldSpec.tests + checkoutEngineTests <- CheckoutEngineSpec.tests + checkoutTests <- CheckoutSpec.tests + seedTests <- SeedSpec.tests schemaUpgradeTests <- SchemaUpgradeSpec.tests statusTests <- StatusSpec.tests variableTests <- VariableSpec.tests @@ -128,6 +137,7 @@ integrationTests <- IntegrationSpec.tests generationTests <- GenerationSpec.tests manifestTypesTests <- ManifestTypesSpec.tests + manifestUpgradeTests <- ManifestUpgradeSpec.tests promptTests <- PromptSpec.tests confirmTests <- ConfirmSpec.tests - defaultMain (testGroup "seihou-core" [graphTests, instanceTests, compositionPlanTests, compositionRecipeTests, resolveTests, agentPromptTests, applicationTests, artifactOriginDetectTests, artifactRefTests, blueprintTests, commandFingerprintTests, commandVarTests, typesTests, contextTests, entailmentTests, exprTests, installTests, listTests, migrationTests, moduleTests, recipeTests, registryTests, registryEmitTests, registrySyncTests, scaffoldTests, schemaUpgradeTests, statusTests, variableTests, versionTests, templateTests, threeWayMergeTests, updateTransactionTests, planTests, previewTests, reconcileTests, sectionTests, validateTests, splitFlakeTests, dhallTextFlakeTests, typedDhallTextTests, conditionalTemplateTests, configTests, dhallEvalTests, migrationDecoderTests, configReaderTests, configWriterTests, baselineStoreTests, filesystemTests, loggerTests, manifestStoreTests, conflictTests, baselineTests, diffTests, executeTests, engineMigrateTests, removeTests, compositionTests, executionTests, integrationTests, generationTests, manifestTypesTests, promptTests, confirmTests]) + defaultMain (testGroup "seihou-core" [graphTests, instanceTests, compositionPlanTests, compositionRecipeTests, resolveTests, agentPromptTests, applicationTests, artifactIdentityTests, artifactOriginDetectTests, artifactRefTests, blueprintTests, commandFingerprintTests, commandVarTests, typesTests, contextTests, entailmentTests, exprTests, installTests, listTests, migrationTests, moduleTests, recipeTests, registryTests, registryEmitTests, registrySyncTests, scaffoldTests, checkoutEngineTests, checkoutTests, seedTests, schemaUpgradeTests, statusTests, variableTests, versionTests, templateTests, threeWayMergeTests, updateTransactionTests, planTests, previewTests, reconcileTests, sectionTests, validateTests, splitFlakeTests, dhallTextFlakeTests, typedDhallTextTests, conditionalTemplateTests, configTests, dhallEvalTests, migrationDecoderTests, configReaderTests, configWriterTests, baselineStoreTests, filesystemTests, loggerTests, manifestStoreTests, conflictTests, baselineTests, diffTests, executeTests, engineMigrateTests, removeTests, compositionTests, executionTests, integrationTests, generationTests, manifestTypesTests, manifestUpgradeTests, promptTests, confirmTests]) diff --git a/test/Seihou/Core/ApplicationSpec.hs b/test/Seihou/Core/ApplicationSpec.hs --- a/test/Seihou/Core/ApplicationSpec.hs +++ b/test/Seihou/Core/ApplicationSpec.hs @@ -1,6 +1,7 @@ module Seihou.Core.ApplicationSpec (tests) where import Control.Lens ((&), (?~), (^.)) +import Control.Monad (forM_) import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Set qualified as Set @@ -158,41 +159,50 @@ it "unions prior and current ownership and preserves the generated baseline" $ do let priorId = ApplicationId "prior" currentId = ApplicationId "current" - prior = FileRecord (hashContent "old") "module" Template fixedTime Nothing (Set.singleton priorId) False - current = FileRecord (hashContent "new") "module" Template fixedTime (Just (BaselineRef (hashContent "generated"))) Set.empty False + prior = FileRecord (hashContent "old") "module" Template fixedTime Nothing (Set.singleton priorId) SharedWriteUnknown + current = FileRecord (hashContent "new") "module" Template fixedTime (Just (BaselineRef (hashContent "generated"))) Set.empty SharedWriteRequiresOwnershipClosure attached = attachApplication currentId (Just prior) current (attached ^. #applicationIds) `shouldBe` Set.fromList [priorId, currentId] (attached ^. #baseline) `shouldBe` Just (BaselineRef (hashContent "generated")) - it "cannot strengthen additiveOnly while a prior owner survives" $ do + it "cannot strengthen a closure requirement while a prior owner survives" $ do -- This run executed only its own application's operations, so its -- answer covers only its own contributions. A co-owner that rewrites -- the whole file must keep the path under the ownership closure. let priorId = ApplicationId "prior" currentId = ApplicationId "current" - prior = record (Set.singleton priorId) False - current = record Set.empty True - (attachApplication currentId (Just prior) current ^. #additiveOnly) `shouldBe` False + prior = record (Set.singleton priorId) SharedWriteRequiresOwnershipClosure + current = record Set.empty SharedWriteAdditiveOnly + (attachApplication currentId (Just prior) current ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure - it "keeps additiveOnly true when the prior record and this run agree" $ do + it "keeps unknown evidence unknown while a prior owner survives" $ do + -- Nothing this run did says how the retained owner writes the path. let priorId = ApplicationId "prior" currentId = ApplicationId "current" - (attachApplication currentId (Just (record (Set.singleton priorId) True)) (record Set.empty True) ^. #additiveOnly) - `shouldBe` True + (attachApplication currentId (Just (record (Set.singleton priorId) SharedWriteUnknown)) (record Set.empty SharedWriteAdditiveOnly) ^. #sharedWriteMode) + `shouldBe` SharedWriteUnknown - it "weakens additiveOnly when this run is no longer additive" $ do + it "keeps additive-only when the prior record and this run agree" $ do let priorId = ApplicationId "prior" currentId = ApplicationId "current" - (attachApplication currentId (Just (record (Set.singleton priorId) True)) (record Set.empty False) ^. #additiveOnly) - `shouldBe` False + (attachApplication currentId (Just (record (Set.singleton priorId) SharedWriteAdditiveOnly)) (record Set.empty SharedWriteAdditiveOnly) ^. #sharedWriteMode) + `shouldBe` SharedWriteAdditiveOnly + it "records a closure requirement when this run is no longer additive" $ do + let priorId = ApplicationId "prior" + currentId = ApplicationId "current" + forM_ [minBound .. maxBound] $ \priorMode -> + (attachApplication currentId (Just (record (Set.singleton priorId) priorMode)) (record Set.empty SharedWriteRequiresOwnershipClosure) ^. #sharedWriteMode) + `shouldBe` SharedWriteRequiresOwnershipClosure + it "trusts this run's answer when it is the only owner" $ do let currentId = ApplicationId "current" - prior = record (Set.singleton currentId) False - (attachApplication currentId (Just prior) (record Set.empty True) ^. #additiveOnly) `shouldBe` True - (attachApplication currentId Nothing (record Set.empty True) ^. #additiveOnly) `shouldBe` True + forM_ [minBound .. maxBound] $ \priorMode -> + (attachApplication currentId (Just (record (Set.singleton currentId) priorMode)) (record Set.empty SharedWriteAdditiveOnly) ^. #sharedWriteMode) + `shouldBe` SharedWriteAdditiveOnly + (attachApplication currentId Nothing (record Set.empty SharedWriteAdditiveOnly) ^. #sharedWriteMode) `shouldBe` SharedWriteAdditiveOnly --- | A file record carrying the given owners and additive-only verdict. -record :: Set.Set ApplicationId -> Bool -> FileRecord -record owners additive = - FileRecord (hashContent "content") "module" Template fixedTime Nothing owners additive +-- | A file record carrying the given owners and shared-write mode. +record :: Set.Set ApplicationId -> SharedWriteMode -> FileRecord +record owners mode = + FileRecord (hashContent "content") "module" Template fixedTime Nothing owners mode diff --git a/test/Seihou/Core/ArtifactIdentitySpec.hs b/test/Seihou/Core/ArtifactIdentitySpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/ArtifactIdentitySpec.hs @@ -0,0 +1,49 @@ +module Seihou.Core.ArtifactIdentitySpec (tests) where + +import Control.Monad (forM_) +import Data.Text (Text) +import Data.Text qualified as T +import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.ArtifactIdentity" spec + +machineLocal :: [Text] +machineLocal = + [ "/Users/alice/Keikaku/bokuno/seihou-modules", + " /srv/modules ", + "./modules", + "../seihou-modules", + ".", + "..", + "~/src/seihou-modules", + "~", + "file:///Users/alice/seihou-modules", + "file:../modules", + "C:\\src\\modules", + "c:/src/modules" + ] + +remote :: [Text] +remote = + [ "https://github.com/shinzui/seihou-modules.git", + "http://example.com/mods", + "ssh://git@github.com/shinzui/seihou-modules.git", + "git://example.com/mods.git", + "git@github.com:shinzui/seihou-modules.git", + "github.com:shinzui/seihou-modules", + "modules" + ] + +spec :: Spec +spec = + describe "isMachineLocalOriginUrl" $ do + forM_ machineLocal $ \url -> + it ("treats " <> T.unpack url <> " as machine-local") $ + isMachineLocalOriginUrl url `shouldBe` True + forM_ remote $ \url -> + it ("treats " <> T.unpack url <> " as reachable from other machines") $ + isMachineLocalOriginUrl url `shouldBe` False diff --git a/test/Seihou/Core/ArtifactOriginDetectSpec.hs b/test/Seihou/Core/ArtifactOriginDetectSpec.hs --- a/test/Seihou/Core/ArtifactOriginDetectSpec.hs +++ b/test/Seihou/Core/ArtifactOriginDetectSpec.hs @@ -65,6 +65,16 @@ origin <- detectArtifactOrigin projectRoot moduleDir origin `shouldBe` LocalOrigin "haskell-base" + it "records an origin installed from a local path as a local origin" $ do + withRoots $ \projectRoot installedRoot -> do + let moduleDir = installedRoot "nix-haskell-flake" + createDirectoryIfMissing True moduleDir + writeFile + (moduleDir ".seihou-origin.json") + "{\"sourceUrl\":\"/Users/someone/src/modules\",\"repoName\":\"modules\"}" + origin <- detectArtifactOrigin projectRoot moduleDir + origin `shouldBe` LocalOrigin "nix-haskell-flake" + it "falls back to a local origin when there is no metadata file" $ do withRoots $ \projectRoot installedRoot -> do let moduleDir = installedRoot "scratch-module" diff --git a/test/Seihou/Core/CheckoutSpec.hs b/test/Seihou/Core/CheckoutSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/CheckoutSpec.hs @@ -0,0 +1,95 @@ +module Seihou.Core.CheckoutSpec (tests) where + +import Control.Monad (forM_) +import Data.Aeson qualified as Aeson +import Data.Either (isLeft) +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Time (UTCTime (..), fromGregorian) +import Seihou.Core.Checkout +import Seihou.Core.Types +import Seihou.Effect.Filesystem (PathEntry (..)) +import Seihou.Manifest.Types +import Seihou.Manifest.Upgrade +import Seihou.Prelude +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +record :: FilePath -> Text -> CheckoutOutputRecord +record source app = CheckoutOutputRecord (DirectorySymlink source) (Map.singleton (ApplicationId app) (Set.singleton "demo")) + +tests :: IO TestTree +tests = testSpec "checkout declarations and planning" $ do + let dest = ".local/config" + old = Map.singleton dest (record "config/editor" "a") + next = Map.singleton dest (record "config/new" "a") + obs entry = Map.singleton dest (CheckoutObservation entry True [] True True) + actions intent prior candidate entry = map (^. #action) (planCheckoutOutputs intent SyncIgnoredOnly prior candidate (obs entry) ^. #entries) + it "rejects portable path escapes, reserved metadata and overlapping paths" $ + forM_ ["", ".", "../escape", "a/../b", "/abs", "C:local", "a\\b", "a//b", "a/./b", "a/", ".GIT/config", ".seihou/x", "a\0b"] $ \source -> + validateCheckoutPaths source dest `shouldSatisfy` isLeft + it "rejects source/destination ancestry in either direction" $ do + validateCheckoutPaths "config" "config/local" `shouldSatisfy` isLeft + validateCheckoutPaths "config/local" "config" `shouldSatisfy` isLeft + it "uses canonical relative link text" $ do + expectedTarget ".local/config" (DirectorySymlink "config/editor") `shouldBe` "../config/editor" + expectedTarget ".claude/skills/demo" (DirectorySymlink "agents/skills/demo") `shouldBe` "../../agents/skills/demo" + it "merges agreeing claims associatively, commutatively and idempotently" $ do + let add a = mergeCheckoutRecord dest (record "config/editor" a) + merge names = foldl (\acc app -> acc >>= add app) (Right Map.empty) names + merge ["a", "b", "c"] `shouldBe` merge ["c", "a", "b"] + merge ["a", "a"] `shouldBe` merge ["a"] + merge ["a", "b", "c"] `shouldBe` (merge ["a"] >>= add "b" >>= add "c") + it "refuses conflicting owners regardless of contribution order" $ do + mergeCheckoutRecord dest (record "other" "b") old `shouldSatisfy` isLeft + mergeCheckoutRecord dest (record "config/editor" "a") (Map.singleton dest (record "other" "b")) `shouldSatisfy` isLeft + it "drops only selected owners" $ do + Right shared <- pure (mergeCheckoutRecord dest (record "config/editor" "b") old) + dropCheckoutOwners (Map.singleton (ApplicationId "a") (Set.singleton "demo")) shared `shouldBe` Map.singleton dest (record "config/editor" "b") + it "rebuilds missing and wrong links but preserves correct links" $ do + actions Rebuild old old EntryMissing `shouldBe` [CreateLink] + actions Rebuild old old (EntrySymlink "wrong") `shouldBe` [ReplaceLink] + actions Rebuild old old (EntrySymlink "../config/editor") `shouldBe` [UnchangedLink] + it "refuses real objects without discarding other classifications" $ do + let records = Map.insert ".local/second" (record "assets/shared" "a") old + observations = Map.insert ".local/second" (CheckoutObservation EntryMissing True [] True True) (obs EntryDirectory) + plan = planCheckoutOutputs Rebuild SyncIgnoredOnly records records observations + checkoutApplicable plan `shouldBe` False + map (^. #action) (plan ^. #entries) `shouldBe` [RefusedLink, CreateLink] + it "does no repair for unchanged declarations or owner-only changes" $ do + actions Reconcile old old EntryMissing `shouldBe` [UnchangedLink] + actions Reconcile old (Map.singleton dest (record "config/editor" "b")) (EntrySymlink "edited") `shouldBe` [UnchangedLink] + it "retires only matching links even with a missing source" $ do + let observations = Map.singleton dest (CheckoutObservation (EntrySymlink "../config/editor") False [] True False) + map (^. #action) (planCheckoutOutputs Reconcile ApplyDeclaration old Map.empty observations ^. #entries) `shouldBe` [RetireLink] + actions Reconcile old Map.empty (EntrySymlink "edited") `shouldBe` [PreserveModified] + actions Reconcile old Map.empty EntryDirectory `shouldBe` [PreserveModified] + actions Reconcile old Map.empty EntryMissing `shouldBe` [AlreadyAbsent] + it "retargets old or already-correct links but refuses third targets" $ do + actions Reconcile old next (EntrySymlink "../config/editor") `shouldBe` [ReplaceLink] + actions Reconcile old next (EntrySymlink "../config/new") `shouldBe` [UnchangedLink] + actions Reconcile old next (EntrySymlink "edited") `shouldBe` [RefusedLink] + it "rejects a rebuild contract with changed declarations" $ + checkoutApplicable (planCheckoutOutputs Rebuild SyncIgnoredOnly old next (obs EntryMissing)) `shouldBe` False + it "keeps the warning policy distinct from sync's ignored-only policy" $ do + let observations = Map.singleton dest (CheckoutObservation EntryMissing True [] False False) + checkoutApplicable (planCheckoutOutputs Rebuild SyncIgnoredOnly old old observations) `shouldBe` False + let apply = planCheckoutOutputs Reconcile ApplyDeclaration Map.empty old observations + checkoutApplicable apply `shouldBe` True + concatMap (^. #warnings) (apply ^. #entries) `shouldSatisfy` (not . null) + it "adds schema 9 losslessly without inventing declarations" $ do + let now = UTCTime (fromGregorian 2026 10 15) 0 + original = emptyManifest now & #version .~ ManifestSchemaVersion 8 + Right (_, document) <- pure (upgradeDocumentLosslessly (ManifestSchemaVersion 9) =<< decode original) + case manifestFromJSON (encode document) of + Right result -> Map.null (result ^. #checkoutOutputs) `shouldBe` True + Left err -> expectationFailure err + it "rejects duplicate keys before JSON object construction, including escaped-equivalent keys" $ do + manifestFromJSON "{\"version\":9,\"version\":9}" `shouldSatisfy` isLeft + manifestFromJSON "{\"version\":9,\"owners\":{\"a\":[],\"\\u0061\":[]}}" `shouldSatisfy` either (T.isInfixOf "duplicate" . T.pack) (const False) + where + decode manifest = first (const (MalformedDocument (ManifestSchemaVersion 8) "invalid fixture")) (Aeson.eitherDecode (manifestToJSON manifest)) + encode = Aeson.encode diff --git a/test/Seihou/Core/ModuleSpec.hs b/test/Seihou/Core/ModuleSpec.hs --- a/test/Seihou/Core/ModuleSpec.hs +++ b/test/Seihou/Core/ModuleSpec.hs @@ -40,7 +40,8 @@ src = "README.md.tpl", dest = "README.md", condition = Nothing, - patch = Nothing + patch = Nothing, + lifecycle = Managed } ], commands = [], @@ -180,7 +181,7 @@ let bad = goodModule & #steps - .~ [Step Template "README.md.tpl" "../etc/passwd" Nothing Nothing] + .~ [Step Template "README.md.tpl" "../etc/passwd" Nothing Nothing Managed] result <- validateModule tmpDir bad case result of Left (ValidationError _ errs) -> @@ -195,7 +196,7 @@ let bad = goodModule & #steps - .~ [Step Template "README.md.tpl" "/etc/passwd" Nothing Nothing] + .~ [Step Template "README.md.tpl" "/etc/passwd" Nothing Nothing Managed] result <- validateModule tmpDir bad case result of Left (ValidationError _ errs) -> @@ -210,7 +211,7 @@ let dotted = goodModule & #steps - .~ [Step Template "README.md.tpl" "docs/README.v2.md" Nothing Nothing] + .~ [Step Template "README.md.tpl" "docs/README.v2.md" Nothing Nothing Managed] result <- validateModule tmpDir dotted case result of Right m -> (m ^. #name) `shouldBe` "test-module" @@ -223,7 +224,7 @@ let bad = goodModule & #steps - .~ [Step Template "README.md.tpl" "src/{{unknown}}/Main.hs" Nothing Nothing] + .~ [Step Template "README.md.tpl" "src/{{unknown}}/Main.hs" Nothing Nothing Managed] result <- validateModule tmpDir bad case result of Left (ValidationError _ errs) -> @@ -241,7 +242,7 @@ vars = [], exports = [VarExport {var = "missing", alias = Nothing}], prompts = [Prompt {var = "missing", text = "?", condition = Nothing, choices = Nothing}], - steps = [Step Template "nonexistent.tpl" "/bad/dest" Nothing Nothing], + steps = [Step Template "nonexistent.tpl" "/bad/dest" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, diff --git a/test/Seihou/Core/SeedSpec.hs b/test/Seihou/Core/SeedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/SeedSpec.hs @@ -0,0 +1,71 @@ +module Seihou.Core.SeedSpec (tests) where + +import Data.Either (isLeft) +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Time (UTCTime (..), fromGregorian) +import Seihou.Core.Module (checkSeedSteps) +import Seihou.Core.Seed +import Seihou.Core.Types +import Seihou.Dhall.Eval (evalModuleFromFile) +import Seihou.Manifest.Types +import Seihou.Prelude +import System.Directory (getCurrentDirectory) +import System.FilePath (takeDirectory) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "seed foundations" $ do + let now = UTCTime (fromGregorian 2026 10 15) 0 + first = SeedRecord "demo" (Set.singleton (ApplicationId "a")) SeedCreated now + second = SeedRecord "demo" (Set.singleton (ApplicationId "b")) SeedFoundExisting now + manifest = mergeSeedRecord "CHANGELOG.md" second (mergeSeedRecord "CHANGELOG.md" first (emptyManifest now)) + it "preserves the first settlement while merging owners" $ do + let Just receipt = Map.lookup "CHANGELOG.md" (manifest ^. #seeds) + receipt ^. #outcome `shouldBe` SeedCreated + receipt ^. #applicationIds `shouldBe` Set.fromList [ApplicationId "a", ApplicationId "b"] + it "releases only selected owners and drops the last claim" $ do + let one = dropSeedOwner (Set.singleton (ApplicationId "a")) "CHANGELOG.md" manifest + Map.size (one ^. #seeds) `shouldBe` 1 + Map.null (dropSeedOwner (Set.singleton (ApplicationId "b")) "CHANGELOG.md" one ^. #seeds) `shouldBe` True + it "round trips receipts without hashes or baselines" $ do + manifestFromJSON (manifestToJSON manifest) `shouldBe` Right manifest + it "rejects a managed/seed collision at decoding" $ do + let file = FileRecord (SHA256 "hash") "demo" Copy now Nothing Set.empty SharedWriteUnknown + invalid = manifest & #files .~ Map.singleton "CHANGELOG.md" file + validateManifestInvariants invalid `shouldBe` Left (PathBothManagedAndSeeded "CHANGELOG.md") + manifestFromJSON (manifestToJSON invalid) `shouldSatisfy` isLeft + it "keeps schema 7 unchanged and diagnoses seed information loss" $ do + let old = emptyManifest now & #version .~ ManifestSchemaVersion 7 + manifestFromJSON (manifestToJSON old) `shouldBe` Right old + it "reports facts an older schema cannot encode" $ do + manifestEncodingLoss (manifest & #version .~ ManifestSchemaVersion 7) `shouldSatisfy` (not . null) + it "decodes omitted lifecycle and rejects invalid lifecycle values" $ + withSystemTempDirectory "lifecycle" $ \dir -> do + cwd <- getCurrentDirectory + let schema = takeDirectory cwd "schema/package.dhall" + source field = + T.unlines + [ "let S = " <> T.pack schema, + "in S.Module::{ name = \"demo\", version = Some \"1.0\", steps = [S.Step::{ strategy = \"template\", src = \"a\", dest = \"b\"" <> field <> " }] }" + ] + TIO.writeFile (dir "module.dhall") (source "") + Right old <- evalModuleFromFile (dir "module.dhall") + map (^. #lifecycle) (old ^. #steps) `shouldBe` [Managed] + TIO.writeFile (dir "module.dhall") (source ", lifecycle = Some \"seed\"") + Right seed <- evalModuleFromFile (dir "module.dhall") + checkSeedSteps seed `shouldBe` [] + let patched = seed & #steps %~ map (#patch ?~ AppendFile) + checkSeedSteps patched `shouldSatisfy` (not . null) + checkSeedSteps (seed & #steps %~ map (#strategy .~ Structured)) `shouldSatisfy` (not . null) + checkSeedSteps (seed & #steps %~ (<> map (#lifecycle .~ Managed) (seed ^. #steps))) `shouldSatisfy` (not . null) + checkSeedSteps (seed & #removal ?~ Removal [RemovalStep RemoveFileAction "b" Nothing] []) `shouldSatisfy` (not . null) + TIO.writeFile (dir "module.dhall") (source ", lifecycle = Some \"sede\"") + invalid <- evalModuleFromFile (dir "module.dhall") + invalid `shouldSatisfy` isLeft diff --git a/test/Seihou/Core/StatusSpec.hs b/test/Seihou/Core/StatusSpec.hs --- a/test/Seihou/Core/StatusSpec.hs +++ b/test/Seihou/Core/StatusSpec.hs @@ -33,7 +33,7 @@ generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, - additiveOnly = False + sharedWriteMode = SharedWriteUnknown } runStatus :: PureFS -> Manifest -> [TrackedFile] @@ -49,7 +49,7 @@ ( (emptyManifest fixedTime :: Manifest) & #files .~ Map.singleton "README.md" (mkRecord content) ) - fs = PureFS (Map.singleton "README.md" content) mempty + fs = PureFS (Map.singleton "README.md" content) mempty Map.empty result = runStatus fs manifest length result `shouldBe` 1 ((head result) ^. #path) `shouldBe` "README.md" @@ -63,7 +63,7 @@ ( (emptyManifest fixedTime :: Manifest) & #files .~ Map.singleton "README.md" (mkRecord originalContent) ) - fs = PureFS (Map.singleton "README.md" modifiedContent) mempty + fs = PureFS (Map.singleton "README.md" modifiedContent) mempty Map.empty result = runStatus fs manifest length result `shouldBe` 1 ((head result) ^. #status) `shouldBe` TfsModified @@ -95,6 +95,7 @@ ] ) mempty + Map.empty result = runStatus fs manifest length result `shouldBe` 3 -- Results are sorted by path diff --git a/test/Seihou/Effect/FilesystemSpec.hs b/test/Seihou/Effect/FilesystemSpec.hs --- a/test/Seihou/Effect/FilesystemSpec.hs +++ b/test/Seihou/Effect/FilesystemSpec.hs @@ -48,7 +48,7 @@ exists `shouldBe` True it "copyFile copies content" $ do - let initial = PureFS (Map.singleton "src.txt" "source content") Set.empty + let initial = PureFS (Map.singleton "src.txt" "source content") Set.empty Map.empty (content, _) = runPure initial $ do copyFile "src.txt" "dest.txt" readFileText "dest.txt" diff --git a/test/Seihou/Effect/ManifestStoreSpec.hs b/test/Seihou/Effect/ManifestStoreSpec.hs --- a/test/Seihou/Effect/ManifestStoreSpec.hs +++ b/test/Seihou/Effect/ManifestStoreSpec.hs @@ -33,7 +33,7 @@ (emptyManifest fixedTime) & #modules .~ [AppliedModule (ModuleName "haskell-base") emptyParentVars (LocalOrigin "haskell-base") Nothing fixedTime Nothing] & #vars .~ Map.fromList [(VarName "project.name", "my-app")] - & #files .~ Map.fromList [("README.md", FileRecord (SHA256 "abc123") (ModuleName "haskell-base") Template fixedTime Nothing mempty False)] + & #files .~ Map.fromList [("README.md", FileRecord (SHA256 "abc123") (ModuleName "haskell-base") Template fixedTime Nothing mempty SharedWriteUnknown)] spec :: Spec spec = do @@ -88,7 +88,7 @@ runManifestStore manifestPath (writeManifest sampleManifest) c <- readFileText manifestPath pure ((), c) - T.isInfixOf "\"version\":6" content `shouldBe` True + T.isInfixOf "\"version\":9" content `shouldBe` True T.isInfixOf "haskell-base" content `shouldBe` True T.isInfixOf "my-app" content `shouldBe` True @@ -104,7 +104,7 @@ it "returns Left for corrupt JSON" $ do let manifestPath = ".seihou/manifest.json" - corruptFS = PureFS (Map.fromList [(manifestPath, "{ this is not json }")]) Set.empty + corruptFS = PureFS (Map.fromList [(manifestPath, "{ this is not json }")]) Set.empty Map.empty (result, _) = runPureEff $ runFilesystemPure corruptFS $ diff --git a/test/Seihou/Engine/BaselineSpec.hs b/test/Seihou/Engine/BaselineSpec.hs --- a/test/Seihou/Engine/BaselineSpec.hs +++ b/test/Seihou/Engine/BaselineSpec.hs @@ -38,9 +38,9 @@ generatedAt = fixedTime, baseline = Nothing, applicationIds = Set.singleton applicationId, - additiveOnly = False + sharedWriteMode = SharedWriteUnknown } - initialFS = PureFS (Map.singleton ("/project/" <> path) content) Set.empty + initialFS = PureFS (Map.singleton ("/project/" <> path) content) Set.empty Map.empty ((result, stored), _) = runPureEff $ runFilesystemPure initialFS $ @@ -57,10 +57,10 @@ Map.lookup expectedRef stored `shouldBe` Just content it "returns an error and publishes no reference when a generated file is missing" $ do - let record = FileRecord (hashContent "planned") "module" Template fixedTime Nothing Set.empty False + let record = FileRecord (hashContent "planned") "module" Template fixedTime Nothing Set.empty SharedWriteUnknown ((result, stored), _) = runPureEff $ - runFilesystemPure (PureFS Map.empty Set.empty) $ + runFilesystemPure (PureFS Map.empty Set.empty Map.empty) $ runBaselineStorePure Map.empty $ recordGeneratedBaselines "/project" (Map.singleton "missing.txt" record) result `shouldSatisfy` isStoreFailure @@ -68,8 +68,8 @@ it "stores content that can be read back through the baseline effect" $ do let content = "round trip" - record = FileRecord (hashContent content) "module" Copy fixedTime Nothing Set.empty False - initialFS = PureFS (Map.singleton "copy.txt" content) Set.empty + record = FileRecord (hashContent content) "module" Copy fixedTime Nothing Set.empty SharedWriteUnknown + initialFS = PureFS (Map.singleton "copy.txt" content) Set.empty Map.empty ((result, readBack), _) = runPureEff $ runFilesystemPure initialFS $ @@ -87,7 +87,7 @@ it "collects and deduplicates every referenced blob" $ do let first = baselineRefForContent "first" second = baselineRefForContent "second" - mkRecord ref = FileRecord (hashContent "applied") "module" Template fixedTime ref Set.empty False + mkRecord ref = FileRecord (hashContent "applied") "module" Template fixedTime ref Set.empty SharedWriteUnknown manifest :: Manifest manifest = ( (emptyManifest fixedTime) diff --git a/test/Seihou/Engine/CheckoutSpec.hs b/test/Seihou/Engine/CheckoutSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Engine/CheckoutSpec.hs @@ -0,0 +1,213 @@ +module Seihou.Engine.CheckoutSpec (tests) where + +import Control.Monad (forM_, when) +import Data.ByteString.Lazy qualified as LBS +import Data.Either (isLeft) +import Data.Generics.Labels () +import Data.IORef +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust) +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Text.IO qualified as TIO +import Data.Time (UTCTime (..), fromGregorian) +import Seihou.Core.Checkout +import Seihou.Core.Module (checkFileExistence, validateModule) +import Seihou.Core.Types +import Seihou.Dhall.Eval (evalModuleFromFile) +import Seihou.Effect.Filesystem +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.Process +import Seihou.Effect.ProcessInterp (runProcessIO) +import Seihou.Engine.Checkout +import Seihou.Engine.Plan (compilePlan) +import Seihou.Engine.Remove (CheckoutRemovalSelection (..), selectCheckoutRemoval) +import Seihou.Manifest.Types +import Seihou.Prelude +import System.Directory qualified as D +import System.Exit (ExitCode (..)) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (readProcessWithExitCode) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +fixtureManifest :: Manifest +fixtureManifest = emptyManifest now & #applications .~ [app] & #checkoutOutputs .~ Map.fromList [(dest, record source) | (dest, source) <- [(".local/config", "config/editor"), (".tool/assets", "assets/shared")]] + where + now = UTCTime (fromGregorian 2026 10 15) 0 + app = AppliedComposition (ApplicationId "a") (AppliedModuleTarget "demo") (LocalOrigin "demo") (Just "1") [] Nothing Nothing [AppliedInstanceState "demo" emptyParentVars (LocalOrigin "demo") (Just "1") Map.empty] Map.empty now + record source = CheckoutOutputRecord (DirectorySymlink source) (Map.singleton (ApplicationId "a") (Set.singleton "demo")) + +withFixture :: (FilePath -> IO a) -> IO a +withFixture action = withSystemTempDirectory "checkout-contract" $ \temp -> do + root <- D.canonicalizePath temp + (code, _, _) <- readProcessWithExitCode "git" ["-C", root, "init", "-q"] "" + code `shouldBe` ExitSuccess + forM_ ["config/editor", "assets/shared"] (D.createDirectoryIfMissing True . (root )) + TIO.writeFile (root ".gitignore") ".local/\n.tool/\n" + TIO.writeFile (root "config/editor/settings") "sentinel" + action root + +prepare root intent old new = runEff $ runFilesystem $ runProcessIO $ prepareCheckoutPlan intent SyncIgnoredOnly root old new [] + +apply root plan = runEff $ runFilesystem $ runProcessIO $ applyCheckoutPlan SyncIgnoredOnly root plan + +tests :: IO TestTree +tests = testSpec "checkout filesystem contract" $ do + it "requires application selection for ambiguous owners and preserves unselected claims" $ do + let [app] = fixtureManifest ^. #applications + second = app & #applicationId .~ ApplicationId "b" + shared = fixtureManifest & #applications .~ [app, second] & #checkoutOutputs %~ Map.map (#owners %~ Map.insert (ApplicationId "b") (Set.singleton "demo")) + selectCheckoutRemoval shared "demo" Nothing `shouldSatisfy` isLeft + Right (Just selected) <- pure (selectCheckoutRemoval shared "demo" (Just (ApplicationId "a"))) + let retained = selected ^. #candidateManifest + map (^. #applicationId) (retained ^. #applications) `shouldBe` [ApplicationId "b"] + map (Map.keys . (^. #owners)) (Map.elems (retained ^. #checkoutOutputs)) `shouldBe` [[ApplicationId "b"], [ApplicationId "b"]] + it "rejects native spelling aliases when the temporary volume is case-insensitive" $ withFixture $ \root -> do + insensitive <- D.doesDirectoryExist (root ".GIT") + when insensitive $ do + let aliased = fixtureManifest & #checkoutOutputs %~ Map.adjust (#spec .~ DirectorySymlink "config/Editor") ".local/config" + Right plan <- prepare root Rebuild aliased aliased + checkoutApplicable plan `shouldBe` False + concatMap (map (^. #code) . (^. #errors)) (plan ^. #entries) `shouldContain` ["checkout_native_alias"] + it "compiles project sources without an installed files source and validates rendered paths" $ withFixture $ \root -> do + let modul = Module "demo" (Just "1.0.0") Nothing [VarDecl "source" VTText Nothing Nothing True Nothing] [] [] [Step Symlink "{{source}}" ".local/config" Nothing Nothing Checkout] [] [] Nothing [] + checkFileExistence root modul `shouldReturn` [] + compiled <- compilePlan root modul (Map.singleton "source" (VText "config/editor")) + compiled `shouldBe` Right [CheckoutOutputOp ".local/config" (DirectorySymlink "config/editor") "demo"] + escaped <- compilePlan root modul (Map.singleton "source" (VText "../outside")) + escaped `shouldSatisfy` isLeft + invalid <- validateModule root (modul & #steps %~ map (#lifecycle .~ Managed)) + invalid `shouldSatisfy` isLeft + skipped <- compilePlan root (modul & #steps %~ map (#condition ?~ ExprLit False)) Map.empty + skipped `shouldBe` Right [] + it "traces only declared link writes and parent creation, with fixed read-only Git calls" $ withFixture $ \root -> do + Right plan <- prepare root Rebuild fixtureManifest fixtureManifest + writes <- newIORef [] + processes <- newIORef [] + applied <- runEff $ tracedFilesystem writes $ tracedProcess processes $ applyCheckoutPlan SyncIgnoredOnly root plan + applied ^. #failure `shouldBe` Nothing + actualWrites <- readIORef writes + Set.fromList actualWrites `shouldBe` Set.fromList [("mkdir", root ".local"), ("mkdir", root ".tool"), ("link", root ".local/config"), ("link", root ".tool/assets")] + actualProcesses <- readIORef processes + actualProcesses + `shouldSatisfy` all + ( \(cmd, args) -> + cmd == "git" && case args of + ["rev-parse", "--show-toplevel"] -> True + ["ls-files", "--cached", "-z"] -> True + ["check-ignore", "-q", "--", path] -> "./" `T.isPrefixOf` path + _ -> False + ) + it "creates portable links and converges without following their contents" $ withFixture $ \root -> do + Right plan <- prepare root Rebuild fixtureManifest fixtureManifest + map (^. #action) (plan ^. #entries) `shouldBe` [CreateLink, CreateLink] + result <- apply root plan + result ^. #failure `shouldBe` Nothing + D.getSymbolicLinkTarget (root ".local/config") `shouldReturn` "../config/editor" + TIO.readFile (root "config/editor/settings") `shouldReturn` "sentinel" + Right repeated <- prepare root Rebuild fixtureManifest fixtureManifest + map (^. #action) (repeated ^. #entries) `shouldBe` [UnchangedLink, UnchangedLink] + it "repairs dangling wrong links and leaves sentinel target bytes alone" $ withFixture $ \root -> do + D.createDirectoryIfMissing True (root ".local") + D.createDirectoryLink "../missing" (root ".local/config") + Right plan <- prepare root Rebuild fixtureManifest fixtureManifest + map (^. #action) (plan ^. #entries) `shouldBe` [ReplaceLink, CreateLink] + result <- apply root plan + result ^. #failure `shouldBe` Nothing + it "refuses every mutation when any destination is a real object" $ withFixture $ \root -> do + D.createDirectoryIfMissing True (root ".local/config") + TIO.writeFile (root ".local/config/sentinel") "keep" + Right plan <- prepare root Rebuild fixtureManifest fixtureManifest + checkoutApplicable plan `shouldBe` False + result <- apply root plan + result ^. #failure `shouldSatisfy` isJust + D.doesPathExist (root ".tool") `shouldReturn` False + TIO.readFile (root ".local/config/sentinel") `shouldReturn` "keep" + it "refuses symlink ancestors and missing sources" $ withFixture $ \root -> do + D.createDirectoryLink "assets" (root ".local") + Right plan <- prepare root Rebuild fixtureManifest fixtureManifest + checkoutApplicable plan `shouldBe` False + D.removeDirectoryLink (root ".local") + D.removeDirectory (root "assets/shared") + Right missing <- prepare root Rebuild fixtureManifest fixtureManifest + checkoutApplicable missing `shouldBe` False + it "protects ignored tracked paths even when absent on disk" $ withFixture $ \root -> do + D.createDirectoryIfMissing True (root ".local") + TIO.writeFile (root ".local/config") "tracked" + (code, _, _) <- readProcessWithExitCode "git" ["-C", root, "add", "-f", "--", ".local/config"] "" + code `shouldBe` ExitSuccess + D.removeFile (root ".local/config") + Right plan <- prepare root Rebuild fixtureManifest fixtureManifest + checkoutApplicable plan `shouldBe` False + concatMap (map (^. #code) . (^. #errors)) (plan ^. #entries) `shouldContain` ["checkout_path_tracked"] + it "reports unsupported symlink creation without copying source data" $ withFixture $ \root -> do + Right plan <- prepare root Rebuild fixtureManifest fixtureManifest + result <- runEff $ unsupportedLinks $ runProcessIO $ applyCheckoutPlan SyncIgnoredOnly root plan + result ^. #failure `shouldSatisfy` isJust + case result ^. #failure of + Just err -> err ^. #message `shouldSatisfy` T.isInfixOf "symlink permissions" + Nothing -> expectationFailure "expected a creation error" + D.doesPathExist (root ".local") `shouldReturn` False + TIO.readFile (root "config/editor/settings") `shouldReturn` "sentinel" + it "rolls back an ordinary mid-apply failure and supports retry" $ withFixture $ \root -> do + Right plan <- prepare root Rebuild fixtureManifest fixtureManifest + result <- runEff $ runFilesystem $ runProcessIO $ applyCheckoutPlanWithHook (\n -> when (n == 1) (liftIO (ioError (userError "injected")))) SyncIgnoredOnly root plan + result ^. #failure `shouldSatisfy` isJust + D.doesPathExist (root ".local") `shouldReturn` False + retried <- apply root plan + retried ^. #failure `shouldBe` Nothing + it "retires a dangling last-owner link without checking its source" $ withFixture $ \root -> do + Right first <- prepare root Rebuild fixtureManifest fixtureManifest + _ <- apply root first + D.removeFile (root "config/editor/settings") + D.removeDirectory (root "config/editor") + let candidate = fixtureManifest & #checkoutOutputs %~ Map.delete ".local/config" + Right retired <- prepare root Reconcile fixtureManifest candidate + map (^. #action) (retired ^. #entries) `shouldBe` [RetireLink, UnchangedLink] + result <- apply root retired + result ^. #failure `shouldBe` Nothing + D.pathIsSymbolicLink (root ".tool/assets") `shouldReturn` True + it "rejects unknown specs and bad owners at the byte decoding boundary" $ do + let bytes = manifestToJSON fixtureManifest + manifestFromJSON bytes `shouldBe` Right fixtureManifest + manifestFromJSON (replace "directory-symlink" "invented-kind" bytes) `shouldSatisfy` isLeft + manifestFromJSON (manifestToJSON (fixtureManifest & #applications .~ [])) `shouldSatisfy` isLeft + where + replace a b = LBS.fromStrict . TE.encodeUtf8 . T.replace a b . TE.decodeUtf8 . LBS.toStrict + +-- These first-order effects can be reissued in an isolated real interpreter. +-- The trace fails on any text read/write, copy, rename or recursive removal. +tracedFilesystem :: (IOE :> es) => IORef [(Text, FilePath)] -> Eff (Filesystem : es) a -> Eff es a +tracedFilesystem trace = interpret $ \_ operation -> do + case operation of + CreateDirectoryIfMissing _ path -> liftIO (modifyIORef' trace (("mkdir", path) :)) + CreateDirectoryLink _ path -> liftIO (modifyIORef' trace (("link", path) :)) + RemoveLink path -> liftIO (modifyIORef' trace (("unlink", path) :)) + InspectPath _ -> pure () + ListDirectory _ -> pure () + NormalizePath _ -> pure () + _ -> liftIO (ioError (userError "checkout attempted an unexpected filesystem effect")) + liftIO $ runEff $ runFilesystem $ reissue operation + +reissue :: Filesystem m a -> Eff '[Filesystem, IOE] a +reissue (CreateDirectoryIfMissing parents path) = createDirectoryIfMissing parents path +reissue (CreateDirectoryLink target path) = createLink target path +reissue (RemoveLink path) = removeLink path +reissue (InspectPath path) = inspectPath path +reissue (ListDirectory path) = listDirectory path +reissue (NormalizePath path) = normalizePath path +reissue (RemoveDirectoryIfEmpty path) = removeDirectoryIfEmpty path +reissue _ = liftIO (ioError (userError "unexpected filesystem effect")) + +tracedProcess :: (IOE :> es) => IORef [(Text, [Text])] -> Eff (Process : es) a -> Eff es a +tracedProcess trace = interpret $ \_ (RunProcess cmd args root) -> do + liftIO (modifyIORef' trace ((cmd, args) :)) + liftIO $ runEff $ runProcessIO $ runProcess cmd args root + +unsupportedLinks :: (IOE :> es) => Eff (Filesystem : es) a -> Eff es a +unsupportedLinks = interpret $ \_ operation -> case operation of + CreateDirectoryLink _ _ -> liftIO (ioError (userError "symlink creation unsupported")) + _ -> liftIO $ runEff $ runFilesystem $ reissue operation diff --git a/test/Seihou/Engine/DiffSpec.hs b/test/Seihou/Engine/DiffSpec.hs --- a/test/Seihou/Engine/DiffSpec.hs +++ b/test/Seihou/Engine/DiffSpec.hs @@ -41,7 +41,7 @@ generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, - additiveOnly = False + sharedWriteMode = SharedWriteUnknown } -- | Helper to create a manifest with file records (avoids ambiguous record update). @@ -57,6 +57,8 @@ applications = base ^. #applications, recipe = base ^. #recipe, blueprint = base ^. #blueprint, + seeds = base ^. #seeds, + checkoutOutputs = base ^. #checkoutOutputs, blueprintMigrations = base ^. #blueprintMigrations } @@ -75,7 +77,7 @@ it "classifies file in plan + on disk (not in manifest) as Conflict" $ do let manifest = emptyManifest fixedTime planned = [("README.md", "# Hello", modName, Nothing)] - fs = PureFS (Map.singleton "README.md" "existing content") mempty + fs = PureFS (Map.singleton "README.md" "existing content") mempty Map.empty result = runDiff fs manifest active planned length (result ^. #conflicts) `shouldBe` 1 ((head (result ^. #conflicts)) ^. #path) `shouldBe` "README.md" @@ -83,7 +85,7 @@ it "classifies patch op on existing file (not in manifest) as New, not Conflict" $ do let manifest = emptyManifest fixedTime planned = [(".gitignore", ".claude/\n", modName, Just AppendSection)] - fs = PureFS (Map.singleton ".gitignore" ".seihou/\n") mempty + fs = PureFS (Map.singleton ".gitignore" ".seihou/\n") mempty Map.empty result = runDiff fs manifest active planned length (result ^. #conflicts) `shouldBe` 0 length (result ^. #new) `shouldBe` 1 @@ -95,7 +97,7 @@ patchContent = "new section" manifest = manifestWithFiles (Map.singleton "config.txt" (mkRecord originalContent)) planned = [("config.txt", patchContent, modName, Just AppendSection)] - fs = PureFS (Map.singleton "config.txt" userContent) mempty + fs = PureFS (Map.singleton "config.txt" userContent) mempty Map.empty result = runDiff fs manifest active planned length (result ^. #conflicts) `shouldBe` 0 length (result ^. #modified) `shouldBe` 1 @@ -105,7 +107,7 @@ let content = "# Hello World" manifest = manifestWithFiles (Map.singleton "README.md" (mkRecord content)) planned = [("README.md", content, modName, Nothing)] - fs = PureFS (Map.singleton "README.md" content) mempty + fs = PureFS (Map.singleton "README.md" content) mempty Map.empty result = runDiff fs manifest active planned length (result ^. #unchanged) `shouldBe` 1 head (result ^. #unchanged) `shouldBe` "README.md" @@ -116,7 +118,7 @@ manifest = manifestWithFiles (Map.singleton "README.md" (mkRecord oldContent)) planned = [("README.md", newContent, modName, Nothing)] -- Disk matches manifest (user didn't touch it) - fs = PureFS (Map.singleton "README.md" oldContent) mempty + fs = PureFS (Map.singleton "README.md" oldContent) mempty Map.empty result = runDiff fs manifest active planned length (result ^. #modified) `shouldBe` 1 ((head (result ^. #modified)) ^. #path) `shouldBe` "README.md" @@ -129,7 +131,7 @@ manifest = manifestWithFiles (Map.singleton "README.md" (mkRecord originalContent)) planned = [("README.md", planContent, modName, Nothing)] -- Disk was modified by user (doesn't match manifest) - fs = PureFS (Map.singleton "README.md" userContent) mempty + fs = PureFS (Map.singleton "README.md" userContent) mempty Map.empty result = runDiff fs manifest active planned length (result ^. #conflicts) `shouldBe` 1 ((head (result ^. #conflicts)) ^. #path) `shouldBe` "README.md" @@ -142,7 +144,7 @@ & #files .~ Map.singleton "old-file.txt" (mkRecord content) ) planned = [] :: [(FilePath, Text, ModuleName, Maybe PatchOp)] -- module no longer produces this file - fs = PureFS (Map.singleton "old-file.txt" content) mempty + fs = PureFS (Map.singleton "old-file.txt" content) mempty Map.empty result = runDiff fs manifest active planned length (result ^. #orphaned) `shouldBe` 1 ((head (result ^. #orphaned)) ^. #path) `shouldBe` "old-file.txt" @@ -183,6 +185,7 @@ PureFS (Map.fromList [("unchanged.txt", existingContent), ("orphaned.txt", "orphan")]) mempty + Map.empty result = runDiff fs manifest active planned length (result ^. #new) `shouldBe` 1 length (result ^. #unchanged) `shouldBe` 1 @@ -210,12 +213,12 @@ generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, - additiveOnly = False + sharedWriteMode = SharedWriteUnknown } manifest = manifestWithFiles (Map.singleton "other.txt" record) planned = [("new.txt", "new content", modName, Nothing)] activeModules = Set.singleton modName -- "test-module", NOT "other-module" - fs = PureFS (Map.singleton "other.txt" content) mempty + fs = PureFS (Map.singleton "other.txt" content) mempty Map.empty result = runDiff fs manifest activeModules planned length (result ^. #orphaned) `shouldBe` 0 length (result ^. #new) `shouldBe` 1 @@ -225,7 +228,7 @@ manifest = manifestWithFiles (Map.singleton "old.txt" (mkRecord content)) planned = [("new.txt", "new content", modName, Nothing)] activeModules = Set.singleton modName -- file belongs to active module - fs = PureFS (Map.singleton "old.txt" content) mempty + fs = PureFS (Map.singleton "old.txt" content) mempty Map.empty result = runDiff fs manifest activeModules planned length (result ^. #orphaned) `shouldBe` 1 ((head (result ^. #orphaned)) ^. #path) `shouldBe` "old.txt" @@ -240,7 +243,7 @@ generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, - additiveOnly = False + sharedWriteMode = SharedWriteUnknown } manifest = manifestWithFiles @@ -256,6 +259,7 @@ PureFS (Map.fromList [("active-old.txt", "active old"), ("other.txt", "other content")]) mempty + Map.empty result = runDiff fs manifest activeModules planned -- active-old.txt is orphaned (active module no longer produces it) length (result ^. #orphaned) `shouldBe` 1 @@ -274,13 +278,13 @@ generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, - additiveOnly = False + sharedWriteMode = SharedWriteUnknown } manifest = manifestWithFiles (Map.singleton "shared.txt" otherRecord) -- active module wants to write to same path owned by inactive module planned = [("shared.txt", "new content from active", modName, Nothing)] activeModules = Set.singleton modName - fs = PureFS (Map.singleton "shared.txt" "other content") mempty + fs = PureFS (Map.singleton "shared.txt" "other content") mempty Map.empty result = runDiff fs manifest activeModules planned -- File exists on disk but not in active manifest → Conflict length (result ^. #conflicts) `shouldBe` 1 @@ -298,7 +302,7 @@ generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, - additiveOnly = False + sharedWriteMode = SharedWriteUnknown } manifest = manifestWithFiles @@ -320,6 +324,7 @@ ] ) mempty + Map.empty result = runDiff fs manifest activeModules planned -- from-a.txt unchanged (active, still produced) length (result ^. #unchanged) `shouldBe` 1 diff --git a/test/Seihou/Engine/ExecuteSpec.hs b/test/Seihou/Engine/ExecuteSpec.hs --- a/test/Seihou/Engine/ExecuteSpec.hs +++ b/test/Seihou/Engine/ExecuteSpec.hs @@ -95,7 +95,7 @@ Map.size records `shouldBe` 0 it "handles CopyFileOp by reading source and writing dest" $ do - let initial = PureFS (Map.singleton "/source/file.txt" "copied content") mempty + let initial = PureFS (Map.singleton "/source/file.txt" "copied content") mempty Map.empty ops = [CopyFileOp "/source/file.txt" "dest.txt"] (records, fs) = runExecFS initial ops Map.member "dest.txt" records `shouldBe` True @@ -126,7 +126,7 @@ (record ^. #strategy) `shouldBe` Structured it "executes PatchFileOp AppendFile on existing file" $ do - let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty + let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty Map.empty ops = [PatchFileOp "README.md" "extra line\n" AppendFile Template modName] (records, fs) = runExecFS initial ops Map.member "README.md" records `shouldBe` True @@ -135,7 +135,7 @@ T.isInfixOf "extra line" content `shouldBe` True it "executes PatchFileOp PrependFile on existing file" $ do - let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty + let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty Map.empty ops = [PatchFileOp "README.md" "header\n" PrependFile Template modName] (records, fs) = runExecFS initial ops Map.member "README.md" records `shouldBe` True @@ -144,7 +144,7 @@ T.isInfixOf "# Title" content `shouldBe` True it "executes PatchFileOp AppendSection with section markers" $ do - let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty + let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty Map.empty ops = [PatchFileOp "README.md" "section content\n" AppendSection Template modName] (records, fs) = runExecFS initial ops Map.member "README.md" records `shouldBe` True @@ -161,7 +161,7 @@ T.isInfixOf "new content" content `shouldBe` True it "executes PatchFileOp AppendLineIfAbsent, skipping existing lines" $ do - let initial = PureFS (Map.singleton "/project/.gitignore" "node_modules/\n.env\n") mempty + let initial = PureFS (Map.singleton "/project/.gitignore" "node_modules/\n.env\n") mempty Map.empty ops = [PatchFileOp ".gitignore" ".env\n.claude/\n" AppendLineIfAbsent Template modName] (records, fs) = runExecFS initial ops Map.member ".gitignore" records `shouldBe` True @@ -169,42 +169,42 @@ content `shouldBe` "node_modules/\n.env\n.claude/\n" it "executes PatchFileOp AppendLineIfAbsent idempotently" $ do - let initial = PureFS (Map.singleton "/project/.gitignore" "node_modules/\n.claude/\n") mempty + let initial = PureFS (Map.singleton "/project/.gitignore" "node_modules/\n.claude/\n") mempty Map.empty ops = [PatchFileOp ".gitignore" ".claude/\n" AppendLineIfAbsent Template modName] (records, fs) = runExecFS initial ops Map.member ".gitignore" records `shouldBe` True let content = (fs ^. #files) Map.! "/project/.gitignore" content `shouldBe` "node_modules/\n.claude/\n" - describe "executePlan additiveOnly" $ do + describe "executePlan sharedWriteMode" $ do it "records an additive patch as additive-only" $ do let ops = [PatchFileOp ".gitignore" "/result\n" AppendLineIfAbsent Template modName] (records, _) = runExecFS emptyFS ops - ((records Map.! ".gitignore") ^. #additiveOnly) `shouldBe` True + ((records Map.! ".gitignore") ^. #sharedWriteMode) `shouldBe` SharedWriteAdditiveOnly it "records an appended section as additive-only" $ do let ops = [PatchFileOp ".gitignore" "/dist\n" AppendSection Template modName] (records, _) = runExecFS emptyFS ops - ((records Map.! ".gitignore") ^. #additiveOnly) `shouldBe` True + ((records Map.! ".gitignore") ^. #sharedWriteMode) `shouldBe` SharedWriteAdditiveOnly it "does not record a position-dependent patch as additive-only" $ do -- AppendFile and PrependFile place bytes relative to whatever is -- already in the file, so replaying one owner can reorder the result. let appendOps = [PatchFileOp "notes.md" "tail\n" AppendFile Template modName] prependOps = [PatchFileOp "notes.md" "head\n" PrependFile Template modName] - ((fst (runExecFS emptyFS appendOps) Map.! "notes.md") ^. #additiveOnly) `shouldBe` False - ((fst (runExecFS emptyFS prependOps) Map.! "notes.md") ^. #additiveOnly) `shouldBe` False + ((fst (runExecFS emptyFS appendOps) Map.! "notes.md") ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure + ((fst (runExecFS emptyFS prependOps) Map.! "notes.md") ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure it "does not record a whole-file write as additive-only" $ do let ops = [WriteFileOp "README.md" "# Title\n" Template] (records, _) = runExecFS emptyFS ops - ((records Map.! "README.md") ^. #additiveOnly) `shouldBe` False + ((records Map.! "README.md") ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure it "does not record a copied file as additive-only" $ do - let initial = PureFS (Map.singleton "/source/file.txt" "copied") mempty + let initial = PureFS (Map.singleton "/source/file.txt" "copied") mempty Map.empty ops = [CopyFileOp "/source/file.txt" "dest.txt"] (records, _) = runExecFS initial ops - ((records Map.! "dest.txt") ^. #additiveOnly) `shouldBe` False + ((records Map.! "dest.txt") ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure it "folds the flag across every operation targeting one destination" $ do -- A path this module both writes and patches is not additive-only, and @@ -214,7 +214,7 @@ PatchFileOp ".gitignore" "/result\n" AppendLineIfAbsent Template modName ] (records, _) = runExecFS emptyFS ops - ((records Map.! ".gitignore") ^. #additiveOnly) `shouldBe` False + ((records Map.! ".gitignore") ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure it "keeps one destination's write mode out of another's record" $ do let ops = @@ -222,8 +222,8 @@ PatchFileOp ".gitignore" "/result\n" AppendLineIfAbsent Template modName ] (records, _) = runExecFS emptyFS ops - ((records Map.! "README.md") ^. #additiveOnly) `shouldBe` False - ((records Map.! ".gitignore") ^. #additiveOnly) `shouldBe` True + ((records Map.! "README.md") ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure + ((records Map.! ".gitignore") ^. #sharedWriteMode) `shouldBe` SharedWriteAdditiveOnly describe "dryRunPlan" $ do it "formats WriteFileOp" $ do diff --git a/test/Seihou/Engine/MigrateSpec.hs b/test/Seihou/Engine/MigrateSpec.hs --- a/test/Seihou/Engine/MigrateSpec.hs +++ b/test/Seihou/Engine/MigrateSpec.hs @@ -58,11 +58,11 @@ mkManifest entries = (emptyManifest fixedTime) & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin "demo", moduleVersion = Just "1.0.0", appliedAt = fixedTime, removal = Nothing}] - & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}) | (path, content) <- entries] + & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, sharedWriteMode = SharedWriteUnknown}) | (path, content) <- entries] -- | Build an in-memory filesystem from (path, content) pairs. mkFS :: [(FilePath, Text)] -> PureFS -mkFS entries = PureFS (Map.fromList entries) Set.empty +mkFS entries = PureFS (Map.fromList entries) Set.empty Map.empty -- | Single-step plan wrapping the supplied ops. chain1 :: Text -> Text -> [MigrationOp] -> MigrationPlan diff --git a/test/Seihou/Engine/PlanSpec.hs b/test/Seihou/Engine/PlanSpec.hs --- a/test/Seihou/Engine/PlanSpec.hs +++ b/test/Seihou/Engine/PlanSpec.hs @@ -60,7 +60,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -82,7 +82,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Template "hello.tpl" "hello.txt" Nothing Nothing], + steps = [Step Template "hello.tpl" "hello.txt" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -104,7 +104,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Copy "data.txt" "data.txt" (Just (ExprLit False)) Nothing], + steps = [Step Copy "data.txt" "data.txt" (Just (ExprLit False)) Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -126,7 +126,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Copy "data.txt" "data.txt" (Just (ExprLit True)) Nothing], + steps = [Step Copy "data.txt" "data.txt" (Just (ExprLit True)) Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -148,7 +148,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Copy "LICENSE" "LICENSE" (Just (ExprIsSet "license")) Nothing], + steps = [Step Copy "LICENSE" "LICENSE" (Just (ExprIsSet "license")) Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -177,7 +177,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Template "pkg.cabal.tpl" "{{name}}.cabal" Nothing Nothing], + steps = [Step Template "pkg.cabal.tpl" "{{name}}.cabal" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -199,7 +199,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Template "README.md.tpl" "{{project.name}}/README.md" Nothing Nothing], + steps = [Step Template "README.md.tpl" "{{project.name}}/README.md" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -224,7 +224,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Template "README.md.tpl" "{{project.name}}/README.md" Nothing Nothing], + steps = [Step Template "README.md.tpl" "{{project.name}}/README.md" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -249,7 +249,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Template "README.md.tpl" "docs/README.v2.md" Nothing Nothing], + steps = [Step Template "README.md.tpl" "docs/README.v2.md" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -271,7 +271,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Template "Lib.hs.tpl" "src/Lib.hs" Nothing Nothing], + steps = [Step Template "Lib.hs.tpl" "src/Lib.hs" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -295,8 +295,8 @@ exports = [], prompts = [], steps = - [ Step Template "A.hs.tpl" "src/A.hs" Nothing Nothing, - Step Template "B.hs.tpl" "src/B.hs" Nothing Nothing + [ Step Template "A.hs.tpl" "src/A.hs" Nothing Nothing Managed, + Step Template "B.hs.tpl" "src/B.hs" Nothing Nothing Managed ], commands = [], dependencies = [], @@ -324,7 +324,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Template "hello.tpl" "hello.txt" Nothing Nothing], + steps = [Step Template "hello.tpl" "hello.txt" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -348,7 +348,7 @@ vars = [], exports = [], prompts = [], - steps = [Step DhallText "greeting.dhall" "greeting.txt" Nothing Nothing], + steps = [Step DhallText "greeting.dhall" "greeting.txt" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -374,7 +374,7 @@ vars = [], exports = [], prompts = [], - steps = [Step DhallText "pkg.dhall" "pkg.txt" Nothing Nothing], + steps = [Step DhallText "pkg.dhall" "pkg.txt" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -396,7 +396,7 @@ vars = [], exports = [], prompts = [], - steps = [Step DhallText "bad.dhall" "out.txt" Nothing Nothing], + steps = [Step DhallText "bad.dhall" "out.txt" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -420,7 +420,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Structured "data.json.gen" "data.json" Nothing Nothing], + steps = [Step Structured "data.json.gen" "data.json" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -451,7 +451,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Structured "config.yaml.gen" "config.yaml" Nothing Nothing], + steps = [Step Structured "config.yaml.gen" "config.yaml" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -483,7 +483,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Structured "bad.gen" "out.json" Nothing Nothing], + steps = [Step Structured "bad.gen" "out.json" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -507,7 +507,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Structured "data.gen" "output.txt" Nothing Nothing], + steps = [Step Structured "data.gen" "output.txt" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -572,7 +572,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Template "section.tpl" "README.md" Nothing (Just AppendFile)], + steps = [Step Template "section.tpl" "README.md" Nothing (Just AppendFile) Managed], commands = [], dependencies = [], removal = Nothing, @@ -595,7 +595,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Template "section.tpl" "README.md" Nothing (Just AppendSection)], + steps = [Step Template "section.tpl" "README.md" Nothing (Just AppendSection) Managed], commands = [], dependencies = [], removal = Nothing, @@ -619,7 +619,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Template "conditional.tpl" "out.txt" Nothing Nothing], + steps = [Step Template "conditional.tpl" "out.txt" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -643,7 +643,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Template "conditional.tpl" "out.txt" Nothing Nothing], + steps = [Step Template "conditional.tpl" "out.txt" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -667,7 +667,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Template "patch.tpl" "README.md" Nothing (Just AppendFile)], + steps = [Step Template "patch.tpl" "README.md" Nothing (Just AppendFile) Managed], commands = [], dependencies = [], removal = Nothing, @@ -691,7 +691,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Copy "header.txt" "out.txt" Nothing (Just PrependFile)], + steps = [Step Copy "header.txt" "out.txt" Nothing (Just PrependFile) Managed], commands = [], dependencies = [], removal = Nothing, @@ -714,7 +714,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Structured "data.gen" "data.json" Nothing (Just AppendFile)], + steps = [Step Structured "data.gen" "data.json" Nothing (Just AppendFile) Managed], commands = [], dependencies = [], removal = Nothing, @@ -738,7 +738,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed], commands = [Command "echo hello" Nothing Nothing], dependencies = [], removal = Nothing, @@ -791,7 +791,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed], commands = [Command "echo skip" Nothing (Just (ExprLit False))], dependencies = [], removal = Nothing, @@ -815,7 +815,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed], commands = [Command "echo yes" Nothing (Just (ExprIsSet "name"))], dependencies = [], removal = Nothing, @@ -839,7 +839,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed], commands = [Command "echo post" Nothing Nothing], dependencies = [], removal = Nothing, @@ -872,7 +872,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed], commands = [Command "npm install" (Just "subdir") Nothing], dependencies = [], removal = Nothing, @@ -897,7 +897,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed], commands = [Command "echo {{name}}" Nothing Nothing], dependencies = [], removal = Nothing, @@ -922,7 +922,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed], commands = [Command "cabal build" (Just "{{name}}") Nothing], dependencies = [], removal = Nothing, @@ -972,7 +972,7 @@ vars = [], exports = [], prompts = [], - steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed], commands = [Command "echo {{missing}}" Nothing Nothing], dependencies = [], removal = Nothing, diff --git a/test/Seihou/Engine/ReconcileSpec.hs b/test/Seihou/Engine/ReconcileSpec.hs --- a/test/Seihou/Engine/ReconcileSpec.hs +++ b/test/Seihou/Engine/ReconcileSpec.hs @@ -352,6 +352,8 @@ applications = manifest ^. #applications, recipe = manifest ^. #recipe, blueprint = manifest ^. #blueprint, + seeds = manifest ^. #seeds, + checkoutOutputs = manifest ^. #checkoutOutputs, blueprintMigrations = manifest ^. #blueprintMigrations } @@ -364,7 +366,7 @@ generatedAt = fixedTime, baseline = baseline, applicationIds = Set.fromList owners', - additiveOnly = False + sharedWriteMode = SharedWriteUnknown } -- | A record for a path every owner reaches through an additive patch. @@ -377,7 +379,7 @@ generatedAt = fixedTime, baseline = baseline, applicationIds = Set.fromList owners', - additiveOnly = True + sharedWriteMode = SharedWriteAdditiveOnly } owners :: FilePath -> [ApplicationId] -> Map.Map FilePath DesiredFileOwner diff --git a/test/Seihou/Engine/RemoveSpec.hs b/test/Seihou/Engine/RemoveSpec.hs --- a/test/Seihou/Engine/RemoveSpec.hs +++ b/test/Seihou/Engine/RemoveSpec.hs @@ -36,18 +36,18 @@ mkManifest isRemovable fileContents = (emptyManifest fixedTime) & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin "test-module", moduleVersion = Nothing, appliedAt = fixedTime, removal = if isRemovable then Just (Removal [] []) else Nothing}] - & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}) | (path, content) <- fileContents] + & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, sharedWriteMode = SharedWriteUnknown}) | (path, content) <- fileContents] -- | Helper: create a manifest with a specific removal spec. mkManifestWithRemoval :: Removal -> [(FilePath, Text)] -> Manifest mkManifestWithRemoval removal fileContents = (emptyManifest fixedTime) & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin "test-module", moduleVersion = Nothing, appliedAt = fixedTime, removal = Just removal}] - & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}) | (path, content) <- fileContents] + & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, sharedWriteMode = SharedWriteUnknown}) | (path, content) <- fileContents] -- | Helper: create a PureFS with files. mkFS :: [(FilePath, Text)] -> PureFS -mkFS fileContents = PureFS (Map.fromList fileContents) Set.empty +mkFS fileContents = PureFS (Map.fromList fileContents) Set.empty Map.empty -- | Run computeRemovalPlan in the pure filesystem. runPlan :: PureFS -> Manifest -> ModuleName -> Either RemovalError RemovalPlan @@ -158,7 +158,7 @@ it "preserves files from other modules in manifest" $ do let base = mkManifest True [("mine.txt", "mine")] - otherRec = FileRecord (hashContent "other") otherMod Template fixedTime Nothing mempty False + otherRec = FileRecord (hashContent "other") otherMod Template fixedTime Nothing mempty SharedWriteUnknown manifest = Manifest { version = base ^. #version, @@ -169,6 +169,8 @@ applications = base ^. #applications, recipe = base ^. #recipe, blueprint = base ^. #blueprint, + seeds = base ^. #seeds, + checkoutOutputs = base ^. #checkoutOutputs, blueprintMigrations = base ^. #blueprintMigrations } fs = mkFS [("mine.txt", "mine"), ("other.txt", "other")] @@ -341,7 +343,7 @@ it "preserves other modules' files in manifest" $ do let base = mkManifest True [("mine.txt", "mine")] - otherRec = FileRecord (hashContent "other") otherMod Template fixedTime Nothing mempty False + otherRec = FileRecord (hashContent "other") otherMod Template fixedTime Nothing mempty SharedWriteUnknown manifest = Manifest { version = base ^. #version, @@ -352,6 +354,8 @@ applications = base ^. #applications, recipe = base ^. #recipe, blueprint = base ^. #blueprint, + seeds = base ^. #seeds, + checkoutOutputs = base ^. #checkoutOutputs, blueprintMigrations = base ^. #blueprintMigrations } fs = mkFS [("mine.txt", "mine"), ("other.txt", "other")] diff --git a/test/Seihou/Engine/UpdateTransactionSpec.hs b/test/Seihou/Engine/UpdateTransactionSpec.hs --- a/test/Seihou/Engine/UpdateTransactionSpec.hs +++ b/test/Seihou/Engine/UpdateTransactionSpec.hs @@ -3,6 +3,8 @@ import Control.Exception (throwIO) import Control.Lens ((&), (.~), (^.)) import Control.Monad (unless, when) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap import Data.ByteString.Lazy qualified as LBS import Data.Foldable (traverse_) import Data.Generics.Labels () @@ -34,6 +36,44 @@ spec :: Spec spec = do + describe "literal symlink journal snapshots" $ do + it "restores a dangling target without traversing it" $ withSystemTempDirectory "checkout-journal" $ \root -> do + Directory.createDirectoryLink "missing-old-target" (root "local-link") + Right transaction <- beginUpdateTransaction root (Set.singleton "local-link") + Directory.removeDirectoryLink (root "local-link") + Directory.createDirectoryLink "missing-new-target" (root "local-link") + restored <- recoverIncompleteTransactions root + restored `shouldBe` [Right ()] + Directory.getSymbolicLinkTarget (root "local-link") `shouldReturn` "missing-old-target" + it "retains the version-1 regular-file recovery contract" $ withSystemTempDirectory "legacy-journal" $ \root -> do + TIO.writeFile (root "managed.txt") "before" + Right transaction <- beginUpdateTransaction root (Set.singleton "managed.txt") + let journal = transaction ^. #transactionDirectory "journal.json" + Right (Aeson.Object object) <- Aeson.eitherDecode <$> LBS.readFile journal + let stripEntry (Aeson.Object fields) = Aeson.Object (KeyMap.delete "kind" (KeyMap.delete "target" fields)) + stripEntry other = other + legacy = KeyMap.mapWithKey (\key value -> case (key, value) of ("version", _) -> Aeson.Number 1; ("entries", Aeson.Array values) -> Aeson.Array (fmap stripEntry values); _ -> value) object + LBS.writeFile journal (Aeson.encode (Aeson.Object legacy)) + TIO.writeFile (root "managed.txt") "after" + recoverIncompleteTransactions root `shouldReturn` [Right ()] + TIO.readFile (root "managed.txt") `shouldReturn` "before" + it "rejects an unknown version-2 kind before recovery writes" $ withSystemTempDirectory "unknown-journal" $ \root -> do + TIO.writeFile (root "managed.txt") "before" + Right transaction <- beginUpdateTransaction root (Set.singleton "managed.txt") + let journal = transaction ^. #transactionDirectory "journal.json" + bytes <- TIO.readFile journal + TIO.writeFile journal (T.replace "\"kind\":\"file\"" "\"kind\":\"unknown\"" bytes) + TIO.writeFile (root "managed.txt") "after" + restored <- rollbackUpdateTransaction transaction + restored `shouldSatisfy` \case Left TransactionJournalMalformed {} -> True; _ -> False + TIO.readFile (root "managed.txt") `shouldReturn` "after" + it "removes a newly created dangling link when restoring an absent snapshot" $ withSystemTempDirectory "checkout-journal" $ \root -> do + Right transaction <- beginUpdateTransaction root (Set.singleton "local-link") + Directory.createDirectoryLink "missing-target" (root "local-link") + restored <- rollbackUpdateTransaction transaction + restored `shouldBe` Right () + Directory.listDirectory root `shouldReturn` [".seihou"] + describe "applyReconciliation" $ do it "writes resolved files and updates baselines, hashes, ownership, and orphans" $ withSystemTempDirectory "seihou-update-transaction" $ \projectRoot -> do @@ -191,7 +231,7 @@ -- A targeted update plans only the applications it selected, so for a -- co-owned path the reconciliation result describes a subset of the -- owners. Everything belonging to an unselected owner must survive. - let coOwned additive = + let coOwned mode = ( ( fileRecord "/dist\n" (Just (baselineRefForContent "/dist\n")) [appA, appB] & #moduleName .~ "co-owner" @@ -199,8 +239,8 @@ & #strategy .~ DhallText ) - & #additiveOnly - .~ additive + & #sharedWriteMode + .~ mode alphaOnly additive = (desiredFile ".gitignore" "/dist\n/result\n" [appA] & #moduleName .~ "alpha") & #additiveOnly @@ -223,38 +263,42 @@ pure ((candidate ^. #files) Map.! ".gitignore") it "keeps an unselected co-owner in the record" $ do - record <- runPartial (Set.singleton appA) (coOwned True) (alphaOnly True) + record <- runPartial (Set.singleton appA) (coOwned SharedWriteAdditiveOnly) (alphaOnly True) (record ^. #applicationIds) `shouldBe` Set.fromList [appA, appB] it "keeps the prior attribution when an unselected co-owner survives" $ do - record <- runPartial (Set.singleton appA) (coOwned True) (alphaOnly True) + record <- runPartial (Set.singleton appA) (coOwned SharedWriteAdditiveOnly) (alphaOnly True) (record ^. #moduleName) `shouldBe` "co-owner" (record ^. #strategy) `shouldBe` DhallText - it "keeps additiveOnly true when both the prior record and the candidate agree" $ do - record <- runPartial (Set.singleton appA) (coOwned True) (alphaOnly True) - (record ^. #additiveOnly) `shouldBe` True + it "keeps additive-only when both the prior record and the candidate agree" $ do + record <- runPartial (Set.singleton appA) (coOwned SharedWriteAdditiveOnly) (alphaOnly True) + (record ^. #sharedWriteMode) `shouldBe` SharedWriteAdditiveOnly - it "cannot strengthen additiveOnly from a partial update" $ do - -- The prior False may have been set because the unselected co-owner - -- writes the whole file. This run has no evidence about that owner, so - -- flipping the flag open here would let a later update through unsafely. - record <- runPartial (Set.singleton appA) (coOwned False) (alphaOnly True) - (record ^. #additiveOnly) `shouldBe` False + it "cannot strengthen a closure requirement from a partial update" $ do + -- The unselected co-owner may write the whole file. This run has no + -- evidence about that owner, so opening the gate here would let a later + -- update through unsafely. + record <- runPartial (Set.singleton appA) (coOwned SharedWriteRequiresOwnershipClosure) (alphaOnly True) + (record ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure - it "weakens additiveOnly when the candidate is no longer additive" $ do - record <- runPartial (Set.singleton appA) (coOwned True) (alphaOnly False) - (record ^. #additiveOnly) `shouldBe` False + it "keeps unknown evidence unknown from a partial update" $ do + record <- runPartial (Set.singleton appA) (coOwned SharedWriteUnknown) (alphaOnly True) + (record ^. #sharedWriteMode) `shouldBe` SharedWriteUnknown + it "records a closure requirement when the candidate is no longer additive" $ do + record <- runPartial (Set.singleton appA) (coOwned SharedWriteAdditiveOnly) (alphaOnly False) + (record ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure + it "re-credits the path and trusts the candidate once every owner is selected" $ do -- Subtracting the selection rather than the desired set matters here: -- appA stopped writing the path but was part of this update, so it -- genuinely loses ownership and the candidate's own answer stands. - record <- runPartial (Set.fromList [appA, appB]) (coOwned False) (alphaOnly True) + record <- runPartial (Set.fromList [appA, appB]) (coOwned SharedWriteUnknown) (alphaOnly True) (record ^. #applicationIds) `shouldBe` Set.singleton appA (record ^. #moduleName) `shouldBe` "alpha" (record ^. #strategy) `shouldBe` Template - (record ^. #additiveOnly) `shouldBe` True + (record ^. #sharedWriteMode) `shouldBe` SharedWriteAdditiveOnly describe "rollback and recovery" $ do it "rolls every earlier mutation back after an injected failure" $ @@ -350,6 +394,8 @@ applications = candidate ^. #applications, recipe = candidate ^. #recipe, blueprint = candidate ^. #blueprint, + seeds = candidate ^. #seeds, + checkoutOutputs = candidate ^. #checkoutOutputs, blueprintMigrations = candidate ^. #blueprintMigrations } setUpdateTransactionExpectedManifest transaction finalManifest `shouldReturn` Right () @@ -446,6 +492,8 @@ applications = manifest ^. #applications, recipe = manifest ^. #recipe, blueprint = manifest ^. #blueprint, + seeds = manifest ^. #seeds, + checkoutOutputs = manifest ^. #checkoutOutputs, blueprintMigrations = manifest ^. #blueprintMigrations } @@ -458,7 +506,7 @@ generatedAt = fixedTime, baseline = baseline, applicationIds = Set.fromList owners, - additiveOnly = False + sharedWriteMode = SharedWriteUnknown } desiredFile :: FilePath -> Text -> [ApplicationId] -> DesiredFile diff --git a/test/Seihou/Engine/ValidateSpec.hs b/test/Seihou/Engine/ValidateSpec.hs --- a/test/Seihou/Engine/ValidateSpec.hs +++ b/test/Seihou/Engine/ValidateSpec.hs @@ -40,7 +40,8 @@ src = "README.md.tpl", dest = "README.md", condition = Nothing, - patch = Nothing + patch = Nothing, + lifecycle = Managed } ], commands = [], @@ -62,7 +63,7 @@ ], exports = [VarExport {var = "nonexistent", alias = Nothing}], prompts = [Prompt {var = "undeclared", text = "?", condition = Nothing, choices = Nothing}], - steps = [Step Template "missing.tpl" "/absolute/path" Nothing Nothing], + steps = [Step Template "missing.tpl" "/absolute/path" Nothing Nothing Managed], commands = [], dependencies = [], removal = Nothing, @@ -222,8 +223,8 @@ writeFile (tmpDir "files" "b.tpl") "stub" let m = withSteps - [ Step Template "a.tpl" "out.txt" Nothing Nothing, - Step Template "b.tpl" "out.txt" Nothing Nothing + [ Step Template "a.tpl" "out.txt" Nothing Nothing Managed, + Step Template "b.tpl" "out.txt" Nothing Nothing Managed ] goodModule report <- buildReport True tmpDir m @@ -236,8 +237,8 @@ writeFile (tmpDir "files" "b.tpl") "stub" let m = withSteps - [ Step Template "a.tpl" "out.txt" Nothing Nothing, - Step Template "b.tpl" "out.txt" Nothing (Just AppendFile) + [ Step Template "a.tpl" "out.txt" Nothing Nothing Managed, + Step Template "b.tpl" "out.txt" Nothing (Just AppendFile) Managed ] goodModule report <- buildReport True tmpDir m @@ -281,7 +282,7 @@ ] stepWithCondition cond = withSteps - [Step Template "README.md.tpl" "README.md" cond Nothing] + [Step Template "README.md.tpl" "README.md" cond Nothing Managed] (withVars baseVars goodModule) it "flags a bool variable compared against a string literal in a when clause" $ do diff --git a/test/Seihou/Integration/ExecutionSpec.hs b/test/Seihou/Integration/ExecutionSpec.hs --- a/test/Seihou/Integration/ExecutionSpec.hs +++ b/test/Seihou/Integration/ExecutionSpec.hs @@ -68,6 +68,8 @@ applications = base ^. #applications, recipe = base ^. #recipe, blueprint = base ^. #blueprint, + seeds = base ^. #seeds, + checkoutOutputs = base ^. #checkoutOutputs, blueprintMigrations = base ^. #blueprintMigrations } @@ -170,7 +172,7 @@ executePlan "" ops Map.empty modName fixedTime manifest = manifestWithFiles fixedTime records -- Simulate user editing README.md - fs2 = PureFS (Map.insert "README.md" "user edit" (fs1 ^. #files)) (fs1 ^. #dirs) + fs2 = PureFS (Map.insert "README.md" "user edit" (fs1 ^. #files)) (fs1 ^. #dirs) Map.empty -- Compute diff → should detect conflict (diff, _) = runPureEff $ diff --git a/test/Seihou/Integration/GenerationSpec.hs b/test/Seihou/Integration/GenerationSpec.hs --- a/test/Seihou/Integration/GenerationSpec.hs +++ b/test/Seihou/Integration/GenerationSpec.hs @@ -98,7 +98,7 @@ -- Provide all vars but use an empty var map for IsSet evaluation. -- The real scenario: license has a default so it's always set. -- To test the conditional, we use a stripped-down module with only the LICENSE step. - let licenseStep = Step Copy "LICENSE" "LICENSE" (Just (ExprIsSet "license")) Nothing + let licenseStep = Step Copy "LICENSE" "LICENSE" (Just (ExprIsSet "license")) Nothing Managed smallModule = modul & #steps .~ [licenseStep] vars = Map.empty -- no license variable set planResult <- compilePlan (fixtures "haskell-base") smallModule vars diff --git a/test/Seihou/Manifest/TypesSpec.hs b/test/Seihou/Manifest/TypesSpec.hs --- a/test/Seihou/Manifest/TypesSpec.hs +++ b/test/Seihou/Manifest/TypesSpec.hs @@ -50,7 +50,7 @@ -- | Helper to set modules on a Manifest without ambiguous record update. withManifestModules :: [AppliedModule] -> Manifest -> Manifest withManifestModules mods m = - Manifest (m ^. #version) (m ^. #genAt) mods (m ^. #vars) (m ^. #files) (m ^. #applications) (m ^. #recipe) (m ^. #blueprint) (m ^. #blueprintMigrations) + Manifest (m ^. #version) (m ^. #genAt) mods (m ^. #vars) (m ^. #files) (m ^. #seeds) (m ^. #checkoutOutputs) (m ^. #applications) (m ^. #recipe) (m ^. #blueprint) (m ^. #blueprintMigrations) -- | Every string that appears anywhere inside a value keyed @origin@ or -- @targetOrigin@, at any depth. @@ -122,6 +122,8 @@ manifestWithEveryStringPosition :: Manifest manifestWithEveryStringPosition = manifestWithEveryOriginPosition + & #checkoutOutputs .~ Map.singleton ".local/shared" (CheckoutOutputRecord (DirectorySymlink "assets/shared") (Map.singleton (ApplicationId "app") (Set.singleton "haskell-base"))) + & #seeds .~ Map.singleton "CHANGELOG.md" (SeedRecord "haskell-base" (Set.singleton (ApplicationId "app")) SeedCreated fixedTime) & #modules .~ [ AppliedModule { name = ModuleName "haskell-base", @@ -148,7 +150,7 @@ fixedTime (Just (BaselineRef (hashContent "flake"))) (Set.singleton (ApplicationId "app")) - False + SharedWriteRequiresOwnershipClosure ) & #applications %~ map (withCommandReceipts (Map.singleton receiptFingerprint receipt)) @@ -265,7 +267,7 @@ it "creates a manifest with the current version" $ do let m = emptyManifest fixedTime (m ^. #version) `shouldBe` currentManifestVersion - (m ^. #version) `shouldBe` 6 + (m ^. #version) `shouldBe` currentManifestVersion it "creates a manifest with no modules, vars, or files" $ do let m = emptyManifest fixedTime @@ -344,6 +346,8 @@ applications = base ^. #applications, recipe = Nothing, blueprint = Nothing, + seeds = Map.empty, + checkoutOutputs = Map.empty, blueprintMigrations = [] } manifestFromJSON (manifestToJSON m) `shouldBe` Right m @@ -352,7 +356,7 @@ let m :: Manifest m = ( (emptyManifest fixedTime) - & #files .~ Map.fromList [("README.md", FileRecord {hash = SHA256 "abc123", moduleName = ModuleName "haskell-base", strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}), ("my-app.cabal", FileRecord {hash = SHA256 "def456", moduleName = ModuleName "haskell-base", strategy = DhallText, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False})] + & #files .~ Map.fromList [("README.md", FileRecord {hash = SHA256 "abc123", moduleName = ModuleName "haskell-base", strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, sharedWriteMode = SharedWriteUnknown}), ("my-app.cabal", FileRecord {hash = SHA256 "def456", moduleName = ModuleName "haskell-base", strategy = DhallText, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, sharedWriteMode = SharedWriteUnknown})] ) manifestFromJSON (manifestToJSON m) `shouldBe` Right m @@ -373,15 +377,17 @@ files = Map.fromList [ ( "README.md", - FileRecord (SHA256 "aaa") (ModuleName "haskell-base") Template fixedTime Nothing mempty False + FileRecord (SHA256 "aaa") (ModuleName "haskell-base") Template fixedTime Nothing mempty SharedWriteUnknown ), ( "LICENSE", - FileRecord (SHA256 "bbb") (ModuleName "haskell-base") Copy fixedTime Nothing mempty False + FileRecord (SHA256 "bbb") (ModuleName "haskell-base") Copy fixedTime Nothing mempty SharedWriteUnknown ) ], applications = [], recipe = Nothing, blueprint = Nothing, + seeds = Map.empty, + checkoutOutputs = Map.empty, blueprintMigrations = [] } manifestFromJSON (manifestToJSON m) `shouldBe` Right m @@ -389,7 +395,7 @@ it "roundtrips all strategy types" $ do let strategies = [Copy, Template, DhallText, Structured] makeRecord s = - FileRecord (SHA256 "hash") (ModuleName "mod") s fixedTime Nothing mempty False + FileRecord (SHA256 "hash") (ModuleName "mod") s fixedTime Nothing mempty SharedWriteUnknown m :: Manifest m = ( (emptyManifest fixedTime) @@ -503,7 +509,7 @@ generatedAt = fixedTime, baseline = Just (BaselineRef (hashContent "generated baseline")), applicationIds = Set.fromList [appId1, appId2], - additiveOnly = False + sharedWriteMode = SharedWriteUnknown } manifest = ( (emptyManifest fixedTime) @@ -664,7 +670,7 @@ commandReceipts = Map.empty, appliedAt = fixedTime } - fileRecord = FileRecord (SHA256 "hash") "base" Template fixedTime Nothing mempty False + fileRecord = FileRecord (SHA256 "hash") "base" Template fixedTime Nothing mempty SharedWriteUnknown recipe = AppliedRecipe "recipe" (LocalOrigin "recipe") (Just "1.0.0") fixedTime normalBlueprint = AppliedBlueprint "payments" (LocalOrigin "payments") (Just "0.4.0") fixedTime [] False Nothing Nothing seed = @@ -707,8 +713,8 @@ Right _ -> expectationFailure "a version-1 manifest should not decode directly" Left err -> err `shouldSatisfy` isInfixOf "seihou manifest upgrade" - describe "additive-only file records" $ do - let additiveRecord additive = + describe "shared-write evidence" $ do + let modeRecord mode = FileRecord { hash = SHA256 "aaa", moduleName = ModuleName "nix-haskell-flake", @@ -716,46 +722,105 @@ generatedAt = fixedTime, baseline = Nothing, applicationIds = Set.fromList [ApplicationId "app-one", ApplicationId "app-two"], - additiveOnly = additive + sharedWriteMode = mode } - manifestWith additive = - (emptyManifest fixedTime) & #files .~ Map.singleton ".gitignore" (additiveRecord additive) - recordKeys manifest = case Aeson.decode (manifestToJSON manifest) of + manifestWith mode = + (emptyManifest fixedTime) & #files .~ Map.singleton ".gitignore" (modeRecord mode) + recordObject manifest = case Aeson.decode (manifestToJSON manifest) of Just (Aeson.Object top) -> case KeyMap.lookup "files" top of Just (Aeson.Object files) -> case KeyMap.lookup ".gitignore" files of - Just (Aeson.Object record) -> map Key.toText (KeyMap.keys record) - _ -> [] - _ -> [] - _ -> [] + Just (Aeson.Object record) -> record + _ -> KeyMap.empty + _ -> KeyMap.empty + _ -> KeyMap.empty + schemaJson :: Int -> String -> String + schemaJson version recordTail = + "{\"version\":" + <> show version + <> ",\"generatedAt\":\"2026-03-01T10:30:00Z\",\"modules\":[]" + <> ",\"variables\":{},\"applications\":[],\"files\":{\".gitignore\":{\"hash\":\"aaa\"" + <> ",\"module\":\"nix-haskell-flake\",\"strategy\":\"template\"" + <> ",\"generatedAt\":\"2026-03-01T10:30:00Z\"" + <> recordTail + <> "}}}" + schema6Json = schemaJson 6 + schema7Json = schemaJson 7 + decodedMode json = case manifestFromJSON (LBS8.pack json) of + Left err -> Left err + Right decoded -> maybe (Left "no .gitignore record") (Right . (^. #sharedWriteMode)) (Map.lookup ".gitignore" (decoded ^. #files)) - it "roundtrips a record whose additiveOnly is true" $ do - manifestFromJSON (manifestToJSON (manifestWith True)) `shouldBe` Right (manifestWith True) + forM_ [minBound .. maxBound] $ \mode -> + it ("roundtrips a schema-7 record whose mode is " <> show mode) $ + manifestFromJSON (manifestToJSON (manifestWith mode)) `shouldBe` Right (manifestWith mode) - it "roundtrips a record whose additiveOnly is false" $ do - manifestFromJSON (manifestToJSON (manifestWith False)) `shouldBe` Right (manifestWith False) + it "always emits sharedWriteMode at schema 7, including unknown" $ do + KeyMap.lookup "sharedWriteMode" (recordObject (manifestWith SharedWriteUnknown)) + `shouldBe` Just (Aeson.String "unknown") + KeyMap.lookup "sharedWriteMode" (recordObject (manifestWith SharedWriteAdditiveOnly)) + `shouldBe` Just (Aeson.String "additive-only") + KeyMap.lookup "sharedWriteMode" (recordObject (manifestWith SharedWriteRequiresOwnershipClosure)) + `shouldBe` Just (Aeson.String "requires-ownership-closure") + KeyMap.member "additiveOnly" (recordObject (manifestWith SharedWriteAdditiveOnly)) `shouldBe` False - it "emits the additiveOnly key only when the flag is true" $ do - recordKeys (manifestWith True) `shouldContain` ["additiveOnly"] - recordKeys (manifestWith False) `shouldNotContain` ["additiveOnly"] + it "decodes a schema-6 additiveOnly: true as certified additive-only" $ + decodedMode (schema6Json ",\"additiveOnly\":true") `shouldBe` Right SharedWriteAdditiveOnly - it "decodes a record with no additiveOnly key as not additive-only" $ do - -- A manifest written before the field existed must keep every shared - -- path under the ownership closure, so the absent key must fail closed. - let json = - "{\"version\":6,\"generatedAt\":\"2026-03-01T10:30:00Z\",\"modules\":[]" - <> ",\"variables\":{},\"applications\":[],\"files\":{\".gitignore\":{\"hash\":\"aaa\"" - <> ",\"module\":\"nix-haskell-flake\",\"strategy\":\"template\"" - <> ",\"generatedAt\":\"2026-03-01T10:30:00Z\"}}}" - case manifestFromJSON json of - Left err -> expectationFailure ("expected the manifest to decode, got: " <> err) - Right decoded -> case Map.lookup ".gitignore" (decoded ^. #files) of - Nothing -> expectationFailure "expected a .gitignore record" - Just decodedRecord -> (decodedRecord ^. #additiveOnly) `shouldBe` False + it "decodes a schema-6 record with no additiveOnly key as unknown, not as closure-required" $ + -- The version-6 encoder omitted false, so absence proves nothing. + decodedMode (schema6Json "") `shouldBe` Right SharedWriteUnknown + it "decodes a schema-6 additiveOnly: false as unknown" $ + decodedMode (schema6Json ",\"additiveOnly\":false") `shouldBe` Right SharedWriteUnknown + + it "keeps the decoded schema-6 version so capability checks see what the file proves" $ + case manifestFromJSON (LBS8.pack (schema6Json "")) of + Left err -> expectationFailure err + Right decoded -> do + (decoded ^. #version) `shouldBe` ManifestSchemaVersion 6 + manifestSupports TargetedAdditiveSharedPathUpdate decoded `shouldBe` False + + it "re-encodes a schema-6 manifest in the schema-6 representation" $ do + let asSchema6 mode = manifestWith mode & #version .~ ManifestSchemaVersion 6 + KeyMap.lookup "additiveOnly" (recordObject (asSchema6 SharedWriteAdditiveOnly)) `shouldBe` Just (Aeson.Bool True) + KeyMap.member "sharedWriteMode" (recordObject (asSchema6 SharedWriteAdditiveOnly)) `shouldBe` False + -- Schema 6 cannot say "closure required"; it fails closed to unknown. + KeyMap.member "additiveOnly" (recordObject (asSchema6 SharedWriteRequiresOwnershipClosure)) `shouldBe` False + + it "rejects a schema-7 record without sharedWriteMode and names the record and key" $ + case manifestFromJSON (LBS8.pack (schema7Json "")) of + Right _ -> expectationFailure "a schema-7 record without sharedWriteMode must not decode" + Left err -> do + err `shouldSatisfy` isInfixOf ".gitignore" + err `shouldSatisfy` isInfixOf "sharedWriteMode" + + it "rejects a schema-7 record with an unrecognised sharedWriteMode" $ + case manifestFromJSON (LBS8.pack (schema7Json ",\"sharedWriteMode\":\"maybe\"")) of + Right _ -> expectationFailure "an unknown sharedWriteMode value must not decode" + Left err -> do + err `shouldSatisfy` isInfixOf ".gitignore" + err `shouldSatisfy` isInfixOf "sharedWriteMode" + err `shouldSatisfy` isInfixOf "maybe" + + it "does not read a schema-7 additiveOnly key as evidence" $ + case manifestFromJSON (LBS8.pack (schema7Json ",\"additiveOnly\":true")) of + Right _ -> expectationFailure "schema 7 requires sharedWriteMode even when additiveOnly is present" + Left err -> err `shouldSatisfy` isInfixOf "sharedWriteMode" + + describe "manifest capabilities" $ do + it "requires schema 7 for targeted additive shared-path updates" $ + minimumManifestVersion TargetedAdditiveSharedPathUpdate `shouldBe` ManifestSchemaVersion 7 + + it "never requires a schema newer than this build" $ + forM_ [minBound .. maxBound] $ \capability -> + minimumManifestVersion capability `shouldSatisfy` (<= currentManifestVersion) + + it "is supported by a schema-7 manifest" $ + manifestSupports TargetedAdditiveSharedPathUpdate (emptyManifest fixedTime) `shouldBe` True + describe "version checking" $ do it "rejects manifests with version higher than current" $ do let base = emptyManifest fixedTime - m = Manifest {version = 99, genAt = base ^. #genAt, modules = base ^. #modules, vars = base ^. #vars, files = base ^. #files, applications = base ^. #applications, recipe = Nothing, blueprint = Nothing, blueprintMigrations = []} + m = Manifest {version = ManifestSchemaVersion 99, genAt = base ^. #genAt, modules = base ^. #modules, vars = base ^. #vars, files = base ^. #files, applications = base ^. #applications, recipe = Nothing, blueprint = Nothing, seeds = Map.empty, checkoutOutputs = Map.empty, blueprintMigrations = []} result = manifestFromJSON (manifestToJSON m) case result of Left err -> err `shouldContain` "newer version" diff --git a/test/Seihou/Manifest/UpgradeSpec.hs b/test/Seihou/Manifest/UpgradeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Manifest/UpgradeSpec.hs @@ -0,0 +1,174 @@ +module Seihou.Manifest.UpgradeSpec (tests) where + +import Control.Lens ((^.)) +import Control.Monad (forM_) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Types +import Seihou.Manifest.Types +import Seihou.Manifest.Upgrade +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Manifest.Upgrade" spec + +v :: Int -> ManifestSchemaVersion +v = ManifestSchemaVersion + +-- | A schema-6 document with an additive path, a path with no evidence, an +-- explicit false, and keys this build does not model at every level. +schema6Document :: Aeson.Value +schema6Document = + Aeson.object + [ "version" Aeson..= (6 :: Int), + "generatedAt" Aeson..= ("2026-03-01T10:30:00Z" :: String), + "modules" Aeson..= ([] :: [Aeson.Value]), + "variables" Aeson..= Aeson.object [], + "applications" Aeson..= ([] :: [Aeson.Value]), + "producerOwned" Aeson..= Aeson.object ["keep" Aeson..= True], + "files" + Aeson..= Aeson.object + [ ".gitignore" Aeson..= record [("additiveOnly", Aeson.Bool True), ("applications", Aeson.toJSON ["a" :: String, "b"])], + "README.md" Aeson..= record [("futureKey", Aeson.String "survives")], + "flake.nix" Aeson..= record [("additiveOnly", Aeson.Bool False)] + ] + ] + where + record extra = + Aeson.Object + ( KeyMap.fromList + ( [ ("hash", Aeson.String "aaa"), + ("module", Aeson.String "base"), + ("strategy", Aeson.String "template"), + ("generatedAt", Aeson.String "2026-03-01T10:30:00Z") + ] + <> extra + ) + ) + +fileField :: String -> Aeson.Key -> Aeson.Value -> Maybe Aeson.Value +fileField path key (Aeson.Object top) = case KeyMap.lookup "files" top of + Just (Aeson.Object files) -> case KeyMap.lookup (Key.fromString path) files of + Just (Aeson.Object record) -> KeyMap.lookup key record + _ -> Nothing + _ -> Nothing +fileField _ _ _ = Nothing + +spec :: Spec +spec = do + describe "the step registry" $ do + it "plans a contiguous path from every supported version to the current one" $ + -- ADR 0014's mechanical gap check: a schema bump without its adjacent + -- step fails here. + forM_ [oldestUpgradableManifestVersion ^. #unManifestSchemaVersion .. currentManifestVersion ^. #unManifestSchemaVersion] $ \source -> + case planManifestUpgrade (v source) currentManifestVersion of + Left err -> expectationFailure ("no path from schema " <> show source <> ": " <> show err) + Right steps -> do + map (^. #fromVersion) steps `shouldBe` map v [source .. currentManifestVersion ^. #unManifestSchemaVersion - 1] + map (^. #toVersion) steps `shouldBe` map v [source + 1 .. currentManifestVersion ^. #unManifestSchemaVersion] + + it "defines exactly one step per source version" $ do + let sources = map (^. #fromVersion) manifestUpgradeSteps + length sources `shouldBe` Map.size (Map.fromList [(s, ()) | s <- sources]) + + it "returns an empty path from a version to itself" $ + planManifestUpgrade (v 7) (v 7) `shouldBe` Right [] + + it "stops at a requested intermediate target" $ + map (^. #toVersion) <$> planManifestUpgrade (v 5) (v 6) `shouldBe` Right [v 6] + + it "reports a missing adjacent step instead of jumping over it" $ do + let gappy = filter ((/= v 6) . (^. #fromVersion)) manifestUpgradeSteps + planUpgradeWith gappy (v 7) (v 5) (v 7) `shouldBe` Left (MissingUpgradeStep (v 6)) + + it "rejects targets above current and below the source" $ do + planManifestUpgrade (v 6) (v 99) `shouldBe` Left (TargetAboveCurrent (v 99)) + planManifestUpgrade (v 7) (v 6) `shouldBe` Left (TargetBelowSource (v 7) (v 6)) + planManifestUpgrade (v 99) (v 99) `shouldBe` Left (SourceNewerThanBinary (v 99)) + planManifestUpgrade (v 0) (v 7) `shouldBe` Left (SourceVersionUnsupported (v 0)) + + it "classifies the path conversion as inference-bearing and 6 -> 7 as lossless" $ do + let kindFrom source = upgradeStepKind . (^. #action) <$> lookup (v source) [(s ^. #fromVersion, s) | s <- manifestUpgradeSteps] + kindFrom 5 `shouldBe` Just InferenceBearingUpgrade + kindFrom 6 `shouldBe` Just LosslessUpgrade + + describe "the 7 -> 8 step" $ do + it "preserves unrelated raw fields and adds seed receipts" $ do + Right (_, upgraded) <- pure (upgradeDocumentLosslessly (v 8) schema6Document) + documentSchemaVersion upgraded `shouldBe` Right (v 8) + case upgraded of + Aeson.Object fields -> do + KeyMap.lookup "seeds" fields `shouldBe` Just (Aeson.object []) + KeyMap.lookup "producerOwned" fields `shouldBe` Just (Aeson.object ["keep" Aeson..= True]) + _ -> expectationFailure "expected object" + case Aeson.fromJSON upgraded :: Aeson.Result Manifest of + Aeson.Success manifest -> manifestFromJSON (manifestToJSON manifest) `shouldBe` Right manifest + Aeson.Error err -> expectationFailure err + it "rejects malformed seed containers before stamping" $ do + let document = Aeson.object ["version" Aeson..= (7 :: Int), "seeds" Aeson..= False] + upgradeDocumentLosslessly (v 8) document `shouldSatisfy` either (const True) (const False) + + describe "the 6 -> 7 step" $ do + let upgraded = upgradeDocumentLosslessly (v 7) schema6Document + + it "maps additiveOnly: true to additive-only and absent or false to unknown" $ do + (fileField ".gitignore" "sharedWriteMode" . snd <$> upgraded) `shouldBe` Right (Just (Aeson.String "additive-only")) + (fileField "README.md" "sharedWriteMode" . snd <$> upgraded) `shouldBe` Right (Just (Aeson.String "unknown")) + (fileField "flake.nix" "sharedWriteMode" . snd <$> upgraded) `shouldBe` Right (Just (Aeson.String "unknown")) + + it "removes the schema-6 key and keeps unrelated members at every level" $ do + (fileField ".gitignore" "additiveOnly" . snd <$> upgraded) `shouldBe` Right Nothing + (fileField "README.md" "futureKey" . snd <$> upgraded) `shouldBe` Right (Just (Aeson.String "survives")) + (fileField ".gitignore" "applications" . snd <$> upgraded) `shouldBe` Right (Just (Aeson.toJSON ["a" :: String, "b"])) + case snd <$> upgraded of + Right (Aeson.Object top) -> KeyMap.lookup "producerOwned" top `shouldBe` Just (Aeson.object ["keep" Aeson..= True]) + other -> expectationFailure ("unexpected result: " <> show other) + + it "stamps version 7 and reports the one step it ran" $ do + (documentSchemaVersion . snd =<< upgraded) `shouldBe` Right (v 7) + (map (^. #fromVersion) . fst <$> upgraded) `shouldBe` Right [v 6] + + it "produces a document the typed decoder reads and round-trips" $ + case upgraded of + Left err -> expectationFailure (show err) + Right (_, document) -> case manifestFromJSON (Aeson.encode document) of + Left err -> expectationFailure err + Right manifest -> do + (manifest ^. #version) `shouldBe` v 7 + fmap (^. #sharedWriteMode) (Map.lookup ".gitignore" (manifest ^. #files)) `shouldBe` Just SharedWriteAdditiveOnly + fmap (^. #sharedWriteMode) (Map.lookup "README.md" (manifest ^. #files)) `shouldBe` Just SharedWriteUnknown + manifestSupports TargetedAdditiveSharedPathUpdate manifest `shouldBe` True + manifestFromJSON (manifestToJSON manifest) `shouldBe` Right manifest + + it "is a no-op from 7 to 7" $ + case upgraded of + Left err -> expectationFailure (show err) + Right (_, document) -> upgradeDocumentLosslessly (v 7) document `shouldBe` Right ([], document) + + it "rejects a malformed additiveOnly value" $ do + let bad = Aeson.object ["version" Aeson..= (6 :: Int), "files" Aeson..= Aeson.object ["x" Aeson..= Aeson.object ["additiveOnly" Aeson..= ("yes" :: String)]]] + case upgradeDocumentLosslessly (v 7) bad of + Left (MalformedDocument source _) -> source `shouldBe` v 6 + other -> expectationFailure ("expected a malformed-document error, got " <> show other) + + it "refuses to run on a document at another version" $ do + let sixToSeven = last manifestUpgradeSteps + atFive = setDocumentSchemaVersion (v 5) schema6Document + applyLosslessUpgradeStep sixToSeven atFive `shouldBe` Left (StepVersionMismatch sixToSeven (v 5)) + + describe "lossless staging" $ do + it "refuses to cross the inference-bearing 5 -> 6 conversion" $ do + let atFive = setDocumentSchemaVersion (v 5) schema6Document + case upgradeDocumentLosslessly (v 7) atFive of + Left (StepRequiresInference s) -> (s ^. #fromVersion) `shouldBe` v 5 + other -> expectationFailure ("expected the path conversion to block, got " <> show other) + + it "names the explicit upgrade command when it refuses" $ + forM_ [s | s <- manifestUpgradeSteps, s ^. #fromVersion == v 5] $ \step5 -> + renderManifestUpgradeError (StepRequiresInference step5) `shouldSatisfy` T.isInfixOf "seihou manifest upgrade"