diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,29 @@ # Changelog +## 1.1.0.0 — 2026-07-13 + +Major release: this set adds constructors to the public `ManifestError` and +`AuthoringError` sums. + +### Breaking changes + +- Added `ManifestByteOrderMark` so a leading UTF-8 BOM has a dedicated diagnostic. +- Added `AuthoringConcurrentModification` so a detected post-rename manifest clobber does + not silently report successful authoring. + +### Fixes and behavior changes + +- Stop automatic numbering before a successor would lose the sequence's leading zero and + become unreadable by the next authoring operation. +- Emit embedded SQL as one static primitive byte literal instead of one Template Haskell + expression per byte, making multi-megabyte payloads practical while preserving exact + bytes. +- Add `Database.PostgreSQL.Migrate.Embed.RecompilePlugin` for GHC 9.12. A module-local + `OPTIONS_GHC -fplugin=...` pragma makes the embedding module recompile on every build so + newly added or removed sibling SQL files rerun strict manifest membership validation. +- Document that migration authoring requires POSIX while manifest validation and embedding + remain portable, and describe the authoring helper's actual concurrency guarantees. + ## 1.0.0.0 — 2026-07-10 - Initial stable release of manifest format v1, exact-byte Template Haskell embedding, diff --git a/pg-migrate-embed.cabal b/pg-migrate-embed.cabal --- a/pg-migrate-embed.cabal +++ b/pg-migrate-embed.cabal @@ -1,6 +1,6 @@ cabal-version: 3.8 name: pg-migrate-embed -version: 1.0.0.0 +version: 1.1.0.0 synopsis: Compile-time ordered SQL manifests for pg-migrate category: Database maintainer: nadeem@gmail.com @@ -51,6 +51,7 @@ exposed-modules: Database.PostgreSQL.Migrate.Embed Database.PostgreSQL.Migrate.Embed.Internal + Database.PostgreSQL.Migrate.Embed.RecompilePlugin other-modules: Database.PostgreSQL.Migrate.Embed.Authoring @@ -61,7 +62,8 @@ , bytestring >=0.12 && <0.13 , directory >=1.3 && <1.4 , filepath >=1.5 && <1.6 - , pg-migrate >=1.0 && <1.1 + , ghc >=9.10 && <9.13 + , pg-migrate >=1.1 && <1.2 , template-haskell >=2.22 && <2.24 , text >=2.1 && <2.2 , unix >=2.8 && <2.9 diff --git a/src/Database/PostgreSQL/Migrate/Embed/Authoring.hs b/src/Database/PostgreSQL/Migrate/Embed/Authoring.hs --- a/src/Database/PostgreSQL/Migrate/Embed/Authoring.hs +++ b/src/Database/PostgreSQL/Migrate/Embed/Authoring.hs @@ -4,6 +4,8 @@ newMigrationOptions, newMigration, newMigrationWithRename, + renderNextMigrationName, + numericPrefix, ) where @@ -44,6 +46,7 @@ | ExplicitMigrationNameRequired | MigrationSequenceExhausted !Int | MigrationFileAlreadyExists !FilePath + | AuthoringConcurrentModification !FilePath | AuthoringIoError !FilePath !Text.Text | AuthoringCleanupError !FilePath !Text.Text deriving stock (Eq, Show) @@ -62,7 +65,8 @@ explicitName <- traverse normalizeExplicitName requestedName Right NewMigrationOptions {manifestPath, explicitName, initialSql} --- | Exclusively create a SQL file and atomically append its manifest entry. +-- | Exclusively create a SQL file and atomically replace the manifest with its new entry. +-- Concurrent authoring is not supported; detected post-replacement clobbers are reported. newMigration :: NewMigrationOptions -> IO (Either AuthoringError FilePath) newMigration = newMigrationWithRename Directory.renameFile @@ -109,7 +113,7 @@ renderNextMigrationName :: Int -> Integer -> Either AuthoringError FilePath renderNextMigrationName width next = let rendered = show next - in if length rendered > width + in if length rendered >= width then Left (MigrationSequenceExhausted width) else firstLeft @@ -156,7 +160,15 @@ replacementResult <- replaceManifest renameFile manifestPath (appendEntry originalManifest entry) case replacementResult of - Right () -> pure (Right migrationPath) + Right () -> do + verificationResult <- manifestContainsEntry manifestPath entry + case verificationResult of + Left verificationError -> pure (Left verificationError) + Right True -> pure (Right migrationPath) + Right False -> + cleanupCreatedFile + migrationPath + (AuthoringConcurrentModification manifestPath) Left replacementError -> do cleanupResult <- tryIOException (Directory.removeFile migrationPath) pure $ case cleanupResult of @@ -196,7 +208,7 @@ ignoreIOException (IO.hClose handle) cleanupCreatedFile path (authoringIoError path err) -cleanupCreatedFile :: FilePath -> AuthoringError -> IO (Either AuthoringError ()) +cleanupCreatedFile :: FilePath -> AuthoringError -> IO (Either AuthoringError value) cleanupCreatedFile path originalError = do cleanupResult <- tryIOException (Directory.removeFile path) pure $ case cleanupResult of @@ -245,6 +257,23 @@ | ByteString.null original = ByteString.empty | ByteString.last original == 0x0A = ByteString.empty | otherwise = "\n" + +manifestContainsEntry :: FilePath -> FilePath -> IO (Either AuthoringError Bool) +manifestContainsEntry manifestPath entry = do + manifestResult <- tryIOException (ByteString.readFile manifestPath) + pure $ case manifestResult of + Left err -> Left (authoringIoError manifestPath err) + Right contents -> + Right + ( Text.Encoding.encodeUtf8 (Text.pack entry) + `elem` (dropCarriageReturn <$> ByteString.split 0x0A contents) + ) + +dropCarriageReturn :: ByteString.ByteString -> ByteString.ByteString +dropCarriageReturn line = + case ByteString.unsnoc line of + Just (prefix, 0x0D) -> prefix + _ -> line authoringIoError :: FilePath -> IOException -> AuthoringError authoringIoError path err = AuthoringIoError path (Text.pack (show err)) diff --git a/src/Database/PostgreSQL/Migrate/Embed/Internal.hs b/src/Database/PostgreSQL/Migrate/Embed/Internal.hs --- a/src/Database/PostgreSQL/Migrate/Embed/Internal.hs +++ b/src/Database/PostgreSQL/Migrate/Embed/Internal.hs @@ -2,7 +2,15 @@ module Database.PostgreSQL.Migrate.Embed.Internal ( newMigrationWithRename, + renderNextMigrationName, + numericPrefix, + byteStringExpression, ) where -import Database.PostgreSQL.Migrate.Embed.Authoring (newMigrationWithRename) +import Database.PostgreSQL.Migrate.Embed.Authoring + ( newMigrationWithRename, + numericPrefix, + renderNextMigrationName, + ) +import Database.PostgreSQL.Migrate.Embed.Manifest (byteStringExpression) diff --git a/src/Database/PostgreSQL/Migrate/Embed/Manifest.hs b/src/Database/PostgreSQL/Migrate/Embed/Manifest.hs --- a/src/Database/PostgreSQL/Migrate/Embed/Manifest.hs +++ b/src/Database/PostgreSQL/Migrate/Embed/Manifest.hs @@ -4,6 +4,7 @@ checkMigrationManifest, embedMigrationManifest, validateManifestEntry, + byteStringExpression, ) where @@ -11,6 +12,7 @@ import Control.Exception qualified as Exception import Data.Bifunctor (first) import Data.ByteString qualified as ByteString +import Data.ByteString.Internal qualified as ByteString.Internal import Data.Foldable (toList, traverse_) import Data.List qualified as List import Data.List.NonEmpty (NonEmpty (..)) @@ -21,6 +23,7 @@ Lit (..), Q, ) +import Language.Haskell.TH.Lib qualified as TH.Lib import Language.Haskell.TH.Syntax qualified as TH.Syntax import System.Directory qualified as Directory import System.FilePath qualified as FilePath @@ -33,6 +36,7 @@ data ManifestError = ManifestIoError !FilePath !Text.Text | ManifestInvalidUtf8 !FilePath !Text.Text + | ManifestByteOrderMark !FilePath | EmptyManifest | BlankManifestLine !Int | CommentManifestLine !Int @@ -61,6 +65,12 @@ Right entries -> checkManifestFiles manifestPath entries -- | Validate and embed an ordered migration manifest at compile time. +-- +-- On GHC 9.12, modules using this splice should load +-- @Database.PostgreSQL.Migrate.Embed.RecompilePlugin@ with a module-local +-- @OPTIONS_GHC -fplugin=...@ pragma. The plugin makes additions and removals in the +-- manifest directory observable even though that compiler can register only existing +-- files as Template Haskell dependencies. embedMigrationManifest :: FilePath -> Q Exp embedMigrationManifest inputPath = do manifestPath <- TH.Syntax.makeRelativeToProject inputPath @@ -76,19 +86,25 @@ 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 +parseManifest manifestPath manifestBytes + | utf8ByteOrderMark `ByteString.isPrefixOf` manifestBytes = + Left (ManifestByteOrderMark manifestPath) + | otherwise = 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 +utf8ByteOrderMark :: ByteString.ByteString +utf8ByteOrderMark = ByteString.pack [0xEF, 0xBB, 0xBF] + normalizeLineEnding :: Text.Text -> Text.Text normalizeLineEnding = Text.dropWhileEnd (== '\r') @@ -172,12 +188,26 @@ entryExpression (entry, bytes) = TupE [ Just (LitE (StringL entry)), - Just + Just (byteStringExpression bytes) + ] + +byteStringExpression :: ByteString.ByteString -> Exp +byteStringExpression bytes = + let (foreignPointer, offset, length_) = ByteString.Internal.toForeignPtr bytes + in AppE ( AppE - (VarE 'ByteString.pack) - (ListE (LitE . IntegerL . fromIntegral <$> ByteString.unpack bytes)) + (VarE 'ByteString.Internal.unsafePackLenLiteral) + (LitE (IntegerL (fromIntegral length_))) ) - ] + ( LitE + ( TH.Lib.bytesPrimL + ( TH.Lib.mkBytes + foreignPointer + (fromIntegral offset) + (fromIntegral length_) + ) + ) + ) tryIOException :: IO value -> IO (Either IOException value) tryIOException = Exception.try diff --git a/src/Database/PostgreSQL/Migrate/Embed/RecompilePlugin.hs b/src/Database/PostgreSQL/Migrate/Embed/RecompilePlugin.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate/Embed/RecompilePlugin.hs @@ -0,0 +1,24 @@ +-- | GHC 9.12 recompilation support for strict manifest membership checks. +-- +-- Put this pragma in each module that calls @embedMigrationManifest@: +-- +-- > {-# OPTIONS_GHC -fplugin=Database.PostgreSQL.Migrate.Embed.RecompilePlugin #-} +-- +-- GHC 9.12 can track existing files but has no Template Haskell directory-dependency +-- API. This no-op Core plugin forces that embedding module to be reconsidered on every +-- build, allowing a newly added or removed sibling SQL file to rerun manifest validation. +module Database.PostgreSQL.Migrate.Embed.RecompilePlugin (plugin) where + +import GHC.Plugins + ( Plugin (pluginRecompile), + PluginRecompile (ForceRecompile), + defaultPlugin, + ) + +-- | The compiler plugin entry point. Applications load it with the module-local pragma +-- shown above; application code does not call it. +plugin :: Plugin +plugin = + defaultPlugin + { pluginRecompile = const (pure ForceRecompile) + } diff --git a/test/recompilation/Main.hs b/test/recompilation/Main.hs --- a/test/recompilation/Main.hs +++ b/test/recompilation/Main.hs @@ -2,7 +2,7 @@ import Control.Exception qualified as Exception import Control.Monad (filterM, unless, when) -import Data.List (isPrefixOf) +import Data.List (isInfixOf, isPrefixOf) import Data.Time.Clock qualified as Time import Paths_pg_migrate_embed qualified as Paths import System.Directory qualified as Directory @@ -28,11 +28,25 @@ copyDirectory fixtureSource workspace writeProjectFile corePackageRoot packageRoot workspace prepareProbe workspace - moduleTimestamp <- Directory.getModificationTime (workspace FilePath. "app/Main.hs") + directoryModuleTimestamp <- + Directory.getModificationTime (workspace FilePath. "app/Main.hs") + trackedModuleTimestamp <- + Directory.getModificationTime (workspace FilePath. "app/TrackedMain.hs") - initialOutput <- runProbe workspace + directoryOutput <- runDirectoryProbe workspace + let unlistedPath = workspace FilePath. "migrations/0002-unlisted.sql" + writeFile unlistedPath "SELECT 2;\n" + runDirectoryProbeExpectingFailure + workspace + "UnlistedSqlFiles [\"0002-unlisted.sql\"]" + Directory.removeFile unlistedPath + directoryOutputAfterRemoval <- runDirectoryProbe workspace + unless (directoryOutputAfterRemoval == directoryOutput) $ + fail "removing the unlisted SQL file changed the embedded checksums" + + initialOutput <- runTrackedProbe workspace writeTrackedFile (workspace FilePath. "migrations/0001-first.sql") "SELECT 2;\n" - sqlChangedOutput <- runProbe workspace + sqlChangedOutput <- runTrackedProbe workspace when (sqlChangedOutput == initialOutput) $ fail "changing a tracked SQL file did not change the embedded checksums" @@ -40,47 +54,102 @@ writeTrackedFile (workspace FilePath. "migrations/manifest") "0001-first.sql\n0002-second.sql\n" - manifestChangedOutput <- runProbe workspace + manifestChangedOutput <- runTrackedProbe 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" + finalDirectoryModuleTimestamp <- + Directory.getModificationTime (workspace FilePath. "app/Main.hs") + finalTrackedModuleTimestamp <- + Directory.getModificationTime (workspace FilePath. "app/TrackedMain.hs") + unless + ( finalDirectoryModuleTimestamp == directoryModuleTimestamp + && finalTrackedModuleTimestamp == trackedModuleTimestamp + ) + $ fail "the recompilation test unexpectedly touched a Haskell module" -runProbe :: FilePath -> IO String -runProbe workspace = do +runDirectoryProbe :: FilePath -> IO String +runDirectoryProbe 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") [] + directoryProbeArguments + runChecked workspace (workspace FilePath. "ghc-directory-recompilation/probe") [] +runDirectoryProbeExpectingFailure :: FilePath -> String -> IO () +runDirectoryProbeExpectingFailure workspace expectedError = do + let command = + (Process.proc "cabal" directoryProbeArguments) + { Process.cwd = Just workspace + } + (exitCode, standardOutput, standardError) <- + Process.readCreateProcessWithExitCode command "" + case exitCode of + ExitFailure _ -> + unless (expectedError `isInfixOf` (standardOutput <> standardError)) $ + fail + ( "probe compilation failed without the expected diagnostic " + <> show expectedError + <> ":\n" + <> standardError + ) + ExitSuccess -> + fail "adding an unlisted SQL file did not force manifest revalidation" + +runTrackedProbe :: FilePath -> IO String +runTrackedProbe workspace = do + _ <- + runChecked + workspace + "cabal" + trackedProbeArguments + runChecked workspace (workspace FilePath. "ghc-tracked-recompilation/probe") [] + +directoryProbeArguments :: [String] +directoryProbeArguments = + ghcArguments + "app/Main.hs" + Nothing + "ghc-directory-recompilation" + +trackedProbeArguments :: [String] +trackedProbeArguments = + ghcArguments + "app/TrackedMain.hs" + (Just "TrackedMain") + "ghc-tracked-recompilation" + +ghcArguments :: FilePath -> Maybe String -> FilePath -> [String] +ghcArguments source mainModule outputDirectory = + [ "exec", + "--builddir=dist-recompilation", + "--", + "ghc", + "--make", + source, + "-o", + outputDirectory FilePath. "probe", + "-odir", + outputDirectory, + "-hidir", + outputDirectory, + "-package", + "pg-migrate", + "-package", + "pg-migrate-embed", + "-XGHC2024", + "-XOverloadedStrings", + "-XTemplateHaskell" + ] + <> maybe [] (\moduleName -> ["-main-is", moduleName]) mainModule + prepareProbe :: FilePath -> IO () prepareProbe workspace = do - Directory.createDirectory (workspace FilePath. "ghc-recompilation") + Directory.createDirectory (workspace FilePath. "ghc-directory-recompilation") + Directory.createDirectory (workspace FilePath. "ghc-tracked-recompilation") _ <- runChecked workspace diff --git a/test/recompilation/fixture/app/Main.hs b/test/recompilation/fixture/app/Main.hs --- a/test/recompilation/fixture/app/Main.hs +++ b/test/recompilation/fixture/app/Main.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fplugin=Database.PostgreSQL.Migrate.Embed.RecompilePlugin #-} + module Main (main) where import Data.ByteString (ByteString) diff --git a/test/recompilation/fixture/app/TrackedMain.hs b/test/recompilation/fixture/app/TrackedMain.hs new file mode 100644 --- /dev/null +++ b/test/recompilation/fixture/app/TrackedMain.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TemplateHaskell #-} + +module TrackedMain (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/unit/Test/Authoring.hs b/test/unit/Test/Authoring.hs --- a/test/unit/Test/Authoring.hs +++ b/test/unit/Test/Authoring.hs @@ -1,12 +1,17 @@ module Test.Authoring (tests) where import Control.Exception qualified as Exception +import Control.Monad (forM_) 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 Database.PostgreSQL.Migrate.Embed.Internal + ( newMigrationWithRename, + numericPrefix, + renderNextMigrationName, + ) import System.Directory qualified as Directory import System.FilePath qualified as FilePath import Test.Tasty (TestTree, testGroup) @@ -40,6 +45,26 @@ options <- assertRight (newMigrationOptions manifestPath Nothing "SELECT 2;\n") result <- newMigration options result @?= Left ExplicitMigrationNameRequired, + testCase "next automatic name after 08 is 09" $ + withWorkspace "next-nine" (numberedFiles 2 [1 .. 8]) $ \manifestPath -> do + options <- assertRight (newMigrationOptions manifestPath Nothing "SELECT 9;\n") + result <- newMigration options + result + @?= Right (FilePath.takeDirectory manifestPath FilePath. "09.sql"), + testCase "successor of 09 at width 2 is exhausted" $ + withWorkspace "width-two-exhausted" (numberedFiles 2 [1 .. 9]) $ \manifestPath -> do + options <- assertRight (newMigrationOptions manifestPath Nothing "SELECT 10;\n") + result <- newMigration options + result @?= Left (MigrationSequenceExhausted 2), + testCase "successor of 0999 at width 4 is exhausted" $ + withWorkspace "width-four-exhausted" [("0999.sql", "SELECT 999;\n")] $ \manifestPath -> do + options <- assertRight (newMigrationOptions manifestPath Nothing "SELECT 1000;\n") + result <- newMigration options + result @?= Left (MigrationSequenceExhausted 4), + testCase "automatic names round-trip through numeric-prefix inference" $ + forM_ roundTripCases $ \(width, next) -> do + entry <- assertRight (renderNextMigrationName width next) + numericPrefix entry @?= Just (width, next), testCase "exclusive creation refuses an existing migration" $ withWorkspace "collision" [("0001-first.sql", "SELECT 1;\n")] $ \manifestPath -> do originalManifest <- ByteString.readFile manifestPath @@ -75,6 +100,19 @@ createdFileExists @?= False directoryEntries <- List.sort <$> Directory.listDirectory (FilePath.takeDirectory manifestPath) directoryEntries @?= ["0001-first.sql", "manifest"], + testCase "a post-rename clobber is detected and the new SQL file is removed" $ + withWorkspace "concurrent-modification" [("0001-first.sql", "SELECT 1;\n")] $ \manifestPath -> do + originalManifest <- ByteString.readFile manifestPath + options <- assertRight (newMigrationOptions manifestPath Nothing "SELECT 2;\n") + let clobberingRename temporaryPath destinationPath = do + Directory.renameFile temporaryPath destinationPath + ByteString.writeFile destinationPath originalManifest + result <- newMigrationWithRename clobberingRename options + result @?= Left (AuthoringConcurrentModification manifestPath) + ByteString.readFile manifestPath >>= (@?= originalManifest) + Directory.doesFileExist + (FilePath.takeDirectory manifestPath FilePath. "0002.sql") + >>= (@?= False), testCase "option construction rejects nested explicit names" $ case newMigrationOptions "migrations/manifest" (Just "../outside") "SELECT 1" of Left (InvalidNewMigrationName (ParentTraversalManifestEntry 1 "../outside.sql")) -> pure () @@ -88,6 +126,21 @@ numericFiles = [ ("0001-first.sql", "SELECT 1;\n"), ("0002-second.sql", "SELECT 2;\n") + ] + +numberedFiles :: Int -> [Integer] -> [(FilePath, ByteString.ByteString)] +numberedFiles width = + fmap $ \number -> + ( replicate (width - length (show number)) '0' <> show number <> ".sql", + "SELECT " <> ByteString.Char8.pack (show number) <> ";\n" + ) + +roundTripCases :: [(Int, Integer)] +roundTripCases = + [ (width, next) + | width <- [2 .. 6], + next <- [1, 8, 9, 10, 99, 100, 999], + length (show next) < width ] withWorkspace :: diff --git a/test/unit/Test/Manifest.hs b/test/unit/Test/Manifest.hs --- a/test/unit/Test/Manifest.hs +++ b/test/unit/Test/Manifest.hs @@ -6,6 +6,7 @@ import Data.ByteString qualified as ByteString import Data.List.NonEmpty (NonEmpty (..)) import Database.PostgreSQL.Migrate.Embed +import Database.PostgreSQL.Migrate.Embed.Internal (byteStringExpression) import Paths_pg_migrate_embed qualified as Paths import System.Directory qualified as Directory import System.FilePath (()) @@ -21,6 +22,11 @@ testCase "valid entries and exact bytes follow manifest order" $ do result <- checkMigrationManifest =<< fixture "valid/migrations/manifest" result @?= Right validEmbedded, + testCase "embedded primitive bytes preserve every byte value" $ + embeddedAllBytes @?= ByteString.pack [0 .. 255], + testCase "a large embedded payload compiles without per-byte AST expansion" $ do + ByteString.length largeEmbeddedBytes @?= largeFixtureSize + ByteString.all (== 0xA5) largeEmbeddedBytes @?= True, testCase "blank lines are rejected" $ checkError "blank/manifest" (BlankManifestLine 2), testCase "comment lines are rejected" $ @@ -67,12 +73,29 @@ 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" + Right _ -> fail "expected invalid manifest UTF-8 to fail", + testCase "a manifest byte-order mark has a dedicated diagnostic" + $ withTemporaryManifest + "byte-order-mark" + (ByteString.pack [0xEF, 0xBB, 0xBF] <> "0001-first.sql\n") + $ \manifestPath -> + checkTemporaryError manifestPath (ManifestByteOrderMark manifestPath) ] validEmbedded :: NonEmpty (FilePath, ByteString.ByteString) validEmbedded = $(embedMigrationManifest "test/fixtures/valid/migrations/manifest") + +embeddedAllBytes :: ByteString.ByteString +embeddedAllBytes = + $(pure (byteStringExpression (ByteString.pack [0 .. 255]))) + +largeFixtureSize :: Int +largeFixtureSize = 1024 * 1024 + 1 + +largeEmbeddedBytes :: ByteString.ByteString +largeEmbeddedBytes = + $(pure (byteStringExpression (ByteString.replicate (1024 * 1024 + 1) 0xA5))) checkError :: FilePath -> ManifestError -> IO () checkError relativePath expected = do