clickhouse-migrate-cli (empty) → 0.1.0.0
raw patch · 18 files changed
+1747/−0 lines, 18 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, clickhouse-migrate, clickhouse-migrate-cli, containers, optparse-applicative, text
Files
- CHANGELOG.md +18/−0
- LICENSE +25/−0
- README.md +20/−0
- clickhouse-migrate-cli.cabal +67/−0
- src/ClickHouseMigrate/CLI.hs +18/−0
- src/ClickHouseMigrate/CLI/AdoptionFile.hs +124/−0
- src/ClickHouseMigrate/CLI/Handler.hs +148/−0
- src/ClickHouseMigrate/CLI/Parser.hs +131/−0
- src/ClickHouseMigrate/CLI/Render/Json.hs +242/−0
- src/ClickHouseMigrate/CLI/Render/Text.hs +48/−0
- src/ClickHouseMigrate/CLI/Types.hs +89/−0
- test/Main.hs +100/−0
- test/golden/accepted.json +131/−0
- test/golden/delayed-ledger.json +171/−0
- test/golden/malformed.json +14/−0
- test/golden/partial.json +176/−0
- test/golden/recovery-too-large.json +158/−0
- test/golden/schedule.json +67/−0
+ CHANGELOG.md view
@@ -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.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ clickhouse-migrate-cli.cabal view
@@ -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
+ src/ClickHouseMigrate/CLI.hs view
@@ -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
+ src/ClickHouseMigrate/CLI/AdoptionFile.hs view
@@ -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
+ src/ClickHouseMigrate/CLI/Handler.hs view
@@ -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)
+ src/ClickHouseMigrate/CLI/Parser.hs view
@@ -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
+ src/ClickHouseMigrate/CLI/Render/Json.hs view
@@ -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"
+ src/ClickHouseMigrate/CLI/Render/Text.hs view
@@ -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)"
+ src/ClickHouseMigrate/CLI/Types.hs view
@@ -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)
+ test/Main.hs view
@@ -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)
+ test/golden/accepted.json view
@@ -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+}
+ test/golden/delayed-ledger.json view
@@ -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"+ }+ }+}
+ test/golden/malformed.json view
@@ -0,0 +1,14 @@+{+ "schemaVersion": 1,+ "command": "parse",+ "status": "error",+ "result": null,+ "error": {+ "category": "command",+ "primary": {+ "code": "invalid-arguments"+ },+ "secondary": [],+ "report": null+ }+}
+ test/golden/partial.json view
@@ -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"+ }+ }+}
+ test/golden/recovery-too-large.json view
@@ -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"+ }+ }+}
+ test/golden/schedule.json view
@@ -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+}