pg-migrate-embed (empty) → 1.0.0.0

raw patch · 34 files changed

+1187/−0 lines, 34 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, directory, filepath, pg-migrate, pg-migrate-embed, process, tasty, tasty-hunit, template-haskell, text, time, unix

Files

• CHANGELOG.md +6/−0
• pg-migrate-embed.cabal +105/−0
• src/Database/PostgreSQL/Migrate/Embed.hs +26/−0
• src/Database/PostgreSQL/Migrate/Embed/Authoring.hs +264/−0
• src/Database/PostgreSQL/Migrate/Embed/Internal.hs +8/−0
• src/Database/PostgreSQL/Migrate/Embed/Manifest.hs +183/−0
• test/fixtures/absolute/manifest +1/−0
• test/fixtures/blank/0001-first.sql +1/−0
• test/fixtures/blank/0002-second.sql +1/−0
• test/fixtures/blank/manifest +3/−0
• test/fixtures/comment/0001-first.sql +1/−0
• test/fixtures/comment/manifest +2/−0
• test/fixtures/duplicate/0001-first.sql +1/−0
• test/fixtures/duplicate/manifest +2/−0
• test/fixtures/missing/manifest +1/−0
• test/fixtures/nested/manifest +1/−0
• test/fixtures/non-sql/README.txt +1/−0
• test/fixtures/non-sql/manifest +1/−0
• test/fixtures/parent/manifest +1/−0
• test/fixtures/unlisted/0001-listed.sql +1/−0
• test/fixtures/unlisted/0002-unlisted.sql +1/−0
• test/fixtures/unlisted/manifest +1/−0
• test/fixtures/valid/migrations/0001-first.sql +1/−0
• test/fixtures/valid/migrations/0002-second.sql +1/−0
• test/fixtures/valid/migrations/manifest +2/−0
• test/recompilation/Main.hs +180/−0
• test/recompilation/fixture/app/Main.hs +21/−0
• test/recompilation/fixture/migrations/0001-first.sql +1/−0
• test/recompilation/fixture/migrations/manifest +1/−0
• test/recompilation/fixture/recompilation-probe.cabal +19/−0
• test/unit/Main.hs +17/−0
• test/unit/Test/Authoring.hs +126/−0
• test/unit/Test/Component.hs +97/−0
• test/unit/Test/Manifest.hs +109/−0

@@ -0,0 +1,6 @@+# Changelog++## 1.0.0.0 — 2026-07-10++- Initial stable release of manifest format v1, exact-byte Template Haskell embedding,+  validation, and crash-conservative migration authoring.

@@ -0,0 +1,105 @@+cabal-version:   3.8+name:            pg-migrate-embed+version:         1.0.0.0+synopsis:        Compile-time ordered SQL manifests for pg-migrate+category:        Database+maintainer:      nadeem@gmail.com+description:+  Checks ordered migration manifests, embeds their exact SQL bytes, and provides+  crash-conservative migration authoring helpers.++license:         BSD-3-Clause+build-type:      Simple+extra-doc-files: CHANGELOG.md+data-files:+  test/fixtures/absolute/manifest+  test/fixtures/blank/*.sql+  test/fixtures/blank/manifest+  test/fixtures/comment/*.sql+  test/fixtures/comment/manifest+  test/fixtures/duplicate/*.sql+  test/fixtures/duplicate/manifest+  test/fixtures/missing/manifest+  test/fixtures/nested/manifest+  test/fixtures/non-sql/*.txt+  test/fixtures/non-sql/manifest+  test/fixtures/parent/manifest+  test/fixtures/unlisted/*.sql+  test/fixtures/unlisted/manifest+  test/fixtures/valid/migrations/*.sql+  test/fixtures/valid/migrations/manifest+  test/recompilation/fixture/*.cabal+  test/recompilation/fixture/app/*.hs+  test/recompilation/fixture/migrations/*.sql+  test/recompilation/fixture/migrations/manifest++common common+  default-language:   GHC2024+  default-extensions:+    DeriveAnyClass+    DuplicateRecordFields+    MultilineStrings+    OverloadedLabels+    OverloadedStrings++  ghc-options:        -Wall -Wcompat++library+  import:             common+  default-extensions: TemplateHaskell+  hs-source-dirs:     src+  exposed-modules:+    Database.PostgreSQL.Migrate.Embed+    Database.PostgreSQL.Migrate.Embed.Internal++  other-modules:+    Database.PostgreSQL.Migrate.Embed.Authoring+    Database.PostgreSQL.Migrate.Embed.Manifest++  build-depends:+    , base              >=4.20 && <4.22+    , bytestring        >=0.12 && <0.13+    , directory         >=1.3  && <1.4+    , filepath          >=1.5  && <1.6+    , pg-migrate        >=1.0  && <1.1+    , template-haskell  >=2.22 && <2.24+    , text              >=2.1  && <2.2+    , unix              >=2.8  && <2.9++test-suite pg-migrate-embed-test+  import:          common+  type:            exitcode-stdio-1.0+  hs-source-dirs:  test/unit+  main-is:         Main.hs+  other-modules:+    Paths_pg_migrate_embed+    Test.Authoring+    Test.Component+    Test.Manifest++  autogen-modules: Paths_pg_migrate_embed+  build-depends:+    , base              >=4.20 && <4.22+    , bytestring        >=0.12 && <0.13+    , containers        >=0.7  && <0.8+    , directory         >=1.3  && <1.4+    , filepath          >=1.5  && <1.6+    , pg-migrate+    , pg-migrate-embed+    , tasty             >=1.5  && <1.6+    , tasty-hunit       >=0.10 && <0.11+    , text              >=2.1  && <2.2++test-suite pg-migrate-embed-recompilation+  import:          common+  type:            exitcode-stdio-1.0+  hs-source-dirs:  test/recompilation+  main-is:         Main.hs+  other-modules:   Paths_pg_migrate_embed+  autogen-modules: Paths_pg_migrate_embed+  build-depends:+    , base       >=4.20 && <4.22+    , directory  >=1.3  && <1.4+    , filepath   >=1.5  && <1.6+    , process    >=1.6  && <1.7+    , time       >=1.12 && <1.15

@@ -0,0 +1,26 @@+-- | Manifest format v1 validation, exact-byte Template Haskell embedding, and exclusive+-- migration authoring helpers.+module Database.PostgreSQL.Migrate.Embed+  ( manifestFormatVersion,+    ManifestError (..),+    checkMigrationManifest,+    embedMigrationManifest,+    NewMigrationOptions,+    AuthoringError (..),+    newMigrationOptions,+    newMigration,+  )+where++import Database.PostgreSQL.Migrate.Embed.Authoring+  ( AuthoringError (..),+    NewMigrationOptions,+    newMigration,+    newMigrationOptions,+  )+import Database.PostgreSQL.Migrate.Embed.Manifest+  ( ManifestError (..),+    checkMigrationManifest,+    embedMigrationManifest,+    manifestFormatVersion,+  )

@@ -0,0 +1,264 @@+module Database.PostgreSQL.Migrate.Embed.Authoring+  ( NewMigrationOptions,+    AuthoringError (..),+    newMigrationOptions,+    newMigration,+    newMigrationWithRename,+  )+where++import Control.Exception (IOException)+import Control.Exception qualified as Exception+import Data.ByteString qualified as ByteString+import Data.Char qualified as Char+import Data.List qualified as List+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Database.PostgreSQL.Migrate.Embed.Manifest+  ( ManifestError,+    checkMigrationManifest,+    validateManifestEntry,+  )+import System.Directory qualified as Directory+import System.FilePath qualified as FilePath+import System.IO (Handle)+import System.IO qualified as IO+import System.IO.Error qualified as IO.Error+import System.Posix.IO qualified as Posix++-- | Validated exclusive-create settings for one new migration file.+data NewMigrationOptions = NewMigrationOptions+  { manifestPath :: !FilePath,+    explicitName :: !(Maybe FilePath),+    initialSql :: !ByteString.ByteString+  }+  deriving stock (Eq, Show)++-- | Structured option, filesystem, or manifest replacement failure.+data AuthoringError+  = InvalidAuthoringManifestPath !FilePath+  | InvalidNewMigrationName !ManifestError+  | AuthoringManifestError !ManifestError+  | ExplicitMigrationNameRequired+  | MigrationSequenceExhausted !Int+  | MigrationFileAlreadyExists !FilePath+  | AuthoringIoError !FilePath !Text.Text+  | AuthoringCleanupError !FilePath !Text.Text+  deriving stock (Eq, Show)++-- | Validate manifest path and optional explicit migration name.+newMigrationOptions ::+  FilePath ->+  Maybe FilePath ->+  ByteString.ByteString ->+  Either AuthoringError NewMigrationOptions+newMigrationOptions manifestPath requestedName initialSql+  | null manifestPath = Left (InvalidAuthoringManifestPath manifestPath)+  | FilePath.hasTrailingPathSeparator manifestPath =+      Left (InvalidAuthoringManifestPath manifestPath)+  | otherwise = do+      explicitName <- traverse normalizeExplicitName requestedName+      Right NewMigrationOptions {manifestPath, explicitName, initialSql}++-- | Exclusively create a SQL file and atomically append its manifest entry.+newMigration :: NewMigrationOptions -> IO (Either AuthoringError FilePath)+newMigration = newMigrationWithRename Directory.renameFile++newMigrationWithRename ::+  (FilePath -> FilePath -> IO ()) ->+  NewMigrationOptions ->+  IO (Either AuthoringError FilePath)+newMigrationWithRename renameFile options@NewMigrationOptions {manifestPath} = do+  manifestResult <- checkMigrationManifest manifestPath+  case firstLeft AuthoringManifestError manifestResult of+    Left err -> pure (Left err)+    Right entries ->+      case chooseMigrationName options (fst <$> entries) of+        Left err -> pure (Left err)+        Right entry -> createAndAppend renameFile options entry++normalizeExplicitName :: FilePath -> Either AuthoringError FilePath+normalizeExplicitName requestedName =+  firstLeft InvalidNewMigrationName (validateManifestEntry normalizedName)+  where+    normalizedName =+      case FilePath.takeExtension requestedName of+        "" -> requestedName <> ".sql"+        _ -> requestedName++chooseMigrationName ::+  NewMigrationOptions ->+  NonEmpty FilePath ->+  Either AuthoringError FilePath+chooseMigrationName NewMigrationOptions {explicitName = Just entry} _ = Right entry+chooseMigrationName NewMigrationOptions {explicitName = Nothing} entries =+  automaticMigrationName entries++automaticMigrationName :: NonEmpty FilePath -> Either AuthoringError FilePath+automaticMigrationName entries =+  case traverse numericPrefix entries of+    Nothing -> Left ExplicitMigrationNameRequired+    Just prefixes ->+      let width = fst (NonEmpty.head prefixes)+       in if all ((== width) . fst) prefixes+            then renderNextMigrationName width (maximum (snd <$> prefixes) + 1)+            else Left ExplicitMigrationNameRequired++renderNextMigrationName :: Int -> Integer -> Either AuthoringError FilePath+renderNextMigrationName width next =+  let rendered = show next+   in if length rendered > width+        then Left (MigrationSequenceExhausted width)+        else+          firstLeft+            InvalidNewMigrationName+            (validateManifestEntry (replicate (width - length rendered) '0' <> rendered <> ".sql"))++numericPrefix :: FilePath -> Maybe (Int, Integer)+numericPrefix entry = do+  let basename = FilePath.dropExtension entry+      (digits, suffix) = span Char.isDigit basename+  guardMaybe $ case digits of+    '0' : _ : _ -> True+    _ -> False+  guardMaybe (null suffix || "-" `List.isPrefixOf` suffix)+  value <- readInteger digits+  pure (length digits, value)++readInteger :: String -> Maybe Integer+readInteger value =+  case reads value of+    [(parsed, "")] -> Just parsed+    _ -> Nothing++guardMaybe :: Bool -> Maybe ()+guardMaybe condition+  | condition = Just ()+  | otherwise = Nothing++createAndAppend ::+  (FilePath -> FilePath -> IO ()) ->+  NewMigrationOptions ->+  FilePath ->+  IO (Either AuthoringError FilePath)+createAndAppend renameFile NewMigrationOptions {manifestPath, initialSql} entry = do+  originalResult <- tryIOException (ByteString.readFile manifestPath)+  case originalResult of+    Left err -> pure (Left (authoringIoError manifestPath err))+    Right originalManifest -> do+      let migrationPath = FilePath.takeDirectory manifestPath FilePath.</> entry+      creationResult <- createExclusive migrationPath initialSql+      case creationResult of+        Left err -> pure (Left err)+        Right () -> do+          replacementResult <-+            replaceManifest renameFile manifestPath (appendEntry originalManifest entry)+          case replacementResult of+            Right () -> pure (Right migrationPath)+            Left replacementError -> do+              cleanupResult <- tryIOException (Directory.removeFile migrationPath)+              pure $ case cleanupResult of+                Left cleanupError -> Left (cleanupIoError migrationPath cleanupError)+                Right () -> Left replacementError++createExclusive :: FilePath -> ByteString.ByteString -> IO (Either AuthoringError ())+createExclusive path contents = do+  openResult <-+    tryIOException+      ( Posix.openFd+          path+          Posix.WriteOnly+          Posix.defaultFileFlags+            { Posix.exclusive = True,+              Posix.creat = Just 0o644+            }+      )+  case openResult of+    Left err+      | IO.Error.isAlreadyExistsError err ->+          pure (Left (MigrationFileAlreadyExists path))+      | otherwise -> pure (Left (authoringIoError path err))+    Right fileDescriptor -> do+      handleResult <- tryIOException (Posix.fdToHandle fileDescriptor)+      case handleResult of+        Left err -> do+          ignoreIOException (Posix.closeFd fileDescriptor)+          cleanupCreatedFile path (authoringIoError path err)+        Right handle -> do+          writeResult <-+            tryIOException+              (ByteString.hPut handle contents >> IO.hFlush handle >> IO.hClose handle)+          case writeResult of+            Right () -> pure (Right ())+            Left err -> do+              ignoreIOException (IO.hClose handle)+              cleanupCreatedFile path (authoringIoError path err)++cleanupCreatedFile :: FilePath -> AuthoringError -> IO (Either AuthoringError ())+cleanupCreatedFile path originalError = do+  cleanupResult <- tryIOException (Directory.removeFile path)+  pure $ case cleanupResult of+    Left err -> Left (cleanupIoError path err)+    Right () -> Left originalError++replaceManifest ::+  (FilePath -> FilePath -> IO ()) ->+  FilePath ->+  ByteString.ByteString ->+  IO (Either AuthoringError ())+replaceManifest renameFile manifestPath contents = do+  let directory = FilePath.takeDirectory manifestPath+      temporaryTemplate = FilePath.takeFileName manifestPath <> ".tmp"+  temporaryResult <-+    tryIOException (IO.openBinaryTempFileWithDefaultPermissions directory temporaryTemplate)+  case temporaryResult of+    Left err -> pure (Left (authoringIoError manifestPath err))+    Right (temporaryPath, handle) -> do+      replacementResult <-+        tryIOException+          ( ByteString.hPut handle contents+              >> IO.hFlush handle+              >> IO.hClose handle+              >> renameFile temporaryPath manifestPath+          )+      case replacementResult of+        Right () -> pure (Right ())+        Left err -> do+          cleanupTemporaryFile handle temporaryPath+          pure (Left (authoringIoError manifestPath err))++cleanupTemporaryFile :: Handle -> FilePath -> IO ()+cleanupTemporaryFile handle path = do+  ignoreIOException (IO.hClose handle)+  ignoreIOException (Directory.removeFile path)++appendEntry :: ByteString.ByteString -> FilePath -> ByteString.ByteString+appendEntry original entry =+  original+    <> separator+    <> Text.Encoding.encodeUtf8 (Text.pack entry)+    <> "\n"+  where+    separator+      | ByteString.null original = ByteString.empty+      | ByteString.last original == 0x0A = ByteString.empty+      | otherwise = "\n"++authoringIoError :: FilePath -> IOException -> AuthoringError+authoringIoError path err = AuthoringIoError path (Text.pack (show err))++cleanupIoError :: FilePath -> IOException -> AuthoringError+cleanupIoError path err = AuthoringCleanupError path (Text.pack (show err))++tryIOException :: IO value -> IO (Either IOException value)+tryIOException = Exception.try++ignoreIOException :: IO value -> IO ()+ignoreIOException action = do+  _ <- tryIOException action+  pure ()++firstLeft :: (error -> mappedError) -> Either error value -> Either mappedError value+firstLeft mapError = either (Left . mapError) Right

@@ -0,0 +1,8 @@+{-# OPTIONS_HADDOCK hide #-}++module Database.PostgreSQL.Migrate.Embed.Internal+  ( newMigrationWithRename,+  )+where++import Database.PostgreSQL.Migrate.Embed.Authoring (newMigrationWithRename)

@@ -0,0 +1,183 @@+module Database.PostgreSQL.Migrate.Embed.Manifest+  ( manifestFormatVersion,+    ManifestError (..),+    checkMigrationManifest,+    embedMigrationManifest,+    validateManifestEntry,+  )+where++import Control.Exception (IOException)+import Control.Exception qualified as Exception+import Data.Bifunctor (first)+import Data.ByteString qualified as ByteString+import Data.Foldable (toList, traverse_)+import Data.List qualified as List+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Language.Haskell.TH+  ( Exp (..),+    Lit (..),+    Q,+  )+import Language.Haskell.TH.Syntax qualified as TH.Syntax+import System.Directory qualified as Directory+import System.FilePath qualified as FilePath++-- | Supported ordered-manifest contract version.+manifestFormatVersion :: Int+manifestFormatVersion = 1++-- | Exact manifest syntax, path, membership, or SQL validation failure.+data ManifestError+  = ManifestIoError !FilePath !Text.Text+  | ManifestInvalidUtf8 !FilePath !Text.Text+  | EmptyManifest+  | BlankManifestLine !Int+  | CommentManifestLine !Int+  | ManifestEntryHasSurroundingWhitespace !Int !FilePath+  | AbsoluteManifestEntry !Int !FilePath+  | ParentTraversalManifestEntry !Int !FilePath+  | NestedManifestEntry !Int !FilePath+  | NonSqlManifestEntry !Int !FilePath+  | EmptySqlBasename !Int+  | DuplicateManifestEntry !FilePath !Int !Int+  | MissingManifestFile !FilePath+  | UnlistedSqlFiles ![FilePath]+  deriving stock (Eq, Show)++-- | Validate a manifest and return ordered exact SQL bytes at runtime.+checkMigrationManifest ::+  FilePath ->+  IO (Either ManifestError (NonEmpty (FilePath, ByteString.ByteString)))+checkMigrationManifest manifestPath = do+  manifestResult <- tryIOException (ByteString.readFile manifestPath)+  case manifestResult of+    Left err -> pure (Left (ManifestIoError manifestPath (Text.pack (show err))))+    Right manifestBytes ->+      case parseManifest manifestPath manifestBytes of+        Left err -> pure (Left err)+        Right entries -> checkManifestFiles manifestPath entries++-- | Validate and embed an ordered migration manifest at compile time.+embedMigrationManifest :: FilePath -> Q Exp+embedMigrationManifest inputPath = do+  manifestPath <- TH.Syntax.makeRelativeToProject inputPath+  TH.Syntax.addDependentFile manifestPath+  result <- TH.Syntax.runIO (checkMigrationManifest manifestPath)+  case result of+    Left err -> fail ("invalid pg-migrate manifest: " <> show err)+    Right entries -> do+      let directory = FilePath.takeDirectory manifestPath+      traverse_+        (TH.Syntax.addDependentFile . (directory FilePath.</>) . fst)+        entries+      pure (nonEmptyExpression entries)++parseManifest :: FilePath -> ByteString.ByteString -> Either ManifestError (NonEmpty FilePath)+parseManifest manifestPath manifestBytes = do+  manifestText <-+    first+      (ManifestInvalidUtf8 manifestPath . Text.pack . show)+      (Text.Encoding.decodeUtf8' manifestBytes)+  let numberedLines = zip [1 ..] (normalizeLineEnding <$> Text.lines manifestText)+  entries <- traverse validateManifestLine numberedLines+  nonEmptyEntries <-+    case entries of+      firstEntry : remainingEntries -> Right (firstEntry :| remainingEntries)+      [] -> Left EmptyManifest+  validateDuplicates nonEmptyEntries++normalizeLineEnding :: Text.Text -> Text.Text+normalizeLineEnding = Text.dropWhileEnd (== '\r')++validateManifestLine :: (Int, Text.Text) -> Either ManifestError FilePath+validateManifestLine (lineNumber, entryText)+  | Text.null entryText = Left (BlankManifestLine lineNumber)+  | "#" `Text.isPrefixOf` Text.stripStart entryText =+      Left (CommentManifestLine lineNumber)+  | "--" `Text.isPrefixOf` Text.stripStart entryText =+      Left (CommentManifestLine lineNumber)+  | Text.strip entryText /= entryText =+      Left (ManifestEntryHasSurroundingWhitespace lineNumber entry)+  | FilePath.isAbsolute entry = Left (AbsoluteManifestEntry lineNumber entry)+  | ".." `elem` FilePath.splitDirectories entry =+      Left (ParentTraversalManifestEntry lineNumber entry)+  | FilePath.takeFileName entry /= entry = Left (NestedManifestEntry lineNumber entry)+  | FilePath.takeExtension entry /= ".sql" = Left (NonSqlManifestEntry lineNumber entry)+  | null (FilePath.dropExtension entry) = Left (EmptySqlBasename lineNumber)+  | otherwise = Right entry+  where+    entry = Text.unpack entryText++validateManifestEntry :: FilePath -> Either ManifestError FilePath+validateManifestEntry entry = validateManifestLine (1, Text.pack entry)++validateDuplicates :: NonEmpty FilePath -> Either ManifestError (NonEmpty FilePath)+validateDuplicates entries = go [] (zip [1 ..] (toList entries))+  where+    go _ [] = Right entries+    go seen ((lineNumber, entry) : remaining) =+      case List.lookup entry seen of+        Just firstLine -> Left (DuplicateManifestEntry entry firstLine lineNumber)+        Nothing -> go ((entry, lineNumber) : seen) remaining++checkManifestFiles ::+  FilePath ->+  NonEmpty FilePath ->+  IO (Either ManifestError (NonEmpty (FilePath, ByteString.ByteString)))+checkManifestFiles manifestPath entries = do+  let directory = FilePath.takeDirectory manifestPath+      listedEntries = toList entries+  directoryResult <- tryIOException (Directory.listDirectory directory)+  case directoryResult of+    Left err -> pure (Left (ManifestIoError directory (Text.pack (show err))))+    Right directoryEntries ->+      case List.sort+        [ entry+        | entry <- directoryEntries,+          FilePath.takeExtension entry == ".sql",+          entry `notElem` listedEntries+        ] of+        unlisted@(_ : _) -> pure (Left (UnlistedSqlFiles unlisted))+        [] -> readManifestFiles directory entries++readManifestFiles ::+  FilePath ->+  NonEmpty FilePath ->+  IO (Either ManifestError (NonEmpty (FilePath, ByteString.ByteString)))+readManifestFiles directory entries = do+  results <- traverse readEntry entries+  pure (sequence results)+  where+    readEntry entry = do+      let path = directory FilePath.</> entry+      exists <- Directory.doesFileExist path+      if not exists+        then pure (Left (MissingManifestFile entry))+        else do+          result <- tryIOException (ByteString.readFile path)+          pure $ case result of+            Left err -> Left (ManifestIoError path (Text.pack (show err)))+            Right bytes -> Right (entry, bytes)++nonEmptyExpression :: NonEmpty (FilePath, ByteString.ByteString) -> Exp+nonEmptyExpression (firstEntry :| remainingEntries) =+  AppE+    (AppE (ConE '(:|)) (entryExpression firstEntry))+    (ListE (entryExpression <$> remainingEntries))++entryExpression :: (FilePath, ByteString.ByteString) -> Exp+entryExpression (entry, bytes) =+  TupE+    [ Just (LitE (StringL entry)),+      Just+        ( AppE+            (VarE 'ByteString.pack)+            (ListE (LitE . IntegerL . fromIntegral <$> ByteString.unpack bytes))+        )+    ]++tryIOException :: IO value -> IO (Either IOException value)+tryIOException = Exception.try

@@ -0,0 +1,1 @@+/tmp/outside.sql

@@ -0,0 +1,1 @@+SELECT 1;

@@ -0,0 +1,1 @@+SELECT 2;

@@ -0,0 +1,3 @@+0001-first.sql++0002-second.sql

@@ -0,0 +1,1 @@+SELECT 1;

@@ -0,0 +1,2 @@+0001-first.sql+# comments are not part of the v1 format

@@ -0,0 +1,1 @@+SELECT 1;

@@ -0,0 +1,2 @@+0001-first.sql+0001-first.sql

@@ -0,0 +1,1 @@+0001-missing.sql

@@ -0,0 +1,1 @@+nested/0001-first.sql

@@ -0,0 +1,1 @@+This is not a SQL migration.

@@ -0,0 +1,1 @@+README.txt

@@ -0,0 +1,1 @@+../outside.sql

@@ -0,0 +1,1 @@+SELECT 1;

@@ -0,0 +1,1 @@+SELECT 2;

@@ -0,0 +1,1 @@+0001-listed.sql

@@ -0,0 +1,1 @@+SELECT 'first';

@@ -0,0 +1,1 @@+SELECT 'second';

@@ -0,0 +1,2 @@+0002-second.sql+0001-first.sql

@@ -0,0 +1,180 @@+module Main (main) where++import Control.Exception qualified as Exception+import Control.Monad (filterM, unless, when)+import Data.List (isPrefixOf)+import Data.Time.Clock qualified as Time+import Paths_pg_migrate_embed qualified as Paths+import System.Directory qualified as Directory+import System.Exit (ExitCode (..))+import System.FilePath qualified as FilePath+import System.IO qualified as IO+import System.Process qualified as Process++main :: IO ()+main = do+  fixtureCabal <-+    Paths.getDataFileName "test/recompilation/fixture/recompilation-probe.cabal"+  let fixtureSource = FilePath.normalise (FilePath.takeDirectory fixtureCabal)+      packageRoot =+        FilePath.normalise+          ( FilePath.takeDirectory+              (FilePath.takeDirectory (FilePath.takeDirectory fixtureSource))+          )+      repositoryRoot = FilePath.takeDirectory packageRoot+  corePackageRoot <- resolvePackageRoot repositoryRoot "pg-migrate" "pg-migrate.cabal"+  assertFileExists (packageRoot FilePath.</> "pg-migrate-embed.cabal")+  withTemporaryDirectory $ \workspace -> do+    copyDirectory fixtureSource workspace+    writeProjectFile corePackageRoot packageRoot workspace+    prepareProbe workspace+    moduleTimestamp <- Directory.getModificationTime (workspace FilePath.</> "app/Main.hs")++    initialOutput <- runProbe workspace+    writeTrackedFile (workspace FilePath.</> "migrations/0001-first.sql") "SELECT 2;\n"+    sqlChangedOutput <- runProbe workspace+    when (sqlChangedOutput == initialOutput) $+      fail "changing a tracked SQL file did not change the embedded checksums"++    writeFile (workspace FilePath.</> "migrations/0002-second.sql") "SELECT 3;\n"+    writeTrackedFile+      (workspace FilePath.</> "migrations/manifest")+      "0001-first.sql\n0002-second.sql\n"+    manifestChangedOutput <- runProbe workspace+    when (manifestChangedOutput == sqlChangedOutput) $+      fail "changing the manifest did not change the embedded checksums"+    unless (length (lines manifestChangedOutput) == 2) $+      fail "the rebuilt probe did not embed both manifest entries"++    finalModuleTimestamp <- Directory.getModificationTime (workspace FilePath.</> "app/Main.hs")+    unless (finalModuleTimestamp == moduleTimestamp) $+      fail "the recompilation test unexpectedly touched the Haskell module"++runProbe :: FilePath -> IO String+runProbe workspace = do+  _ <-+    runChecked+      workspace+      "cabal"+      [ "exec",+        "--builddir=dist-recompilation",+        "--",+        "ghc",+        "--make",+        "app/Main.hs",+        "-o",+        "ghc-recompilation/probe",+        "-odir",+        "ghc-recompilation",+        "-hidir",+        "ghc-recompilation",+        "-package",+        "pg-migrate",+        "-package",+        "pg-migrate-embed",+        "-XGHC2024",+        "-XOverloadedStrings",+        "-XTemplateHaskell"+      ]+  runChecked workspace (workspace FilePath.</> "ghc-recompilation/probe") []++prepareProbe :: FilePath -> IO ()+prepareProbe workspace = do+  Directory.createDirectory (workspace FilePath.</> "ghc-recompilation")+  _ <-+    runChecked+      workspace+      "cabal"+      [ "build",+        "pg-migrate",+        "pg-migrate-embed",+        "--builddir=dist-recompilation"+      ]+  pure ()++runChecked :: FilePath -> FilePath -> [String] -> IO String+runChecked workspace executable arguments = do+  let command =+        (Process.proc executable arguments)+          { Process.cwd = Just workspace+          }+  (exitCode, standardOutput, standardError) <-+    Process.readCreateProcessWithExitCode command ""+  case exitCode of+    ExitSuccess -> pure standardOutput+    ExitFailure code ->+      fail+        ( executable+            <> " failed with exit code "+            <> show code+            <> ":\n"+            <> standardError+        )++writeTrackedFile :: FilePath -> String -> IO ()+writeTrackedFile path contents = do+  writeFile path contents+  now <- Time.getCurrentTime+  Directory.setModificationTime path (Time.addUTCTime 2 now)++writeProjectFile :: FilePath -> FilePath -> FilePath -> IO ()+writeProjectFile corePackageRoot embedPackageRoot workspace =+  writeFile+    (workspace FilePath.</> "cabal.project")+    ( unlines+        [ "packages:",+          "  .",+          "  " <> corePackageRoot,+          "  " <> embedPackageRoot,+          "tests: False",+          "benchmarks: False"+        ]+    )++resolvePackageRoot :: FilePath -> FilePath -> FilePath -> IO FilePath+resolvePackageRoot parent packageName cabalFile = do+  let exact = parent FilePath.</> packageName+  exactExists <- Directory.doesFileExist (exact FilePath.</> cabalFile)+  if exactExists+    then pure exact+    else do+      entries <- Directory.listDirectory parent+      let candidates =+            [ parent FilePath.</> entry+            | entry <- entries,+              (packageName <> "-") `isPrefixOf` entry+            ]+      matching <- filterM (Directory.doesFileExist . (FilePath.</> cabalFile)) candidates+      case matching of+        [resolved] -> pure resolved+        _ -> fail ("could not resolve source distribution for " <> packageName)++copyDirectory :: FilePath -> FilePath -> IO ()+copyDirectory source destination = do+  Directory.createDirectoryIfMissing True destination+  entries <- Directory.listDirectory source+  mapM_ copyEntry entries+  where+    copyEntry entry = do+      let sourcePath = source FilePath.</> entry+          destinationPath = destination FilePath.</> entry+      isDirectory <- Directory.doesDirectoryExist sourcePath+      if isDirectory+        then copyDirectory sourcePath destinationPath+        else Directory.copyFile sourcePath destinationPath++withTemporaryDirectory :: (FilePath -> IO value) -> IO value+withTemporaryDirectory = Exception.bracket create Directory.removePathForcibly+  where+    create = do+      parent <- Directory.getTemporaryDirectory+      (path, handle) <- IO.openTempFile parent "pg-migrate-recompilation"+      IO.hClose handle+      Directory.removeFile path+      Directory.createDirectory path+      pure path++assertFileExists :: FilePath -> IO ()+assertFileExists path = do+  exists <- Directory.doesFileExist path+  unless exists (fail ("required source file does not exist: " <> path))

@@ -0,0 +1,21 @@+module Main (main) where++import Data.ByteString (ByteString)+import Data.Foldable (traverse_)+import Data.List.NonEmpty (NonEmpty)+import Database.PostgreSQL.Migrate qualified as Migrate+import Database.PostgreSQL.Migrate.Embed (embedMigrationManifest)+import Database.PostgreSQL.Migrate.Internal qualified as Internal++main :: IO ()+main = traverse_ printChecksum embeddedMigrations+  where+    printChecksum =+      print+        . Internal.migrationChecksumBytes+        . Migrate.migrationFingerprint+        . snd++embeddedMigrations :: NonEmpty (FilePath, ByteString)+embeddedMigrations =+  $(embedMigrationManifest "migrations/manifest")

@@ -0,0 +1,1 @@+SELECT 1;

@@ -0,0 +1,1 @@+0001-first.sql

@@ -0,0 +1,19 @@+cabal-version: 3.8+name:          pg-migrate-embed-recompilation-probe+version:       0.1.0.0+build-type:    Simple++executable recompilation-probe+  default-language:   GHC2024+  default-extensions:+    OverloadedStrings+    TemplateHaskell++  ghc-options:        -Wall -threaded+  hs-source-dirs:     app+  main-is:            Main.hs+  build-depends:+    , base              >=4.20 && <4.22+    , bytestring        >=0.12 && <0.13+    , pg-migrate+    , pg-migrate-embed

@@ -0,0 +1,17 @@+module Main (main) where++import Test.Authoring qualified as Authoring+import Test.Component qualified as Component+import Test.Manifest qualified as Manifest+import Test.Tasty (defaultMain, testGroup)++main :: IO ()+main =+  defaultMain+    ( testGroup+        "pg-migrate-embed"+        [ Manifest.tests,+          Component.tests,+          Authoring.tests+        ]+    )

@@ -0,0 +1,126 @@+module Test.Authoring (tests) where++import Control.Exception qualified as Exception+import Data.ByteString qualified as ByteString+import Data.ByteString.Char8 qualified as ByteString.Char8+import Data.Foldable (traverse_)+import Data.List qualified as List+import Database.PostgreSQL.Migrate.Embed+import Database.PostgreSQL.Migrate.Embed.Internal (newMigrationWithRename)+import System.Directory qualified as Directory+import System.FilePath qualified as FilePath+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "authoring"+    [ testCase "numeric manifests create and append the next sequence" $+        withWorkspace "next" numericFiles $ \manifestPath -> do+          options <- assertRight (newMigrationOptions manifestPath Nothing "SELECT 3;\n")+          result <- newMigration options+          let expectedPath = FilePath.takeDirectory manifestPath FilePath.</> "0003.sql"+          result @?= Right expectedPath+          actualSql <- ByteString.readFile expectedPath+          actualSql @?= "SELECT 3;\n"+          actualManifest <- ByteString.readFile manifestPath+          actualManifest @?= "0001-first.sql\n0002-second.sql\n0003.sql\n",+      testCase "explicit names work when the existing sequence is irregular" $+        withWorkspace "explicit" [("first.sql", "SELECT 1;\n")] $ \manifestPath -> do+          automatic <- assertRight (newMigrationOptions manifestPath Nothing "SELECT 2;\n")+          automaticResult <- newMigration automatic+          automaticResult @?= Left ExplicitMigrationNameRequired+          explicit <- assertRight (newMigrationOptions manifestPath (Just "second") "SELECT 2;\n")+          result <- newMigration explicit+          result+            @?= Right (FilePath.takeDirectory manifestPath FilePath.</> "second.sql"),+      testCase "automatic names require a zero-padded numeric sequence" $+        withWorkspace "not-zero-padded" [("1001-first.sql", "SELECT 1;\n")] $ \manifestPath -> do+          options <- assertRight (newMigrationOptions manifestPath Nothing "SELECT 2;\n")+          result <- newMigration options+          result @?= Left ExplicitMigrationNameRequired,+      testCase "exclusive creation refuses an existing migration" $+        withWorkspace "collision" [("0001-first.sql", "SELECT 1;\n")] $ \manifestPath -> do+          originalManifest <- ByteString.readFile manifestPath+          options <-+            assertRight+              (newMigrationOptions manifestPath (Just "0001-first") "replacement")+          result <- newMigration options+          result+            @?= Left+              ( MigrationFileAlreadyExists+                  (FilePath.takeDirectory manifestPath FilePath.</> "0001-first.sql")+              )+          actualManifest <- ByteString.readFile manifestPath+          actualManifest @?= originalManifest+          existingSql <-+            ByteString.readFile+              (FilePath.takeDirectory manifestPath FilePath.</> "0001-first.sql")+          existingSql @?= "SELECT 1;\n",+      testCase "failed manifest replacement removes only the newly created file" $+        withWorkspace "replacement-failure" [("0001-first.sql", "SELECT 1;\n")] $ \manifestPath -> do+          originalManifest <- ByteString.readFile manifestPath+          options <- assertRight (newMigrationOptions manifestPath Nothing "SELECT 2;\n")+          result <- newMigrationWithRename failingRename options+          case result of+            Left (AuthoringIoError actualPath _) -> actualPath @?= manifestPath+            Left actual -> assertFailure ("expected AuthoringIoError, received " <> show actual)+            Right path -> assertFailure ("expected replacement failure, created " <> path)+          actualManifest <- ByteString.readFile manifestPath+          actualManifest @?= originalManifest+          createdFileExists <-+            Directory.doesPathExist+              (FilePath.takeDirectory manifestPath FilePath.</> "0002.sql")+          createdFileExists @?= False+          directoryEntries <- List.sort <$> Directory.listDirectory (FilePath.takeDirectory manifestPath)+          directoryEntries @?= ["0001-first.sql", "manifest"],+      testCase "option construction rejects nested explicit names" $+        case newMigrationOptions "migrations/manifest" (Just "../outside") "SELECT 1" of+          Left (InvalidNewMigrationName (ParentTraversalManifestEntry 1 "../outside.sql")) -> pure ()+          actual -> assertFailure ("expected parent traversal failure, received " <> show actual),+      testCase "option construction rejects a directory as the manifest path" $+        newMigrationOptions "migrations/" Nothing "SELECT 1"+          @?= Left (InvalidAuthoringManifestPath "migrations/")+    ]++numericFiles :: [(FilePath, ByteString.ByteString)]+numericFiles =+  [ ("0001-first.sql", "SELECT 1;\n"),+    ("0002-second.sql", "SELECT 2;\n")+  ]++withWorkspace ::+  String ->+  [(FilePath, ByteString.ByteString)] ->+  (FilePath -> IO value) ->+  IO value+withWorkspace label files action =+  Exception.bracket create remove action+  where+    create = do+      temporaryDirectory <- Directory.getTemporaryDirectory+      let directory = temporaryDirectory FilePath.</> ("pg-migrate-authoring-" <> label)+          manifestPath = directory FilePath.</> "manifest"+      Directory.removePathForcibly directory `Exception.catch` ignoreMissing+      Directory.createDirectory directory+      traverse_+        (\(entry, contents) -> ByteString.writeFile (directory FilePath.</> entry) contents)+        files+      ByteString.writeFile manifestPath (manifestBytes files)+      pure manifestPath+    remove manifestPath = Directory.removePathForcibly (FilePath.takeDirectory manifestPath)+    ignoreMissing :: IOError -> IO ()+    ignoreMissing _ = pure ()++manifestBytes :: [(FilePath, ByteString.ByteString)] -> ByteString.ByteString+manifestBytes files =+  ByteString.concat [ByteString.Char8.pack entry <> "\n" | (entry, _) <- files]++failingRename :: FilePath -> FilePath -> IO ()+failingRename _ _ = ioError (userError "simulated manifest replacement failure")++assertRight :: (Show error) => Either error value -> IO value+assertRight = \case+  Left err -> assertFailure ("expected Right, received Left " <> show err)+  Right value -> pure value

@@ -0,0 +1,97 @@+module Test.Component (tests) where++import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Set qualified as Set+import Data.Text (Text)+import Database.PostgreSQL.Migrate qualified as Migrate+import Database.PostgreSQL.Migrate.Embed (checkMigrationManifest)+import Database.PostgreSQL.Migrate.Internal qualified as Internal+import Paths_pg_migrate_embed qualified as Paths+import System.FilePath ((</>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "embedded component"+    [ testCase "manifest order and suffix-derived names are authoritative" $ do+        entries <- validEntries+        component <-+          assertRight+            ( Migrate.migrationComponentFromEmbeddedSql+                "example-component"+                Set.empty+                entries+            )+        plan <- assertRight (Migrate.migrationPlan (component :| []))+        let descriptions = migrationDescriptions (Internal.planDescription plan)+        fmap Internal.migrationId descriptions+          @?= ( assertMigrationId "example-component" "0002-second"+                  :| [assertMigrationId "example-component" "0001-first"]+              ),+      testCase "each embedded file retains its own derived transaction mode" $ do+        component <-+          assertRight+            ( Migrate.migrationComponentFromEmbeddedSql+                "example-component"+                Set.empty+                ( ("0001-transactional.sql", "SELECT 1")+                    :| [ ( "0002-nontransactional.sql",+                           "-- pg-migrate: no-transaction\nCREATE INDEX CONCURRENTLY example_idx ON example (id)"+                         )+                       ]+                )+            )+        plan <- assertRight (Migrate.migrationPlan (component :| []))+        fmap Internal.transactionMode (migrationDescriptions (Internal.planDescription plan))+          @?= (Internal.Transactional :| [Internal.NonTransactional]),+      testCase "invalid SQL keeps its structured definition error" $+        assertDefinitionLeft+          (Migrate.InvalidSql (Migrate.ProhibitedTransactionCommand "BEGIN"))+          ( Migrate.migrationComponentFromEmbeddedSql+              "example-component"+              Set.empty+              (("0001-invalid.sql", "BEGIN") :| [])+          ),+      testCase "manual entries must have the SQL suffix" $+        assertDefinitionLeft+          (Migrate.InvalidEmbeddedMigrationFile "0001-invalid.txt")+          ( Migrate.migrationComponentFromEmbeddedSql+              "example-component"+              Set.empty+              (("0001-invalid.txt", "SELECT 1") :| [])+          )+    ]++validEntries :: IO (NonEmpty (FilePath, ByteString))+validEntries = do+  manifestPath <- Paths.getDataFileName ("test/fixtures" </> "valid/migrations/manifest")+  result <- checkMigrationManifest manifestPath+  case result of+    Left err -> assertFailure ("expected valid fixture, received Left " <> show err)+    Right entries -> pure entries++migrationDescriptions :: Internal.PlanDescription -> NonEmpty Internal.MigrationDescription+migrationDescriptions (Internal.PlanDescription (component :| [])) = Internal.migrations component+migrationDescriptions _ = error "expected one component"++assertMigrationId :: Text -> Text -> Migrate.MigrationId+assertMigrationId component name =+  case Migrate.migrationId component name of+    Left err -> error (show err)+    Right value -> value++assertRight :: (Show error) => Either error value -> IO value+assertRight = \case+  Left err -> assertFailure ("expected Right, received Left " <> show err)+  Right value -> pure value++assertDefinitionLeft ::+  Migrate.DefinitionError ->+  Either Migrate.DefinitionError value ->+  IO ()+assertDefinitionLeft expected = \case+  Left actual -> actual @?= expected+  Right _ -> assertFailure ("expected Left " <> show expected <> ", received Right")

@@ -0,0 +1,109 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.Manifest (tests) where++import Control.Exception qualified as Exception+import Data.ByteString qualified as ByteString+import Data.List.NonEmpty (NonEmpty (..))+import Database.PostgreSQL.Migrate.Embed+import Paths_pg_migrate_embed qualified as Paths+import System.Directory qualified as Directory+import System.FilePath ((</>))+import System.FilePath qualified as FilePath+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "manifest"+    [ testCase "the supported format version is one" (manifestFormatVersion @?= 1),+      testCase "valid entries and exact bytes follow manifest order" $ do+        result <- checkMigrationManifest =<< fixture "valid/migrations/manifest"+        result @?= Right validEmbedded,+      testCase "blank lines are rejected" $+        checkError "blank/manifest" (BlankManifestLine 2),+      testCase "comment lines are rejected" $+        checkError "comment/manifest" (CommentManifestLine 2),+      testCase "duplicates identify both lines" $+        checkError+          "duplicate/manifest"+          (DuplicateManifestEntry "0001-first.sql" 1 2),+      testCase "absolute paths are rejected" $+        checkError+          "absolute/manifest"+          (AbsoluteManifestEntry 1 "/tmp/outside.sql"),+      testCase "parent traversal is rejected" $+        checkError+          "parent/manifest"+          (ParentTraversalManifestEntry 1 "../outside.sql"),+      testCase "nested paths are rejected" $+        checkError+          "nested/manifest"+          (NestedManifestEntry 1 "nested/0001-first.sql"),+      testCase "non-SQL entries are rejected" $+        checkError+          "non-sql/manifest"+          (NonSqlManifestEntry 1 "README.txt"),+      testCase "missing files are rejected" $+        checkError+          "missing/manifest"+          (MissingManifestFile "0001-missing.sql"),+      testCase "unlisted SQL files are rejected deterministically" $+        checkError+          "unlisted/manifest"+          (UnlistedSqlFiles ["0002-unlisted.sql"]),+      testCase "an empty manifest is rejected" $+        withTemporaryManifest "empty" ByteString.empty $ \manifestPath ->+          checkTemporaryError manifestPath EmptyManifest,+      testCase "surrounding entry whitespace is rejected" $+        withTemporaryManifest "whitespace" " 0001-first.sql\n" $ \manifestPath ->+          checkTemporaryError+            manifestPath+            (ManifestEntryHasSurroundingWhitespace 1 " 0001-first.sql"),+      testCase "invalid manifest UTF-8 is rejected" $+        withTemporaryManifest "invalid-utf8" (ByteString.pack [0xC3, 0x28]) $ \manifestPath -> do+          result <- checkMigrationManifest manifestPath+          case result of+            Left (ManifestInvalidUtf8 actualPath _) -> actualPath @?= manifestPath+            Left actual -> fail ("expected ManifestInvalidUtf8, received " <> show actual)+            Right _ -> fail "expected invalid manifest UTF-8 to fail"+    ]++validEmbedded :: NonEmpty (FilePath, ByteString.ByteString)+validEmbedded =+  $(embedMigrationManifest "test/fixtures/valid/migrations/manifest")++checkError :: FilePath -> ManifestError -> IO ()+checkError relativePath expected = do+  result <- checkMigrationManifest =<< fixture relativePath+  case result of+    Left actual -> actual @?= expected+    Right _ -> fail ("expected Left " <> show expected <> ", received Right")++fixture :: FilePath -> IO FilePath+fixture relativePath =+  Paths.getDataFileName ("test/fixtures" </> relativePath)++checkTemporaryError :: FilePath -> ManifestError -> IO ()+checkTemporaryError manifestPath expected = do+  result <- checkMigrationManifest manifestPath+  case result of+    Left actual -> actual @?= expected+    Right _ -> fail ("expected Left " <> show expected <> ", received Right")++withTemporaryManifest :: String -> ByteString.ByteString -> (FilePath -> IO value) -> IO value+withTemporaryManifest label bytes action =+  Exception.bracket create remove action+  where+    create = do+      temporaryDirectory <- Directory.getTemporaryDirectory+      let directory = temporaryDirectory </> ("pg-migrate-embed-" <> label)+          manifestPath = directory </> "manifest"+      Directory.removePathForcibly directory `Exception.catch` ignoreMissing+      Directory.createDirectory directory+      ByteString.writeFile manifestPath bytes+      pure manifestPath+    remove manifestPath = Directory.removePathForcibly (FilePath.takeDirectory manifestPath)+    ignoreMissing :: IOError -> IO ()+    ignoreMissing _ = pure ()