diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/hinagata-cli.cabal b/hinagata-cli.cabal new file mode 100644 --- /dev/null +++ b/hinagata-cli.cabal @@ -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 diff --git a/src/Hinagata/Cli/Command.hs b/src/Hinagata/Cli/Command.hs new file mode 100644 --- /dev/null +++ b/src/Hinagata/Cli/Command.hs @@ -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) + ] diff --git a/src/Hinagata/Cli/Config.hs b/src/Hinagata/Cli/Config.hs new file mode 100644 --- /dev/null +++ b/src/Hinagata/Cli/Config.hs @@ -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) diff --git a/src/Hinagata/Cli/Options.hs b/src/Hinagata/Cli/Options.hs new file mode 100644 --- /dev/null +++ b/src/Hinagata/Cli/Options.hs @@ -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" diff --git a/src/Hinagata/Cli/Output.hs b/src/Hinagata/Cli/Output.hs new file mode 100644 --- /dev/null +++ b/src/Hinagata/Cli/Output.hs @@ -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] diff --git a/src/Hinagata/Cli/Process.hs b/src/Hinagata/Cli/Process.hs new file mode 100644 --- /dev/null +++ b/src/Hinagata/Cli/Process.hs @@ -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) diff --git a/src/Hinagata/Cli/Revision.hs b/src/Hinagata/Cli/Revision.hs new file mode 100644 --- /dev/null +++ b/src/Hinagata/Cli/Revision.hs @@ -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") diff --git a/src/Hinagata/Cli/Validation.hs b/src/Hinagata/Cli/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Hinagata/Cli/Validation.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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)