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.6.0.0 +version: 0.7.0.0 synopsis: Core library for Seihou project scaffolding description: Core library for Seihou, a composable project scaffolding system. @@ -40,6 +40,7 @@ Seihou.Composition.Resolve Seihou.Core.AgentPrompt Seihou.Core.Application + Seihou.Core.ArtifactIdentity Seihou.Core.ArtifactOriginDetect Seihou.Core.ArtifactRef Seihou.Core.Blueprint @@ -157,6 +158,7 @@ Seihou.Core.CommandFingerprintSpec Seihou.Core.CommandVarSpec Seihou.Core.ContextSpec + Seihou.Core.EntailmentSpec Seihou.Core.ExprSpec Seihou.Core.InstallSpec Seihou.Core.ListSpec diff --git a/src/Seihou/Core/ArtifactIdentity.hs b/src/Seihou/Core/ArtifactIdentity.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/ArtifactIdentity.hs @@ -0,0 +1,77 @@ +-- | When two recorded artifact origins name the same artifact. +-- +-- The manifest identifies an artifact by its origin plus its name (see +-- docs\/adr\/0002-artifact-identity-is-origin-url-plus-name.md), and several +-- places have to ask whether two such identities are the same one: the +-- blueprint-migration receipt ledger in 'Seihou.Manifest.Types' when it +-- upserts a receipt, the pending-edge filter in +-- 'Seihou.CLI.BlueprintMigration' when it decides what still has to run, and +-- the pre-generation guard in 'Seihou.CLI.ManifestGuard' when it compares +-- what the manifest records against what is installed here. They must agree, +-- or a receipt could be written as a new entry while being read as a +-- duplicate, so the comparison lives in one place. +-- +-- This module answers a plain yes-or-no question. The richer three-way +-- judgement that distinguishes "different artifact" from "cannot be proved +-- either way" belongs to 'Seihou.CLI.ManifestGuard.judgeArtifact' and is not +-- appropriate here: a receipt either records this exact identity or it does +-- not, with no unverifiable middle ground. +module Seihou.Core.ArtifactIdentity + ( sameArtifactIdentity, + normalizeOriginUrl, + normalizeProjectPath, + ) +where + +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Seihou.Core.Types (ArtifactOrigin (..)) +import Seihou.Prelude + +-- | Whether two recorded origins name the same artifact. +-- +-- Two origins of different kinds are never the same artifact. Within a kind +-- the comparison is structural, after normalising away spellings that differ +-- without meaning anything: a trailing @.git@ on a git URL, and a @.\/@ +-- prefix or trailing slash on a project-relative path. +-- +-- A 'LocalOrigin' carries no provenance at all, so two of them compare equal +-- exactly when they carry the same name. That is deliberately weak — it is +-- also the strongest statement available about an artifact seihou can only +-- identify by name — and it is what makes two receipts written before origins +-- were recorded still match each other. +sameArtifactIdentity :: ArtifactOrigin -> ArtifactOrigin -> Bool +sameArtifactIdentity left right = case (left, right) of + (RemoteOrigin leftUrl leftName _, RemoteOrigin rightUrl rightName _) -> + normalizeOriginUrl leftUrl == normalizeOriginUrl rightUrl + && leftName == rightName + (ProjectOrigin leftPath, ProjectOrigin rightPath) -> + normalizeProjectPath leftPath == normalizeProjectPath rightPath + (LocalOrigin leftName, LocalOrigin rightName) -> leftName == rightName + _ -> False + +-- | Reduce a git URL to a form two spellings of the same repository share. +-- +-- @https:\/\/host\/repo@, @https:\/\/host\/repo.git@ and +-- @https:\/\/host\/repo\/@ all name the same repository, and a manifest +-- written by a developer who typed one of them must not read as a different +-- artifact to a developer who typed another. +normalizeOriginUrl :: Text -> Text +normalizeOriginUrl = + dropTrailingSlashes . dropGitSuffix . dropTrailingSlashes . T.strip + where + dropTrailingSlashes = T.dropWhileEnd (== '/') + dropGitSuffix url = fromMaybe url (T.stripSuffix ".git" url) + +-- | Reduce a project-relative path to a comparable form. The manifest stores +-- these with forward slashes; @.\/@ prefixes and trailing slashes are noise. +normalizeProjectPath :: FilePath -> FilePath +normalizeProjectPath = + dropWhileEnd' (== '/') . dropDotPrefix . dropWhileEnd' (== '/') + where + dropDotPrefix path = fromMaybe path (stripPrefix' "./" path) + stripPrefix' prefix path = + if take (length prefix) path == prefix + then Just (drop (length prefix) path) + else Nothing + dropWhileEnd' p = reverse . dropWhile p . reverse diff --git a/src/Seihou/Core/Blueprint.hs b/src/Seihou/Core/Blueprint.hs --- a/src/Seihou/Core/Blueprint.hs +++ b/src/Seihou/Core/Blueprint.hs @@ -13,6 +13,7 @@ checkBlueprintAllowedTools, checkBlueprintMigrations, checkBlueprintLaunch, + checkBlueprintVersionProbe, ) where @@ -20,7 +21,7 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text qualified as T -import Seihou.Core.Migration (BlueprintMigration (..)) +import Seihou.Core.Migration (BlueprintMigration (..), EntailedEdge (..)) import Seihou.Core.Module (defaultSearchPaths, discoverRunnable, isValidModuleName) import Seihou.Core.Types import Seihou.Core.Version (parseVersion) @@ -46,10 +47,21 @@ -- 8. Every tag is non-empty. -- 9. Every @allowedTools@ entry, when set, is non-empty. -- 10. Every migration is a forward dotted-numeric edge with a non-empty --- prompt, and each starting version occurs at most once. +-- prompt, and each starting version occurs at most once. Every entailed +-- edge names a well-formed blueprint other than this one, with a forward +-- dotted-numeric window, and no edge entails the same edge twice. +-- Whether the named blueprint exists and declares that exact edge cannot +-- be checked here — this function is pure and existence is a filesystem +-- question — so it is checked when @seihou agent migrate@ resolves the +-- cohort. -- 11. Every field the @launch@ record does set is non-blank. The values -- themselves are parsed by the CLI, which owns the provider and effort -- vocabularies. +-- 12. @versionProbe@, when set, is non-blank. What the command /does/ is +-- deliberately not checked: validation must not execute anything, and +-- seihou cannot know whether the author's @jq@ or @nix@ is installed on +-- the consumer's machine. A probe that fails at run time degrades to +-- requiring @--to@ rather than failing the blueprint. validateBlueprint :: FilePath -> Blueprint -> IO (Either ModuleLoadError Blueprint) validateBlueprint baseDir b = do searchPaths <- defaultSearchPaths @@ -77,6 +89,7 @@ <> checkBlueprintAllowedTools b <> checkBlueprintMigrations b <> checkBlueprintLaunch b + <> checkBlueprintVersionProbe b allErrs = pureErrs <> fileErrs <> baseErrs pure $ if null allErrs @@ -228,7 +241,85 @@ <> versionErrors "from" (migration ^. #from) <> versionErrors "to" (migration ^. #to) <> orderErrors migration + <> concatMap (entailErrors migration) (migration ^. #entails) + <> duplicateEntailErrors migration + -- An entailed edge names another blueprint's exact edge. Everything + -- checkable without touching the filesystem is checked here; existence of + -- the named blueprint and of the exact edge is resolved by + -- @seihou agent migrate@, which is the only caller that has search paths. + entailErrors :: BlueprintMigration -> EntailedEdge -> [Text] + entailErrors migration entailed = + nameErrors + <> entailVersionErrors "from" (entailed ^. #from) + <> entailVersionErrors "to" (entailed ^. #to) + <> entailOrderErrors + <> selfErrors + where + prefix = + "blueprint migration " + <> migration ^. #from + <> " -> " + <> migration ^. #to + <> " entails " + + nameErrors + | T.null target || not (isValidModuleName target) = + [prefix <> "a blueprint whose name must match [a-z][a-z0-9-]*, got: " <> target] + | otherwise = [] + + entailVersionErrors label versionText = case parseVersion versionText of + Nothing -> + [ prefix + <> "'" + <> target + <> "' with a " + <> label + <> " version that is not dotted numeric: " + <> versionText + ] + Just _ -> [] + + entailOrderErrors = + case (parseVersion (entailed ^. #from), parseVersion (entailed ^. #to)) of + (Just fromVersion, Just toVersion) + | fromVersion >= toVersion -> + [ prefix + <> "'" + <> target + <> "' with an edge that does not advance versions: " + <> entailed ^. #from + <> " -> " + <> entailed ^. #to + ] + _ -> [] + + -- Entailment crosses blueprints. An edge naming its own blueprint is + -- either a typo or an attempt to express ordering within one + -- migrations list, which the version window already decides. + selfErrors + | target == b ^. #name . #unModuleName = + [prefix <> "an edge of its own blueprint '" <> target <> "'"] + | otherwise = [] + + target = entailed ^. #blueprint + + duplicateEntailErrors :: BlueprintMigration -> [Text] + duplicateEntailErrors migration = + map + ( \key -> + "blueprint migration " + <> migration ^. #from + <> " -> " + <> migration ^. #to + <> " entails the same edge twice: " + <> key + ) + (findDupes Set.empty Set.empty (map renderEntailed (migration ^. #entails))) + + renderEntailed entailed = + entailed ^. #blueprint <> " " <> entailed ^. #from <> " -> " <> entailed ^. #to + promptErrors :: BlueprintMigration -> [Text] promptErrors migration = [ "blueprint migration " @@ -276,3 +367,13 @@ | Just v <- [value], T.null (T.strip v) ] + +-- Rule 12: @versionProbe@, when set, must not be blank. Nothing more is +-- checkable here: the command is a shell string for the consumer's machine, +-- and validation runs on the author's. +checkBlueprintVersionProbe :: Blueprint -> [Text] +checkBlueprintVersionProbe b = + [ "versionProbe, if specified, must not be empty" + | Just probe <- [b ^. #versionProbe], + T.null (T.strip probe) + ] diff --git a/src/Seihou/Core/Migration.hs b/src/Seihou/Core/Migration.hs --- a/src/Seihou/Core/Migration.hs +++ b/src/Seihou/Core/Migration.hs @@ -3,18 +3,27 @@ Migration (..), MigrationOp (..), BlueprintMigration (..), + EntailedEdge (..), -- * Migration planning MigrationPlan (..), BlueprintMigrationPlan (..), + BlueprintMigrationStep (..), MigrationPlanError (..), planMigrationChain, planBlueprintMigrationChain, + + -- * Entailment expansion + EntailmentSite (..), + EntailmentError (..), + expandEntailedEdges, ) where +import Control.Monad (foldM) import Data.Generics.Labels () import Data.List (sortOn) +import Data.Set qualified as Set import Seihou.Core.Version (Version, parseVersion) import Seihou.Prelude @@ -50,13 +59,35 @@ } deriving stock (Eq, Show, Generic) +-- | A reference from one blueprint's migration edge to an exact edge of +-- another blueprint. Resolution is by name through the same search paths +-- @seihou agent migrate@ uses; the referenced edge must exist verbatim. +-- +-- This is how a breaking change that reaches consumers through an +-- intermediary library travels. A blueprint for @keiro@ — which absorbed a +-- breaking change from @kiroku@ — declares that crossing its own +-- @2.4.0 -> 3.0.0@ edge entails crossing kiroku's @1.9.0 -> 2.0.0@ edge. A +-- project that depends on keiro and has never heard of kiroku still gets +-- kiroku's upgrade guidance, in kiroku's own version space. +data EntailedEdge = EntailedEdge + { blueprint :: !Text, + from :: !Text, + to :: !Text + } + deriving stock (Eq, Show, Generic) + -- | One agent-guided source migration declared by a blueprint. The -- version strings use the same dotted-numeric format as module migrations, -- while 'prompt' describes only the changes needed for this edge. +-- +-- 'entails' names exact edges of other blueprints that crossing this edge +-- requires. They are expanded recursively and run before this edge; see +-- 'expandEntailedEdges'. data BlueprintMigration = BlueprintMigration { from :: !Text, to :: !Text, - prompt :: !Text + prompt :: !Text, + entails :: ![EntailedEdge] } deriving stock (Eq, Show, Generic) @@ -102,14 +133,52 @@ } deriving stock (Eq, Show, Generic) +-- | Where an entailment declaration was written: the blueprint that owns the +-- declaring edge, and that edge's own version window. +-- +-- Both 'EntailmentError' variants carry one because both are authoring +-- mistakes in that exact edge, and an error message that cannot say which +-- edge to fix is useless to the author who has to fix it. +data EntailmentSite = EntailmentSite + { blueprint :: !Text, + from :: !Text, + to :: !Text + } + deriving stock (Eq, Show, Generic) + +-- | One edge to run, together with the blueprint that declares it. +-- +-- @owner@ is the name of the blueprint whose @migrations@ list contains +-- @edge@ — not the blueprint the user named on the command line. Receipts +-- are written under the owner, which is what makes a shared cohort edge the +-- same edge from either entry point. +-- +-- @entailedBy@ names the edge that pulled this one in, when this step was +-- reached through entailment rather than selected directly by the version +-- window. It exists so output can say @(entailed by keiro-upgrade 2.4.0 -> +-- 3.0.0)@. It is display-only and must never enter an identity comparison: +-- the same cohort edge reached from two different declaring edges is one +-- edge, and treating the two as distinct would cross it twice. +data BlueprintMigrationStep = BlueprintMigrationStep + { owner :: !Text, + edge :: !BlueprintMigration, + entailedBy :: !(Maybe EntailmentSite) + } + deriving stock (Eq, Show, Generic) + -- | The ordered blueprint migrations selected for a requested version -- window. A non-trivial window may have no selected steps when the author -- declared no agent intervention for that range. +-- +-- @name@ and the version window belong to the blueprint the user invoked. +-- After 'expandEntailedEdges' has run, individual steps may be owned by other +-- blueprints and carry versions from those blueprints' version spaces; each +-- step says which blueprint it belongs to. data BlueprintMigrationPlan = BlueprintMigrationPlan { name :: !Text, from :: !Version, to :: !Version, - steps :: ![BlueprintMigration] + steps :: ![BlueprintMigrationStep] } deriving stock (Eq, Show, Generic) @@ -179,6 +248,10 @@ -- | Compute the ordered agent-guided migrations for a blueprint and version -- window. Selection and errors deliberately match 'planMigrationChain'. +-- +-- Every selected edge is labelled with @blueprintName@, because at this point +-- every edge in the plan came out of that blueprint's own @migrations@ list. +-- Steps owned by other blueprints appear only after 'expandEntailedEdges'. planBlueprintMigrationChain :: Text -> [BlueprintMigration] -> @@ -193,11 +266,128 @@ { name = blueprintName, from = current, to = target, - steps = steps + steps = map ownedBy steps } ) ) (planMigrationWindow (^. #from) (^. #to) migrations current target) + where + ownedBy selected = + BlueprintMigrationStep + { owner = blueprintName, + edge = selected, + entailedBy = Nothing + } + +-- | All the ways entailment expansion can fail. Every variant is an authoring +-- mistake in a published blueprint rather than anything the consumer running +-- the migration did, so each carries enough to name the blueprint whose author +-- has to fix it. +data EntailmentError + = -- | An entailed blueprint could not be resolved on this machine. Carries + -- the declaring edge and the name that did not resolve. This is a + -- consumer-fixable situation — the blueprint is simply not installed — + -- but seihou refuses rather than skipping, because the consumer does not + -- know the cohort and a silently omitted member leaves a half-migrated + -- project with no signal. + EntailedBlueprintNotFound !EntailmentSite !Text + | -- | The named blueprint resolved but declares no edge with that exact + -- window. Carries the declaring edge, then the entailed blueprint's name, + -- @from@, and @to@. Entailment names one exact edge; falling back to + -- window planning inside the entailed blueprint would let a release + -- silently change which upstream work it implies. + EntailedEdgeNotDeclared !EntailmentSite !Text !Text !Text + | -- | Entailment forms a cycle. Carries the chain in order, each element + -- rendered as @blueprint from -> to@, beginning and ending with the edge + -- that closed it. + EntailmentCycle ![Text] + deriving stock (Eq, Show, Generic) + +-- | Expand each selected edge into its entailed edges followed by itself, +-- recursively, in declaration order. +-- +-- @lookupMigrations@ answers "what edges does this blueprint declare?" and +-- returns 'Nothing' for a blueprint that could not be resolved. Keeping it a +-- parameter is what lets this function stay pure: discovery is the CLI's job. +-- +-- Ordering: an entailed edge runs /before/ the edge that declares it, and +-- several entailed edges run in declaration order. The entailed edge is the +-- deeper change — kiroku's API — and the declaring edge's own guidance may +-- assume it has already been applied. +-- +-- Deduplication: an edge already emitted is not emitted again, no matter how +-- many selected edges entail it. Identity is the triple @(owner, from, to)@, +-- which deliberately ignores @entailedBy@: the same cohort edge reached from +-- two declaring edges is one piece of work. This is expansion-time +-- deduplication only; dropping edges this project has already recorded +-- receipts for happens afterwards and separately. +-- +-- Cycles are a hard error rather than a silently broken chain, because a +-- cycle means two blueprints each claim the other's edge must run first and +-- there is no order that satisfies both. +expandEntailedEdges :: + (Text -> Maybe [BlueprintMigration]) -> + [BlueprintMigrationStep] -> + Either EntailmentError [BlueprintMigrationStep] +expandEntailedEdges lookupMigrations topSteps = do + (expanded, _visited) <- foldM (expandStep []) ([], Set.empty) topSteps + Right expanded + where + -- @path@ is the chain of edges currently being expanded, oldest first. + -- @emitted@ is the output so far, in final order. @visited@ is every + -- edge already emitted, so a second reference to it is dropped. + expandStep path (emitted, visited) step + | stepKey `Set.member` visited = Right (emitted, visited) + | stepKey `elem` path = Left (EntailmentCycle (renderCycle path stepKey)) + | otherwise = do + entailedSteps <- traverse (resolveEntailed step) (step ^. #edge . #entails) + (emitted', visited') <- + foldM (expandStep (path <> [stepKey])) (emitted, visited) entailedSteps + Right (emitted' <> [step], Set.insert stepKey visited') + where + stepKey = edgeKey step + + resolveEntailed declaringStep entailed = + case lookupMigrations (entailed ^. #blueprint) of + Nothing -> Left (EntailedBlueprintNotFound site (entailed ^. #blueprint)) + Just declared -> + case [ candidate + | candidate <- declared, + candidate ^. #from == entailed ^. #from, + candidate ^. #to == entailed ^. #to + ] of + (matched : _) -> + Right + BlueprintMigrationStep + { owner = entailed ^. #blueprint, + edge = matched, + entailedBy = Just site + } + [] -> + Left + ( EntailedEdgeNotDeclared + site + (entailed ^. #blueprint) + (entailed ^. #from) + (entailed ^. #to) + ) + where + site = + EntailmentSite + { blueprint = declaringStep ^. #owner, + from = declaringStep ^. #edge . #from, + to = declaringStep ^. #edge . #to + } + + edgeKey step = (step ^. #owner, step ^. #edge . #from, step ^. #edge . #to) + + -- The cycle a reader wants to see starts where the repeat began, not at + -- whichever top-level edge happened to lead there. + renderCycle path repeated = + map renderKey (dropWhile (/= repeated) path <> [repeated]) + + renderKey (owner, fromVersion, toVersion) = + owner <> " " <> fromVersion <> " -> " <> toVersion -- | Shared gap-tolerant version-window planner. Keeping parsing, duplicate -- detection, ordering, overlap handling, and overshoot handling here prevents 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 @@ -46,6 +46,7 @@ AppliedModule (..), AppliedRecipe (..), AppliedBlueprint (..), + MigrationOutcome (..), AppliedBlueprintMigration (..), FileRecord (..), SHA256 (..), @@ -314,7 +315,14 @@ allowedTools :: !(Maybe [Text]), tags :: ![Text], migrations :: ![BlueprintMigration], - launch :: !(Maybe AgentLaunch) + launch :: !(Maybe AgentLaunch), + -- | A shell command that prints which version of this blueprint's + -- library the project currently declares. It supplies the default + -- @--to@ for @seihou agent migrate@; only the blueprint's author + -- knows where the version lives in their ecosystem, which is how + -- seihou infers a target without reading any package-manager format + -- itself. + versionProbe :: !(Maybe Text) } deriving stock (Eq, Show, Generic) @@ -582,8 +590,16 @@ deriving stock (Eq, Show, Generic) -- | Recipe provenance recorded in the manifest when a recipe is used. +-- +-- @origin@ is the recipe's portable identity. Turning it back into a +-- directory on the current machine is +-- 'Seihou.Core.ArtifactRef.resolveArtifactOrigin'; no path is ever recorded +-- here. Manifests written before the field existed decode with a +-- 'LocalOrigin' carrying the recorded name, which honestly says "this +-- recipe's provenance cannot be verified". data AppliedRecipe = AppliedRecipe { name :: !RecipeName, + origin :: !ArtifactOrigin, recipeVersion :: !(Maybe Text), appliedAt :: !UTCTime } @@ -602,8 +618,16 @@ -- @agentSessionId@ is reserved for the deferred resume feature recorded -- in @docs/masterplans/3-agent-driven-blueprints.md@; in v1 it is always -- 'Nothing' and the encoder omits the JSON key in that case. +-- +-- @origin@ is the blueprint's portable identity. Turning it back into a +-- directory on the current machine is +-- 'Seihou.Core.ArtifactRef.resolveArtifactOrigin'; no path is ever recorded +-- here. Manifests written before the field existed decode with a +-- 'LocalOrigin' carrying the recorded name, which honestly says "this +-- blueprint's provenance cannot be verified". data AppliedBlueprint = AppliedBlueprint { name :: !ModuleName, + origin :: !ArtifactOrigin, blueprintVersion :: !(Maybe Text), appliedAt :: !UTCTime, baselineModules :: ![ModuleName], @@ -613,14 +637,49 @@ } deriving stock (Eq, Show, Generic) --- | A durable receipt for one successfully completed agent-guided blueprint --- migration edge. Exact-edge identity is the blueprint 'name' together with --- 'fromVersion' and 'toVersion'; the remaining fields are audit metadata. +-- | What actually happened when seihou ran one blueprint migration edge. +-- +-- 'MigrationApplied' means the provider interaction returned. As +-- @docs\/user\/blueprint-migrations.md@ states, that is bookkeeping and not +-- proof that the build passes. +-- +-- 'MigrationNotApplicable' means the edge reported that its precondition is +-- unmet in this project and it deliberately changed nothing. The attempt is +-- recorded so the audit trail is complete, but it does not suppress a later +-- run: the precondition may be met by then. +-- +-- The reason is carried inside the constructor rather than in a sibling +-- @Maybe Text@ field, so the type cannot express a reason for an applied edge +-- or a skipped edge with no reason. +data MigrationOutcome + = MigrationApplied + | MigrationNotApplicable !Text + deriving stock (Eq, Show, Generic) + +-- | A durable receipt for one attempted agent-guided blueprint migration +-- edge. Exact-edge identity is the 'origin' and 'name' of the blueprint that +-- owns the edge together with 'fromVersion' and 'toVersion'; the remaining +-- fields, 'outcome' included, are audit metadata. +-- +-- @outcome@ is deliberately not part of the identity: re-running an edge that +-- was previously not applicable replaces its receipt rather than appending a +-- second one for the same edge. +-- +-- @origin@ is the blueprint's portable identity. Turning it back into a +-- directory on the current machine is +-- 'Seihou.Core.ArtifactRef.resolveArtifactOrigin'; no path is ever recorded +-- here. It is part of the identity, not merely audit metadata, because two +-- blueprints published by different repositories under the same name are not +-- the same blueprint and their identically-numbered edges are not the same +-- edge. Manifests written before the field existed decode with a +-- 'LocalOrigin' carrying the recorded name. data AppliedBlueprintMigration = AppliedBlueprintMigration { name :: !ModuleName, + origin :: !ArtifactOrigin, blueprintVersion :: !(Maybe Text), fromVersion :: !Text, toVersion :: !Text, + outcome :: !MigrationOutcome, appliedAt :: !UTCTime, agentSessionId :: !(Maybe Text) } 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 @@ -48,7 +48,7 @@ import Dhall.Marshal.Decode (Decoder (..), Extractor, bool, constructor, field, maybe, natural, string, union) import Dhall.Src (Src) import Seihou.Core.Expr (parseExpr) -import Seihou.Core.Migration (BlueprintMigration (..), Migration (..), MigrationOp (..)) +import Seihou.Core.Migration (BlueprintMigration (..), EntailedEdge (..), Migration (..), MigrationOp (..)) import Seihou.Core.Registry (Registry (..), RegistryEntry (..)) import Seihou.Core.Types import Seihou.Core.Variable (coerceDefault) @@ -176,7 +176,7 @@ moduleDecoder = withDefaults [ ("removal", noneText), - ("migrations", emptyMigrationList) + ("migrations", emptyRecordList) ] $ record ( Module @@ -193,12 +193,14 @@ <*> field "migrations" (list migrationDecoder) ) --- | A Dhall expression representing an empty list of Migration records. +-- | A Dhall expression representing an empty list of records, used as the +-- default for a list-typed field an older artifact omits entirely. -- The list element type annotation is unused by the list extractor (which -- ignores the annotation and reads element values), so we use a placeholder --- type to keep the synthesized expression compact. -emptyMigrationList :: Dhall.Expr Src Void -emptyMigrationList = Dhall.ListLit (Just Dhall.Text) mempty +-- type to keep the synthesized expression compact and reuse one constant for +-- every such field. +emptyRecordList :: Dhall.Expr Src Void +emptyRecordList = Dhall.ListLit (Just Dhall.Text) mempty -- | Decoder for a single 'Migration' record. migrationDecoder :: Decoder Migration @@ -211,13 +213,30 @@ ) -- | Decoder for one agent-guided blueprint migration edge. +-- Uses 'withDefaults' to handle blueprints published before the @entails@ +-- field existed. The default has to be attached here rather than on +-- 'blueprintDecoder', because the missing key is inside each element of the +-- @migrations@ list rather than on the blueprint record itself. blueprintMigrationDecoder :: Decoder BlueprintMigration blueprintMigrationDecoder = + withDefaults [("entails", emptyRecordList)] $ + record + ( BlueprintMigration + <$> field "from" strictText + <*> field "to" strictText + <*> field "prompt" strictText + <*> field "entails" (list entailedEdgeDecoder) + ) + +-- | Decoder for one entailed-edge reference: the blueprint that owns the +-- entailed edge, and that edge's exact version window. +entailedEdgeDecoder :: Decoder EntailedEdge +entailedEdgeDecoder = record - ( BlueprintMigration - <$> field "from" strictText + ( EntailedEdge + <$> field "blueprint" strictText + <*> field "from" strictText <*> field "to" strictText - <*> field "prompt" strictText ) -- | Decoder for a 'MigrationOp' from a Dhall union value. @@ -277,12 +296,16 @@ ) -- | Decoder for the top-level Blueprint type from Dhall. --- Uses 'withDefaults' to handle blueprints that predate the @migrations@ and --- @launch@ fields. +-- Uses 'withDefaults' to handle blueprints that predate the @migrations@, +-- @launch@, and @versionProbe@ fields. blueprintDecoder :: Decoder Blueprint blueprintDecoder = - withDefaults [("migrations", emptyMigrationList), ("launch", noneText)] $ - record + withDefaults + [ ("migrations", emptyRecordList), + ("launch", noneText), + ("versionProbe", noneText) + ] + $ record ( Blueprint <$> field "name" moduleNameDecoder <*> field "version" (maybe strictText) @@ -296,6 +319,7 @@ <*> field "tags" (list strictText) <*> field "migrations" (list blueprintMigrationDecoder) <*> field "launch" (maybe agentLaunchDecoder) + <*> field "versionProbe" (maybe strictText) ) -- | Evaluate a @blueprint.dhall@ file and decode it into a 'Blueprint'. 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 @@ -16,9 +16,11 @@ import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels () import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) import Data.Set qualified as Set import Data.Text qualified as T import Data.Time (UTCTime) +import Seihou.Core.ArtifactIdentity (sameArtifactIdentity) import Seihou.Core.Types import Seihou.Manifest.Hash (baselineRefFromText) import Seihou.Prelude hiding ((.=)) @@ -89,6 +91,11 @@ -- | Insert or replace one exact blueprint migration receipt. Replacement is -- performed in place, while adding a v5-only receipt upgrades the manifest -- version and preserves every unrelated field. +-- +-- The receipt's 'outcome' is deliberately excluded from the edge comparison, +-- which is the one place it is left out of one. An edge that reported itself +-- not applicable and later runs for real must replace its earlier receipt, not +-- accumulate a second one for the same edge. writeAppliedBlueprintMigration :: AppliedBlueprintMigration -> Manifest -> Manifest writeAppliedBlueprintMigration receipt manifest = Manifest @@ -104,7 +111,8 @@ } where sameEdge existing = - existing ^. #name == receipt ^. #name + sameArtifactIdentity (existing ^. #origin) (receipt ^. #origin) + && existing ^. #name == receipt ^. #name && existing ^. #fromVersion == receipt ^. #fromVersion && existing ^. #toVersion == (receipt ^. #toVersion) @@ -112,12 +120,26 @@ | any sameEdge receipts = map (\existing -> if sameEdge existing then receipt else existing) receipts | otherwise = receipts <> [receipt] --- | Whether one exact blueprint migration edge already has a receipt. -hasAppliedBlueprintMigration :: ModuleName -> Text -> Text -> Manifest -> Bool -hasAppliedBlueprintMigration blueprintName fromVersion toVersion manifest = +-- | Whether one exact blueprint migration edge has been applied. +-- +-- The edge is identified by the origin and name of the blueprint that owns it +-- together with its @from@ and @to@ versions, and only a receipt whose outcome +-- is 'MigrationApplied' counts — matching the completion key +-- 'Seihou.CLI.BlueprintMigration.pendingBlueprintMigrations' applies when it +-- decides what is still pending. The two must agree, or an edge could be +-- reported here as done while the planner still schedules it. +-- +-- This is deliberately a different comparison from +-- 'writeAppliedBlueprintMigration'’s: that one identifies the edge in order to +-- upsert its receipt and so ignores the outcome, while this one answers +-- whether the work happened. +hasAppliedBlueprintMigration :: ArtifactOrigin -> ModuleName -> Text -> Text -> Manifest -> Bool +hasAppliedBlueprintMigration blueprintOrigin blueprintName fromVersion toVersion manifest = any ( \receipt -> - receipt ^. #name == blueprintName + receipt ^. #outcome == MigrationApplied + && sameArtifactIdentity (receipt ^. #origin) blueprintOrigin + && receipt ^. #name == blueprintName && receipt ^. #fromVersion == fromVersion && receipt ^. #toVersion == toVersion ) @@ -242,6 +264,22 @@ artifactOriginName (LocalOrigin artifact) = artifact artifactOriginName (ProjectOrigin path) = T.pack (takeFileName path) +-- | The origin to use for a record written before 'ArtifactOrigin' reached the +-- agent-applied records — the blueprint, blueprint-migration and recipe +-- entries, all of which carried a bare name until +-- docs\/plans\/81-record-artifact-origin-for-agent-applied-artifacts.md. +-- +-- Where the artifact actually came from is genuinely unrecoverable: nothing on +-- disk says which repository a receipt written last month was resolved from. +-- 'LocalOrigin' is the constructor that already means "provenance seihou +-- cannot verify", so decoding to it is honest rather than a fabrication, and +-- it keeps every older manifest readable without an explicit conversion pass +-- (see docs\/adr\/0005-legacy-manifests-convert-through-an-explicit-command.md, +-- whose explicit-command rule exists for conversions that lose or relocate +-- information; this one loses nothing). +legacyLocalOrigin :: Text -> Maybe ArtifactOrigin -> ArtifactOrigin +legacyLocalOrigin recordedName = fromMaybe (LocalOrigin recordedName) + instance ToJSON AppliedInstanceState where toJSON state = Aeson.object $ @@ -325,21 +363,24 @@ toJSON ar = Aeson.object $ [ "name" .= (ar ^. #name . #unRecipeName), + "origin" .= (ar ^. #origin), "appliedAt" .= (ar ^. #appliedAt) ] ++ maybe [] (\v -> ["version" .= v]) (ar ^. #recipeVersion) instance FromJSON AppliedRecipe where - parseJSON = Aeson.withObject "AppliedRecipe" $ \o -> - AppliedRecipe - <$> (RecipeName <$> o .: "name") - <*> o Aeson..:? "version" + parseJSON = Aeson.withObject "AppliedRecipe" $ \o -> do + name <- RecipeName <$> o .: "name" + origin <- legacyLocalOrigin (name ^. #unRecipeName) <$> o Aeson..:? "origin" + AppliedRecipe name origin + <$> o Aeson..:? "version" <*> o .: "appliedAt" instance ToJSON AppliedBlueprint where toJSON ab = Aeson.object $ [ "name" .= (ab ^. #name . #unModuleName), + "origin" .= (ab ^. #origin), "appliedAt" .= (ab ^. #appliedAt), "baselineModules" .= map (^. #unModuleName) (ab ^. #baselineModules), "noBaseline" .= (ab ^. #noBaseline) @@ -349,34 +390,68 @@ ++ maybe [] (\s -> ["agentSessionId" .= s]) (ab ^. #agentSessionId) instance FromJSON AppliedBlueprint where - parseJSON = Aeson.withObject "AppliedBlueprint" $ \o -> - AppliedBlueprint - <$> (ModuleName <$> o .: "name") - <*> o Aeson..:? "version" + parseJSON = Aeson.withObject "AppliedBlueprint" $ \o -> do + name <- ModuleName <$> o .: "name" + origin <- legacyLocalOrigin (name ^. #unModuleName) <$> o Aeson..:? "origin" + AppliedBlueprint name origin + <$> o Aeson..:? "version" <*> o .: "appliedAt" <*> (map ModuleName <$> o Aeson..:? "baselineModules" Aeson..!= []) <*> o Aeson..:? "noBaseline" Aeson..!= False <*> o Aeson..:? "userPrompt" <*> o Aeson..:? "agentSessionId" +-- | A nested object with a discriminator, matching 'ArtifactOrigin', because +-- the not-applicable case carries a reason and a bare string would have +-- nowhere to put it. +instance ToJSON MigrationOutcome where + toJSON MigrationApplied = + Aeson.object ["status" .= ("applied" :: Text)] + toJSON (MigrationNotApplicable reason) = + Aeson.object + [ "status" .= ("not-applicable" :: Text), + "reason" .= reason + ] + +instance FromJSON MigrationOutcome where + parseJSON = Aeson.withObject "MigrationOutcome" $ \o -> do + status <- o .: "status" :: Aeson.Parser Text + case status of + "applied" -> pure MigrationApplied + "not-applicable" -> MigrationNotApplicable <$> o Aeson..:? "reason" Aeson..!= unstatedReason + other -> fail ("unknown blueprint migration outcome: " <> T.unpack other) + +-- | Stand-in for a not-applicable outcome whose reason is missing. An edge +-- that reports itself skipped always supplies one, so this only covers a +-- hand-edited manifest. +unstatedReason :: Text +unstatedReason = "(no reason recorded)" + instance ToJSON AppliedBlueprintMigration where toJSON receipt = Aeson.object $ [ "name" .= (receipt ^. #name . #unModuleName), + "origin" .= (receipt ^. #origin), "from" .= (receipt ^. #fromVersion), "to" .= (receipt ^. #toVersion), + "outcome" .= (receipt ^. #outcome), "appliedAt" .= (receipt ^. #appliedAt) ] ++ maybe [] (\version -> ["version" .= version]) (receipt ^. #blueprintVersion) ++ maybe [] (\sessionId -> ["agentSessionId" .= sessionId]) (receipt ^. #agentSessionId) instance FromJSON AppliedBlueprintMigration where - parseJSON = Aeson.withObject "AppliedBlueprintMigration" $ \o -> - AppliedBlueprintMigration - <$> (ModuleName <$> o .: "name") - <*> o Aeson..:? "version" + parseJSON = Aeson.withObject "AppliedBlueprintMigration" $ \o -> do + name <- ModuleName <$> o .: "name" + origin <- legacyLocalOrigin (name ^. #unModuleName) <$> o Aeson..:? "origin" + AppliedBlueprintMigration name origin + <$> o Aeson..:? "version" <*> o .: "from" <*> o .: "to" + -- A receipt written before the field existed records an edge whose + -- session returned, which is exactly what 'MigrationApplied' means, so + -- reading it that way preserves its meaning rather than inventing one. + <*> o Aeson..:? "outcome" Aeson..!= MigrationApplied <*> o .: "appliedAt" <*> o Aeson..:? "agentSessionId" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -13,6 +13,7 @@ import Seihou.Core.CommandFingerprintSpec qualified as CommandFingerprintSpec import Seihou.Core.CommandVarSpec qualified as CommandVarSpec import Seihou.Core.ContextSpec qualified as ContextSpec +import Seihou.Core.EntailmentSpec qualified as EntailmentSpec import Seihou.Core.ExprSpec qualified as ExprSpec import Seihou.Core.InstallSpec qualified as InstallSpec import Seihou.Core.ListSpec qualified as ListSpec @@ -80,6 +81,7 @@ commandVarTests <- CommandVarSpec.tests typesTests <- TypesSpec.tests contextTests <- ContextSpec.tests + entailmentTests <- EntailmentSpec.tests exprTests <- ExprSpec.tests installTests <- InstallSpec.tests listTests <- ListSpec.tests @@ -128,4 +130,4 @@ manifestTypesTests <- ManifestTypesSpec.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, 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, 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]) diff --git a/test/Seihou/Core/BlueprintSpec.hs b/test/Seihou/Core/BlueprintSpec.hs --- a/test/Seihou/Core/BlueprintSpec.hs +++ b/test/Seihou/Core/BlueprintSpec.hs @@ -4,7 +4,12 @@ import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T -import Seihou.Core.Blueprint (checkBlueprintLaunch, checkBlueprintMigrations, validateBlueprintWith) +import Seihou.Core.Blueprint + ( checkBlueprintLaunch, + checkBlueprintMigrations, + checkBlueprintVersionProbe, + validateBlueprintWith, + ) import Seihou.Core.Migration (BlueprintMigration (..)) import Seihou.Core.Module (discoverRunnable) import Seihou.Core.Types @@ -49,6 +54,7 @@ [] [] Nothing + Nothing -- | Helpers to update individual 'Blueprint' fields without ambiguous -- record updates. Several @Blueprint@ fields collide by name with @@ -56,48 +62,52 @@ -- the ambiguity once and for all. withBlueprintName :: ModuleName -> Blueprint -> Blueprint withBlueprintName n b = - Blueprint n (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) + Blueprint n (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) (b ^. #versionProbe) withBlueprintVersion :: Maybe T.Text -> Blueprint -> Blueprint withBlueprintVersion v b = - Blueprint (b ^. #name) v (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) + Blueprint (b ^. #name) v (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) (b ^. #versionProbe) withBlueprintPrompt :: T.Text -> Blueprint -> Blueprint withBlueprintPrompt p b = - Blueprint (b ^. #name) (b ^. #version) (b ^. #description) p (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) + Blueprint (b ^. #name) (b ^. #version) (b ^. #description) p (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) (b ^. #versionProbe) withBlueprintVars :: [VarDecl] -> Blueprint -> Blueprint withBlueprintVars vs b = - Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) vs (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) + Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) vs (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) (b ^. #versionProbe) withBlueprintPrompts :: [Prompt] -> Blueprint -> Blueprint withBlueprintPrompts ps b = - Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) ps (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) + Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) ps (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) (b ^. #versionProbe) withBlueprintBaseModules :: [Dependency] -> Blueprint -> Blueprint withBlueprintBaseModules ds b = - Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) ds (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) + Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) ds (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) (b ^. #versionProbe) withBlueprintFiles :: [BlueprintFile] -> Blueprint -> Blueprint withBlueprintFiles fs b = - Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) fs (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) + Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) fs (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) (b ^. #versionProbe) withBlueprintAllowedTools :: Maybe [T.Text] -> Blueprint -> Blueprint withBlueprintAllowedTools at b = - Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) at (b ^. #tags) (b ^. #migrations) (b ^. #launch) + Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) at (b ^. #tags) (b ^. #migrations) (b ^. #launch) (b ^. #versionProbe) withBlueprintTags :: [T.Text] -> Blueprint -> Blueprint withBlueprintTags ts b = - Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) ts (b ^. #migrations) (b ^. #launch) + Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) ts (b ^. #migrations) (b ^. #launch) (b ^. #versionProbe) withBlueprintMigrations :: [BlueprintMigration] -> Blueprint -> Blueprint withBlueprintMigrations migrations b = - Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) migrations (b ^. #launch) + Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) migrations (b ^. #launch) (b ^. #versionProbe) withBlueprintLaunch :: Maybe AgentLaunch -> Blueprint -> Blueprint withBlueprintLaunch launch b = - Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) launch + Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) launch (b ^. #versionProbe) +withBlueprintVersionProbe :: Maybe T.Text -> Blueprint -> Blueprint +withBlueprintVersionProbe probe b = + Blueprint (b ^. #name) (b ^. #version) (b ^. #description) (b ^. #prompt) (b ^. #vars) (b ^. #prompts) (b ^. #baseModules) (b ^. #files) (b ^. #allowedTools) (b ^. #tags) (b ^. #migrations) (b ^. #launch) probe + spec :: Spec spec = do describe "evalBlueprintFromFile (sample fixture)" $ do @@ -115,8 +125,8 @@ (b ^. #baseModules) `shouldBe` [] length (b ^. #files) `shouldBe` 1 (b ^. #migrations) - `shouldBe` [ BlueprintMigration "1.0.0" "2.0.0" "Update {{project.name}} for the first library release.", - BlueprintMigration "2.5.0" "3.0.0" "Update {{project.name}} for the second library release." + `shouldBe` [ BlueprintMigration "1.0.0" "2.0.0" "Update {{project.name}} for the first library release." [], + BlueprintMigration "2.5.0" "3.0.0" "Update {{project.name}} for the second library release." [] ] it "decodes declared blueprint migrations in declaration order" $ do @@ -127,8 +137,8 @@ case result of Right b -> (b ^. #migrations) - `shouldBe` [ BlueprintMigration "1.0.0" "2.0.0" "first edge", - BlueprintMigration "2.5.0" "3.0.0" "second edge" + `shouldBe` [ BlueprintMigration "1.0.0" "2.0.0" "first edge" [], + BlueprintMigration "2.5.0" "3.0.0" "second edge" [] ] Left err -> expectationFailure ("Expected migrations to decode, got: " <> show err) @@ -180,6 +190,42 @@ } Left err -> expectationFailure ("Expected legacy launch to decode, got: " <> show err) + it "decodes a declared version probe" $ do + withSystemTempDirectory "seihou-blueprint-probe-decode" $ \tmpDir -> do + let path = tmpDir "blueprint.dhall" + writeFile path (sampleBlueprintWithVersionProbeDhall "probe-bp") + result <- evalBlueprintFromFile path + case result of + Right b -> (b ^. #versionProbe) `shouldBe` Just "jq -r .dependencies.payments package.json" + Left err -> expectationFailure ("Expected version probe to decode, got: " <> show err) + + -- Regression: blueprints authored against a schema pin that predates + -- @versionProbe@ must keep decoding. 'sampleBlueprintDhall' writes no + -- such key, so this exercises the decoder's 'withDefaults'. + it "decodes a blueprint with no version probe as Nothing" $ do + withSystemTempDirectory "seihou-blueprint-noprobe-decode" $ \tmpDir -> do + let path = tmpDir "blueprint.dhall" + writeFile path (sampleBlueprintDhall "no-probe-bp") + result <- evalBlueprintFromFile path + case result of + Right b -> (b ^. #versionProbe) `shouldBe` Nothing + Left err -> expectationFailure ("Expected blueprint to decode, got: " <> show err) + + describe "checkBlueprintVersionProbe" $ do + it "rejects a blank probe command" $ + checkBlueprintVersionProbe (withBlueprintVersionProbe (Just " ") goodBlueprint) + `shouldBe` ["versionProbe, if specified, must not be empty"] + + -- Validation runs on the author's machine and must execute nothing, so + -- anything non-blank is accepted; a probe that cannot run degrades to + -- requiring --to at migrate time. + it "accepts any non-blank command without running it" $ + checkBlueprintVersionProbe (withBlueprintVersionProbe (Just "definitely-not-installed --version") goodBlueprint) + `shouldBe` [] + + it "accepts a blueprint that declares no probe" $ + checkBlueprintVersionProbe goodBlueprint `shouldBe` [] + describe "validateBlueprintWith (sample fixture)" $ do it "accepts the sample-blueprint fixture" $ do cwd <- getCurrentDirectory @@ -275,26 +321,26 @@ other -> expectationFailure ("Expected ValidationError, got: " <> show other) it "rejects an empty migration prompt" $ do - let bad = withBlueprintMigrations [BlueprintMigration "1.0.0" "2.0.0" " "] goodBlueprint + let bad = withBlueprintMigrations [BlueprintMigration "1.0.0" "2.0.0" " " []] goodBlueprint checkBlueprintMigrations bad `shouldSatisfy` hasError "prompt must not be empty" it "rejects malformed migration versions" $ do - let bad = withBlueprintMigrations [BlueprintMigration "release-1" "next" "change"] goodBlueprint + let bad = withBlueprintMigrations [BlueprintMigration "release-1" "next" "change" []] goodBlueprint errors = checkBlueprintMigrations bad errors `shouldSatisfy` hasError "from version is not dotted numeric" errors `shouldSatisfy` hasError "to version is not dotted numeric" it "rejects migration edges that do not advance" $ do - let equalEdge = withBlueprintMigrations [BlueprintMigration "2.0.0" "2.0.0" "change"] goodBlueprint - reverseEdge = withBlueprintMigrations [BlueprintMigration "3.0.0" "2.0.0" "change"] goodBlueprint + let equalEdge = withBlueprintMigrations [BlueprintMigration "2.0.0" "2.0.0" "change" []] goodBlueprint + reverseEdge = withBlueprintMigrations [BlueprintMigration "3.0.0" "2.0.0" "change" []] goodBlueprint checkBlueprintMigrations equalEdge `shouldSatisfy` hasError "must advance versions" checkBlueprintMigrations reverseEdge `shouldSatisfy` hasError "must advance versions" it "rejects duplicate migration starts" $ do let bad = withBlueprintMigrations - [ BlueprintMigration "1.0.0" "2.0.0" "first", - BlueprintMigration "1.0.0" "3.0.0" "second" + [ BlueprintMigration "1.0.0" "2.0.0" "first" [], + BlueprintMigration "1.0.0" "3.0.0" "second" [] ] goodBlueprint checkBlueprintMigrations bad `shouldSatisfy` hasError "duplicate blueprint migration from version" @@ -507,6 +553,16 @@ " , effort = Some \"max\"", " , mode = Some \"reserved\"", " }", + "}" + ] + +-- | A blueprint declaring the shell command that reads its library's version +-- out of the consuming project. +sampleBlueprintWithVersionProbeDhall :: T.Text -> String +sampleBlueprintWithVersionProbeDhall n = + unlines $ + init (lines (sampleBlueprintDhall n)) + <> [ ", versionProbe = Some \"jq -r .dependencies.payments package.json\"", "}" ] diff --git a/test/Seihou/Core/EntailmentSpec.hs b/test/Seihou/Core/EntailmentSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/EntailmentSpec.hs @@ -0,0 +1,217 @@ +-- | Tests for 'expandEntailedEdges', the pure heart of blueprint migration +-- fan-out. It turns the edges a version window selected into the flat, ordered +-- list of steps a run actually performs, following each edge's declared +-- entailments into other blueprints. +-- +-- Most of the risk in the feature lives here: a subtle bug produces a +-- plausible-looking plan that runs the wrong work, in the wrong order, or +-- twice. +module Seihou.Core.EntailmentSpec (tests) where + +import Control.Lens ((^.)) +import Data.Generics.Labels () +import Data.Text (Text) +import Seihou.Core.Migration + ( BlueprintMigration (..), + BlueprintMigrationStep (..), + EntailedEdge (..), + EntailmentError (..), + EntailmentSite (..), + expandEntailedEdges, + ) +import Test.Hspec +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Migration entailment" spec + +spec :: Spec +spec = describe "expandEntailedEdges" $ do + it "leaves a step with no entailed edges alone" $ do + let step = ownedStep "keiro-upgrade" (edge "2.4.0" "3.0.0" []) + expandEntailedEdges (const Nothing) [step] `shouldBe` Right [step] + + -- The ordering rule the whole design rests on: the entailed edge is the + -- deeper change, and the declaring edge's guidance may assume it landed. + it "runs one entailed edge before the edge that declares it" $ do + let kirokuEdge = edge "1.9.0" "2.0.0" [] + keiroEdge = edge "2.4.0" "3.0.0" [EntailedEdge "kiroku-upgrade" "1.9.0" "2.0.0"] + declared = library [("kiroku-upgrade", [kirokuEdge])] + expandEntailedEdges declared [ownedStep "keiro-upgrade" keiroEdge] + `shouldBe` Right + [ entailedStep "kiroku-upgrade" kirokuEdge (EntailmentSite "keiro-upgrade" "2.4.0" "3.0.0"), + ownedStep "keiro-upgrade" keiroEdge + ] + + it "runs several entailed edges in declaration order, all before the declaring edge" $ do + let firstEdge = edge "1.0.0" "1.1.0" [] + secondEdge = edge "5.0.0" "6.0.0" [] + declaring = + edge + "2.4.0" + "3.0.0" + [ EntailedEdge "alpha" "1.0.0" "1.1.0", + EntailedEdge "beta" "5.0.0" "6.0.0" + ] + declared = library [("alpha", [firstEdge]), ("beta", [secondEdge])] + site = EntailmentSite "keiro-upgrade" "2.4.0" "3.0.0" + fmap (map label) (expandEntailedEdges declared [ownedStep "keiro-upgrade" declaring]) + `shouldBe` Right + [ "alpha 1.0.0 -> 1.1.0", + "beta 5.0.0 -> 6.0.0", + "keiro-upgrade 2.4.0 -> 3.0.0" + ] + -- and the middle step remembers what pulled it in + fmap (map (^. #entailedBy)) (expandEntailedEdges declared [ownedStep "keiro-upgrade" declaring]) + `shouldBe` Right [Just site, Just site, Nothing] + + -- Recursion is what lets a three-deep cohort work without every blueprint + -- knowing the whole graph. + it "expands transitive entailment depth first" $ do + let deepest = edge "0.1.0" "0.2.0" [] + middle = edge "1.9.0" "2.0.0" [EntailedEdge "shibuya" "0.1.0" "0.2.0"] + top = edge "2.4.0" "3.0.0" [EntailedEdge "kiroku-upgrade" "1.9.0" "2.0.0"] + declared = library [("kiroku-upgrade", [middle]), ("shibuya", [deepest])] + fmap (map label) (expandEntailedEdges declared [ownedStep "keiro-upgrade" top]) + `shouldBe` Right + [ "shibuya 0.1.0 -> 0.2.0", + "kiroku-upgrade 1.9.0 -> 2.0.0", + "keiro-upgrade 2.4.0 -> 3.0.0" + ] + + -- Two selected edges of one blueprint can both depend on the same upstream + -- edge. It is one piece of work and must run once. + it "emits a shared entailed edge only once" $ do + let shared = edge "1.9.0" "2.0.0" [] + earlier = edge "2.0.0" "2.4.0" [EntailedEdge "kiroku-upgrade" "1.9.0" "2.0.0"] + later = edge "2.4.0" "3.0.0" [EntailedEdge "kiroku-upgrade" "1.9.0" "2.0.0"] + declared = library [("kiroku-upgrade", [shared])] + fmap + (map label) + ( expandEntailedEdges + declared + [ownedStep "keiro-upgrade" earlier, ownedStep "keiro-upgrade" later] + ) + `shouldBe` Right + [ "kiroku-upgrade 1.9.0 -> 2.0.0", + "keiro-upgrade 2.0.0 -> 2.4.0", + "keiro-upgrade 2.4.0 -> 3.0.0" + ] + + -- The over-eager cycle check this test exists to catch keys on blueprint + -- name. Two blueprints may legitimately entail each other at *different* + -- edges, which is a chain, not a cycle. + it "does not mistake mutual entailment at different edges for a cycle" $ do + let kirokuEarly = edge "1.0.0" "1.5.0" [] + kirokuLate = edge "1.9.0" "2.0.0" [EntailedEdge "keiro-upgrade" "1.0.0" "2.0.0"] + keiroEarly = edge "1.0.0" "2.0.0" [EntailedEdge "kiroku-upgrade" "1.0.0" "1.5.0"] + keiroLate = edge "2.4.0" "3.0.0" [EntailedEdge "kiroku-upgrade" "1.9.0" "2.0.0"] + declared = + library + [ ("kiroku-upgrade", [kirokuEarly, kirokuLate]), + ("keiro-upgrade", [keiroEarly, keiroLate]) + ] + fmap (map label) (expandEntailedEdges declared [ownedStep "keiro-upgrade" keiroLate]) + `shouldBe` Right + [ "kiroku-upgrade 1.0.0 -> 1.5.0", + "keiro-upgrade 1.0.0 -> 2.0.0", + "kiroku-upgrade 1.9.0 -> 2.0.0", + "keiro-upgrade 2.4.0 -> 3.0.0" + ] + + it "reports a cycle with its chain rather than looping" $ do + let keiroEdge = edge "2.4.0" "3.0.0" [EntailedEdge "kiroku-upgrade" "1.9.0" "2.0.0"] + kirokuEdge = edge "1.9.0" "2.0.0" [EntailedEdge "keiro-upgrade" "2.4.0" "3.0.0"] + declared = + library [("keiro-upgrade", [keiroEdge]), ("kiroku-upgrade", [kirokuEdge])] + expandEntailedEdges declared [ownedStep "keiro-upgrade" keiroEdge] + `shouldBe` Left + ( EntailmentCycle + [ "keiro-upgrade 2.4.0 -> 3.0.0", + "kiroku-upgrade 1.9.0 -> 2.0.0", + "keiro-upgrade 2.4.0 -> 3.0.0" + ] + ) + + -- A cycle that does not include the edge the run started from. The reported + -- chain should begin where the repetition begins, not at the entry point. + it "reports a cycle deeper than the entry point from where it closes" $ do + let top = edge "2.4.0" "3.0.0" [EntailedEdge "kiroku-upgrade" "1.9.0" "2.0.0"] + kirokuEdge = edge "1.9.0" "2.0.0" [EntailedEdge "shibuya" "0.1.0" "0.2.0"] + shibuyaEdge = edge "0.1.0" "0.2.0" [EntailedEdge "kiroku-upgrade" "1.9.0" "2.0.0"] + declared = + library [("kiroku-upgrade", [kirokuEdge]), ("shibuya", [shibuyaEdge])] + expandEntailedEdges declared [ownedStep "keiro-upgrade" top] + `shouldBe` Left + ( EntailmentCycle + [ "kiroku-upgrade 1.9.0 -> 2.0.0", + "shibuya 0.1.0 -> 0.2.0", + "kiroku-upgrade 1.9.0 -> 2.0.0" + ] + ) + + -- Skipping an unresolvable member silently would leave a half-migrated + -- project with no signal, because the consumer does not know the cohort. + it "refuses when an entailed blueprint cannot be resolved" $ do + let keiroEdge = edge "2.4.0" "3.0.0" [EntailedEdge "kiroku-upgrade" "1.9.0" "2.0.0"] + expandEntailedEdges (const Nothing) [ownedStep "keiro-upgrade" keiroEdge] + `shouldBe` Left + ( EntailedBlueprintNotFound + (EntailmentSite "keiro-upgrade" "2.4.0" "3.0.0") + "kiroku-upgrade" + ) + + -- Entailment names one exact edge. Falling back to window planning inside + -- the entailed blueprint would let a release silently change which upstream + -- work it implies. + it "refuses when the entailed blueprint declares no such edge" $ do + let keiroEdge = edge "2.4.0" "3.0.0" [EntailedEdge "kiroku-upgrade" "1.9.0" "2.0.0"] + declared = + library [("kiroku-upgrade", [edge "1.0.0" "1.5.0" [], edge "1.5.0" "2.0.0" []])] + expandEntailedEdges declared [ownedStep "keiro-upgrade" keiroEdge] + `shouldBe` Left + ( EntailedEdgeNotDeclared + (EntailmentSite "keiro-upgrade" "2.4.0" "3.0.0") + "kiroku-upgrade" + "1.9.0" + "2.0.0" + ) + + it "matches an entailed edge on both ends of its window, not just its start" $ do + let keiroEdge = edge "2.4.0" "3.0.0" [EntailedEdge "kiroku-upgrade" "1.9.0" "2.0.0"] + declared = library [("kiroku-upgrade", [edge "1.9.0" "1.9.5" []])] + expandEntailedEdges declared [ownedStep "keiro-upgrade" keiroEdge] + `shouldSatisfy` \result -> case result of + Left (EntailedEdgeNotDeclared _ _ _ _) -> True + _ -> False + +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- + +edge :: Text -> Text -> [EntailedEdge] -> BlueprintMigration +edge fromVersion toVersion entailed = + BlueprintMigration + { from = fromVersion, + to = toVersion, + prompt = "migrate " <> fromVersion <> " -> " <> toVersion, + entails = entailed + } + +ownedStep :: Text -> BlueprintMigration -> BlueprintMigrationStep +ownedStep owner declared = + BlueprintMigrationStep {owner = owner, edge = declared, entailedBy = Nothing} + +entailedStep :: Text -> BlueprintMigration -> EntailmentSite -> BlueprintMigrationStep +entailedStep owner declared site = + BlueprintMigrationStep {owner = owner, edge = declared, entailedBy = Just site} + +-- | A stand-in for the blueprints a run has loaded off disk. +library :: [(Text, [BlueprintMigration])] -> Text -> Maybe [BlueprintMigration] +library table name = lookup name table + +-- | The shape a failure is easiest to read in: owner and window per step. +label :: BlueprintMigrationStep -> Text +label step = + step ^. #owner <> " " <> step ^. #edge . #from <> " -> " <> step ^. #edge . #to diff --git a/test/Seihou/Core/MigrationSpec.hs b/test/Seihou/Core/MigrationSpec.hs --- a/test/Seihou/Core/MigrationSpec.hs +++ b/test/Seihou/Core/MigrationSpec.hs @@ -6,6 +6,7 @@ import Seihou.Core.Migration ( BlueprintMigration (..), BlueprintMigrationPlan (..), + BlueprintMigrationStep (..), Migration (..), MigrationOp (..), MigrationPlan (..), @@ -162,15 +163,18 @@ describe "planBlueprintMigrationChain" $ do it "orders in-window migrations while allowing intentional gaps" $ do - let early = BlueprintMigration "1.0.0" "2.0.0" "first" - late = BlueprintMigration "2.5.0" "3.0.0" "second" + let early = BlueprintMigration "1.0.0" "2.0.0" "first" [] + late = BlueprintMigration "2.5.0" "3.0.0" "second" [] result = planBlueprintMigrationChain "demo" [late, early] (mkV "1.0.0") (mkV "3.0.0") case result of Right (Just plan) -> do (plan ^. #name) `shouldBe` "demo" (plan ^. #from) `shouldBe` mkV "1.0.0" (plan ^. #to) `shouldBe` mkV "3.0.0" - (plan ^. #steps) `shouldBe` [early, late] + -- Every window-selected edge is owned by the blueprint that was + -- planned; owners other than that one appear only after entailment + -- expansion. + (plan ^. #steps) `shouldBe` [ownedBy "demo" early, ownedBy "demo" late] other -> expectationFailure ("Expected ordered blueprint plan, got: " <> show other) it "returns Nothing for an equal version window" $ do @@ -182,20 +186,20 @@ `shouldBe` Left (MigrationDowngradeNotSupported (mkV "3.0.0") (mkV "2.0.0")) it "rejects an unparseable declared version" $ do - let migration = BlueprintMigration "release-1" "2.0.0" "change" + let migration = BlueprintMigration "release-1" "2.0.0" "change" [] planBlueprintMigrationChain "demo" [migration] (mkV "1.0.0") (mkV "2.0.0") `shouldBe` Left (MigrationVersionUnparseable "release-1") it "rejects duplicate starts" $ do - let first = BlueprintMigration "1.0.0" "2.0.0" "first" - second = BlueprintMigration "1.0.0" "1.5.0" "second" + let first = BlueprintMigration "1.0.0" "2.0.0" "first" [] + second = BlueprintMigration "1.0.0" "1.5.0" "second" [] result = planBlueprintMigrationChain "demo" [first, second] (mkV "1.0.0") (mkV "2.0.0") case result of Left (MigrationDuplicateEdge fromVersion _) -> fromVersion `shouldBe` mkV "1.0.0" other -> expectationFailure ("Expected duplicate blueprint edge error, got: " <> show other) it "skips an edge that overshoots the target" $ do - let migration = BlueprintMigration "1.0.0" "3.0.0" "too far" + let migration = BlueprintMigration "1.0.0" "3.0.0" "too far" [] result = planBlueprintMigrationChain "demo" [migration] (mkV "1.0.0") (mkV "2.0.0") case result of Right (Just plan) -> (plan ^. #steps) `shouldBe` [] @@ -209,3 +213,9 @@ mkV t = case parseVersion t of Just ver -> ver Nothing -> error ("MigrationSpec.mkV: bad version literal " <> show t) + +-- | A directly selected step: owned by the planned blueprint, entailed by +-- nothing. +ownedBy :: Text -> BlueprintMigration -> BlueprintMigrationStep +ownedBy owner edge = + BlueprintMigrationStep {owner = owner, edge = edge, entailedBy = Nothing} 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 @@ -34,13 +34,19 @@ mkBlueprintMigrationReceipt blueprintName fromVersion toVersion appliedAt = AppliedBlueprintMigration { name = ModuleName blueprintName, + origin = RemoteOrigin ("https://github.com/acme/" <> blueprintName) blueprintName Nothing, blueprintVersion = Just "0.4.0", fromVersion = fromVersion, toVersion = toVersion, + outcome = MigrationApplied, appliedAt = appliedAt, agentSessionId = Nothing } +-- | The identity the @payments@ blueprint carries in the receipt cases below. +paymentsOrigin :: ArtifactOrigin +paymentsOrigin = RemoteOrigin "https://github.com/acme/payments" "payments" Nothing + -- | Helper to set modules on a Manifest without ambiguous record update. withManifestModules :: [AppliedModule] -> Manifest -> Manifest withManifestModules mods m = @@ -145,11 +151,19 @@ ) & #applications %~ map (withCommandReceipts (Map.singleton receiptFingerprint receipt)) - & #recipe .~ Just (AppliedRecipe (RecipeName "haskell-service") (Just "3.1.0") fixedTime) + & #recipe + .~ Just + ( AppliedRecipe + (RecipeName "haskell-service") + (RemoteOrigin "https://github.com/acme/haskell-service" "haskell-service" Nothing) + (Just "3.1.0") + fixedTime + ) & #blueprint .~ Just ( AppliedBlueprint { name = ModuleName "service-blueprint", + origin = RemoteOrigin "https://github.com/acme/service-blueprint" "service-blueprint" Nothing, blueprintVersion = Just "2.0.0", appliedAt = fixedTime, baselineModules = [ModuleName "haskell-base"], @@ -508,6 +522,7 @@ let ab = AppliedBlueprint { name = ModuleName "payments-service", + origin = RemoteOrigin "https://github.com/acme/payments-service" "payments-service" Nothing, blueprintVersion = Just "0.3.1", appliedAt = fixedTime, baselineModules = [ModuleName "nix-flake", ModuleName "haskell-base"], @@ -521,6 +536,7 @@ let ab = AppliedBlueprint { name = ModuleName "lone-blueprint", + origin = LocalOrigin "lone-blueprint", blueprintVersion = Nothing, appliedAt = fixedTime, baselineModules = [], @@ -535,6 +551,7 @@ ab1 = AppliedBlueprint (ModuleName "first") + (LocalOrigin "first") Nothing fixedTime [] @@ -544,6 +561,7 @@ ab2 = AppliedBlueprint (ModuleName "second") + (LocalOrigin "second") (Just "1.0.0") fixedTime2 [ModuleName "x"] @@ -560,13 +578,28 @@ let receipt = AppliedBlueprintMigration (ModuleName "payments") + (RemoteOrigin "https://github.com/acme/payments" "payments" Nothing) (Just "0.4.0") "1.0.0" "2.0.0" + MigrationApplied fixedTime (Just "session-123") Aeson.eitherDecode (Aeson.encode receipt) `shouldBe` Right receipt + it "round-trips a not-applicable receipt with its reason" $ do + let receipt = + AppliedBlueprintMigration + (ModuleName "payments") + (RemoteOrigin "https://github.com/acme/payments" "payments" Nothing) + (Just "0.4.0") + "1.0.0" + "2.0.0" + (MigrationNotApplicable "the project has not adopted the bundle") + fixedTime + Nothing + Aeson.eitherDecode (Aeson.encode receipt) `shouldBe` Right receipt + it "round-trips a version-5 manifest containing a receipt" $ do let receipt = mkBlueprintMigrationReceipt "payments" "1.0.0" "2.0.0" fixedTime manifest = ((emptyManifest fixedTime) & #blueprintMigrations .~ [receipt]) @@ -578,17 +611,42 @@ replacement = AppliedBlueprintMigration (ModuleName "payments") + (RemoteOrigin "https://github.com/acme/payments" "payments" Nothing) (Just "0.5.0") "1.0.0" "2.0.0" + MigrationApplied fixedTime2 (Just "rerun") manifest1 = writeAppliedBlueprintMigration unrelated (writeAppliedBlueprintMigration first (emptyManifest fixedTime)) manifest2 = writeAppliedBlueprintMigration replacement manifest1 (manifest2 ^. #blueprintMigrations) `shouldBe` [replacement, unrelated] - hasAppliedBlueprintMigration "payments" "1.0.0" "2.0.0" manifest2 `shouldBe` True - hasAppliedBlueprintMigration "payments" "2.0.0" "3.0.0" manifest2 `shouldBe` False + hasAppliedBlueprintMigration paymentsOrigin "payments" "1.0.0" "2.0.0" manifest2 `shouldBe` True + hasAppliedBlueprintMigration paymentsOrigin "payments" "2.0.0" "3.0.0" manifest2 `shouldBe` False + -- A blueprint of the same name from another repository has its own + -- receipts, so the identical edge is not recorded for it. + hasAppliedBlueprintMigration + (RemoteOrigin "https://github.com/other/payments" "payments" Nothing) + "payments" + "1.0.0" + "2.0.0" + manifest2 + `shouldBe` False + -- The upsert key deliberately ignores the outcome, so a re-run replaces + -- the earlier record. The read side does not ignore it: an edge that + -- reported itself inapplicable has not been applied. + it "upserts across a change of outcome and reports the edge unapplied while it is skipped" $ do + let edge = mkBlueprintMigrationReceipt "payments" "1.0.0" "2.0.0" fixedTime + skipped = edge & #outcome .~ MigrationNotApplicable "no adr bundle" + applied = edge & #appliedAt .~ fixedTime2 + afterSkip = writeAppliedBlueprintMigration skipped (emptyManifest fixedTime) + afterApply = writeAppliedBlueprintMigration applied afterSkip + (afterSkip ^. #blueprintMigrations) `shouldBe` [skipped] + hasAppliedBlueprintMigration paymentsOrigin "payments" "1.0.0" "2.0.0" afterSkip `shouldBe` False + (afterApply ^. #blueprintMigrations) `shouldBe` [applied] + hasAppliedBlueprintMigration paymentsOrigin "payments" "1.0.0" "2.0.0" afterApply `shouldBe` True + it "preserves modules, applications, files, recipe, and normal blueprint provenance" $ do let appliedModule = AppliedModule "base" emptyParentVars (LocalOrigin "base") (Just "1.0.0") fixedTime Nothing application = @@ -605,8 +663,8 @@ appliedAt = fixedTime } fileRecord = FileRecord (SHA256 "hash") "base" Template fixedTime Nothing mempty - recipe = AppliedRecipe "recipe" (Just "1.0.0") fixedTime - normalBlueprint = AppliedBlueprint "payments" (Just "0.4.0") fixedTime [] False Nothing Nothing + recipe = AppliedRecipe "recipe" (LocalOrigin "recipe") (Just "1.0.0") fixedTime + normalBlueprint = AppliedBlueprint "payments" (LocalOrigin "payments") (Just "0.4.0") fixedTime [] False Nothing Nothing seed = ( (emptyManifest fixedTime) & #modules .~ [appliedModule]