diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# Changelog + +## 1.0.0.0 — 2026-07-10 + +- Initial stable release of the reusable command tree, typed dispatcher, text output, + parser-derived completion, and JSON schema v1 including history-import reports. diff --git a/pg-migrate-cli.cabal b/pg-migrate-cli.cabal new file mode 100644 --- /dev/null +++ b/pg-migrate-cli.cabal @@ -0,0 +1,112 @@ +cabal-version: 3.8 +name: pg-migrate-cli +version: 1.0.0.0 +synopsis: Reusable command parsers and renderers for pg-migrate +category: Database +maintainer: nadeem@gmail.com +description: + Lets service executables mount pg-migrate commands while retaining ownership + of configuration precedence, output streams, logging, and process exit. + +license: BSD-3-Clause +build-type: Simple +extra-doc-files: CHANGELOG.md +data-files: + test/golden/help/*.txt + test/golden/json/*.json + +common common + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + MultilineStrings + OverloadedLabels + OverloadedStrings + + ghc-options: -Wall -Wcompat + +library + import: common + hs-source-dirs: src + exposed-modules: + Database.PostgreSQL.Migrate.CLI + PgMigrate.CLI.Prelude + + other-modules: + Database.PostgreSQL.Migrate.CLI.Handler + Database.PostgreSQL.Migrate.CLI.Json + Database.PostgreSQL.Migrate.CLI.Outcome + Database.PostgreSQL.Migrate.CLI.Parser + Database.PostgreSQL.Migrate.CLI.Text + Database.PostgreSQL.Migrate.CLI.Types + + build-depends: + , aeson >=2.2 && <2.3 + , base >=4.20 && <4.22 + , bytestring >=0.12 && <0.13 + , containers >=0.7 && <0.8 + , hasql >=1.10 && <1.11 + , optparse-applicative >=0.19 && <0.20 + , pg-migrate >=1.0 && <1.1 + , pg-migrate-embed >=1.0 && <1.1 + , text >=2.1 && <2.2 + , time >=1.12 && <1.15 + +test-suite pg-migrate-cli-test + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test/unit + main-is: Main.hs + other-modules: + Paths_pg_migrate_cli + Test.Handler + Test.Json + Test.Parser + + autogen-modules: Paths_pg_migrate_cli + build-depends: + , aeson >=2.2 && <2.3 + , base >=4.20 && <4.22 + , bytestring >=0.12 && <0.13 + , containers >=0.7 && <0.8 + , directory >=1.3 && <1.4 + , filepath >=1.5 && <1.6 + , hasql >=1.10 && <1.11 + , optparse-applicative >=0.19 && <0.20 + , pg-migrate + , pg-migrate-cli + , pg-migrate-embed + , tasty >=1.5 && <1.6 + , tasty-hunit >=0.10 && <0.11 + , text >=2.1 && <2.2 + , time >=1.12 && <1.15 + +test-suite pg-migrate-cli-integration + import: common + type: exitcode-stdio-1.0 + ghc-options: -threaded + hs-source-dirs: test/integration + main-is: Main.hs + build-depends: + , base >=4.20 && <4.22 + , bytestring >=0.12 && <0.13 + , containers >=0.7 && <0.8 + , hasql >=1.10 && <1.11 + , pg-migrate + , pg-migrate-cli + , tasty >=1.5 && <1.6 + , tasty-hunit >=0.10 && <0.11 + , text >=2.1 && <2.2 + +executable pg-migrate-cli-help-fixture + import: common + hs-source-dirs: test/help-fixture + main-is: Main.hs + build-depends: + , base >=4.20 && <4.22 + , bytestring >=0.12 && <0.13 + , containers >=0.7 && <0.8 + , optparse-applicative >=0.19 && <0.20 + , pg-migrate + , pg-migrate-cli diff --git a/src/Database/PostgreSQL/Migrate/CLI.hs b/src/Database/PostgreSQL/Migrate/CLI.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate/CLI.hs @@ -0,0 +1,49 @@ +-- | Reusable parser, dispatcher, and text/JSON rendering boundary. Applications retain +-- ownership of their plan, connection configuration, streams, logging, and process exit. +module Database.PostgreSQL.Migrate.CLI + ( migrationCommandParser, + CliEnvironment, + cliEnvironment, + cliEnvironmentWithConnectionProvider, + runMigrationCommand, + renderMigrationCommandText, + jsonSchemaVersion, + renderMigrationCommandJson, + renderHistoryImportJson, + ExitClass (..), + CheckedMigration (..), + CliPayload (..), + CliError (..), + CliOutcome (..), + OutputFormat (..), + ConnectionOptions (..), + ExecutionOptions (..), + OutputOptions (..), + InspectionOptions (..), + PlanOptions (..), + ListOptions (..), + CheckOptions (..), + StatusOptions (..), + VerifyOptions (..), + UpOptions (..), + RepairOptions (..), + NewOptions (..), + MigrationCommand (..), + ) +where + +import Database.PostgreSQL.Migrate.CLI.Handler + ( CliEnvironment, + cliEnvironment, + cliEnvironmentWithConnectionProvider, + runMigrationCommand, + ) +import Database.PostgreSQL.Migrate.CLI.Json + ( jsonSchemaVersion, + renderHistoryImportJson, + renderMigrationCommandJson, + ) +import Database.PostgreSQL.Migrate.CLI.Outcome +import Database.PostgreSQL.Migrate.CLI.Parser (migrationCommandParser) +import Database.PostgreSQL.Migrate.CLI.Text (renderMigrationCommandText) +import Database.PostgreSQL.Migrate.CLI.Types diff --git a/src/Database/PostgreSQL/Migrate/CLI/Handler.hs b/src/Database/PostgreSQL/Migrate/CLI/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate/CLI/Handler.hs @@ -0,0 +1,268 @@ +module Database.PostgreSQL.Migrate.CLI.Handler + ( CliEnvironment, + cliEnvironment, + cliEnvironmentWithConnectionProvider, + runMigrationCommand, + ) +where + +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text.Encoding qualified as Text.Encoding +import Database.PostgreSQL.Migrate + ( ComponentName, + Confirmation, + ConnectionProvider, + MigrationId, + MigrationPlan, + RepairOperation, + RunOptions, + StatusReport (..), + StoredMigration (..), + VerificationReport (..), + connectionProviderFromSettings, + migrationFingerprint, + migrationStatusWith, + repairMigration, + repairRequest, + runMigrationPlanWith, + verifyMigrationPlanWith, + withLockWait, + withStatementTimeout, + ) +import Database.PostgreSQL.Migrate.CLI.Outcome +import Database.PostgreSQL.Migrate.CLI.Types +import Database.PostgreSQL.Migrate.Embed + ( AuthoringError (..), + checkMigrationManifest, + newMigration, + newMigrationOptions, + ) +import Database.PostgreSQL.Migrate.Internal + ( ComponentDescription (..), + MigrationDescription (..), + PlanDescription (..), + migrationIdComponent, + migrationIdName, + planDescription, + ) +import Hasql.Connection.Settings qualified as Settings +import PgMigrate.CLI.Prelude + +data CliConnection + = SettingsConnection !Settings.Settings + | ProviderConnection !ConnectionProvider + +-- | Application-supplied plan, runner defaults, and connection ownership boundary. +data CliEnvironment = CliEnvironment + { defaultConnection :: !CliConnection, + migrationPlan :: !MigrationPlan, + runnerOptions :: !RunOptions + } + +-- | Construct a CLI environment from concrete Hasql settings. +cliEnvironment :: Settings.Settings -> MigrationPlan -> RunOptions -> CliEnvironment +cliEnvironment settings = CliEnvironment (SettingsConnection settings) + +-- | Construct a CLI environment from an application connection provider. +cliEnvironmentWithConnectionProvider :: + ConnectionProvider -> + MigrationPlan -> + RunOptions -> + CliEnvironment +cliEnvironmentWithConnectionProvider provider = CliEnvironment (ProviderConnection provider) + +-- | Dispatch a parsed command without writing streams or exiting the process. +runMigrationCommand :: CliEnvironment -> MigrationCommand -> IO CliOutcome +runMigrationCommand environment commandValue = + case commandValue of + Plan PlanOptions {inspection} -> + pure + ( success + "plan" + (PlanPayload (filterPlan inspection (planDescription (migrationPlan environment)))) + ) + List ListOptions {inspection} -> + pure + ( success + "list" + ( ListPayload + ( filterMigrations + inspection + (flattenPlanDescription (planDescription (migrationPlan environment))) + ) + ) + ) + Check CheckOptions {manifestPath} -> runCheck manifestPath + Status StatusOptions {inspection, connection} -> runStatus environment inspection connection + Verify VerifyOptions {inspection, connection} -> runVerify environment inspection connection + Up UpOptions {connection, execution} -> runUp environment connection execution + Repair RepairOptions {target, operation, reason, confirmation, connection, execution} -> + runRepair environment connection execution target operation reason confirmation + New NewOptions {manifestPath, description, requestedName} -> + runNew manifestPath description requestedName + +runCheck :: FilePath -> IO CliOutcome +runCheck manifestPath = do + checked <- checkMigrationManifest manifestPath + pure $ case checked of + Left manifestError -> failure "check" ExitUsageFailed (CliManifestError manifestError) + Right entries -> + success + "check" + ( CheckPayload + ((\(file, bytes) -> CheckedMigration file (migrationFingerprint bytes)) <$> entries) + ) + +runStatus :: CliEnvironment -> InspectionOptions -> ConnectionOptions -> IO CliOutcome +runStatus environment inspection connection = do + result <- + migrationStatusWith + (runnerOptions environment) + (selectProvider environment connection) + (migrationPlan environment) + pure $ case result of + Left migrationError -> failure "status" ExitExecutionFailed (CliMigrationError migrationError) + Right report -> success "status" (StatusPayload (filterStatus inspection report)) + +runVerify :: CliEnvironment -> InspectionOptions -> ConnectionOptions -> IO CliOutcome +runVerify environment inspection connection = do + result <- + verifyMigrationPlanWith + (runnerOptions environment) + (selectProvider environment connection) + (migrationPlan environment) + pure $ case result of + Left migrationError -> failure "verify" ExitExecutionFailed (CliMigrationError migrationError) + Right report -> + CliOutcome + { command = "verify", + exitClass = verificationExitClass report, + payload = Right (VerifyPayload (filterVerification inspection report)) + } + +runUp :: CliEnvironment -> ConnectionOptions -> ExecutionOptions -> IO CliOutcome +runUp environment connection execution = do + result <- + runMigrationPlanWith + (applyExecution execution (runnerOptions environment)) + (selectProvider environment connection) + (migrationPlan environment) + pure $ case result of + Left migrationError -> failure "up" ExitExecutionFailed (CliMigrationError migrationError) + Right report -> success "up" (UpPayload report) + +runRepair :: + CliEnvironment -> + ConnectionOptions -> + ExecutionOptions -> + MigrationId -> + RepairOperation -> + Text -> + Confirmation -> + IO CliOutcome +runRepair environment connection execution target operation reason confirmation = + case repairRequest target operation reason confirmation of + Left definitionError -> + pure (failure "repair" ExitUsageFailed (CliRepairDefinitionError definitionError)) + Right request -> do + result <- + repairMigration + (applyExecution execution (runnerOptions environment)) + (selectProvider environment connection) + (migrationPlan environment) + request + pure $ case result of + Left repairError -> failure "repair" ExitExecutionFailed (CliRepairError repairError) + Right report -> success "repair" (RepairPayload report) + +runNew :: FilePath -> Text -> Maybe FilePath -> IO CliOutcome +runNew manifestPath description requestedName = + case newMigrationOptions manifestPath requestedName initialSql of + Left authoringError -> + pure (failure "new" ExitUsageFailed (CliAuthoringError authoringError)) + Right options -> do + result <- newMigration options + pure $ case result of + Left authoringError -> + failure "new" (authoringExitClass authoringError) (CliAuthoringError authoringError) + Right path -> success "new" (NewPayload path) + where + initialSql = Text.Encoding.encodeUtf8 ("-- " <> description <> "\n\n") + +selectProvider :: CliEnvironment -> ConnectionOptions -> ConnectionProvider +selectProvider CliEnvironment {defaultConnection} ConnectionOptions {databaseSettings} = + case databaseSettings of + Just settings -> connectionProviderFromSettings settings + Nothing -> + case defaultConnection of + SettingsConnection settings -> connectionProviderFromSettings settings + ProviderConnection provider -> provider + +applyExecution :: ExecutionOptions -> RunOptions -> RunOptions +applyExecution ExecutionOptions {lockWait, statementTimeout} = + withStatementTimeout statementTimeout . withLockWait lockWait + +verificationExitClass :: VerificationReport -> ExitClass +verificationExitClass VerificationReport {issues} + | null issues = ExitSuccess + | otherwise = ExitVerificationFailed + +authoringExitClass :: AuthoringError -> ExitClass +authoringExitClass authoringError = + case authoringError of + AuthoringIoError {} -> ExitExecutionFailed + AuthoringCleanupError {} -> ExitExecutionFailed + _ -> ExitUsageFailed + +success :: Text -> CliPayload -> CliOutcome +success command payload = CliOutcome {command, exitClass = ExitSuccess, payload = Right payload} + +failure :: Text -> ExitClass -> CliError -> CliOutcome +failure command exitClass cliError = CliOutcome {command, exitClass, payload = Left cliError} + +flattenPlanDescription :: PlanDescription -> [MigrationDescription] +flattenPlanDescription (PlanDescription components) = + concatMap (toList . migrations) (toList components) + +filterPlan :: InspectionOptions -> PlanDescription -> [ComponentDescription] +filterPlan inspection (PlanDescription components) = + foldr filterComponent [] (toList components) + where + filterComponent componentDescription@ComponentDescription {name, migrations} remaining + | not (matchesComponent inspection name) = remaining + | otherwise = + case NonEmpty.nonEmpty (filter (matchesMigrationDescription inspection) (toList migrations)) of + Nothing -> remaining + Just filteredMigrations -> + componentDescription {migrations = filteredMigrations} : remaining + +filterMigrations :: InspectionOptions -> [MigrationDescription] -> [MigrationDescription] +filterMigrations inspection = filter (matchesMigrationDescription inspection) + +filterStatus :: InspectionOptions -> StatusReport -> StatusReport +filterStatus inspection (StatusReport issues applied pending unknown) = + StatusReport + issues + (filter (matchesMigrationId inspection) applied) + (filter (matchesMigrationId inspection) pending) + (filter (matchesMigrationId inspection . storedMigrationId) unknown) + +filterVerification :: InspectionOptions -> VerificationReport -> VerificationReport +filterVerification inspection (VerificationReport issues applied pending unknown) = + VerificationReport + issues + (filter (matchesMigrationId inspection) applied) + (filter (matchesMigrationId inspection) pending) + (filter (matchesMigrationId inspection . storedMigrationId) unknown) + +matchesMigrationDescription :: InspectionOptions -> MigrationDescription -> Bool +matchesMigrationDescription inspection MigrationDescription {migrationId} = + matchesMigrationId inspection migrationId + +matchesMigrationId :: InspectionOptions -> MigrationId -> Bool +matchesMigrationId InspectionOptions {component, migration} identifier = + maybe True (== migrationIdComponent identifier) component + && maybe True (== migrationIdName identifier) migration + +matchesComponent :: InspectionOptions -> ComponentName -> Bool +matchesComponent InspectionOptions {component} candidate = maybe True (== candidate) component diff --git a/src/Database/PostgreSQL/Migrate/CLI/Json.hs b/src/Database/PostgreSQL/Migrate/CLI/Json.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate/CLI/Json.hs @@ -0,0 +1,305 @@ +module Database.PostgreSQL.Migrate.CLI.Json + ( jsonSchemaVersion, + renderMigrationCommandJson, + renderHistoryImportJson, + ) +where + +import Data.Aeson (Value, object, (.=)) +import Data.Aeson.Types (Pair) +import Data.ByteString qualified as ByteString +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Time (UTCTime, defaultTimeLocale, formatTime) +import Database.PostgreSQL.Migrate +import Database.PostgreSQL.Migrate.CLI.Outcome +import Database.PostgreSQL.Migrate.Internal +import Numeric qualified +import PgMigrate.CLI.Prelude + +-- | Supported machine-readable CLI schema version. +jsonSchemaVersion :: Int +jsonSchemaVersion = 1 + +-- | Render a command outcome using JSON schema v1. +renderMigrationCommandJson :: CliOutcome -> Value +renderMigrationCommandJson CliOutcome {command, exitClass, payload} = + object + ( [ "schemaVersion" .= jsonSchemaVersion, + "command" .= command, + "ok" .= (exitClass == ExitSuccess) + ] + <> case payload of + Left cliError -> ["error" .= errorValue cliError] + Right cliPayload -> ["data" .= payloadValue cliPayload] + ) + +-- | Render an adapter import report using JSON schema v1. +renderHistoryImportJson :: Text -> HistoryImportReport -> Value +renderHistoryImportJson sourceName HistoryImportReport {importResults} = + object + [ "schemaVersion" .= jsonSchemaVersion, + "command" .= ("import" :: Text), + "ok" .= True, + "data" + .= object + [ "source" .= sourceName, + "results" .= (historyImportResultValue <$> NonEmpty.toList importResults) + ] + ] + +historyImportResultValue :: HistoryImportResult -> Value +historyImportResultValue HistoryImportResult {importedMigration, importOutcome} = + object + [ "id" .= migrationIdText importedMigration, + "outcome" .= case importOutcome of Imported -> ("imported" :: Text); AlreadyImported -> "alreadyImported" + ] + +payloadValue :: CliPayload -> Value +payloadValue cliPayload = + case cliPayload of + PlanPayload components -> + object ["components" .= (componentValue <$> components)] + ListPayload migrations -> + object ["migrations" .= (migrationValue <$> migrations)] + CheckPayload checked -> + object ["migrations" .= (checkedValue <$> NonEmpty.toList checked)] + StatusPayload report -> statusValue report + VerifyPayload report -> verificationValue report + UpPayload report -> migrationReportValue report + RepairPayload report -> repairReportValue report + NewPayload path -> object ["path" .= path] + +componentValue :: ComponentDescription -> Value +componentValue (ComponentDescription name position dependencies migrations) = + object + [ "name" .= componentNameText name, + "position" .= position, + "dependencies" .= (componentNameText <$> Set.toAscList dependencies), + "migrations" .= (migrationValue <$> NonEmpty.toList migrations) + ] + +migrationValue :: MigrationDescription -> Value +migrationValue (MigrationDescription identifier position checksum kind mode) = + object + [ "id" .= migrationIdText identifier, + "position" .= position, + "checksum" .= checksumText checksum, + "kind" .= kindText kind, + "transactionMode" .= modeText mode + ] + +checkedValue :: CheckedMigration -> Value +checkedValue (CheckedMigration file checksum) = + object + [ "file" .= file, + "checksum" .= checksumText checksum + ] + +statusValue :: StatusReport -> Value +statusValue (StatusReport issues applied pending unknown) = + object + [ "issues" .= (verificationIssueValue <$> issues), + "applied" .= (migrationIdText <$> applied), + "pending" .= (migrationIdText <$> pending), + "unknown" .= (storedMigrationValue <$> unknown) + ] + +verificationValue :: VerificationReport -> Value +verificationValue (VerificationReport issues applied pending unknown) = + object + [ "issues" .= (verificationIssueValue <$> issues), + "applied" .= (migrationIdText <$> applied), + "pending" .= (migrationIdText <$> pending), + "unknown" .= (storedMigrationValue <$> unknown) + ] + +storedMigrationValue :: StoredMigration -> Value +storedMigrationValue + ( StoredMigration + identifier + position + checksum + kind + mode + status + startedAt + finishedAt + executionTimeMilliseconds + errorMessage + runnerVersion + ) = + object + [ "id" .= migrationIdText identifier, + "position" .= position, + "checksum" .= checksumText checksum, + "kind" .= kindText kind, + "transactionMode" .= modeText mode, + "status" .= statusText status, + "startedAt" .= utcText startedAt, + "finishedAt" .= (utcText <$> finishedAt), + "durationMilliseconds" .= executionTimeMilliseconds, + "error" .= errorMessage, + "runnerVersion" .= runnerVersion + ] + +verificationIssueValue :: VerificationIssue -> Value +verificationIssueValue issue = + case issue of + DuplicateStoredMigration identifier -> issueWithId "duplicateStoredMigration" identifier + DuplicateStoredPosition component position -> + object + [ "type" .= ("duplicateStoredPosition" :: Text), + "component" .= componentNameText component, + "position" .= position + ] + StoredMigrationRunning identifier -> issueWithId "storedMigrationRunning" identifier + StoredMigrationFailed identifier -> issueWithId "storedMigrationFailed" identifier + MigrationPositionMismatch identifier expected actual -> + mismatchValue "migrationPositionMismatch" identifier ("expected" .= expected) ("actual" .= actual) + MigrationChecksumMismatch identifier expected actual -> + mismatchValue + "migrationChecksumMismatch" + identifier + ("expected" .= checksumText expected) + ("actual" .= checksumText actual) + MigrationKindMismatch identifier expected actual -> + mismatchValue + "migrationKindMismatch" + identifier + ("expected" .= kindText expected) + ("actual" .= kindText actual) + MigrationTransactionModeMismatch identifier expected actual -> + mismatchValue + "migrationTransactionModeMismatch" + identifier + ("expected" .= modeText expected) + ("actual" .= modeText actual) + AppliedMigrationAfterGap identifier missing -> + object + [ "type" .= ("appliedMigrationAfterGap" :: Text), + "id" .= migrationIdText identifier, + "missing" .= migrationIdText missing + ] + UnknownStoredMigration identifier -> issueWithId "unknownStoredMigration" identifier + PendingMigration identifier -> issueWithId "pendingMigration" identifier + +issueWithId :: Text -> MigrationId -> Value +issueWithId issueType identifier = + object + [ "type" .= issueType, + "id" .= migrationIdText identifier + ] + +mismatchValue :: Text -> MigrationId -> Pair -> Pair -> Value +mismatchValue issueType identifier expected actual = + object ["type" .= issueType, "id" .= migrationIdText identifier, expected, actual] + +migrationReportValue :: MigrationReport -> Value +migrationReportValue (MigrationReport startedAt finishedAt results) = + object + [ "startedAt" .= utcText startedAt, + "finishedAt" .= utcText finishedAt, + "results" .= (migrationResultValue <$> NonEmpty.toList results) + ] + +migrationResultValue :: MigrationResult -> Value +migrationResultValue (MigrationResult identifier outcome duration) = + object + [ "id" .= migrationIdText identifier, + "outcome" .= outcomeText outcome, + "durationMilliseconds" .= (durationMilliseconds <$> duration) + ] + +repairReportValue :: RepairReport -> Value +repairReportValue (RepairReport identifier operation oldStatus newStatus) = + object + [ "id" .= migrationIdText identifier, + "operation" .= repairOperationText operation, + "oldStatus" .= statusText oldStatus, + "newStatus" .= statusText newStatus + ] + +errorValue :: CliError -> Value +errorValue cliError = + object + [ "type" .= cliErrorType cliError, + "message" .= Text.pack (renderCliErrorMessage cliError) + ] + +cliErrorType :: CliError -> Text +cliErrorType cliError = + case cliError of + CliMigrationError migrationError -> "migration." <> migrationErrorType migrationError + CliRepairDefinitionError _ -> "repair.definition" + CliRepairError _ -> "repair.execution" + CliManifestError _ -> "manifest.invalid" + CliAuthoringError _ -> "authoring.failed" + +renderCliErrorMessage :: CliError -> String +renderCliErrorMessage cliError = + case cliError of + CliMigrationError err -> show err + CliRepairDefinitionError err -> show err + CliRepairError err -> show err + CliManifestError err -> show err + CliAuthoringError err -> show err + +migrationErrorType :: MigrationError -> Text +migrationErrorType migrationError = + case migrationError of + ConnectionAcquisitionFailed _ -> "connectionAcquisitionFailed" + DatabaseSessionFailed _ -> "databaseSessionFailed" + UnsupportedPostgresVersion _ -> "unsupportedPostgresVersion" + InvalidLockWait _ -> "invalidLockWait" + InvalidStatementTimeout _ -> "invalidStatementTimeout" + AdvisoryLockUnavailable -> "advisoryLockUnavailable" + AdvisoryLockTimedOut _ -> "advisoryLockTimedOut" + LedgerInitializationFailed _ -> "ledgerInitializationFailed" + PlanVerificationFailed _ -> "planVerificationFailed" + UnsupportedNonTransactionalMigration _ -> "unsupportedNonTransactionalMigration" + TransactionCondemned _ -> "transactionCondemned" + EventHandlerFailed _ _ -> "eventHandlerFailed" + MigrationActionFailed _ -> "migrationActionFailed" + InvalidMigrationAction _ -> "invalidMigrationAction" + NonTransactionalMigrationFailed _ _ -> "nonTransactionalMigrationFailed" + LedgerTransitionDidNotMatch _ _ _ -> "ledgerTransitionDidNotMatch" + NonTransactionalFailureRecordingFailed _ _ _ -> "nonTransactionalFailureRecordingFailed" + CleanupFailed _ _ -> "cleanupFailed" + +migrationIdText :: MigrationId -> Text +migrationIdText identifier = + componentNameText (migrationIdComponent identifier) + <> "/" + <> migrationNameText (migrationIdName identifier) + +checksumText :: MigrationChecksum -> Text +checksumText = + Text.pack . concatMap renderByte . ByteString.unpack . migrationChecksumBytes + where + renderByte byte = + case Numeric.showHex byte "" of + [digit] -> ['0', digit] + digits -> digits + +kindText :: MigrationKind -> Text +kindText kind = case kind of SqlKind -> "sql"; HaskellKind -> "haskell" + +modeText :: TransactionMode -> Text +modeText mode = case mode of Transactional -> "transactional"; NonTransactional -> "nontransactional" + +statusText :: MigrationStatus -> Text +statusText status = case status of Running -> "running"; Applied -> "applied"; Failed -> "failed" + +outcomeText :: MigrationOutcome -> Text +outcomeText outcome = case outcome of AlreadyApplied -> "alreadyApplied"; AppliedNow -> "appliedNow" + +repairOperationText :: RepairOperation -> Text +repairOperationText operation = case operation of MarkApplied -> "markApplied"; Retry -> "retry" + +durationMilliseconds :: NominalDiffTime -> Integer +durationMilliseconds duration = round (duration * 1000) + +utcText :: UTCTime -> Text +utcText = Text.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" diff --git a/src/Database/PostgreSQL/Migrate/CLI/Outcome.hs b/src/Database/PostgreSQL/Migrate/CLI/Outcome.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate/CLI/Outcome.hs @@ -0,0 +1,69 @@ +module Database.PostgreSQL.Migrate.CLI.Outcome + ( ExitClass (..), + CheckedMigration (..), + CliPayload (..), + CliError (..), + CliOutcome (..), + ) +where + +import Database.PostgreSQL.Migrate + ( MigrationChecksum, + MigrationError, + MigrationReport, + RepairDefinitionError, + RepairError, + RepairReport, + StatusReport, + VerificationReport, + ) +import Database.PostgreSQL.Migrate.Embed (AuthoringError, ManifestError) +import Database.PostgreSQL.Migrate.Internal + ( ComponentDescription, + MigrationDescription, + ) +import PgMigrate.CLI.Prelude + +-- | Stable process-exit classification chosen by the application. +data ExitClass + = ExitSuccess + | ExitVerificationFailed + | ExitUsageFailed + | ExitExecutionFailed + deriving stock (Generic, Eq, Ord, Show) + +-- | One migration summarized by local plan checking. +data CheckedMigration = CheckedMigration + { file :: !FilePath, + checksum :: !MigrationChecksum + } + deriving stock (Generic, Eq, Show) + +-- | Successful command-specific structured payload. +data CliPayload + = PlanPayload ![ComponentDescription] + | ListPayload ![MigrationDescription] + | CheckPayload !(NonEmpty CheckedMigration) + | StatusPayload !StatusReport + | VerifyPayload !VerificationReport + | UpPayload !MigrationReport + | RepairPayload !RepairReport + | NewPayload !FilePath + deriving stock (Generic, Eq, Show) + +-- | Structured CLI definition, runner, repair, authoring, or import failure. +data CliError + = CliMigrationError !MigrationError + | CliRepairDefinitionError !RepairDefinitionError + | CliRepairError !RepairError + | CliManifestError !ManifestError + | CliAuthoringError !AuthoringError + deriving stock (Generic, Show) + +-- | Renderable command result with stable exit classification. +data CliOutcome = CliOutcome + { command :: !Text, + exitClass :: !ExitClass, + payload :: !(Either CliError CliPayload) + } + deriving stock (Generic, Show) diff --git a/src/Database/PostgreSQL/Migrate/CLI/Parser.hs b/src/Database/PostgreSQL/Migrate/CLI/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate/CLI/Parser.hs @@ -0,0 +1,222 @@ +module Database.PostgreSQL.Migrate.CLI.Parser + ( migrationCommandParser, + ) +where + +import Data.Text qualified as Text +import Database.PostgreSQL.Migrate + ( ComponentName, + Confirmation (Confirmed), + DefinitionError, + LockWait (..), + MigrationId, + MigrationName, + MigrationPlan, + RepairOperation (..), + componentName, + migrationId, + migrationName, + ) +import Database.PostgreSQL.Migrate.CLI.Types +import Hasql.Connection.Settings qualified as Settings +import Options.Applicative +import PgMigrate.CLI.Prelude +import Text.Read qualified as Read + +-- | Build the reusable parser, using the plan for target-aware choices. +migrationCommandParser :: MigrationPlan -> Parser MigrationCommand +migrationCommandParser _ = + subparser (commandGroup "Inspection" <> inspectionCommands) + <|> subparser (commandGroup "Execution" <> executionCommands) + <|> subparser (commandGroup "Authoring" <> authoringCommands) + where + inspectionCommands = + command + "plan" + (info (Plan <$> planOptionsParser <**> helper) (progDesc "Show component order and dependencies")) + <> command + "status" + (info (Status <$> statusOptionsParser <**> helper) (progDesc "Show declared and stored migration status")) + <> command + "verify" + ( info + (Verify <$> verifyOptionsParser <**> helper) + (progDesc "Strictly compare the declared plan with the migration ledger (not live schema snapshots)") + ) + <> command + "list" + (info (List <$> listOptionsParser <**> helper) (progDesc "List declared migrations and metadata")) + <> command + "check" + (info (Check <$> checkOptionsParser <**> helper) (progDesc "Validate an ordered SQL manifest without a database")) + executionCommands = + command + "up" + ( info + (Up <$> upOptionsParser <**> helper) + (progDesc "Apply the complete migration plan; selective execution is unavailable in v1") + ) + <> command + "repair" + (info (Repair <$> repairOptionsParser <**> helper) (progDesc "Repair one nontransactional migration after operator inspection")) + authoringCommands = + command + "new" + (info (New <$> newOptionsParser <**> helper) (progDesc "Create and append one SQL migration without applying it")) + +planOptionsParser :: Parser PlanOptions +planOptionsParser = + PlanOptions + <$> inspectionOptionsParser + <*> outputOptionsParser + +listOptionsParser :: Parser ListOptions +listOptionsParser = + ListOptions + <$> inspectionOptionsParser + <*> outputOptionsParser + +checkOptionsParser :: Parser CheckOptions +checkOptionsParser = + CheckOptions + <$> strArgument (metavar "MANIFEST" <> help "Path to the ordered migration manifest") + <*> outputOptionsParser + +statusOptionsParser :: Parser StatusOptions +statusOptionsParser = + StatusOptions + <$> inspectionOptionsParser + <*> connectionOptionsParser + <*> outputOptionsParser + +verifyOptionsParser :: Parser VerifyOptions +verifyOptionsParser = + VerifyOptions + <$> inspectionOptionsParser + <*> connectionOptionsParser + <*> outputOptionsParser + +upOptionsParser :: Parser UpOptions +upOptionsParser = + UpOptions + <$> connectionOptionsParser + <*> executionOptionsParser + <*> outputOptionsParser + +repairOptionsParser :: Parser RepairOptions +repairOptionsParser = + RepairOptions + <$> argument migrationIdReader (metavar "COMPONENT/MIGRATION") + <*> repairOperationParser + <*> strOption (long "reason" <> metavar "TEXT" <> help "Audit reason for the repair") + <*> flag' Confirmed (long "confirm" <> help "Confirm that the database result was inspected") + <*> connectionOptionsParser + <*> executionOptionsParser + <*> outputOptionsParser + +newOptionsParser :: Parser NewOptions +newOptionsParser = + NewOptions + <$> strOption (long "manifest" <> metavar "PATH" <> help "Ordered manifest to append") + <*> strOption (long "description" <> metavar "TEXT" <> help "Human description written into the new SQL file") + <*> optional (strOption (long "name" <> metavar "BASENAME" <> help "Explicit SQL basename when numeric inference is unavailable")) + <*> outputOptionsParser + +connectionOptionsParser :: Parser ConnectionOptions +connectionOptionsParser = + parserOptionGroup + "Connection" + ( ConnectionOptions + <$> optional + ( option + databaseSettingsReader + ( long "database-url" + <> metavar "URL" + <> help "PostgreSQL URI or keyword/value connection string; no environment variable is read" + ) + ) + ) + +executionOptionsParser :: Parser ExecutionOptions +executionOptionsParser = + parserOptionGroup + "Execution" + ( ExecutionOptions + <$> lockWaitParser + <*> optional + ( option + positiveMillisecondsReader + ( long "statement-timeout" + <> metavar "MILLISECONDS" + <> help "Positive PostgreSQL statement timeout in milliseconds" + ) + ) + ) + +outputOptionsParser :: Parser OutputOptions +outputOptionsParser = + parserOptionGroup + "Output" + ( OutputOptions + <$> flag TextOutput JsonOutput (long "json" <> help "Emit JSON schema version 1") + ) + +inspectionOptionsParser :: Parser InspectionOptions +inspectionOptionsParser = + parserOptionGroup + "Filters" + ( InspectionOptions + <$> optional + (option componentNameReader (long "component" <> metavar "COMPONENT" <> help "Limit inspection output to one component")) + <*> optional + (option migrationNameReader (long "migration" <> metavar "MIGRATION" <> help "Limit inspection output to one migration name")) + ) + +lockWaitParser :: Parser LockWait +lockWaitParser = + flag' NoWait (long "no-wait" <> help "Fail immediately when the advisory lock is unavailable") + <|> ( WaitFor + <$> option + positiveMillisecondsReader + ( long "lock-timeout" + <> metavar "MILLISECONDS" + <> help "Wait at most this many positive milliseconds for the advisory lock" + ) + ) + <|> pure WaitIndefinitely + +repairOperationParser :: Parser RepairOperation +repairOperationParser = + flag' MarkApplied (long "mark-applied" <> help "Record the inspected nontransactional result as applied") + <|> flag' Retry (long "retry" <> help "Return the migration to running and execute its action again") + +positiveMillisecondsReader :: ReadM NominalDiffTime +positiveMillisecondsReader = eitherReader $ \input -> + case Read.readMaybe input :: Maybe Integer of + Just milliseconds + | milliseconds > 0 -> Right (fromRational (toRational milliseconds / 1000)) + _ -> Left "expected a positive integer number of milliseconds" + +databaseSettingsReader :: ReadM Settings.Settings +databaseSettingsReader = Settings.connectionString . Text.pack <$> str + +componentNameReader :: ReadM ComponentName +componentNameReader = validatedTextReader componentName + +migrationNameReader :: ReadM MigrationName +migrationNameReader = validatedTextReader migrationName + +validatedTextReader :: (Text -> Either DefinitionError value) -> ReadM value +validatedTextReader validate = eitherReader $ \input -> + case validate (Text.pack input) of + Left err -> Left (show err) + Right validated -> Right validated + +migrationIdReader :: ReadM MigrationId +migrationIdReader = eitherReader $ \input -> + case Text.splitOn "/" (Text.pack input) of + [component, migration] -> + case migrationId component migration of + Left err -> Left (show err) + Right validated -> Right validated + _ -> Left "expected COMPONENT/MIGRATION" diff --git a/src/Database/PostgreSQL/Migrate/CLI/Text.hs b/src/Database/PostgreSQL/Migrate/CLI/Text.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate/CLI/Text.hs @@ -0,0 +1,159 @@ +module Database.PostgreSQL.Migrate.CLI.Text + ( renderMigrationCommandText, + ) +where + +import Data.ByteString qualified as ByteString +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set qualified as Set +import Data.Text qualified as Text +import Database.PostgreSQL.Migrate +import Database.PostgreSQL.Migrate.CLI.Outcome +import Database.PostgreSQL.Migrate.Internal +import Numeric qualified +import PgMigrate.CLI.Prelude + +-- | Render a stable human-oriented outcome. +renderMigrationCommandText :: CliOutcome -> Text +renderMigrationCommandText CliOutcome {command, payload = Left cliError} = + command <> ": error: " <> renderCliError cliError +renderMigrationCommandText CliOutcome {payload = Right cliPayload} = renderPayload cliPayload + +renderCliError :: CliError -> Text +renderCliError cliError = + case cliError of + CliMigrationError err -> Text.pack (show err) + CliRepairDefinitionError err -> Text.pack (show err) + CliRepairError err -> Text.pack (show err) + CliManifestError err -> Text.pack (show err) + CliAuthoringError err -> Text.pack (show err) + +renderPayload :: CliPayload -> Text +renderPayload cliPayload = + case cliPayload of + PlanPayload components -> renderPlan components + ListPayload migrations -> Text.unlines (renderMigration <$> migrations) + CheckPayload checked -> Text.unlines (renderChecked <$> NonEmpty.toList checked) + StatusPayload report -> renderStatus report + VerifyPayload report -> renderVerification report + UpPayload report -> renderMigrationReport report + RepairPayload report -> renderRepairReport report + NewPayload path -> "created " <> Text.pack path <> "\n" + +renderPlan :: [ComponentDescription] -> Text +renderPlan components = Text.unlines (renderComponent <$> components) + +renderComponent :: ComponentDescription -> Text +renderComponent (ComponentDescription name position dependencies migrations) = + Text.intercalate + " " + [ Text.pack (show position) <> ".", + componentNameText name, + "depends=[" <> Text.intercalate "," (componentNameText <$> Set.toAscList dependencies) <> "]", + "migrations=" <> Text.pack (show (NonEmpty.length migrations)) + ] + +renderMigration :: MigrationDescription -> Text +renderMigration (MigrationDescription identifier position checksum kind mode) = + Text.intercalate + " " + [ renderMigrationId identifier, + "position=" <> Text.pack (show position), + "checksum=" <> checksumText checksum, + "kind=" <> renderKind kind, + "transaction=" <> renderMode mode + ] + +renderChecked :: CheckedMigration -> Text +renderChecked (CheckedMigration file checksum) = + Text.pack file <> " checksum=" <> checksumText checksum + +renderStatus :: StatusReport -> Text +renderStatus (StatusReport issues applied pending unknown) = + Text.unlines + ( [ "applied=" <> Text.pack (show (length applied)), + "pending=" <> Text.pack (show (length pending)), + "unknown=" <> Text.pack (show (length unknown)), + "issues=" <> Text.pack (show (length issues)) + ] + <> (("applied " <>) . renderMigrationId <$> applied) + <> (("pending " <>) . renderMigrationId <$> pending) + <> (("unknown " <>) . renderStoredMigrationId <$> unknown) + <> (("issue " <>) . Text.pack . show <$> issues) + ) + +renderVerification :: VerificationReport -> Text +renderVerification (VerificationReport issues applied pending unknown) = + Text.unlines + ( [ if null issues then "verification ok" else "verification failed", + "applied=" <> Text.pack (show (length applied)), + "pending=" <> Text.pack (show (length pending)), + "unknown=" <> Text.pack (show (length unknown)) + ] + <> (("issue " <>) . Text.pack . show <$> issues) + ) + +renderMigrationReport :: MigrationReport -> Text +renderMigrationReport (MigrationReport startedAt finishedAt results) = + Text.unlines + ( [ "started=" <> Text.pack (show startedAt), + "finished=" <> Text.pack (show finishedAt) + ] + <> (renderMigrationResult <$> NonEmpty.toList results) + ) + +renderMigrationResult :: MigrationResult -> Text +renderMigrationResult (MigrationResult identifier outcome duration) = + Text.intercalate + " " + [ renderMigrationId identifier, + "outcome=" <> renderOutcome outcome, + "duration_ms=" <> maybe "null" renderDurationMilliseconds duration + ] + +renderRepairReport :: RepairReport -> Text +renderRepairReport (RepairReport identifier operation oldStatus newStatus) = + Text.intercalate + " " + [ renderMigrationId identifier, + "operation=" <> renderRepairOperation operation, + "old_status=" <> renderStatusName oldStatus, + "new_status=" <> renderStatusName newStatus + ] + <> "\n" + +renderStoredMigrationId :: StoredMigration -> Text +renderStoredMigrationId StoredMigration {storedMigrationId} = renderMigrationId storedMigrationId + +renderMigrationId :: MigrationId -> Text +renderMigrationId identifier = + componentNameText (migrationIdComponent identifier) + <> "/" + <> migrationNameText (migrationIdName identifier) + +checksumText :: MigrationChecksum -> Text +checksumText = + Text.pack . concatMap renderByte . ByteString.unpack . migrationChecksumBytes + where + renderByte byte = + case Numeric.showHex byte "" of + [digit] -> ['0', digit] + digits -> digits + +renderKind :: MigrationKind -> Text +renderKind kind = case kind of SqlKind -> "sql"; HaskellKind -> "haskell" + +renderMode :: TransactionMode -> Text +renderMode mode = case mode of Transactional -> "transactional"; NonTransactional -> "nontransactional" + +renderOutcome :: MigrationOutcome -> Text +renderOutcome outcome = case outcome of AlreadyApplied -> "already_applied"; AppliedNow -> "applied_now" + +renderRepairOperation :: RepairOperation -> Text +renderRepairOperation operation = case operation of MarkApplied -> "mark_applied"; Retry -> "retry" + +renderStatusName :: MigrationStatus -> Text +renderStatusName status = case status of Running -> "running"; Applied -> "applied"; Failed -> "failed" + +renderDurationMilliseconds :: NominalDiffTime -> Text +renderDurationMilliseconds duration = Text.pack (show (round (duration * 1000) :: Integer)) diff --git a/src/Database/PostgreSQL/Migrate/CLI/Types.hs b/src/Database/PostgreSQL/Migrate/CLI/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate/CLI/Types.hs @@ -0,0 +1,138 @@ +module Database.PostgreSQL.Migrate.CLI.Types + ( OutputFormat (..), + ConnectionOptions (..), + ExecutionOptions (..), + OutputOptions (..), + InspectionOptions (..), + PlanOptions (..), + ListOptions (..), + CheckOptions (..), + StatusOptions (..), + VerifyOptions (..), + UpOptions (..), + RepairOptions (..), + NewOptions (..), + MigrationCommand (..), + ) +where + +import Database.PostgreSQL.Migrate + ( ComponentName, + Confirmation, + LockWait, + MigrationId, + MigrationName, + RepairOperation, + ) +import Hasql.Connection.Settings qualified as Settings +import PgMigrate.CLI.Prelude + +-- | Human-readable or versioned JSON rendering. +data OutputFormat + = TextOutput + | JsonOutput + deriving stock (Generic, Eq, Ord, Show) + +-- | Optional command-line database connection override. +newtype ConnectionOptions = ConnectionOptions + { databaseSettings :: Maybe Settings.Settings + } + deriving stock (Generic, Eq, Show) + +-- | Shared lock and statement-timeout flags. +data ExecutionOptions = ExecutionOptions + { lockWait :: !LockWait, + statementTimeout :: !(Maybe NominalDiffTime) + } + deriving stock (Generic, Eq, Show) + +-- | Shared output selection. +newtype OutputOptions = OutputOptions + { outputFormat :: OutputFormat + } + deriving stock (Generic, Eq, Show) + +-- | Shared read-only command options. +data InspectionOptions = InspectionOptions + { component :: !(Maybe ComponentName), + migration :: !(Maybe MigrationName) + } + deriving stock (Generic, Eq, Show) + +-- | Shared local plan-rendering options. +data PlanOptions = PlanOptions + { inspection :: !InspectionOptions, + output :: !OutputOptions + } + deriving stock (Generic, Eq, Show) + +-- | Parsed @list@ command options. +data ListOptions = ListOptions + { inspection :: !InspectionOptions, + output :: !OutputOptions + } + deriving stock (Generic, Eq, Show) + +-- | Parsed @check@ command options. +data CheckOptions = CheckOptions + { manifestPath :: !FilePath, + output :: !OutputOptions + } + deriving stock (Generic, Eq, Show) + +-- | Parsed @status@ command options. +data StatusOptions = StatusOptions + { inspection :: !InspectionOptions, + connection :: !ConnectionOptions, + output :: !OutputOptions + } + deriving stock (Generic, Eq, Show) + +-- | Parsed strict @verify@ command options. +data VerifyOptions = VerifyOptions + { inspection :: !InspectionOptions, + connection :: !ConnectionOptions, + output :: !OutputOptions + } + deriving stock (Generic, Eq, Show) + +-- | Parsed @up@ command options. +data UpOptions = UpOptions + { connection :: !ConnectionOptions, + execution :: !ExecutionOptions, + output :: !OutputOptions + } + deriving stock (Generic, Eq, Show) + +-- | Parsed confirmed @repair@ command options. +data RepairOptions = RepairOptions + { target :: !MigrationId, + operation :: !RepairOperation, + reason :: !Text, + confirmation :: !Confirmation, + connection :: !ConnectionOptions, + execution :: !ExecutionOptions, + output :: !OutputOptions + } + deriving stock (Generic, Eq, Show) + +-- | Parsed migration-authoring command options. +data NewOptions = NewOptions + { manifestPath :: !FilePath, + description :: !Text, + requestedName :: !(Maybe FilePath), + output :: !OutputOptions + } + deriving stock (Generic, Eq, Show) + +-- | Complete reusable command algebra mounted by an application executable. +data MigrationCommand + = Plan !PlanOptions + | Status !StatusOptions + | Verify !VerifyOptions + | List !ListOptions + | Check !CheckOptions + | Up !UpOptions + | Repair !RepairOptions + | New !NewOptions + deriving stock (Generic, Eq, Show) diff --git a/src/PgMigrate/CLI/Prelude.hs b/src/PgMigrate/CLI/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/PgMigrate/CLI/Prelude.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_HADDOCK hide #-} + +module PgMigrate.CLI.Prelude + ( module X, + ) +where + +import "base" Control.Applicative as X (Alternative (..), optional) +import "base" Data.Foldable as X (toList) +import "base" Data.List.NonEmpty as X (NonEmpty (..)) +import "base" Data.Maybe as X (fromMaybe) +import "base" GHC.Generics as X (Generic) +import "text" Data.Text as X (Text) +import "time" Data.Time as X (NominalDiffTime) +import "base" Prelude as X diff --git a/test/golden/help/check.txt b/test/golden/help/check.txt new file mode 100644 --- /dev/null +++ b/test/golden/help/check.txt @@ -0,0 +1,10 @@ +Usage: pg-migrate-cli-help-fixture check MANIFEST [--json] + + Validate an ordered SQL manifest without a database + +Available options: + MANIFEST Path to the ordered migration manifest + -h,--help Show this help text + +Output + --json Emit JSON schema version 1 diff --git a/test/golden/help/list.txt b/test/golden/help/list.txt new file mode 100644 --- /dev/null +++ b/test/golden/help/list.txt @@ -0,0 +1,14 @@ +Usage: pg-migrate-cli-help-fixture list + [--component COMPONENT] [--migration MIGRATION] [--json] + + List declared migrations and metadata + +Filters + --component COMPONENT Limit inspection output to one component + --migration MIGRATION Limit inspection output to one migration name + +Output + --json Emit JSON schema version 1 + +Available options: + -h,--help Show this help text diff --git a/test/golden/help/new.txt b/test/golden/help/new.txt new file mode 100644 --- /dev/null +++ b/test/golden/help/new.txt @@ -0,0 +1,14 @@ +Usage: pg-migrate-cli-help-fixture new + --manifest PATH --description TEXT [--name BASENAME] [--json] + + Create and append one SQL migration without applying it + +Available options: + --manifest PATH Ordered manifest to append + --description TEXT Human description written into the new SQL file + --name BASENAME Explicit SQL basename when numeric inference is + unavailable + -h,--help Show this help text + +Output + --json Emit JSON schema version 1 diff --git a/test/golden/help/plan.txt b/test/golden/help/plan.txt new file mode 100644 --- /dev/null +++ b/test/golden/help/plan.txt @@ -0,0 +1,14 @@ +Usage: pg-migrate-cli-help-fixture plan + [--component COMPONENT] [--migration MIGRATION] [--json] + + Show component order and dependencies + +Filters + --component COMPONENT Limit inspection output to one component + --migration MIGRATION Limit inspection output to one migration name + +Output + --json Emit JSON schema version 1 + +Available options: + -h,--help Show this help text diff --git a/test/golden/help/repair.txt b/test/golden/help/repair.txt new file mode 100644 --- /dev/null +++ b/test/golden/help/repair.txt @@ -0,0 +1,31 @@ +Usage: pg-migrate-cli-help-fixture repair + COMPONENT/MIGRATION (--mark-applied | --retry) --reason TEXT --confirm + [--database-url URL] [--no-wait | --lock-timeout MILLISECONDS] + [--statement-timeout MILLISECONDS] [--json] + + Repair one nontransactional migration after operator inspection + +Available options: + --mark-applied Record the inspected nontransactional result as + applied + --retry Return the migration to running and execute its + action again + --reason TEXT Audit reason for the repair + --confirm Confirm that the database result was inspected + -h,--help Show this help text + +Connection + --database-url URL PostgreSQL URI or keyword/value connection string; no + environment variable is read + +Execution + --no-wait Fail immediately when the advisory lock is + unavailable + --lock-timeout MILLISECONDS + Wait at most this many positive milliseconds for the + advisory lock + --statement-timeout MILLISECONDS + Positive PostgreSQL statement timeout in milliseconds + +Output + --json Emit JSON schema version 1 diff --git a/test/golden/help/status.txt b/test/golden/help/status.txt new file mode 100644 --- /dev/null +++ b/test/golden/help/status.txt @@ -0,0 +1,19 @@ +Usage: pg-migrate-cli-help-fixture status + [--component COMPONENT] [--migration MIGRATION] [--database-url URL] + [--json] + + Show declared and stored migration status + +Filters + --component COMPONENT Limit inspection output to one component + --migration MIGRATION Limit inspection output to one migration name + +Connection + --database-url URL PostgreSQL URI or keyword/value connection string; no + environment variable is read + +Output + --json Emit JSON schema version 1 + +Available options: + -h,--help Show this help text diff --git a/test/golden/help/top.txt b/test/golden/help/top.txt new file mode 100644 --- /dev/null +++ b/test/golden/help/top.txt @@ -0,0 +1,24 @@ +Usage: pg-migrate-cli-help-fixture (COMMAND | COMMAND | COMMAND) + + Manage the fixture service migration plan + +Available options: + -h,--help Show this help text + +Inspection + plan Show component order and dependencies + status Show declared and stored migration status + verify Strictly compare the declared plan with the migration + ledger (not live schema snapshots) + list List declared migrations and metadata + check Validate an ordered SQL manifest without a database + +Execution + up Apply the complete migration plan; selective + execution is unavailable in v1 + repair Repair one nontransactional migration after operator + inspection + +Authoring + new Create and append one SQL migration without applying + it diff --git a/test/golden/help/up.txt b/test/golden/help/up.txt new file mode 100644 --- /dev/null +++ b/test/golden/help/up.txt @@ -0,0 +1,24 @@ +Usage: pg-migrate-cli-help-fixture up + [--database-url URL] [--no-wait | --lock-timeout MILLISECONDS] + [--statement-timeout MILLISECONDS] [--json] + + Apply the complete migration plan; selective execution is unavailable in v1 + +Connection + --database-url URL PostgreSQL URI or keyword/value connection string; no + environment variable is read + +Execution + --no-wait Fail immediately when the advisory lock is + unavailable + --lock-timeout MILLISECONDS + Wait at most this many positive milliseconds for the + advisory lock + --statement-timeout MILLISECONDS + Positive PostgreSQL statement timeout in milliseconds + +Output + --json Emit JSON schema version 1 + +Available options: + -h,--help Show this help text diff --git a/test/golden/help/verify.txt b/test/golden/help/verify.txt new file mode 100644 --- /dev/null +++ b/test/golden/help/verify.txt @@ -0,0 +1,20 @@ +Usage: pg-migrate-cli-help-fixture verify + [--component COMPONENT] [--migration MIGRATION] [--database-url URL] + [--json] + + Strictly compare the declared plan with the migration ledger (not live schema + snapshots) + +Filters + --component COMPONENT Limit inspection output to one component + --migration MIGRATION Limit inspection output to one migration name + +Connection + --database-url URL PostgreSQL URI or keyword/value connection string; no + environment variable is read + +Output + --json Emit JSON schema version 1 + +Available options: + -h,--help Show this help text diff --git a/test/golden/json/error.json b/test/golden/json/error.json new file mode 100644 --- /dev/null +++ b/test/golden/json/error.json @@ -0,0 +1,9 @@ +{ + "schemaVersion": 1, + "command": "check", + "ok": false, + "error": { + "type": "manifest.invalid", + "message": "EmptyManifest" + } +} diff --git a/test/golden/json/import.json b/test/golden/json/import.json new file mode 100644 --- /dev/null +++ b/test/golden/json/import.json @@ -0,0 +1,18 @@ +{ + "schemaVersion": 1, + "command": "import", + "ok": true, + "data": { + "source": "codd", + "results": [ + { + "id": "accounts/0001", + "outcome": "imported" + }, + { + "id": "accounts/0002", + "outcome": "alreadyImported" + } + ] + } +} diff --git a/test/golden/json/plan.json b/test/golden/json/plan.json new file mode 100644 --- /dev/null +++ b/test/golden/json/plan.json @@ -0,0 +1,23 @@ +{ + "schemaVersion": 1, + "command": "plan", + "ok": true, + "data": { + "components": [ + { + "name": "accounts", + "position": 1, + "dependencies": [], + "migrations": [ + { + "id": "accounts/0001", + "position": 1, + "checksum": "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855", + "kind": "sql", + "transactionMode": "transactional" + } + ] + } + ] + } +} diff --git a/test/golden/json/repair.json b/test/golden/json/repair.json new file mode 100644 --- /dev/null +++ b/test/golden/json/repair.json @@ -0,0 +1,11 @@ +{ + "schemaVersion": 1, + "command": "repair", + "ok": true, + "data": { + "id": "accounts/0001", + "operation": "markApplied", + "oldStatus": "failed", + "newStatus": "applied" + } +} diff --git a/test/golden/json/status.json b/test/golden/json/status.json new file mode 100644 --- /dev/null +++ b/test/golden/json/status.json @@ -0,0 +1,11 @@ +{ + "schemaVersion": 1, + "command": "status", + "ok": true, + "data": { + "issues": [], + "applied": ["accounts/0001"], + "pending": [], + "unknown": [] + } +} diff --git a/test/golden/json/up.json b/test/golden/json/up.json new file mode 100644 --- /dev/null +++ b/test/golden/json/up.json @@ -0,0 +1,16 @@ +{ + "schemaVersion": 1, + "command": "up", + "ok": true, + "data": { + "startedAt": "2026-07-10T12:00:00Z", + "finishedAt": "2026-07-10T12:00:01Z", + "results": [ + { + "id": "accounts/0001", + "outcome": "appliedNow", + "durationMilliseconds": 125 + } + ] + } +} diff --git a/test/golden/json/verify.json b/test/golden/json/verify.json new file mode 100644 --- /dev/null +++ b/test/golden/json/verify.json @@ -0,0 +1,13 @@ +{ + "schemaVersion": 1, + "command": "verify", + "ok": false, + "data": { + "issues": [ + {"type": "pendingMigration", "id": "accounts/0001"} + ], + "applied": [], + "pending": ["accounts/0001"], + "unknown": [] + } +} diff --git a/test/help-fixture/Main.hs b/test/help-fixture/Main.hs new file mode 100644 --- /dev/null +++ b/test/help-fixture/Main.hs @@ -0,0 +1,40 @@ +module Main (main) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Set qualified as Set +import Database.PostgreSQL.Migrate +import Database.PostgreSQL.Migrate.CLI +import Options.Applicative + +main :: IO () +main = do + _ <- + execParser + ( info + (migrationCommandParser fixturePlan <**> helper) + (fullDesc <> progDesc "Manage the fixture service migration plan") + ) + pure () + +fixturePlan :: MigrationPlan +fixturePlan = + expectRight + ( migrationPlan + ( expectRight + ( migrationComponent + "accounts" + Set.empty + (expectRight (sqlMigration "0001" "SELECT 1") :| []) + ) + :| [ expectRight + ( migrationComponent + "billing" + (Set.singleton "accounts") + (expectRight (sqlMigration "0001" "SELECT 2") :| []) + ) + ] + ) + ) + +expectRight :: (Show error) => Either error value -> value +expectRight = either (error . show) id diff --git a/test/integration/Main.hs b/test/integration/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/Main.hs @@ -0,0 +1,210 @@ +module Main (main) where + +import Control.Exception qualified as Exception +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Database.PostgreSQL.Migrate +import Database.PostgreSQL.Migrate.CLI +import Hasql.Connection qualified as Connection +import Hasql.Connection.Settings qualified as Settings +import Hasql.Session qualified as Session +import System.Environment (lookupEnv) +import Test.Tasty +import Test.Tasty.HUnit + +main :: IO () +main = do + maybeConnectionString <- lookupEnv "PG_CONNECTION_STRING" + case maybeConnectionString of + Nothing -> + putStrLn + "pg-migrate-cli integration tests skipped: PG_CONNECTION_STRING is not set" + Just connectionString -> + defaultMain (tests (Settings.connectionString (Text.pack connectionString))) + +tests :: Settings.Settings -> TestTree +tests settings = + testGroup + "pg-migrate CLI PostgreSQL" + [ testCase "status verify and full up preserve their contracts" (testCommandLifecycle settings), + testCase "confirmed repair dispatches through the shared lifecycle" (testRepairLifecycle settings) + ] + +testCommandLifecycle :: Settings.Settings -> Assertion +testCommandLifecycle settings = + withCleanLedger settings "pgmigrate_cli_commands" 0x70676D636C690001 $ \options -> do + let environment = cliEnvironment settings commandPlan options + + statusBefore <- runMigrationCommand environment statusCommand + exitClass statusBefore @?= ExitSuccess + case payload statusBefore of + Right (StatusPayload (StatusReport issues applied pending unknown)) -> do + issues @?= [] + applied @?= [] + length pending @?= 1 + unknown @?= [] + other -> assertFailure ("unexpected status outcome: " <> show other) + + verifyBefore <- runMigrationCommand environment verifyCommand + exitClass verifyBefore @?= ExitVerificationFailed + case payload verifyBefore of + Right (VerifyPayload (VerificationReport issues _ pending _)) -> do + length issues @?= 1 + length pending @?= 1 + other -> assertFailure ("unexpected pre-run verify outcome: " <> show other) + + firstUp <- runMigrationCommand environment upCommand + exitClass firstUp @?= ExitSuccess + assertSingleOutcome AppliedNow firstUp + + verifyAfter <- runMigrationCommand environment verifyCommand + exitClass verifyAfter @?= ExitSuccess + case payload verifyAfter of + Right (VerifyPayload (VerificationReport issues applied pending unknown)) -> do + issues @?= [] + length applied @?= 1 + pending @?= [] + unknown @?= [] + other -> assertFailure ("unexpected post-run verify outcome: " <> show other) + + secondUp <- runMigrationCommand environment upCommand + exitClass secondUp @?= ExitSuccess + assertSingleOutcome AlreadyApplied secondUp + +testRepairLifecycle :: Settings.Settings -> Assertion +testRepairLifecycle settings = + withCleanLedger settings "pgmigrate_cli_repair" 0x70676D636C690002 $ \options -> do + let environment = cliEnvironment settings failingPlan options + + failedUp <- runMigrationCommand environment upCommand + exitClass failedUp @?= ExitExecutionFailed + + repaired <- + runMigrationCommand + environment + ( Repair + ( RepairOptions + failingMigrationId + MarkApplied + "operator inspected the database result" + Confirmed + noConnectionOverride + defaultExecution + jsonOutput + ) + ) + exitClass repaired @?= ExitSuccess + case payload repaired of + Right (RepairPayload (RepairReport identifier MarkApplied Failed Applied)) -> + identifier @?= failingMigrationId + other -> assertFailure ("unexpected repair outcome: " <> show other) + + verified <- runMigrationCommand environment verifyCommand + exitClass verified @?= ExitSuccess + +assertSingleOutcome :: MigrationOutcome -> CliOutcome -> Assertion +assertSingleOutcome expected outcome = + case payload outcome of + Right (UpPayload (MigrationReport _ _ (MigrationResult _ actual _ :| []))) -> + actual @?= expected + other -> assertFailure ("unexpected up outcome: " <> show other) + +statusCommand :: MigrationCommand +statusCommand = Status (StatusOptions noInspection noConnectionOverride jsonOutput) + +verifyCommand :: MigrationCommand +verifyCommand = Verify (VerifyOptions noInspection noConnectionOverride jsonOutput) + +upCommand :: MigrationCommand +upCommand = Up (UpOptions noConnectionOverride defaultExecution jsonOutput) + +noInspection :: InspectionOptions +noInspection = InspectionOptions Nothing Nothing + +noConnectionOverride :: ConnectionOptions +noConnectionOverride = ConnectionOptions Nothing + +defaultExecution :: ExecutionOptions +defaultExecution = ExecutionOptions WaitIndefinitely Nothing + +jsonOutput :: OutputOptions +jsonOutput = OutputOptions JsonOutput + +commandPlan :: MigrationPlan +commandPlan = + expectRight + ( migrationPlan + ( expectRight + ( migrationComponent + "cli-commands" + Set.empty + ( expectRight + ( sqlMigration + "0001" + "CREATE TABLE pgmigrate_cli_commands.cli_command_probe (id bigint PRIMARY KEY)" + ) + :| [] + ) + ) + :| [] + ) + ) + +failingPlan :: MigrationPlan +failingPlan = + expectRight + ( migrationPlan + ( expectRight + ( migrationComponent + "cli-repair" + Set.empty + (failingMigration :| []) + ) + :| [] + ) + ) + +failingMigration :: Migration +failingMigration = + expectRight + ( sessionMigration + "0001" + (migrationFingerprint "cli-repair-v1") + (Session.script "SELECT * FROM pgmigrate_cli_deliberately_missing_table") + ) + +failingMigrationId :: MigrationId +failingMigrationId = expectRight (migrationId "cli-repair" "0001") + +withCleanLedger :: + Settings.Settings -> + Text.Text -> + Int64 -> + (RunOptions -> IO value) -> + IO value +withCleanLedger settings schemaName lockKey action = do + let config = expectRight (ledgerConfig schemaName lockKey) + Exception.bracket_ + (dropSchema settings schemaName) + (dropSchema settings schemaName) + (action (withLedger config defaultRunOptions)) + +dropSchema :: Settings.Settings -> Text.Text -> IO () +dropSchema settings schemaName = do + acquired <- Connection.acquire settings + case acquired of + Left connectionError -> assertFailure ("could not acquire integration connection: " <> show connectionError) + Right connection -> + Exception.finally + ( do + result <- Connection.use connection (Session.script ("DROP SCHEMA IF EXISTS " <> schemaName <> " CASCADE")) + case result of + Left sessionError -> assertFailure ("could not clean integration schema: " <> show sessionError) + Right () -> pure () + ) + (Connection.release connection) + +expectRight :: (Show error) => Either error value -> value +expectRight = either (error . show) id diff --git a/test/unit/Main.hs b/test/unit/Main.hs new file mode 100644 --- /dev/null +++ b/test/unit/Main.hs @@ -0,0 +1,17 @@ +module Main (main) where + +import Test.Handler qualified as Handler +import Test.Json qualified as Json +import Test.Parser qualified as Parser +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain + ( testGroup + "pg-migrate-cli" + [ Parser.tests, + Handler.tests, + Json.tests + ] + ) diff --git a/test/unit/Test/Handler.hs b/test/unit/Test/Handler.hs new file mode 100644 --- /dev/null +++ b/test/unit/Test/Handler.hs @@ -0,0 +1,154 @@ +module Test.Handler (tests) where + +import Control.Exception qualified as Exception +import Data.ByteString qualified as ByteString +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Database.PostgreSQL.Migrate +import Database.PostgreSQL.Migrate.CLI +import Database.PostgreSQL.Migrate.Embed (AuthoringError (ExplicitMigrationNameRequired)) +import Hasql.Connection.Settings qualified as Settings +import System.Directory qualified as Directory +import System.FilePath (()) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "handler" + [ testCase "plan text is stable and preserves component order" testPlanText, + testCase "list filters narrow output without changing plan order" testListFilter, + testCase "check returns exact-byte checksums" testCheck, + testCase "new creates and appends a migration without applying it" testNew, + testCase "new reports when a nonnumeric manifest requires an explicit name" testNewRequiresName, + testCase "manifest failures are typed usage outcomes" testCheckFailure + ] + +testPlanText :: Assertion +testPlanText = do + outcome <- + runMigrationCommand + fixtureEnvironment + (Plan (PlanOptions noInspection textOutput)) + exitClass outcome @?= ExitSuccess + renderMigrationCommandText outcome + @?= Text.unlines + [ "1. accounts depends=[] migrations=1", + "2. billing depends=[accounts] migrations=1" + ] + +testListFilter :: Assertion +testListFilter = do + let billing = expectRight (componentName "billing") + outcome <- + runMigrationCommand + fixtureEnvironment + (List (ListOptions (InspectionOptions (Just billing) Nothing) textOutput)) + exitClass outcome @?= ExitSuccess + let rendered = renderMigrationCommandText outcome + assertBool "billing migration is present" ("billing/0001" `Text.isInfixOf` rendered) + assertBool "accounts migration is filtered out" (not ("accounts/0001" `Text.isInfixOf` rendered)) + assertBool "checksums are lowercase hexadecimal" (Text.all validOutputCharacter rendered) + where + validOutputCharacter character = not (character >= 'A' && character <= 'F') + +testCheck :: Assertion +testCheck = + withFixtureDirectory "check" $ \directory -> do + let manifest = directory "manifest" + ByteString.writeFile (directory "0001.sql") "SELECT 1;\n" + ByteString.writeFile manifest "0001.sql\n" + outcome <- + runMigrationCommand + fixtureEnvironment + (Check (CheckOptions manifest textOutput)) + exitClass outcome @?= ExitSuccess + let rendered = renderMigrationCommandText outcome + assertBool "manifest entry is rendered" ("0001.sql checksum=" `Text.isPrefixOf` rendered) + Text.length (Text.takeWhileEnd (/= '=') (Text.strip rendered)) @?= 64 + +testNew :: Assertion +testNew = + withFixtureDirectory "new" $ \directory -> do + let manifest = directory "manifest" + ByteString.writeFile (directory "0001.sql") "SELECT 1;\n" + ByteString.writeFile manifest "0001.sql\n" + outcome <- + runMigrationCommand + fixtureEnvironment + (New (NewOptions manifest "add profile" Nothing textOutput)) + exitClass outcome @?= ExitSuccess + renderMigrationCommandText outcome @?= "created " <> Text.pack (directory "0002.sql") <> "\n" + ByteString.readFile (directory "0002.sql") >>= (@?= "-- add profile\n\n") + ByteString.readFile manifest >>= (@?= "0001.sql\n0002.sql\n") + +testCheckFailure :: Assertion +testCheckFailure = + withFixtureDirectory "missing" $ \directory -> do + outcome <- + runMigrationCommand + fixtureEnvironment + (Check (CheckOptions (directory "missing-manifest") textOutput)) + exitClass outcome @?= ExitUsageFailed + case payload outcome of + Left (CliManifestError _) -> pure () + result -> assertFailure ("expected typed manifest error, received: " <> show result) + +testNewRequiresName :: Assertion +testNewRequiresName = + withFixtureDirectory "new-name" $ \directory -> do + let manifest = directory "manifest" + ByteString.writeFile (directory "baseline.sql") "SELECT 1;\n" + ByteString.writeFile manifest "baseline.sql\n" + outcome <- + runMigrationCommand + fixtureEnvironment + (New (NewOptions manifest "add profile" Nothing textOutput)) + exitClass outcome @?= ExitUsageFailed + case payload outcome of + Left (CliAuthoringError ExplicitMigrationNameRequired) -> pure () + result -> assertFailure ("expected explicit-name usage error, received: " <> show result) + +fixtureEnvironment :: CliEnvironment +fixtureEnvironment = cliEnvironment (Settings.connectionString "") fixturePlan defaultRunOptions + +fixturePlan :: MigrationPlan +fixturePlan = + expectRight + ( migrationPlan + ( expectRight + ( migrationComponent + "accounts" + Set.empty + (expectRight (sqlMigration "0001" "SELECT 1") :| []) + ) + :| [ expectRight + ( migrationComponent + "billing" + (Set.singleton "accounts") + (expectRight (sqlMigration "0001" "SELECT 2") :| []) + ) + ] + ) + ) + +noInspection :: InspectionOptions +noInspection = InspectionOptions Nothing Nothing + +textOutput :: OutputOptions +textOutput = OutputOptions TextOutput + +withFixtureDirectory :: String -> (FilePath -> IO value) -> IO value +withFixtureDirectory label = Exception.bracket create Directory.removePathForcibly + where + create = do + temporaryDirectory <- Directory.getTemporaryDirectory + let directory = temporaryDirectory ("pg-migrate-cli-" <> label) + Directory.removePathForcibly directory + Directory.createDirectory directory + pure directory + +expectRight :: (Show error) => Either error value -> value +expectRight = either (error . show) id diff --git a/test/unit/Test/Json.hs b/test/unit/Test/Json.hs new file mode 100644 --- /dev/null +++ b/test/unit/Test/Json.hs @@ -0,0 +1,158 @@ +module Test.Json (tests) where + +import Data.Aeson qualified as Aeson +import Data.ByteString qualified as ByteString +import Data.Foldable (traverse_) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Time (UTCTime) +import Database.PostgreSQL.Migrate +import Database.PostgreSQL.Migrate.CLI +import Database.PostgreSQL.Migrate.Embed (ManifestError (EmptyManifest)) +import Database.PostgreSQL.Migrate.Internal + ( ComponentDescription (ComponentDescription), + MigrationDescription (MigrationDescription), + MigrationKind (..), + TransactionMode (..), + ) +import Paths_pg_migrate_cli qualified as Paths +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "JSON schema v1" + [ goldenCase "plan" planOutcome, + goldenCase "status" statusOutcome, + goldenCase "verify" verifyOutcome, + goldenCase "up" upOutcome, + goldenCase "repair" repairOutcome, + goldenCase "error" errorOutcome, + testCase "import matches its golden contract" testImportGolden, + testCase "rendering is byte-for-byte stable" testStableRendering + ] + +goldenCase :: FilePath -> CliOutcome -> TestTree +goldenCase name outcome = + testCase (name <> " matches its golden contract") $ do + goldenPath <- Paths.getDataFileName ("test/golden/json/" <> name <> ".json") + goldenBytes <- ByteString.readFile goldenPath + expected <- + case Aeson.eitherDecodeStrict' goldenBytes of + Left decodeError -> assertFailure ("invalid golden JSON: " <> decodeError) + Right value -> pure value + renderMigrationCommandJson outcome @?= expected + +testImportGolden :: Assertion +testImportGolden = do + goldenPath <- Paths.getDataFileName "test/golden/json/import.json" + goldenBytes <- ByteString.readFile goldenPath + expected <- + case Aeson.eitherDecodeStrict' goldenBytes of + Left decodeError -> assertFailure ("invalid golden JSON: " <> decodeError) + Right value -> pure value + renderHistoryImportJson "codd" importReport @?= expected + +testStableRendering :: Assertion +testStableRendering = + traverse_ + ( \outcome -> + Aeson.encode (renderMigrationCommandJson outcome) + @?= Aeson.encode (renderMigrationCommandJson outcome) + ) + fixtureOutcomes + +fixtureOutcomes :: [CliOutcome] +fixtureOutcomes = + [ planOutcome, + statusOutcome, + verifyOutcome, + upOutcome, + repairOutcome, + errorOutcome + ] + +planOutcome :: CliOutcome +planOutcome = + successful + "plan" + ( PlanPayload + [ ComponentDescription + accounts + 1 + Set.empty + (MigrationDescription migrationIdentifier 1 emptyChecksum SqlKind Transactional :| []) + ] + ) + +statusOutcome :: CliOutcome +statusOutcome = + successful "status" (StatusPayload (StatusReport [] [migrationIdentifier] [] [])) + +verifyOutcome :: CliOutcome +verifyOutcome = + CliOutcome + { command = "verify", + exitClass = ExitVerificationFailed, + payload = + Right + ( VerifyPayload + (VerificationReport [PendingMigration migrationIdentifier] [] [migrationIdentifier] []) + ) + } + +upOutcome :: CliOutcome +upOutcome = + successful + "up" + ( UpPayload + ( MigrationReport + fixtureStartedAt + fixtureFinishedAt + (MigrationResult migrationIdentifier AppliedNow (Just 0.125) :| []) + ) + ) + +repairOutcome :: CliOutcome +repairOutcome = + successful + "repair" + (RepairPayload (RepairReport migrationIdentifier MarkApplied Failed Applied)) + +errorOutcome :: CliOutcome +errorOutcome = + CliOutcome + { command = "check", + exitClass = ExitUsageFailed, + payload = Left (CliManifestError EmptyManifest) + } + +successful :: Text -> CliPayload -> CliOutcome +successful command payload = CliOutcome {command, exitClass = ExitSuccess, payload = Right payload} + +accounts :: ComponentName +accounts = expectRight (componentName "accounts") + +migrationIdentifier :: MigrationId +migrationIdentifier = expectRight (migrationId "accounts" "0001") + +emptyChecksum :: MigrationChecksum +emptyChecksum = migrationFingerprint ByteString.empty + +fixtureStartedAt :: UTCTime +fixtureStartedAt = read "2026-07-10 12:00:00 UTC" + +fixtureFinishedAt :: UTCTime +fixtureFinishedAt = read "2026-07-10 12:00:01 UTC" + +importReport :: HistoryImportReport +importReport = + HistoryImportReport + ( HistoryImportResult migrationIdentifier Imported + :| [HistoryImportResult (expectRight (migrationId "accounts" "0002")) AlreadyImported] + ) + +expectRight :: (Show error) => Either error value -> value +expectRight = either (error . show) id diff --git a/test/unit/Test/Parser.hs b/test/unit/Test/Parser.hs new file mode 100644 --- /dev/null +++ b/test/unit/Test/Parser.hs @@ -0,0 +1,188 @@ +module Test.Parser (tests) where + +import Data.ByteString.Char8 qualified as ByteString +import Data.Foldable (traverse_) +import Data.List (isInfixOf) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Set qualified as Set +import Database.PostgreSQL.Migrate +import Database.PostgreSQL.Migrate.CLI +import Options.Applicative +import Paths_pg_migrate_cli qualified as Paths +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "parser" + [ testCase "top-level help groups commands by operator intent" testGroupedHelp, + testCase "verify help defines ledger verification narrowly" testVerifyHelp, + testCase "up has no selective execution filters" testUpRejectsFilters, + testCase "durations must be positive integer milliseconds" testDurationValidation, + testCase "lock wait flags conflict" testConflictingWaitFlags, + testCase "repair requires an operation and confirmation" testRepairConfirmation, + testCase "repair validates the component/migration target" testRepairTarget, + testCase "parsing does not imply database settings" testNoImplicitDatabaseSettings, + testCase "plain completion derives all commands from the parser" testPlainCompletion, + testCase "enriched completion derives execution flags and descriptions" testEnrichedCompletion, + testGroup "help goldens" (uncurry goldenHelpCase <$> helpGoldens) + ] + +testGroupedHelp :: Assertion +testGroupedHelp = do + helpText <- parseFailure ["--help"] + assertContains "Inspection" helpText + assertContains "plan" helpText + assertContains "status" helpText + assertContains "verify" helpText + assertContains "list" helpText + assertContains "check" helpText + assertContains "Execution" helpText + assertContains "up" helpText + assertContains "repair" helpText + assertContains "Authoring" helpText + assertContains "new" helpText + +testVerifyHelp :: Assertion +testVerifyHelp = do + helpText <- parseFailure ["verify", "--help"] + assertContains "declared plan" helpText + assertContains "migration ledger" helpText + assertContains "not live schema" helpText + assertContains "snapshots" helpText + assertContains "Connection" helpText + assertContains "Output" helpText + +testUpRejectsFilters :: Assertion +testUpRejectsFilters = do + failure <- parseFailure ["up", "--component", "accounts"] + assertContains "Invalid option" failure + +testDurationValidation :: Assertion +testDurationValidation = do + zeroFailure <- parseFailure ["up", "--lock-timeout", "0"] + assertContains "positive integer" zeroFailure + fractionalFailure <- parseFailure ["up", "--statement-timeout", "1.5"] + assertContains "positive integer" fractionalFailure + +testConflictingWaitFlags :: Assertion +testConflictingWaitFlags = do + failure <- parseFailure ["up", "--no-wait", "--lock-timeout", "100"] + assertContains "Invalid option" failure + +testRepairConfirmation :: Assertion +testRepairConfirmation = do + missingOperation <- parseFailure ["repair", "accounts/0001", "--reason", "inspected", "--confirm"] + assertContains "mark-applied" missingOperation + missingConfirmation <- parseFailure ["repair", "accounts/0001", "--mark-applied", "--reason", "inspected"] + assertContains "confirm" missingConfirmation + +testRepairTarget :: Assertion +testRepairTarget = do + failure <- parseFailure ["repair", "accounts", "--mark-applied", "--reason", "inspected", "--confirm"] + assertContains "COMPONENT/MIGRATION" failure + +testNoImplicitDatabaseSettings :: Assertion +testNoImplicitDatabaseSettings = + case parseSuccess ["status"] of + Status StatusOptions {connection = ConnectionOptions {databaseSettings = Nothing}} -> pure () + result -> assertFailure ("expected status without database settings, received: " <> show result) + +testPlainCompletion :: Assertion +testPlainCompletion = do + completion <- completionOutput False 0 [] + traverse_ (\commandName -> assertContains commandName completion) expectedCommands + +testEnrichedCompletion :: Assertion +testEnrichedCompletion = do + commands <- completionOutput True 0 [] + assertContains "verify\tStrictly compare" commands + flags <- completionOutput True 2 ["test-migrate", "up"] + assertContains "--database-url\tPostgreSQL URI" flags + assertContains "--lock-timeout\tWait at most" flags + assertContains "--no-wait\tFail immediately" flags + assertContains "--statement-timeout\tPositive PostgreSQL" flags + assertContains "--json\tEmit JSON schema version 1" flags + +completionOutput :: Bool -> Int -> [String] -> IO String +completionOutput enriched index wordsBeforeCursor = + case execParserPure defaultPrefs commandInfo arguments of + CompletionInvoked completion -> execCompletion completion "test-migrate" + Failure failure -> assertFailure (fst (renderFailure failure "test-migrate")) + Success parsedCommand -> assertFailure ("expected completion, received command: " <> show parsedCommand) + where + arguments = + ["--bash-completion-enriched" | enriched] + <> ["--bash-completion-index", show index] + <> concatMap (\word -> ["--bash-completion-word", word]) wordsBeforeCursor + +expectedCommands :: [String] +expectedCommands = ["plan", "status", "verify", "list", "check", "up", "repair", "new"] + +goldenHelpCase :: FilePath -> [String] -> TestTree +goldenHelpCase name arguments = + testCase name $ do + goldenPath <- Paths.getDataFileName ("test/golden/help/" <> name <> ".txt") + expected <- readFile goldenPath + actual <- parseFailure (arguments <> ["--help"]) + normalizeHelp actual @?= expected + +normalizeHelp :: String -> String +normalizeHelp = unlines . fmap (reverse . dropWhile (== ' ') . reverse) . lines + +helpGoldens :: [(FilePath, [String])] +helpGoldens = + [ ("top", []), + ("plan", ["plan"]), + ("status", ["status"]), + ("verify", ["verify"]), + ("list", ["list"]), + ("check", ["check"]), + ("up", ["up"]), + ("repair", ["repair"]), + ("new", ["new"]) + ] + +commandInfo :: ParserInfo MigrationCommand +commandInfo = + info + (migrationCommandParser fixturePlan <**> helper) + (fullDesc <> progDesc "Manage the fixture service migration plan") + +parseSuccess :: [String] -> MigrationCommand +parseSuccess arguments = + case execParserPure defaultPrefs commandInfo arguments of + Success parsedCommand -> parsedCommand + Failure failure -> + let (message, _) = renderFailure failure "pg-migrate-cli-help-fixture" + in error message + CompletionInvoked _ -> error "unexpected completion" + +parseFailure :: [String] -> IO String +parseFailure arguments = + case execParserPure defaultPrefs commandInfo arguments of + Failure failure -> pure (fst (renderFailure failure "pg-migrate-cli-help-fixture")) + Success parsedCommand -> assertFailure ("expected parser failure, received: " <> show parsedCommand) + CompletionInvoked _ -> assertFailure "expected parser failure, received completion" + +assertContains :: String -> String -> Assertion +assertContains needle haystack = + assertBool ("expected output to contain " <> show needle <> ", received:\n" <> haystack) (needle `isInfixOf` haystack) + +fixturePlan :: MigrationPlan +fixturePlan = + expectRight + ( migrationPlan + ( expectRight + ( migrationComponent + "accounts" + Set.empty + (expectRight (sqlMigration "0001" (ByteString.pack "SELECT 1")) :| []) + ) + :| [] + ) + ) + +expectRight :: (Show error) => Either error value -> value +expectRight = either (error . show) id