diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,18 @@ +# Changelog for clickhouse-migrate-cli + +## 0.1.0.0 — 2026-10-16 + +Initial release. + +### New Features + +- Reusable, composable administrative CLI for `clickhouse-migrate` + (`ClickHouseMigrate.CLI`) with application-owned configuration, coordination, + rendering and exit policy. +- Composable parsing and dispatch of guarded commands with explicit result + contracts (`ClickHouseMigrate.CLI.Parser`, `ClickHouseMigrate.CLI.Handler`). +- Text and `schemaVersion` 1 JSON rendering + (`ClickHouseMigrate.CLI.Render.Text`, `ClickHouseMigrate.CLI.Render.Json`). +- Bounded adoption input files (`ClickHouseMigrate.CLI.AdoptionFile`). +- Preserves partial evidence, explicit recovery, stdout/stderr separation and + cancellation. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2026, shinzui +All rights reserved. + +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,20 @@ +# clickhouse-migrate-cli + +Mount `commandParser` or use `parseInvocation`, then pass the application-owned +environment and compiled plan to `handleCommand`. The application chooses configuration, +exclusive-access provider, event/diagnostic sinks, command policy, stdout and exit code. +The reusable library performs no implicit environment/secret loading or process exit. +Offline plan never evaluates the environment; mutations require a provider. + +Includes plan, status, history, verify with require-current, up with explicit retained +initialization UUID, all four repair operations, and adoption preview/apply/resume. +No force/reset/checksum-rewrite operations. Repair/adoption validate explicit audit, +expected state and quiescence/evidence before core dispatch. Adoption reads only an +explicit bounded strict JSON evidence file; executable SQL comes from the compiled plan. + +`renderJson` returns one schemaVersion 1 document without a newline. The caller writes +it after normal return and keeps progress on a separate sink. Synchronous failures +retain primary cause, latest acknowledged report, query/receipt identities and separate +secondary errors. Cancellation is rethrown and may produce no final JSON. Default +text/JSON excludes SQL, credentials and raw exception bodies. Frozen golden fixtures +ship under test/golden; the workspace's docs/user/contracts/json-v1.md defines the wire format. diff --git a/clickhouse-migrate-cli.cabal b/clickhouse-migrate-cli.cabal new file mode 100644 --- /dev/null +++ b/clickhouse-migrate-cli.cabal @@ -0,0 +1,67 @@ +cabal-version: 3.12 +name: clickhouse-migrate-cli +version: 0.1.0.0 +synopsis: Reusable administrative CLI for ClickHouse migrations +description: + Reusable administrative CLI for ClickHouse migrations. + Application-owned configuration, coordination, rendering and exit policy. + +license: BSD-3-Clause +license-file: LICENSE +author: shinzui +maintainer: shinzui@users.noreply.github.com +category: Database +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +data-files: test/golden/*.json +tested-with: ghc ==9.12.4 + +source-repository head + type: git + location: https://github.com/shinzui/clickhouse-migrate.git + subdir: clickhouse-migrate-cli + +common common + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + OverloadedLabels + OverloadedStrings + + ghc-options: + -Wall + -Werror=incomplete-patterns + + build-depends: + aeson >=2.2.4.1 && <2.4, + base >=4.21 && <4.22, + bytestring >=0.12.2 && <0.13, + clickhouse-migrate ==0.1.*, + containers >=0.7 && <0.9, + optparse-applicative >=0.18.1 && <0.20, + text >=2.1 && <2.2, + +library + import: common + hs-source-dirs: src + exposed-modules: + ClickHouseMigrate.CLI + ClickHouseMigrate.CLI.AdoptionFile + ClickHouseMigrate.CLI.Handler + ClickHouseMigrate.CLI.Parser + ClickHouseMigrate.CLI.Render.Json + ClickHouseMigrate.CLI.Render.Text + ClickHouseMigrate.CLI.Types + +test-suite clickhouse-migrate-cli-test + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: clickhouse-migrate-cli + other-modules: Paths_clickhouse_migrate_cli + autogen-modules: Paths_clickhouse_migrate_cli diff --git a/src/ClickHouseMigrate/CLI.hs b/src/ClickHouseMigrate/CLI.hs new file mode 100644 --- /dev/null +++ b/src/ClickHouseMigrate/CLI.hs @@ -0,0 +1,18 @@ +-- | Reusable commands around an application's compiled plan. The application +-- owns configuration, coordination, diagnostics, stdout and process exit policy. +-- 'handleCommand' returns synchronous failures with the last acknowledged report; +-- asynchronous exceptions propagate after the core's bounded cleanup. +module ClickHouseMigrate.CLI + ( module ClickHouseMigrate.CLI.Types, + module ClickHouseMigrate.CLI.Parser, + module ClickHouseMigrate.CLI.Handler, + renderJson, + renderText, + ) +where + +import ClickHouseMigrate.CLI.Handler +import ClickHouseMigrate.CLI.Parser +import ClickHouseMigrate.CLI.Render.Json (renderJson) +import ClickHouseMigrate.CLI.Render.Text (renderText) +import ClickHouseMigrate.CLI.Types diff --git a/src/ClickHouseMigrate/CLI/AdoptionFile.hs b/src/ClickHouseMigrate/CLI/AdoptionFile.hs new file mode 100644 --- /dev/null +++ b/src/ClickHouseMigrate/CLI/AdoptionFile.hs @@ -0,0 +1,124 @@ +-- | Explicit bounded source-neutral input. SQL definitions always come from the +-- compiled plan; historical bytes here can only verify predecessor evidence. +module ClickHouseMigrate.CLI.AdoptionFile (readAdoptionInput, decodeAdoptionInput) where + +import ClickHouseMigrate.Adoption qualified as A +import ClickHouseMigrate.CLI.Types +import ClickHouseMigrate.Ledger qualified as L +import ClickHouseMigrate.Prelude +import ClickHouseMigrate.Target (TargetKey) +import Control.Exception (IOException, try) +import Data.Aeson (Value (..), eitherDecodeStrict') +import Data.Aeson.Decoding.ByteString (bsToTokens) +import Data.Aeson.Decoding.Tokens +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString qualified as BS +import Data.Foldable (toList) +import Data.List.NonEmpty qualified as NE +import Data.Set qualified as Set +import Data.Text qualified as Text +import System.IO (IOMode (ReadMode), withBinaryFile) + +readAdoptionInput :: FilePath -> IO (Either CommandError ByteString) +readAdoptionInput file = do + result <- try @IOException (withBinaryFile file ReadMode (\handle -> BS.hGet handle 16777217)) + pure $ case result of Left _ -> Left InputUnavailable; Right bytes | BS.length bytes > 16777216 -> Left InputTooLarge; Right bytes -> Right bytes + +-- The public Aeson token API is walked before duplicate keys are discarded, +-- including escaped aliases. Parser errors never carry arbitrary input text. +checkTokens :: Int -> Tokens k String -> Either CommandError k +checkTokens _ (TkLit _ next) = Right next +checkTokens _ (TkText _ next) = Right next +checkTokens _ (TkNumber _ next) = Right next +checkTokens depth (TkArrayOpen values) | depth < 64 = checkArray (depth + 1) values +checkTokens depth (TkRecordOpen pairs) | depth < 64 = checkRecord (depth + 1) Set.empty pairs +checkTokens _ _ = Left InvalidJsonInput + +checkArray :: Int -> TkArray k String -> Either CommandError k +checkArray _ (TkArrayEnd next) = Right next +checkArray _ (TkArrayErr _) = Left InvalidJsonInput +checkArray depth (TkItem value) = checkTokens depth value >>= checkArray depth + +checkRecord :: Int -> Set Key.Key -> TkRecord k String -> Either CommandError k +checkRecord _ _ (TkRecordEnd next) = Right next +checkRecord _ _ (TkRecordErr _) = Left InvalidJsonInput +checkRecord depth seen (TkPair key value) + | Set.member key seen = Left DuplicateJsonKey + | otherwise = checkTokens depth value >>= checkRecord depth (Set.insert key seen) + +objectAt :: [Key.Key] -> Value -> Either CommandError (KM.KeyMap Value) +objectAt allowed (Object value) | all (`elem` allowed) (KM.keys value) = Right value +objectAt _ _ = Left InvalidAdoptionInput + +member :: Key.Key -> KM.KeyMap Value -> Either CommandError Value +member name = maybe (Left InvalidAdoptionInput) Right . KM.lookup name + +textAt :: Value -> Either CommandError Text +textAt (String value) = Right value +textAt _ = Left InvalidAdoptionInput + +arrayAt :: Value -> Either CommandError [Value] +arrayAt (Array values) | length values <= 1000 = Right (toList values) +arrayAt (Array _) = Left InputTooLarge +arrayAt _ = Left InvalidAdoptionInput + +unhex :: Text -> Either CommandError ByteString +unhex value + | Text.length value > 4194304 = Left InputTooLarge + | odd (Text.length value) = Left InvalidAdoptionInput + | otherwise = BS.pack <$> go [] (Text.unpack value) + where + nibble c + | c >= '0' && c <= '9' = Right (fromEnum c - fromEnum '0') + | c >= 'a' && c <= 'f' = Right (fromEnum c - fromEnum 'a' + 10) + | otherwise = Left InvalidAdoptionInput + go acc [] = Right (reverse acc) + go acc (a : b : rest) = do x <- nibble a; y <- nibble b; go (fromIntegral (x * 16 + y) : acc) rest + go _ _ = Left InvalidAdoptionInput + +core :: Either A.AdoptionError a -> Either CommandError a +core = either (const (Left InvalidAdoptionInput)) Right + +decodeAdoptionInput :: TargetKey -> L.ExpectedLedgerState -> Maybe L.InitializationAuthorization -> L.QuiescenceEvidence -> L.AuditContext -> ByteString -> Either CommandError A.AdoptionRequest +decodeAdoptionInput target expected authorization quiet audit bytes = do + when (BS.length bytes > 16777216) (Left InputTooLarge) + _ <- checkTokens 0 (bsToTokens bytes) + value <- either (const (Left InvalidJsonInput)) Right (eitherDecodeStrict' bytes) + object <- objectAt ["schemaVersion", "source", "snapshotReference", "rows", "mappings"] value + version <- member "schemaVersion" object + unless (version == Number 1) (Left UnsupportedInputVersion) + source <- member "source" object >>= textAt + reference <- member "snapshotReference" object >>= textAt + rows <- member "rows" object >>= arrayAt >>= traverse parseRow + mappings <- member "mappings" object >>= arrayAt >>= traverse parseMapping + nonemptyRows <- maybe (Left InvalidAdoptionInput) Right (NE.nonEmpty rows) + nonemptyMappings <- maybe (Left InvalidAdoptionInput) Right (NE.nonEmpty mappings) + core (A.adoptionRequest target expected authorization quiet audit source reference nonemptyRows nonemptyMappings) + where + parseRow value = do + object <- objectAt ["id", "appliedAt", "checksum"] value + identity <- member "id" object >>= textAt + appliedAt <- member "appliedAt" object >>= textAt + checksum <- case KM.lookup "checksum" object of + Nothing -> Right Nothing + Just Null -> Right Nothing + Just stored -> do + fields <- objectAt ["algorithm", "digest"] stored + algorithm <- member "algorithm" fields >>= textAt + digest <- member "digest" fields >>= textAt + Just <$> core (A.sourceChecksum algorithm digest) + core (A.legacyRow identity appliedAt checksum) + parseMapping value = do + object <- objectAt ["row", "component", "migration", "checksum", "evidence"] value + row <- member "row" object >>= textAt + component <- member "component" object >>= textAt + migration <- member "migration" object >>= textAt + checksum <- member "checksum" object >>= textAt + evidence <- member "evidence" object >>= objectAt ["level", "references", "historicalBytesHex"] + level <- member "level" evidence >>= textAt + refs <- member "references" evidence >>= arrayAt >>= traverse textAt + case level of + "operator-attestation" | not (KM.member "historicalBytesHex" evidence) -> core (A.attestedMapping row component migration checksum refs) + "predecessor-checksum" -> do historical <- member "historicalBytesHex" evidence >>= textAt >>= unhex; core (A.verifiedMapping row component migration checksum historical refs) + _ -> Left InvalidAdoptionInput diff --git a/src/ClickHouseMigrate/CLI/Handler.hs b/src/ClickHouseMigrate/CLI/Handler.hs new file mode 100644 --- /dev/null +++ b/src/ClickHouseMigrate/CLI/Handler.hs @@ -0,0 +1,148 @@ +-- | Dispatch with application-owned configuration, sinks and command policy. +module ClickHouseMigrate.CLI.Handler (commandEnvironment, handleCommand, planReport, quiescenceForCommand) where + +import ClickHouseMigrate +import ClickHouseMigrate.Adoption qualified as A +import ClickHouseMigrate.CLI.AdoptionFile +import ClickHouseMigrate.CLI.Parser (commandName, isMutation) +import ClickHouseMigrate.CLI.Types +import ClickHouseMigrate.Event qualified as E +import ClickHouseMigrate.ExclusiveAccess (ExclusiveAccess) +import ClickHouseMigrate.Inspection qualified as I +import ClickHouseMigrate.Ledger qualified as L +import ClickHouseMigrate.Prelude +import ClickHouseMigrate.Repair qualified as Repair +import ClickHouseMigrate.Report qualified as R +import ClickHouseMigrate.Runner qualified as Run +import Data.List.NonEmpty qualified as NE +import Data.Set qualified as Set + +commandEnvironment :: Maybe TargetConfig -> Maybe ExclusiveAccess -> E.EventSink -> E.DiagnosticPolicy -> CommandPolicy -> CommandEnvironment +commandEnvironment = CommandEnvironment + +planReport :: MigrationPlan -> [PlanComponent] +planReport plan = + [ PlanComponent + (componentNameText (componentViewName component)) + (map componentNameText (Set.toAscList (componentDependencies component))) + [ PlanMigration + (migrationNameText (migrationIdName (migrationId migration))) + (migrationDescription migration) + (migrationChecksumHex (migrationChecksum migration)) + [PlanStep (stepNameText (stepViewName step)) (stepChecksumHex (stepChecksum step)) | step <- NE.toList (migrationSteps migration)] + | migration <- NE.toList (componentMigrations component) + ] + | component <- NE.toList (inspectPlan plan) + ] + +makeAudit :: AuditInput -> Either CommandError L.AuditContext +makeAudit (AuditInput actor reason refs) = either (const (Left InvalidAuditInput)) Right (L.auditContext actor reason refs) + +makeQuiet :: TargetKey -> AuditInput -> Bool -> Either CommandError (Maybe L.QuiescenceEvidence) +makeQuiet _ _ False = Right Nothing +makeQuiet key input@(AuditInput _ _ refs) True = do + unless (not (null refs)) (Left RecoveryEvidenceRequired) + audit <- makeAudit input + Just <$> either (const (Left InvalidAuditInput)) Right (L.attestQuiescence key audit) + +-- Applications may use this to construct a conservative development provider. +-- It does not prove exclusion/drain; the assertion remains the caller's duty. +quiescenceForCommand :: TargetKey -> Command -> Either CommandError (Maybe L.QuiescenceEvidence) +quiescenceForCommand actual = \case + UpCommand (UpInput expected audit _ quiet) -> match expected >> makeQuiet actual audit quiet + RepairCommand _ (RepairInput expected _ _ _ audit quiet _) -> match expected >> required audit quiet + AdoptCommand _ (AdoptionInput expected _ _ audit quiet _ _) -> match expected >> required audit quiet + _ -> Right Nothing + where + match expected = unless (actual == expected) (Left ExpectedTargetMismatch) + required audit quiet = do + unless quiet (Left QuiescenceRequired) + makeQuiet actual audit quiet + +data Ready = Ready !TargetConfig !(Maybe ExclusiveAccess) !E.EventSink !E.DiagnosticPolicy + +prepare :: CommandEnvironment -> Command -> Either CommandError Ready +prepare (CommandEnvironment configured provider sink diagnostics policy) command = do + when (isMutation command && policy /= AdministrativeCommands) (Left CommandNotAllowed) + config <- maybe (Left MissingTargetConfiguration) Right configured + when (isMutation command && isNothing provider) (Left MissingExclusiveAccess) + let key = configuredTargetKey config + _ <- quiescenceForCommand key command + case command of + UpCommand (UpInput _ audit _ _) -> void (makeAudit audit) + RepairCommand _ (RepairInput _ _ _ _ audit _ _) -> void (makeAudit audit) + AdoptCommand _ (AdoptionInput _ _ _ audit _ _ file) -> do + void (makeAudit audit) + when (null file || '\0' `elem` file) (Left InvalidAdoptionInput) + _ -> pure () + pure (Ready config provider sink diagnostics) + +inspection :: Maybe ExclusiveAccess -> Bool -> Either CommandError I.InspectionOptions +inspection _ False = Right I.Observe +inspection provider True = maybe (Left MissingExclusiveAccess) (Right . I.Guarded) provider + +-- Offline plan deliberately does not force the environment argument. +handleCommand :: CommandEnvironment -> MigrationPlan -> Command -> IO CommandResult +handleCommand _ plan PlanCommand = pure (CommandResult "plan" (Right (PlanReport (planReport plan) [(componentNameText (migrationIdComponent identity), migrationNameText (migrationIdName identity)) | view <- NE.toList (inspectSchedule plan), let identity = migrationId view]))) +handleCommand environment plan command = + let name = commandName command + reject = pure . CommandResult name . Left . CommandRejected + finish = pure . CommandResult name + in case prepare environment command of + Left failure -> reject failure + Right (Ready config provider sink diagnostics) -> + let readWith guarded action = case inspection provider guarded of Left failure -> reject failure; Right options -> action options >>= finish + mutate action = case provider of Nothing -> reject MissingExclusiveAccess; Just access -> action (Run.mutationContext config access sink diagnostics) + in case command of + StatusCommand guarded -> readWith guarded (\options -> fmap (either (Left . InspectionFailed) (Right . StatusReport)) (I.status options config plan)) + HistoryCommand guarded -> readWith guarded (\options -> fmap (either (Left . InspectionFailed) (Right . HistoryReport)) (I.history options config)) + VerifyCommand current guarded -> readWith guarded (\options -> fmap (either (Left . InspectionFailed) (Right . VerificationReport)) (I.verify options config (I.verifyOptions current) plan)) + UpCommand (UpInput target input initialization _) -> case makeAudit input of + Left failure -> reject failure + Right audit -> mutate $ \context -> Run.up context (Run.upOptions audit (fmap (\ledger -> L.authorizeInitialization target ledger audit) initialization)) plan >>= finish . either (Left . RunFailed) (Right . RunReport) + RepairCommand operation (RepairInput _ expected attempt selected input quiet receipts) -> case recovery config input quiet receipts of + Left failure -> reject failure + Right evidence -> case buildRepair operation expected attempt selected evidence of + Left failure -> reject failure + Right request -> mutate $ \context -> Repair.repair context plan request >>= finish . either (Left . RunFailed) (Right . RunReport) + AdoptCommand operation (AdoptionInput target expected initialization input quiet guarded file) -> case makeAdoption target expected initialization input quiet of + Left failure -> reject failure + Right (state, authorization, established, audit) -> do + loaded <- readAdoptionInput file + case loaded >>= decodeAdoptionInput target state authorization established audit of + Left failure -> reject failure + Right request -> case inspection provider guarded of + Left failure -> reject failure + Right options -> do + observed <- I.status options config plan + case observed of + Left failure -> finish (Left (InspectionFailed failure)) + Right snapshot -> case A.planAdoption plan snapshot request of + Left failure -> let R.InspectionReport observedHistory _ _ = snapshot in finish (Left (AdoptionRejected failure observedHistory)) + Right adoption -> case operation of + PlanAdoption -> let R.InspectionReport observedHistory _ _ = snapshot in finish (Right (AdoptionPlanReport observedHistory (A.inspectAdoption adoption) (A.adoptionEntries adoption))) + ApplyAdoption -> mutate $ \context -> A.applyAdoption context plan adoption >>= finish . either (Left . RunFailed) (Right . RunReport) + ResumeAdoption -> mutate $ \context -> A.resumeAdoption context plan adoption >>= finish . either (Left . RunFailed) (Right . RunReport) + +recovery :: TargetConfig -> AuditInput -> Bool -> [L.AppendReceipt] -> Either CommandError Repair.RecoveryEvidence +recovery config input quiet receipts = do + established <- makeQuiet (configuredTargetKey config) input quiet >>= maybe (Left QuiescenceRequired) Right + audit <- makeAudit input + either (const (Left InvalidRepairInput)) Right (Repair.recoveryEvidence audit established receipts) + +buildRepair :: RepairOperation -> L.LedgerPosition -> L.AttemptId -> Maybe R.StepAttempt -> Repair.RecoveryEvidence -> Either CommandError Repair.RepairRequest +buildRepair operation expected attempt selected evidence = either (const (Left InvalidRepairInput)) Right $ case (operation, selected) of + (Resume, Nothing) -> Repair.resumeRequest expected attempt evidence + (Finalize, Nothing) -> Repair.finalizeRequest expected attempt evidence + (RetryStep, Just step) -> Repair.retryStepRequest expected attempt step evidence + (AcceptStep, Just step) -> Repair.acceptStepRequest expected attempt step evidence + _ -> Left Repair.InvalidStepAttempt + +makeAdoption :: TargetKey -> ExpectedInput -> Maybe LedgerId -> AuditInput -> Bool -> Either CommandError (L.ExpectedLedgerState, Maybe L.InitializationAuthorization, L.QuiescenceEvidence, L.AuditContext) +makeAdoption target expected initialization input quiet = do + established <- makeQuiet target input quiet >>= maybe (Left QuiescenceRequired) Right + audit <- makeAudit input + let state = case expected of AbsentInput -> L.ExpectAbsent target; PositionInput position -> L.ExpectPosition position + authorization = fmap (\ledger -> L.authorizeInitialization target ledger audit) initialization + when (case expected of AbsentInput -> isNothing authorization; _ -> False) (Left InitializationRequired) + pure (state, authorization, established, audit) diff --git a/src/ClickHouseMigrate/CLI/Parser.hs b/src/ClickHouseMigrate/CLI/Parser.hs new file mode 100644 --- /dev/null +++ b/src/ClickHouseMigrate/CLI/Parser.hs @@ -0,0 +1,131 @@ +-- | Composable optparse-applicative parser. The caller owns its outer executable. +module ClickHouseMigrate.CLI.Parser (commandParser, commandInfo, parseInvocation, commandName, requiresTarget, isMutation) where + +import ClickHouseMigrate.CLI.Types +import ClickHouseMigrate.Definition qualified as D +import ClickHouseMigrate.Ledger qualified as L +import ClickHouseMigrate.Prelude +import ClickHouseMigrate.Repair qualified as Repair +import ClickHouseMigrate.Report qualified as R +import ClickHouseMigrate.Target qualified as T +import Control.Applicative (many, optional, some, (<**>), (<|>)) +import Data.Text qualified as Text +import Options.Applicative qualified as O +import System.Exit (ExitCode (..)) + +readValidated :: (Show e) => (Text -> Either e a) -> O.ReadM a +readValidated parse = O.eitherReader (either (Left . show) Right . parse . Text.pack) + +textOption :: String -> String -> String -> O.Parser Text +textOption name metavar description = O.option reader (O.long name <> O.metavar metavar <> O.help description) + where + reader = O.eitherReader $ \raw -> + let value = Text.pack raw + checked = case name of "actor" -> L.auditContext value "parser validation" []; "reason" -> L.auditContext "parser validation" value []; _ -> L.auditContext "parser validation" "parser validation" [value] + in either (const (Left "Invalid audit field")) (const (Right value)) checked + +output :: O.Parser OutputFormat +output = O.flag TextOutput JsonOutput (O.long "json" <> O.help "Return one schemaVersion 1 command-result JSON document; progress uses the caller sink") + +audit :: Bool -> O.Parser AuditInput +audit required = AuditInput <$> textOption "actor" "ACTOR" "Administrative actor retained in immutable history" <*> textOption "reason" "REASON" "Reason retained in immutable history" <*> (if required then some evidence else many evidence) + where + evidence = textOption "evidence" "REFERENCE" "External evidence reference; repeat for additional evidence" + +expectedTarget :: O.Parser T.TargetKey +expectedTarget = O.option (readValidated T.targetKey) (O.long "expect-target" <> O.metavar "TARGET" <> O.help "Exact configured target key") + +initialization :: O.Parser (Maybe T.LedgerId) +initialization = optional (O.option (readValidated T.ledgerId) (O.long "initialize-ledger" <> O.metavar "UUID" <> O.help "Explicit first-use UUID; retain before submission, then persist the returned ledger binding")) + +quiescent :: Bool -> O.Parser Bool +quiescent required = if required then O.flag' True description else O.switch description + where + description = O.long "quiescent" <> O.help "Assert external exclusion and complete drain of all predecessor SQL, ledger and bootstrap requests; absence/timeout is insufficient" + +guarded :: O.Parser Bool +guarded = O.switch (O.long "guarded" <> O.help "Acquire the caller's provider for this observation") + +stepAttempt :: O.Parser R.StepAttempt +stepAttempt = R.StepAttempt <$> O.option (readValidated L.parseAttemptId) (O.long "step-attempt" <> O.metavar "UUID" <> O.help "Original migration attempt owning the selected step query") <*> O.option (O.eitherReader (either (const (Left "Invalid stable step name")) (Right . D.stepNameText) . D.stepName . Text.pack)) (O.long "step" <> O.metavar "STEP") <*> O.option (readValidated T.queryId) (O.long "query-id" <> O.metavar "QUERY_ID" <> O.help "Exact selected query identity from history") + +repairInput :: Bool -> O.Parser RepairInput +repairInput selected = RepairInput <$> expectedTarget <*> O.option (readValidated L.parseLedgerPosition) (O.long "expect-position" <> O.metavar "TOKEN") <*> O.option (readValidated L.parseAttemptId) (O.long "attempt" <> O.metavar "UUID" <> O.help "Current migration attempt from fresh guarded history") <*> (if selected then Just <$> stepAttempt else pure Nothing) <*> audit True <*> quiescent True <*> many (O.option (readValidated L.parseAppendReceipt) (O.long "pending-append" <> O.metavar "RECEIPT" <> O.help "Retained exact uncertain append receipt; repeat as needed")) + +adoptionInput :: O.Parser AdoptionInput +adoptionInput = AdoptionInput <$> expectedTarget <*> expected <*> initialization <*> audit True <*> quiescent True <*> guarded <*> O.strOption (O.long "request" <> O.metavar "FILE" <> O.help "Explicit source-neutral adoption input JSON; contains no executable migration definitions") + where + expected = (PositionInput <$> O.option (readValidated L.parseLedgerPosition) (O.long "expect-position" <> O.metavar "TOKEN")) <|> O.flag' AbsentInput (O.long "expect-absent" <> O.help "Expect missing or compatible uninitialized native history; requires explicit initialization UUID") + +leaf :: String -> String -> O.Parser Command -> O.Mod O.CommandFields Invocation +leaf name description parser = O.command name (O.info ((Invocation <$> output <*> parser) <**> O.helper) (O.progDesc description)) + +commandParser :: O.Parser Invocation +commandParser = + O.hsubparser + ( leaf "plan" "Inspect compiled definitions offline; no target or server required" (pure PlanCommand) + <> leaf "status" "Observe definition compatibility and recorded states; never initialize" (StatusCommand <$> guarded) + <> leaf "history" "Observe immutable history without requiring compatible current definitions" (HistoryCommand <$> guarded) + <> leaf "verify" "Verify compatible history; pending is compatible unless --require-current. This does not verify schema equality" (VerifyCommand <$> O.switch (O.long "require-current" <> O.help "Fail when any migration remains pending") <*> guarded) + <> leaf "up" "Execute pending SQL once per authorized attempt; unresolved history blocks; no automatic repair" (UpCommand <$> (UpInput <$> expectedTarget <*> audit False <*> initialization <*> quiescent False)) + <> O.command "repair" (O.info (repairs <**> O.helper) (O.progDesc "Explicit expected-state recovery; no force, reset or checksum rewriting")) + <> O.command "adopt" (O.info (adoptions <**> O.helper) (O.progDesc "Review/apply/resume a complete legacy prefix without executing its SQL")) + ) + where + repairs = O.hsubparser (leaf "resume" "Run only never-started remaining steps of the selected migration" (RepairCommand Resume <$> repairInput False) <> leaf "retry-step" "Authorize fresh attempt/query IDs and execute only the selected step" (RepairCommand RetryStep <$> repairInput True) <> leaf "accept-step" "Attest the selected uncertain step; no SQL, continuation or finalization" (RepairCommand AcceptStep <$> repairInput True) <> leaf "finalize" "Complete a fully resolved migration without application SQL" (RepairCommand Finalize <$> repairInput False)) + adoptions = O.hsubparser (leaf "plan" "Read and validate the entire source/mapping before mutation" (AdoptCommand PlanAdoption <$> adoptionInput) <> leaf "apply" "Initialize only when explicitly authorized; append a reviewed fresh batch" (AdoptCommand ApplyAdoption <$> adoptionInput) <> leaf "resume" "Resume the identical interrupted batch at fresh expected state" (AdoptCommand ResumeAdoption <$> adoptionInput)) + +commandInfo :: O.ParserInfo Invocation +commandInfo = O.info (commandParser <**> O.helper) (O.fullDesc <> O.progDesc "Compiled ClickHouse migrations; application-owned configuration, coordination, logging and exit policy") + +-- Invalid arguments deliberately do not echo arbitrary values or secrets. +-- Applications needing optparse's richer diagnostics may use commandInfo directly. +parseInvocation :: [String] -> Either ParseIssue Invocation +parseInvocation args = case O.execParserPure O.defaultPrefs commandInfo args of + O.Success invocation@(Invocation _ command) -> validateParsed command >> Right invocation + O.Failure failure -> let (helpText, exit) = O.renderFailure failure "clickhouse-migrate" in Left (if exit == ExitSuccess then HelpRequested (Text.pack helpText) else ArgumentsRejected) + O.CompletionInvoked _ -> Left CompletionRequested + +validateParsed :: Command -> Either ParseIssue () +validateParsed = \case + UpCommand (UpInput target input _ quiet) -> do + auditContext <- checkedAudit input + when (quiet && null (L.auditReferences auditContext)) (Left ArgumentsRejected) + _ <- if quiet then validate (L.attestQuiescence target auditContext) else Right () + pure () + RepairCommand operation (RepairInput target expected attempt step input quiet receipts) -> do + auditContext <- checkedAudit input + unless quiet (Left ArgumentsRejected) + established <- either (const (Left ArgumentsRejected)) Right (L.attestQuiescence target auditContext) + evidence <- either (const (Left ArgumentsRejected)) Right (Repair.recoveryEvidence auditContext established receipts) + case (operation, step) of + (Resume, Nothing) -> validate (Repair.resumeRequest expected attempt evidence) + (Finalize, Nothing) -> validate (Repair.finalizeRequest expected attempt evidence) + (RetryStep, Just selected) -> validate (Repair.retryStepRequest expected attempt selected evidence) + (AcceptStep, Just selected) -> validate (Repair.acceptStepRequest expected attempt selected evidence) + _ -> Left ArgumentsRejected + AdoptCommand _ (AdoptionInput _ expected initialLedger input quiet _ file) -> do + auditContext <- checkedAudit input + unless (quiet && not (null (L.auditReferences auditContext)) && not (null file) && not ('\0' `elem` file)) (Left ArgumentsRejected) + case expected of AbsentInput | isNothing initialLedger -> Left ArgumentsRejected; _ -> Right () + _ -> Right () + where + checkedAudit (AuditInput actor reason refs) = either (const (Left ArgumentsRejected)) Right (L.auditContext actor reason refs) + validate = either (const (Left ArgumentsRejected)) (const (Right ())) + +commandName :: Command -> Text +commandName = \case + PlanCommand -> "plan" + StatusCommand _ -> "status" + HistoryCommand _ -> "history" + VerifyCommand _ _ -> "verify" + UpCommand _ -> "up" + RepairCommand operation _ -> case operation of Resume -> "repair.resume"; RetryStep -> "repair.retry-step"; AcceptStep -> "repair.accept-step"; Finalize -> "repair.finalize" + AdoptCommand operation _ -> case operation of PlanAdoption -> "adopt.plan"; ApplyAdoption -> "adopt.apply"; ResumeAdoption -> "adopt.resume" + +requiresTarget :: Command -> Bool +requiresTarget PlanCommand = False +requiresTarget _ = True + +isMutation :: Command -> Bool +isMutation = \case UpCommand _ -> True; RepairCommand _ _ -> True; AdoptCommand PlanAdoption _ -> False; AdoptCommand _ _ -> True; _ -> False diff --git a/src/ClickHouseMigrate/CLI/Render/Json.hs b/src/ClickHouseMigrate/CLI/Render/Json.hs new file mode 100644 --- /dev/null +++ b/src/ClickHouseMigrate/CLI/Render/Json.hs @@ -0,0 +1,242 @@ +-- | Explicit schemaVersion 1 encoding. No domain Generic/Show-based wire format. +module ClickHouseMigrate.CLI.Render.Json (renderJson, resultValue, commandErrorCode, runErrorCode) where + +import ClickHouseMigrate.Adoption qualified as A +import ClickHouseMigrate.CLI.Types +import ClickHouseMigrate.ExclusiveAccess qualified as Access +import ClickHouseMigrate.Ledger qualified as L +import ClickHouseMigrate.Plan qualified as Plan +import ClickHouseMigrate.Prelude +import ClickHouseMigrate.Report qualified as R +import ClickHouseMigrate.Target qualified as T +import Data.Aeson (Value (..), object, (.=)) +import Data.Aeson qualified as JSON +import Data.ByteString.Lazy qualified as Lazy +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Encoding + +renderJson :: CommandResult -> ByteString +renderJson = Lazy.toStrict . JSON.encode . resultValue + +nullable :: (a -> Value) -> Maybe a -> Value +nullable encode = maybe Null encode + +resultValue :: CommandResult -> Value +resultValue (CommandResult command result) = + object + [ "schemaVersion" .= (1 :: Int), + "command" .= command, + "status" .= (case result of Left _ -> "error" :: Text; Right _ -> "ok"), + "result" .= either (const Null) reportValue result, + "error" .= either failureValue (const Null) result + ] + +reportValue :: CommandReport -> Value +reportValue = \case + PlanReport components schedule -> object ["kind" .= ("plan" :: Text), "checksumFormat" .= Plan.checksumFormatName Plan.ChecksumV1, "completionPolicy" .= Encoding.decodeUtf8 Plan.completionPolicy, "components" .= componentsValue schedule 0 components, "schedule" .= [object ["ordinal" .= ordinal, "component" .= component, "migration" .= migration] | (ordinal, (component, migration)) <- zip [0 :: Int ..] schedule]] + StatusReport report -> object ["kind" .= ("status" :: Text), "report" .= inspectionValue report] + HistoryReport report -> object ["kind" .= ("history" :: Text), "report" .= historyValue report] + VerificationReport (R.VerificationReport report current) -> object ["kind" .= ("verification" :: Text), "compatible" .= True, "current" .= current, "report" .= inspectionValue report] + RunReport report -> object ["kind" .= ("run" :: Text), "report" .= runValue report] + AdoptionPlanReport observation summary entries -> object ["kind" .= ("adoption-plan" :: Text), "observation" .= historyValue observation, "batch" .= adoptionValue summary, "entries" .= [object ["definition" .= definitionValue definition, "evidence" .= evidenceValue evidence] | (definition, evidence) <- entries]] + +componentsValue :: [(Text, Text)] -> Int -> [PlanComponent] -> [Value] +componentsValue _ _ [] = [] +componentsValue schedule componentIndex (PlanComponent name dependencies migrations : rest) = + object ["index" .= componentIndex, "name" .= name, "dependencies" .= dependencies, "migrations" .= [object ["ordinal" .= lookup (name, migration) (zip schedule [0 :: Int ..]), "name" .= migration, "description" .= description, "checksum" .= checksum, "steps" .= [object ["index" .= stepIndex, "name" .= step, "checksum" .= digest] | (stepIndex, PlanStep step digest) <- zip [0 :: Int ..] steps]] | PlanMigration migration description checksum steps <- migrations]] : componentsValue schedule (componentIndex + 1) rest + +definitionValue :: R.DefinitionSummary -> Value +definitionValue (R.DefinitionSummary ordinal componentIndex component dependencies migration checksum steps) = object ["ordinal" .= ordinal, "componentIndex" .= componentIndex, "component" .= component, "dependencies" .= dependencies, "migration" .= migration, "checksum" .= checksum, "steps" .= [object ["name" .= name, "checksum" .= digest] | (name, digest) <- steps]] + +stepReferenceValue :: R.StepReference -> Value +stepReferenceValue (R.StepReference component migration step migrationChecksum stepChecksum) = object ["component" .= component, "migration" .= migration, "step" .= step, "migrationChecksum" .= migrationChecksum, "stepChecksum" .= stepChecksum] + +evidenceValue :: R.EvidenceSummary -> Value +evidenceValue (R.EvidenceSummary level references) = object ["level" .= (case level of L.OperatorAttestation -> "operator-attestation" :: Text; L.PredecessorChecksum -> "predecessor-checksum"), "references" .= references] + +stepAttemptValue :: R.StepAttempt -> Value +stepAttemptValue (R.StepAttempt owner name query) = object ["ownerAttempt" .= L.attemptIdText owner, "step" .= name, "queryId" .= T.queryIdText query] + +migrationState :: R.MigrationStatus -> Text +migrationState = \case R.Pending -> "pending"; R.InProgress -> "in-progress"; R.Failed -> "failed"; R.Applied -> "applied"; R.Adopted -> "adopted"; R.Invalid -> "invalid" + +stepState :: R.StepStatus -> Text +stepState = \case R.StepPending -> "pending"; R.StepUncertain -> "uncertain"; R.StepObservedSuccess -> "observed-success"; R.StepObservedFailure -> "observed-failure"; R.StepAccepted -> "accepted" + +migrationValue :: R.MigrationSummary -> Value +migrationValue (R.MigrationSummary definition state attempt steps) = object ["definition" .= definitionValue definition, "state" .= migrationState state, "attempt" .= fmap L.attemptIdText attempt, "steps" .= map stepValue steps] + where + stepValue (R.StepSummary name checksum status selected evidence) = object ["name" .= name, "checksum" .= checksum, "state" .= stepState status, "attempt" .= nullable stepAttemptValue selected, "evidence" .= nullable evidenceValue evidence] + +accessValue :: Access.AccessDescription -> Value +accessValue access = object ["strategy" .= Access.accessStrategy access, "scope" .= Access.accessScope access] + +observationAccess :: R.InspectionAccess -> Value +observationAccess = \case + R.UnguardedObservation -> object ["mode" .= ("unguarded-observation" :: Text)] + R.GuardedObservation access -> object ["mode" .= ("guarded-observation" :: Text), "provider" .= accessValue access] + +presenceValue :: R.LedgerPresence -> Value +presenceValue = \case + R.LedgerUnknown -> object ["kind" .= ("unknown" :: Text)] + R.LedgerMissing -> object ["kind" .= ("missing" :: Text)] + R.LedgerUninitialized -> object ["kind" .= ("uninitialized" :: Text)] + R.LedgerInitializedAt ledger -> object ["kind" .= ("initialized" :: Text), "ledgerId" .= T.ledgerIdText ledger] + +serverValue :: T.ServerIdentity -> Value +serverValue identity = object ["serverId" .= T.serverIdText (T.identityServerId identity), "version" .= T.identityVersion identity, "hostName" .= T.identityHostName identity] + +historyValue :: R.HistoryReport -> Value +historyValue (R.HistoryReport target server presence position access events migrations unresolved) = object ["target" .= T.targetKeyText target, "server" .= nullable serverValue server, "ledger" .= presenceValue presence, "position" .= fmap L.ledgerPositionText position, "access" .= observationAccess access, "events" .= map eventValue events, "migrations" .= map migrationValue migrations, "unresolved" .= unresolved] + +inspectionValue :: R.InspectionReport -> Value +inspectionValue (R.InspectionReport history migrations issues) = object ["observation" .= historyValue history, "migrations" .= map migrationValue migrations, "issues" .= map issueValue issues] + +issueValue :: R.CompatibilityIssue -> Value +issueValue = \case + R.DefinitionChanged index expected actual -> object ["code" .= ("definition-changed" :: Text), "index" .= index, "expected" .= nullable definitionValue expected, "actual" .= nullable definitionValue actual] + R.UnresolvedAttempt attempt -> object ["code" .= ("unresolved-attempt" :: Text), "attempt" .= L.attemptIdText attempt] + R.IncompleteAdoption batch -> object ["code" .= ("incomplete-adoption" :: Text), "batch" .= adoptionValue batch] + +runValue :: R.RunReport -> Value +runValue (R.RunReport identity target access acquired history migrations observations initialized) = object ["runId" .= identity, "target" .= T.targetKeyText target, "access" .= accessValue access, "acquired" .= acquired, "history" .= historyValue history, "migrations" .= map migrationValue migrations, "observations" .= map sqlValue observations, "initializedLedgerId" .= fmap T.ledgerIdText initialized] + +sqlValue :: R.SqlObservation -> Value +sqlValue (R.SqlObservation reference query evidence) = object ["step" .= stepReferenceValue reference, "queryId" .= T.queryIdText query, "evidence" .= case evidence of R.QueryAcknowledged -> object ["outcome" .= ("acknowledged-success" :: Text)]; R.QueryRejected outcome problem -> object ["outcome" .= requestEvidence outcome, "transport" .= transportValue problem]] + +auditValue :: L.AuditContext -> Value +auditValue audit = object ["actor" .= L.auditActor audit, "reason" .= L.auditReason audit, "references" .= L.auditReferences audit] + +adoptionValue :: R.AdoptionSummary -> Value +adoptionValue (R.AdoptionSummary source snapshot mapping definitions count) = object ["source" .= source, "snapshotDigest" .= snapshot, "mappingDigest" .= mapping, "definitionsDigest" .= definitions, "count" .= count] + +eventValue :: R.HistoryEvent -> Value +eventValue (R.HistoryEvent eventSequence identity ledger run attempt time audit runner context body) = object ["sequence" .= Text.pack (show eventSequence), "eventId" .= identity, "ledgerId" .= T.ledgerIdText ledger, "runId" .= run, "attempt" .= fmap L.attemptIdText attempt, "occurredAt" .= time, "audit" .= auditValue audit, "runnerVersion" .= runner, "context" .= nullable contextValue context, "kind" .= R.historyKind body, "body" .= bodyValue body] + where + contextValue (component, migration, checksum, step) = object ["component" .= component, "migration" .= migration, "checksum" .= checksum, "step" .= nullable (\(name, digest) -> object ["name" .= name, "checksum" .= digest]) step] + +bodyValue :: R.HistoryBody -> Value +bodyValue = \case + R.LedgerInitialized target -> object ["target" .= T.targetKeyText target] + R.MigrationDefinition definition -> object ["definition" .= definitionValue definition] + R.StepIntent index query -> object ["step" .= index, "queryId" .= T.queryIdText query] + R.StepCompletion index query -> object ["step" .= index, "queryId" .= T.queryIdText query] + R.ExecutionFailure index query (R.FailureSummary code status server) -> object ["step" .= index, "queryId" .= T.queryIdText query, "code" .= code, "httpStatus" .= status, "serverCode" .= server] + R.MigrationCompletion -> object [] + R.RecoveryAuthorization action expected previous next target quietAudit -> object ["action" .= recoveryValue action, "expected" .= L.ledgerPositionText expected, "previousAttempt" .= L.attemptIdText previous, "nextAttempt" .= L.attemptIdText next, "target" .= T.targetKeyText target, "quiescence" .= auditValue quietAudit] + R.AcceptedCompletion index evidence -> object ["step" .= index, "evidence" .= evidenceValue evidence] + R.AdoptionBeginning batch -> adoptionValue batch + R.AdoptedDefinition definition evidence -> object ["definition" .= definitionValue definition, "evidence" .= evidenceValue evidence] + R.AdoptionCompletion digest -> object ["mappingDigest" .= digest] + +recoveryValue :: R.RecoveryAction -> Value +recoveryValue = \case R.Resume -> object ["kind" .= ("resume" :: Text)]; R.RetryStep index -> object ["kind" .= ("retry-step" :: Text), "step" .= index]; R.AcceptStep index -> object ["kind" .= ("accept-step" :: Text), "step" .= index]; R.Finalize -> object ["kind" .= ("finalize" :: Text)] + +failureValue :: CommandFailure -> Value +failureValue = \case + CommandRejected failure -> envelope "command" (object ["code" .= commandErrorCode failure]) [] Null + AdoptionRejected failure observation -> envelope "adoption" (object ["code" .= adoptionErrorCode failure]) [] (historyValue observation) + RunFailed (R.RunFailure primary report secondary) -> envelope "run" (runErrorValue primary) (map secondaryValue secondary) (runValue report) + InspectionFailed (R.InspectionFailure primary observation secondary) -> envelope "inspection" (runErrorValue primary) (map secondaryValue secondary) (nullable historyValue observation) + where + envelope :: Text -> Value -> [Value] -> Value -> Value + envelope category primary secondary report = object ["category" .= (category :: Text), "primary" .= primary, "secondary" .= secondary, "report" .= report] + +secondaryValue :: R.SecondaryError -> Value +secondaryValue = \case + R.RecordingError problem -> object ["kind" .= ("recording" :: Text), "error" .= runErrorValue problem] + R.ObserverError phase -> object ["kind" .= ("observer" :: Text), "callback" .= callbackValue phase] + R.TransportCleanup problem -> object ["kind" .= ("transport-cleanup" :: Text), "error" .= transportValue problem] + R.AccessCleanup problem -> object ["kind" .= ("access-cleanup" :: Text), "code" .= accessErrorCode problem] + +callbackValue :: R.CallbackPhase -> Value +callbackValue = \case R.EventCallback phase -> object ["kind" .= ("event" :: Text), "phase" .= phase]; R.SqlDiagnosticCallback -> object ["kind" .= ("sql-diagnostic" :: Text)] + +requestEvidence :: L.RequestEvidence -> Text +requestEvidence = \case L.PositiveNonSubmission -> "positive-non-submission"; L.ObservedFailure -> "observed-server-failure"; L.UncertainSubmission -> "submission-uncertain" + +transportValue :: L.TransportError -> Value +transportValue (L.TransportError code status server) = object ["code" .= transportErrorCode code, "httpStatus" .= status, "serverCode" .= server] + +transportErrorCode :: L.TransportErrorCode -> Text +transportErrorCode = \case L.AdministrativeAccessLost -> "administrative-access-lost"; L.InvalidRequest -> "invalid-request"; L.ClientScopeFailed -> "client-scope-failed"; L.ConnectionFailed -> "connection-failed"; L.DeadlineExpired -> "deadline-expired"; L.ResponseInterrupted -> "response-interrupted"; L.ResponseTooLarge -> "response-too-large"; L.UnexpectedResponse -> "unexpected-response"; L.ServerRejected -> "server-rejected"; L.RedirectRejected -> "redirect-rejected"; L.ServerIdentityMismatch -> "server-identity-mismatch"; L.UnsupportedServer -> "unsupported-server"; L.CompletionPolicyMismatch -> "completion-policy-mismatch"; L.CleanupFailed -> "cleanup-failed"; L.CleanupTimedOut -> "cleanup-timed-out" + +accessErrorCode :: Access.AccessError -> Text +accessErrorCode = \case Access.InvalidAccessStrategy -> "invalid-access-strategy"; Access.AcquisitionTimedOut -> "acquisition-timed-out"; Access.AcquisitionFailed -> "acquisition-failed"; Access.AccessLost -> "access-lost"; Access.AccessScopeClosed -> "access-scope-closed"; Access.AccessActionFailed -> "access-action-failed"; Access.PredecessorQuiescenceRequired -> "predecessor-quiescence-required"; Access.AccessReleaseFailed -> "access-release-failed"; Access.AccessReleaseTimedOut -> "access-release-timed-out" + +ledgerErrorCode :: L.LedgerError -> Text +ledgerErrorCode = \case L.InvalidPosition -> "invalid-position"; L.InvalidAudit -> "invalid-audit"; L.InvalidEvidence -> "invalid-evidence"; L.InvalidEvent -> "invalid-event"; L.UnsupportedLedgerVersion -> "unsupported-ledger-version"; L.SequenceGap -> "sequence-gap"; L.SequenceConflict -> "sequence-conflict"; L.EventIdentityConflict -> "event-identity-conflict"; L.LedgerIdentityMismatch -> "ledger-identity-mismatch"; L.MissingInitialization -> "missing-initialization"; L.ImpossibleTransition -> "impossible-transition"; L.DefinitionMismatch -> "definition-mismatch"; L.InvalidLedgerSchema -> "invalid-ledger-schema"; L.UnsupportedLedgerStorage -> "unsupported-ledger-storage"; L.LedgerAbsent -> "ledger-absent"; L.LedgerUninitialized -> "ledger-uninitialized"; L.InitializationNotAuthorized -> "initialization-not-authorized"; L.StaleLedgerState -> "stale-ledger-state"; L.UnresolvedHistory -> "unresolved-history"; L.OutstandingRequests -> "outstanding-requests"; L.LedgerLimitExceeded -> "ledger-limit-exceeded" + +adoptionErrorCode :: A.AdoptionError -> Text +adoptionErrorCode = \case A.InvalidSourceEvidence -> "invalid-source-evidence"; A.UnsupportedSourceChecksum -> "unsupported-source-checksum"; A.InvalidSourceChecksum -> "invalid-source-checksum"; A.DuplicateSourceRow -> "duplicate-source-row"; A.DuplicateMapping -> "duplicate-mapping"; A.IncompleteMapping -> "incomplete-mapping"; A.UnknownSourceRow -> "unknown-source-row"; A.MappingOrderMismatch -> "mapping-order-mismatch"; A.MappingDefinitionMismatch -> "mapping-definition-mismatch"; A.HistoricalChecksumMismatch -> "historical-checksum-mismatch"; A.HistoricalChecksumRequired -> "historical-checksum-required"; A.AdoptionTargetMismatch -> "adoption-target-mismatch"; A.AdoptionInitializationRequired -> "adoption-initialization-required"; A.AdoptionExpectedStateMismatch -> "adoption-expected-state-mismatch"; A.AdoptionNativeConflict -> "adoption-native-conflict"; A.AdoptionBatchConflict -> "adoption-batch-conflict"; A.AdoptionResumeRequired -> "adoption-resume-required"; A.AdoptionBatchTooLarge -> "adoption-batch-too-large" + +repairReason :: R.RepairReason -> Text +repairReason = \case R.NoActiveMigration -> "no-active-migration"; R.AdoptionInProgress -> "adoption-in-progress"; R.UncertainStepRemains -> "uncertain-step-remains"; R.NoPendingSteps -> "no-pending-steps"; R.SelectedStepIsResolved -> "selected-step-is-resolved"; R.StepsNotResolved -> "steps-not-resolved"; R.ConflictingAppend -> "conflicting-append"; R.WrongQuiescenceTarget -> "wrong-quiescence-target" + +commandErrorCode :: CommandError -> Text +commandErrorCode = \case InvalidArguments -> "invalid-arguments"; MissingTargetConfiguration -> "missing-target-configuration"; MissingExclusiveAccess -> "missing-exclusive-access"; CommandNotAllowed -> "command-not-allowed"; ExpectedTargetMismatch -> "expected-target-mismatch"; InvalidAuditInput -> "invalid-audit-input"; QuiescenceRequired -> "quiescence-required"; RecoveryEvidenceRequired -> "recovery-evidence-required"; InvalidRepairInput -> "invalid-repair-input"; InitializationRequired -> "initialization-required"; InvalidAdoptionInput -> "invalid-adoption-input"; InputUnavailable -> "input-unavailable"; InputTooLarge -> "input-too-large"; InvalidJsonInput -> "invalid-json-input"; DuplicateJsonKey -> "duplicate-json-key"; UnsupportedInputVersion -> "unsupported-input-version" + +runErrorCode :: R.RunError -> Text +runErrorCode = \case + R.InvalidRuntimePlan _ -> "invalid-runtime-plan" + R.LedgerNamespaceInSql _ -> "ledger-namespace-in-sql" + R.DefinitionTooLarge _ -> "definition-too-large" + R.AccessFailed problem -> accessErrorCode problem + R.TargetFailed _ -> "target-failed" + R.LedgerFailed problem -> ledgerErrorCode problem + R.LedgerRequestFailed {} -> "ledger-request-failed" + R.InitializationFailed {} -> "initialization-failed" + R.SqlFailed {} -> "sql-failed" + R.CallbackFailed _ -> "callback-failed" + R.IncompatibleHistory _ -> "incompatible-history" + R.VerificationNotCurrent -> "verification-not-current" + R.RecoveryEventTooLarge _ -> "recovery-event-too-large" + R.AuditTooLarge -> "audit-too-large" + R.LedgerRequired -> "ledger-required" + R.AdoptionRejected problem -> adoptionErrorCode problem + R.ExistingBindingRequired -> "existing-ledger-binding-required" + R.StalePosition {} -> "stale-position" + R.AttemptMismatch {} -> "attempt-mismatch" + R.StepAttemptMismatch _ -> "step-attempt-mismatch" + R.RepairNotAllowed _ -> "repair-not-allowed" + R.PriorQueriesActive _ -> "prior-queries-active" + R.CleanupFailed -> "cleanup-failed" + R.UnexpectedRuntimeFailure -> "unexpected-runtime-failure" + +runErrorValue :: R.RunError -> Value +runErrorValue failure = object (("code" .= runErrorCode failure) : fields failure) + where + fields = \case + R.InvalidRuntimePlan step -> ["step" .= stepReferenceValue step] + R.LedgerNamespaceInSql step -> ["step" .= stepReferenceValue step] + R.DefinitionTooLarge definition -> ["definition" .= definitionValue definition] + R.AccessFailed _ -> [] + R.TargetFailed problem -> ["transport" .= transportValue problem] + R.LedgerFailed _ -> [] + R.LedgerRequestFailed evidence problem receipt -> ["evidence" .= requestEvidence evidence, "transport" .= transportValue problem, "pendingAppend" .= fmap L.appendReceiptText receipt] + R.InitializationFailed ledger stage query evidence problem -> ["ledgerId" .= ledger, "stage" .= stage, "queryId" .= T.queryIdText query, "evidence" .= requestEvidence evidence, "transport" .= transportValue problem] + R.SqlFailed step query evidence problem -> ["step" .= stepReferenceValue step, "queryId" .= T.queryIdText query, "evidence" .= requestEvidence evidence, "transport" .= transportValue problem] + R.CallbackFailed phase -> ["callback" .= callbackValue phase] + R.IncompatibleHistory issues -> ["issues" .= map issueValue issues] + R.VerificationNotCurrent -> [] + R.RecoveryEventTooLarge kind -> ["event" .= recoveryEventKind kind] + R.AuditTooLarge -> [] + R.LedgerRequired -> [] + R.AdoptionRejected _ -> [] + R.ExistingBindingRequired -> [] + R.StalePosition expected actual -> ["expected" .= L.ledgerPositionText expected, "actual" .= fmap L.ledgerPositionText actual] + R.AttemptMismatch expected actual -> ["expected" .= L.attemptIdText expected, "actual" .= fmap L.attemptIdText actual] + R.StepAttemptMismatch step -> ["stepAttempt" .= stepAttemptValue step] + R.RepairNotAllowed reason -> ["reason" .= repairReason reason] + R.PriorQueriesActive queries -> ["queryIds" .= map T.queryIdText queries] + R.CleanupFailed -> [] + R.UnexpectedRuntimeFailure -> [] + +recoveryEventKind :: R.RecoveryEventKind -> Text +recoveryEventKind = \case + R.RecoveryAuthorizationEvent -> "authorization" + R.RecoveryAcceptanceEvent -> "acceptance" + R.RecoveryCompletionEvent -> "completion" + R.RecoveryStepStartEvent -> "step-start" + R.RecoveryStepSuccessEvent -> "step-success" + R.RecoveryStepFailureEvent -> "step-failure" diff --git a/src/ClickHouseMigrate/CLI/Render/Text.hs b/src/ClickHouseMigrate/CLI/Render/Text.hs new file mode 100644 --- /dev/null +++ b/src/ClickHouseMigrate/CLI/Render/Text.hs @@ -0,0 +1,48 @@ +-- | Concise human summaries, with complete safe failure detail retained. +module ClickHouseMigrate.CLI.Render.Text (renderText) where + +import ClickHouseMigrate.CLI.Render.Json (renderJson) +import ClickHouseMigrate.CLI.Types +import ClickHouseMigrate.Ledger qualified as L +import ClickHouseMigrate.Prelude +import ClickHouseMigrate.Report qualified as R +import ClickHouseMigrate.Target qualified as T +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Encoding + +renderText :: CommandResult -> Text +renderText result@(CommandResult command outcome) = Text.unlines $ case outcome of + Left _ -> [command <> ": error", "Safe failure detail (schemaVersion 1; latest acknowledged report, local observations and secondary errors):", Encoding.decodeUtf8 (renderJson result)] + Right report -> + (command <> ": ok") : case report of + PlanReport components schedule -> ["Execution order:"] ++ [" " <> number ordinal <> " " <> component <> "/" <> migrationName | (ordinal, (component, migrationName)) <- zip [0 ..] schedule] ++ concatMap componentLines components + StatusReport (R.InspectionReport history migrations issues) -> historyLines history ++ migrationLines migrations ++ ["Compatibility issues: " <> number (length issues)] + HistoryReport history -> historyLines history ++ eventLines history + VerificationReport (R.VerificationReport (R.InspectionReport history migrations _) current) -> ["Compatible: yes", "Current: " <> if current then "yes" else "no (pending definitions)"] ++ historyLines history ++ migrationLines migrations + RunReport (R.RunReport _ _ _ acquired history migrations observations _) -> ["Administrative access acquired: " <> if acquired then "yes" else "no"] ++ historyLines history ++ migrationLines migrations ++ ["Local SQL observations: " <> number (length observations)] + AdoptionPlanReport history (R.AdoptionSummary source _ _ _ count) _ -> historyLines history ++ ["Adoption source: " <> source, "Reviewed prefix entries: " <> number count, "No application SQL executed."] + where + componentLines (PlanComponent name dependencies migrations) = ("Component: " <> name <> " (depends on: " <> Text.intercalate ", " dependencies <> ")") : concatMap migration migrations + migration (PlanMigration name _ checksum steps) = (" " <> name <> " " <> checksum) : [" " <> step <> " " <> digest | PlanStep step digest <- steps] + +number :: Int -> Text +number = Text.pack . show + +historyLines :: R.HistoryReport -> [Text] +historyLines (R.HistoryReport target _ presence position access _ _ unresolved) = + [ "Target: " <> T.targetKeyText target, + "Ledger: " <> case presence of R.LedgerUnknown -> "unknown"; R.LedgerMissing -> "missing"; R.LedgerUninitialized -> "uninitialized"; R.LedgerInitializedAt identity -> T.ledgerIdText identity, + "Position: " <> maybe "none" L.ledgerPositionText position, + "Observation: " <> case access of R.UnguardedObservation -> "unguarded"; R.GuardedObservation _ -> "guarded", + "Unresolved: " <> if unresolved then "yes" else "no" + ] + +eventLines :: R.HistoryReport -> [Text] +eventLines (R.HistoryReport _ _ _ _ _ events _ _) = [Text.pack (show ordinal) <> " " <> R.historyKind body | R.HistoryEvent ordinal _ _ _ _ _ _ _ _ body <- events] + +migrationLines :: [R.MigrationSummary] -> [Text] +migrationLines = concatMap $ \(R.MigrationSummary (R.DefinitionSummary _ _ component _ name _ _) state _ steps) -> + (component <> "/" <> name <> ": " <> migrationState state) : [" " <> step <> ": " <> stepState status | R.StepSummary step _ status _ _ <- steps] + where + migrationState = \case R.Pending -> "pending"; R.InProgress -> "in-progress"; R.Failed -> "failed"; R.Applied -> "applied"; R.Adopted -> "adopted"; R.Invalid -> "invalid" + stepState = \case R.StepPending -> "pending"; R.StepUncertain -> "uncertain"; R.StepObservedSuccess -> "observed-success"; R.StepObservedFailure -> "observed-failure"; R.StepAccepted -> "accepted (operator attestation)" diff --git a/src/ClickHouseMigrate/CLI/Types.hs b/src/ClickHouseMigrate/CLI/Types.hs new file mode 100644 --- /dev/null +++ b/src/ClickHouseMigrate/CLI/Types.hs @@ -0,0 +1,89 @@ +-- | Command values contain input, never an acquired administrative capability. +module ClickHouseMigrate.CLI.Types where + +import ClickHouseMigrate.Adoption (AdoptionError) +import ClickHouseMigrate.Event (DiagnosticPolicy, EventSink) +import ClickHouseMigrate.ExclusiveAccess (ExclusiveAccess) +import ClickHouseMigrate.Ledger qualified as L +import ClickHouseMigrate.Prelude +import ClickHouseMigrate.Report qualified as R +import ClickHouseMigrate.Target (LedgerId, TargetConfig, TargetKey) + +data OutputFormat = TextOutput | JsonOutput deriving stock (Eq, Show) + +data Invocation = Invocation !OutputFormat !Command deriving stock (Show) + +data AuditInput = AuditInput !Text !Text ![Text] deriving stock (Show) + +data UpInput = UpInput !TargetKey !AuditInput !(Maybe LedgerId) !Bool deriving stock (Show) + +data RepairOperation = Resume | RetryStep | AcceptStep | Finalize deriving stock (Eq, Show) + +data RepairInput = RepairInput !TargetKey !L.LedgerPosition !L.AttemptId !(Maybe R.StepAttempt) !AuditInput !Bool ![L.AppendReceipt] deriving stock (Show) + +data AdoptionOperation = PlanAdoption | ApplyAdoption | ResumeAdoption deriving stock (Eq, Show) + +data ExpectedInput = AbsentInput | PositionInput !L.LedgerPosition deriving stock (Show) + +data AdoptionInput = AdoptionInput !TargetKey !ExpectedInput !(Maybe LedgerId) !AuditInput !Bool !Bool !FilePath deriving stock (Show) + +data Command + = PlanCommand + | StatusCommand !Bool + | HistoryCommand !Bool + | VerifyCommand !Bool !Bool + | UpCommand !UpInput + | RepairCommand !RepairOperation !RepairInput + | AdoptCommand !AdoptionOperation !AdoptionInput + deriving stock (Show) + +data CommandPolicy = ReadOnlyCommands | AdministrativeCommands deriving stock (Eq, Show) + +-- Configuration and sinks are explicitly supplied. No implicit environment, +-- credentials, stdout, process exit, or live guard is owned by this value. +data CommandEnvironment = CommandEnvironment !(Maybe TargetConfig) !(Maybe ExclusiveAccess) !EventSink !DiagnosticPolicy !CommandPolicy + +data CommandError + = InvalidArguments + | MissingTargetConfiguration + | MissingExclusiveAccess + | CommandNotAllowed + | ExpectedTargetMismatch + | InvalidAuditInput + | QuiescenceRequired + | RecoveryEvidenceRequired + | InvalidRepairInput + | InitializationRequired + | InvalidAdoptionInput + | InputUnavailable + | InputTooLarge + | InvalidJsonInput + | DuplicateJsonKey + | UnsupportedInputVersion + deriving stock (Eq, Show) + +data CommandFailure + = CommandRejected !CommandError + | RunFailed !R.RunFailure + | InspectionFailed !R.InspectionFailure + | AdoptionRejected !AdoptionError !R.HistoryReport + deriving stock (Show) + +data PlanStep = PlanStep !Text !Text deriving stock (Eq, Show) + +data PlanMigration = PlanMigration !Text !(Maybe Text) !Text ![PlanStep] deriving stock (Eq, Show) + +data PlanComponent = PlanComponent !Text ![Text] ![PlanMigration] deriving stock (Eq, Show) + +data CommandReport + = PlanReport ![PlanComponent] ![(Text, Text)] + | StatusReport !R.InspectionReport + | HistoryReport !R.HistoryReport + | VerificationReport !R.VerificationReport + | RunReport !R.RunReport + | AdoptionPlanReport !R.HistoryReport !R.AdoptionSummary ![(R.DefinitionSummary, R.EvidenceSummary)] + deriving stock (Show) + +data CommandResult = CommandResult !Text !(Either CommandFailure CommandReport) deriving stock (Show) + +data ParseIssue = HelpRequested !Text | ArgumentsRejected | CompletionRequested deriving stock (Show) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,100 @@ +module Main (main) where + +import ClickHouseMigrate hiding (history, up) +import ClickHouseMigrate.CLI +import ClickHouseMigrate.CLI.AdoptionFile +import ClickHouseMigrate.Event qualified as E +import ClickHouseMigrate.ExclusiveAccess qualified as Access +import ClickHouseMigrate.Ledger qualified as L +import ClickHouseMigrate.Report qualified as R +import Control.Monad (forM_, unless) +import Data.Aeson qualified as JSON +import Data.ByteString qualified as BS +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Encoding +import Paths_clickhouse_migrate_cli (getDataFileName) + +assert :: String -> Bool -> IO () +assert label value = unless value (fail label) + +right :: (Show e) => Either e a -> a +right = either (error . show) id + +uuid :: Text.Text +uuid = "00000000-0000-0000-0000-000000000001" + +positionText :: Text.Text +positionText = "chm1:" <> uuid <> ":5:" <> uuid + +receiptText :: Text.Text +receiptText = "chm-receipt1:74657374:" <> uuid <> ":6:" <> uuid <> ":" <> Text.replicate 64 "a" <> ":append-6" + +main :: IO () +main = do + let step = right (sqlStep "create" "CREATE TABLE default.secret_fixture (id UInt8) ENGINE=Memory") + migration = right (sqlMigration "one" (step :| [])) + component = right (migrationComponent "app" Set.empty (migration :| [])) + plan = right (migrationPlan (component :| [])) + key = right (targetKey "test") + audit = right (L.auditContext "fixture actor" "fixture reason" ["fixture/drain"]) + quiet = right (L.attestQuiescence key audit) + ledger = right (ledgerId uuid) + authorization = Just (L.authorizeInitialization key ledger audit) + decode = decodeAdoptionInput key (L.ExpectAbsent key) authorization quiet audit + offline <- handleCommand (error "Offline plan forced configuration") plan PlanCommand + assert "offline plan missing" (case offline of CommandResult "plan" (Right (PlanReport [_] [("app", "one")])) -> True; _ -> False) + let two = right (sqlMigration "two" (step :| [])) + a = right (migrationComponent "a" Set.empty (migration :| [two])) + b = right (migrationComponent "b" (Set.singleton "a") (migration :| [])) + identity c m = migrationIdFromNames (right (componentName c)) (right (migrationName m)) + scheduled = right (scheduledMigrationPlan (a :| [b]) (identity "a" "one" :| [identity "b" "one", identity "a" "two"])) + scheduledResult <- handleCommand (error "Offline schedule forced environment") scheduled PlanCommand + assert "CLI schedule order wrong" (case scheduledResult of CommandResult _ (Right (PlanReport _ [("a", "one"), ("b", "one"), ("a", "two")])) -> True; _ -> False) + assert "Text omits execution schedule" ("0 a/one\n 1 b/one\n 2 a/two" `Text.isInfixOf` renderText scheduledResult) + assert "offline plan leaked SQL" (not ("secret_fixture" `Text.isInfixOf` Encoding.decodeUtf8 (renderJson offline))) + let auditArgs = ["--expect-target", "test", "--actor", "fixture actor", "--reason", "fixture reason"] + recoveryArgs = auditArgs ++ ["--expect-position", Text.unpack positionText, "--attempt", Text.unpack uuid, "--evidence", "fixture/drain", "--quiescent", "--pending-append", Text.unpack receiptText] + selected = ["--step-attempt", Text.unpack uuid, "--step", "insert", "--query-id", "query-2"] + adoptionArgs = auditArgs ++ ["--expect-absent", "--initialize-ledger", Text.unpack uuid, "--evidence", "fixture/drain", "--quiescent", "--request", "input.json"] + forM_ ([["plan", "--json"], ["status"], ["history", "--guarded"], ["verify", "--require-current"], ["up"] ++ auditArgs] ++ [["repair", op] ++ recoveryArgs ++ if op `elem` ["retry-step", "accept-step"] then selected else [] | op <- ["resume", "retry-step", "accept-step", "finalize"]] ++ [["adopt", op] ++ adoptionArgs | op <- ["plan", "apply", "resume"]]) $ \args -> assert ("Valid parser case rejected: " ++ show args) (case parseInvocation args of Right _ -> True; _ -> False) + forM_ [[], ["reset"], ["up", "--force"], ["repair", "accept-step"] ++ recoveryArgs, ["repair", "resume"] ++ filter (/= "--quiescent") recoveryArgs, ["up"] ++ auditArgs ++ ["--actor", "secret-password"], ["adopt", "apply"] ++ auditArgs ++ ["--expect-absent", "--quiescent", "--evidence", "fixture/drain", "--request", "a.json"], ["status", "--initialize-ledger", Text.unpack uuid]] $ \args -> assert "Malformed parser input accepted" (case parseInvocation args of Left ArgumentsRejected -> True; _ -> False) + assert "Help missing" (case parseInvocation ["verify", "--help"] of Left (HelpRequested text) -> "schema equality" `Text.isInfixOf` text; _ -> False) + let noTarget = commandEnvironment Nothing Nothing E.quietEvents E.redactedDiagnostics AdministrativeCommands + config = targetConfig key (right (directEndpoint "http://127.0.0.1:1")) (right (serverId uuid)) (right (ledgerNamespace "fixture_history")) FirstUse (right (basicCredentials "default" "secret-password")) defaultHttpLimits + noProvider = commandEnvironment (Just config) Nothing E.quietEvents E.redactedDiagnostics AdministrativeCommands + forbidden = commandEnvironment Nothing Nothing E.quietEvents E.redactedDiagnostics ReadOnlyCommands + up = UpCommand (UpInput key (AuditInput "actor" "reason" []) Nothing False) + forM_ [(noTarget, StatusCommand False, MissingTargetConfiguration), (noProvider, up, MissingExclusiveAccess), (noProvider, StatusCommand True, MissingExclusiveAccess), (forbidden, up, CommandNotAllowed)] $ \(env, command, expected) -> do + result <- handleCommand env plan command + assert "Preflight error wrong" (case result of CommandResult _ (Left (CommandRejected actual)) -> actual == expected; _ -> False) + forM_ [("{", InvalidJsonInput), ("{\"schemaVersion\":1,\"schemaVersion\":1}", DuplicateJsonKey), ("{\"schemaVersion\":1,\"schema\\u0056ersion\":1}", DuplicateJsonKey), ("{\"schemaVersion\":2}", UnsupportedInputVersion), ("{\"schemaVersion\":1,\"force\":true}", InvalidAdoptionInput), ("{} {}", InvalidJsonInput)] $ \(bytes, expected) -> assert "Unsafe adoption JSON accepted" (case decode bytes of Left actual -> actual == expected; _ -> False) + forM_ goldenCases $ \(name, result) -> do + path <- getDataFileName ("test/golden/" ++ name ++ ".json") + bytes <- BS.readFile path + let actual = JSON.eitherDecodeStrict' (renderJson result) :: Either String JSON.Value + expected = JSON.eitherDecodeStrict' bytes :: Either String JSON.Value + assert ("JSON golden mismatch: " ++ name) (actual == expected && either (const False) (const True) expected) + forM_ [renderJson result, Encoding.encodeUtf8 (renderText result)] $ \rendered -> assert "Sensitive SQL or credentials escaped" (not (BS.isInfixOf "SQL_SECRET_MARKER" rendered) && not (BS.isInfixOf "secret-password" rendered)) + putStrLn "CLI: offline environment unforced; all commands parsed; fail-closed policy/access; strict adoption decoding; six schemaVersion 1 golden results" + +goldenCases :: [(String, CommandResult)] +goldenCases = [("schedule", CommandResult "plan" (Right (PlanReport [PlanComponent "a" [] [PlanMigration "one" Nothing "a1-hash" [], PlanMigration "two" (Just "upgrade") "a2-hash" []], PlanComponent "b" ["a"] [PlanMigration "one" Nothing "b1-hash" []]] [("a", "one"), ("b", "one"), ("a", "two")]))), ("recovery-too-large", CommandResult "repair.accept-step" (Left (RunFailed (R.RunFailure (R.RecoveryEventTooLarge R.RecoveryAcceptanceEvent) run [])))), ("malformed", CommandResult "parse" (Left (CommandRejected InvalidArguments))), ("partial", CommandResult "up" (Left (RunFailed (R.RunFailure (R.SqlFailed reference query L.UncertainSubmission problem) run [R.AccessCleanup Access.AccessReleaseFailed])))), ("delayed-ledger", CommandResult "up" (Left (RunFailed (R.RunFailure (R.LedgerRequestFailed L.UncertainSubmission problem (Just receipt)) run [R.RecordingError (R.LedgerFailed L.OutstandingRequests)])))), ("accepted", CommandResult "status" (Right (StatusReport (R.InspectionReport history [accepted] []))))] + where + identity = right (ledgerId uuid) + attempt = right (L.parseAttemptId uuid) + query = right (queryId "query-2") + receipt = right (L.parseAppendReceipt receiptText) + position = right (L.parseLedgerPosition positionText) + key = right (targetKey "test") + access = Access.exclusiveAccessDescription (right (Access.externallySerialized "fixture" "owned target" 1000 (const (fail "Golden provider must never acquire")) (const (pure ())) (const (pure False)))) + definition = R.DefinitionSummary 0 0 "app" [] "one" "migration-hash" [("create", "create-hash"), ("insert", "insert-hash")] + reference = R.StepReference "app" "one" "insert" "migration-hash" "insert-hash" + selected = R.StepAttempt attempt "insert" query + create = R.StepSummary "create" "create-hash" R.StepObservedSuccess (Just (R.StepAttempt attempt "create" (right (queryId "query-1")))) Nothing + unresolved = R.MigrationSummary definition R.InProgress (Just attempt) [create, R.StepSummary "insert" "insert-hash" R.StepUncertain (Just selected) Nothing] + accepted = R.MigrationSummary definition R.InProgress (Just attempt) [create, R.StepSummary "insert" "insert-hash" R.StepAccepted (Just selected) (Just (R.EvidenceSummary L.OperatorAttestation ["fixture/drain"]))] + history = R.HistoryReport key Nothing (R.LedgerInitializedAt identity) (Just position) (R.GuardedObservation access) [] [unresolved] True + problem = L.TransportError L.ResponseInterrupted Nothing Nothing + run = R.RunReport "run-fixture" key access True history [unresolved] [R.SqlObservation reference query (R.QueryRejected L.UncertainSubmission problem)] (Just identity) diff --git a/test/golden/accepted.json b/test/golden/accepted.json new file mode 100644 --- /dev/null +++ b/test/golden/accepted.json @@ -0,0 +1,131 @@ +{ + "schemaVersion": 1, + "command": "status", + "status": "ok", + "result": { + "kind": "status", + "report": { + "observation": { + "target": "test", + "server": null, + "ledger": { + "kind": "initialized", + "ledgerId": "00000000-0000-0000-0000-000000000001" + }, + "position": "chm1:00000000-0000-0000-0000-000000000001:5:00000000-0000-0000-0000-000000000001", + "access": { + "mode": "guarded-observation", + "provider": { + "strategy": "fixture", + "scope": "owned target" + } + }, + "events": [], + "migrations": [ + { + "definition": { + "ordinal": 0, + "componentIndex": 0, + "component": "app", + "dependencies": [], + "migration": "one", + "checksum": "migration-hash", + "steps": [ + { + "name": "create", + "checksum": "create-hash" + }, + { + "name": "insert", + "checksum": "insert-hash" + } + ] + }, + "state": "in-progress", + "attempt": "00000000-0000-0000-0000-000000000001", + "steps": [ + { + "name": "create", + "checksum": "create-hash", + "state": "observed-success", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "create", + "queryId": "query-1" + }, + "evidence": null + }, + { + "name": "insert", + "checksum": "insert-hash", + "state": "uncertain", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "insert", + "queryId": "query-2" + }, + "evidence": null + } + ] + } + ], + "unresolved": true + }, + "migrations": [ + { + "definition": { + "ordinal": 0, + "componentIndex": 0, + "component": "app", + "dependencies": [], + "migration": "one", + "checksum": "migration-hash", + "steps": [ + { + "name": "create", + "checksum": "create-hash" + }, + { + "name": "insert", + "checksum": "insert-hash" + } + ] + }, + "state": "in-progress", + "attempt": "00000000-0000-0000-0000-000000000001", + "steps": [ + { + "name": "create", + "checksum": "create-hash", + "state": "observed-success", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "create", + "queryId": "query-1" + }, + "evidence": null + }, + { + "name": "insert", + "checksum": "insert-hash", + "state": "accepted", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "insert", + "queryId": "query-2" + }, + "evidence": { + "level": "operator-attestation", + "references": [ + "fixture/drain" + ] + } + } + ] + } + ], + "issues": [] + } + }, + "error": null +} diff --git a/test/golden/delayed-ledger.json b/test/golden/delayed-ledger.json new file mode 100644 --- /dev/null +++ b/test/golden/delayed-ledger.json @@ -0,0 +1,171 @@ +{ + "schemaVersion": 1, + "command": "up", + "status": "error", + "result": null, + "error": { + "category": "run", + "primary": { + "code": "ledger-request-failed", + "evidence": "submission-uncertain", + "transport": { + "code": "response-interrupted", + "httpStatus": null, + "serverCode": null + }, + "pendingAppend": "chm-receipt1:74657374:00000000-0000-0000-0000-000000000001:6:00000000-0000-0000-0000-000000000001:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa:append-6" + }, + "secondary": [ + { + "kind": "recording", + "error": { + "code": "outstanding-requests" + } + } + ], + "report": { + "runId": "run-fixture", + "target": "test", + "access": { + "strategy": "fixture", + "scope": "owned target" + }, + "acquired": true, + "history": { + "target": "test", + "server": null, + "ledger": { + "kind": "initialized", + "ledgerId": "00000000-0000-0000-0000-000000000001" + }, + "position": "chm1:00000000-0000-0000-0000-000000000001:5:00000000-0000-0000-0000-000000000001", + "access": { + "mode": "guarded-observation", + "provider": { + "strategy": "fixture", + "scope": "owned target" + } + }, + "events": [], + "migrations": [ + { + "definition": { + "ordinal": 0, + "componentIndex": 0, + "component": "app", + "dependencies": [], + "migration": "one", + "checksum": "migration-hash", + "steps": [ + { + "name": "create", + "checksum": "create-hash" + }, + { + "name": "insert", + "checksum": "insert-hash" + } + ] + }, + "state": "in-progress", + "attempt": "00000000-0000-0000-0000-000000000001", + "steps": [ + { + "name": "create", + "checksum": "create-hash", + "state": "observed-success", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "create", + "queryId": "query-1" + }, + "evidence": null + }, + { + "name": "insert", + "checksum": "insert-hash", + "state": "uncertain", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "insert", + "queryId": "query-2" + }, + "evidence": null + } + ] + } + ], + "unresolved": true + }, + "migrations": [ + { + "definition": { + "ordinal": 0, + "componentIndex": 0, + "component": "app", + "dependencies": [], + "migration": "one", + "checksum": "migration-hash", + "steps": [ + { + "name": "create", + "checksum": "create-hash" + }, + { + "name": "insert", + "checksum": "insert-hash" + } + ] + }, + "state": "in-progress", + "attempt": "00000000-0000-0000-0000-000000000001", + "steps": [ + { + "name": "create", + "checksum": "create-hash", + "state": "observed-success", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "create", + "queryId": "query-1" + }, + "evidence": null + }, + { + "name": "insert", + "checksum": "insert-hash", + "state": "uncertain", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "insert", + "queryId": "query-2" + }, + "evidence": null + } + ] + } + ], + "observations": [ + { + "step": { + "component": "app", + "migration": "one", + "step": "insert", + "migrationChecksum": "migration-hash", + "stepChecksum": "insert-hash" + }, + "queryId": "query-2", + "evidence": { + "outcome": "submission-uncertain", + "transport": { + "code": "response-interrupted", + "httpStatus": null, + "serverCode": null + } + } + } + ], + "initializedLedgerId": "00000000-0000-0000-0000-000000000001" + } + } +} diff --git a/test/golden/malformed.json b/test/golden/malformed.json new file mode 100644 --- /dev/null +++ b/test/golden/malformed.json @@ -0,0 +1,14 @@ +{ + "schemaVersion": 1, + "command": "parse", + "status": "error", + "result": null, + "error": { + "category": "command", + "primary": { + "code": "invalid-arguments" + }, + "secondary": [], + "report": null + } +} diff --git a/test/golden/partial.json b/test/golden/partial.json new file mode 100644 --- /dev/null +++ b/test/golden/partial.json @@ -0,0 +1,176 @@ +{ + "schemaVersion": 1, + "command": "up", + "status": "error", + "result": null, + "error": { + "category": "run", + "primary": { + "code": "sql-failed", + "step": { + "component": "app", + "migration": "one", + "step": "insert", + "migrationChecksum": "migration-hash", + "stepChecksum": "insert-hash" + }, + "queryId": "query-2", + "evidence": "submission-uncertain", + "transport": { + "code": "response-interrupted", + "httpStatus": null, + "serverCode": null + } + }, + "secondary": [ + { + "kind": "access-cleanup", + "code": "access-release-failed" + } + ], + "report": { + "runId": "run-fixture", + "target": "test", + "access": { + "strategy": "fixture", + "scope": "owned target" + }, + "acquired": true, + "history": { + "target": "test", + "server": null, + "ledger": { + "kind": "initialized", + "ledgerId": "00000000-0000-0000-0000-000000000001" + }, + "position": "chm1:00000000-0000-0000-0000-000000000001:5:00000000-0000-0000-0000-000000000001", + "access": { + "mode": "guarded-observation", + "provider": { + "strategy": "fixture", + "scope": "owned target" + } + }, + "events": [], + "migrations": [ + { + "definition": { + "ordinal": 0, + "componentIndex": 0, + "component": "app", + "dependencies": [], + "migration": "one", + "checksum": "migration-hash", + "steps": [ + { + "name": "create", + "checksum": "create-hash" + }, + { + "name": "insert", + "checksum": "insert-hash" + } + ] + }, + "state": "in-progress", + "attempt": "00000000-0000-0000-0000-000000000001", + "steps": [ + { + "name": "create", + "checksum": "create-hash", + "state": "observed-success", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "create", + "queryId": "query-1" + }, + "evidence": null + }, + { + "name": "insert", + "checksum": "insert-hash", + "state": "uncertain", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "insert", + "queryId": "query-2" + }, + "evidence": null + } + ] + } + ], + "unresolved": true + }, + "migrations": [ + { + "definition": { + "ordinal": 0, + "componentIndex": 0, + "component": "app", + "dependencies": [], + "migration": "one", + "checksum": "migration-hash", + "steps": [ + { + "name": "create", + "checksum": "create-hash" + }, + { + "name": "insert", + "checksum": "insert-hash" + } + ] + }, + "state": "in-progress", + "attempt": "00000000-0000-0000-0000-000000000001", + "steps": [ + { + "name": "create", + "checksum": "create-hash", + "state": "observed-success", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "create", + "queryId": "query-1" + }, + "evidence": null + }, + { + "name": "insert", + "checksum": "insert-hash", + "state": "uncertain", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "insert", + "queryId": "query-2" + }, + "evidence": null + } + ] + } + ], + "observations": [ + { + "step": { + "component": "app", + "migration": "one", + "step": "insert", + "migrationChecksum": "migration-hash", + "stepChecksum": "insert-hash" + }, + "queryId": "query-2", + "evidence": { + "outcome": "submission-uncertain", + "transport": { + "code": "response-interrupted", + "httpStatus": null, + "serverCode": null + } + } + } + ], + "initializedLedgerId": "00000000-0000-0000-0000-000000000001" + } + } +} diff --git a/test/golden/recovery-too-large.json b/test/golden/recovery-too-large.json new file mode 100644 --- /dev/null +++ b/test/golden/recovery-too-large.json @@ -0,0 +1,158 @@ +{ + "schemaVersion": 1, + "command": "repair.accept-step", + "status": "error", + "result": null, + "error": { + "category": "run", + "primary": { + "code": "recovery-event-too-large", + "event": "acceptance" + }, + "secondary": [], + "report": { + "runId": "run-fixture", + "target": "test", + "access": { + "strategy": "fixture", + "scope": "owned target" + }, + "acquired": true, + "history": { + "target": "test", + "server": null, + "ledger": { + "kind": "initialized", + "ledgerId": "00000000-0000-0000-0000-000000000001" + }, + "position": "chm1:00000000-0000-0000-0000-000000000001:5:00000000-0000-0000-0000-000000000001", + "access": { + "mode": "guarded-observation", + "provider": { + "strategy": "fixture", + "scope": "owned target" + } + }, + "events": [], + "migrations": [ + { + "definition": { + "ordinal": 0, + "componentIndex": 0, + "component": "app", + "dependencies": [], + "migration": "one", + "checksum": "migration-hash", + "steps": [ + { + "name": "create", + "checksum": "create-hash" + }, + { + "name": "insert", + "checksum": "insert-hash" + } + ] + }, + "state": "in-progress", + "attempt": "00000000-0000-0000-0000-000000000001", + "steps": [ + { + "name": "create", + "checksum": "create-hash", + "state": "observed-success", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "create", + "queryId": "query-1" + }, + "evidence": null + }, + { + "name": "insert", + "checksum": "insert-hash", + "state": "uncertain", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "insert", + "queryId": "query-2" + }, + "evidence": null + } + ] + } + ], + "unresolved": true + }, + "migrations": [ + { + "definition": { + "ordinal": 0, + "componentIndex": 0, + "component": "app", + "dependencies": [], + "migration": "one", + "checksum": "migration-hash", + "steps": [ + { + "name": "create", + "checksum": "create-hash" + }, + { + "name": "insert", + "checksum": "insert-hash" + } + ] + }, + "state": "in-progress", + "attempt": "00000000-0000-0000-0000-000000000001", + "steps": [ + { + "name": "create", + "checksum": "create-hash", + "state": "observed-success", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "create", + "queryId": "query-1" + }, + "evidence": null + }, + { + "name": "insert", + "checksum": "insert-hash", + "state": "uncertain", + "attempt": { + "ownerAttempt": "00000000-0000-0000-0000-000000000001", + "step": "insert", + "queryId": "query-2" + }, + "evidence": null + } + ] + } + ], + "observations": [ + { + "step": { + "component": "app", + "migration": "one", + "step": "insert", + "migrationChecksum": "migration-hash", + "stepChecksum": "insert-hash" + }, + "queryId": "query-2", + "evidence": { + "outcome": "submission-uncertain", + "transport": { + "code": "response-interrupted", + "httpStatus": null, + "serverCode": null + } + } + } + ], + "initializedLedgerId": "00000000-0000-0000-0000-000000000001" + } + } +} diff --git a/test/golden/schedule.json b/test/golden/schedule.json new file mode 100644 --- /dev/null +++ b/test/golden/schedule.json @@ -0,0 +1,67 @@ +{ + "schemaVersion": 1, + "command": "plan", + "status": "ok", + "result": { + "kind": "plan", + "checksumFormat": "sha256-v1", + "completionPolicy": "clickhouse-migrate/local-sync-v1;async_insert=0;mutations_sync=1;alter_sync=1", + "components": [ + { + "index": 0, + "name": "a", + "dependencies": [], + "migrations": [ + { + "ordinal": 0, + "name": "one", + "description": null, + "checksum": "a1-hash", + "steps": [] + }, + { + "ordinal": 2, + "name": "two", + "description": "upgrade", + "checksum": "a2-hash", + "steps": [] + } + ] + }, + { + "index": 1, + "name": "b", + "dependencies": [ + "a" + ], + "migrations": [ + { + "ordinal": 1, + "name": "one", + "description": null, + "checksum": "b1-hash", + "steps": [] + } + ] + } + ], + "schedule": [ + { + "ordinal": 0, + "component": "a", + "migration": "one" + }, + { + "ordinal": 1, + "component": "b", + "migration": "one" + }, + { + "ordinal": 2, + "component": "a", + "migration": "two" + } + ] + }, + "error": null +}