seihou-cli 0.12.0.1 → 0.12.1.0
raw patch · 9 files changed
+419/−64 lines, 9 filesdep ~seihou-corePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: seihou-core
API changes (from Hackage documentation)
+ Seihou.CLI.CommandExecution: expectedCommandReceipts :: UTCTime -> CommandPlan -> [CommandReceipt]
+ Seihou.CLI.CommandExecution: withReceiptWithdrawal :: IO () -> IO (Either CommandExecutionError a) -> IO (Either CommandExecutionError a)
Files
- data/module-reference.md +3/−0
- help/update.md +7/−3
- seihou-cli.cabal +5/−4
- src-exe/Seihou/CLI/Run.hs +70/−29
- src/Seihou/CLI/CommandExecution.hs +43/−6
- src/Seihou/CLI/Update.hs +55/−21
- test/Main.hs +3/−1
- test/Seihou/CLI/CommandExecutionSpec.hs +72/−0
- test/Seihou/CLI/CommandReceiptE2ESpec.hs +161/−0
data/module-reference.md view
@@ -70,6 +70,9 @@ resolved checkout subset stored in manifest schema 10, without module/configuration resolution or receipts. Repeated sync reruns all of it. Commit scripts needed by these commands as project assets; never depend on a producer cache path.+Run and update write a phase's application receipts into the manifest before its+first command starts, so a command may commit the project (`git add -A && git+commit`) and capture a complete manifest; failure or interrupt withdraws them. Checkout working directories must be real project-relative directories already present in a receiving clone, with no symlink ancestors. Sync preflights all links
help/update.md view
@@ -132,8 +132,10 @@ A true no-op executes neither lifecycle; use sync to repeat recorded local setup. --run-all-commands explicitly makes command execution actionable; --no-commands suppresses both lifecycles while retaining checkout declarations. Those flags- are mutually exclusive. Only application commands receive success receipts,- published after the entire phase succeeds.+ are mutually exclusive. Only application commands receive success receipts.+ They are written to the manifest before the first command starts, so a+ command that commits the project captures them and leaves a clean tree; a+ failure or interrupt rolls the manifest back with the rest of the update. PREVIEW, AUTOMATION, AND COMMITS @@ -151,7 +153,9 @@ Before mutation, Seihou checks that the manifest, project files, and staged sources still match the accepted plan. Managed migrations, files, baseline blobs, installed-cache entries, and the manifest are protected by recovery- journals. The manifest is the final publication marker.+ journals. Commit markers, set after the command phase, are the final+ publication step; until then a failure, interrupt or crash rolls back files,+ install cache and the journaled manifest copy together. External effects from module or migration shell commands cannot be undone. A failure reports that limitation instead of claiming a full rollback.
seihou-cli.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-cli-version: 0.12.0.1+version: 0.12.1.0 synopsis: CLI for Seihou project scaffolding description: Command-line interface for Seihou, a composable project scaffolding@@ -144,7 +144,7 @@ generic-lens >=2.2 && <3, lens >=5.2 && <6, process >=1.6 && <2,- seihou-core ^>=0.12.0.1,+ seihou-core ^>=0.12.1.0, streamly-core >=0.3 && <0.5, temporary >=1.3 && <2, text >=2.0 && <3,@@ -232,7 +232,7 @@ optparse-applicative >=0.18 && <1, process >=1.6 && <2, seihou-cli-internal,- seihou-core ^>=0.12.0.1,+ seihou-core ^>=0.12.1.0, temporary >=1.3 && <2, text >=2.0 && <3, time >=1.12 && <2,@@ -268,6 +268,7 @@ Seihou.CLI.CheckoutSyncE2ESpec Seihou.CLI.CheckoutSyncSpec Seihou.CLI.CommandExecutionSpec+ Seihou.CLI.CommandReceiptE2ESpec Seihou.CLI.CommitMessageSpec Seihou.CLI.DiffSpec Seihou.CLI.ExtensionSpec@@ -327,7 +328,7 @@ lens >=5.2 && <6, process >=1.6 && <2, seihou-cli-internal,- seihou-core ^>=0.12.0.1,+ seihou-core ^>=0.12.1.0, streamly-core >=0.3 && <0.5, tasty >=1.4 && <2, tasty-hspec >=1.2 && <2,
src-exe/Seihou/CLI/Run.hs view
@@ -6,6 +6,7 @@ import Control.Exception (IOException, displayException, try) import Control.Monad (foldM, forM_, unless, when) import Data.Generics.Labels ()+import Data.IORef (newIORef, readIORef, writeIORef) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, isJust) import Data.Set qualified as Set@@ -22,8 +23,10 @@ CommandPolicy (..), PlannedCommand (..), executeCommandPlanWithOutput,+ expectedCommandReceipts, finalizeCommandReceipts, planCommands,+ withReceiptWithdrawal, ) import Seihou.CLI.Commands (RunOpts (..)) import Seihou.CLI.CommitMessage (generateCommitMessage)@@ -325,6 +328,11 @@ -- Commands are planned against the previously accepted receipts for this -- exact top-level application. Ordinary run deliberately remains run-all; -- --no-commands disables execution while retaining matching old receipts.+ -- The receipts a successful phase will produce are known before it runs,+ -- so the manifest written before the phase already carries them: a module+ -- command that commits the project then captures a complete manifest. The+ -- candidate set is what the manifest must fall back to if the phase fails.+ -- See docs/adr/0023-command-receipts-are-published-before-the-command-phase-runs.md. -- What lands in the manifest must mean the same thing on every machine, so -- each artifact's discovery directory is classified into a portable origin -- before it is recorded. See docs/adr/0001-manifest-is-a-checked-in-machine-independent-artifact.md.@@ -350,6 +358,8 @@ commandPlan = planCommands commandPolicy priorCommandReceipts ops candidateCommandReceipts = finalizeCommandReceipts commandPlan [] priorCommandReceipts+ expectedCommandReceiptMap =+ finalizeCommandReceipts commandPlan (expectedCommandReceipts now commandPlan) priorCommandReceipts let recordedRecipe = fmap (const (Map.map (varValueToText . (^. #value)) recipeResolved)) recipeInfo let declarationApplication =@@ -505,7 +515,7 @@ & #recipeInputs .~ recordedRecipe & #commandReceipts- .~ candidateCommandReceipts+ .~ expectedCommandReceiptMap & #checkoutCommands .~ checkoutCommandsFromOperations ops )@@ -587,22 +597,41 @@ <> T.pack (show nUnch) <> " unchanged." - -- Execute commands after file generation. The command library- -- returns candidate receipts only when the entire phase- -- succeeds, so a failed run leaves the candidate manifest with- -- no newly-minted success evidence.+ -- Execute commands after file generation. The manifest written+ -- above already holds the receipts a successful phase earns; a+ -- failed or interrupted phase withdraws them, leaving the+ -- manifest with no newly-minted success evidence. forM_ (commandPlan ^. #commands) $ \planned -> when (planned ^. #disposition == CommandWillRun) $ logIO level (logDebug $ " run " <> plannedCommandText planned)+ let receiptsPublished = expectedCommandReceiptMap /= candidateCommandReceipts+ receiptsWithdrawn <- newIORef False+ let withdrawReceipts = when receiptsPublished $ do+ withdrawAttempt <-+ try @IOException $+ runEff $+ runFilesystem $+ runManifestStore manifestPath $+ writeManifest (setApplicationCommandReceipts currentApplicationId candidateCommandReceipts newManifest)+ case withdrawAttempt of+ Left err ->+ logIO level $+ logError $+ "Could not withdraw this run's command receipts from "+ <> T.pack manifestPath+ <> ": "+ <> T.pack (displayException err)+ Right () -> writeIORef receiptsWithdrawn True commandResult <-- runEff $- runProcessIO $- executeCommandPlanWithOutput- now- ( \_ commandStdout _ ->- when (not (T.null commandStdout)) (liftIO $ TIO.putStr commandStdout)- )- commandPlan+ withReceiptWithdrawal withdrawReceipts $+ runEff $+ runProcessIO $+ executeCommandPlanWithOutput+ now+ ( \_ commandStdout _ ->+ when (not (T.null commandStdout)) (liftIO $ TIO.putStr commandStdout)+ )+ commandPlan completedReceipts <- case commandResult of Right receipts -> pure receipts Left commandError -> do@@ -617,26 +646,38 @@ if isCheckoutCommand (commandError ^. #command . #operation) then TIO.putStrLn "Accepted checkout declarations remain recorded. Correct the failure and retry seihou sync; ordinary application commands are not retried by sync." else TIO.putStrLn ("Ordinary application commands are not retried by sync. Correct the failure and rerun seihou run " <> modName ^. #unModuleName <> "; accepted checkout declarations remain recorded.")+ withdrawn <- readIORef receiptsWithdrawn+ when withdrawn $+ TIO.putStrLn+ ( "The command receipts this run published in advance were withdrawn from "+ <> T.pack manifestPath+ <> ". If a command in this run committed or pushed the manifest, that snapshot records receipts for commands that did not complete; rerun seihou run "+ <> modName ^. #unModuleName+ <> " after correcting the failure and commit the result."+ ) exitFailure + -- The receipts were published before the phase. Rewrite the+ -- manifest only if the phase's actual receipts differ from that+ -- expectation, which would indicate a bug in+ -- expectedCommandReceipts rather than an expected path. let finalCommandReceipts = finalizeCommandReceipts commandPlan completedReceipts priorCommandReceipts- receiptManifest =- setApplicationCommandReceipts- currentApplicationId- finalCommandReceipts- newManifest- receiptWriteAttempt <-- try @IOException $- runEff $- runFilesystem $- runManifestStore manifestPath $- writeManifest receiptManifest- case receiptWriteAttempt of- Left err -> do- logIO level $ logError $ "Commands succeeded but their receipts could not be recorded: " <> T.pack (displayException err)- exitFailure- Right () -> pure ()+ if finalCommandReceipts == expectedCommandReceiptMap+ then logIO level (logDebug "Command receipts published before the command phase were confirmed.")+ else do+ logIO level (logDebug "Command receipts differed from those published before the command phase; rewriting the manifest.")+ receiptWriteAttempt <-+ try @IOException $+ runEff $+ runFilesystem $+ runManifestStore manifestPath $+ writeManifest (setApplicationCommandReceipts currentApplicationId finalCommandReceipts newManifest)+ case receiptWriteAttempt of+ Left err -> do+ logIO level $ logError $ "Commands succeeded but their receipts could not be recorded: " <> T.pack (displayException err)+ exitFailure+ Right () -> pure () -- Commit generated files if --commit or --commit-message when (runOpts ^. #commit || isJust (runOpts ^. #commitMessage)) $ do
src/Seihou/CLI/CommandExecution.hs view
@@ -10,6 +10,8 @@ summarizeCommandPlan, executeCommandPlan, executeCommandPlanWithOutput,+ expectedCommandReceipts,+ withReceiptWithdrawal, finalizeCommandReceipts, CommandOutcome (..), CommandOutcomeStatus (..),@@ -19,8 +21,8 @@ ) where -import Control.Exception (IOException, displayException, try)-import Control.Monad (forM, forM_, when)+import Control.Exception (IOException, SomeException, displayException, onException, try)+import Control.Monad (forM, forM_, void, when) import Data.Generics.Labels () import Data.List (find) import Data.Map.Strict qualified as Map@@ -231,10 +233,45 @@ where receipt outcome | outcome ^. #status /= CommandSucceeded = Nothing- | isCheckoutCommand (outcome ^. #command . #operation) = Nothing- | otherwise = case outcome ^. #command . #operation of- RunCommandOp {moduleName, command, workDir} -> Just (CommandReceipt (outcome ^. #command . #fingerprint) moduleName command workDir completedAt)- _ -> Nothing+ | otherwise = plannedReceipt completedAt (outcome ^. #command)++-- | The receipts 'executeCommandPlan' returns when every runnable command in+-- the plan succeeds, stamped with @completedAt@. Known before the first+-- command runs, because fingerprints and the stamp do not depend on execution.+expectedCommandReceipts :: UTCTime -> CommandPlan -> [CommandReceipt]+expectedCommandReceipts completedAt commandPlan =+ mapMaybe expected (commandPlan ^. #commands)+ where+ expected planned+ | planned ^. #disposition /= CommandWillRun = Nothing+ | otherwise = plannedReceipt completedAt planned++-- | The receipt a successful run of one planned command earns. Checkout+-- commands and non-command operations never earn one.+plannedReceipt :: UTCTime -> PlannedCommand -> Maybe CommandReceipt+plannedReceipt completedAt planned+ | isCheckoutCommand (planned ^. #operation) = Nothing+ | otherwise = case planned ^. #operation of+ RunCommandOp {moduleName, command, workDir} -> Just (CommandReceipt (planned ^. #fingerprint) moduleName command workDir completedAt)+ _ -> Nothing++-- | Run a command phase whose receipts were published in advance. If the+-- phase returns a failure or throws, run the withdrawal action first, then+-- return the failure or rethrow. The withdrawal runs at most once, and an+-- exception it throws is discarded so it never masks the phase's own outcome;+-- callers that want to report a failed withdrawal do so inside the action.+withReceiptWithdrawal ::+ IO () ->+ IO (Either CommandExecutionError a) ->+ IO (Either CommandExecutionError a)+withReceiptWithdrawal withdraw phase = do+ result <- phase `onException` withdrawQuietly+ case result of+ Left _ -> withdrawQuietly+ Right _ -> pure ()+ pure result+ where+ withdrawQuietly = void (try @SomeException withdraw) -- | Produce the accepted receipt map for the plan's current declaration set. -- Removed commands are dropped. Fresh successes replace old receipts;
src/Seihou/CLI/Update.hs view
@@ -19,7 +19,7 @@ ) where -import Control.Exception (SomeException, displayException, throwIO, toException, try)+import Control.Exception (SomeException, displayException, onException, throwIO, toException, try) import Control.Monad (foldM, forM, forM_, when) import Data.Aeson qualified as Aeson import Data.ByteString qualified as BS@@ -519,29 +519,55 @@ case linkResult of Left err -> abortUpdate transaction err Right checkoutWarnings -> do- commandResult <-- runEff $- runProcessIO $- executeCommandPlan now (plan ^. #commandPlan)- case commandResult of- Left err ->- abortUpdate- transaction- (UpdateCommandFailed err [ArbitraryCommandSideEffectsMayRemain])- Right completedReceipts -> do- let finalManifest = buildFinalManifest now plan filesManifest completedReceipts- markerResult <- setCommitMarkers transaction finalManifest- case markerResult of+ -- The manifest is published before the command+ -- phase, carrying the receipts a successful+ -- phase earns, and baselines it no longer+ -- references are set aside, so a command that+ -- commits the project captures both complete+ -- and leaves a clean tree. The commit+ -- markers are set only after the phase: until+ -- then a failure, an interrupt or a crash rolls+ -- back files, install cache and the journaled+ -- manifest copy together. See+ -- docs/adr/0023-command-receipts-are-published-before-the-command-phase-runs.md.+ let expectedManifest = buildFinalManifest now plan filesManifest (expectedCommandReceipts now (plan ^. #commandPlan))+ manifestPath = plan ^. #snapshot . #manifestPath+ publication <- publishCandidates (plan ^. #candidateArtifacts)+ case publication of+ Left err -> abortUpdate transaction err+ Right () -> do+ published <- writeManifestIO manifestPath expectedManifest+ setAside <- case published of+ Left err -> pure (Left err)+ Right () -> first UpdateTransactionFailed <$> setAsideUnreferencedBaselines transaction (manifestBaselineRefs expectedManifest)+ case setAside of Left err -> abortUpdate transaction err Right () -> do- publication <- publishCandidates (plan ^. #candidateArtifacts)- case publication of- Left err -> abortUpdate transaction err- Right () -> do- written <- writeManifestIO (plan ^. #snapshot . #manifestPath) finalManifest- case written of+ commandResult <-+ runEff (runProcessIO (executeCommandPlan now (plan ^. #commandPlan)))+ `onException` abandonUpdate transaction+ case commandResult of+ Left err ->+ abortUpdate+ transaction+ (UpdateCommandFailed err [ArbitraryCommandSideEffectsMayRemain])+ Right completedReceipts -> do+ -- A difference means expectedCommandReceipts+ -- disagrees with execution, a bug rather+ -- than an expected path; publish the+ -- receipts the phase actually earned.+ let finalManifest = buildFinalManifest now plan filesManifest completedReceipts+ corrected <-+ if finalManifest == expectedManifest+ then pure (Right ())+ else writeManifestIO manifestPath finalManifest+ case corrected of Left err -> abortUpdate transaction err- Right () -> finishCommitted transaction plan finalManifest checkoutWarnings+ Right () -> do+ markerResult <- setCommitMarkers transaction finalManifest+ case markerResult of+ Left err -> abortUpdate transaction err+ Right () -> finishCommitted transaction plan finalManifest checkoutWarnings planApplication :: UpdateRequest ->@@ -1358,6 +1384,14 @@ _ -> do manifest <- first (UpdateManifestUnreadable path . T.pack) (manifestFromJSON bytes) Right (document, manifest)++-- | Best-effort rollback while an exception (such as an interrupt) is+-- propagating. Anything left behind is recovered by the next update.+abandonUpdate :: UpdateTransaction -> IO ()+abandonUpdate transaction = do+ _ <- try @SomeException (restoreServiceBackups transaction)+ _ <- try @SomeException (rollbackUpdateTransaction transaction)+ pure () abortUpdate :: UpdateTransaction -> UpdateError -> IO (Either UpdateError a) abortUpdate transaction original = do
test/Main.hs view
@@ -17,6 +17,7 @@ import Seihou.CLI.CheckoutSyncE2ESpec qualified as CheckoutSyncE2ESpec import Seihou.CLI.CheckoutSyncSpec qualified as CheckoutSyncSpec import Seihou.CLI.CommandExecutionSpec qualified as CommandExecutionSpec+import Seihou.CLI.CommandReceiptE2ESpec qualified as CommandReceiptE2E import Seihou.CLI.CommitMessageSpec qualified as CommitMessageSpec import Seihou.CLI.DiffSpec qualified as DiffSpec import Seihou.CLI.ExtensionSpec qualified as ExtensionSpec@@ -115,4 +116,5 @@ validateRecipeTests <- ValidateRecipeE2E.tests recipeInputsTests <- RecipeInputsE2E.tests seedRunTests <- SeedRunE2E.tests- defaultMain (testGroup "seihou-cli" (validateRecipeTests : recipeInputsTests : seedUpdateTests : seedRunTests : tests))+ commandReceiptTests <- CommandReceiptE2E.tests+ defaultMain (testGroup "seihou-cli" (validateRecipeTests : recipeInputsTests : seedUpdateTests : seedRunTests : commandReceiptTests : tests))
test/Seihou/CLI/CommandExecutionSpec.hs view
@@ -1,6 +1,8 @@ module Seihou.CLI.CommandExecutionSpec (tests) where +import Control.Exception (AsyncException (UserInterrupt), throwIO, try) import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef) import Data.Map.Strict qualified as Map import Data.Maybe (fromJust) import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError)@@ -165,3 +167,73 @@ plan = planCommands DisableCommands prior [old, new] finalizeCommandReceipts plan [] prior `shouldBe` Map.singleton (oldReceipt ^. #fingerprint) oldReceipt++ describe "expectedCommandReceipts" $ do+ it "equals the receipts a fully successful execution returns" $ do+ let first = commandOp "echo first" Nothing "app" 0+ second = commandOp "echo second" (Just "subdir") "app" 0+ plan = planCommands RunAllCommands Map.empty [first, second]+ result <-+ runEff $+ runProcessPure [successMock "echo first", successMock "echo second"] $+ executeCommandPlan laterTime plan+ result `shouldBe` Right (expectedCommandReceipts laterTime plan)+ map (^. #fingerprint) (expectedCommandReceipts laterTime plan) `shouldBe` map fingerprintOf [first, second]++ it "yields no receipt for skipped, disabled, or checkout commands" $ do+ let unchanged = commandOp "echo unchanged" Nothing "app" 0+ checkout = RunCommandOp "echo checkout" Nothing "app" 0 CheckoutCommandLifecycle+ prior = Map.singleton (fingerprintOf unchanged) (receiptFor fixedTime unchanged)+ expectedCommandReceipts laterTime (planCommands RunChangedCommands prior [unchanged, checkout]) `shouldBe` []+ expectedCommandReceipts laterTime (planCommands DisableCommands Map.empty [unchanged]) `shouldBe` []++ it "finalizes to the same receipt map as a successful execution" $ do+ let unchanged = commandOp "echo unchanged" Nothing "app" 0+ changed = commandOp "echo changed" Nothing "app" 0+ removed = commandOp "echo removed" Nothing "app" 0+ prior =+ Map.fromList+ [ (fingerprintOf unchanged, receiptFor fixedTime unchanged),+ (fingerprintOf removed, receiptFor fixedTime removed)+ ]+ plan = planCommands RunChangedCommands prior [unchanged, changed]+ result <- runEff $ runProcessPure [successMock "echo changed"] $ executeCommandPlan laterTime plan+ case result of+ Right actual ->+ finalizeCommandReceipts plan (expectedCommandReceipts laterTime plan) prior+ `shouldBe` finalizeCommandReceipts plan actual prior+ Left err -> expectationFailure ("Expected success, got: " <> show err)++ describe "withReceiptWithdrawal" $ do+ let failing = commandOp "exit 7" Nothing "app" 0+ failure =+ CommandExecutionError+ { command = PlannedCommand failing (fingerprintOf failing) CommandWillRun,+ exitCode = 7,+ stdout = "",+ stderr = ""+ }++ it "does not withdraw after a successful phase" $ do+ withdrawals <- newIORef (0 :: Int)+ result <- withReceiptWithdrawal (modifyIORef' withdrawals (+ 1)) (pure (Right ()))+ result `shouldBe` Right ()+ readIORef withdrawals `shouldReturn` 0++ it "withdraws once and returns a failed phase unchanged" $ do+ withdrawals <- newIORef (0 :: Int)+ result <- withReceiptWithdrawal (modifyIORef' withdrawals (+ 1)) (pure (Left failure :: Either CommandExecutionError ()))+ result `shouldBe` Left failure+ readIORef withdrawals `shouldReturn` 1++ it "withdraws once and rethrows an interrupted phase" $ do+ withdrawals <- newIORef (0 :: Int)+ result <-+ try @AsyncException $+ withReceiptWithdrawal (modifyIORef' withdrawals (+ 1)) (throwIO UserInterrupt :: IO (Either CommandExecutionError ()))+ result `shouldBe` Left UserInterrupt+ readIORef withdrawals `shouldReturn` 1++ it "does not let a failing withdrawal mask the phase failure" $ do+ result <- withReceiptWithdrawal (ioError (userError "disk full")) (pure (Left failure :: Either CommandExecutionError ()))+ result `shouldBe` Left failure
+ test/Seihou/CLI/CommandReceiptE2ESpec.hs view
@@ -0,0 +1,161 @@+module Seihou.CLI.CommandReceiptE2ESpec (tests) where++import Control.Monad (filterM)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Text.IO qualified as TIO+import Seihou.CLI.SeedRunE2ESpec (body, invoke, prepare, readManifest, success)+import Seihou.CLI.SeihouBinary (seihouBinary)+import Seihou.CLI.UpdateSpec (UpdateFixture (..), prepareUpdateFixture)+import Seihou.Core.Types+import Seihou.Manifest.Types (manifestFromJSON)+import Seihou.Prelude+import System.Directory qualified as D+import System.Environment (getEnvironment)+import System.Exit (ExitCode (..))+import System.IO.Temp (withSystemTempDirectory)+import System.Process (CreateProcess (..), callProcess, proc, readCreateProcessWithExitCode, readProcess)+import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec (testSpec)++initCommand :: Text+initCommand = "git init -q -b master"++commitCommand :: Text+commitCommand = "git add -A && git -c user.name='Seihou Test' -c user.email=test@example.com -c commit.gpgsign=false commit -qm 'Initial commit'"++-- | Replace the demo module with a managed step and the given commands. The+-- fixture's HOME and XDG directories live inside the project, so ignore them+-- before any command snapshots the tree.+writeCommandModule :: FilePath -> FilePath -> [Text] -> IO ()+writeCommandModule root modul commands = do+ TIO.writeFile (root </> ".gitignore") "/home/\n/config/\n/cache/\n"+ TIO.writeFile (modul </> "module.dhall") (body "managed" (", commands = [" <> T.intercalate ", " (map command commands) <> "]"))+ where+ command text = "S.Command::{action = S.Command.Action.Apply \"" <> T.replace "\"" "\\\"" text <> "\"}"++demoReceipts :: Manifest -> [CommandReceipt]+demoReceipts manifest =+ concat+ [ Map.elems (application ^. #commandReceipts)+ | application <- manifest ^. #applications,+ application ^. #target == AppliedModuleTarget "demo"+ ]++-- | The manifest blob recorded at HEAD, as bytes and decoded.+committedManifest :: FilePath -> IO (BS.ByteString, Manifest)+committedManifest root = do+ blob <- readProcess "git" ["-C", root, "show", "HEAD:.seihou/manifest.json"] ""+ let bytes = TE.encodeUtf8 (T.pack blob)+ case manifestFromJSON (LBS.fromStrict bytes) of+ Left err -> fail err+ Right manifest -> pure (bytes, manifest)++-- | Turn the update fixture's project into a git repository, and publish a+-- 2.0.0 of @demo@ whose only command is @command@.+prepareCommandUpdate :: FilePath -> Text -> IO (FilePath, UpdateFixture)+prepareCommandUpdate root command = do+ fixture <- prepareUpdateFixture root+ binary <- seihouBinary+ let project = fixture ^. #projectRoot+ remote = fixture ^. #remote+ callProcess "git" ["-C", project, "init", "-q", "-b", "master"]+ callProcess "git" ["-C", project, "add", "-A"]+ callProcess "git" ["-C", project, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "-c", "commit.gpgsign=false", "commit", "-qm", "Adopt demo 1.0.0"]+ released <- TIO.readFile (remote </> "module.dhall")+ TIO.writeFile (remote </> "module.dhall") (T.replace "printf should-not-run >> command.log" command released)+ callProcess "git" ["-C", remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "-c", "commit.gpgsign=false", "commit", "-qam", "v2 command"]+ pure (binary, fixture)++runUpdate :: FilePath -> UpdateFixture -> [String] -> IO (ExitCode, Text)+runUpdate binary fixture args = do+ inherited <- getEnvironment+ let environment = ("XDG_CONFIG_HOME", fixture ^. #xdgHome) : filter ((/= "XDG_CONFIG_HOME") . fst) inherited+ (code, out, err) <- readCreateProcessWithExitCode (proc binary args) {cwd = Just (fixture ^. #projectRoot), env = Just environment} ""+ pure (code, T.pack (out <> err))++tests :: IO TestTree+tests = testSpec "command receipts end-to-end" $ do+ it "commits a complete manifest when a module command commits the project" $+ withSystemTempDirectory "receipt-run-commit" $ \root -> do+ (binary, modul) <- prepare root+ writeCommandModule root modul [initCommand, commitCommand]+ _ <- success binary root ["run", "demo"]+ readProcess "git" ["-C", root, "status", "--porcelain"] "" `shouldReturn` ""+ (committedBytes, committed) <- committedManifest root+ map (^. #command) (demoReceipts committed) `shouldMatchList` [initCommand, commitCommand]+ BS.readFile (root </> ".seihou/manifest.json") `shouldReturn` committedBytes+ withSystemTempDirectory "receipt-run-clone" $ \cloneParent -> do+ let clone = cloneParent </> "clone"+ callProcess "git" ["clone", "-q", root, clone]+ output <- success binary clone ["update", "demo", "--dry-run"]+ output `shouldSatisfy` T.isInfixOf "Already up to date."++ it "withdraws the published receipts when a later command fails" $+ withSystemTempDirectory "receipt-run-failure" $ \root -> do+ (binary, modul) <- prepare root+ writeCommandModule root modul [initCommand, commitCommand, "exit 7"]+ (code, out, err) <- invoke binary root ["run", "demo"]+ let output = T.pack (out <> err)+ code `shouldBe` ExitFailure 1+ output `shouldSatisfy` T.isInfixOf "Command failed (exit 7)"+ output `shouldSatisfy` T.isInfixOf "published in advance were withdrawn"+ onDisk <- readManifest root+ demoReceipts onDisk `shouldBe` []+ readProcess "git" ["-C", root, "status", "--porcelain"] "" `shouldReturn` " M .seihou/manifest.json\n"+ -- The accepted residual: the snapshot the commit took over-claims.+ (_, committed) <- committedManifest root+ length (demoReceipts committed) `shouldBe` 3++ it "keeps --no-commands and --dry-run behavior unchanged" $ do+ withSystemTempDirectory "receipt-run-disabled" $ \root -> do+ (binary, modul) <- prepare root+ writeCommandModule root modul [initCommand, commitCommand]+ _ <- success binary root ["run", "demo"]+ before <- demoReceipts <$> readManifest root+ length before `shouldBe` 2+ _ <- success binary root ["run", "demo", "--no-commands", "--force"]+ after <- demoReceipts <$> readManifest root+ after `shouldBe` before+ withSystemTempDirectory "receipt-run-dry" $ \root -> do+ (binary, modul) <- prepare root+ writeCommandModule root modul [initCommand, commitCommand]+ _ <- success binary root ["run", "demo", "--dry-run"]+ D.doesPathExist (root </> ".seihou/manifest.json") `shouldReturn` False+ D.doesPathExist (root </> ".git") `shouldReturn` False++ it "commits a complete manifest when an update's new command commits the project" $+ withSystemTempDirectory "receipt-update-commit" $ \root -> do+ let command = "git add -A && git -c user.name='Seihou Test' -c user.email=test@example.com -c commit.gpgsign=false commit -qm 'Adopt demo 2.0.0'"+ (binary, fixture) <- prepareCommandUpdate root command+ let project = fixture ^. #projectRoot+ (code, output) <- runUpdate binary fixture ["update", "demo", "--json"]+ code `shouldBe` ExitSuccess+ output `shouldSatisfy` T.isInfixOf "\"outcome\":\"applied\""+ readProcess "git" ["-C", project, "status", "--porcelain"] "" `shouldReturn` ""+ (committedBytes, committed) <- committedManifest project+ map (^. #command) (demoReceipts committed) `shouldBe` [command]+ map (^. #moduleVersion) (committed ^. #modules) `shouldBe` [Just "2.0.0"]+ BS.readFile (fixture ^. #manifestPath) `shouldReturn` committedBytes++ it "restores the pre-update manifest and files when an update's command fails" $+ withSystemTempDirectory "receipt-update-failure" $ \root -> do+ (binary, fixture) <- prepareCommandUpdate root "exit 7"+ let project = fixture ^. #projectRoot+ beforeManifest <- BS.readFile (fixture ^. #manifestPath)+ beforeReadme <- BS.readFile (fixture ^. #projectFile)+ (code, output) <- runUpdate binary fixture ["update", "demo", "--json"]+ code `shouldNotBe` ExitSuccess+ output `shouldSatisfy` T.isInfixOf "\"command_failed\""+ BS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest+ BS.readFile (fixture ^. #projectFile) `shouldReturn` beforeReadme+ let transactions = project </> ".seihou/transactions"+ exists <- D.doesDirectoryExist transactions+ entries <- if exists then D.listDirectory transactions else pure []+ leftovers <- filterM (D.doesDirectoryExist . (transactions </>)) entries+ leftovers `shouldBe` []