diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/ephemeral-pg.cabal b/ephemeral-pg.cabal --- a/ephemeral-pg.cabal +++ b/ephemeral-pg.cabal @@ -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. diff --git a/src/EphemeralPg.hs b/src/EphemeralPg.hs --- a/src/EphemeralPg.hs +++ b/src/EphemeralPg.hs @@ -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) diff --git a/src/EphemeralPg/Dump.hs b/src/EphemeralPg/Dump.hs --- a/src/EphemeralPg/Dump.hs +++ b/src/EphemeralPg/Dump.hs @@ -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] diff --git a/src/EphemeralPg/Internal/Cache.hs b/src/EphemeralPg/Internal/Cache.hs --- a/src/EphemeralPg/Internal/Cache.hs +++ b/src/EphemeralPg/Internal/Cache.hs @@ -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. -- diff --git a/src/EphemeralPg/Internal/Directory.hs b/src/EphemeralPg/Internal/Directory.hs --- a/src/EphemeralPg/Internal/Directory.hs +++ b/src/EphemeralPg/Internal/Directory.hs @@ -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 diff --git a/src/EphemeralPg/Internal/Except.hs b/src/EphemeralPg/Internal/Except.hs --- a/src/EphemeralPg/Internal/Except.hs +++ b/src/EphemeralPg/Internal/Except.hs @@ -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 diff --git a/src/EphemeralPg/Process/Postgres.hs b/src/EphemeralPg/Process/Postgres.hs --- a/src/EphemeralPg/Process/Postgres.hs +++ b/src/EphemeralPg/Process/Postgres.hs @@ -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 diff --git a/src/EphemeralPg/Snapshot.hs b/src/EphemeralPg/Snapshot.hs --- a/src/EphemeralPg/Snapshot.hs +++ b/src/EphemeralPg/Snapshot.hs @@ -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)