diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# Changelog + +## 1.0.0.0 — 2026-07-10 + +- Initial stable release of manifest format v1, exact-byte Template Haskell embedding, + validation, and crash-conservative migration authoring. diff --git a/pg-migrate-embed.cabal b/pg-migrate-embed.cabal new file mode 100644 --- /dev/null +++ b/pg-migrate-embed.cabal @@ -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 diff --git a/src/Database/PostgreSQL/Migrate/Embed.hs b/src/Database/PostgreSQL/Migrate/Embed.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate/Embed.hs @@ -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, + ) diff --git a/src/Database/PostgreSQL/Migrate/Embed/Authoring.hs b/src/Database/PostgreSQL/Migrate/Embed/Authoring.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate/Embed/Authoring.hs @@ -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 diff --git a/src/Database/PostgreSQL/Migrate/Embed/Internal.hs b/src/Database/PostgreSQL/Migrate/Embed/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate/Embed/Internal.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Database.PostgreSQL.Migrate.Embed.Internal + ( newMigrationWithRename, + ) +where + +import Database.PostgreSQL.Migrate.Embed.Authoring (newMigrationWithRename) diff --git a/src/Database/PostgreSQL/Migrate/Embed/Manifest.hs b/src/Database/PostgreSQL/Migrate/Embed/Manifest.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate/Embed/Manifest.hs @@ -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 diff --git a/test/fixtures/absolute/manifest b/test/fixtures/absolute/manifest new file mode 100644 --- /dev/null +++ b/test/fixtures/absolute/manifest @@ -0,0 +1,1 @@ +/tmp/outside.sql diff --git a/test/fixtures/blank/0001-first.sql b/test/fixtures/blank/0001-first.sql new file mode 100644 --- /dev/null +++ b/test/fixtures/blank/0001-first.sql @@ -0,0 +1,1 @@ +SELECT 1; diff --git a/test/fixtures/blank/0002-second.sql b/test/fixtures/blank/0002-second.sql new file mode 100644 --- /dev/null +++ b/test/fixtures/blank/0002-second.sql @@ -0,0 +1,1 @@ +SELECT 2; diff --git a/test/fixtures/blank/manifest b/test/fixtures/blank/manifest new file mode 100644 --- /dev/null +++ b/test/fixtures/blank/manifest @@ -0,0 +1,3 @@ +0001-first.sql + +0002-second.sql diff --git a/test/fixtures/comment/0001-first.sql b/test/fixtures/comment/0001-first.sql new file mode 100644 --- /dev/null +++ b/test/fixtures/comment/0001-first.sql @@ -0,0 +1,1 @@ +SELECT 1; diff --git a/test/fixtures/comment/manifest b/test/fixtures/comment/manifest new file mode 100644 --- /dev/null +++ b/test/fixtures/comment/manifest @@ -0,0 +1,2 @@ +0001-first.sql +# comments are not part of the v1 format diff --git a/test/fixtures/duplicate/0001-first.sql b/test/fixtures/duplicate/0001-first.sql new file mode 100644 --- /dev/null +++ b/test/fixtures/duplicate/0001-first.sql @@ -0,0 +1,1 @@ +SELECT 1; diff --git a/test/fixtures/duplicate/manifest b/test/fixtures/duplicate/manifest new file mode 100644 --- /dev/null +++ b/test/fixtures/duplicate/manifest @@ -0,0 +1,2 @@ +0001-first.sql +0001-first.sql diff --git a/test/fixtures/missing/manifest b/test/fixtures/missing/manifest new file mode 100644 --- /dev/null +++ b/test/fixtures/missing/manifest @@ -0,0 +1,1 @@ +0001-missing.sql diff --git a/test/fixtures/nested/manifest b/test/fixtures/nested/manifest new file mode 100644 --- /dev/null +++ b/test/fixtures/nested/manifest @@ -0,0 +1,1 @@ +nested/0001-first.sql diff --git a/test/fixtures/non-sql/README.txt b/test/fixtures/non-sql/README.txt new file mode 100644 --- /dev/null +++ b/test/fixtures/non-sql/README.txt @@ -0,0 +1,1 @@ +This is not a SQL migration. diff --git a/test/fixtures/non-sql/manifest b/test/fixtures/non-sql/manifest new file mode 100644 --- /dev/null +++ b/test/fixtures/non-sql/manifest @@ -0,0 +1,1 @@ +README.txt diff --git a/test/fixtures/parent/manifest b/test/fixtures/parent/manifest new file mode 100644 --- /dev/null +++ b/test/fixtures/parent/manifest @@ -0,0 +1,1 @@ +../outside.sql diff --git a/test/fixtures/unlisted/0001-listed.sql b/test/fixtures/unlisted/0001-listed.sql new file mode 100644 --- /dev/null +++ b/test/fixtures/unlisted/0001-listed.sql @@ -0,0 +1,1 @@ +SELECT 1; diff --git a/test/fixtures/unlisted/0002-unlisted.sql b/test/fixtures/unlisted/0002-unlisted.sql new file mode 100644 --- /dev/null +++ b/test/fixtures/unlisted/0002-unlisted.sql @@ -0,0 +1,1 @@ +SELECT 2; diff --git a/test/fixtures/unlisted/manifest b/test/fixtures/unlisted/manifest new file mode 100644 --- /dev/null +++ b/test/fixtures/unlisted/manifest @@ -0,0 +1,1 @@ +0001-listed.sql diff --git a/test/fixtures/valid/migrations/0001-first.sql b/test/fixtures/valid/migrations/0001-first.sql new file mode 100644 --- /dev/null +++ b/test/fixtures/valid/migrations/0001-first.sql @@ -0,0 +1,1 @@ +SELECT 'first'; diff --git a/test/fixtures/valid/migrations/0002-second.sql b/test/fixtures/valid/migrations/0002-second.sql new file mode 100644 --- /dev/null +++ b/test/fixtures/valid/migrations/0002-second.sql @@ -0,0 +1,1 @@ +SELECT 'second'; diff --git a/test/fixtures/valid/migrations/manifest b/test/fixtures/valid/migrations/manifest new file mode 100644 --- /dev/null +++ b/test/fixtures/valid/migrations/manifest @@ -0,0 +1,2 @@ +0002-second.sql +0001-first.sql diff --git a/test/recompilation/Main.hs b/test/recompilation/Main.hs new file mode 100644 --- /dev/null +++ b/test/recompilation/Main.hs @@ -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)) diff --git a/test/recompilation/fixture/app/Main.hs b/test/recompilation/fixture/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/recompilation/fixture/app/Main.hs @@ -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") diff --git a/test/recompilation/fixture/migrations/0001-first.sql b/test/recompilation/fixture/migrations/0001-first.sql new file mode 100644 --- /dev/null +++ b/test/recompilation/fixture/migrations/0001-first.sql @@ -0,0 +1,1 @@ +SELECT 1; diff --git a/test/recompilation/fixture/migrations/manifest b/test/recompilation/fixture/migrations/manifest new file mode 100644 --- /dev/null +++ b/test/recompilation/fixture/migrations/manifest @@ -0,0 +1,1 @@ +0001-first.sql diff --git a/test/recompilation/fixture/recompilation-probe.cabal b/test/recompilation/fixture/recompilation-probe.cabal new file mode 100644 --- /dev/null +++ b/test/recompilation/fixture/recompilation-probe.cabal @@ -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 diff --git a/test/unit/Main.hs b/test/unit/Main.hs new file mode 100644 --- /dev/null +++ b/test/unit/Main.hs @@ -0,0 +1,17 @@ +module Main (main) where + +import Test.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 + ] + ) diff --git a/test/unit/Test/Authoring.hs b/test/unit/Test/Authoring.hs new file mode 100644 --- /dev/null +++ b/test/unit/Test/Authoring.hs @@ -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 diff --git a/test/unit/Test/Component.hs b/test/unit/Test/Component.hs new file mode 100644 --- /dev/null +++ b/test/unit/Test/Component.hs @@ -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") diff --git a/test/unit/Test/Manifest.hs b/test/unit/Test/Manifest.hs new file mode 100644 --- /dev/null +++ b/test/unit/Test/Manifest.hs @@ -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 ()