hinagata-cli (empty) → 0.1.0.0

raw patch · 12 files changed

+1826/−0 lines, 12 filesdep +aesondep +asyncdep +base

Dependencies added: aeson, async, base, bytestring, directory, filepath, hinagata-core, hinagata-postgres, optparse-applicative, process, settei, settei-env, settei-optparse-applicative, settei-yaml, text, unix

Files

• CHANGELOG.md +21/−0
• LICENSE +28/−0
• app/Main.hs +290/−0
• hinagata-cli.cabal +105/−0
• src/Hinagata/Cli/Command.hs +145/−0
• src/Hinagata/Cli/Config.hs +206/−0
• src/Hinagata/Cli/Options.hs +144/−0
• src/Hinagata/Cli/Output.hs +317/−0
• src/Hinagata/Cli/Process.hs +303/−0
• src/Hinagata/Cli/Revision.hs +50/−0
• src/Hinagata/Cli/Validation.hs +43/−0
• test/Main.hs +174/−0

@@ -0,0 +1,21 @@+# Changelog++## 0.1.0.0 - 2026-10-18++### New Features++- Provide offline fixture planning, direct loading into an explicit target database, and fixture validation.+- Prepare reusable baselines; acquire, release, inspect, and clean leases; run commands within a scoped database lease.+- Load layered YAML, environment, and command-line configuration with schema descriptions, explanations, validation, shell completions, and JSON output.+- Supervise per-clone preparation commands and derive migration and verification revisions from declared content inputs.+- Pass explicit PostgreSQL connection variables and run and lease identifiers to service and test commands.++### Bug Fixes++- Honor explicit endpoints over ambient host addresses and prevent application handoff after failed preparation.+- Stop supervised commands on cancellation and preserve leases when child-process cleanup is uncertain.+- Report structured fixture failures across lifecycle commands without exposing secret values.++### Other Changes++- Include package changelog, description, repository metadata, required autogenerated-module declaration, and internal PVP dependency bounds.

@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2026, Hinagata contributors++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors+   may be used to endorse or promote products derived from this software without+   specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,290 @@+{-# LANGUAGE CPP #-}++module Main (main) where++import Control.Exception (IOException, catch, try)+import Data.List (sort)+import Data.Text qualified as Text+import Data.Text.IO qualified as TextIO+import Data.Version (showVersion)+import Hinagata.Cli.Command (compileScenario, prepareBaseline)+import Hinagata.Cli.Config+import Hinagata.Cli.Options+import Hinagata.Cli.Output+import Hinagata.Cli.Process (CancellationScope, ChildCleanupException (..), ChildFailure (..), ChildReport (..), ChildSpec (..), CommandCancelled (..), cancellationSignal, checkCancellation, runChild, withCancellationScope, withCommandCancellation)+import Hinagata.Cli.Validation (cancelledError, validateBatches)+import Hinagata.Config (AccessConfig (..), EndpointConfig (..), HinagataConfig (..))+import Hinagata.Connection (mkConnectionTarget)+import Hinagata.Fixture.Bundle+import Hinagata.Fixture.Types (mkFixtureName)+import Hinagata.Postgres.Cleanup (CleanupResult (..), CleanupSelection (..), applyCleanup, inspectLease, planCleanup, releaseLease)+import Hinagata.Postgres.Lease (LeaseError (..), LeaseInfo (..), LeaseOutcome (..), RetentionPolicy (..))+import Hinagata.Postgres.Load (loadInto)+import Hinagata.Postgres.Manager (withManagedDatabaseClassified, withManager)+import Hinagata.Postgres.Session (SessionOptions (..), defaultSessionOptions)+import Hinagata.Prelude ()+import Hinagata.Types (mkDatabaseName, positiveValue)+import Options.Applicative qualified as Options+import Options.Applicative.BashCompletion qualified as Completion+import Paths_hinagata_cli qualified as Package+import Settei qualified+import Settei.Optparse qualified as SetteiOptions+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.Environment (getProgName)+import System.Exit (ExitCode (..), exitWith)+import System.FilePath ((</>))+import System.IO (stderr)++main :: IO ()+main = do+  options <- Options.execParser (parserInfo ("hinagata " <> showVersion Package.version <> " (" <> buildRevision <> ")"))+  withCancellationScope $ \scope -> do+    completed <- try @ExitCode (withCommandCancellation scope (resolveAndDispatch scope options) `catch` \(CommandCancelled signal) -> abort (jsonOutput options) (cancelledError signal))+    signal <- cancellationSignal scope+    case signal of+      Just number -> exitWith (ExitFailure (128 + number))+      Nothing -> either exitWith pure completed++resolveAndDispatch :: CancellationScope -> CliOptions -> IO ()+resolveAndDispatch scope options =+  case command options of+    Just (Completions shell) -> do+      name <- getProgName+      putStr (completionScript shell name)+    _ -> case SetteiOptions.schemaDiagnostic (diagnosticMode options) (Settei.describe cliConfiguration) of+      Just output -> TextIO.putStr output+      Nothing -> do+        resolved <- resolveConfig options+        case resolved of+          Left failure -> reportConfigFailure options failure+          Right ((configuration, settings), result) -> do+            TextIO.hPutStr stderr (Settei.renderWarningsText (Settei.warnings result))+            case SetteiOptions.resolutionDiagnostic (diagnosticMode options) result of+              Just output -> TextIO.putStr output+              Nothing -> dispatch scope configuration settings options++dispatch :: CancellationScope -> HinagataConfig -> CliSettings -> CliOptions -> IO ()+dispatch scope configuration@HinagataConfig {fixtureRoot, bundleRoot, sqlSizeLimit, chunkSize} settings options = case command options of+  Just (FixturePlan roots jsonSelected) ->+    case traverse mkFixtureName roots of+      Left problem -> abort jsonSelected (CliError "options" "fixture_name_invalid" problem Nothing Nothing Nothing Nothing 2 Nothing Nothing Nothing Nothing)+      Right names -> do+        let bundle = BundleConfig fixtureRoot bundleRoot sqlSizeLimit chunkSize+        compiled <- compileFixtures bundle names+        case compiled of+          Left problem -> abort jsonSelected (bundleError problem)+          Right plan -> checkCancellation scope >> emitPlan jsonSelected plan+  Just (FixtureLoad roots databaseText jsonSelected) ->+    case (traverse mkFixtureName roots, mkDatabaseName databaseText) of+      (Left problem, _) -> abort jsonSelected (CliError "options" "fixture_name_invalid" problem Nothing Nothing Nothing Nothing 2 Nothing Nothing Nothing Nothing)+      (_, Left problem) -> abort jsonSelected (CliError "options" "target_database_invalid" problem Nothing Nothing Nothing Nothing 2 Nothing Nothing Nothing Nothing)+      (Right names, Right database) -> do+        let bundle = BundleConfig fixtureRoot bundleRoot sqlSizeLimit chunkSize+        compiled <- compileFixtures bundle names+        case compiled of+          Left problem -> abort jsonSelected (bundleError problem)+          Right plan -> do+            let EndpointConfig {host = serverHost, port = serverPort} = endpoint configuration+                AccessConfig {user = roleUser, password = rolePassword} = setup configuration+                sessionOptions = defaultSessionOptions {operationDeadlineMs = positiveValue (setupDeadlineMs configuration), statementDeadlineMs = positiveValue (setupDeadlineMs configuration)}+            case mkConnectionTarget serverHost serverPort roleUser database rolePassword of+              Left problem -> abort jsonSelected (CliError "options" "target_invalid" problem Nothing Nothing Nothing Nothing 2 Nothing Nothing Nothing Nothing)+              Right target -> do+                loaded <- loadInto target sessionOptions plan+                case loaded of+                  Left problem -> abort jsonSelected (loadError problem)+                  Right report -> checkCancellation scope >> emitLoad jsonSelected database report+  Just (FixtureValidate roots allSelected jsonSelected)+    | allSelected && not (null roots) -> abort jsonSelected (CliError "options" "validate_selection_invalid" "choose names or --all" Nothing Nothing Nothing Nothing 2 Nothing Nothing Nothing Nothing)+    | not allSelected && null roots -> abort jsonSelected (CliError "options" "validate_selection_required" "choose scenario names or --all" Nothing Nothing Nothing Nothing 2 Nothing Nothing Nothing Nothing)+    | otherwise -> do+        selected <- if allSelected then discoverScenarios fixtureRoot else pure roots+        if null selected+          then abort jsonSelected (CliError "options" "validate_selection_empty" "no scenario fixtures were found" Nothing Nothing Nothing Nothing 2 Nothing Nothing Nothing Nothing)+          else do+            prepared <- prepareBaseline scope configuration settings+            case prepared of+              Left problem -> abort jsonSelected problem+              Right (baseline, _) -> do+                let workerCount = max 1 (min (positiveValue (setupWorkers configuration)) (positiveValue (activeLeases configuration)))+                    validate manager name = do+                      checkCancellation scope+                      compiled <- compileScenario configuration [name]+                      case compiled of+                        Left problem -> pure (ValidationResult name (Left problem))+                        Right scenarioPlan -> do+                          completed <- withManagedDatabaseClassified manager baseline scenarioPlan ReleaseAlways (const False) (const (checkCancellation scope))+                          pure $ ValidationResult name $ case completed of+                            Left problem -> Left (leaseError "fixture-validate" (Just name) problem)+                            Right LeaseOutcome {cleanupDiagnostic = Just LeaseError {cause, sqlState}} -> Left (CliError "fixture-validate" "cleanup_failed" cause (Just name) Nothing sqlState Nothing 1 Nothing Nothing Nothing Nothing)+                            Right LeaseOutcome {timings} -> Right timings+                results <- withManager configuration $ \manager ->+                  validateBatches scope workerCount (validate manager) selected+                let failed = any (\ValidationResult {result} -> either (const True) (const False) result) results+                if failed then pure () else checkCancellation scope+                emitValidation jsonSelected results+                if failed then exitWith (ExitFailure 1) else pure ()+  Just (DbPrepare jsonSelected) -> do+    prepared <- prepareBaseline scope configuration settings+    either (abort jsonSelected) (\(_, report) -> checkCancellation scope >> emitPreparation jsonSelected report) prepared+  Just (DbAcquire roots jsonSelected) -> do+    scenario <- compileScenario configuration roots+    case scenario of+      Left problem -> abort jsonSelected problem+      Right scenarioPlan -> do+        prepared <- prepareBaseline scope configuration settings+        case prepared of+          Left problem -> abort jsonSelected problem+          Right (baseline, _) -> do+            acquired <- withManager configuration $ \manager ->+              withManagedDatabaseClassified manager baseline scenarioPlan DetachAlways (const False) (\info -> checkCancellation scope >> pure info)+            case acquired of+              Left problem -> abort jsonSelected (leaseError "lease-acquire" Nothing problem)+              Right LeaseOutcome {cleanupDiagnostic = Just LeaseError {cause, sqlState}} ->+                abort jsonSelected (CliError "lease-acquire" "lease_cleanup_failed" cause Nothing Nothing sqlState Nothing 1 Nothing Nothing Nothing Nothing)+              Right LeaseOutcome {leaseInfo, timings} -> checkCancellation scope >> emitAcquisition jsonSelected leaseInfo timings+  Just (DbWith _ _ jsonSelected []) -> abort jsonSelected (CliError "options" "program_required" "db with requires a program after --" Nothing Nothing Nothing Nothing 2 Nothing Nothing Nothing Nothing)+  Just (DbWith roots preserveOnFailure jsonSelected (program : programArguments)) -> do+    scenario <- compileScenario configuration roots+    case scenario of+      Left problem -> abort jsonSelected problem+      Right scenarioPlan -> do+        prepared <- prepareBaseline scope configuration settings+        case prepared of+          Left problem -> abort jsonSelected problem+          Right (baseline, _) -> do+            let policy = PreserveFailures+                classify result = case result of+                  Left ChildIdentityUnavailable -> True+                  Left ChildSpawnFailed -> preserveOnFailure+                  Right ChildReport {cleanupFailure = Just _} -> True+                  Right ChildReport {childExit = Just ExitSuccess, timedOut = False, cancelledBy = Nothing} -> False+                  Right _ -> preserveOnFailure+                run LeaseInfo {leaseId, runId, applicationTarget} = do+                  checkCancellation scope+                  let child =+                        ChildSpec+                          { executable = program,+                            arguments = programArguments,+                            workingDirectory = Nothing,+                            environment = [],+                            target = applicationTarget,+                            identifiers = Just (runId, leaseId),+                            deadlineMs = Nothing,+                            stdoutToStderr = jsonSelected+                          }+                  started <-+                    try @IOException+                      ( runChild scope child `catch` \ChildCleanupException -> do+                          signal <- cancellationSignal scope+                          pure (Right (ChildReport Nothing False signal (Just "child process cleanup uncertain")))+                      )+                  pure (either (const (Left ChildSpawnFailed)) id started)+            completed <- withManager configuration $ \manager ->+              withManagedDatabaseClassified manager baseline scenarioPlan policy classify run+            case completed of+              Left problem -> abort jsonSelected (leaseError "lease-acquire" Nothing problem)+              Right outcome -> do+                let status = withExitCode outcome+                if status == 0 then checkCancellation scope else pure ()+                emitWith jsonSelected outcome+                if status == 0 then pure () else exitWith (ExitFailure status)+  Just (Inspect identifier jsonSelected) -> do+    inspected <- inspectLease configuration identifier+    either (abort jsonSelected . cleanupError) (emitCandidate jsonSelected) inspected+  Just (DbRelease identifier jsonSelected) -> do+    released <- releaseLease configuration identifier+    case released of+      Left problem -> abort jsonSelected (cleanupError problem)+      Right outcome -> do+        emitCleanupResults jsonSelected [outcome]+        case outcome of+          Refused _ _ -> exitWith (ExitFailure 1)+          Skipped _ _ -> exitWith (ExitFailure 1)+          _ -> pure ()+  Just (Clean apply includeRetained identifiers jsonSelected)+    | not apply && (includeRetained || not (null identifiers)) ->+        abort jsonSelected (CliError "options" "clean_preview_options_invalid" "--id and --include-retained require --apply" Nothing Nothing Nothing Nothing 2 Nothing Nothing Nothing Nothing)+    | apply && null identifiers ->+        abort jsonSelected (CliError "options" "clean_selection_required" "--apply requires one or more --id selections" Nothing Nothing Nothing Nothing 2 Nothing Nothing Nothing Nothing)+    | includeRetained && null identifiers ->+        abort jsonSelected (CliError "options" "clean_retained_selection_required" "retained cleanup requires selected allocation IDs" Nothing Nothing Nothing Nothing 2 Nothing Nothing Nothing Nothing)+    | apply -> do+        let selection = if includeRetained then IncludeRetained else OrphansOnly+        applied <- applyCleanup configuration selection identifiers+        case applied of+          Left problem -> abort jsonSelected (cleanupError problem)+          Right outcomes -> do+            emitCleanupResults jsonSelected outcomes+            if any unsuccessful outcomes then exitWith (ExitFailure 1) else pure ()+    | otherwise -> do+        planned <- planCleanup configuration+        either (abort jsonSelected . cleanupError) (emitCleanupPlan jsonSelected) planned+  Nothing -> abort False (CliError "options" "command_required" "choose a command or configuration diagnostic" Nothing Nothing Nothing Nothing 2 Nothing Nothing Nothing Nothing)+  Just (Completions _) -> pure ()+  where+    unsuccessful (Refused _ _) = True+    unsuccessful (Skipped _ _) = True+    unsuccessful _ = False++reportConfigFailure :: CliOptions -> ConfigFailure -> IO ()+reportConfigFailure options failure = do+  let jsonSelected = jsonOutput options+      outcome = case failure of+        SourceFailure message -> CliError "configuration-source" "config_source_invalid" message Nothing Nothing Nothing Nothing 3 Nothing Nothing Nothing Nothing+        ResolutionFailure message _ -> CliError "configuration-resolution" "config_resolution_invalid" message Nothing Nothing Nothing Nothing 4 Nothing Nothing Nothing Nothing+  case failure of+    ResolutionFailure _ explanation -> TextIO.hPutStr stderr explanation+    _ -> pure ()+  abort jsonSelected outcome++jsonOutput :: CliOptions -> Bool+jsonOutput options = case command options of+  Just (FixturePlan _ selected) -> selected+  Just (FixtureLoad _ _ selected) -> selected+  Just (FixtureValidate _ _ selected) -> selected+  Just (DbPrepare selected) -> selected+  Just (DbAcquire _ selected) -> selected+  Just (DbWith _ _ selected _) -> selected+  Just (DbRelease _ selected) -> selected+  Just (Inspect _ selected) -> selected+  Just (Clean _ _ _ selected) -> selected+  _ -> False++abort :: Bool -> CliError -> IO a+abort jsonSelected failure = do+  emitError jsonSelected failure+  exitWith (ExitFailure (exitCode failure))++completionScript :: Shell -> String -> String+completionScript shell name = case shell of+  Bash -> Completion.bashCompletionScript name name+  Zsh -> Completion.zshCompletionScript name name+  Fish -> Completion.fishCompletionScript name name++discoverScenarios :: FilePath -> IO [Text.Text]+discoverScenarios root = do+  directoryExists <- doesDirectoryExist root+  if not directoryExists+    then pure []+    else do+      entries <- sort <$> listDirectory root+      included <- traverse hasFixture entries+      pure [Text.pack entry | (entry, True) <- zip entries included]+  where+    hasFixture entry = do+      let directory = root </> entry+      validDirectory <- doesDirectoryExist directory+      if not validDirectory+        then pure False+        else do+          yaml <- doesFileExist (directory </> "fixture.yaml")+          sql <- doesFileExist (directory </> "fixture.sql")+          pure (yaml || sql)++buildRevision :: String+#ifdef GIT_HASH+buildRevision = "revision " <> GIT_HASH+#else+buildRevision = "revision unavailable"+#endif

@@ -0,0 +1,105 @@+cabal-version: 3.12+name: hinagata-cli+version: 0.1.0.0+synopsis: Fixture planning and PostgreSQL lease commands for Hinagata+description: Plan and load fixtures, prepare reusable baselines, and manage isolated PostgreSQL database leases.+category: Testing+license: BSD-3-Clause+license-file: LICENSE+author: Nadeem Bitar+maintainer: nadeem@gmail.com+homepage: https://github.com/shinzui/hinagata+bug-reports: https://github.com/shinzui/hinagata/issues+extra-doc-files: CHANGELOG.md+build-type: Simple++common common+  default-language: GHC2024+  default-extensions:+    DeriveAnyClass+    DuplicateRecordFields+    OverloadedLabels+    OverloadedStrings++  ghc-options: -Wall++executable hinagata+  import: common+  ghc-options:+    -threaded+    -rtsopts++  hs-source-dirs:+    app+    src++  main-is: Main.hs+  other-modules:+    Hinagata.Cli.Command+    Hinagata.Cli.Config+    Hinagata.Cli.Options+    Hinagata.Cli.Output+    Hinagata.Cli.Process+    Hinagata.Cli.Revision+    Hinagata.Cli.Validation+    Paths_hinagata_cli++  autogen-modules: Paths_hinagata_cli+  build-depends:+    aeson >=2.2 && <2.4,+    async >=2.2.6 && <2.3,+    base >=4.21 && <5,+    bytestring >=0.12 && <0.14,+    directory >=1.3 && <1.4,+    filepath >=1.4 && <1.6,+    hinagata-core ^>=0.1.0.0,+    hinagata-postgres ^>=0.1.0.0,+    optparse-applicative >=0.19 && <0.20,+    process >=1.6.26 && <1.7,+    settei >=0.2 && <0.3,+    settei-env >=0.2 && <0.3,+    settei-optparse-applicative >=0.2 && <0.3,+    settei-yaml >=0.2 && <0.3,+    text >=2.1 && <2.3,+    unix >=2.8 && <2.9,++test-suite hinagata-cli-process-test+  import: common+  type: exitcode-stdio-1.0+  hs-source-dirs:+    test+    src++  main-is: Main.hs+  ghc-options: -threaded+  other-modules:+    Hinagata.Cli.Command+    Hinagata.Cli.Config+    Hinagata.Cli.Options+    Hinagata.Cli.Output+    Hinagata.Cli.Process+    Hinagata.Cli.Revision+    Hinagata.Cli.Validation++  build-depends:+    aeson >=2.2 && <2.4,+    async >=2.2.6 && <2.3,+    base >=4.21 && <5,+    bytestring >=0.12 && <0.14,+    directory >=1.3 && <1.4,+    filepath >=1.4 && <1.6,+    hinagata-core ^>=0.1.0.0,+    hinagata-postgres ^>=0.1.0.0,+    optparse-applicative >=0.19 && <0.20,+    process >=1.6.26 && <1.7,+    settei >=0.2 && <0.3,+    settei-env >=0.2 && <0.3,+    settei-optparse-applicative >=0.2 && <0.3,+    settei-yaml >=0.2 && <0.3,+    text >=2.1 && <2.3,+    unix >=2.8 && <2.9,++source-repository head+  type: git+  location: https://github.com/shinzui/hinagata.git+  subdir: hinagata-cli

@@ -0,0 +1,145 @@+-- | CLI assembly of frozen plans and executable hooks; SQL stays in the library.+module Hinagata.Cli.Command+  ( prepareBaseline,+    compileScenario,+    prepareBaselineWithRunner,+  )+where++import Control.Exception (Handler (..), IOException, catches, mask_, throwIO, try)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Text qualified as Text+import Hinagata.Cli.Config (CliSettings (..), HookSettings (..), validateHook)+import Hinagata.Cli.Output (CliError (..), baselineError, bundleError)+import Hinagata.Cli.Process (CancellationScope, ChildCleanupException (..), ChildFailure (..), ChildReport (..), ChildSpec (..), CommandCancelled (..), checkCancellation, parseOverlay, runChild, withCooperativeCancellation)+import Hinagata.Cli.Revision (captureHookRevision, effectiveRevision, verifyHookRevisions)+import Hinagata.Config (HinagataConfig (..))+import Hinagata.Connection (ConnectionTarget)+import Hinagata.Fixture.Bundle (BundleConfig (..), FixturePlan, compileFixtures)+import Hinagata.Fixture.Types (mkFixtureName)+import Hinagata.Postgres.Baseline (BaselineRef, BaselineSpec (..), PreparationReport, ensureBaseline)+import Hinagata.Postgres.Lease (PreparationFailure (..), PreparationFailureKind (..))+import System.Directory (getCurrentDirectory)+import System.Exit (ExitCode (..))++prepareBaseline :: CancellationScope -> HinagataConfig -> CliSettings -> IO (Either CliError (BaselineRef, PreparationReport))+prepareBaseline = prepareBaselineWithRunner runChild++-- | Internal runner injection for exercising supervision failure at the actual+-- library/CLI boundary without a public configuration bypass.+prepareBaselineWithRunner :: (CancellationScope -> ChildSpec -> IO (Either ChildFailure ChildReport)) -> CancellationScope -> HinagataConfig -> CliSettings -> IO (Either CliError (BaselineRef, PreparationReport))+prepareBaselineWithRunner runner scope configuration settings = do+  checkCancellation scope+  case traverse (uncurry validateHook) [("migration", migration settings), ("verification", verification settings), ("clone.preparation", clonePreparation settings)] of+    Left problem -> pure (Left (CliError "config-resolution" "config_resolution_invalid" problem Nothing Nothing Nothing Nothing 4 Nothing Nothing Nothing Nothing))+    Right _ -> do+      invocation <- getCurrentDirectory+      migrationIdentity <- captureHookRevision invocation "migration" (migration settings)+      verificationIdentity <- captureHookRevision invocation "verification" (verification settings)+      case (migrationIdentity, verificationIdentity) of+        (Left problem, _) -> pure (Left problem)+        (_, Left problem) -> pure (Left problem)+        (Right migrationCaptured, Right verificationCaptured) -> do+          let identities = [migrationCaptured, verificationCaptured]+          revisionFailure <- newIORef Nothing+          let checked hook target = do+                before <- verifyHookRevisions identities+                case before of+                  Left problem -> writeIORef revisionFailure (Just problem) >> pure (Left "hook revision inputs changed")+                  Right () -> do+                    outcome <- hook target+                    -- Preserve an original command or cleanup failure.+                    case outcome of+                      Left _ -> pure outcome+                      Right () -> do+                        after <- verifyHookRevisions identities+                        case after of+                          Left problem -> writeIORef revisionFailure (Just problem) >> pure (Left "hook revision inputs changed")+                          Right () -> pure (Right ())+              migrationHook = checked (hookRunner runner scope "migration" False (migration settings))+              verificationHook = checked (hookRunner runner scope "verification" False (verification settings))+              clonePreparationHook = case clonePreparation settings of+                HookSettings {executable = Nothing} -> Nothing+                _ -> Just (hookRunner runner scope "clone preparation" True (clonePreparation settings))+          compiled <- compileScenario configuration (baseFixtures settings)+          case compiled of+            Left problem -> pure (Left problem)+            Right basePlan -> do+              let specification =+                    BaselineSpec+                      { configuration,+                        basePlan,+                        migrationRevision = effectiveRevision migrationCaptured,+                        verificationRevision = effectiveRevision verificationCaptured,+                        requiredExtensions = [],+                        requiredLocale = Nothing,+                        migrationHook,+                        verificationHook,+                        clonePreparationHook,+                        compareAgainst = Nothing+                      }+              prepared <- ensureBaseline specification+              specific <- readIORef revisionFailure+              case prepared of+                Left problem -> pure (Left (maybe (baselineError problem) id specific))+                Right value -> do+                  final <- verifyHookRevisions identities+                  pure (value <$ final)++compileScenario :: HinagataConfig -> [Text.Text] -> IO (Either CliError FixturePlan)+compileScenario HinagataConfig {fixtureRoot, bundleRoot, sqlSizeLimit, chunkSize} roots =+  case traverse mkFixtureName roots of+    Left problem -> pure (Left (CliError "options" "fixture_name_invalid" problem Nothing Nothing Nothing Nothing 2 Nothing Nothing Nothing Nothing))+    Right names -> do+      compiled <- compileFixtures (BundleConfig fixtureRoot bundleRoot sqlSizeLimit chunkSize) names+      pure (either (Left . bundleError) Right compiled)++-- Keep the supervision outcome and its release-safety classification masked+-- together. Blocking process waits remain interruptible.+hookRunner :: (CancellationScope -> ChildSpec -> IO (Either ChildFailure ChildReport)) -> CancellationScope -> Text.Text -> Bool -> HookSettings -> ConnectionTarget -> IO (Either Text.Text ())+hookRunner runner scope name preparation HookSettings {executable, arguments, workingDirectory, environment, deadlineMs} target = case executable of+  Nothing -> checkCancellation scope >> pure (Right ())+  Just program -> do+    result <- withCooperativeCancellation scope $ mask_ $ runProgram program+    case result of+      Right () -> checkCancellation scope >> pure (Right ())+      Left problem -> pure (Left problem)+  where+    runProgram program = do+      let failWith kind safe =+            if preparation then throwIO (PreparationFailure kind safe) else pure (Left (name <> " hook failed: " <> Text.pack (show kind)))+          run = case parseOverlay environment of+            Left _ -> failWith PreparationSpawnFailed True+            Right overlay -> do+              attempted <-+                try @IOException $+                  runner+                    scope+                    ChildSpec+                      { executable = Text.unpack program,+                        arguments = map Text.unpack arguments,+                        workingDirectory = Text.unpack <$> workingDirectory,+                        environment = overlay,+                        target,+                        identifiers = Nothing,+                        deadlineMs = Just deadlineMs,+                        stdoutToStderr = True+                      }+              case attempted of+                Left _ -> failWith PreparationSpawnFailed True+                Right result -> case result of+                  Left ChildSpawnFailed -> failWith PreparationSpawnFailed True+                  Left ChildIdentityUnavailable -> failWith PreparationIdentityUnavailable False+                  Right ChildReport {cleanupFailure = Just _, cancelledBy = Just signal} -> failWith (PreparationCancelled signal) False+                  Right ChildReport {cleanupFailure = Just _, timedOut = True} -> failWith PreparationTimeout False+                  Right ChildReport {cleanupFailure = Just _, childExit = Just (ExitFailure status)} -> failWith (PreparationExit status) False+                  Right ChildReport {cleanupFailure = Just _} -> failWith PreparationCleanupFailed False+                  Right ChildReport {cancelledBy = Just signal} -> failWith (PreparationCancelled signal) True+                  Right ChildReport {timedOut = True} -> failWith PreparationTimeout True+                  Right ChildReport {childExit = Just ExitSuccess} -> checkCancellation scope >> pure (Right ())+                  Right ChildReport {childExit = Just (ExitFailure status)} -> failWith (PreparationExit status) True+                  Right _ -> failWith PreparationSpawnFailed True+      run+        `catches` [ Handler (\ChildCleanupException -> failWith PreparationCleanupFailed False),+                    Handler (\(CommandCancelled signal) -> failWith (PreparationCancelled signal) True)+                  ]

@@ -0,0 +1,206 @@+module Hinagata.Cli.Config+  ( ConfigFailure (..),+    CliSettings (..),+    HookSettings (..),+    cliConfiguration,+    resolveConfig,+    validateHook,+    revisionDeclarations,+  )+where++import Control.Monad (void)+import Data.Text qualified as Text+import Hinagata.Cli.Options (CliOptions (..))+import Hinagata.Cli.Process (parseOverlay)+import Hinagata.Config (HinagataConfig, hinagataConfig, hinagataEnvironmentBindings)+import Hinagata.Hook.Revision qualified as Revision+import Settei qualified+import Settei.Env qualified as Env+import Settei.Optparse qualified as SetteiOptions+import Settei.Yaml qualified as Yaml+import System.Environment (getEnvironment)+import System.FilePath (isAbsolute)+import Text.Read (readMaybe)++data ConfigFailure+  = SourceFailure !Text.Text+  | ResolutionFailure !Text.Text !Text.Text+  deriving stock (Eq, Show)++data HookSettings = HookSettings+  { executable :: !(Maybe Text.Text),+    arguments :: ![Text.Text],+    workingDirectory :: !(Maybe Text.Text),+    environment :: ![Text.Text],+    revision :: !(Maybe Text.Text),+    revisionExecutable :: !Bool,+    revisionInputs :: ![Text.Text],+    revisionValues :: ![Text.Text],+    deadlineMs :: !Int+  }+  deriving stock (Eq)++data CliSettings = CliSettings+  { baseFixtures :: ![Text.Text],+    migration :: !HookSettings,+    verification :: !HookSettings,+    clonePreparation :: !HookSettings+  }+  deriving stock (Eq)++cliConfiguration :: Settei.Config (HinagataConfig, CliSettings)+cliConfiguration = (,) <$> hinagataConfig <*> settings++settings :: Settei.Config CliSettings+settings =+  CliSettings+    <$> listSetting "baseline.fixtures" "Base fixtures loaded into every sealed template"+    <*> hookSettings "migration"+    <*> hookSettings "verification"+    <*> hookSettings "clone.preparation"++hookSettings :: Text.Text -> Settei.Config HookSettings+hookSettings prefix =+  HookSettings+    <$> optionalText (prefix <> ".executable") ("Executable to run against the " <> if prefix == "clone.preparation" then "fresh clone" else "baseline database")+    <*> secretListSetting (prefix <> ".argv") "Argument vector passed without shell evaluation"+    <*> optionalText (prefix <> ".cwd") "Working directory for the hook"+    <*> secretListSetting (prefix <> ".environment") "Explicit NAME=VALUE child environment overlay"+    <*> (if prefix == "clone.preparation" then pure Nothing else optionalText (prefix <> ".revision") "Declared revision identifying the hook's effects")+    <*> ( if prefix == "clone.preparation"+            then pure False+            else+              Settei.withDefault+                (Settei.publicShowSetting (settingKey (prefix <> ".revision_executable")) "Select absolute executable bytes for hook identity" Settei.boolDecoder)+                (Settei.constantDefault (Settei.RuleName (prefix <> "-revision-executable")) "Executable bytes are not selected" False)+        )+    <*> (if prefix == "clone.preparation" then pure [] else secretListSetting (prefix <> ".revision_inputs") "Named NAME=PATH content inputs for hook identity")+    <*> (if prefix == "clone.preparation" then pure [] else secretListSetting (prefix <> ".revision_values") "Named NAME=VALUE non-secret identity values")+    <*> Settei.withDefault+      (Settei.publicShowSetting (settingKey (prefix <> ".deadline_ms")) "Hook deadline in milliseconds" deadlineDecoder)+      (Settei.constantDefault (Settei.RuleName (prefix <> "-deadline")) "Bound hook execution" (300000 :: Int))++optionalText :: Text.Text -> Text.Text -> Settei.Config (Maybe Text.Text)+optionalText name description = Settei.optional (Settei.publicSetting (settingKey name) description Settei.textDecoder)++listSetting :: Text.Text -> Text.Text -> Settei.Config [Text.Text]+listSetting name description =+  Settei.withDefault+    (Settei.publicShowSetting (settingKey name) description (Settei.listDecoder Settei.textDecoder))+    (Settei.constantDefault (Settei.RuleName (name <> "-empty")) "No entries configured" [])++secretListSetting :: Text.Text -> Text.Text -> Settei.Config [Text.Text]+secretListSetting name description =+  Settei.withDefault+    (Settei.secretSetting (settingKey name) description (Settei.listDecoder Settei.textDecoder))+    (Settei.constantDefault (Settei.RuleName (name <> "-empty")) "No entries configured" [])++settingKey :: Text.Text -> Settei.Key+settingKey name = either (error . show) id (Settei.parseKey name)++deadlineDecoder :: Settei.Decoder Int+deadlineDecoder = Settei.parsedDecoder "a positive integer number of milliseconds" $ \value ->+  case readMaybe (Text.unpack value) of+    Just milliseconds | milliseconds > 0 -> Right milliseconds+    _ -> Left "deadline must be a positive integer"++-- | Files are loaded in command-line order, then environment bindings and+-- repeated overrides. Settei's declaration supplies built-in defaults.+resolveConfig :: CliOptions -> IO (Either ConfigFailure ((HinagataConfig, CliSettings), Settei.ResolveResult (HinagataConfig, CliSettings)))+resolveConfig CliOptions {configPaths, overrides, diagnosticMode} = do+  case hinagataEnvironmentBindings of+    Left problems -> pure (Left (SourceFailure (Env.renderEnvErrorsText problems)))+    Right bindings -> do+      let cliBindings =+            Env.bindings+              [ Env.binding (Env.EnvName ("HINAGATA_" <> Text.toUpper (Text.replace "." "_" name))) (settingKey name)+              | name <- ["migration.executable", "migration.cwd", "migration.revision", "migration.deadline_ms", "migration.revision_executable", "verification.executable", "verification.cwd", "verification.revision", "verification.deadline_ms", "verification.revision_executable", "clone.preparation.executable", "clone.preparation.cwd", "clone.preparation.deadline_ms"]+              ]+      case cliBindings of+        Left problems -> pure (Left (SourceFailure (Env.renderEnvErrorsText problems)))+        Right hookBindings -> resolveSources bindings hookBindings+  where+    resolveSources bindings hookBindings = do+      fileResults <- traverse (\(index, path) -> Yaml.readYamlSource (Yaml.yamlSourceOptions ("config #" <> Text.pack (show index))) path) (zip [1 :: Int ..] configPaths)+      case traverse (either (Left . SourceFailure . Yaml.renderYamlErrorsText) Right) fileResults of+        Left failure -> pure (Left failure)+        Right files -> do+          environment <- getEnvironment+          let snapshot = Env.envSnapshot [(Text.pack key, Text.pack value) | (key, value) <- environment]+              sources = files <> [Env.environmentSource bindings snapshot, Env.environmentSource hookBindings snapshot] <> SetteiOptions.cliSources "arguments" overrides+              result@Settei.ResolveResult {answer, report} = Settei.resolve Settei.defaultResolveOptions sources cliConfiguration+          pure $ case answer of+            Left problems ->+              let detail = Settei.renderErrorsText problems+                  explanation = case diagnosticMode of+                    SetteiOptions.ExplainText -> Settei.renderResolutionText report+                    SetteiOptions.ExplainJson -> Settei.renderResolutionJson report <> "\n"+                    _ -> ""+               in Left (ResolutionFailure detail explanation)+            Right configuration@(_, cli) -> case traverse (uncurry validateHook) [("migration", migration cli), ("verification", verification cli), ("clone.preparation", clonePreparation cli)] of+              Left problem -> Left (ResolutionFailure problem "")+              Right _ -> Right (configuration, result)++-- | Semantic checks also run for offline diagnostics, before any database work.+validateHook :: Text.Text -> HookSettings -> Either Text.Text ()+validateHook name hook = do+  either (Left . ((name <> ": ") <>)) (const (Right ())) (revisionDeclarations hook)+  validateCommand name hook++validateCommand :: Text.Text -> HookSettings -> Either Text.Text ()+validateCommand name HookSettings {executable, arguments, workingDirectory, environment, revision, deadlineMs}+  | deadlineMs <= 0 = invalid "hook deadline must be positive"+  | otherwise = case executable of+      Nothing+        | null arguments && workingDirectory == Nothing && null environment && revision == Nothing -> Right ()+        | otherwise -> invalid "hook settings require an executable"+      Just program+        | Text.null program || Text.any (== '\0') program -> invalid "hook executable is empty or contains NUL"+        | any (Text.any (== '\0')) arguments -> invalid "hook argv contains NUL"+        | maybe False (\path -> not (isAbsolute (Text.unpack path)) || Text.any (== '\0') path) workingDirectory -> invalid "hook cwd must be absolute and without NUL"+        | otherwise -> either invalid (const (Right ())) (void (parseOverlay environment))+  where+    invalid message = Left (name <> ": " <> message)++-- | Parse and validate effective declarations without reading files. Config+-- explanations use sensitive arrays; failures never retain rejected entries.+revisionDeclarations :: HookSettings -> Either Text.Text [Revision.RevisionInput]+revisionDeclarations HookSettings {executable, revision, revisionExecutable, revisionInputs, revisionValues}+  | derived && revision /= Nothing = Left "revision conflicts with derived revision selectors"+  | derived && executable == Nothing = Left "derived revision requires a hook executable"+  | revisionExecutable && maybe True (not . isAbsolute . Text.unpack) executable = Left "revision_executable requires an absolute executable"+  | otherwise = do+      files <- traverse (entry "revision_inputs" True) revisionInputs+      values <- traverse (entry "revision_values" False) revisionValues+      selected <-+        if revisionExecutable+          then case executable of+            Just path -> do+              name <- logicalName "revision_executable" "executable"+              pure [Revision.FileInput name (Text.unpack path)]+            Nothing -> Left "revision_executable requires an executable"+          else pure []+      let inputs = selected <> files <> values+      if null inputs+        then Right []+        else case Revision.validateRevisionInputs inputs of+          Left (Revision.DuplicateInput name) -> Left ("revision inputs contain duplicate logical name " <> Revision.inputNameText name)+          Left _ -> Left "revision inputs are invalid"+          Right () -> Right inputs+  where+    derived = revisionExecutable || not (null revisionInputs) || not (null revisionValues)+    logicalName setting label = either (const (Left (setting <> " requires normalized logical names"))) Right (Revision.mkInputName label)+    entry setting isFile raw = do+      let (label, suffix) = Text.breakOn "=" raw+      if Text.null suffix+        then Left (setting <> " entries require NAME=PAYLOAD")+        else do+          name <- logicalName setting label+          let payload = Text.drop 1 suffix+          if isFile+            then+              if Text.null payload || Text.any (== '\0') payload+                then Left (setting <> " requires nonempty paths without NUL")+                else Right (Revision.FileInput name (Text.unpack payload))+            else Right (Revision.ValueInput name payload)

@@ -0,0 +1,144 @@+module Hinagata.Cli.Options+  ( CliOptions (..),+    Command (..),+    Shell (..),+    parserInfo,+  )+where++import Control.Applicative (many, optional, some)+import Data.Text qualified as Text+import Options.Applicative (Parser, ParserInfo)+import Options.Applicative qualified as Options+import Settei.Optparse qualified as SetteiOptions++data Shell = Bash | Zsh | Fish+  deriving stock (Eq, Show)++data Command+  = FixturePlan ![Text.Text] !Bool+  | FixtureLoad ![Text.Text] !Text.Text !Bool+  | FixtureValidate ![Text.Text] !Bool !Bool+  | DbPrepare !Bool+  | DbAcquire ![Text.Text] !Bool+  | DbWith ![Text.Text] !Bool !Bool ![String]+  | DbRelease !Text.Text !Bool+  | Inspect !Text.Text !Bool+  | Clean !Bool !Bool ![Text.Text] !Bool+  | Completions !Shell+  deriving stock (Eq, Show)++data CliOptions = CliOptions+  { configPaths :: ![FilePath],+    overrides :: ![SetteiOptions.CliOverride],+    diagnosticMode :: !SetteiOptions.DiagnosticMode,+    command :: !(Maybe Command)+  }++parserInfo :: String -> ParserInfo CliOptions+parserInfo version =+  Options.info+    (cliOptionsParser Options.<**> Options.helper Options.<**> Options.infoOption version (Options.long "version" <> Options.help "Show package version and build revision"))+    (Options.fullDesc <> Options.progDesc "Plan fixtures and manage isolated PostgreSQL test databases" <> Options.failureCode 2)++cliOptionsParser :: Parser CliOptions+cliOptionsParser =+  CliOptions+    <$> Options.parserOptionGroup "Configuration" SetteiOptions.configPathOptions+    <*> Options.parserOptionGroup "Configuration" SetteiOptions.overrideOptions+    <*> Options.parserOptionGroup "Diagnostics" SetteiOptions.diagnosticModeOptions+    <*> optional commandParser++commandParser :: Parser Command+commandParser =+  Options.hsubparser+    ( Options.command "fixture" (Options.info fixtureParser (Options.progDesc "Plan or load fixture sources"))+        <> Options.command "db" (Options.info dbParser (Options.progDesc "Manage isolated database leases"))+        <> Options.command "inspect" (Options.info inspectParser (Options.progDesc "Inspect a lease by ID"))+        <> Options.command "clean" (Options.info cleanParser (Options.progDesc "Preview or apply ownership-checked cleanup"))+        <> Options.command "completions" (Options.info completionParser (Options.progDesc "Print a shell completion script"))+    )++fixtureParser :: Parser Command+fixtureParser =+  Options.hsubparser+    ( Options.command "plan" (Options.info planParser (Options.progDesc "Compile and inspect a fixture plan without PostgreSQL"))+        <> Options.command "load" (Options.info loadParser (Options.progDesc "Transactionally load fixtures into an existing test database"))+        <> Options.command "validate" (Options.info validateParser (Options.progDesc "Test each scenario in a separate isolated clone"))+    )++planParser :: Parser Command+planParser =+  FixturePlan+    <$> (fmap Text.pack <$> some (Options.strArgument (Options.metavar "NAME...")))+    <*> Options.switch (Options.long "json" <> Options.help "Print versioned JSON")++loadParser :: Parser Command+loadParser =+  FixtureLoad+    <$> (fmap Text.pack <$> some (Options.strArgument (Options.metavar "NAME...")))+    <*> (Text.pack <$> Options.strOption (Options.long "target-database" <> Options.metavar "DATABASE" <> Options.help "Existing caller-owned test database to write"))+    <*> Options.switch (Options.long "json" <> Options.help "Print versioned JSON")++validateParser :: Parser Command+validateParser =+  FixtureValidate+    <$> many (Text.pack <$> Options.strArgument (Options.metavar "NAME..."))+    <*> Options.switch (Options.long "all" <> Options.help "Discover all fixture sources")+    <*> jsonSwitch++dbParser :: Parser Command+dbParser =+  Options.hsubparser+    ( Options.command "prepare" (Options.info (DbPrepare <$> jsonSwitch) (Options.progDesc "Build or reuse a sealed baseline"))+        <> Options.command "acquire" (Options.info acquireParser (Options.progDesc "Acquire a detached isolated database"))+        <> Options.command "with" (Options.info withParser (Options.progDesc "Run one command with an isolated database lease"))+        <> Options.command "release" (Options.info releaseParser (Options.progDesc "Release a detached or retained lease"))+    )++acquireParser :: Parser Command+acquireParser =+  DbAcquire+    <$> many (Text.pack <$> Options.strOption (Options.long "fixture" <> Options.metavar "NAME" <> Options.help "Scenario fixture (repeatable)"))+    <*> jsonSwitch++withParser :: Parser Command+withParser =+  DbWith+    <$> many (Text.pack <$> Options.strOption (Options.long "fixture" <> Options.metavar "NAME" <> Options.help "Scenario fixture (repeatable)"))+    <*> Options.switch (Options.long "preserve-on-failure" <> Options.help "Retain a failed command's database for inspection")+    <*> jsonSwitch+    <*> some (Options.strArgument (Options.metavar "-- PROGRAM ARGS..."))++jsonSwitch :: Parser Bool+jsonSwitch = Options.switch (Options.long "json" <> Options.help "Print versioned JSON")++releaseParser :: Parser Command+releaseParser =+  DbRelease+    <$> (Text.pack <$> Options.strArgument (Options.metavar "LEASE_ID"))+    <*> Options.switch (Options.long "json" <> Options.help "Print versioned JSON")++inspectParser :: Parser Command+inspectParser =+  Inspect+    <$> (Text.pack <$> Options.strArgument (Options.metavar "LEASE_ID"))+    <*> Options.switch (Options.long "json" <> Options.help "Print versioned JSON")++cleanParser :: Parser Command+cleanParser =+  Clean+    <$> Options.switch (Options.long "apply" <> Options.help "Revalidate and apply cleanup to selected allocations")+    <*> Options.switch (Options.long "include-retained" <> Options.help "Allow explicitly selected retained allocations")+    <*> many (Text.pack <$> Options.strOption (Options.long "id" <> Options.metavar "ALLOCATION_ID" <> Options.help "Allocation to revalidate and clean"))+    <*> Options.switch (Options.long "json" <> Options.help "Print versioned JSON")++completionParser :: Parser Command+completionParser = Completions <$> Options.argument shellReader (Options.metavar "bash|zsh|fish")++shellReader :: Options.ReadM Shell+shellReader = Options.eitherReader $ \case+  "bash" -> Right Bash+  "zsh" -> Right Zsh+  "fish" -> Right Fish+  _ -> Left "expected bash, zsh, or fish"

@@ -0,0 +1,317 @@+module Hinagata.Cli.Output+  ( CliError (..),+    bundleError,+    baselineError,+    leaseError,+    loadError,+    cleanupError,+    emitError,+    emitLoad,+    emitPlan,+    emitCandidate,+    emitCleanupPlan,+    emitCleanupResults,+    emitPreparation,+    emitAcquisition,+    emitWith,+    withExitCode,+    ValidationResult (..),+    emitValidation,+  )+where++import Data.Aeson ((.=))+import Data.Aeson qualified as Json+import Data.ByteString.Lazy qualified as Lazy+import Data.Text qualified as Text+import Data.Text.IO qualified as TextIO+import Hinagata.Cli.Process (ChildFailure (..), ChildReport (..))+import Hinagata.Connection (connectionDatabase, connectionHost, connectionPort, connectionUser, hostText)+import Hinagata.Fixture.Bundle+import Hinagata.Fixture.Types (fixtureNameText)+import Hinagata.Postgres.Baseline (BaselineError (..), FingerprintComparison (..), PreparationKind (..), PreparationReport (..), fingerprintComponents)+import Hinagata.Postgres.Cleanup (CleanupCandidate (..), CleanupDisposition (..), CleanupError (..), CleanupResult (..))+import Hinagata.Postgres.Error (FixtureLoadContext (..), LoadError (..), loadErrorContext)+import Hinagata.Postgres.Lease (LeaseError (..), LeaseInfo (..), LeaseOutcome (..), LeaseTimings (..), PreparationContext (..), PreparationFailure (..), PreparationFailureKind (..))+import Hinagata.Postgres.Load (LoadReport (..))+import Hinagata.Types (DatabaseName, databaseNameText, portNumber)+import System.Exit (ExitCode (..))+import System.IO qualified as IO++data CliError = CliError+  { phase :: !Text.Text,+    code :: !Text.Text,+    message :: !Text.Text,+    fixture :: !(Maybe Text.Text),+    stepIndex :: !(Maybe Int),+    sqlState :: !(Maybe Text.Text),+    target :: !(Maybe Text.Text),+    exitCode :: !Int,+    errorRunId :: !(Maybe Text.Text),+    errorLeaseId :: !(Maybe Text.Text),+    loadContext :: !(Maybe FixtureLoadContext),+    errorCleanupFailure :: !(Maybe Text.Text)+  }+  deriving stock (Eq, Show)++data ValidationResult = ValidationResult+  { scenario :: !Text.Text,+    result :: !(Either CliError LeaseTimings)+  }++bundleError :: BundleError -> CliError+bundleError problem = case problem of+  BundleIo reason -> failure "bundle_io" reason Nothing+  MissingFixture name -> failure "fixture_missing" "fixture does not exist" (Just (fixtureNameText name))+  UnsafePath path -> failure "fixture_unsafe_path" (Text.pack path) Nothing+  InvalidFixtureManifest name _ -> failure "fixture_manifest_invalid" "fixture manifest is invalid" (Just (fixtureNameText name))+  InvalidFixtureGraph _ -> failure "fixture_graph_invalid" "fixture graph is invalid" Nothing+  SourceChanged path -> failure "fixture_source_changed" (Text.pack path) Nothing+  SqlStepTooLarge path -> failure "fixture_sql_too_large" (Text.pack path) Nothing+  InvalidSql path _ -> failure "fixture_sql_invalid" (Text.pack path) Nothing+  where+    failure code message fixture = CliError "fixture-plan" code message fixture Nothing Nothing Nothing 1 Nothing Nothing Nothing Nothing++loadError :: LoadError -> CliError+loadError problem@LoadError {phase, targetIdentity, fixture, stepIndex, cause, sqlState} =+  attachFixtureContext (Just (loadErrorContext problem)) $ CliError (Text.pack (show phase)) "load_failed" cause (fixtureNameText <$> fixture) stepIndex sqlState targetIdentity 1 Nothing Nothing Nothing Nothing++-- | Preserve lifecycle identity while adding safe fixture details.+baselineError :: BaselineError -> CliError+baselineError BaselineError {cause, sqlState, fixtureLoadContext} =+  attachFixtureContext fixtureLoadContext (CliError "baseline-prepare" "baseline_failed" cause Nothing Nothing sqlState Nothing 1 Nothing Nothing Nothing Nothing)++attachFixtureContext :: Maybe FixtureLoadContext -> CliError -> CliError+attachFixtureContext Nothing problem = problem+attachFixtureContext selected@(Just FixtureLoadContext {fixture, stepIndex, sqlState}) problem =+  problem {fixture = fixtureNameText <$> fixture, stepIndex, sqlState, loadContext = selected}++cleanupError :: CleanupError -> CliError+cleanupError CleanupError {cause, sqlState} = CliError "cleanup" "cleanup_failed" cause Nothing Nothing sqlState Nothing 1 Nothing Nothing Nothing Nothing++-- | Common acquisition mapping keeps per-lease failures independent of the+-- command's shared cancellation status.+leaseError :: Text.Text -> Maybe Text.Text -> LeaseError -> CliError+leaseError fallback fixture LeaseError {cause, sqlState, cleanupFailure, preparationContext, fixtureLoadContext} =+  attachFixtureContext fixtureLoadContext $+    let message = cause <> maybe "" ("; cleanup: " <>) cleanupFailure+     in case preparationContext of+          Nothing -> CliError fallback "lease_failed" message fixture Nothing sqlState Nothing 1 Nothing Nothing Nothing cleanupFailure+          Just PreparationContext {preparationFailure = PreparationFailure {failureKind, releaseSafe}, preparationRunId, preparationLeaseId} ->+            let code =+                  if not releaseSafe+                    then "clone_preparation_cleanup_failed"+                    else case failureKind of+                      PreparationTimeout -> "clone_preparation_timeout"+                      PreparationCancelled _ -> "clone_preparation_cancelled"+                      _ -> "clone_preparation_failed"+                status = case failureKind of PreparationCancelled signal -> 128 + signal; _ -> 1+             in CliError "clone-preparation" code message fixture Nothing sqlState Nothing status (Just preparationRunId) (Just preparationLeaseId) Nothing cleanupFailure++emitCandidate :: Bool -> Maybe CleanupCandidate -> IO ()+emitCandidate jsonSelected found =+  if jsonSelected+    then emitValue (Json.object ["formatVersion" .= (1 :: Int), "ok" .= True, "kind" .= ("inspect" :: Text.Text), "candidate" .= fmap candidateValue found])+    else case found of+      Nothing -> TextIO.putStrLn "lease not found"+      Just CleanupCandidate {allocationId, database, state, disposition} ->+        TextIO.putStrLn (allocationId <> " " <> databaseNameText database <> " " <> state <> " " <> dispositionText disposition)++emitCleanupPlan :: Bool -> [CleanupCandidate] -> IO ()+emitCleanupPlan jsonSelected candidates =+  if jsonSelected+    then emitValue (Json.object ["formatVersion" .= (1 :: Int), "ok" .= True, "kind" .= ("cleanup-preview" :: Text.Text), "candidates" .= map candidateValue candidates])+    else mapM_ (emitCandidate False . Just) candidates++emitCleanupResults :: Bool -> [CleanupResult] -> IO ()+emitCleanupResults jsonSelected results =+  if jsonSelected+    then emitValue (Json.object ["formatVersion" .= (1 :: Int), "ok" .= all successful results, "kind" .= ("cleanup-apply" :: Text.Text), "results" .= map cleanupResultValue results])+    else mapM_ (TextIO.putStrLn . resultText) results+  where+    successful (Released _) = True+    successful (AlreadyReleased _) = True+    successful (Preserved _) = True+    successful _ = False++candidateValue :: CleanupCandidate -> Json.Value+candidateValue CleanupCandidate {allocationId, leaseId, database, state, disposition} =+  Json.object ["allocationId" .= allocationId, "leaseId" .= leaseId, "database" .= databaseNameText database, "state" .= state, "disposition" .= dispositionText disposition]++dispositionText :: CleanupDisposition -> Text.Text+dispositionText = Text.pack . show++cleanupResultValue :: CleanupResult -> Json.Value+cleanupResultValue result = Json.object ["id" .= resultId result, "code" .= resultCode result, "outcome" .= resultText result, "reason" .= resultReason result]++resultCode :: CleanupResult -> Text.Text+resultCode = \case+  Released _ -> "released"+  AlreadyReleased _ -> "already_released"+  Preserved _ -> "preserved"+  Skipped _ _ -> "skipped"+  Refused _ _ -> "refused"++resultReason :: CleanupResult -> Maybe Text.Text+resultReason = \case+  Refused _ reason -> Just reason+  _ -> Nothing++resultId :: CleanupResult -> Text.Text+resultId = \case+  Released identifier -> identifier+  AlreadyReleased identifier -> identifier+  Preserved identifier -> identifier+  Skipped identifier _ -> identifier+  Refused identifier _ -> identifier++resultText :: CleanupResult -> Text.Text+resultText = \case+  Released identifier -> "released " <> identifier+  AlreadyReleased identifier -> "already released " <> identifier+  Preserved identifier -> "preserved " <> identifier+  Skipped identifier disposition -> "skipped " <> identifier <> " (" <> dispositionText disposition <> ")"+  Refused identifier reason -> "refused " <> identifier <> ": " <> reason++emitValue :: Json.Value -> IO ()+emitValue value = Lazy.putStr (Json.encode value <> "\n")++emitValidation :: Bool -> [ValidationResult] -> IO ()+emitValidation jsonSelected results =+  if jsonSelected+    then emitValue (Json.object ["formatVersion" .= (1 :: Int), "ok" .= all passed results, "kind" .= ("fixture-validate" :: Text.Text), "results" .= map resultValue results])+    else mapM_ (\ValidationResult {scenario, result} -> TextIO.putStrLn (scenario <> either (\problem -> " failed: " <> errorText problem) (const " passed") result)) results+  where+    passed ValidationResult {result} = either (const False) (const True) result+    resultValue ValidationResult {scenario, result} =+      Json.object ["scenario" .= scenario, "ok" .= either (const False) (const True) result, "error" .= either (Just . validationErrorValue) (const Nothing) result, "timingsMs" .= either (const Nothing) (Just . timingValue) result]+    timingValue LeaseTimings {queueWaitMs, catalogMs, generationLockMs, cloneMs, scenarioLoadMs, completionMs} =+      Json.object ["queueWait" .= queueWaitMs, "catalog" .= catalogMs, "generationLock" .= generationLockMs, "clone" .= cloneMs, "scenarioLoad" .= scenarioLoadMs, "completion" .= completionMs]++validationErrorValue :: CliError -> Json.Value+validationErrorValue CliError {phase, code, message, fixture, stepIndex, sqlState, target, errorRunId, errorLeaseId, loadContext, errorCleanupFailure} =+  Json.object ["phase" .= phase, "code" .= code, "message" .= message, "fixture" .= fixture, "stepIndex" .= stepIndex, "sqlState" .= sqlState, "target" .= target, "runId" .= errorRunId, "leaseId" .= errorLeaseId, "loadContext" .= fmap loadContextValue loadContext, "cleanupFailure" .= errorCleanupFailure]++loadContextValue :: FixtureLoadContext -> Json.Value+loadContextValue FixtureLoadContext {phase, fixture, stepIndex, sqlState, cause, rollbackFailure} =+  Json.object ["phase" .= Text.pack (show phase), "fixture" .= fmap fixtureNameText fixture, "stepIndex" .= stepIndex, "sqlState" .= sqlState, "cause" .= cause, "rollbackFailure" .= rollbackFailure]++errorText :: CliError -> Text.Text+errorText CliError {phase, code, message, fixture, stepIndex, loadContext} =+  phase+    <> ": "+    <> code+    <> ": "+    <> message+    <> maybe "" ("; fixture " <>) fixture+    <> maybe "" (\index -> "; step " <> Text.pack (show index)) stepIndex+    <> maybe "" (\FixtureLoadContext {phase = loadPhase} -> "; load " <> Text.pack (show loadPhase)) loadContext++emitPreparation :: Bool -> PreparationReport -> IO ()+emitPreparation jsonSelected PreparationReport {kind, fingerprint, elapsedMs, comparison} =+  if jsonSelected+    then emitValue (Json.object ["formatVersion" .= (1 :: Int), "ok" .= True, "kind" .= ("baseline-prepare" :: Text.Text), "result" .= Text.pack (show kind), "reason" .= preparationReason kind, "fingerprint" .= fingerprint, "fingerprintCategories" .= map (Text.pack . show) fingerprintComponents, "elapsedMs" .= elapsedMs, "comparison" .= fmap comparisonValue comparison])+    else TextIO.putStrLn (Text.pack (show kind) <> " baseline " <> fingerprint <> " in " <> Text.pack (show elapsedMs) <> " ms")++preparationReason :: PreparationKind -> Text.Text+preparationReason Built = "no-matching-ready-generation"+preparationReason Reused = "matching-sealed-generation"++comparisonValue :: FingerprintComparison -> Json.Value+comparisonValue FingerprintComparison {previousFingerprint, changedComponents} =+  Json.object ["previousFingerprint" .= previousFingerprint, "changedComponents" .= map (Text.pack . show) changedComponents]++emitAcquisition :: Bool -> LeaseInfo -> LeaseTimings -> IO ()+emitAcquisition jsonSelected LeaseInfo {leaseId, runId, applicationTarget} LeaseTimings {queueWaitMs, catalogMs, generationLockMs, cloneMs, scenarioLoadMs, completionMs} =+  if jsonSelected+    then emitValue (Json.object ["formatVersion" .= (1 :: Int), "ok" .= True, "kind" .= ("db-acquire" :: Text.Text), "leaseId" .= leaseId, "runId" .= runId, "database" .= databaseNameText (connectionDatabase applicationTarget), "host" .= hostText (connectionHost applicationTarget), "port" .= portNumber (connectionPort applicationTarget), "user" .= connectionUser applicationTarget, "timingsMs" .= Json.object ["queueWait" .= queueWaitMs, "catalog" .= catalogMs, "generationLock" .= generationLockMs, "clone" .= cloneMs, "scenarioLoad" .= scenarioLoadMs, "completion" .= completionMs]])+    else TextIO.putStrLn ("acquired " <> leaseId <> " " <> databaseNameText (connectionDatabase applicationTarget))++withExitCode :: LeaseOutcome (Either ChildFailure ChildReport) -> Int+withExitCode LeaseOutcome {callbackValue, cleanupDiagnostic} =+  let childStatus = case callbackValue of+        Left _ -> 1+        Right ChildReport {cancelledBy = Just signal} -> 128 + signal+        Right ChildReport {timedOut = True} -> 1+        Right ChildReport {childExit = Just ExitSuccess, cleanupFailure = Nothing} -> 0+        Right ChildReport {childExit = Just (ExitFailure status)} -> if status < 0 then 128 - status else status+        Right _ -> 1+   in if childStatus == 0 && cleanupDiagnostic /= Nothing then 1 else childStatus++emitWith :: Bool -> LeaseOutcome (Either ChildFailure ChildReport) -> IO ()+emitWith jsonSelected outcome@LeaseOutcome {callbackValue, leaseInfo = LeaseInfo {leaseId, runId}, leaseDisposition, cleanupDiagnostic, timings} = do+  let status = withExitCode outcome+      childValue = case callbackValue of+        Left ChildSpawnFailed -> Json.object ["outcome" .= ("spawn-failed" :: Text.Text)]+        Left ChildIdentityUnavailable -> Json.object ["outcome" .= ("identity-unavailable" :: Text.Text)]+        Right ChildReport {childExit, timedOut, cancelledBy, cleanupFailure} ->+          Json.object ["outcome" .= (if timedOut then "timed-out" else if cancelledBy /= Nothing then "cancelled" else "exited" :: Text.Text), "exitCode" .= fmap exitNumber childExit, "signal" .= cancelledBy, "processCleanup" .= cleanupFailure]+      LeaseTimings {queueWaitMs, catalogMs, generationLockMs, cloneMs, scenarioLoadMs, completionMs} = timings+      cleanupValue = fmap (\LeaseError {cause, sqlState, cleanupFailure} -> Json.object ["message" .= cause, "sqlState" .= sqlState, "detail" .= cleanupFailure]) cleanupDiagnostic+  if jsonSelected+    then emitValue (Json.object ["formatVersion" .= (1 :: Int), "ok" .= (status == 0), "kind" .= ("db-with" :: Text.Text), "leaseId" .= leaseId, "runId" .= runId, "disposition" .= Text.pack (show leaseDisposition), "status" .= status, "child" .= childValue, "databaseCleanup" .= cleanupValue, "timingsMs" .= Json.object ["queueWait" .= queueWaitMs, "catalog" .= catalogMs, "generationLock" .= generationLockMs, "clone" .= cloneMs, "scenarioLoad" .= scenarioLoadMs, "completion" .= completionMs]])+    else TextIO.putStrLn ("lease " <> leaseId <> " " <> Text.pack (show leaseDisposition) <> "; command status " <> Text.pack (show status))+  if status /= 0 then TextIO.hPutStrLn IO.stderr ("db with: command status " <> Text.pack (show status) <> "; lease " <> leaseId <> " " <> Text.pack (show leaseDisposition)) else pure ()+  where+    exitNumber ExitSuccess = 0 :: Int+    exitNumber (ExitFailure status) = if status < 0 then 128 - status else status++emitError :: Bool -> CliError -> IO ()+emitError jsonSelected failure = do+  TextIO.hPutStrLn IO.stderr (errorText failure)+  if jsonSelected+    then emitValue (Json.object ["formatVersion" .= (1 :: Int), "ok" .= False, "error" .= validationErrorValue failure])+    else pure ()++emitLoad :: Bool -> DatabaseName -> LoadReport -> IO ()+emitLoad jsonSelected database LoadReport {fixtureCount, stepCount, bytesSent, verifyMs, setupMs, sqlMs, copyMs, commitMs, elapsedMs} =+  if jsonSelected+    then+      Lazy.putStr+        ( Json.encode+            ( Json.object+                [ "formatVersion" .= (1 :: Int),+                  "ok" .= True,+                  "kind" .= ("fixture-load" :: Text.Text),+                  "database" .= databaseNameText database,+                  "fixtureCount" .= fixtureCount,+                  "stepCount" .= stepCount,+                  "bytesSent" .= bytesSent,+                  "timingsMs" .= Json.object ["verify" .= verifyMs, "setup" .= setupMs, "sql" .= sqlMs, "copy" .= copyMs, "commit" .= commitMs, "elapsed" .= elapsedMs]+                ]+            )+            <> "\n"+        )+    else TextIO.putStrLn ("loaded " <> Text.pack (show fixtureCount) <> " fixtures into " <> databaseNameText database)++emitPlan :: Bool -> FixturePlan -> IO ()+emitPlan jsonSelected plan =+  if jsonSelected+    then Lazy.putStr (Json.encode planValue <> "\n")+    else do+      TextIO.putStrLn ("plan " <> planDigest plan)+      mapM_ (TextIO.putStrLn . ("fixture " <>) . fixtureNameText . name) (planFixtures plan)+  where+    planValue =+      Json.object+        [ "formatVersion" .= (1 :: Int),+          "ok" .= True,+          "kind" .= ("fixture-plan" :: Text.Text),+          "digest" .= planDigest plan,+          "fixtures" .= map fixtureValue (planFixtures plan)+        ]++fixtureValue :: CapturedFixture -> Json.Value+fixtureValue CapturedFixture {name, includes, steps, identity} =+  Json.object+    [ "name" .= fixtureNameText name,+      "includes" .= map fixtureNameText includes,+      "identity" .= identity,+      "steps" .= map stepValue steps+    ]++stepValue :: CapturedStep -> Json.Value+stepValue CapturedSql {relativePath, contentDigest, byteLength} =+  Json.object ["type" .= ("sql" :: Text.Text), "path" .= relativePath, "digest" .= contentDigest, "bytes" .= byteLength]+stepValue CapturedCopy {relativePath, contentDigest, byteLength} =+  Json.object ["type" .= ("copy" :: Text.Text), "path" .= relativePath, "digest" .= contentDigest, "bytes" .= byteLength]

@@ -0,0 +1,303 @@+-- | Generic, shell-free child execution with a private PostgreSQL password channel.+module Hinagata.Cli.Process+  ( ChildSpec (..),+    ChildReport (..),+    ChildFailure (..),+    CancellationScope,+    CommandCancelled (..),+    ChildCleanupException (..),+    withCancellationScope,+    withCommandCancellation,+    withCooperativeCancellation,+    cancellationSignal,+    checkCancellation,+    waitCancellation,+    runChild,+    runChildWithCleanupCheck,+    withRegistration,+    parseOverlay,+  )+where++import Control.Applicative ((<|>))+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async qualified as Async+import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newEmptyMVar, newMVar, readMVar, tryPutMVar, tryReadMVar)+import Control.Exception (Exception (..), IOException, SomeException, asyncExceptionFromException, asyncExceptionToException, bracket, bracket_, finally, mask, throwIO, try)+import Control.Monad (unless, void)+import Data.List (isPrefixOf)+import Data.Text qualified as Text+import Data.Text.IO qualified as TextIO+import Hinagata.Connection+import Hinagata.Types (databaseNameText, portNumber)+import System.Directory (getTemporaryDirectory, removeFile)+import System.Environment (getEnvironment)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.IO (IOMode (ReadMode), hClose, hFlush, hIsClosed, stderr, withFile)+import System.IO.Error (isDoesNotExistError)+import System.Posix.Files (ownerReadMode, ownerWriteMode, setFileMode, unionFileModes)+import System.Posix.Signals (Handler (Catch), Signal, installHandler, nullSignal, sigINT, sigKILL, sigTERM, signalProcessGroup)+import System.Posix.Temp (mkstemp)+import System.Posix.Types qualified+import System.Process (CreateProcess (..), ProcessHandle, StdStream (Inherit, UseHandle), createProcess, getPid, getProcessExitCode, proc, waitForProcess)+import System.Timeout (timeout)++data ChildSpec = ChildSpec+  { executable :: !FilePath,+    arguments :: ![String],+    workingDirectory :: !(Maybe FilePath),+    environment :: ![(String, String)],+    target :: !ConnectionTarget,+    identifiers :: !(Maybe (Text.Text, Text.Text)),+    deadlineMs :: !(Maybe Int),+    stdoutToStderr :: !Bool+  }++data ChildReport = ChildReport+  { childExit :: !(Maybe ExitCode),+    timedOut :: !Bool,+    cancelledBy :: !(Maybe Int),+    cleanupFailure :: !(Maybe Text.Text)+  }+  deriving stock (Eq, Show)++data ChildFailure = ChildSpawnFailed | ChildIdentityUnavailable+  deriving stock (Eq, Show)++-- | Explicit hook overlays cannot replace the managed PostgreSQL connection+-- or inject a shell through argument splitting.+parseOverlay :: [Text.Text] -> Either Text.Text [(String, String)]+parseOverlay = traverse parseOne+  where+    parseOne entry =+      let (name, rest) = Text.breakOn "=" entry+       in if not (validName name) || Text.null rest || Text.any (== '\0') rest+            then Left "hook environment entries must be NAME=VALUE without NUL"+            else+              if "PG" `Text.isPrefixOf` name || "HINAGATA_" `Text.isPrefixOf` name+                then Left "hook environment cannot override managed PG* or HINAGATA_* variables"+                else Right (Text.unpack name, Text.unpack (Text.drop 1 rest))++    validName name = case Text.uncons name of+      Nothing -> False+      Just (initial, following) -> (initial == '_' || asciiLetter initial) && Text.all (\character -> character == '_' || asciiLetter character || asciiDigit character) following+    asciiLetter character = ('A' <= character && character <= 'Z') || ('a' <= character && character <= 'z')+    asciiDigit character = '0' <= character && character <= '9'++-- | One command owns process-wide handlers. Registration and first-signal+-- observation share a lock, so spawning cannot miss concurrent cancellation.+data ScopeState = ScopeState+  { selectedSignal :: !(Maybe Int),+    nextRegistration :: !Int,+    registrations :: ![(Int, MVar Int)],+    cooperative :: !Int,+    deferRoot :: !Bool+  }++newtype CancellationScope = CancellationScope (MVar ScopeState)++data CommandCancelled = CommandCancelled !Int+  deriving stock (Show)++instance Exception CommandCancelled where+  toException = asyncExceptionToException+  fromException = asyncExceptionFromException++data ChildCleanupException = ChildCleanupException+  deriving stock (Show)+  deriving anyclass (Exception)++withCancellationScope :: (CancellationScope -> IO a) -> IO a+withCancellationScope callback = mask $ \restore -> do+  scope@(CancellationScope state) <- CancellationScope <$> newMVar (ScopeState Nothing 0 [] 0 False)+  let notify number = modifyMVar_ state $ \record@ScopeState {selectedSignal, registrations, cooperative, deferRoot} -> do+        let selected = selectedSignal <|> Just number+            deferred = case selectedSignal of+              Just _ -> deferRoot+              Nothing -> cooperative > 0 || not (null registrations)+        mapM_ (\(_, marker) -> void (tryPutMVar marker (maybe number id selected))) registrations+        pure record {selectedSignal = selected, deferRoot = deferred}+      settle = do+        ScopeState {registrations = children} <- readMVar state+        unless (null children) (threadDelay 10000 >> settle)+  previousInt <- installHandler sigINT (Catch (notify 2)) Nothing+  previousTerm <- installHandler sigTERM (Catch (notify 15)) Nothing+  restore (callback scope)+    `finally` ( settle `finally` do+                  _ <- installHandler sigINT previousInt Nothing+                  _ <- installHandler sigTERM previousTerm Nothing+                  pure ()+              )++cancellationSignal :: CancellationScope -> IO (Maybe Int)+cancellationSignal (CancellationScope state) = do+  ScopeState {selectedSignal = signal} <- readMVar state+  pure signal++checkCancellation :: CancellationScope -> IO ()+checkCancellation scope = cancellationSignal scope >>= maybe (pure ()) (throwIO . CommandCancelled)++waitCancellation :: CancellationScope -> IO Int+waitCancellation scope = cancellationSignal scope >>= maybe (threadDelay 10000 >> waitCancellation scope) pure++-- | The root cancels native work once and joins cleanup. If the first signal+-- arrives inside an existing child/validation supervisor, that supervisor owns+-- delivery through its typed outcome; the root only joins it. This decision is+-- latched with the signal, so unregistering cannot cause a second interruption.+withCommandCancellation :: CancellationScope -> IO a -> IO a+withCommandCancellation scope@(CancellationScope state) action =+  Async.withAsync (checkCancellation scope >> action) $ \worker -> do+    raced <- Async.race (Async.waitCatch worker) (waitCancellation scope)+    completed <- case raced of+      Left result -> pure result+      Right signal -> do+        ScopeState {deferRoot} <- readMVar state+        unless deferRoot (Async.cancelWith worker (CommandCancelled signal))+        Async.waitCatch worker+    either throwIO pure completed++-- | Delegate first-signal delivery to an existing supervisor. Its cleanup and+-- typed outcome must settle before leaving this region.+withCooperativeCancellation :: CancellationScope -> IO a -> IO a+withCooperativeCancellation (CancellationScope state) = bracket_ enter leave+  where+    enter = modifyMVar_ state (\record -> pure record {cooperative = cooperative record + 1})+    leave = modifyMVar_ state (\record -> pure record {cooperative = cooperative record - 1})++withRegistration :: CancellationScope -> (MVar Int -> IO a) -> IO a+withRegistration (CancellationScope state) callback = bracket register unregister (callback . snd)+  where+    register = do+      marker <- newEmptyMVar+      modifyMVar state $ \record@ScopeState {selectedSignal, nextRegistration, registrations} -> do+        mapM_ (void . tryPutMVar marker) selectedSignal+        pure (record {nextRegistration = nextRegistration + 1, registrations = (nextRegistration, marker) : registrations}, (nextRegistration, marker))+    unregister (key, _) = modifyMVar_ state $ \record@ScopeState {registrations} ->+      pure record {registrations = filter ((/= key) . fst) registrations}++runChild :: CancellationScope -> ChildSpec -> IO (Either ChildFailure ChildReport)+runChild = runChildWithCleanupCheck (pure True)++-- | Internal test seam: a negative proof forces retention after real cleanup.+-- There is deliberately no environment or configuration switch for this.+runChildWithCleanupCheck :: IO Bool -> CancellationScope -> ChildSpec -> IO (Either ChildFailure ChildReport)+runChildWithCleanupCheck cleanupCheck scope specification@ChildSpec {target} = do+  checkCancellation scope+  withRegistration scope $ \marker -> withPasswordFile target $ \passwordPath -> do+    inherited <- getEnvironment+    let forwarded = filter (\(name, _) -> not ("PG" `isPrefixOf` name || "HINAGATA_" `isPrefixOf` name)) inherited+        connectionEnvironment =+          [ ("PGHOST", Text.unpack (hostText (connectionHost target))),+            ("PGPORT", show (portNumber (connectionPort target))),+            ("PGUSER", Text.unpack (connectionUser target)),+            ("PGDATABASE", Text.unpack (databaseNameText (connectionDatabase target)))+          ]+        identityEnvironment = case identifiers specification of+          Nothing -> []+          Just (runId, leaseId) -> [("HINAGATA_RUN_ID", Text.unpack runId), ("HINAGATA_LEASE_ID", Text.unpack leaseId)]+        passwordEnvironment = maybe [] (\path -> [("PGPASSFILE", path)]) passwordPath+        overlayNames = map fst (environment specification)+        processEnvironment = environment specification <> connectionEnvironment <> identityEnvironment <> passwordEnvironment <> filter (\(name, _) -> name `notElem` overlayNames) forwarded+    withFile "/dev/null" ReadMode $ \nullInput -> mask $ \restore -> do+      checkCancellation scope+      let child =+            (proc (executable specification) (arguments specification))+              { cwd = workingDirectory specification,+                env = Just processEnvironment,+                std_in = UseHandle nullInput,+                std_out = if stdoutToStderr specification then UseHandle stderr else Inherit,+                create_group = True,+                delegate_ctlc = False+              }+      spawned <- try @IOException (createProcess child)+      case spawned of+        Left _ -> pure (Left ChildSpawnFailed)+        Right (_, _, _, handle) -> do+          maybePid <- getPid handle+          case maybePid of+            Nothing -> pure (Left ChildIdentityUnavailable)+            Just pid -> do+              let stop = do+                    signal <- cancellationSignal scope+                    attempted <- try @IOException $ do+                      stopped <- stopGroup (maybe sigTERM (\number -> if number == 2 then sigINT else sigTERM) signal) pid handle+                      _ <- timeout 2000000 (try @IOException (waitForProcess handle))+                      pure stopped+                    proven <- cleanupCheck+                    pure (if proven then either (const (Just "child process cleanup could not be observed")) id attempted else Just "child process group could not be proven stopped")+                  wait = do+                    signal <- tryReadMVar marker+                    case signal of+                      Just _ -> pure Nothing+                      Nothing -> do+                        completed <- getProcessExitCode handle+                        case completed of+                          Just status -> pure (Just status)+                          Nothing -> threadDelay 10000 >> wait+                  supervise = do+                    waited <- case deadlineMs specification of+                      Nothing -> Just <$> restore wait+                      Just milliseconds -> restore (timeout (milliseconds * 1000) wait)+                    stopped <- stop+                    signal <- cancellationSignal scope+                    pure (Right (ChildReport (waited >>= id) (waited == Nothing) signal stopped))+              result <- try @SomeException supervise+              case result of+                Right report -> pure report+                Left exception -> do+                  stopped <- stop+                  case stopped of+                    Just _ -> throwIO ChildCleanupException+                    Nothing -> throwIO exception++-- | Bounded escalation also reaps the leader while checking the group.+stopGroup :: System.Posix.Signals.Signal -> System.Posix.Types.ProcessID -> ProcessHandle -> IO (Maybe Text.Text)+stopGroup signal groupId handle = do+  alive <- groupAlive groupId+  if not alive+    then pure Nothing+    else do+      _ <- try @IOException (signalProcessGroup signal groupId)+      stopped <- waitGone 40+      if stopped+        then pure Nothing+        else do+          _ <- try @IOException (signalProcessGroup sigKILL groupId)+          killed <- waitGone 40+          pure (if killed then Nothing else Just "child process group could not be proven stopped")+  where+    waitGone attempts = do+      _ <- getProcessExitCode handle+      alive <- groupAlive groupId+      if not alive then pure True else if attempts <= (0 :: Int) then pure False else threadDelay 50000 >> waitGone (attempts - 1)++groupAlive :: System.Posix.Types.ProcessID -> IO Bool+groupAlive groupId = do+  result <- try @IOException (signalProcessGroup nullSignal groupId)+  pure $ case result of+    Right () -> True+    Left problem -> not (isDoesNotExistError problem)++withPasswordFile :: ConnectionTarget -> (Maybe FilePath -> IO a) -> IO a+withPasswordFile target callback = case connectionPassword target of+  Nothing -> callback Nothing+  Just password -> do+    temporary <- getTemporaryDirectory+    bracket (mkstemp (temporary </> "hinagata-pgpass-")) removePassword $ \(path, handle) -> do+      setFileMode path (ownerReadMode `unionFileModes` ownerWriteMode)+      TextIO.hPutStrLn handle (passwordLine target password)+      hFlush handle+      hClose handle+      callback (Just path)+  where+    removePassword (path, handle) = do+      closed <- hIsClosed handle+      unless closed (hClose handle)+      removeFile path++passwordLine :: ConnectionTarget -> Secret -> Text.Text+passwordLine target password =+  Text.intercalate ":" (map escape [hostText (connectionHost target), Text.pack (show (portNumber (connectionPort target))), databaseNameText (connectionDatabase target), connectionUser target, secretText password])+  where+    escape = Text.concatMap (\character -> if character == ':' || character == '\\' then Text.pack ['\\', character] else Text.singleton character)

@@ -0,0 +1,50 @@+-- | Per-preparation capture of explicitly selected hook identity inputs.+module Hinagata.Cli.Revision+  ( HookRevision,+    captureHookRevision,+    effectiveRevision,+    verifyHookRevisions,+  )+where++import Data.Text (Text)+import Data.Text qualified as Text+import Hinagata.Cli.Config (HookSettings (..), revisionDeclarations)+import Hinagata.Cli.Output (CliError (..))+import Hinagata.Hook.Revision qualified as Revision+import System.FilePath (isAbsolute, (</>))++data HookRevision = HookRevision !Text !(Maybe Text) !(Maybe Revision.CapturedRevision)++effectiveRevision :: HookRevision -> Maybe Text+effectiveRevision (HookRevision _ revision _) = revision++captureHookRevision :: FilePath -> Text -> HookSettings -> IO (Either CliError HookRevision)+captureHookRevision invocation name settings = case revisionDeclarations settings of+  Left _ -> pure (Left (CliError "config-resolution" "config_resolution_invalid" (name <> ": invalid revision declaration") Nothing Nothing Nothing Nothing 4 Nothing Nothing Nothing Nothing))+  Right [] -> pure (Right (HookRevision name (revision settings) Nothing))+  Right inputs -> do+    let root = maybe invocation Text.unpack (workingDirectory settings)+        locate (Revision.FileInput label path) = Revision.FileInput label (if isAbsolute path then path else root </> path)+        locate input = input+    captured <- Revision.deriveHookRevision (map locate inputs)+    pure $ case captured of+      Left failure -> Left (revisionError name failure)+      Right evidence -> Right (HookRevision name (Just (Revision.hookRevision evidence)) (Just evidence))++verifyHookRevisions :: [HookRevision] -> IO (Either CliError ())+verifyHookRevisions [] = pure (Right ())+verifyHookRevisions (HookRevision _ _ Nothing : rest) = verifyHookRevisions rest+verifyHookRevisions (HookRevision name _ (Just evidence) : rest) = do+  checked <- Revision.verifyHookRevisionInputs evidence+  case checked of+    Left failure -> pure (Left (revisionError name failure))+    Right () -> verifyHookRevisions rest++revisionError :: Text -> Revision.RevisionError -> CliError+revisionError hook failure = CliError "hook-revision" code (hook <> ": " <> message) Nothing Nothing Nothing Nothing 1 Nothing Nothing Nothing Nothing+  where+    (code, message) = case failure of+      Revision.InputsChanged label -> ("hook_revision_inputs_changed", "selected input changed: " <> Revision.inputNameText label)+      Revision.InputUnreadable label -> ("hook_revision_input_unreadable", "selected input cannot be read: " <> Revision.inputNameText label)+      _ -> ("hook_revision_input_unreadable", "invalid selected inputs")

@@ -0,0 +1,43 @@+-- | Bounded validation admission and command-wide cancellation.+module Hinagata.Cli.Validation (cancelledError, validateBatches) where++import Control.Concurrent.Async qualified as Async+import Control.Exception qualified+import Data.Text qualified as Text+import Hinagata.Cli.Output (CliError (..), ValidationResult (..))+import Hinagata.Cli.Process (CancellationScope, CommandCancelled (..), cancellationSignal, waitCancellation, withCooperativeCancellation)++cancelledError :: Int -> CliError+cancelledError signal = CliError "command" "command_cancelled" "command cancelled before completion" Nothing Nothing Nothing Nothing (128 + signal) Nothing Nothing Nothing Nothing++-- | A worker is joined even after cancellation. Its typed preparation result+-- takes precedence over a generic cancellation; completed results are retained.+validateBatches :: CancellationScope -> Int -> (Text.Text -> IO ValidationResult) -> [Text.Text] -> IO [ValidationResult]+validateBatches scope size validate names = withCooperativeCancellation scope (go (chunksOf size names))+  where+    cancelled name signal = ValidationResult name (Left (cancelledError signal))+    run name = Async.withAsync (validate name) $ \worker -> do+      raced <- Async.race (Async.waitCatch worker) (waitCancellation scope)+      result <- case raced of+        Left completed -> pure completed+        Right signal -> do+          Async.cancelWith worker (CommandCancelled signal)+          Async.waitCatch worker+      case result of+        Right value -> pure value+        Left exception -> case Control.Exception.fromException exception of+          Just (CommandCancelled signal) -> pure (cancelled name signal)+          Nothing -> Control.Exception.throwIO exception+    go [] = pure []+    go (batch : pending) = do+      signal <- cancellationSignal scope+      case signal of+        Just number -> pure (map (\name -> cancelled name number) (concat (batch : pending)))+        Nothing -> do+          results <- Async.mapConcurrently run batch+          rest <- go pending+          pure (results <> rest)++chunksOf :: Int -> [a] -> [[a]]+chunksOf _ [] = []+chunksOf size values = let (first, rest) = splitAt size values in first : chunksOf size rest

@@ -0,0 +1,174 @@+module Main (main) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async qualified as Async+import Control.Concurrent.MVar+import Control.Exception (bracket, finally, try)+import Control.Monad (unless, void)+import Data.IORef+import Hinagata.Cli.Command (compileScenario, prepareBaselineWithRunner)+import Hinagata.Cli.Config+import Hinagata.Cli.Options (CliOptions (..))+import Hinagata.Cli.Output (CliError (..), ValidationResult (..), leaseError)+import Hinagata.Cli.Process+import Hinagata.Cli.Process qualified as Process+import Hinagata.Cli.Validation (validateBatches)+import Hinagata.Config qualified as Config+import Hinagata.Connection+import Hinagata.Postgres.Cleanup qualified as Cleanup+import Hinagata.Postgres.Lease qualified as Lease+import Hinagata.Postgres.Manager+import Hinagata.Types+import Settei.Optparse (DiagnosticMode (NoDiagnostic))+import System.Directory (doesFileExist, removePathForcibly)+import System.Environment (getArgs)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.Posix.Signals+import System.Posix.Temp (mkdtemp)+import System.Timeout (timeout)++main :: IO ()+main = bracket (mkdtemp "/tmp/hinagata-process-XXXXXX") removePathForcibly $ \directory -> do+  host <- require (tcpHost "127.0.0.1")+  port <- require (mkPort 1)+  database <- require (mkDatabaseName "unused")+  secret <- require (mkSecret "process-secret-sentinel")+  target <- require (mkConnectionTarget host port "unused" database (Just secret))+  let spec = ChildSpec "/bin/sh" [] Nothing [] target Nothing (Just 50) True+  -- Signals arriving before and during registration are observed atomically.+  restored <- newEmptyMVar+  previous <- installHandler sigTERM (Catch (void (tryPutMVar restored ()))) Nothing+  withCancellationScope $ \scope -> do+    withRegistration scope $ \marker -> do+      raiseSignal sigINT+      assert "registered child observes INT" =<< ((== Just 2) <$> timeout 1000000 (readMVar marker))+    withRegistration scope $ \marker ->+      assert "late registration observes prior cancellation" =<< ((== 2) <$> readMVar marker)+    raiseSignal sigTERM+    threadDelay 30000+    assert "first signal survives repeated signals" =<< ((== Just 2) <$> cancellationSignal scope)+    spawned <- try @CommandCancelled (runChild scope spec)+    assert "cancelled scope refuses spawning" (case spawned of Left (CommandCancelled 2) -> True; _ -> False)+  raiseSignal sigTERM+  assert "original handlers restored at scope exit" =<< ((== Just ()) <$> timeout 1000000 (takeMVar restored))+  _ <- installHandler sigTERM previous Nothing+  let marker = directory </> "password-path"+      asleep = spec {Process.arguments = ["-c", "printf '%s' \"$PGPASSFILE\" > \"$1\"; sleep 30", "sh", marker], Process.deadlineMs = Just 100}+  withCancellationScope $ \scope -> do+    report <- runChildWithCleanupCheck (pure False) scope asleep+    assert "deterministic uncertain stop retained in normal report" (case report of Right ChildReport {cleanupFailure = Just _, timedOut = True} -> True; _ -> False)+    password <- readFile marker+    assert "private password removed after timeout" . not =<< doesFileExist password+    unwound <- try @ChildCleanupException (timeout 150000 (runChildWithCleanupCheck (pure False) scope (asleep {Process.deadlineMs = Nothing})))+    assert "uncertain cleanup survives asynchronous timeout unwinding" (case unwound of Left ChildCleanupException -> True; _ -> False)+    passwordAfter <- readFile marker+    assert "private password removed during unwind" . not =<< doesFileExist passwordAfter+  withCancellationScope $ \scope -> do+    let ready = directory </> "ready"+        zeroExit = spec {Process.arguments = ["-c", "trap 'exit 0' INT TERM; touch \"$1\"; while :; do sleep .05; done", "sh", ready], Process.deadlineMs = Nothing}+    Async.withAsync (runChild scope zeroExit) $ \child -> do+      waitFile ready+      raiseSignal sigTERM+      result <- timeout 6000000 (Async.wait child)+      assert "zero-exit signal handler cannot turn cancellation into success" (case result of Just (Right ChildReport {cancelledBy = Just 15, cleanupFailure = Nothing}) -> True; _ -> False)+  withCancellationScope $ \scope -> do+    entered <- newEmptyMVar+    cleaned <- newEmptyMVar+    Async.withAsync (try @CommandCancelled (withCommandCancellation scope (putMVar entered () >> threadDelay 30000000 `finally` putMVar cleaned ()))) $ \command -> do+      takeMVar entered+      raiseSignal sigTERM+      result <- timeout 2000000 (Async.wait command)+      assert "root supervisor cancels native work" (case result of Just (Left (CommandCancelled 15)) -> True; _ -> False)+      assert "root supervisor joins cleanup" =<< ((== Just ()) <$> tryReadMVar cleaned)+  withCancellationScope $ \scope -> do+    entered <- newEmptyMVar+    finish <- newEmptyMVar+    Async.withAsync (withCommandCancellation scope (withCooperativeCancellation scope (putMVar entered () >> waitCancellation scope >> takeMVar finish >> pure (17 :: Int)))) $ \command -> do+      takeMVar entered+      raiseSignal sigINT+      _ <- waitCancellation scope+      raiseSignal sigTERM+      putMVar finish ()+      result <- timeout 2000000 (Async.wait command)+      assert "root preserves delegated outcome through repeated signals" (result == Just 17)+  getArgs >>= \case+    [] -> pure ()+    [path] -> postgresTests path+    _ -> fail "expected optional CLI configuration path"+  putStrLn "CLI process scope, race, and cleanup fault tests passed"++postgresTests :: FilePath -> IO ()+postgresTests path = do+  resolved <- resolveConfig (CliOptions [path] [] NoDiagnostic Nothing)+  ((configuration, settings), _) <- either (const (fail "test configuration failed")) pure resolved+  scenario <- require =<< compileScenario configuration []+  -- Both ordinary completion and outer-deadline unwinding must reach the same+  -- typed library preservation boundary, without calling the consumer.+  mapM_ (preservation configuration settings scenario) [False, True]+  withCancellationScope $ \scope -> do+    ordinal <- newIORef (0 :: Int)+    ready <- newEmptyMVar+    let runner commandScope child = do+          index <- atomicModifyIORef' ordinal (\n -> (n + 1, n))+          void (tryPutMVar ready ())+          if index == 0+            then runChildWithCleanupCheck (pure False) commandScope child+            else pure (Right (ChildReport (Just (ExitFailure 17)) False Nothing Nothing))+        hook = HookSettings (Just "/bin/sh") ["-c", "sleep 30"] Nothing [] Nothing False [] [] 10000+        selected = settings {clonePreparation = hook}+    (baseline, _) <- require =<< prepareBaselineWithRunner runner scope configuration selected+    Async.withAsync+      ( withCommandCancellation scope $ withManager configuration $ \manager ->+          validateBatches+            scope+            2+            ( \name -> do+                result <- withManagedDatabaseClassified manager baseline scenario Lease.ReleaseAlways (const False) (const (checkCancellation scope))+                pure (ValidationResult name (either (Left . leaseError "fixture-validate" (Just name)) (Right . Lease.timings) result))+            )+            ["unsafe", "ordinary", "pending"]+      )+      $ \workers -> do+        readMVar ready+        threadDelay 100000+        raiseSignal sigINT+        results <- Async.wait workers+        assert "signal wins command aggregate status" =<< ((== Just 2) <$> cancellationSignal scope)+        let errors = [problem | ValidationResult {result = Left problem} <- results]+        assert "sibling errors survive shared cancellation" (any (\CliError {code} -> code == "clone_preparation_cleanup_failed") errors && any (\CliError {code} -> code == "clone_preparation_failed") errors && any (\CliError {code} -> code == "command_cancelled") errors)+        mapM_ (\CliError {errorLeaseId} -> mapM_ (void . Cleanup.releaseLease configuration) errorLeaseId) errors+  where+    preservation configuration settings scenario outerDeadline = withCancellationScope $ \scope -> do+      called <- newIORef False+      limit <- require (mkPositive "test deadline" 600)+      let hook = HookSettings (Just "/bin/sh") ["-c", if outerDeadline then "sleep 30" else "exit 0"] Nothing [] Nothing False [] [] 10000+          selected = settings {clonePreparation = hook}+          bounded = if outerDeadline then configuration {Config.acquisitionDeadlineMs = limit} else configuration+      (baseline, _) <- require =<< prepareBaselineWithRunner (runChildWithCleanupCheck (pure False)) scope bounded selected+      result <- withManager bounded $ \manager -> withManagedDatabaseClassified manager baseline scenario Lease.ReleaseAlways (const False) (\_ -> writeIORef called True)+      assert "unsafe preparation prevents consumer" . not =<< readIORef called+      case result of+        Left problem@Lease.LeaseError {preparationContext = Just Lease.PreparationContext {preparationLeaseId}} -> do+          let CliError {code} = leaseError "lease-acquire" Nothing problem+          assert "unsafe preparation has stable diagnostic" (code == "clone_preparation_cleanup_failed")+          inspected <- require =<< Cleanup.inspectLease bounded preparationLeaseId+          assert "unsafe preparation preserves inspectable ownership" (case inspected of Just Cleanup.CleanupCandidate {state = "Preserved"} -> True; _ -> False)+          void (require =<< Cleanup.releaseLease bounded preparationLeaseId)+        _ -> fail ("unsafe preparation lost context: " <> show result)++-- The seam records uncertainty after doing real process-group cleanup;+-- explicit release here is safe because this test knows the injection.++assert :: String -> Bool -> IO ()+assert message condition = unless condition (fail message)++require :: (Show e) => Either e a -> IO a+require = either (fail . show) pure++waitFile :: FilePath -> IO ()+waitFile path = do+  ready <- timeout 2000000 loop+  assert "child readiness" (ready == Just ())+  where+    loop = doesFileExist path >>= \found -> unless found (threadDelay 10000 >> loop)