packages feed

pg-migrate-import-hasql-migration (empty) → 1.0.0.0

raw patch · 15 files changed

+1244/−0 lines, 15 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, crypton, hasql, hasql-transaction, optparse-applicative, pg-migrate, pg-migrate-cli, pg-migrate-import-hasql-migration, ram, tasty, tasty-hunit, text, time

Files

+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Changelog++## 1.0.0.0 — 2026-07-10++- Initial stable release of the qualified-table `hasql-migration` adapter with base64-MD5+  verification, SHA-256 evidence, and validator-backed alternative history.
+ pg-migrate-import-hasql-migration.cabal view
@@ -0,0 +1,94 @@+cabal-version:   3.8+name:            pg-migrate-import-hasql-migration+version:         1.0.0.0+synopsis:        Import hasql-migration history into pg-migrate+category:        Database+maintainer:      nadeem@gmail.com+description:+  Reads qualified hasql-migration ledgers with Hasql, verifies legacy+  base64 MD5 evidence, and delegates target writes to pg-migrate.++license:         BSD-3-Clause+build-type:      Simple+extra-doc-files: CHANGELOG.md++common common+  default-language:   GHC2024+  default-extensions:+    DeriveAnyClass+    DuplicateRecordFields+    MultilineStrings+    OverloadedLabels+    OverloadedStrings++  ghc-options:        -Wall -Wcompat++library+  import:          common+  hs-source-dirs:  src+  exposed-modules:+    Database.PostgreSQL.Migrate.History.HasqlMigration+    Database.PostgreSQL.Migrate.History.HasqlMigration.Internal+    PgMigrate.History.HasqlMigration.Prelude++  other-modules:+    Database.PostgreSQL.Migrate.History.HasqlMigration.Import+    Database.PostgreSQL.Migrate.History.HasqlMigration.Ledger+    Database.PostgreSQL.Migrate.History.HasqlMigration.Parser+    Database.PostgreSQL.Migrate.History.HasqlMigration.Types++  build-depends:+    , aeson                 >=2.2  && <2.3+    , base                  >=4.20 && <4.22+    , bytestring            >=0.12 && <0.13+    , containers            >=0.7  && <0.8+    , crypton               >=1.1  && <1.2+    , hasql                 >=1.10 && <1.11+    , optparse-applicative  >=0.19 && <0.20+    , pg-migrate            >=1.0  && <1.1+    , pg-migrate-cli        >=1.0  && <1.1+    , ram                   >=0.20 && <0.23+    , text                  >=2.1  && <2.2+    , time                  >=1.12 && <1.15++test-suite pg-migrate-import-hasql-migration-test+  import:         common+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/unit+  main-is:        Main.hs+  other-modules:+    Test.Definition+    Test.Evidence+    Test.Ledger+    Test.Parser++  build-depends:+    , base                               >=4.20 && <4.22+    , bytestring                         >=0.12 && <0.13+    , containers                         >=0.7  && <0.8+    , optparse-applicative               >=0.19 && <0.20+    , pg-migrate+    , pg-migrate-cli+    , pg-migrate-import-hasql-migration+    , tasty                              >=1.5  && <1.6+    , tasty-hunit                        >=0.10 && <0.11+    , text                               >=2.1  && <2.2+    , time                               >=1.12 && <1.15++test-suite pg-migrate-import-hasql-migration-integration+  import:         common+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/integration+  main-is:        Main.hs+  build-depends:+    , aeson                              >=2.2  && <2.3+    , base                               >=4.20 && <4.22+    , bytestring                         >=0.12 && <0.13+    , containers                         >=0.7  && <0.8+    , hasql                              >=1.10 && <1.11+    , hasql-transaction                  >=1.2  && <1.3+    , pg-migrate+    , pg-migrate-import-hasql-migration+    , tasty                              >=1.5  && <1.6+    , tasty-hunit                        >=0.10 && <0.11+    , text                               >=2.1  && <2.2
+ src/Database/PostgreSQL/Migrate/History/HasqlMigration.hs view
@@ -0,0 +1,24 @@+-- | Hasql-only reader and importer for qualified hasql-migration ledgers. Selected exact+-- payload bytes must reproduce the predecessor's base64 MD5 before evidence is emitted.+module Database.PostgreSQL.Migrate.History.HasqlMigration+  ( QualifiedTable,+    qualifiedTable,+    defaultHasqlMigrationTable,+    HasqlMigrationSourceConfig,+    hasqlMigrationSourceConfig,+    HasqlMigrationRow (..),+    HasqlMigrationHistory (..),+    HasqlMigrationDefinitionError (..),+    HasqlMigrationImportError (..),+    HasqlMigrationImportCommand (..),+    hasqlMigrationEvidenceKey,+    readHasqlMigrationHistory,+    importHasqlMigrationHistory,+    hasqlMigrationImportCommandParser,+  )+where++import Database.PostgreSQL.Migrate.History.HasqlMigration.Import (importHasqlMigrationHistory)+import Database.PostgreSQL.Migrate.History.HasqlMigration.Ledger (readHasqlMigrationHistory)+import Database.PostgreSQL.Migrate.History.HasqlMigration.Parser (hasqlMigrationImportCommandParser)+import Database.PostgreSQL.Migrate.History.HasqlMigration.Types
+ src/Database/PostgreSQL/Migrate/History/HasqlMigration/Import.hs view
@@ -0,0 +1,110 @@+module Database.PostgreSQL.Migrate.History.HasqlMigration.Import+  ( importHasqlMigrationHistory,+    buildHasqlMigrationEvidence,+  )+where++import Data.Aeson qualified as Aeson+import Data.Bifunctor (first)+import Data.Map.Strict qualified as Map+import Data.Text qualified as Text+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate.History.HasqlMigration.Ledger (readHasqlMigrationHistory)+import Database.PostgreSQL.Migrate.History.HasqlMigration.Types+import PgMigrate.History.HasqlMigration.Prelude++-- | Verify source payloads, then atomically import matching target metadata.+importHasqlMigrationHistory ::+  ImportOptions ->+  HasqlMigrationSourceConfig ->+  ConnectionProvider ->+  MigrationPlan ->+  NonEmpty HistoryMapping ->+  IO (Either HasqlMigrationImportError HistoryImportReport)+importHasqlMigrationHistory options config targetProvider plan mappings =+  case validateImportDefinition config plan mappings of+    Left err -> pure (Left err)+    Right () -> do+      loaded <- readHasqlMigrationHistory config+      case loaded of+        Left err -> pure (Left err)+        Right history ->+          case buildHistoryImport config history mappings of+            Left err -> pure (Left err)+            Right historyImportDefinition -> do+              imported <- importMigrationHistory options targetProvider plan historyImportDefinition+              pure (first HasqlMigrationTargetImportFailed imported)++validateImportDefinition ::+  HasqlMigrationSourceConfig ->+  MigrationPlan ->+  NonEmpty HistoryMapping ->+  Either HasqlMigrationImportError ()+validateImportDefinition config@HasqlMigrationSourceConfig {selectedFilenames, stateValidators} plan mappings = do+  placeholder <- placeholderEvidence config selectedFilenames+  case historyImport "hasql-migration" placeholder stateValidators mappings (importReason config) of+    Left err -> Left (HasqlMigrationHistoryDefinitionFailed err)+    Right _ -> Right ()+  first+    (HasqlMigrationTargetImportFailed . HistoryImportValidationFailed)+    (validateHistoryMappingTargets plan mappings)++placeholderEvidence ::+  HasqlMigrationSourceConfig ->+  NonEmpty FilePath ->+  Either HasqlMigrationImportError (Map EvidenceKey ImportEvidence)+placeholderEvidence HasqlMigrationSourceConfig {sourcePayloads} filenames =+  Map.fromList . toList <$> traverse placeholder filenames+  where+    placeholder migrationFilename = do+      key <- first HasqlMigrationDefinitionFailed (hasqlMigrationEvidenceKey migrationFilename)+      evidence <-+        first+          HasqlMigrationHistoryDefinitionFailed+          ( sourceLedgerChecksumVerifiedEvidence+              (Text.pack migrationFilename)+              Nothing+              (Just (migrationFingerprint (sourcePayloads Map.! migrationFilename)))+              Aeson.Null+          )+      Right (key, evidence)++buildHistoryImport ::+  HasqlMigrationSourceConfig ->+  HasqlMigrationHistory ->+  NonEmpty HistoryMapping ->+  Either HasqlMigrationImportError HistoryImport+buildHistoryImport config@HasqlMigrationSourceConfig {stateValidators} history mappings = do+  evidence <- buildHasqlMigrationEvidence config history+  first+    HasqlMigrationHistoryDefinitionFailed+    (historyImport "hasql-migration" evidence stateValidators mappings (importReason config))++buildHasqlMigrationEvidence ::+  HasqlMigrationSourceConfig ->+  HasqlMigrationHistory ->+  Either HasqlMigrationImportError (Map EvidenceKey ImportEvidence)+buildHasqlMigrationEvidence HasqlMigrationSourceConfig {sourcePayloads, sourceTable} HasqlMigrationHistory {selectedRows} =+  Map.fromList . toList <$> traverse rowEvidence selectedRows+  where+    rowEvidence row@HasqlMigrationRow {filename, executedAt} = do+      key <- first HasqlMigrationDefinitionFailed (hasqlMigrationEvidenceKey filename)+      evidence <-+        first+          HasqlMigrationHistoryDefinitionFailed+          ( sourceLedgerChecksumVerifiedEvidence+              (Text.pack filename)+              (Just (LocalTimeWithoutZone executedAt))+              (Just (migrationFingerprint (sourcePayloads Map.! filename)))+              (rowDetails sourceTable row)+          )+      Right (key, evidence)++rowDetails :: QualifiedTable -> HasqlMigrationRow -> Aeson.Value+rowDetails _ HasqlMigrationRow {filename, storedMd5, executedAt} =+  Aeson.object+    [ "adapter" Aeson..= ("hasql-migration" :: Text),+      "filename" Aeson..= filename,+      "storedMd5" Aeson..= storedMd5,+      "executedAt" Aeson..= executedAt+    ]
+ src/Database/PostgreSQL/Migrate/History/HasqlMigration/Internal.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_HADDOCK hide #-}++module Database.PostgreSQL.Migrate.History.HasqlMigration.Internal+  ( buildHasqlMigrationEvidence,+    renderQualifiedTable,+    validateHasqlMigrationRows,+  )+where++import Database.PostgreSQL.Migrate.History.HasqlMigration.Import (buildHasqlMigrationEvidence)+import Database.PostgreSQL.Migrate.History.HasqlMigration.Ledger+  ( renderQualifiedTable,+    validateHasqlMigrationRows,+  )
+ src/Database/PostgreSQL/Migrate/History/HasqlMigration/Ledger.hs view
@@ -0,0 +1,120 @@+module Database.PostgreSQL.Migrate.History.HasqlMigration.Ledger+  ( readHasqlMigrationHistory,+    validateHasqlMigrationRows,+    renderQualifiedTable,+  )+where++import Crypto.Hash (MD5 (..), hashWith)+import Data.Bifunctor (first)+import Data.ByteArray.Encoding (Base (Base64), convertToBase)+import Data.Functor.Contravariant ((>$<))+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Database.PostgreSQL.Migrate.History.HasqlMigration.Types+import Database.PostgreSQL.Migrate.Internal+  ( PostgresIdentifier (..),+    quotePostgresIdentifier,+    useConnectionProvider,+  )+import Hasql.Connection qualified as Connection+import Hasql.Decoders qualified as Decoders+import Hasql.Encoders qualified as Encoders+import Hasql.Session qualified as Session+import Hasql.Statement (Statement)+import Hasql.Statement qualified as Statement+import PgMigrate.History.HasqlMigration.Prelude++-- | Read source rows and reproduce their base64 MD5 without source mutation.+readHasqlMigrationHistory :: HasqlMigrationSourceConfig -> IO (Either HasqlMigrationImportError HasqlMigrationHistory)+readHasqlMigrationHistory config@HasqlMigrationSourceConfig {sourceProvider, sourceTable} = do+  acquired <-+    useConnectionProvider sourceProvider $ \connection -> do+      detected <- runSession connection (Session.statement (qualifiedTableParts sourceTable) detectTableStatement)+      case detected of+        Left err -> pure (Left err)+        Right [] -> pure (Left (HasqlMigrationTableMissing (renderQualifiedTable sourceTable)))+        Right columns+          | columns /= expectedColumns ->+              pure (Left (HasqlMigrationUnsupportedShape (renderQualifiedTable sourceTable) columns))+          | otherwise -> do+              loaded <- runSession connection (Session.statement () (loadRowsStatement sourceTable))+              pure (loaded >>= validateHasqlMigrationRows config)+  pure $ case acquired of+    Left connectionError -> Left (HasqlMigrationConnectionFailed connectionError)+    Right result -> result++expectedColumns :: [Text]+expectedColumns = ["filename", "checksum", "executed_at"]++validateHasqlMigrationRows ::+  HasqlMigrationSourceConfig ->+  [HasqlMigrationRow] ->+  Either HasqlMigrationImportError HasqlMigrationHistory+validateHasqlMigrationRows HasqlMigrationSourceConfig {selectedFilenames, strictSource, sourcePayloads} rows = do+  case firstDuplicate (filename <$> rows) of+    Just duplicate -> Left (HasqlMigrationDuplicateLedgerFilename duplicate)+    Nothing -> pure ()+  selected <- traverse selectRow selectedFilenames+  traverse_ verifyChecksum selected+  let selectedSet = Set.fromList (toList selectedFilenames)+      extras = filter ((`Set.notMember` selectedSet) . filename) rows+  if strictSource && not (null extras)+    then Left (HasqlMigrationStrictSourceHasUnselected (filename <$> extras))+    else Right HasqlMigrationHistory {selectedRows = selected, unselectedRows = extras}+  where+    byFilename = Map.fromList [(filename row, row) | row <- rows]+    selectRow selected =+      maybe (Left (HasqlMigrationSelectedFilenameMissing selected)) Right (Map.lookup selected byFilename)+    verifyChecksum row =+      let actual = legacyMd5 (sourcePayloads Map.! filename row)+       in if storedMd5 row == actual+            then Right ()+            else Left (HasqlMigrationChecksumMismatch (filename row) (storedMd5 row) actual)++legacyMd5 :: ByteString -> Text+legacyMd5 = Text.Encoding.decodeUtf8 . convertToBase Base64 . hashWith MD5++renderQualifiedTable :: QualifiedTable -> Text+renderQualifiedTable QualifiedTable {tableSchema, tableName} =+  quotePostgresIdentifier tableSchema <> "." <> quotePostgresIdentifier tableName++qualifiedTableParts :: QualifiedTable -> (Text, Text)+qualifiedTableParts QualifiedTable {tableSchema = PostgresIdentifier schemaName, tableName = PostgresIdentifier relationName} =+  (schemaName, relationName)++detectTableStatement :: Statement (Text, Text) [Text]+detectTableStatement =+  Statement.preparable+    "SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN pg_catalog.pg_class c ON a.attrelid = c.oid JOIN pg_catalog.pg_namespace n ON c.relnamespace = n.oid WHERE n.nspname = $1 AND c.relname = $2 AND a.attnum >= 1 AND NOT a.attisdropped ORDER BY a.attnum"+    ( (fst >$< Encoders.param (Encoders.nonNullable Encoders.text))+        <> (snd >$< Encoders.param (Encoders.nonNullable Encoders.text))+    )+    (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text)))++loadRowsStatement :: QualifiedTable -> Statement () [HasqlMigrationRow]+loadRowsStatement sourceTable =+  Statement.unpreparable+    ("SELECT filename, checksum, executed_at FROM " <> renderQualifiedTable sourceTable <> " ORDER BY executed_at, filename")+    Encoders.noParams+    (Decoders.rowList rowDecoder)+  where+    rowDecoder =+      HasqlMigrationRow+        <$> (Text.unpack <$> required Decoders.text)+        <*> required Decoders.text+        <*> required Decoders.timestamp+    required = Decoders.column . Decoders.nonNullable++runSession :: Connection.Connection -> Session.Session value -> IO (Either HasqlMigrationImportError value)+runSession connection session = first HasqlMigrationSessionFailed <$> Connection.use connection session++firstDuplicate :: (Ord value) => [value] -> Maybe value+firstDuplicate = go Set.empty+  where+    go _ [] = Nothing+    go seen (value : rest)+      | Set.member value seen = Just value+      | otherwise = go (Set.insert value seen) rest
+ src/Database/PostgreSQL/Migrate/History/HasqlMigration/Parser.hs view
@@ -0,0 +1,32 @@+module Database.PostgreSQL.Migrate.History.HasqlMigration.Parser+  ( hasqlMigrationImportCommandParser,+  )+where++import Data.Text qualified as Text+import Database.PostgreSQL.Migrate (MigrationPlan)+import Database.PostgreSQL.Migrate.CLI (OutputFormat (..))+import Database.PostgreSQL.Migrate.History.HasqlMigration.Types+import Hasql.Connection.Settings qualified as Settings+import Options.Applicative++-- | Build the reusable, target-aware hasql-migration import parser.+hasqlMigrationImportCommandParser :: MigrationPlan -> Parser HasqlMigrationImportCommand+hasqlMigrationImportCommandParser _ =+  HasqlMigrationImportCommand+    <$> parserOptionGroup+      "Connection"+      ( optional+          ( option+              (Settings.connectionString . Text.pack <$> str)+              (long "source-database-url" <> metavar "URL" <> help "hasql-migration source connection string; no environment variable is read")+          )+      )+    <*> option+      (eitherReader (either (Left . show) Right . qualifiedTable . Text.pack))+      (long "source-table" <> metavar "SCHEMA.TABLE" <> value defaultHasqlMigrationTable <> showDefaultWith (const "public.schema_migrations"))+    <*> strOption (long "mapping" <> metavar "PATH" <> help "Checked-in source-to-target mapping artifact")+    <*> strOption (long "source-directory" <> metavar "PATH" <> help "Directory containing exact selected legacy SQL payloads")+    <*> switch (long "strict-source" <> help "Reject every unselected source row")+    <*> switch (long "allow-equivalent" <> help "Opt in to mappings proven by read-only state validators")+    <*> flag TextOutput JsonOutput (long "json" <> help "Emit JSON schema version 1 conventions")
+ src/Database/PostgreSQL/Migrate/History/HasqlMigration/Types.hs view
@@ -0,0 +1,159 @@+module Database.PostgreSQL.Migrate.History.HasqlMigration.Types+  ( QualifiedTable (..),+    HasqlMigrationSourceConfig (..),+    HasqlMigrationRow (..),+    HasqlMigrationHistory (..),+    HasqlMigrationDefinitionError (..),+    HasqlMigrationImportError (..),+    HasqlMigrationImportCommand (..),+    qualifiedTable,+    defaultHasqlMigrationTable,+    hasqlMigrationSourceConfig,+    hasqlMigrationEvidenceKey,+  )+where++import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as Text+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate.CLI (OutputFormat)+import Database.PostgreSQL.Migrate.Internal+  ( PostgresIdentifier,+    postgresIdentifier,+  )+import Hasql.Connection.Settings qualified as Settings+import Hasql.Errors qualified as Errors+import PgMigrate.History.HasqlMigration.Prelude++-- | Validated schema-qualified predecessor ledger table.+data QualifiedTable = QualifiedTable+  { tableSchema :: !PostgresIdentifier,+    tableName :: !PostgresIdentifier+  }+  deriving stock (Generic, Eq, Show)++-- | Validated source settings, table, payload selection, and mapping policy.+data HasqlMigrationSourceConfig = HasqlMigrationSourceConfig+  { sourceProvider :: !ConnectionProvider,+    sourceTable :: !QualifiedTable,+    selectedFilenames :: !(NonEmpty FilePath),+    strictSource :: !Bool,+    sourcePayloads :: !(Map FilePath ByteString),+    stateValidators :: ![StateValidator],+    importReason :: !Text+  }++-- | Normalized immutable hasql-migration row with verified payload bytes.+data HasqlMigrationRow = HasqlMigrationRow+  { filename :: !FilePath,+    storedMd5 :: !Text,+    executedAt :: !LocalTime+  }+  deriving stock (Generic, Eq, Show)++-- | Selected verified rows and any unselected source extras.+data HasqlMigrationHistory = HasqlMigrationHistory+  { selectedRows :: !(NonEmpty HasqlMigrationRow),+    unselectedRows :: ![HasqlMigrationRow]+  }+  deriving stock (Generic, Eq, Show)++-- | Invalid qualified name, mappings, or source configuration.+data HasqlMigrationDefinitionError+  = InvalidQualifiedTable !Text+  | InvalidQualifiedTableIdentifier !Text !PostgresIdentifierError+  | EmptyHasqlMigrationSelection+  | EmptyHasqlMigrationFilename+  | DuplicateHasqlMigrationFilename !FilePath+  | MissingHasqlMigrationPayload !FilePath+  | EmptyHasqlMigrationImportReason+  | HasqlMigrationEvidenceDefinitionError !HistoryDefinitionError+  deriving stock (Generic, Eq, Show)++-- | Structured source-read, checksum, validation, or target-import failure.+data HasqlMigrationImportError+  = HasqlMigrationDefinitionFailed !HasqlMigrationDefinitionError+  | HasqlMigrationConnectionFailed !Errors.ConnectionError+  | HasqlMigrationSessionFailed !Errors.SessionError+  | HasqlMigrationTableMissing !Text+  | HasqlMigrationUnsupportedShape !Text ![Text]+  | HasqlMigrationDuplicateLedgerFilename !FilePath+  | HasqlMigrationSelectedFilenameMissing !FilePath+  | HasqlMigrationStrictSourceHasUnselected ![FilePath]+  | HasqlMigrationChecksumMismatch !FilePath !Text !Text+  | HasqlMigrationHistoryDefinitionFailed !HistoryDefinitionError+  | HasqlMigrationTargetImportFailed !HistoryImportError+  deriving stock (Generic, Show)++-- | Parsed, application-dispatchable hasql-migration import command.+data HasqlMigrationImportCommand = HasqlMigrationImportCommand+  { sourceSettings :: !(Maybe Settings.Settings),+    table :: !QualifiedTable,+    mappingPath :: !FilePath,+    sourceDirectory :: !FilePath,+    strict :: !Bool,+    allowEquivalent :: !Bool,+    outputFormat :: !OutputFormat+  }+  deriving stock (Generic, Eq, Show)++-- | Parse and validate a schema-qualified table name.+qualifiedTable :: Text -> Either HasqlMigrationDefinitionError QualifiedTable+qualifiedTable input =+  case Text.splitOn "." input of+    [schemaInput, tableInput] ->+      QualifiedTable+        <$> validatePart schemaInput+        <*> validatePart tableInput+    _ -> Left (InvalidQualifiedTable input)+  where+    validatePart value =+      case postgresIdentifier value of+        Right identifier -> Right identifier+        Left InvalidLedgerSchema {postgresIdentifierReason} ->+          Left (InvalidQualifiedTableIdentifier value postgresIdentifierReason)+        Left _ -> Left (InvalidQualifiedTable value)++-- | The predecessor's conventional @public.schema_migrations@ table.+defaultHasqlMigrationTable :: QualifiedTable+defaultHasqlMigrationTable = either (error . show) id (qualifiedTable "public.schema_migrations")++-- | Validate a complete hasql-migration source configuration.+hasqlMigrationSourceConfig ::+  ConnectionProvider ->+  QualifiedTable ->+  NonEmpty FilePath ->+  Bool ->+  Map FilePath ByteString ->+  [StateValidator] ->+  Text ->+  Either HasqlMigrationDefinitionError HasqlMigrationSourceConfig+hasqlMigrationSourceConfig sourceProvider sourceTable selectedFilenames strictSource sourcePayloads stateValidators importReason = do+  let filenames = toList selectedFilenames+  case firstDuplicate filenames of+    Just duplicate -> Left (DuplicateHasqlMigrationFilename duplicate)+    Nothing -> pure ()+  if any null filenames then Left EmptyHasqlMigrationFilename else pure ()+  case filter (`Map.notMember` sourcePayloads) filenames of+    missing : _ -> Left (MissingHasqlMigrationPayload missing)+    [] -> pure ()+  if Text.null (Text.strip importReason) then Left EmptyHasqlMigrationImportReason else pure ()+  Right HasqlMigrationSourceConfig {sourceProvider, sourceTable, selectedFilenames, strictSource, sourcePayloads, stateValidators, importReason}++-- | Derive the canonical evidence key for one selected payload file.+hasqlMigrationEvidenceKey :: FilePath -> Either HasqlMigrationDefinitionError EvidenceKey+hasqlMigrationEvidenceKey migrationFilename+  | null migrationFilename = Left EmptyHasqlMigrationFilename+  | otherwise =+      case evidenceKey ("hasql-migration:" <> Text.pack migrationFilename) of+        Left err -> Left (HasqlMigrationEvidenceDefinitionError err)+        Right key -> Right key++firstDuplicate :: (Ord value) => [value] -> Maybe value+firstDuplicate = go Set.empty+  where+    go _ [] = Nothing+    go seen (value : remaining)+      | Set.member value seen = Just value+      | otherwise = go (Set.insert value seen) remaining
+ src/PgMigrate/History/HasqlMigration/Prelude.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_HADDOCK hide #-}++module PgMigrate.History.HasqlMigration.Prelude+  ( module X,+  )+where++import "base" Control.Applicative as X (Alternative (..), optional)+import "base" Data.Foldable as X (toList, traverse_)+import "base" Data.List.NonEmpty as X (NonEmpty (..))+import "base" GHC.Generics as X (Generic)+import "bytestring" Data.ByteString as X (ByteString)+import "containers" Data.Map.Strict as X (Map)+import "text" Data.Text as X (Text)+import "time" Data.Time as X (LocalTime)+import "base" Prelude as X
+ test/integration/Main.hs view
@@ -0,0 +1,383 @@+module Main (main) where++import Control.Exception qualified as Exception+import Data.Aeson qualified as Aeson+import Data.ByteString (ByteString)+import Data.Foldable (toList)+import Data.Int (Int64)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate.History.HasqlMigration+import Hasql.Connection qualified as Connection+import Hasql.Connection.Settings qualified as Settings+import Hasql.Decoders qualified as Decoders+import Hasql.Encoders qualified as Encoders+import Hasql.Session qualified as Session+import Hasql.Statement (Statement)+import Hasql.Statement qualified as Statement+import Hasql.Transaction qualified as Transaction+import System.Environment (lookupEnv)+import Test.Tasty+import Test.Tasty.HUnit++main :: IO ()+main = do+  maybeConnectionString <- lookupEnv "PG_CONNECTION_STRING"+  case maybeConnectionString of+    Nothing -> putStrLn "pg-migrate-import-hasql-migration integration tests skipped: PG_CONNECTION_STRING is not set"+    Just connectionString ->+      defaultMain (tests (Settings.connectionString (Text.pack connectionString)))++tests :: Settings.Settings -> TestTree+tests settings =+  testGroup+    "hasql-migration adapter PostgreSQL"+    [ testCase "qualified custom table reads without source mutation" (testQualifiedRead settings),+      testCase "bad MD5 and duplicate rows reject before target mutation" (testInvalidSource settings),+      testCase "lenient selection reports extras and strict selection rejects" (testStrictSelection settings),+      testCase "direct import preserves local time, skips actions, and is idempotent" (testDirectImport settings),+      testCase "changed source evidence conflicts with an existing import" (testChangedEvidence settings),+      testCase "alternative history requires and runs a read-only domain validator" (testEquivalentHistory settings)+    ]++testQualifiedRead :: Settings.Settings -> Assertion+testQualifiedRead settings =+  withCleanSchemas settings $ do+    runScript settings customFixtureSql+    let config = sourceConfig settings customTable False (directFilename :| []) directPayloads []+    before <- query settings customSourceSnapshotStatement+    history <- readHasqlMigrationHistory config >>= requireAdapterRight+    (filename <$> toList (selectedRows history)) @?= [directFilename]+    afterSnapshot <- query settings customSourceSnapshotStatement+    afterSnapshot @?= before++testInvalidSource :: Settings.Settings -> Assertion+testInvalidSource settings = do+  withCleanSchemas settings $ do+    runScript settings (sourceFixtureSql <> sourceInsert directFilename "wrong" directExecutedAt)+    runDirectImport settings >>= assertAdapterError (\case HasqlMigrationChecksumMismatch name "wrong" _ -> name == directFilename; _ -> False)+    targetExists <- query settings targetSchemaExistsStatement+    targetExists @?= False+  withCleanSchemas settings $ do+    runScript settings (sourceFixtureSql <> sourceInsert directFilename directMd5 directExecutedAt <> sourceInsert directFilename directMd5 directExecutedAt)+    runDirectImport settings >>= assertAdapterError (\case HasqlMigrationDuplicateLedgerFilename name -> name == directFilename; _ -> False)+    targetExists <- query settings targetSchemaExistsStatement+    targetExists @?= False++testStrictSelection :: Settings.Settings -> Assertion+testStrictSelection settings =+  withCleanSchemas settings $ do+    runScript settings (sourceFixtureSql <> sourceInsert directFilename directMd5 directExecutedAt <> sourceInsert "unselected.sql" md5Two "2024-01-02 04:05:06")+    let lenient = sourceConfig settings defaultSourceTable False (directFilename :| []) directPayloads []+        strict = sourceConfig settings defaultSourceTable True (directFilename :| []) directPayloads []+    history <- readHasqlMigrationHistory lenient >>= requireAdapterRight+    (filename <$> unselectedRows history) @?= ["unselected.sql"]+    readHasqlMigrationHistory strict+      >>= assertAdapterError (\case HasqlMigrationStrictSourceHasUnselected ["unselected.sql"] -> True; _ -> False)++testDirectImport :: Settings.Settings -> Assertion+testDirectImport settings =+  withCleanSchemas settings $ do+    runScript settings (sourceFixtureSql <> sourceInsert directFilename directMd5 directExecutedAt)+    before <- query settings sourceSnapshotStatement+    first <- runDirectImport settings >>= requireAdapterRight+    outcomes first @?= [Imported]+    facts <- query settings directTargetFactsStatement+    facts @?= (1, 1, False, True, True)+    second <- runDirectImport settings >>= requireAdapterRight+    outcomes second @?= [AlreadyImported]+    repeatedFacts <- query settings directTargetFactsStatement+    repeatedFacts @?= facts+    afterSnapshot <- query settings sourceSnapshotStatement+    afterSnapshot @?= before++testChangedEvidence :: Settings.Settings -> Assertion+testChangedEvidence settings =+  withCleanSchemas settings $ do+    runScript settings (sourceFixtureSql <> sourceInsert directFilename directMd5 directExecutedAt)+    _ <- runDirectImport settings >>= requireAdapterRight+    runScript settings ("UPDATE hasql_migration_source.schema_migrations SET executed_at = '2024-02-03 04:05:06' WHERE filename = '" <> Text.pack directFilename <> "';")+    runDirectImport settings+      >>= assertAdapterError+        (\case HasqlMigrationTargetImportFailed (HistoryImportConflict identifier) -> identifier == directTargetId; _ -> False)+    counts <- query settings targetCountsStatement+    counts @?= (1, 1)++testEquivalentHistory :: Settings.Settings -> Assertion+testEquivalentHistory settings = do+  withCleanSchemas settings $ do+    runScript settings (sourceFixtureSql <> sourceInsert "legacy-one.sql" md5One directExecutedAt <> sourceInsert "legacy-two.sql" md5Two "2024-01-02 04:05:06" <> "CREATE SCHEMA legacy_domain; CREATE TABLE legacy_domain.ready (id integer);")+    let passingConfig = equivalentSourceConfig settings passingValidator+    rejected <- runEquivalentImport settings directOptions passingConfig+    assertAdapterError+      (\case HasqlMigrationTargetImportFailed (HistoryImportValidationFailed (HistoryEquivalentStateDisallowed _)) -> True; _ -> False)+      rejected+    imported <- runEquivalentImport settings equivalentOptions passingConfig >>= requireAdapterRight+    outcomes imported @?= [Imported]+    facts <- query settings equivalentTargetFactsStatement+    facts @?= (1, 1, False, True)+  withCleanSchemas settings $ do+    runScript settings (sourceFixtureSql <> sourceInsert "legacy-one.sql" md5One directExecutedAt <> sourceInsert "legacy-two.sql" md5Two "2024-01-02 04:05:06")+    result <- runEquivalentImport settings equivalentOptions (equivalentSourceConfig settings failingValidator)+    assertAdapterError+      (\case HasqlMigrationTargetImportFailed (HistoryStateValidationFailed key _) -> key == stateKey; _ -> False)+      result+    counts <- query settings targetCountsIfPresentStatement+    counts @?= (0, 0)++runDirectImport :: Settings.Settings -> IO (Either HasqlMigrationImportError HistoryImportReport)+runDirectImport settings =+  importHasqlMigrationHistory+    directOptions+    (sourceConfig settings defaultSourceTable False (directFilename :| []) directPayloads [])+    (connectionProviderFromSettings settings)+    directPlan+    (directMapping :| [])++runEquivalentImport :: Settings.Settings -> ImportOptions -> HasqlMigrationSourceConfig -> IO (Either HasqlMigrationImportError HistoryImportReport)+runEquivalentImport settings options config =+  importHasqlMigrationHistory options config (connectionProviderFromSettings settings) equivalentPlan (equivalentMapping :| [])++sourceConfig ::+  Settings.Settings ->+  QualifiedTable ->+  Bool ->+  NonEmpty FilePath ->+  Map.Map FilePath ByteString ->+  [StateValidator] ->+  HasqlMigrationSourceConfig+sourceConfig settings table strict filenames payloads validators =+  expectRight+    ( hasqlMigrationSourceConfig+        (connectionProviderFromSettings settings)+        table+        filenames+        strict+        payloads+        validators+        "verified hasql-migration cutover"+    )++equivalentSourceConfig :: Settings.Settings -> StateValidator -> HasqlMigrationSourceConfig+equivalentSourceConfig settings validator =+  sourceConfig+    settings+    defaultSourceTable+    False+    ("legacy-one.sql" :| ["legacy-two.sql"])+    (Map.fromList [("legacy-one.sql", "LEGACY PART ONE"), ("legacy-two.sql", "LEGACY PART TWO")])+    [validator]++passingValidator :: StateValidator+passingValidator =+  stateValidator stateKey $ do+    exists <- Transaction.statement "legacy_domain.ready" regclassStatement+    pure+      ( if exists+          then Right (Aeson.object ["legacy_domain" Aeson..= ("ready" :: Text)])+          else Left (expectRight (stateValidationError "legacy domain is missing"))+      )++failingValidator :: StateValidator+failingValidator =+  stateValidator stateKey (pure (Left (expectRight (stateValidationError "legacy domain is missing"))))++regclassStatement :: Statement Text Bool+regclassStatement =+  Statement.preparable+    "SELECT to_regclass($1) IS NOT NULL"+    (Encoders.param (Encoders.nonNullable Encoders.text))+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool)))++directMapping :: HistoryMapping+directMapping = historyMapping directTargetId (Evidence directKey) (SamePayload directKey)++equivalentMapping :: HistoryMapping+equivalentMapping =+  historyMapping+    equivalentTargetId+    (AllOf (Evidence legacyOneKey :| [Evidence legacyTwoKey, Evidence stateKey]))+    EquivalentState++directKey, legacyOneKey, legacyTwoKey, stateKey :: EvidenceKey+directKey = expectRight (hasqlMigrationEvidenceKey directFilename)+legacyOneKey = expectRight (hasqlMigrationEvidenceKey "legacy-one.sql")+legacyTwoKey = expectRight (hasqlMigrationEvidenceKey "legacy-two.sql")+stateKey = expectRight (evidenceKey "hasql-migration:domain-ready")++directTargetId, equivalentTargetId :: MigrationId+directTargetId = expectRight (migrationId "hasql-target" "0001-direct")+equivalentTargetId = expectRight (migrationId "hasql-equivalent" "0001-domain")++directPlan, equivalentPlan :: MigrationPlan+directPlan = singlePlan "hasql-target" "0001-direct" directPayload+equivalentPlan = singlePlan "hasql-equivalent" "0001-domain" "CREATE TABLE pgmigrate_hasql_target.equivalent_action (id bigint)"++singlePlan :: Text -> Text -> ByteString -> MigrationPlan+singlePlan component migration payload =+  expectRight (migrationPlan (expectRight (migrationComponent component Set.empty (expectRight (sqlMigration migration payload) :| [])) :| []))++directOptions, equivalentOptions :: ImportOptions+directOptions = withImportRunOptions targetRunOptions defaultImportOptions+equivalentOptions = withEquivalentHistory AllowEquivalentHistory directOptions++targetRunOptions :: RunOptions+targetRunOptions = withLedger (expectRight (ledgerConfig targetSchema 0x686173716C746172)) defaultRunOptions++outcomes :: HistoryImportReport -> [HistoryImportOutcome]+outcomes HistoryImportReport {importResults} = importOutcome <$> toList importResults++sourceFixtureSql :: Text+sourceFixtureSql =+  "CREATE SCHEMA hasql_migration_source; CREATE TABLE hasql_migration_source.schema_migrations (filename text NOT NULL, checksum text NOT NULL, executed_at timestamp without time zone NOT NULL);"++customFixtureSql :: Text+customFixtureSql =+  "CREATE SCHEMA \"legacy data\"; CREATE TABLE \"legacy data\".\"migration\"\"history\" (filename text NOT NULL, checksum text NOT NULL, executed_at timestamp without time zone NOT NULL); INSERT INTO \"legacy data\".\"migration\"\"history\" VALUES ('"+    <> Text.pack directFilename+    <> "', '"+    <> directMd5+    <> "', '"+    <> directExecutedAt+    <> "');"++sourceInsert :: FilePath -> Text -> Text -> Text+sourceInsert migrationFilename checksum timestamp =+  "INSERT INTO hasql_migration_source.schema_migrations VALUES ('"+    <> Text.pack migrationFilename+    <> "', '"+    <> checksum+    <> "', '"+    <> timestamp+    <> "');"++sourceSnapshotStatement, customSourceSnapshotStatement :: Statement () (Int64, Text)+sourceSnapshotStatement = snapshotStatement "hasql_migration_source.schema_migrations"+customSourceSnapshotStatement = snapshotStatement "\"legacy data\".\"migration\"\"history\""++snapshotStatement :: Text -> Statement () (Int64, Text)+snapshotStatement source =+  Statement.unpreparable+    ("SELECT count(*), md5(string_agg(filename || checksum || executed_at::text, '' ORDER BY executed_at, filename)) FROM " <> source)+    Encoders.noParams+    (Decoders.singleRow ((,) <$> required Decoders.int8 <*> required Decoders.text))+  where+    required = Decoders.column . Decoders.nonNullable++directTargetFactsStatement :: Statement () (Int64, Int64, Bool, Bool, Bool)+directTargetFactsStatement =+  Statement.unpreparable+    ( Text.unwords+        [ "SELECT (SELECT count(*) FROM " <> targetSchema <> ".migrations), count(*),",+          "to_regclass('" <> targetSchema <> ".should_not_exist') IS NOT NULL,",+          "bool_and(source_evidence #>> '{satisfying_evidence,0,strength}' = 'source-ledger-checksum-verified'),",+          "bool_and(source_evidence #>> '{satisfying_evidence,0,applied_at,kind}' = 'local-without-zone'",+          "AND source_evidence #>> '{satisfying_evidence,0,applied_at,value}' = '2024-01-02 03:04:05')",+          "FROM " <> targetSchema <> ".history_imports"+        ]+    )+    Encoders.noParams+    (Decoders.singleRow ((,,,,) <$> required Decoders.int8 <*> required Decoders.int8 <*> required Decoders.bool <*> required Decoders.bool <*> required Decoders.bool))+  where+    required = Decoders.column . Decoders.nonNullable++equivalentTargetFactsStatement :: Statement () (Int64, Int64, Bool, Bool)+equivalentTargetFactsStatement =+  Statement.unpreparable+    ( Text.unwords+        [ "SELECT (SELECT count(*) FROM " <> targetSchema <> ".migrations), count(*),",+          "to_regclass('" <> targetSchema <> ".equivalent_action') IS NOT NULL,",+          "source_evidence::text LIKE '%state-verified%'",+          "FROM " <> targetSchema <> ".history_imports GROUP BY source_evidence"+        ]+    )+    Encoders.noParams+    (Decoders.singleRow ((,,,) <$> required Decoders.int8 <*> required Decoders.int8 <*> required Decoders.bool <*> required Decoders.bool))+  where+    required = Decoders.column . Decoders.nonNullable++targetCountsStatement :: Statement () (Int64, Int64)+targetCountsStatement =+  Statement.unpreparable+    ("SELECT (SELECT count(*) FROM " <> targetSchema <> ".migrations), (SELECT count(*) FROM " <> targetSchema <> ".history_imports)")+    Encoders.noParams+    (Decoders.singleRow ((,) <$> required Decoders.int8 <*> required Decoders.int8))+  where+    required = Decoders.column . Decoders.nonNullable++targetCountsIfPresentStatement :: Statement () (Int64, Int64)+targetCountsIfPresentStatement = targetCountsStatement++targetSchemaExistsStatement :: Statement () Bool+targetSchemaExistsStatement =+  Statement.preparable+    "SELECT to_regnamespace('pgmigrate_hasql_target') IS NOT NULL"+    Encoders.noParams+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool)))++defaultSourceTable, customTable :: QualifiedTable+defaultSourceTable = expectRight (qualifiedTable "hasql_migration_source.schema_migrations")+customTable = expectRight (qualifiedTable "legacy data.migration\"history")++directPayloads :: Map.Map FilePath ByteString+directPayloads = Map.fromList [(directFilename, directPayload), ("unselected.sql", "SELECT 2")]++directFilename :: FilePath+directFilename = "0001-direct.sql"++directPayload :: ByteString+directPayload = "CREATE TABLE pgmigrate_hasql_target.should_not_exist (id bigint)"++directMd5, md5One, md5Two, directExecutedAt :: Text+directMd5 = "h2PAgWYnAN32+RvJkHfzhQ=="+md5One = "Q+RyEgfRb5LTu12mraufdA=="+md5Two = "Gy3qSDLT6v7pC10e6tEwNA=="+directExecutedAt = "2024-01-02 03:04:05"++targetSchema :: Text+targetSchema = "pgmigrate_hasql_target"++withCleanSchemas :: Settings.Settings -> IO value -> IO value+withCleanSchemas settings = Exception.bracket_ cleanup cleanup+  where+    cleanup = runScript settings cleanupSql++cleanupSql :: Text+cleanupSql =+  Text.unwords+    [ "DROP SCHEMA IF EXISTS hasql_migration_source CASCADE;",+      "DROP SCHEMA IF EXISTS \"legacy data\" CASCADE;",+      "DROP SCHEMA IF EXISTS legacy_domain CASCADE;",+      "DROP SCHEMA IF EXISTS " <> targetSchema <> " CASCADE;"+    ]++runScript :: Settings.Settings -> Text -> IO ()+runScript settings sql = withConnection settings (\connection -> useSession connection (Session.script sql))++query :: Settings.Settings -> Statement () value -> IO value+query settings statement = withConnection settings (\connection -> useSession connection (Session.statement () statement))++withConnection :: Settings.Settings -> (Connection.Connection -> IO value) -> IO value+withConnection settings = Exception.bracket acquire Connection.release+  where+    acquire = Connection.acquire settings >>= either (assertFailure . ("could not acquire integration connection: " <>) . show) pure++useSession :: Connection.Connection -> Session.Session value -> IO value+useSession connection session = Connection.use connection session >>= either (assertFailure . ("integration session failed: " <>) . show) pure++requireAdapterRight :: Either HasqlMigrationImportError value -> IO value+requireAdapterRight = either (assertFailure . show) pure++assertAdapterError :: (HasqlMigrationImportError -> Bool) -> Either HasqlMigrationImportError value -> Assertion+assertAdapterError matches result =+  case result of+    Left err | matches err -> pure ()+    Left err -> assertFailure ("unexpected adapter error: " <> show err)+    Right _ -> assertFailure "expected adapter error, received Right"++expectRight :: (Show error) => Either error value -> value+expectRight = either (error . show) id
+ test/unit/Main.hs view
@@ -0,0 +1,10 @@+module Main (main) where++import Test.Definition qualified as Definition+import Test.Evidence qualified as Evidence+import Test.Ledger qualified as Ledger+import Test.Parser qualified as Parser+import Test.Tasty++main :: IO ()+main = defaultMain (testGroup "pg-migrate-import-hasql-migration" [Definition.tests, Evidence.tests, Ledger.tests, Parser.tests])
+ test/unit/Test/Definition.hs view
@@ -0,0 +1,58 @@+module Test.Definition (tests) where++import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate.History.HasqlMigration+import Database.PostgreSQL.Migrate.History.HasqlMigration.Internal+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+  testGroup+    "definition"+    [ testCase "qualified tables require exactly two safe identifiers" testQualifiedTable,+      testCase "qualified tables quote both identifiers" testQuoting,+      testCase "source selections require unique names and exact payloads" testSourceConfig,+      testCase "evidence keys are explicit and stable" testEvidenceKey+    ]++testQualifiedTable :: Assertion+testQualifiedTable = do+  assertLeft (qualifiedTable "schema_migrations")+  assertLeft (qualifiedTable "a.b.c")+  assertLeft (qualifiedTable ".table")+  assertLeft (qualifiedTable "schema.")+  qualifiedTable "public.schema_migrations" @?= Right defaultHasqlMigrationTable++testQuoting :: Assertion+testQuoting =+  renderQualifiedTable (expectRight (qualifiedTable "legacy data.migration\"history"))+    @?= "\"legacy data\".\"migration\"\"history\""++testSourceConfig :: Assertion+testSourceConfig = do+  assertLeft (hasqlMigrationSourceConfig unusedProvider defaultHasqlMigrationTable ("one.sql" :| ["one.sql"]) False payloads [] "reason")+  assertLeft (hasqlMigrationSourceConfig unusedProvider defaultHasqlMigrationTable ("missing.sql" :| []) False payloads [] "reason")+  case hasqlMigrationSourceConfig unusedProvider defaultHasqlMigrationTable ("one.sql" :| []) False payloads [] "reason" of+    Right _ -> pure ()+    Left err -> assertFailure (show err)++testEvidenceKey :: Assertion+testEvidenceKey = do+  expectRight (hasqlMigrationEvidenceKey "one.sql") @?= expectRight (evidenceKey "hasql-migration:one.sql")+  assertLeft (hasqlMigrationEvidenceKey "")++payloads :: Map.Map FilePath ByteString+payloads = Map.singleton "one.sql" "SELECT 1"++unusedProvider :: ConnectionProvider+unusedProvider = connectionProvider (\_ -> error "connection provider must not be used")++assertLeft :: Either error value -> Assertion+assertLeft = either (const (pure ())) (const (assertFailure "expected Left, received Right"))++expectRight :: (Show error) => Either error value -> value+expectRight = either (error . show) id
+ test/unit/Test/Evidence.hs view
@@ -0,0 +1,63 @@+module Test.Evidence (tests) where++import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate.History.HasqlMigration+import Database.PostgreSQL.Migrate.History.HasqlMigration.Internal+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+  testGroup+    "evidence"+    [ testCase "verified ledger evidence carries exact source SHA-256" testEvidence,+      testCase "unknown targets fail before connection acquisition" testTargetPreflight+    ]++testEvidence :: Assertion+testEvidence =+  case buildHasqlMigrationEvidence config history of+    Left err -> assertFailure (show err)+    Right evidence -> Map.size evidence @?= 1++testTargetPreflight :: Assertion+testTargetPreflight = do+  let key = expectRight (hasqlMigrationEvidenceKey "one.sql")+      unknown = expectRight (migrationId "target" "missing")+      mapping = historyMapping unknown (Evidence key) (SamePayload key)+  result <- importHasqlMigrationHistory defaultImportOptions config unusedProvider targetPlan (mapping :| [])+  case result of+    Left (HasqlMigrationTargetImportFailed (HistoryImportValidationFailed (HistoryTargetUnknown actual))) -> actual @?= unknown+    other -> assertFailure ("expected preflight failure, received: " <> show other)++config :: HasqlMigrationSourceConfig+config =+  expectRight+    ( hasqlMigrationSourceConfig+        unusedProvider+        defaultHasqlMigrationTable+        ("one.sql" :| [])+        False+        (Map.singleton "one.sql" "SELECT 1")+        []+        "fixture import"+    )++history :: HasqlMigrationHistory+history = HasqlMigrationHistory (HasqlMigrationRow "one.sql" "sWmOUqDxYgNIlFQZagxjBw==" (read "2024-01-02 03:04:05") :| []) []++targetPlan :: MigrationPlan+targetPlan =+  expectRight+    ( migrationPlan+        (expectRight (migrationComponent "target" Set.empty (expectRight (sqlMigration "0001" "SELECT 1") :| [])) :| [])+    )++unusedProvider :: ConnectionProvider+unusedProvider = connectionProvider (\_ -> error "connection provider must not be used")++expectRight :: (Show error) => Either error value -> value+expectRight = either (error . show) id
+ test/unit/Test/Ledger.hs view
@@ -0,0 +1,99 @@+module Test.Ledger (tests) where++import Data.ByteString (ByteString)+import Data.Foldable (toList)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Time (LocalTime)+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate.History.HasqlMigration+import Database.PostgreSQL.Migrate.History.HasqlMigration.Internal+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+  testGroup+    "ledger model"+    [ testCase "valid legacy MD5 is accepted in selected order" testValid,+      testCase "invalid legacy MD5 reports both encodings" testMismatch,+      testCase "duplicate ledger filenames are rejected" testDuplicate,+      testCase "lenient selection reports extras and strict selection rejects" testStrict,+      testCase "missing selected filenames are distinct" testMissing+    ]++testValid :: Assertion+testValid =+  case validateHasqlMigrationRows (config False ("two.sql" :| ["one.sql"])) [rowOne, rowTwo] of+    Right history -> do+      (filename <$> toList (selectedRows history)) @?= ["two.sql", "one.sql"]+      unselectedRows history @?= []+    Left err -> assertFailure (show err)++testMismatch :: Assertion+testMismatch =+  case validateHasqlMigrationRows (config False ("one.sql" :| [])) [rowOne {storedMd5 = "wrong"}] of+    Left (HasqlMigrationChecksumMismatch "one.sql" "wrong" actual) -> actual @?= md5One+    other -> assertFailure ("unexpected mismatch result: " <> show other)++testDuplicate :: Assertion+testDuplicate =+  assertError+    (\case HasqlMigrationDuplicateLedgerFilename "one.sql" -> True; _ -> False)+    (validateHasqlMigrationRows (config False ("one.sql" :| [])) [rowOne, rowOne])++testStrict :: Assertion+testStrict = do+  case validateHasqlMigrationRows (config False ("one.sql" :| [])) [rowOne, rowTwo] of+    Right history -> (filename <$> unselectedRows history) @?= ["two.sql"]+    Left err -> assertFailure (show err)+  assertError+    (\case HasqlMigrationStrictSourceHasUnselected ["two.sql"] -> True; _ -> False)+    (validateHasqlMigrationRows (config True ("one.sql" :| [])) [rowOne, rowTwo])++testMissing :: Assertion+testMissing =+  assertError+    (\case HasqlMigrationSelectedFilenameMissing "two.sql" -> True; _ -> False)+    (validateHasqlMigrationRows (config False ("two.sql" :| [])) [rowOne])++config :: Bool -> NonEmpty FilePath -> HasqlMigrationSourceConfig+config strict filenames =+  expectRight+    ( hasqlMigrationSourceConfig+        unusedProvider+        defaultHasqlMigrationTable+        filenames+        strict+        payloads+        []+        "fixture import"+    )++rowOne, rowTwo :: HasqlMigrationRow+rowOne = HasqlMigrationRow "one.sql" md5One timestamp+rowTwo = HasqlMigrationRow "two.sql" md5Two timestamp++md5One, md5Two :: Text+md5One = "sWmOUqDxYgNIlFQZagxjBw=="+md5Two = "/Bx6C9zjErILw3gN1tQaqg=="++payloads :: Map.Map FilePath ByteString+payloads = Map.fromList [("one.sql", "SELECT 1"), ("two.sql", "SELECT 2")]++timestamp :: LocalTime+timestamp = read "2024-01-02 03:04:05"++unusedProvider :: ConnectionProvider+unusedProvider = connectionProvider (\_ -> error "connection provider must not be used")++assertError :: (HasqlMigrationImportError -> Bool) -> Either HasqlMigrationImportError value -> Assertion+assertError matches result =+  case result of+    Left err | matches err -> pure ()+    Left err -> assertFailure ("unexpected error: " <> show err)+    Right _ -> assertFailure "expected error, received Right"++expectRight :: (Show error) => Either error value -> value+expectRight = either (error . show) id
+ test/unit/Test/Parser.hs view
@@ -0,0 +1,55 @@+module Test.Parser (tests) where++import Data.ByteString.Char8 qualified as ByteString+import Data.List.NonEmpty (NonEmpty (..))+import Data.Set qualified as Set+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate.CLI (OutputFormat (JsonOutput))+import Database.PostgreSQL.Migrate.History.HasqlMigration+import Options.Applicative+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+  testGroup+    "parser"+    [ testCase "parser records explicit artifacts without reading them" testCommand,+      testCase "invalid qualified tables fail in the parser" testInvalidTable+    ]++testCommand :: Assertion+testCommand =+  case parseSuccess ["--source-table", "legacy.history", "--mapping", "mapping.json", "--source-directory", "migrations", "--strict-source", "--allow-equivalent", "--json"] of+    HasqlMigrationImportCommand {mappingPath, sourceDirectory, strict, allowEquivalent, outputFormat} -> do+      mappingPath @?= "mapping.json"+      sourceDirectory @?= "migrations"+      strict @?= True+      allowEquivalent @?= True+      outputFormat @?= JsonOutput++testInvalidTable :: Assertion+testInvalidTable =+  case execParserPure defaultPrefs commandInfo ["--source-table", "missing-dot", "--mapping", "map.json", "--source-directory", "migrations"] of+    Failure _ -> pure ()+    result -> assertFailure ("expected parser failure, received: " <> show result)++parseSuccess :: [String] -> HasqlMigrationImportCommand+parseSuccess arguments =+  case execParserPure defaultPrefs commandInfo arguments of+    Success parsedCommand -> parsedCommand+    Failure failure -> error (fst (renderFailure failure "hasql-migration-import"))+    CompletionInvoked _ -> error "unexpected completion"++commandInfo :: ParserInfo HasqlMigrationImportCommand+commandInfo = info (hasqlMigrationImportCommandParser fixturePlan <**> helper) fullDesc++fixturePlan :: MigrationPlan+fixturePlan =+  expectRight+    ( migrationPlan+        (expectRight (migrationComponent "target" Set.empty (expectRight (sqlMigration "0001" (ByteString.pack "SELECT 1")) :| [])) :| [])+    )++expectRight :: (Show error) => Either error value -> value+expectRight = either (error . show) id