ephemeral-pg 0.1.0.0 → 0.2.0.0
raw patch · 15 files changed
+347/−361 lines, 15 files
Files
- CHANGELOG.md +19/−0
- README.md +26/−19
- ephemeral-pg.cabal +6/−2
- src/EphemeralPg.hs +46/−56
- src/EphemeralPg/Config.hs +73/−73
- src/EphemeralPg/Database.hs +26/−53
- src/EphemeralPg/Dump.hs +32/−32
- src/EphemeralPg/Error.hs +25/−32
- src/EphemeralPg/Internal/Cache.hs +21/−21
- src/EphemeralPg/Internal/Directory.hs +3/−3
- src/EphemeralPg/Process/CreateDb.hs +6/−6
- src/EphemeralPg/Process/InitDb.hs +7/−7
- src/EphemeralPg/Process/Postgres.hs +25/−25
- src/EphemeralPg/Snapshot.hs +18/−18
- test/Main.hs +14/−14
CHANGELOG.md view
@@ -1,5 +1,24 @@ # Changelog +## 0.2.0.0++### Breaking Changes++- Remove Hungarian-style field prefixes from all record types using+ `NoFieldSelectors`, `DuplicateRecordFields`, and `OverloadedRecordDot`+ - `Config`: `configPort` → `port`, `configDatabaseName` → `databaseName`, etc.+ - `Database`: `dbPort` → `port`, `dbDataDirectory` → `dataDirectory`, etc.+ - `PostgresProcess`: `postgresProcess` → `process`, `postgresPid` → `pid`+ - `DumpOptions`: `dumpFormat` → `format`, `dumpCreateDb` → `createDb`, etc.+ - `Snapshot`: `snapshotPath` → `path`, `snapshotTemporary` → `temporary`+ - `CacheKey`: `cacheKeyPgVersion` → `pgVersion`, `cacheKeyConfigHash` → `configHash`+ - `CacheConfig`: `cacheConfigRoot` → `root`, `cacheConfigCow` → `cow`, `cacheConfigEnabled` → `enabled`+ - Error types: all prefixed fields renamed similarly+- Remove accessor functions from `Database` module (`dataDirectory`, `socketDirectory`,+ `port`, `databaseName`, `user`); use dot syntax instead (e.g., `db.port`)+- `Database` is now exported with `(..)` from `EphemeralPg` for `HasField` resolution+- Consumers should enable `OverloadedRecordDot` to access record fields+ ## 0.1.0.0 - Initial release
README.md view
@@ -93,8 +93,8 @@ customTest :: IO () customTest = do let config = Pg.defaultConfig- { Config.configDatabaseName = "mytest"- , Config.configPostgresSettings =+ { Config.databaseName = "mytest"+ , Config.postgresSettings = [ ("log_statement", "'all'") , ("log_min_duration_statement", "0") ]@@ -173,7 +173,7 @@ Left err -> putStrLn $ Pg.renderStartError err Right db -> do -- Use the database...- putStrLn $ "Database running on port: " <> show (Pg.port db)+ putStrLn $ "Database running on port: " <> show db.port -- Clean up when done Pg.stop db@@ -206,7 +206,7 @@ restartTest :: IO () restartTest = do result <- Pg.with \db -> do- let port1 = Pg.port db+ let port1 = db.port -- Restart the server restartResult <- Pg.restart db@@ -214,7 +214,7 @@ Left err -> fail $ "Restart failed: " <> show err Right db' -> do -- Server restarted, data preserved- let port2 = Pg.port db'+ let port2 = db'.port -- Port remains the same pure (port1 == port2) @@ -290,15 +290,15 @@ | Field | Type | Default | Description | |-------|------|---------|-------------|-| `configDatabaseName` | `Text` | `"test"` | Name of the database to create |-| `configUser` | `Text` | Current user | PostgreSQL username |-| `configPassword` | `Text` | `""` | PostgreSQL password (empty = trust auth) |-| `configPort` | `Last Int` | Auto-assigned | Port number (finds free port if not specified) |-| `configDataDirectory` | `DirectoryConfig` | Temporary | Data directory location |-| `configSocketDirectory` | `DirectoryConfig` | Temporary | Unix socket directory |-| `configTemporaryRoot` | `Last FilePath` | System temp | Root for temporary directories |-| `configPostgresSettings` | `[(Text, Text)]` | Optimized defaults | postgresql.conf settings |-| `configInitDbArgs` | `[Text]` | `[]` | Additional initdb arguments |+| `databaseName` | `Text` | `"postgres"` | Name of the database to create |+| `user` | `Text` | Current user | PostgreSQL username |+| `password` | `Maybe Text` | `Nothing` | PostgreSQL password (`Nothing` = trust auth) |+| `port` | `Last Word16` | Auto-assigned | Port number (finds free port if not specified) |+| `dataDirectory` | `DirectoryConfig` | Temporary | Data directory location |+| `socketDirectory` | `DirectoryConfig` | Temporary | Unix socket directory |+| `temporaryRoot` | `Last FilePath` | System temp | Root for temporary directories |+| `postgresSettings` | `[(Text, Text)]` | Optimized defaults | postgresql.conf settings |+| `initDbArgs` | `[Text]` | `[]` | Additional initdb arguments | ### Pre-configured Configs @@ -341,14 +341,21 @@ ### Database Handle +Access database fields using dot syntax (requires `OverloadedRecordDot`):+ ```haskell+db.port :: Word16 -- Port number+db.databaseName :: Text -- Database name+db.user :: Text -- Username+db.dataDirectory :: FilePath -- Data directory path+db.socketDirectory :: FilePath -- Socket directory path+```++Computed connection helpers:++```haskell connectionSettings :: Database -> Settings -- hasql Settings connectionString :: Database -> Text -- libpq connection string-dataDirectory :: Database -> FilePath-socketDirectory :: Database -> FilePath-port :: Database -> Int-databaseName :: Database -> Text-user :: Database -> Text ``` ### Cache Management
ephemeral-pg.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: ephemeral-pg-version: 0.1.0.0+version: 0.2.0.0 synopsis: Temporary PostgreSQL databases for testing description: A modern library for creating temporary PostgreSQL instances for testing.@@ -27,7 +27,6 @@ -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns- -Wpartial-fields -Wredundant-constraints -Wunused-packages @@ -73,7 +72,10 @@ BlockArguments DeriveAnyClass DerivingStrategies+ DuplicateRecordFields LambdaCase+ NoFieldSelectors+ OverloadedRecordDot OverloadedStrings RecordWildCards StrictData@@ -94,4 +96,6 @@ default-extensions: BlockArguments+ DuplicateRecordFields+ OverloadedRecordDot OverloadedStrings
src/EphemeralPg.hs view
@@ -28,21 +28,16 @@ -- -- main :: IO () -- main = do--- let config = Pg.'defaultConfig' { Pg.configDatabaseName = "testdb" }+-- let config = Pg.'defaultConfig' { Pg.databaseName = "testdb" } -- Pg.'withConfig' config $ \\db -> do -- -- Use the database... -- pure () -- @ module EphemeralPg ( -- * Database Handle- Database,+ Database (..), connectionSettings, connectionString,- dataDirectory,- socketDirectory,- port,- databaseName,- user, -- * Lifecycle Management with,@@ -94,11 +89,6 @@ ( Database (..), connectionSettings, connectionString,- dataDirectory,- databaseName,- port,- socketDirectory,- user, ) import EphemeralPg.Error ( StartError (..),@@ -148,7 +138,7 @@ -- | Like 'with' but with custom configuration. -- -- @--- let config = 'defaultConfig' { configDatabaseName = "testdb" }+-- let config = 'defaultConfig' { databaseName = "testdb" } -- 'withConfig' config $ \\db -> do -- -- Use the database... -- @@@ -177,13 +167,13 @@ -- @ start :: Config -> IO (Either StartError Database) start config = runStartup $ do- let mTempRoot = getLast (configTemporaryRoot config)+ let mTempRoot = getLast config.temporaryRoot -- Create data directory (dataDir, dataDirIsTemp) <- liftE $ resolveDirectory- (configDataDirectory config)+ config.dataDirectory mTempRoot "data" createTempDataDirectory@@ -192,7 +182,7 @@ (socketDir, socketDirIsTemp) <- liftE ( resolveDirectory- (configSocketDirectory config)+ config.socketDirectory mTempRoot "socket" createTempSocketDirectory@@ -218,7 +208,7 @@ `onError` cleanup dataDirIsTemp dataDir socketDirIsTemp socketDir -- Create database- let dbName = configDatabaseName config+ let dbName = config.databaseName () <- liftE (runCreateDb config socketDir p username dbName) `onError` do@@ -236,16 +226,16 @@ pure $ Database- { dbDataDirectory = dataDir,- dbSocketDirectory = socketDir,- dbPort = p,- dbDatabaseName = dbName,- dbUser = username,- dbPassword = configPassword config,- dbProcess = pgProcess,- dbCleanup = cleanupAction,- dbDataDirIsTemp = dataDirIsTemp,- dbSocketDirIsTemp = socketDirIsTemp+ { dataDirectory = dataDir,+ socketDirectory = socketDir,+ port = p,+ databaseName = dbName,+ user = username,+ password = config.password,+ process = pgProcess,+ cleanup = cleanupAction,+ dataDirIsTemp = dataDirIsTemp,+ socketDirIsTemp = socketDirIsTemp } where cleanup :: Bool -> FilePath -> Bool -> FilePath -> IO ()@@ -255,13 +245,13 @@ -- | Get port from config or find a free one. getPort :: Config -> IO (Either StartError Word16)-getPort config = case getLast (configPort config) of+getPort config = case getLast config.port of Just p -> pure $ Right p Nothing -> findFreePort -- | Get username from config or current user. getUsername :: Config -> IO Text-getUsername config = case configUser config of+getUsername config = case config.user of "" -> getCurrentUser u -> pure u @@ -277,10 +267,10 @@ let timeoutSecs = defaultShutdownTimeoutSeconds -- Stop postgres- _ <- stopPostgres (dbProcess db) mode timeoutSecs+ _ <- stopPostgres db.process mode timeoutSecs -- Run cleanup (removes temp directories)- dbCleanup db+ db.cleanup -- | Restart a database. --@@ -306,7 +296,7 @@ restart db = runStartup $ do -- Stop postgres gracefully liftIO $ do- _ <- stopPostgres (dbProcess db) ShutdownGraceful defaultShutdownTimeoutSeconds+ _ <- stopPostgres db.process ShutdownGraceful defaultShutdownTimeoutSeconds pure () -- Start postgres again with the same configuration@@ -314,12 +304,12 @@ liftE $ startPostgres defaultConfig- (dbDataDirectory db)- (dbSocketDirectory db)- (dbPort db)- (dbUser db)+ db.dataDirectory+ db.socketDirectory+ db.port+ db.user - pure $ db {dbProcess = newProcess}+ pure $ db {process = newProcess} -- | Like 'with' but uses initdb caching for faster startup. --@@ -351,7 +341,7 @@ -- from the cache. Otherwise, initdb is run and the result is cached. startCached :: Config -> CacheConfig -> IO (Either StartError Database) startCached config cacheConfig- | not (cacheConfigEnabled cacheConfig) = start config+ | not cacheConfig.enabled = start config | otherwise = do -- Get cache key keyResult <- getCacheKey config@@ -361,7 +351,7 @@ start config Right cacheKey -> do -- Check if cache exists- cached <- isCached cacheKey (cacheConfigRoot cacheConfig)+ cached <- isCached cacheKey cacheConfig.root if cached then startFromCache config cacheConfig cacheKey else startAndCache config cacheConfig cacheKey@@ -369,7 +359,7 @@ -- | Start from an existing cache. startFromCache :: Config -> CacheConfig -> CacheKey -> IO (Either StartError Database) startFromCache config cacheConfig cacheKey = do- let mTempRoot = getLast (configTemporaryRoot config)+ let mTempRoot = getLast config.temporaryRoot -- Create temporary data directory (to get the path) dataResult <- createTempDataDirectory mTempRoot@@ -381,7 +371,7 @@ removeDirectoryIfExists dataDir -- Restore from cache- restoreResult <- restoreFromCache cacheKey dataDir (cacheConfigRoot cacheConfig)+ restoreResult <- restoreFromCache cacheKey dataDir cacheConfig.root case restoreResult of Left _err -> do -- Cache restore failed, fall back to non-cached start@@ -401,7 +391,7 @@ -- Cache is created after initdb but before postgres starts. startAndCache :: Config -> CacheConfig -> CacheKey -> IO (Either StartError Database) startAndCache config cacheConfig cacheKey = do- let mTempRoot = getLast (configTemporaryRoot config)+ let mTempRoot = getLast config.temporaryRoot -- Create data directory dataResult <- createTempDataDirectory mTempRoot@@ -418,7 +408,7 @@ -- Cache the data directory NOW (before postgres starts) -- This ensures the cache contains only clean initdb output when dataDirIsTemp $ do- _ <- createCache cacheKey dataDir (cacheConfigRoot cacheConfig)+ _ <- createCache cacheKey dataDir cacheConfig.root pure () -- Continue with normal startup from the initialized data directory@@ -427,13 +417,13 @@ -- | Continue startup from an existing data directory. continueStartup :: Config -> FilePath -> Bool -> IO (Either StartError Database) continueStartup config dataDir dataDirIsTemp = runStartup $ do- let mTempRoot = getLast (configTemporaryRoot config)+ let mTempRoot = getLast config.temporaryRoot -- Create socket directory (socketDir, socketDirIsTemp) <- liftE ( resolveDirectory- (configSocketDirectory config)+ config.socketDirectory mTempRoot "socket" createTempSocketDirectory@@ -454,7 +444,7 @@ `onError` cleanupDirs dataDirIsTemp dataDir socketDirIsTemp socketDir -- Create database- let dbName = configDatabaseName config+ let dbName = config.databaseName () <- liftE (runCreateDb config socketDir p username dbName) `onError` do@@ -471,16 +461,16 @@ pure $ Database- { dbDataDirectory = dataDir,- dbSocketDirectory = socketDir,- dbPort = p,- dbDatabaseName = dbName,- dbUser = username,- dbPassword = configPassword config,- dbProcess = pgProcess,- dbCleanup = cleanupAction,- dbDataDirIsTemp = dataDirIsTemp,- dbSocketDirIsTemp = socketDirIsTemp+ { dataDirectory = dataDir,+ socketDirectory = socketDir,+ port = p,+ databaseName = dbName,+ user = username,+ password = config.password,+ process = pgProcess,+ cleanup = cleanupAction,+ dataDirIsTemp = dataDirIsTemp,+ socketDirIsTemp = socketDirIsTemp } where cleanupDirs :: Bool -> FilePath -> Bool -> FilePath -> IO ()
src/EphemeralPg/Config.hs view
@@ -6,7 +6,7 @@ -- Configurations can be combined using the 'Semigroup' instance: -- -- @--- myConfig = 'defaultConfig' <> mempty { configDatabaseName = "testdb" }+-- myConfig = 'defaultConfig' <> mempty { databaseName = "testdb" } -- @ module EphemeralPg.Config ( -- * Configuration type@@ -60,65 +60,65 @@ -- for 'Last' fields. data Config = Config { -- | Port to listen on. 'Nothing' means auto-select a free port.- configPort :: Last Word16,+ port :: Last Word16, -- | Database name to create.- configDatabaseName :: Text,+ databaseName :: Text, -- | Username for the database.- configUser :: Text,+ user :: Text, -- | Optional password.- configPassword :: Maybe Text,+ password :: Maybe Text, -- | Data directory configuration.- configDataDirectory :: DirectoryConfig,+ dataDirectory :: DirectoryConfig, -- | Socket directory configuration.- configSocketDirectory :: DirectoryConfig,+ socketDirectory :: DirectoryConfig, -- | Root directory for temporary files.- configTemporaryRoot :: Last FilePath,+ temporaryRoot :: Last FilePath, -- | postgresql.conf settings.- configPostgresSettings :: [(Text, Text)],+ postgresSettings :: [(Text, Text)], -- | Additional arguments for initdb.- configInitDbArgs :: [Text],+ initDbArgs :: [Text], -- | Additional arguments for postgres server.- configPostgresArgs :: [Text],+ postgresArgs :: [Text], -- | Additional arguments for createdb.- configCreateDbArgs :: [Text],+ createDbArgs :: [Text], -- | Timeout waiting for postgres to accept connections (seconds).- configConnectionTimeoutSeconds :: Last Int,+ connectionTimeoutSeconds :: Last Int, -- | Timeout waiting for graceful shutdown (seconds).- configShutdownTimeoutSeconds :: Last Int,+ shutdownTimeoutSeconds :: Last Int, -- | How to shut down postgres.- configShutdownMode :: Last ShutdownMode,+ shutdownMode :: Last ShutdownMode, -- | Handle for postgres stdout (Nothing = discard).- configStdout :: Last (Maybe Handle),+ stdout :: Last (Maybe Handle), -- | Handle for postgres stderr (Nothing = discard).- configStderr :: Last (Maybe Handle)+ stderr :: Last (Maybe Handle) } deriving stock (Show) instance Semigroup Config where a <> b = Config- { configPort = configPort a <> configPort b,- configDatabaseName =- if configDatabaseName b == ""- then configDatabaseName a- else configDatabaseName b,- configUser =- if configUser b == ""- then configUser a- else configUser b,- configPassword = configPassword b <|> configPassword a,- configDataDirectory = combineDir (configDataDirectory a) (configDataDirectory b),- configSocketDirectory = combineDir (configSocketDirectory a) (configSocketDirectory b),- configTemporaryRoot = configTemporaryRoot a <> configTemporaryRoot b,- configPostgresSettings = configPostgresSettings a <> configPostgresSettings b,- configInitDbArgs = configInitDbArgs a <> configInitDbArgs b,- configPostgresArgs = configPostgresArgs a <> configPostgresArgs b,- configCreateDbArgs = configCreateDbArgs a <> configCreateDbArgs b,- configConnectionTimeoutSeconds = configConnectionTimeoutSeconds a <> configConnectionTimeoutSeconds b,- configShutdownTimeoutSeconds = configShutdownTimeoutSeconds a <> configShutdownTimeoutSeconds b,- configShutdownMode = configShutdownMode a <> configShutdownMode b,- configStdout = configStdout a <> configStdout b,- configStderr = configStderr a <> configStderr b+ { port = a.port <> b.port,+ databaseName =+ if b.databaseName == ""+ then a.databaseName+ else b.databaseName,+ user =+ if b.user == ""+ then a.user+ else b.user,+ password = b.password <|> a.password,+ dataDirectory = combineDir a.dataDirectory b.dataDirectory,+ socketDirectory = combineDir a.socketDirectory b.socketDirectory,+ temporaryRoot = a.temporaryRoot <> b.temporaryRoot,+ postgresSettings = a.postgresSettings <> b.postgresSettings,+ initDbArgs = a.initDbArgs <> b.initDbArgs,+ postgresArgs = a.postgresArgs <> b.postgresArgs,+ createDbArgs = a.createDbArgs <> b.createDbArgs,+ connectionTimeoutSeconds = a.connectionTimeoutSeconds <> b.connectionTimeoutSeconds,+ shutdownTimeoutSeconds = a.shutdownTimeoutSeconds <> b.shutdownTimeoutSeconds,+ shutdownMode = a.shutdownMode <> b.shutdownMode,+ stdout = a.stdout <> b.stdout,+ stderr = a.stderr <> b.stderr } where combineDir DirectoryTemporary d = d@@ -132,22 +132,22 @@ instance Monoid Config where mempty = Config- { configPort = Last Nothing,- configDatabaseName = "",- configUser = "",- configPassword = Nothing,- configDataDirectory = DirectoryTemporary,- configSocketDirectory = DirectoryTemporary,- configTemporaryRoot = Last Nothing,- configPostgresSettings = [],- configInitDbArgs = [],- configPostgresArgs = [],- configCreateDbArgs = [],- configConnectionTimeoutSeconds = Last Nothing,- configShutdownTimeoutSeconds = Last Nothing,- configShutdownMode = Last Nothing,- configStdout = Last Nothing,- configStderr = Last Nothing+ { port = Last Nothing,+ databaseName = "",+ user = "",+ password = Nothing,+ dataDirectory = DirectoryTemporary,+ socketDirectory = DirectoryTemporary,+ temporaryRoot = Last Nothing,+ postgresSettings = [],+ initDbArgs = [],+ postgresArgs = [],+ createDbArgs = [],+ connectionTimeoutSeconds = Last Nothing,+ shutdownTimeoutSeconds = Last Nothing,+ shutdownMode = Last Nothing,+ stdout = Last Nothing,+ stderr = Last Nothing } -- | Maximum socket path length for Unix domain sockets.@@ -208,22 +208,22 @@ defaultConfig :: Config defaultConfig = Config- { configPort = Last Nothing,- configDatabaseName = "postgres",- configUser = "", -- Will use current user- configPassword = Nothing,- configDataDirectory = DirectoryTemporary,- configSocketDirectory = DirectoryTemporary,- configTemporaryRoot = Last Nothing,- configPostgresSettings = defaultPostgresSettings,- configInitDbArgs = defaultInitDbArgs,- configPostgresArgs = [],- configCreateDbArgs = [],- configConnectionTimeoutSeconds = Last (Just defaultConnectionTimeoutSeconds),- configShutdownTimeoutSeconds = Last (Just defaultShutdownTimeoutSeconds),- configShutdownMode = Last (Just ShutdownGraceful),- configStdout = Last (Just Nothing), -- Discard by default- configStderr = Last (Just Nothing) -- Discard by default+ { port = Last Nothing,+ databaseName = "postgres",+ user = "", -- Will use current user+ password = Nothing,+ dataDirectory = DirectoryTemporary,+ socketDirectory = DirectoryTemporary,+ temporaryRoot = Last Nothing,+ postgresSettings = defaultPostgresSettings,+ initDbArgs = defaultInitDbArgs,+ postgresArgs = [],+ createDbArgs = [],+ connectionTimeoutSeconds = Last (Just defaultConnectionTimeoutSeconds),+ shutdownTimeoutSeconds = Last (Just defaultShutdownTimeoutSeconds),+ shutdownMode = Last (Just ShutdownGraceful),+ stdout = Last (Just Nothing), -- Discard by default+ stderr = Last (Just Nothing) -- Discard by default } -- | Configuration with verbose PostgreSQL logging.@@ -236,7 +236,7 @@ verboseConfig :: Config verboseConfig = mempty- { configPostgresSettings =+ { postgresSettings = [ ("log_min_duration_statement", "'0'"), ("log_min_messages", "'DEBUG1'"), ("log_min_error_statement", "'DEBUG1'"),@@ -260,7 +260,7 @@ autoExplainConfig :: Int -> Config autoExplainConfig minDurationMs = mempty- { configPostgresSettings =+ { postgresSettings = [ ("shared_preload_libraries", "'auto_explain'"), ("auto_explain.log_min_duration", "'" <> ms <> "'"), ("auto_explain.log_analyze", "'on'")
src/EphemeralPg/Database.hs view
@@ -10,13 +10,6 @@ -- * Connection information connectionSettings, connectionString,-- -- * Accessors- dataDirectory,- socketDirectory,- port,- databaseName,- user, ) where @@ -30,14 +23,14 @@ -- | Handle to a running PostgreSQL server process. data PostgresProcess = PostgresProcess { -- | The typed-process handle- postgresProcess :: Process () () (),+ process :: Process () () (), -- | Process ID for signal handling- postgresPid :: CPid+ pid :: CPid } instance Show PostgresProcess where- show PostgresProcess {postgresPid} =- "PostgresProcess { pid = " <> show postgresPid <> " }"+ show pp =+ "PostgresProcess { pid = " <> show pp.pid <> " }" -- | A running PostgreSQL database instance. --@@ -45,37 +38,37 @@ -- ready to accept connections immediately after creation. data Database = Database { -- | Path to the PostgreSQL data directory- dbDataDirectory :: FilePath,+ dataDirectory :: FilePath, -- | Path to the Unix socket directory- dbSocketDirectory :: FilePath,+ socketDirectory :: FilePath, -- | Port number the server is listening on- dbPort :: Word16,+ port :: Word16, -- | Name of the database- dbDatabaseName :: Text,+ databaseName :: Text, -- | Username for connections- dbUser :: Text,+ user :: Text, -- | Optional password- dbPassword :: Maybe Text,+ password :: Maybe Text, -- | Handle to the running postgres process- dbProcess :: PostgresProcess,+ process :: PostgresProcess, -- | Cleanup action (removes temp directories if needed)- dbCleanup :: IO (),+ cleanup :: IO (), -- | Whether data directory is temporary- dbDataDirIsTemp :: Bool,+ dataDirIsTemp :: Bool, -- | Whether socket directory is temporary- dbSocketDirIsTemp :: Bool+ socketDirIsTemp :: Bool } instance Show Database where show db = "Database { port = "- <> show (dbPort db)+ <> show db.port <> ", database = "- <> show (dbDatabaseName db)+ <> show db.databaseName <> ", user = "- <> show (dbUser db)+ <> show db.user <> ", dataDir = "- <> show (dbDataDirectory db)+ <> show db.dataDirectory <> " }" -- | Get hasql connection settings for this database.@@ -93,10 +86,10 @@ connectionSettings :: Database -> Settings.Settings connectionSettings db = mconcat- [ Settings.hostAndPort (T.pack $ dbSocketDirectory db) (dbPort db),- Settings.dbname (dbDatabaseName db),- Settings.user (dbUser db),- maybe mempty Settings.password (dbPassword db)+ [ Settings.hostAndPort (T.pack db.socketDirectory) db.port,+ Settings.dbname db.databaseName,+ Settings.user db.user,+ maybe mempty Settings.password db.password ] -- | Get a libpq-compatible connection string.@@ -107,28 +100,8 @@ connectionString :: Database -> Text connectionString db = T.unwords- [ "host=" <> T.pack (dbSocketDirectory db),- "port=" <> T.pack (show $ dbPort db),- "dbname=" <> dbDatabaseName db,- "user=" <> dbUser db+ [ "host=" <> T.pack db.socketDirectory,+ "port=" <> T.pack (show db.port),+ "dbname=" <> db.databaseName,+ "user=" <> db.user ]---- | Get the data directory path.-dataDirectory :: Database -> FilePath-dataDirectory = dbDataDirectory---- | Get the socket directory path.-socketDirectory :: Database -> FilePath-socketDirectory = dbSocketDirectory---- | Get the port number.-port :: Database -> Word16-port = dbPort---- | Get the database name.-databaseName :: Database -> Text-databaseName = dbDatabaseName---- | Get the username.-user :: Database -> Text-user = dbUser
src/EphemeralPg/Dump.hs view
@@ -65,17 +65,17 @@ -- | Options for pg_dump. data DumpOptions = DumpOptions { -- | Output format (default: DumpPlain)- dumpFormat :: DumpFormat,+ format :: DumpFormat, -- | Include CREATE DATABASE command- dumpCreateDb :: Bool,+ createDb :: Bool, -- | Schema only (no data)- dumpSchemaOnly :: Bool,+ schemaOnly :: Bool, -- | Data only (no schema)- dumpDataOnly :: Bool,+ dataOnly :: Bool, -- | Include specific tables (empty = all)- dumpTables :: [Text],+ tables :: [Text], -- | Exclude specific tables- dumpExcludeTables :: [Text]+ excludeTables :: [Text] } deriving stock (Eq, Show) @@ -83,12 +83,12 @@ defaultDumpOptions :: DumpOptions defaultDumpOptions = DumpOptions- { dumpFormat = DumpPlain,- dumpCreateDb = False,- dumpSchemaOnly = False,- dumpDataOnly = False,- dumpTables = [],- dumpExcludeTables = []+ { format = DumpPlain,+ createDb = False,+ schemaOnly = False,+ dataOnly = False,+ tables = [],+ excludeTables = [] } -- | Dump a database to a file.@@ -127,7 +127,7 @@ -- Only works with DumpPlain format. dumpToText :: Database -> DumpOptions -> IO (Either Text Text) dumpToText db opts = do- if dumpFormat opts /= DumpPlain+ if opts.format /= DumpPlain then pure $ Left "dumpToText only works with DumpPlain format" else do mPgDump <- findExecutable "pg_dump"@@ -167,13 +167,13 @@ Just psqlPath -> do let args = [ "-h",- T.pack $ dbSocketDirectory db,+ T.pack db.socketDirectory, "-p",- T.pack $ show $ dbPort db,+ T.pack $ show db.port, "-U",- dbUser db,+ db.user, "-d",- dbDatabaseName db,+ db.databaseName, "-f", T.pack inputPath, "-v",@@ -211,13 +211,13 @@ Just psqlPath -> do let args = [ "-h",- T.pack $ dbSocketDirectory db,+ T.pack db.socketDirectory, "-p",- T.pack $ show $ dbPort db,+ T.pack $ show db.port, "-U",- dbUser db,+ db.user, "-d",- dbDatabaseName db,+ db.databaseName, "-c", sqlText, "-v",@@ -250,13 +250,13 @@ buildDumpArgs :: Database -> DumpOptions -> [Text] buildDumpArgs db opts = [ "-h",- T.pack $ dbSocketDirectory db,+ T.pack db.socketDirectory, "-p",- T.pack $ show $ dbPort db,+ T.pack $ show db.port, "-U",- dbUser db,+ db.user, "-d",- dbDatabaseName db+ db.databaseName ] <> formatArg <> createDbArg@@ -265,28 +265,28 @@ <> tableArgs <> excludeTableArgs where- formatArg = case dumpFormat opts of+ formatArg = case opts.format of DumpPlain -> ["-Fp"] DumpCustom -> ["-Fc"] DumpDirectory -> ["-Fd"] DumpTar -> ["-Ft"] createDbArg =- if dumpCreateDb opts then ["-C"] else []+ if opts.createDb then ["-C"] else [] schemaOnlyArg =- if dumpSchemaOnly opts then ["-s"] else []+ if opts.schemaOnly then ["-s"] else [] dataOnlyArg =- if dumpDataOnly opts then ["-a"] else []+ if opts.dataOnly then ["-a"] else [] tableArgs =- concatMap (\t -> ["-t", t]) (dumpTables opts)+ concatMap (\t -> ["-t", t]) opts.tables excludeTableArgs =- concatMap (\t -> ["-T", t]) (dumpExcludeTables opts)+ concatMap (\t -> ["-T", t]) opts.excludeTables -- | Build environment variables for pg commands. buildEnv :: Database -> [(String, String)] buildEnv db =- [("PGPASSWORD", T.unpack pw) | Just pw <- [dbPassword db]]+ [("PGPASSWORD", T.unpack pw) | Just pw <- [db.password]]
src/EphemeralPg/Error.hs view
@@ -1,14 +1,7 @@-{-# LANGUAGE NoFieldSelectors #-}-{-# OPTIONS_GHC -Wno-partial-fields #-}- -- | Error types for ephemeral-pg. -- -- This module provides a rich error hierarchy for diagnosing failures -- when starting or stopping temporary PostgreSQL databases.------ Note: We use record syntax with sum types for structured error data.--- The NoFieldSelectors extension prevents generation of partial field--- accessor functions. module EphemeralPg.Error ( -- * Top-level errors StartError (..),@@ -68,15 +61,15 @@ InitDbNotFound | -- | PostgreSQL version too old InitDbVersionMismatch- { initDbExpected :: Text,- initDbActual :: Text+ { expected :: Text,+ actual :: Text } | -- | initdb process failed InitDbFailed- { initDbExitCode :: ExitCode,- initDbStdout :: Text,- initDbStderr :: Text,- initDbCommand :: Text+ { exitCode :: ExitCode,+ stdout :: Text,+ stderr :: Text,+ command :: Text } | -- | Cannot write to data directory InitDbPermissionDenied FilePath@@ -88,17 +81,17 @@ PostgresNotFound | -- | Server process exited unexpectedly PostgresStartFailed- { pgExitCode :: ExitCode,- pgStdout :: Text,- pgStderr :: Text,- pgCommand :: Text+ { exitCode :: ExitCode,+ stdout :: Text,+ stderr :: Text,+ command :: Text } | -- | Could not connect to verify server is running PostgresConnectionFailed Text | -- | Server version doesn't match requirements PostgresVersionMismatch- { pgExpected :: Text,- pgActual :: Text+ { expected :: Text,+ actual :: Text } deriving stock (Eq, Show) @@ -108,11 +101,11 @@ CreateDbNotFound | -- | createdb process failed CreateDbFailed- { createDbExitCode :: ExitCode,- createDbStdout :: Text,- createDbStderr :: Text,- createDbCommand :: Text,- createDbName :: Text+ { exitCode :: ExitCode,+ stdout :: Text,+ stderr :: Text,+ command :: Text,+ name :: Text } | -- | Database with this name already exists DatabaseAlreadyExists Text@@ -132,9 +125,9 @@ InvalidSocketDirectory FilePath Text | -- | Socket path exceeds Unix domain socket limit SocketPathTooLong- { socketPath :: FilePath,- socketPathLength :: Int,- socketPathMaxLength :: Int+ { path :: FilePath,+ pathLength :: Int,+ pathMaxLength :: Int } | -- | Configuration options conflict with each other ConflictingConfig Text@@ -162,14 +155,14 @@ data TimeoutError = -- | Timed out waiting for PostgreSQL to accept connections ConnectionTimeout- { timeoutDurationSeconds :: Int,- timeoutHost :: Text,- timeoutPort :: Word16+ { durationSeconds :: Int,+ host :: Text,+ port :: Word16 } | -- | Timed out waiting for graceful shutdown ShutdownTimeout- { shutdownTimeoutSeconds :: Int,- shutdownPid :: Int+ { timeoutSeconds :: Int,+ pid :: Int } deriving stock (Eq, Show)
src/EphemeralPg/Internal/Cache.hs view
@@ -61,20 +61,20 @@ -- | A cache key uniquely identifies a cached initdb cluster. data CacheKey = CacheKey { -- | PostgreSQL major version (e.g., "17")- cacheKeyPgVersion :: Text,+ pgVersion :: Text, -- | Hash of configuration that affects initdb output- cacheKeyConfigHash :: Text+ configHash :: Text } deriving stock (Eq, Show) -- | Configuration for the cache system. data CacheConfig = CacheConfig { -- | Root directory for cache (default: ~/.ephemeral-pg)- cacheConfigRoot :: Maybe FilePath,+ root :: Maybe FilePath, -- | Copy-on-write capability (detected if Nothing)- cacheConfigCow :: Maybe CowCapability,+ cow :: Maybe CowCapability, -- | Whether to use caching at all- cacheConfigEnabled :: Bool+ enabled :: Bool } deriving stock (Eq, Show) @@ -82,9 +82,9 @@ defaultCacheConfig :: CacheConfig defaultCacheConfig = CacheConfig- { cacheConfigRoot = Nothing,- cacheConfigCow = Nothing,- cacheConfigEnabled = True+ { root = Nothing,+ cow = Nothing,+ enabled = True } -- | Get the cache root directory.@@ -92,14 +92,14 @@ -- Uses XDG_CACHE_HOME if available, otherwise ~/.cache/ephemeral-pg getCacheRoot :: Maybe FilePath -> IO FilePath getCacheRoot mRoot = case mRoot of- Just root -> pure root+ Just r -> pure r Nothing -> getXdgDirectory XdgCache "ephemeral-pg" -- | Ensure the cache directory structure exists. ensureCacheDirectory :: Maybe FilePath -> IO FilePath ensureCacheDirectory mRoot = do- root <- getCacheRoot mRoot- let cacheDir = root </> "cache"+ r <- getCacheRoot mRoot+ let cacheDir = r </> "cache" createDirectoryIfMissing True cacheDir pure cacheDir @@ -147,23 +147,23 @@ -- Hash the configuration elements that affect initdb output let configStr = T.unlines- [ T.unwords $ configInitDbArgs config,- T.unlines $ map (\(k, v) -> k <> "=" <> v) $ configPostgresSettings config,- configUser config+ [ T.unwords config.initDbArgs,+ T.unlines $ map (\(k, v) -> k <> "=" <> v) config.postgresSettings,+ config.user ]- let configHash = T.pack $ show $ abs $ hash (T.unpack configStr)+ let cfgHash = T.pack $ show $ abs $ hash (T.unpack configStr) pure $ Right $ CacheKey- { cacheKeyPgVersion = version,- cacheKeyConfigHash = configHash+ { pgVersion = version,+ configHash = cfgHash } -- | Get the directory path for a given cache key. getCacheDirectory :: CacheKey -> Maybe FilePath -> IO FilePath getCacheDirectory key mRoot = do cacheDir <- ensureCacheDirectory mRoot- let keyDir = T.unpack (cacheKeyPgVersion key) <> "-" <> T.unpack (cacheKeyConfigHash key)+ let keyDir = T.unpack key.pgVersion <> "-" <> T.unpack key.configHash pure $ cacheDir </> keyDir -- | Check if a cache exists for the given key.@@ -246,10 +246,10 @@ mapM_ removeIfExists runtimeFiles where removeIfExists :: FilePath -> IO ()- removeIfExists path = do- exists <- doesFileExist path+ removeIfExists fp = do+ exists <- doesFileExist fp if exists- then removeFile path `catch_` pure ()+ then removeFile fp `catch_` pure () else pure () catch_ :: IO a -> IO a -> IO a
src/EphemeralPg/Internal/Directory.hs view
@@ -99,9 +99,9 @@ Left $ ConfigError $ SocketPathTooLong- { socketPath = socketDir,- socketPathLength = estimatedLen,- socketPathMaxLength = maxSocketPathLength+ { path = socketDir,+ pathLength = estimatedLen,+ pathMaxLength = maxSocketPathLength } -- | Estimate the full socket path length.
src/EphemeralPg/Process/CreateDb.hs view
@@ -51,11 +51,11 @@ Left $ CreateDbError $ CreateDbFailed- { createDbExitCode = exitCode,- createDbStdout = stdout,- createDbStderr = stderr,- createDbCommand = T.unwords (T.pack createDbPath : args),- createDbName = dbName+ { exitCode,+ stdout,+ stderr,+ command = T.unwords (T.pack createDbPath : args),+ name = dbName } -- | Build createdb command line arguments.@@ -66,4 +66,4 @@ "--username=" <> username, dbName ]- <> configCreateDbArgs config+ <> config.createDbArgs
src/EphemeralPg/Process/InitDb.hs view
@@ -26,7 +26,7 @@ Nothing -> pure $ Left $ InitDbError InitDbNotFound Just initDbPath -> do -- Get username- username <- case configUser config of+ username <- case config.user of "" -> getCurrentUser u -> pure u @@ -46,10 +46,10 @@ Left $ InitDbError $ InitDbFailed- { initDbExitCode = exitCode,- initDbStdout = stdout,- initDbStderr = stderr,- initDbCommand = T.unwords (T.pack initDbPath : args)+ { exitCode,+ stdout,+ stderr,+ command = T.unwords (T.pack initDbPath : args) } -- | Build initdb command line arguments.@@ -58,13 +58,13 @@ [ "--pgdata=" <> T.pack dataDir, "--username=" <> username ]- <> configInitDbArgs config+ <> config.initDbArgs -- | Write postgresql.conf with the configured settings. writePostgresConf :: Config -> FilePath -> IO () writePostgresConf config dataDir = do let confPath = dataDir </> "postgresql.conf"- let settings = configPostgresSettings config+ let settings = config.postgresSettings let content = T.unlines $ map formatSetting settings T.appendFile confPath ("\n# ephemeral-pg settings\n" <> content) where
src/EphemeralPg/Process/Postgres.hs view
@@ -79,51 +79,51 @@ & setCreateGroup True -- So we can signal the whole group -- Start the process- process <-+ typedProcess <- liftIO (try $ startProcess processConfig) >>= \case Left (ex :: SomeException) -> throwE $ PostgresStartError $ PostgresStartFailed- { pgExitCode = ExitFailure 1,- pgStdout = "",- pgStderr = T.pack $ show ex,- pgCommand = T.unwords (T.pack postgresPath : args)+ { exitCode = ExitFailure 1,+ stdout = "",+ stderr = T.pack $ show ex,+ command = T.unwords (T.pack postgresPath : args) } Right p -> pure p -- Get the PID- let pHandle = unsafeProcessHandle process- pid <-+ let pHandle = unsafeProcessHandle typedProcess+ pgPid <- liftMaybe ( PostgresStartError $ PostgresStartFailed- { pgExitCode = ExitFailure 1,- pgStdout = "",- pgStderr = "Could not get process ID",- pgCommand = T.unwords (T.pack postgresPath : args)+ { exitCode = ExitFailure 1,+ stdout = "",+ stderr = "Could not get process ID",+ command = T.unwords (T.pack postgresPath : args) } ) =<< liftIO (getPid pHandle) - let postgresProcess =+ let pgProcess = PostgresProcess- { postgresProcess = process,- postgresPid = CPid $ fromIntegral pid+ { process = typedProcess,+ pid = CPid $ fromIntegral pgPid } -- Wait for the server to be ready let timeoutSecs = maybe defaultConnectionTimeoutSeconds id $- getLast (configConnectionTimeoutSeconds config)+ getLast config.connectionTimeoutSeconds liftE (waitForPostgres socketDir port timeoutSecs) `onError` do -- Kill the server since it didn't start properly- _ <- stopPostgres postgresProcess ShutdownImmediate 5+ _ <- stopPostgres pgProcess ShutdownImmediate 5 pure () - pure postgresProcess+ pure pgProcess -- | Build postgres command line arguments. buildPostgresArgs :: Config -> FilePath -> FilePath -> Word16 -> Text -> [Text]@@ -137,7 +137,7 @@ "-h", "127.0.0.1" -- Also listen on TCP for debugging ]- <> configPostgresArgs config+ <> config.postgresArgs -- | Wait for PostgreSQL to accept connections. waitForPostgres :: FilePath -> Word16 -> Int -> IO (Either StartError ())@@ -150,9 +150,9 @@ Left $ TimeoutError $ ConnectionTimeout- { timeoutDurationSeconds = timeoutSecs,- timeoutHost = T.pack socketDir,- timeoutPort = port+ { durationSeconds = timeoutSecs,+ host = T.pack socketDir,+ port } Just () -> pure $ Right () where@@ -190,7 +190,7 @@ ShutdownImmediate -> sigQUIT -- Send the signal- result <- try $ signalProcess signal postgresPid+ result <- try $ signalProcess signal pid case result of Left (_ :: SomeException) -> -- Process might already be dead@@ -198,13 +198,13 @@ Right () -> do -- Wait for the process to exit with timeout let deadline = timeoutSecs * 1000000- exitResult <- timeout deadline $ waitExitCode postgresProcess+ exitResult <- timeout deadline $ waitExitCode process case exitResult of Just _ -> pure Nothing -- Exited normally Nothing -> do -- Timeout: force kill- _ <- try @SomeException $ signalProcess sigKILL postgresPid+ _ <- try @SomeException $ signalProcess sigKILL pid -- Wait a bit more for the forced kill- _ <- timeout 5000000 $ waitExitCode postgresProcess+ _ <- timeout 5000000 $ waitExitCode process pure $ Just $ ShutdownTimedOut timeoutSecs
src/EphemeralPg/Snapshot.hs view
@@ -53,9 +53,9 @@ -- | A snapshot of database state. data Snapshot = Snapshot { -- | Path to the snapshot data directory- snapshotPath :: FilePath,+ path :: FilePath, -- | Whether to delete the snapshot when done- snapshotTemporary :: Bool+ temporary :: Bool } deriving stock (Eq, Show) @@ -69,7 +69,7 @@ createSnapshot :: Database -> IO (Either Text Snapshot) createSnapshot db = do -- Stop postgres gracefully to ensure data is flushed- stopResult <- stopPostgres (dbProcess db) ShutdownGraceful 30+ stopResult <- stopPostgres db.process ShutdownGraceful 30 case stopResult of Just err -> do -- Restart postgres and return error@@ -84,7 +84,7 @@ cowCapability <- detectCowCapability snapshotDir -- Copy data directory to snapshot- copyResult <- copyDirectory cowCapability (dbDataDirectory db) snapshotDir+ copyResult <- copyDirectory cowCapability db.dataDirectory snapshotDir case copyResult of Left err -> do@@ -107,8 +107,8 @@ pure $ Right $ Snapshot- { snapshotPath = snapshotDir,- snapshotTemporary = True+ { path = snapshotDir,+ temporary = True } -- | Restore a database from a snapshot.@@ -118,25 +118,25 @@ restoreSnapshot :: Snapshot -> Database -> IO (Either Text ()) restoreSnapshot snapshot db = do -- Verify snapshot exists- exists <- doesDirectoryExist (snapshotPath snapshot)+ exists <- doesDirectoryExist snapshot.path if not exists- then pure $ Left $ "Snapshot not found: " <> T.pack (snapshotPath snapshot)+ then pure $ Left $ "Snapshot not found: " <> T.pack snapshot.path else do -- Stop postgres- stopResult <- stopPostgres (dbProcess db) ShutdownGraceful 30+ 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 (dbDataDirectory db)+ removeDirectoryIfExists db.dataDirectory -- Detect CoW capability- cowCapability <- detectCowCapability (snapshotPath snapshot)+ cowCapability <- detectCowCapability snapshot.path -- Copy snapshot to data directory- copyResult <- copyDirectory cowCapability (snapshotPath snapshot) (dbDataDirectory db)+ copyResult <- copyDirectory cowCapability snapshot.path db.dataDirectory case copyResult of Left err -> do@@ -154,8 +154,8 @@ -- Only deletes temporary snapshots. Permanent snapshots are left alone. deleteSnapshot :: Snapshot -> IO () deleteSnapshot snapshot =- if snapshotTemporary snapshot- then removeDirectoryIfExists (snapshotPath snapshot)+ if snapshot.temporary+ then removeDirectoryIfExists snapshot.path else pure () -- | Restart postgres after a snapshot/restore operation.@@ -164,10 +164,10 @@ result <- startPostgres defaultConfig- (dbDataDirectory db)- (dbSocketDirectory db)- (dbPort db)- (dbUser db)+ db.dataDirectory+ db.socketDirectory+ db.port+ db.user case result of Left err -> pure $ Left $ "Failed to restart postgres: " <> T.pack (show err) Right newProcess -> pure $ Right newProcess
test/Main.hs view
@@ -30,7 +30,7 @@ it "can restart a database" $ do result <- Pg.with $ \db -> do -- Get initial port- let port1 = Pg.port db+ let port1 = db.port -- Restart the database restartResult <- Pg.restart db@@ -44,7 +44,7 @@ Right conn -> do Connection.release conn -- Port should be the same- Pg.port db' `shouldBe` port1+ db'.port `shouldBe` port1 result `shouldSatisfy` isRight describe "EphemeralPg caching" $ do@@ -78,27 +78,27 @@ describe "Config" $ do it "satisfies left identity (mempty <> x = x)" $ property $ \dbName ->- let x = Config.defaultConfig {Config.configDatabaseName = T.pack dbName}- in Config.configDatabaseName (mempty <> x) == Config.configDatabaseName x+ let x = Config.defaultConfig {Config.databaseName = T.pack dbName}+ in (mempty <> x).databaseName == x.databaseName it "satisfies right identity (x <> mempty = x)" $ property $ \dbName ->- let x = Config.defaultConfig {Config.configDatabaseName = T.pack dbName}- in Config.configDatabaseName (x <> mempty) == Config.configDatabaseName x+ let x = Config.defaultConfig {Config.databaseName = T.pack dbName}+ in (x <> mempty).databaseName == x.databaseName it "satisfies associativity ((x <> y) <> z = x <> (y <> z))" $ property $ \(n1, n2, n3) ->- let x = mempty {Config.configDatabaseName = T.pack n1}- y = mempty {Config.configDatabaseName = T.pack n2}- z = mempty {Config.configDatabaseName = T.pack n3}- in Config.configDatabaseName ((x <> y) <> z)- == Config.configDatabaseName (x <> (y <> z))+ let x = mempty {Config.databaseName = T.pack n1}+ y = mempty {Config.databaseName = T.pack n2}+ z = mempty {Config.databaseName = T.pack n3}+ in ((x <> y) <> z).databaseName+ == (x <> (y <> z)).databaseName it "combines postgres settings" $ do- let c1 = mempty {Config.configPostgresSettings = [("a", "1")]}- c2 = mempty {Config.configPostgresSettings = [("b", "2")]}+ let c1 = mempty {Config.postgresSettings = [("a", "1")]}+ c2 = mempty {Config.postgresSettings = [("b", "2")]} combined = c1 <> c2- Config.configPostgresSettings combined `shouldBe` [("a", "1"), ("b", "2")]+ combined.postgresSettings `shouldBe` [("a", "1"), ("b", "2")] describe "Socket path validation" $ do it "rejects paths that are too long" $ do