diff --git a/data/module-reference.md b/data/module-reference.md --- a/data/module-reference.md +++ b/data/module-reference.md @@ -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 diff --git a/help/update.md b/help/update.md --- a/help/update.md +++ b/help/update.md @@ -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. diff --git a/seihou-cli.cabal b/seihou-cli.cabal --- a/seihou-cli.cabal +++ b/seihou-cli.cabal @@ -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, diff --git a/src-exe/Seihou/CLI/Run.hs b/src-exe/Seihou/CLI/Run.hs --- a/src-exe/Seihou/CLI/Run.hs +++ b/src-exe/Seihou/CLI/Run.hs @@ -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 diff --git a/src/Seihou/CLI/CommandExecution.hs b/src/Seihou/CLI/CommandExecution.hs --- a/src/Seihou/CLI/CommandExecution.hs +++ b/src/Seihou/CLI/CommandExecution.hs @@ -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; diff --git a/src/Seihou/CLI/Update.hs b/src/Seihou/CLI/Update.hs --- a/src/Seihou/CLI/Update.hs +++ b/src/Seihou/CLI/Update.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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)) diff --git a/test/Seihou/CLI/CommandExecutionSpec.hs b/test/Seihou/CLI/CommandExecutionSpec.hs --- a/test/Seihou/CLI/CommandExecutionSpec.hs +++ b/test/Seihou/CLI/CommandExecutionSpec.hs @@ -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 diff --git a/test/Seihou/CLI/CommandReceiptE2ESpec.hs b/test/Seihou/CLI/CommandReceiptE2ESpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/CommandReceiptE2ESpec.hs @@ -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` []