ephemeral-pg 0.2.0.0 → 0.2.0.1
raw patch · 9 files changed
+264/−382 lines, 9 files
Files
- CHANGELOG.md +6/−0
- ephemeral-pg.cabal +1/−1
- src/EphemeralPg.hs +43/−58
- src/EphemeralPg/Dump.hs +76/−140
- src/EphemeralPg/Internal/Cache.hs +49/−60
- src/EphemeralPg/Internal/Directory.hs +31/−46
- src/EphemeralPg/Internal/Except.hs +1/−1
- src/EphemeralPg/Process/Postgres.hs +6/−1
- src/EphemeralPg/Snapshot.hs +51/−75
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Changelog +## 0.2.0.1++### Bug Fixes++- Suppress pg_isready stdout/stderr during connection polling+ ## 0.2.0.0 ### Breaking Changes
ephemeral-pg.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: ephemeral-pg-version: 0.2.0.0+version: 0.2.0.1 synopsis: Temporary PostgreSQL databases for testing description: A modern library for creating temporary PostgreSQL instances for testing.
src/EphemeralPg.hs view
@@ -143,14 +143,12 @@ -- -- Use the database... -- @ withConfig :: Config -> (Database -> IO a) -> IO (Either StartError a)-withConfig config action = mask $ \restore -> do- result <- start config- case result of- Left err -> pure (Left err)- Right db -> do- a <- restore (action db) `onException` stop db- stop db- pure (Right a)+withConfig config action = mask $ \restore -> runStartup $ do+ db <- liftE $ start config+ liftIO $ do+ a <- restore (action db) `onException` stop db+ stop db+ pure a -- | Start a temporary database. --@@ -326,14 +324,12 @@ -- | Like 'withCached' but with custom configuration. withCachedConfig :: Config -> CacheConfig -> (Database -> IO a) -> IO (Either StartError a)-withCachedConfig config cacheConfig action = mask $ \restore -> do- result <- startCached config cacheConfig- case result of- Left err -> pure (Left err)- Right db -> do- a <- restore (action db) `onException` stop db- stop db- pure (Right a)+withCachedConfig config cacheConfig action = mask $ \restore -> runStartup $ do+ db <- liftE $ startCached config cacheConfig+ liftIO $ do+ a <- restore (action db) `onException` stop db+ stop db+ pure a -- | Start a temporary database using initdb caching. --@@ -358,61 +354,50 @@ -- | Start from an existing cache. startFromCache :: Config -> CacheConfig -> CacheKey -> IO (Either StartError Database)-startFromCache config cacheConfig cacheKey = do+startFromCache config cacheConfig cacheKey = runStartup $ do let mTempRoot = getLast config.temporaryRoot -- Create temporary data directory (to get the path)- dataResult <- createTempDataDirectory mTempRoot- case dataResult of- Left err -> pure $ Left err- Right (dataDir, dataDirIsTemp) -> do- -- Remove the directory so cp can create it fresh- -- (otherwise cp -cR creates nested directories on macOS)- removeDirectoryIfExists dataDir-- -- Restore from cache- restoreResult <- restoreFromCache cacheKey dataDir cacheConfig.root- case restoreResult of- Left _err -> do- -- Cache restore failed, fall back to non-cached start- removeDirectoryIfExists dataDir- start config- Right () -> do- -- Clean up any runtime files from the cache (postmaster.pid, etc.)- cleanupRuntimeFiles dataDir+ (dataDir, dataDirIsTemp) <- liftE $ createTempDataDirectory mTempRoot - -- Write postgresql.conf (cache doesn't include our custom settings)- writePostgresConf config dataDir+ -- Remove the directory so cp can create it fresh+ -- (otherwise cp -cR creates nested directories on macOS)+ liftIO $ removeDirectoryIfExists dataDir - -- Continue with normal startup from the restored data directory- continueStartup config dataDir dataDirIsTemp+ -- Restore from cache+ restoreResult <- liftIO $ restoreFromCache cacheKey dataDir cacheConfig.root+ case restoreResult of+ Left _err -> do+ -- Cache restore failed, fall back to non-cached start+ liftIO $ removeDirectoryIfExists dataDir+ liftE $ start config+ Right () -> do+ liftIO $ do+ cleanupRuntimeFiles dataDir+ writePostgresConf config dataDir+ liftE $ continueStartup config dataDir dataDirIsTemp -- | Start normally and cache the result. -- Cache is created after initdb but before postgres starts. startAndCache :: Config -> CacheConfig -> CacheKey -> IO (Either StartError Database)-startAndCache config cacheConfig cacheKey = do+startAndCache config cacheConfig cacheKey = runStartup $ do let mTempRoot = getLast config.temporaryRoot -- Create data directory- dataResult <- createTempDataDirectory mTempRoot- case dataResult of- Left err -> pure $ Left err- Right (dataDir, dataDirIsTemp) -> do- -- Run initdb- initResult <- runInitDb config dataDir- case initResult of- Left err -> do- when dataDirIsTemp $ removeDirectoryIfExists dataDir- pure $ Left err- Right () -> do- -- Cache the data directory NOW (before postgres starts)- -- This ensures the cache contains only clean initdb output- when dataDirIsTemp $ do- _ <- createCache cacheKey dataDir cacheConfig.root- pure ()+ (dataDir, dataDirIsTemp) <- liftE $ createTempDataDirectory mTempRoot - -- Continue with normal startup from the initialized data directory- continueStartup config dataDir dataDirIsTemp+ -- Run initdb+ liftE (runInitDb config dataDir)+ `onError` when dataDirIsTemp (removeDirectoryIfExists dataDir)++ -- Cache the data directory NOW (before postgres starts)+ -- This ensures the cache contains only clean initdb output+ liftIO $ when dataDirIsTemp $ do+ _ <- createCache cacheKey dataDir cacheConfig.root+ pure ()++ -- Continue with normal startup from the initialized data directory+ liftE $ continueStartup config dataDir dataDirIsTemp -- | Continue startup from an existing data directory. continueStartup :: Config -> FilePath -> Bool -> IO (Either StartError Database)
src/EphemeralPg/Dump.hs view
@@ -34,7 +34,11 @@ where import Control.Exception (SomeException, try)+import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.ByteString.Lazy qualified as LBS+import Data.Function ((&)) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T@@ -93,158 +97,90 @@ -- | Dump a database to a file. dump :: Database -> FilePath -> DumpOptions -> IO (Either Text ())-dump db outputPath opts = do- mPgDump <- findExecutable "pg_dump"- case mPgDump of- Nothing -> pure $ Left "pg_dump not found in PATH"- Just pgDumpPath -> do- let args = buildDumpArgs db opts <> ["-f", T.pack outputPath]- env = buildEnv db- processConfig =- proc pgDumpPath (map T.unpack args)- & setStdout byteStringOutput- & setStderr byteStringOutput- & setEnv env- result <- try $ readProcess processConfig- case result of- Left (ex :: SomeException) ->- pure $ Left $ "pg_dump failed: " <> T.pack (show ex)- Right (exitCode, _stdout, stderr) ->- case exitCode of- ExitSuccess -> pure $ Right ()- ExitFailure code ->- pure $- Left $- "pg_dump failed with code "- <> T.pack (show code)- <> ": "- <> T.decodeUtf8Lenient (LBS.toStrict stderr)- where- (&) = flip ($)+dump db outputPath opts = runExceptT $ do+ pgDumpPath <- findExecutableE "pg_dump"+ let args = buildDumpArgs db opts <> ["-f", T.pack outputPath]+ _ <- runToolE "pg_dump" pgDumpPath args (buildEnv db)+ pure () -- | Dump a database and return the dump as text. -- -- Only works with DumpPlain format. dumpToText :: Database -> DumpOptions -> IO (Either Text Text)-dumpToText db opts = do- if opts.format /= DumpPlain- then pure $ Left "dumpToText only works with DumpPlain format"- else do- mPgDump <- findExecutable "pg_dump"- case mPgDump of- Nothing -> pure $ Left "pg_dump not found in PATH"- Just pgDumpPath -> do- let args = buildDumpArgs db opts- env = buildEnv db- processConfig =- proc pgDumpPath (map T.unpack args)- & setStdout byteStringOutput- & setStderr byteStringOutput- & setEnv env- result <- try $ readProcess processConfig- case result of- Left (ex :: SomeException) ->- pure $ Left $ "pg_dump failed: " <> T.pack (show ex)- Right (exitCode, stdout, stderr) ->- case exitCode of- ExitSuccess -> pure $ Right $ T.decodeUtf8Lenient $ LBS.toStrict stdout- ExitFailure code ->- pure $- Left $- "pg_dump failed with code "- <> T.pack (show code)- <> ": "- <> T.decodeUtf8Lenient (LBS.toStrict stderr)- where- (&) = flip ($)+dumpToText db opts = runExceptT $ do+ when (opts.format /= DumpPlain) $+ throwE "dumpToText only works with DumpPlain format"+ pgDumpPath <- findExecutableE "pg_dump"+ let args = buildDumpArgs db opts+ (stdout, _) <- runToolE "pg_dump" pgDumpPath args (buildEnv db)+ pure $ T.decodeUtf8Lenient $ LBS.toStrict stdout -- | Restore a database from a dump file. restore :: Database -> FilePath -> IO (Either Text ())-restore db inputPath = do- mPsql <- findExecutable "psql"- case mPsql of- Nothing -> pure $ Left "psql not found in PATH"- Just psqlPath -> do- let args =- [ "-h",- T.pack db.socketDirectory,- "-p",- T.pack $ show db.port,- "-U",- db.user,- "-d",- db.databaseName,- "-f",- T.pack inputPath,- "-v",- "ON_ERROR_STOP=1"- ]- env = buildEnv db- processConfig =- proc psqlPath (map T.unpack args)- & setStdout byteStringOutput- & setStderr byteStringOutput- & setEnv env- result <- try $ readProcess processConfig- case result of- Left (ex :: SomeException) ->- pure $ Left $ "psql restore failed: " <> T.pack (show ex)- Right (exitCode, _stdout, stderr) ->- case exitCode of- ExitSuccess -> pure $ Right ()- ExitFailure code ->- pure $- Left $- "psql restore failed with code "- <> T.pack (show code)- <> ": "- <> T.decodeUtf8Lenient (LBS.toStrict stderr)- where- (&) = flip ($)+restore db inputPath = runExceptT $ do+ psqlPath <- findExecutableE "psql"+ let args = buildPsqlArgs db <> ["-f", T.pack inputPath]+ _ <- runToolE "psql restore" psqlPath args (buildEnv db)+ pure () -- | Restore a database from SQL text. restoreFromText :: Database -> Text -> IO (Either Text ())-restoreFromText db sqlText = do- mPsql <- findExecutable "psql"- case mPsql of- Nothing -> pure $ Left "psql not found in PATH"- Just psqlPath -> do- let args =- [ "-h",- T.pack db.socketDirectory,- "-p",- T.pack $ show db.port,- "-U",- db.user,- "-d",- db.databaseName,- "-c",- sqlText,- "-v",- "ON_ERROR_STOP=1"- ]- env = buildEnv db- processConfig =- proc psqlPath (map T.unpack args)- & setStdout byteStringOutput- & setStderr byteStringOutput- & setEnv env- result <- try $ readProcess processConfig- case result of- Left (ex :: SomeException) ->- pure $ Left $ "psql restore failed: " <> T.pack (show ex)- Right (exitCode, _stdout, stderr) ->- case exitCode of- ExitSuccess -> pure $ Right ()- ExitFailure code ->- pure $- Left $- "psql restore failed with code "- <> T.pack (show code)- <> ": "- <> T.decodeUtf8Lenient (LBS.toStrict stderr)+restoreFromText db sqlText = runExceptT $ do+ psqlPath <- findExecutableE "psql"+ let args = buildPsqlArgs db <> ["-c", sqlText]+ _ <- runToolE "psql restore" psqlPath args (buildEnv db)+ pure ()++-- | Find an executable in PATH or fail with a descriptive error.+findExecutableE :: String -> ExceptT Text IO FilePath+findExecutableE name = do+ mPath <- liftIO $ findExecutable name+ case mPath of+ Nothing -> throwE $ T.pack name <> " not found in PATH"+ Just path -> pure path++-- | Run an external tool, handling exceptions and non-zero exit codes.+runToolE ::+ Text ->+ FilePath ->+ [Text] ->+ [(String, String)] ->+ ExceptT Text IO (LBS.ByteString, LBS.ByteString)+runToolE toolName exePath args env = do+ result <- liftIO $ try $ readProcess processConfig+ case result of+ Left (ex :: SomeException) ->+ throwE $ toolName <> " failed: " <> T.pack (show ex)+ Right (ExitSuccess, stdout, stderr) ->+ pure (stdout, stderr)+ Right (ExitFailure code, _, stderr) ->+ throwE $+ toolName+ <> " failed with code "+ <> T.pack (show code)+ <> ": "+ <> T.decodeUtf8Lenient (LBS.toStrict stderr) where- (&) = flip ($)+ processConfig =+ proc exePath (map T.unpack args)+ & setStdout byteStringOutput+ & setStderr byteStringOutput+ & setEnv env++-- | Common psql arguments for restore operations.+buildPsqlArgs :: Database -> [Text]+buildPsqlArgs db =+ [ "-h",+ T.pack db.socketDirectory,+ "-p",+ T.pack $ show db.port,+ "-U",+ db.user,+ "-d",+ db.databaseName,+ "-v",+ "ON_ERROR_STOP=1"+ ] -- | Build pg_dump command line arguments. buildDumpArgs :: Database -> DumpOptions -> [Text]
src/EphemeralPg/Internal/Cache.hs view
@@ -33,7 +33,11 @@ where import Control.Exception (SomeException, try)+import Control.Monad (unless, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE) import Data.ByteString.Lazy qualified as LBS+import Data.Function ((&)) import Data.Hashable (hash) import Data.Text (Text) import Data.Text qualified as T@@ -107,24 +111,19 @@ getPostgresVersion :: IO (Either Text Text) getPostgresVersion = do result <- try $ readProcess config- case result of+ pure $ case result of Left (ex :: SomeException) ->- pure $ Left $ "Failed to get postgres version: " <> T.pack (show ex)- Right (exitCode, stdout, _stderr) ->- case exitCode of- ExitSuccess -> do- let versionLine = T.decodeUtf8Lenient $ LBS.toStrict stdout- pure $ Right $ extractMajorVersion versionLine- ExitFailure code ->- pure $ Left $ "postgres --version failed with code " <> T.pack (show code)+ Left $ "Failed to get postgres version: " <> T.pack (show ex)+ Right (ExitSuccess, stdout, _stderr) ->+ Right $ extractMajorVersion $ T.decodeUtf8Lenient $ LBS.toStrict stdout+ Right (ExitFailure code, _, _) ->+ Left $ "postgres --version failed with code " <> T.pack (show code) where config = proc "postgres" ["--version"] & setStdout byteStringOutput & setStderr byteStringOutput - (&) = flip ($)- -- Extract major version from "postgres (PostgreSQL) 17.7" extractMajorVersion :: Text -> Text extractMajorVersion line =@@ -139,25 +138,21 @@ -- | Generate a cache key for the given configuration. getCacheKey :: Config -> IO (Either Text CacheKey)-getCacheKey config = do- versionResult <- getPostgresVersion- case versionResult of- Left err -> pure $ Left err- Right version -> do- -- Hash the configuration elements that affect initdb output- let configStr =- T.unlines- [ T.unwords config.initDbArgs,- T.unlines $ map (\(k, v) -> k <> "=" <> v) config.postgresSettings,- config.user- ]- let cfgHash = T.pack $ show $ abs $ hash (T.unpack configStr)- pure $- Right $- CacheKey- { pgVersion = version,- configHash = cfgHash- }+getCacheKey config = runExceptT $ do+ version <- ExceptT getPostgresVersion+ -- Hash the configuration elements that affect initdb output+ let configStr =+ T.unlines+ [ T.unwords config.initDbArgs,+ T.unlines $ map (\(k, v) -> k <> "=" <> v) config.postgresSettings,+ config.user+ ]+ let cfgHash = T.pack $ show $ abs $ hash (T.unpack configStr)+ pure+ CacheKey+ { pgVersion = version,+ configHash = cfgHash+ } -- | Get the directory path for a given cache key. getCacheDirectory :: CacheKey -> Maybe FilePath -> IO FilePath@@ -188,47 +183,41 @@ -- | Restore from cache to a new data directory. restoreFromCache :: CacheKey -> FilePath -> Maybe FilePath -> IO (Either Text ())-restoreFromCache key dstDataDir mRoot = do- dir <- getCacheDirectory key mRoot+restoreFromCache key dstDataDir mRoot = runExceptT $ do+ dir <- liftIO $ getCacheDirectory key mRoot let srcDataDir = dir </> "data"-- exists <- doesDirectoryExist srcDataDir- if not exists- then pure $ Left $ "Cache not found: " <> T.pack srcDataDir- else do- -- Detect CoW capability- cowCapability <- detectCowCapability dir-- -- Copy from cache to destination- copyDirectory cowCapability srcDataDir dstDataDir+ exists <- liftIO $ doesDirectoryExist srcDataDir+ unless exists $+ throwE $+ "Cache not found: " <> T.pack srcDataDir+ cowCapability <- liftIO $ detectCowCapability dir+ ExceptT $ copyDirectory cowCapability srcDataDir dstDataDir -- | Clear the cache for a specific key. clearCache :: CacheKey -> Maybe FilePath -> IO (Either Text ())-clearCache key mRoot = do- dir <- getCacheDirectory key mRoot- exists <- doesDirectoryExist dir- if not exists- then pure $ Right ()- else do- result <- try $ removeDirectoryRecursive dir- case result of- Left (ex :: SomeException) ->- pure $ Left $ "Failed to clear cache: " <> T.pack (show ex)- Right () ->- pure $ Right ()+clearCache key mRoot = runExceptT $ do+ dir <- liftIO $ getCacheDirectory key mRoot+ exists <- liftIO $ doesDirectoryExist dir+ when exists $+ tryE "Failed to clear cache" $+ removeDirectoryRecursive dir -- | Clear all caches. clearAllCaches :: Maybe FilePath -> IO (Either Text ())-clearAllCaches mRoot = do- cacheDir <- ensureCacheDirectory mRoot- result <- try $ do+clearAllCaches mRoot = runExceptT $ do+ cacheDir <- liftIO $ ensureCacheDirectory mRoot+ tryE "Failed to clear all caches" $ do entries <- listDirectory cacheDir mapM_ (\e -> removeDirectoryRecursive (cacheDir </> e)) entries++-- | Try an IO action, converting exceptions to a prefixed error.+tryE :: Text -> IO a -> ExceptT Text IO a+tryE prefix action = do+ result <- liftIO $ try action case result of Left (ex :: SomeException) ->- pure $ Left $ "Failed to clear all caches: " <> T.pack (show ex)- Right () ->- pure $ Right ()+ throwE $ prefix <> ": " <> T.pack (show ex)+ Right a -> pure a -- | Clean up PostgreSQL runtime files from a data directory. --
src/EphemeralPg/Internal/Directory.hs view
@@ -18,10 +18,13 @@ import Control.Concurrent (threadDelay) import Control.Exception (SomeException, catch, try) import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.Text (Text) import Data.Text qualified as T import EphemeralPg.Config (DirectoryConfig (..), maxSocketPathLength) import EphemeralPg.Error (ConfigError (..), ResourceError (..), StartError (..))+import EphemeralPg.Internal.Except (onError) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist,@@ -34,36 +37,22 @@ -- -- Returns the path and whether it should be cleaned up. createTempDataDirectory :: Maybe FilePath -> IO (Either StartError (FilePath, Bool))-createTempDataDirectory mTempRoot = do- tmpRoot <- maybe getTemporaryDirectory pure mTempRoot- result <- try $ createTempDirectory tmpRoot "ephpg-data-"- case result of- Left (e :: SomeException) ->- pure $ Left $ ResourceError $ DirectoryCreationFailed tmpRoot (T.pack $ show e)- Right path ->- pure $ Right (path, True)+createTempDataDirectory mTempRoot = runExceptT $ do+ tmpRoot <- liftIO $ maybe getTemporaryDirectory pure mTempRoot+ path <- tryDirCreate tmpRoot $ createTempDirectory tmpRoot "ephpg-data-"+ pure (path, True) -- | Create a temporary socket directory. -- -- Uses short names to avoid Unix socket path length limits. -- Returns the path and whether it should be cleaned up. createTempSocketDirectory :: Maybe FilePath -> IO (Either StartError (FilePath, Bool))-createTempSocketDirectory mTempRoot = do- tmpRoot <- maybe getTemporaryDirectory pure mTempRoot- -- Use very short prefix to minimize socket path length- result <- try $ createTempDirectory tmpRoot "pg-"- case result of- Left (e :: SomeException) ->- pure $ Left $ ResourceError $ DirectoryCreationFailed tmpRoot (T.pack $ show e)- Right path -> do- -- Validate the socket path length- case validateSocketPath path of- Left err -> do- -- Clean up the directory we just created- removeDirectoryIfExists path- pure $ Left err- Right () ->- pure $ Right (path, True)+createTempSocketDirectory mTempRoot = runExceptT $ do+ tmpRoot <- liftIO $ maybe getTemporaryDirectory pure mTempRoot+ path <- tryDirCreate tmpRoot $ createTempDirectory tmpRoot "pg-"+ either throwE pure (validateSocketPath path)+ `onError` removeDirectoryIfExists path+ pure (path, True) -- | Resolve a directory configuration to an actual path. --@@ -81,13 +70,9 @@ case config of DirectoryTemporary -> creator mTempRoot- DirectoryPermanent path -> do- result <- try $ createDirectoryIfMissing True path- case result of- Left (e :: SomeException) ->- pure $ Left $ ResourceError $ DirectoryCreationFailed path (T.pack $ show e)- Right () ->- pure $ Right (path, False)+ DirectoryPermanent path -> runExceptT $ do+ tryDirCreate path $ createDirectoryIfMissing True path+ pure (path, False) -- | Validate that a socket path won't exceed Unix limits. --@@ -126,22 +111,22 @@ retryRemoveDirectory :: FilePath -> Int -> Int -> IO (Either Text ()) retryRemoveDirectory path maxRetries delayMicros = go maxRetries where- go 0 = do- result <- try $ removeDirectoryRecursive path- case result of- Left (e :: SomeException) ->- pure $ Left $ "Failed after " <> T.pack (show maxRetries) <> " retries: " <> T.pack (show e)- Right () ->- pure $ Right () go n = do result <- try $ removeDirectoryRecursive path case result of- Left (_ :: SomeException) -> do- -- Wait and retry- threadDelayMicros delayMicros- go (n - 1)- Right () ->- pure $ Right ()+ Right () -> pure $ Right ()+ Left (e :: SomeException)+ | n <= 0 ->+ pure $ Left $ "Failed after " <> T.pack (show maxRetries) <> " retries: " <> T.pack (show e)+ | otherwise -> do+ threadDelay delayMicros+ go (n - 1) - threadDelayMicros :: Int -> IO ()- threadDelayMicros = threadDelay+-- | Try an IO action, converting exceptions to 'DirectoryCreationFailed'.+tryDirCreate :: FilePath -> IO a -> ExceptT StartError IO a+tryDirCreate dir action = do+ result <- liftIO $ try action+ case result of+ Left (e :: SomeException) ->+ throwE $ ResourceError $ DirectoryCreationFailed dir (T.pack $ show e)+ Right a -> pure a
src/EphemeralPg/Internal/Except.hs view
@@ -61,7 +61,7 @@ -- (socketDir, socketDirIsTemp) <- liftE (createTempSocketDirectory mRoot) -- \`onError\` when dataDirIsTemp (removeDirectoryIfExists dataDir) -- @-onError :: Startup a -> IO () -> Startup a+onError :: ExceptT e IO a -> IO () -> ExceptT e IO a onError action cleanup = catchE action $ \err -> do liftIO cleanup throwE err
src/EphemeralPg/Process/Postgres.hs view
@@ -174,7 +174,12 @@ "-t", "1" -- 1 second timeout per attempt ]- result <- try @SomeException $ runProcess $ proc pgIsReadyPath args+ result <-+ try @SomeException $+ runProcess $+ proc pgIsReadyPath args+ & setStdout nullStream+ & setStderr nullStream case result of Right ExitSuccess -> pure () _ -> do
src/EphemeralPg/Snapshot.hs view
@@ -36,6 +36,9 @@ ) where +import Control.Monad (unless, void)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE, withExceptT) import Data.Text (Text) import Data.Text qualified as T import EphemeralPg.Config (ShutdownMode (..), defaultConfig)@@ -46,6 +49,7 @@ detectCowCapability, ) import EphemeralPg.Internal.Directory (removeDirectoryIfExists)+import EphemeralPg.Internal.Except (onError) import EphemeralPg.Process.Postgres (startPostgres, stopPostgres) import System.Directory (doesDirectoryExist) import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory)@@ -67,87 +71,50 @@ -- Note: This is a relatively expensive operation and should be used -- sparingly (e.g., once after setup, not between every test). createSnapshot :: Database -> IO (Either Text Snapshot)-createSnapshot db = do- -- Stop postgres gracefully to ensure data is flushed- stopResult <- stopPostgres db.process ShutdownGraceful 30- case stopResult of- Just err -> do- -- Restart postgres and return error- _ <- restartPostgres db- pure $ Left $ "Failed to stop postgres for snapshot: " <> T.pack (show err)- Nothing -> do- -- Create snapshot directory- tmpDir <- getCanonicalTemporaryDirectory- snapshotDir <- createTempDirectory tmpDir "ephpg-snap-"-- -- Detect CoW capability- cowCapability <- detectCowCapability snapshotDir-- -- Copy data directory to snapshot- copyResult <- copyDirectory cowCapability db.dataDirectory snapshotDir-- case copyResult of- Left err -> do- removeDirectoryIfExists snapshotDir- _ <- restartPostgres db- pure $ Left $ "Failed to copy data directory: " <> err- Right () -> do- -- Clean up runtime files from the snapshot- cleanupRuntimeFiles snapshotDir-- -- Restart postgres- restartResult <- restartPostgres db- case restartResult of- Left err -> do- removeDirectoryIfExists snapshotDir- pure $ Left err- Right _newProcess ->- -- Note: We don't update the Database record with the new process- -- since Database is immutable. The caller should handle this.- pure $- Right $- Snapshot- { path = snapshotDir,- temporary = True- }+createSnapshot db = runExceptT $ do+ stopPostgresE "snapshot" db+ `onError` void (restartPostgres db)+ snapshotDir <- liftIO $ do+ tmpDir <- getCanonicalTemporaryDirectory+ createTempDirectory tmpDir "ephpg-snap-"+ cowCapability <- liftIO $ detectCowCapability snapshotDir+ withExceptT+ ("Failed to copy data directory: " <>)+ (ExceptT $ copyDirectory cowCapability db.dataDirectory snapshotDir)+ `onError` do+ removeDirectoryIfExists snapshotDir+ void $ restartPostgres db+ liftIO $ cleanupRuntimeFiles snapshotDir+ -- Note: We don't update the Database record with the new process+ -- since Database is immutable. The caller should handle this.+ _ <-+ ExceptT (restartPostgres db)+ `onError` removeDirectoryIfExists snapshotDir+ pure+ Snapshot+ { path = snapshotDir,+ temporary = True+ } -- | Restore a database from a snapshot. -- -- This stops postgres, replaces the data directory with the snapshot, -- then restarts postgres. The original database content is lost. restoreSnapshot :: Snapshot -> Database -> IO (Either Text ())-restoreSnapshot snapshot db = do- -- Verify snapshot exists- exists <- doesDirectoryExist snapshot.path- if not exists- then pure $ Left $ "Snapshot not found: " <> T.pack snapshot.path- else do- -- Stop postgres- stopResult <- stopPostgres db.process ShutdownGraceful 30- case stopResult of- Just err -> do- _ <- restartPostgres db- pure $ Left $ "Failed to stop postgres for restore: " <> T.pack (show err)- Nothing -> do- -- Remove current data directory- removeDirectoryIfExists db.dataDirectory-- -- Detect CoW capability- cowCapability <- detectCowCapability snapshot.path-- -- Copy snapshot to data directory- copyResult <- copyDirectory cowCapability snapshot.path db.dataDirectory-- case copyResult of- Left err -> do- -- This is bad - data directory is in inconsistent state- pure $ Left $ "Failed to restore snapshot, database may be corrupted: " <> err- Right () -> do- -- Restart postgres- restartResult <- restartPostgres db- case restartResult of- Left err -> pure $ Left err- Right _newProcess -> pure $ Right ()+restoreSnapshot snapshot db = runExceptT $ do+ exists <- liftIO $ doesDirectoryExist snapshot.path+ unless exists $+ throwE $+ "Snapshot not found: " <> T.pack snapshot.path+ stopPostgresE "restore" db+ `onError` void (restartPostgres db)+ liftIO $ removeDirectoryIfExists db.dataDirectory+ cowCapability <- liftIO $ detectCowCapability snapshot.path+ withExceptT+ ("Failed to restore snapshot, database may be corrupted: " <>)+ (ExceptT $ copyDirectory cowCapability snapshot.path db.dataDirectory)+ _ <- ExceptT $ restartPostgres db+ pure () -- | Delete a snapshot. --@@ -157,6 +124,15 @@ if snapshot.temporary then removeDirectoryIfExists snapshot.path else pure ()++-- | Stop postgres, failing with a descriptive error.+stopPostgresE :: Text -> Database -> ExceptT Text IO ()+stopPostgresE purpose db = do+ stopResult <- liftIO $ stopPostgres db.process ShutdownGraceful 30+ case stopResult of+ Just err ->+ throwE $ "Failed to stop postgres for " <> purpose <> ": " <> T.pack (show err)+ Nothing -> pure () -- | Restart postgres after a snapshot/restore operation. restartPostgres :: Database -> IO (Either Text PostgresProcess)