seihou-core 0.6.0.0 → 0.7.0.0

raw patch · 12 files changed

+946/−75 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• seihou-core.cabal +3/−1
• src/Seihou/Core/ArtifactIdentity.hs +77/−0
• src/Seihou/Core/Blueprint.hs +103/−2
• src/Seihou/Core/Migration.hs +193/−3
• src/Seihou/Core/Types.hs +63/−4
• src/Seihou/Dhall/Eval.hs +37/−13
• src/Seihou/Manifest/Types.hs +92/−17
• test/Main.hs +3/−1
• test/Seihou/Core/BlueprintSpec.hs +78/−22
• test/Seihou/Core/EntailmentSpec.hs +217/−0
• test/Seihou/Core/MigrationSpec.hs +17/−7
• test/Seihou/Manifest/TypesSpec.hs +63/−5

@@ -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

@@ -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

@@ -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)+  ]

@@ -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

@@ -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)   }

@@ -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'.

@@ -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" 

@@ -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])

@@ -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\"",            "}"          ] 

@@ -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

@@ -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}

@@ -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]