ephemeral-pg 0.2.2.0 → 0.3.0.0

raw patch · 15 files changed

+1222/−267 lines, 15 filesdep +filelockdep +timePVP ok

version bump matches the API change (PVP)

Dependencies added: filelock, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +29/−0
• README.md +81/−6
• ephemeral-pg.cabal +12/−1
• src/EphemeralPg.hs +135/−216
• src/EphemeralPg/Config.hs +5/−0
• src/EphemeralPg/Internal/Cache.hs +5/−5
• src/EphemeralPg/Internal/CopyOnWrite.hs +14/−5
• src/EphemeralPg/Internal/Directory.hs +4/−4
• src/EphemeralPg/Internal/Instance.hs +143/−0
• src/EphemeralPg/Internal/ProcessIdentity.hs +200/−0
• src/EphemeralPg/Internal/Sweep.hs +169/−0
• src/EphemeralPg/Process.hs +25/−17
• src/EphemeralPg/Process/Postgres.hs +21/−11
• test/Main.hs +11/−2
• test/StaleInstances.hs +368/−0

@@ -1,5 +1,34 @@ # Changelog +## Unreleased++## 0.3.0.0++### Breaking Changes++- Add the `sweepStaleOnStart` field to `Config`. Exhaustive constructor uses of+  `Config` must be updated.++### New Features++- Add `sweepStaleInstances` and default-enabled `sweepStaleOnStart` to reclaim+  abandoned temporary PostgreSQL clusters on later startup. Live consumers hold+  external lifetime locks across initialization, cache restore, and restart.++### Bug Fixes++- Verify process identity before bounded fast shutdown; preserve uncertain data,+  permanent directories, sockets, snapshots, and reusable caches.+- Resolve Linux `ps` through `PATH` so process inspection works with Nix-provided+  procps.++### Other Changes++- Consolidate cached startup fallbacks into one protected allocation and preserve+  asynchronous cancellation during cache and resource operations.+- Validate Linux suites locally with Apple containers and the pinned Nix test+  shell instead of Debian Dockerfiles.+ ## 0.2.2.0  ### Bug Fixes

@@ -461,13 +461,17 @@ | `dumpTraced`                 | `ephemeralpg.dump`              | | `restoreTraced`              | `ephemeralpg.restore`           | -Each span carries the standard database attributes-(`db.system.name`/`db.system`, `db.namespace`/`db.name`) plus+Each span carries the standard database and server attributes+(`db.system.name`/`db.system`, `db.namespace`/`db.name`,+`server.address`/`net.peer.name`, `server.port`/`net.peer.port`) plus library-specific ones (`ephemeralpg.port`,-`ephemeralpg.shutdown.mode`). Attribute name selection obeys-`OTEL_SEMCONV_STABILITY_OPT_IN` exactly the way upstream HTTP-instrumentation does — set it to `http` for stable names, `http/dup`-for both stable and legacy. Errors from `EphemeralPg.start` are+`ephemeralpg.shutdown.mode`). `server.address` is the Unix socket+directory, which is what a client passes as libpq's `host`. Attribute+name selection obeys+`OTEL_SEMCONV_STABILITY_OPT_IN` exactly the way upstream database+instrumentation does — set it to `database` for stable names,+`database/dup` for both stable and legacy. Errors from+`EphemeralPg.start` are recorded uniformly with `error.type` (constructor name), span status `Error`, and a `recordException` event. @@ -495,6 +499,77 @@ ```  See `ephemeral-pg-opentelemetry/test/Demo.hs` for a runnable example.++## Cleanup after a killed consumer++`start` and `startCached` sweep abandoned temporary PostgreSQL instances before+allocating a new cluster. If a consumer exits without cleanup (including SIGKILL),+its server can remain alive until the next startup or explicit sweep:++```haskell+import Data.Monoid (Last (..))+import EphemeralPg qualified as Pg++let config = Pg.defaultConfig+      { Pg.temporaryRoot = Last (Just "/tmp/my-tests") }+removedPaths <- Pg.sweepStaleInstances config+```++Create a custom temporary root before using it. The sweep returns sorted canonical+paths actually removed. Disable automatic sweeping with+`config { Pg.sweepStaleOnStart = Last (Just False) }`; explicit sweeps still run,+and new temporary instances still hold ownership locks. An absent setting enables+automatic sweeping.++Cleanup uses local filesystem locks to protect live consumers, including startup+and data replacement. It waits up to five seconds per abandoned server for fast+shutdown, without escalating to SIGKILL. Inspection and deletion add overhead, so+a large backlog can delay startup. Uninspectable or unresponsive instances remain+for a later attempt. Supported inspection platforms are Linux (`ps` and `/proc`)+and macOS (`ps` and `lsof`).++Only immediate temporary data directories are candidates. Permanent data, socket+directories, snapshots, and initialization caches are excluded. Cached startup+with permanent data uses ordinary initialization. Historical untracked clusters+need a valid PID file; live historical servers also need verified identity and+parent PID 1. Untracked directories without PID files remain untouched. The+private `.ephemeral-pg-instances-<uid>` registry retains small lock files to avoid+concurrent lock-replacement races.++## Running tests++Run all suites locally with the pinned Nix toolchain:++```bash+nix develop .#test -c cabal test all --test-show-details=direct+```++On an Apple silicon Mac, run the Linux suites with Apple containers:++```bash+container system start+./test/platform/apple-container.sh+```++The script requires `container`, `git`, `jq`, and `tar`. It uses a pinned official+Nix image and the repository's `flake.lock`, with GHC 9.12.4 and PostgreSQL from+the `test` shell. It copies tracked and non-ignored untracked files from the current+working tree into the container's Linux filesystem, then runs every Cabal test+suite as an unprivileged user. This includes real process ownership and orphan+recovery tests. No Dockerfile or Docker daemon is needed.++The dedicated `ephemeral-pg-nix-validation` container stops after each run, including+failures, and retains Nix and Cabal caches for the next run. Failed source snapshots+and Cabal logs remain inside it for inspection. The first run downloads the Linux+toolchain and builds dependencies. Defaults are four CPUs and 4 GiB of memory;+set `EPHEMERAL_PG_CPUS` and `EPHEMERAL_PG_MEMORY` when creating a container to+change those limits. Set `EPHEMERAL_PG_CONTAINER` to use a separate named container;+the script refuses to reuse a running container. Extra arguments are passed to+`cabal test`, for example `--test-options='--match "Stale instances"'`.++The `test` shell skips editor tools, Git hook installation and development-database+initialization. Linux process inspection requires `procps` on `PATH`, supplied by+this shell. Databases and build outputs stay inside the Linux container.  ## License 

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: ephemeral-pg-version: 0.2.2.0+version: 0.3.0.0 synopsis: Temporary PostgreSQL databases for testing description:   A modern library for creating temporary PostgreSQL instances for testing.@@ -47,7 +47,10 @@     EphemeralPg.Internal.CopyOnWrite     EphemeralPg.Internal.Directory     EphemeralPg.Internal.Except+    EphemeralPg.Internal.Instance     EphemeralPg.Internal.Port+    EphemeralPg.Internal.ProcessIdentity+    EphemeralPg.Internal.Sweep     EphemeralPg.Process     EphemeralPg.Process.CreateDb     EphemeralPg.Process.InitDb@@ -57,6 +60,7 @@     base >=4.18 && <5,     bytestring >=0.11 && <0.13,     directory >=1.3 && <1.4,+    filelock >=0.1.1.9 && <0.2,     filepath >=1.4 && <1.6,     hashable >=1.4 && <1.6,     hasql >=1.10 && <1.11,@@ -64,6 +68,7 @@     process >=1.6 && <1.8,     temporary >=1.3 && <1.4,     text >=2.0 && <2.2,+    time >=1.12 && <1.17,     transformers >=0.5 && <0.7,     typed-process >=0.2.12 && <0.3,     unix >=2.8 && <2.9,@@ -98,11 +103,15 @@     EphemeralPg.Internal.CopyOnWrite     EphemeralPg.Internal.Directory     EphemeralPg.Internal.Except+    EphemeralPg.Internal.Instance     EphemeralPg.Internal.Port+    EphemeralPg.Internal.ProcessIdentity+    EphemeralPg.Internal.Sweep     EphemeralPg.Process     EphemeralPg.Process.CreateDb     EphemeralPg.Process.InitDb     EphemeralPg.Process.Postgres+    StaleInstances    build-depends:     QuickCheck >=2.14 && <2.16,@@ -110,6 +119,7 @@     bytestring,     directory,     ephemeral-pg,+    filelock,     filepath,     hashable,     hasql,@@ -118,6 +128,7 @@     process,     temporary,     text,+    time,     transformers,     typed-process,     unix,

@@ -45,6 +45,7 @@     withCached,     start,     startCached,+    sweepStaleInstances,     stop,     restart, @@ -70,11 +71,14 @@   ) where -import Control.Exception (mask, onException)-import Control.Monad (when)+import Control.Concurrent (threadDelay)+import Control.Exception (IOException, finally, mask, onException, try)+import Control.Monad (unless, when) import Control.Monad.IO.Class (liftIO)+import Data.IORef import Data.Monoid (Last (..)) import Data.Text (Text)+import Data.Text qualified as T import Data.Word (Word16) import EphemeralPg.Config   ( Config (..),@@ -91,14 +95,14 @@     connectionString,   ) import EphemeralPg.Error-  ( StartError (..),+  ( ResourceError (..),+    StartError (..),     StopError (..),     renderStartError,     renderStopError,   ) import EphemeralPg.Internal.Cache   ( CacheConfig (..),-    CacheKey,     cleanupRuntimeFiles,     clearAllCaches,     clearCache,@@ -115,12 +119,16 @@     resolveDirectory,     retryRemoveDirectory,   )-import EphemeralPg.Internal.Except (liftE, onError, runStartup)+import EphemeralPg.Internal.Except (liftE, runStartup)+import EphemeralPg.Internal.Instance (registerInstance, releaseInstance, safeDirectory) import EphemeralPg.Internal.Port (findFreePort)+import EphemeralPg.Internal.ProcessIdentity (systemInspector)+import EphemeralPg.Internal.Sweep qualified as Sweep import EphemeralPg.Process (getCurrentUser) import EphemeralPg.Process.CreateDb (runCreateDb) import EphemeralPg.Process.InitDb (runInitDb, writePostgresConf) import EphemeralPg.Process.Postgres (startPostgres, stopPostgres)+import System.Directory qualified as D  -- | Create a temporary database with default configuration, run an action, then clean up. --@@ -164,84 +172,124 @@ --   Left err -> handleError err -- @ start :: Config -> IO (Either StartError Database)-start config = runStartup $ do-  let mTempRoot = getLast config.temporaryRoot--  -- Create data directory-  (dataDir, dataDirIsTemp) <--    liftE $-      resolveDirectory-        config.dataDirectory-        mTempRoot-        "data"-        createTempDataDirectory--  -- Create socket directory-  (socketDir, socketDirIsTemp) <--    liftE-      ( resolveDirectory-          config.socketDirectory-          mTempRoot-          "socket"-          createTempSocketDirectory-      )-      `onError` when dataDirIsTemp (removeDirectoryIfExists dataDir)--  -- Get port-  p <--    liftE (getPort config)-      `onError` cleanup dataDirIsTemp dataDir socketDirIsTemp socketDir--  -- Get username-  username <- liftIO $ getUsername config--  -- Run initdb-  () <--    liftE (runInitDb config dataDir)-      `onError` cleanup dataDirIsTemp dataDir socketDirIsTemp socketDir--  -- Start postgres-  pgProcess <--    liftE (startPostgres config dataDir socketDir p username)-      `onError` cleanup dataDirIsTemp dataDir socketDirIsTemp socketDir+start config = startManaged config Nothing -  -- Create database-  let dbName = config.databaseName-  () <--    liftE (runCreateDb config socketDir p username dbName)-      `onError` do-        _ <- stopPostgres pgProcess ShutdownImmediate 5-        cleanup dataDirIsTemp dataDir socketDirIsTemp socketDir+-- | Stop provably abandoned PostgreSQL servers and return the canonical paths+-- of temporary data directories removed, in sorted order. Uses 'temporaryRoot'+-- (or the system temporary directory), independently of 'sweepStaleOnStart'.+-- Live ownership locks, permanent data, sockets, snapshots and caches are+-- excluded. Fast shutdown waits up to five seconds per server; uncertain or+-- unresponsive instances are retained. Cleanup after SIGKILL is delayed until+-- the next sweep. Requires local filesystem locks and inspectable processes.+sweepStaleInstances :: Config -> IO [FilePath]+sweepStaleInstances = Sweep.sweepStaleInstances -  -- Build cleanup action-  let cleanupAction = do-        when dataDirIsTemp $ do-          -- Use retry to handle pg_stat race-          _ <- retryRemoveDirectory dataDir 5 100000-          pure ()-        when socketDirIsTemp $-          removeDirectoryIfExists socketDir+-- Allocation, startup and cleanup share one ownership transfer. A cache fallback+-- reuses the protected allocation, so it cannot introduce a second sweep.+startManaged :: Config -> Maybe CacheConfig -> IO (Either StartError Database)+startManaged config cache = mask $ \restore -> do+  when (maybe True id $ getLast config.sweepStaleOnStart) $+    restore (sweepStaleInstances config) >> pure ()+  resources <- newIORef (pure ())+  let clean = readIORef resources >>= id+  result <-+    ( runStartup $ do+        root <- liftIO $ maybe D.getTemporaryDirectory pure (getLast config.temporaryRoot) >>= D.canonicalizePath+        (dataDir, isTemp, release) <- liftE $ case config.dataDirectory of+          DirectoryPermanent _ ->+            fmap (fmap (\(path, temp) -> (path, temp, pure ()))) $+              resolveDirectory config.dataDirectory (Just root) "data" createTempDataDirectory+          DirectoryTemporary -> do+            acquired <- try @IOException $ registerInstance root+            pure $ case acquired of+              Left err -> Left $ ResourceError $ DirectoryCreationFailed root (T.pack $ show err)+              Right (path, lease) -> Right (path, True, releaseInstance lease)+        cleaned <- liftIO $ newIORef False+        let cleanData = do+              already <- atomicModifyIORef' cleaned (\old -> (True, old))+              unless already $+                ( do+                    _ <- try @IOException $ when isTemp $ do+                      -- Snapshot operations can replace the process behind the+                      -- exported immutable handle. Never delete an active cluster.+                      let awaitUnused attempts = do+                            unused <- Sweep.directoryUnused systemInspector dataDir+                            if unused || attempts == (0 :: Int)+                              then pure unused+                              else threadDelay 50000 >> awaitUnused (attempts - 1)+                      unused <- awaitUnused 3+                      when unused $ do+                        _ <- safeDirectory dataDir+                        canonical <- D.canonicalizePath dataDir+                        when (canonical == dataDir) $ do+                          _ <- retryRemoveDirectory dataDir 5 100000+                          pure ()+                    pure ()+                )+                  `finally` release+        liftIO $ writeIORef resources cleanData+        (socketDir, socketIsTemp) <-+          liftE $+            resolveDirectory config.socketDirectory (Just root) "socket" createTempSocketDirectory+        let cleanDirs = cleanData `finally` when socketIsTemp (removeDirectoryIfExists socketDir)+        liftIO $ writeIORef resources cleanDirs+        p <- liftE $ restore $ getPort config+        username <- liftIO $ restore $ getUsername config+        liftE $ restore $ initialize config cache dataDir isTemp+        -- startPostgres masks creation and cleans up cancellation during readiness.+        pgProcess <- liftE $ startPostgres config dataDir socketDir p username+        let abort = do+              outcome <- stopPostgres pgProcess ShutdownImmediate 5+              case outcome of+                Nothing -> cleanDirs+                Just _ -> release -- Keep uncertain data for a later sweep.+        liftIO $ writeIORef resources abort+        liftE $ restore $ runCreateDb config socketDir p username config.databaseName+        pure+          Database+            { dataDirectory = dataDir,+              socketDirectory = socketDir,+              port = p,+              databaseName = config.databaseName,+              user = username,+              password = config.password,+              process = pgProcess,+              cleanup = cleanDirs,+              dataDirIsTemp = isTemp,+              socketDirIsTemp = socketIsTemp,+              shutdownMode = resolveShutdownMode config,+              shutdownTimeoutSeconds = resolveShutdownTimeout config+            }+    )+      `onException` clean+  case result of+    Left _ -> clean >> pure result+    Right _ -> pure result -  pure $-    Database-      { dataDirectory = dataDir,-        socketDirectory = socketDir,-        port = p,-        databaseName = dbName,-        user = username,-        password = config.password,-        process = pgProcess,-        cleanup = cleanupAction,-        dataDirIsTemp = dataDirIsTemp,-        socketDirIsTemp = socketDirIsTemp,-        shutdownMode = resolveShutdownMode config,-        shutdownTimeoutSeconds = resolveShutdownTimeout config-      }-  where-    cleanup :: Bool -> FilePath -> Bool -> FilePath -> IO ()-    cleanup dataDirIsTemp dataDir socketDirIsTemp socketDir = do-      when dataDirIsTemp $ removeDirectoryIfExists dataDir-      when socketDirIsTemp $ removeDirectoryIfExists socketDir+initialize :: Config -> Maybe CacheConfig -> FilePath -> Bool -> IO (Either StartError ())+initialize config cache dataDir isTemp = case cache of+  Just cacheConfig | cacheConfig.enabled && isTemp -> do+    keyResult <- getCacheKey config+    case keyResult of+      Left _ -> runInitDb config dataDir+      Right key -> do+        cached <- isCached key cacheConfig.root+        if cached+          then do+            D.removeDirectory dataDir+            restored <- restoreFromCache key dataDir cacheConfig.root+            case restored of+              Right () -> cleanupRuntimeFiles dataDir >> writePostgresConf config dataDir >> pure (Right ())+              Left _ -> do+                removeDirectoryIfExists dataDir+                D.createDirectory dataDir+                runInitDb config dataDir+          else do+            initialized <- runInitDb config dataDir+            case initialized of+              Left err -> pure $ Left err+              Right () -> createCache key dataDir cacheConfig.root >> pure (Right ())+  _ -> runInitDb config dataDir  -- | Get port from config or find a free one. getPort :: Config -> IO (Either StartError Word16)@@ -274,10 +322,10 @@ stop :: Database -> IO () stop db = do   -- Stop postgres using configured shutdown mode and timeout-  _ <- stopPostgres db.process db.shutdownMode db.shutdownTimeoutSeconds--  -- Run cleanup (removes temp directories)-  db.cleanup+  outcome <- stopPostgres db.process db.shutdownMode db.shutdownTimeoutSeconds+  case outcome of+    Nothing -> db.cleanup+    Just _ -> pure () -- Preserve ownership and data when shutdown is uncertain.  -- | Restart a database. --@@ -340,136 +388,7 @@     stop db     pure a --- | Start a temporary database using initdb caching.------ If caching is enabled and a cache exists, the data directory is copied--- from the cache. Otherwise, initdb is run and the result is cached.+-- | Start with a reusable initialization cache. Permanent data directories use+-- ordinary initialization and are never registered for stale cleanup. startCached :: Config -> CacheConfig -> IO (Either StartError Database)-startCached config cacheConfig-  | not cacheConfig.enabled = start config-  | otherwise = do-      -- Get cache key-      keyResult <- getCacheKey config-      case keyResult of-        Left _err ->-          -- Can't determine cache key, fall back to non-cached start-          start config-        Right cacheKey -> do-          -- Check if cache exists-          cached <- isCached cacheKey cacheConfig.root-          if cached-            then startFromCache config cacheConfig cacheKey-            else startAndCache config cacheConfig cacheKey---- | Start from an existing cache.-startFromCache :: Config -> CacheConfig -> CacheKey -> IO (Either StartError Database)-startFromCache config cacheConfig cacheKey = runStartup $ do-  let mTempRoot = getLast config.temporaryRoot--  -- Create temporary data directory (to get the path)-  (dataDir, dataDirIsTemp) <- liftE $ createTempDataDirectory mTempRoot--  -- Remove the directory so cp can create it fresh-  -- (otherwise cp -cR creates nested directories on macOS)-  liftIO $ removeDirectoryIfExists dataDir--  -- 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 = runStartup $ do-  let mTempRoot = getLast config.temporaryRoot--  -- Create data directory-  (dataDir, dataDirIsTemp) <- liftE $ createTempDataDirectory mTempRoot--  -- 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)-continueStartup config dataDir dataDirIsTemp = runStartup $ do-  let mTempRoot = getLast config.temporaryRoot--  -- Create socket directory-  (socketDir, socketDirIsTemp) <--    liftE-      ( resolveDirectory-          config.socketDirectory-          mTempRoot-          "socket"-          createTempSocketDirectory-      )-      `onError` when dataDirIsTemp (removeDirectoryIfExists dataDir)--  -- Get port-  p <--    liftE (getPort config)-      `onError` cleanupDirs dataDirIsTemp dataDir socketDirIsTemp socketDir--  -- Get username-  username <- liftIO $ getUsername config--  -- Start postgres (initdb already done)-  pgProcess <--    liftE (startPostgres config dataDir socketDir p username)-      `onError` cleanupDirs dataDirIsTemp dataDir socketDirIsTemp socketDir--  -- Create database-  let dbName = config.databaseName-  () <--    liftE (runCreateDb config socketDir p username dbName)-      `onError` do-        _ <- stopPostgres pgProcess ShutdownImmediate 5-        cleanupDirs dataDirIsTemp dataDir socketDirIsTemp socketDir--  -- Build cleanup action-  let cleanupAction = do-        when dataDirIsTemp $ do-          _ <- retryRemoveDirectory dataDir 5 100000-          pure ()-        when socketDirIsTemp $-          removeDirectoryIfExists socketDir--  pure $-    Database-      { dataDirectory = dataDir,-        socketDirectory = socketDir,-        port = p,-        databaseName = dbName,-        user = username,-        password = config.password,-        process = pgProcess,-        cleanup = cleanupAction,-        dataDirIsTemp = dataDirIsTemp,-        socketDirIsTemp = socketDirIsTemp,-        shutdownMode = resolveShutdownMode config,-        shutdownTimeoutSeconds = resolveShutdownTimeout config-      }-  where-    cleanupDirs :: Bool -> FilePath -> Bool -> FilePath -> IO ()-    cleanupDirs dataDirIsTemp' dataDir' socketDirIsTemp' socketDir' = do-      when dataDirIsTemp' $ removeDirectoryIfExists dataDir'-      when socketDirIsTemp' $ removeDirectoryIfExists socketDir'+startCached config cacheConfig = startManaged config (Just cacheConfig)

@@ -73,6 +73,8 @@     socketDirectory :: DirectoryConfig,     -- | Root directory for temporary files.     temporaryRoot :: Last FilePath,+    -- | Sweep abandoned temporary data at startup (absent means True).+    sweepStaleOnStart :: Last Bool,     -- | postgresql.conf settings.     postgresSettings :: [(Text, Text)],     -- | Additional arguments for initdb.@@ -110,6 +112,7 @@         dataDirectory = combineDir a.dataDirectory b.dataDirectory,         socketDirectory = combineDir a.socketDirectory b.socketDirectory,         temporaryRoot = a.temporaryRoot <> b.temporaryRoot,+        sweepStaleOnStart = a.sweepStaleOnStart <> b.sweepStaleOnStart,         postgresSettings = a.postgresSettings <> b.postgresSettings,         initDbArgs = a.initDbArgs <> b.initDbArgs,         postgresArgs = a.postgresArgs <> b.postgresArgs,@@ -139,6 +142,7 @@         dataDirectory = DirectoryTemporary,         socketDirectory = DirectoryTemporary,         temporaryRoot = Last Nothing,+        sweepStaleOnStart = Last Nothing,         postgresSettings = [],         initDbArgs = [],         postgresArgs = [],@@ -215,6 +219,7 @@       dataDirectory = DirectoryTemporary,       socketDirectory = DirectoryTemporary,       temporaryRoot = Last Nothing,+      sweepStaleOnStart = Last (Just True),       postgresSettings = defaultPostgresSettings,       initDbArgs = defaultInitDbArgs,       postgresArgs = [],

@@ -32,7 +32,7 @@   ) where -import Control.Exception (SomeException, try)+import Control.Exception (IOException, try) import Control.Monad (unless, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE)@@ -115,7 +115,7 @@ getPostgresVersion = do   result <- try $ readProcess config   pure $ case result of-    Left (ex :: SomeException) ->+    Left (ex :: IOException) ->       Left $ "Failed to get postgres version: " <> T.pack (show ex)     Right (ExitSuccess, stdout, _stderr) ->       Right $ extractMajorVersion $ T.decodeUtf8Lenient $ LBS.toStrict stdout@@ -195,7 +195,7 @@   where     publishCache :: FilePath -> FilePath -> ExceptT Text IO ()     publishCache tmpDataDir dstDataDir = do-      result <- liftIO $ try @SomeException $ renamePath tmpDataDir dstDataDir+      result <- liftIO $ try @IOException $ renamePath tmpDataDir dstDataDir       case result of         Right () -> pure ()         Left ex -> do@@ -244,7 +244,7 @@ tryE prefix action = do   result <- liftIO $ try action   case result of-    Left (ex :: SomeException) ->+    Left (ex :: IOException) ->       throwE $ prefix <> ": " <> T.pack (show ex)     Right a -> pure a @@ -272,7 +272,7 @@      catch_ :: IO a -> IO a -> IO a     catch_ action fallback = do-      result <- try @SomeException action+      result <- try @IOException action       case result of         Left _ -> fallback         Right a -> pure a

@@ -19,7 +19,8 @@   ) where -import Control.Exception (SomeException, try)+import Control.Exception (IOException, SomeException, fromException, try, tryJust)+import Data.Maybe (isJust) import Data.Text (Text) import Data.Text qualified as T import System.Directory (removeFile)@@ -27,7 +28,7 @@ import System.FilePath ((</>)) import System.IO.Temp (withSystemTempDirectory) import System.Info (os)-import System.Process.Typed (nullStream, proc, runProcess, runProcess_, setStderr)+import System.Process.Typed (ExitCodeException, nullStream, proc, runProcess, runProcess_, setStderr)  -- | Copy-on-write capability for a filesystem. data CowCapability@@ -72,7 +73,7 @@   where     catch_ :: IO a -> IO a -> IO a     catch_ action fallback = do-      result <- try @SomeException action+      result <- try @IOException action       case result of         Left _ -> fallback         Right a -> pure a@@ -108,7 +109,7 @@ -- | Copy a directory using copy-on-write. copyDirectoryCoW :: CowMethod -> FilePath -> FilePath -> IO (Either Text ()) copyDirectoryCoW method src dst = do-  result <- try $ runCopy method+  result <- tryCopy $ runCopy method   case result of     Left (_ :: SomeException) ->       -- Fall back to regular copy on failure@@ -128,9 +129,17 @@ -- | Copy a directory using regular (non-CoW) copy. copyDirectoryRegular :: FilePath -> FilePath -> IO (Either Text ()) copyDirectoryRegular src dst = do-  result <- try $ runProcess_ $ proc "cp" ["-R", src, dst]+  result <- tryCopy $ runProcess_ $ proc "cp" ["-R", src, dst]   case result of     Left (ex :: SomeException) ->       pure $ Left $ T.pack $ show ex     Right () ->       pure $ Right ()++-- Only expected filesystem/process failures permit cache-copy fallback.+-- Cancellation and other exceptions must unwind the protected startup.+tryCopy :: IO a -> IO (Either SomeException a)+tryCopy = tryJust $ \err ->+  if isJust (fromException err :: Maybe IOException) || isJust (fromException err :: Maybe ExitCodeException)+    then Just err+    else Nothing

@@ -16,7 +16,7 @@ where  import Control.Concurrent (threadDelay)-import Control.Exception (SomeException, catch, try)+import Control.Exception (IOException, catch, try) import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)@@ -102,7 +102,7 @@ removeDirectoryIfExists path = do   exists <- doesDirectoryExist path   when exists $-    removeDirectoryRecursive path `catch` \(_ :: SomeException) -> pure ()+    removeDirectoryRecursive path `catch` \(_ :: IOException) -> pure ()  -- | Remove a directory with retries. --@@ -115,7 +115,7 @@       result <- try $ removeDirectoryRecursive path       case result of         Right () -> pure $ Right ()-        Left (e :: SomeException)+        Left (e :: IOException)           | n <= 0 ->               pure $ Left $ "Failed after " <> T.pack (show maxRetries) <> " retries: " <> T.pack (show e)           | otherwise -> do@@ -127,6 +127,6 @@ tryDirCreate dir action = do   result <- liftIO $ try action   case result of-    Left (e :: SomeException) ->+    Left (e :: IOException) ->       throwE $ ResourceError $ DirectoryCreationFailed dir (T.pack $ show e)     Right a -> pure a

@@ -0,0 +1,143 @@+-- | Private, persistent ownership records. Lock paths are never recycled.+module EphemeralPg.Internal.Instance+  ( InstanceLease,+    Record (..),+    registerInstance,+    releaseInstance,+    registryFor,+    withRegistry,+    claimInstance,+    readRecord,+    recordPath,+    safeDirectory,+    safeFile,+    sameFile,+    boundedRead,+  )+where++import Control.Exception (IOException, bracket, catch, finally, mask_, onException)+import Control.Monad (unless)+import Data.Bits ((.&.))+import Data.ByteString.Char8 qualified as BS+import Data.IORef+import System.Directory qualified as D+import System.FileLock+import System.FilePath+import System.IO (IOMode (ReadMode), withBinaryFile)+import System.IO.Error (isAlreadyExistsError, isDoesNotExistError)+import System.IO.Temp (createTempDirectory)+import System.Posix.Directory qualified as Posix+import System.Posix.Files+import System.Posix.Process (getProcessID)+import System.Posix.Types (ProcessID)+import System.Posix.User (getEffectiveUserID)+import Text.Read (readMaybe)++data Record = Record {version :: Int, dataPath :: FilePath, owner :: ProcessID, temporary :: Bool}+  deriving stock (Eq, Show, Read)++data InstanceLease = InstanceLease FilePath FilePath FileLock (IORef Bool)++safeDirectory :: FilePath -> IO FileStatus+safeDirectory path = do+  st <- getSymbolicLinkStatus path+  uid <- getEffectiveUserID+  unless (isDirectory st && fileOwner st == uid) $ ioError $ userError "Unsafe instance directory"+  pure st++safeFile :: FilePath -> IO FileStatus+safeFile path = do+  st <- getSymbolicLinkStatus path+  uid <- getEffectiveUserID+  unless (isRegularFile st && fileOwner st == uid && linkCount st == 1) $+    ioError $+      userError "Unsafe control file"+  pure st++sameFile :: FileStatus -> FileStatus -> Bool+sameFile a b = deviceID a == deviceID b && fileID a == fileID b++boundedRead :: FilePath -> IO String+boundedRead path = do+  before <- safeFile path+  bytes <- withBinaryFile path ReadMode $ \h -> BS.hGet h 8193+  after <- safeFile path+  unless (sameFile before after && BS.length bytes <= 8192) $ ioError $ userError "Changed or oversized control file"+  pure (BS.unpack bytes)++registryFor :: FilePath -> IO FilePath+registryFor root = do+  uid <- getEffectiveUserID+  let registry = root </> (".ephemeral-pg-instances-" <> show uid)+  Posix.createDirectory registry 0o700 `catch` \(e :: IOException) ->+    unless (isAlreadyExistsError e) (ioError e)+  st <- safeDirectory registry+  unless (fileMode st .&. 0o077 == 0) $ ioError $ userError "Instance registry must be private"+  pure registry++-- The enclosing directory is private; reject existing non-regular lock files.+checkLock :: FilePath -> IO ()+checkLock path =+  (safeFile path >> pure ()) `catch` \(e :: IOException) ->+    unless (isDoesNotExistError e) (ioError e)++withRegistry :: FilePath -> IO a -> IO a+withRegistry registry action = do+  _ <- safeDirectory registry+  let path = registry </> "registry.lock"+  checkLock path+  withFileLock path Exclusive $ \_ -> action++recordPath :: FilePath -> FilePath -> FilePath+recordPath registry path = registry </> takeFileName path <.> "record"++readRecord :: FilePath -> FilePath -> IO Record+readRecord registry path = do+  txt <- boundedRead (recordPath registry path)+  case readMaybe txt of+    Just r | r.version == 1 && r.dataPath == path && r.temporary && r.owner > 1 -> pure r+    _ -> ioError $ userError "Invalid instance record"++registerInstance :: FilePath -> IO (FilePath, InstanceLease)+registerInstance root = mask_ $ do+  registry <- registryFor root+  withRegistry registry $ do+    path <- createTempDirectory root "ephpg-data-"+    let lockPath = registry </> takeFileName path <.> "lock"+    checkLock lockPath+    acquired <- tryLockFile lockPath Exclusive+    lock <- maybe (ioError $ userError "New instance lock is busy") pure acquired+    let publish = do+          pid <- getProcessID+          let target = recordPath registry path+          writeFile (target <.> "new") (show (Record 1 path pid True))+          D.renameFile (target <.> "new") target+          ref <- newIORef False+          pure (path, InstanceLease registry path lock ref)+    publish `onException` unlockFile lock++-- Release is idempotent. Keep metadata and lock inode: a later sweep can retry+-- failed cleanup, and no waiter can accidentally acquire an obsolete inode.+releaseInstance :: InstanceLease -> IO ()+releaseInstance (InstanceLease registry path lock ref) = mask_ $ do+  released <- atomicModifyIORef' ref (\old -> (True, old))+  unless released $+    ( do+        exists <- D.doesPathExist path+        unless exists $+          withRegistry registry $+            D.removeFile (recordPath registry path) `catch` \(e :: IOException) ->+              unless (isDoesNotExistError e) (ioError e)+    )+      `finally` unlockFile lock++-- Claims are opened under the registry lock and held outside it. The record is+-- re-read by the caller while holding the lifetime lock.+claimInstance :: FilePath -> FilePath -> (Maybe FileLock -> IO a) -> IO a+claimInstance registry path = bracket acquire (mapM_ unlockFile)+  where+    acquire = withRegistry registry $ do+      let lockPath = registry </> takeFileName path <.> "lock"+      checkLock lockPath+      tryLockFile lockPath Exclusive

@@ -0,0 +1,200 @@+-- | Conservative process inspection. Unknown observations never authorize work.+module EphemeralPg.Internal.ProcessIdentity+  ( Observation (..),+    Identity (..),+    Inspector (..),+    systemInspector,+    PidRecord (..),+    parsePidRecord,+    matchesServer,+    isPostgres,+  )+where++import Control.Exception (IOException, catch)+import Control.Monad (unless)+import Data.ByteString.Char8 qualified as BS+import Data.List (intercalate, isPrefixOf)+import Data.Time (UTCTime, defaultTimeLocale, parseTimeM)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import System.Environment (getEnvironment)+import System.Exit (ExitCode (..))+import System.FilePath (takeFileName)+import System.IO.Error (isDoesNotExistError)+import System.Info (os)+import System.Posix.Files (readSymbolicLink)+import System.Posix.Signals (nullSignal, sigINT, signalProcess)+import System.Posix.Types (ProcessID, UserID)+import System.Posix.User (getEffectiveUserID)+import System.Process (CreateProcess (..), proc, readCreateProcessWithExitCode)+import Text.Read (readMaybe)++data Identity = Identity+  { pid :: ProcessID,+    parent :: ProcessID,+    uid :: UserID,+    started :: Integer,+    command :: String,+    arguments :: String,+    workingDirectory :: Maybe FilePath,+    zombie :: Bool+  }+  deriving stock (Eq, Show)++data Observation = Gone | Present Identity | Unknown String deriving stock (Eq, Show)++data Inspector = Inspector+  { inspect :: ProcessID -> IO Observation,+    enumerate :: IO (Either String [Identity]),+    interrupt :: ProcessID -> IO ()+  }++data PidRecord = PidRecord {pid :: ProcessID, path :: FilePath, started :: Integer}+  deriving stock (Eq, Show)++parsePidRecord :: String -> Maybe PidRecord+parsePidRecord text = case lines text of+  p : path : start : port : socket : _listen : memory : status : _ -> do+    n <- readMaybe p :: Maybe Integer+    t <- readMaybe start+    portNumber <- readMaybe port :: Maybe Int+    if length text <= 8192+      && n > 1+      && n <= toInteger (maxBound :: ProcessID)+      && t > 0+      && not (null path)+      && portNumber > 0+      && portNumber <= 65535+      && not (null socket)+      && not (null memory)+      && words status `elem` [["ready"], ["starting"], ["stopping"]]+      then Just (PidRecord (fromInteger n) path t)+      else Nothing+  _ -> Nothing++matchesServer :: UserID -> PidRecord -> Identity -> Bool+matchesServer uid record ident =+  ident.pid == record.pid+    && ident.uid == uid+    && takeFileName ident.command == "postgres"+    && ident.workingDirectory == Just record.path+    && abs (ident.started - record.started) <= 2+    && (ident.command <> " -D " <> record.path <> " -k ") `isPrefixOf` ident.arguments++systemInspector :: Inspector+systemInspector = Inspector inspectProcess enumerateProcesses (signalProcess sigINT)++-- Linux installations such as NixOS provide procps through PATH.+psExecutable :: FilePath+psExecutable = if os == "darwin" then "/bin/ps" else "ps"++-- Only promote a platform after running the real orphan fixture there.+enumerateProcesses :: IO (Either String [Identity])+enumerateProcesses = observeProcesses Nothing++observeProcesses :: Maybe ProcessID -> IO (Either String [Identity])+observeProcesses target+  | os `notElem` ["darwin", "linux"] = pure $ Left "Process inspection has not been validated on this platform"+  | otherwise =+      ( do+          environment <- getEnvironment+          let fields = "pid=,ppid=,uid=,stat=,lstart=,comm="+              selection = case target of+                Nothing -> ["-ww", "-axo", fields]+                Just pid -> ["-ww", "-p", show pid, "-o", fields]+              cp =+                (proc psExecutable selection)+                  { env = Just (("LC_ALL", "C") : ("TZ", "UTC") : filter (\(k, _) -> k /= "LC_ALL" && k /= "TZ") environment)+                  }+          (code, output, _) <- readCreateProcessWithExitCode cp ""+          if code /= ExitSuccess && not (target /= Nothing && null output)+            then pure (Left "ps enumeration failed")+            else case traverse parseIdentity (lines output) of+              Nothing -> pure $ Left "Unparseable process metadata"+              Just entries -> do+                uid <- getEffectiveUserID+                let relevant = filter (\entry -> not entry.zombie && entry.uid == uid && (isPostgres entry || takeFileName entry.command == "initdb")) entries+                directories <-+                  if null relevant || os == "linux"+                    then pure []+                    else do+                      (cwdCode, cwdOutput, _) <-+                        readCreateProcessWithExitCode+                          (proc "/usr/sbin/lsof" ["-a", "-p", intercalate "," (map (show . (\entry -> entry.pid)) relevant), "-d", "cwd", "-Fn"])+                          ""+                      unless (cwdCode == ExitSuccess || not (null cwdOutput)) $ ioError $ userError "Cannot enumerate PostgreSQL working directories"+                      pure $ parseDirectories Nothing (lines cwdOutput)+                Right <$> traverse (\entry -> addArguments entry {workingDirectory = lookup entry.pid directories}) entries+      )+        `catch` \(e :: IOException) -> pure $ Left (show e)+  where+    addArguments ident+      | ident.zombie = pure ident+      | os == "linux" && (isPostgres ident || takeFileName ident.command == "initdb") = do+          uid <- getEffectiveUserID+          if ident.uid /= uid+            then pure ident+            else do+              let base = "/proc/" <> show ident.pid+              cwd <- readSymbolicLink (base <> "/cwd")+              exe <- readSymbolicLink (base <> "/exe")+              args <- BS.readFile (base <> "/cmdline")+              pure ident {command = exe, arguments = unwords (filter (not . null) $ map BS.unpack $ BS.split '\0' args), workingDirectory = Just cwd}+      | takeFileName ident.command `elem` ["postgres", "initdb"] = do+          (code, output, _) <-+            readCreateProcessWithExitCode+              (proc psExecutable ["-ww", "-p", show ident.pid, "-o", "args="])+              ""+          -- A disappearing entry invalidates this snapshot; the next sweep retries.+          if code == ExitSuccess && not (null output)+            then pure ident {arguments = unlinesTrim output}+            else ioError $ userError "Process changed during enumeration"+      | otherwise = pure ident+    unlinesTrim = reverse . dropWhile (== '\n') . reverse . dropWhile (== ' ')++parseIdentity :: String -> Maybe Identity+parseIdentity line = case words line of+  p : pp : user : state : day : month : date : clock : year : rest -> do+    pid <- readMaybe p+    parent <- readMaybe pp+    uid <- readMaybe user+    time <- parseTimeM True defaultTimeLocale "%a %b %e %T %Y" (unwords [day, month, date, clock, year]) :: Maybe UTCTime+    if null rest+      then Nothing+      else+        pure $+          Identity+            pid+            parent+            uid+            (floor $ utcTimeToPOSIXSeconds time)+            (unwords rest)+            ""+            Nothing+            ("Z" `isPrefixOf` state)+  _ -> Nothing++inspectProcess :: ProcessID -> IO Observation+inspectProcess pid+  | pid <= 1 = pure $ Unknown "Invalid PID"+  | otherwise = do+      snapshot <- observeProcesses (Just pid)+      case snapshot of+        Left reason -> pure $ Unknown reason+        Right entries -> case filter (\entry -> entry.pid == pid) entries of+          [entry] -> pure $ if entry.zombie then Gone else Present entry+          [] ->+            (signalProcess nullSignal pid >> pure (Unknown "Process appeared after enumeration"))+              `catch` \(e :: IOException) ->+                pure $+                  if isDoesNotExistError e then Gone else Unknown (show e)+          _ -> pure $ Unknown "Duplicate process identity"++isPostgres :: Identity -> Bool+isPostgres ident = takeFileName ident.command == "postgres" || "postgres: " `isPrefixOf` ident.command++parseDirectories :: Maybe ProcessID -> [String] -> [(ProcessID, FilePath)]+parseDirectories _ [] = []+parseDirectories _ (('p' : value) : rest) = parseDirectories (readMaybe value) rest+parseDirectories (Just pid) (('n' : path) : rest) = (pid, path) : parseDirectories (Just pid) rest+parseDirectories pid (_ : rest) = parseDirectories pid rest

@@ -0,0 +1,169 @@+-- | Conservative claims, bounded shutdown, and shutdown-before-deletion.+module EphemeralPg.Internal.Sweep (sweepStaleInstances, sweepWith, Outcome (..), directoryUnused) where++import Control.Concurrent (threadDelay)+import Control.Exception (IOException, catch)+import Control.Monad (forM, unless)+import Data.List (isInfixOf, isPrefixOf, sort)+import Data.Monoid (getLast)+import EphemeralPg.Config+import EphemeralPg.Internal.Instance+import EphemeralPg.Internal.ProcessIdentity+import GHC.Clock (getMonotonicTimeNSec)+import System.Directory qualified as D+import System.FilePath+import System.IO.Error (isDoesNotExistError)+import System.Posix.User (getEffectiveUserID)+import System.Timeout (timeout)++data Outcome = Removed | Active | Uncertain | TimedOut | Failed deriving stock (Eq, Show)++-- | Reap provably abandoned immediate temporary data children. Ordinary I/O+-- failures skip candidates; asynchronous exceptions propagate.+sweepStaleInstances :: Config -> IO [FilePath]+sweepStaleInstances config = do+  outcomes <- sweepWith systemInspector config+  pure $ sort [path | (path, Removed) <- outcomes]++sweepWith :: Inspector -> Config -> IO [(FilePath, Outcome)]+sweepWith inspector config =+  ( do+      root <- maybe D.getTemporaryDirectory pure (getLast config.temporaryRoot) >>= D.canonicalizePath+      registry <- registryFor root+      excluded <- case config.dataDirectory of+        DirectoryTemporary -> pure Nothing+        DirectoryPermanent path -> Just <$> D.canonicalizePath path+      names <- D.listDirectory root+      forM (sort $ filter (isPrefixOf "ephpg-data-") names) $ \name -> do+        let path = root </> name+        outcome <-+          if Just path == excluded+            then pure Active+            else+              candidate inspector registry path `catch` \(_ :: IOException) -> pure Failed+        pure (path, outcome)+  )+    `catch` \(_ :: IOException) -> pure []++candidate :: Inspector -> FilePath -> FilePath -> IO Outcome+candidate inspector registry path = claimInstance registry path $ \case+  Nothing -> pure Active+  Just _ -> do+    original <- safeDirectory path+    canonical <- D.canonicalizePath path+    if canonical /= path+      then pure Uncertain+      else do+        tracked <-+          (Just <$> readRecord registry path) `catch` \(e :: IOException) ->+            if isDoesNotExistError e then pure Nothing else ioError e+        case tracked of+          Just record ->+            inspector.inspect record.owner >>= \case+              Gone -> examine True original (stableRecord (Just record))+              Present _ -> pure Active+              Unknown _ -> pure Uncertain+          Nothing -> do+            version <-+              boundedRead (path </> "PG_VERSION") `catch` \(e :: IOException) ->+                if isDoesNotExistError e then pure "" else ioError e+            if null version || any (\c -> c `notElem` ("0123456789.\n" :: String)) version+              then pure Uncertain+              else examine False original (stableRecord Nothing)+  where+    pidPath = path </> "postmaster.pid"+    readPid =+      (Just <$> boundedRead pidPath) `catch` \(e :: IOException) ->+        if isDoesNotExistError e then pure Nothing else ioError e+    stableRecord expected = do+      current <-+        (Just <$> readRecord registry path) `catch` \(e :: IOException) ->+          if isDoesNotExistError e then pure Nothing else ioError e+      if current /= expected+        then pure False+        else case current of+          Nothing -> pure True+          Just record -> (== Gone) <$> inspector.inspect record.owner+    examine tracked original stable = do+      contents <- readPid+      case contents of+        Nothing | tracked -> removeWhenUnused original Nothing stable+        Nothing -> pure Uncertain+        Just text -> case parsePidRecord text of+          Just record+            | record.path == path ->+                inspector.inspect record.pid >>= \case+                  Gone -> removeWhenUnused original (Just text) stable+                  Unknown _ -> pure Uncertain+                  Present ident -> do+                    uid <- getEffectiveUserID+                    if not (matchesServer uid record ident)+                      then pure Uncertain+                      else+                        if not tracked && ident.parent /= 1+                          then pure Active+                          else do+                            -- Revalidate filesystem, PID file and complete process identity.+                            unchanged <- sameFile original <$> safeDirectory path+                            current <- readPid+                            ownershipUnchanged <- stable+                            observed <- inspector.inspect record.pid+                            if not ownershipUnchanged || not unchanged || current /= Just text || observed /= Present ident+                              then pure Uncertain+                              else do+                                inspector.interrupt record.pid+                                deadline <- (+ 5000000000) <$> getMonotonicTimeNSec+                                let wait =+                                      inspector.inspect record.pid >>= \case+                                        Gone -> do+                                          result <- removeWhenUnused original Nothing stable+                                          clock <- getMonotonicTimeNSec+                                          if result == Uncertain && clock < deadline then threadDelay 50000 >> wait else pure result+                                        Present now | now.pid == ident.pid && now.started == ident.started && now.uid == ident.uid -> do+                                          clock <- getMonotonicTimeNSec+                                          if clock >= deadline then pure TimedOut else threadDelay 50000 >> wait+                                        Unknown _ -> do+                                          clock <- getMonotonicTimeNSec+                                          if clock >= deadline then pure Uncertain else threadDelay 50000 >> wait+                                        _ -> pure Uncertain+                                maybe TimedOut id <$> timeout 5000000 wait+          _ -> pure Uncertain+    removeWhenUnused original expected stable = do+      unused <- directoryUnused inspector path+      if not unused+        then pure Uncertain+        else do+          current <- readPid+          ownershipUnchanged <- stable+          -- After shutdown the PID file must be absent. A dead PID fixture may+          -- retain its exact original record, but may not acquire a new one.+          if not ownershipUnchanged || current /= expected+            then pure Uncertain+            else do+              fresh <- safeDirectory path+              unless (sameFile original fresh) $ ioError $ userError "Candidate was replaced"+              D.removeDirectoryRecursive path+              -- Persistent lock files prevent ABA claims; retire only metadata.+              withRegistry registry $+                D.removeFile (recordPath registry path) `catch` \(e :: IOException) ->+                  unless (isDoesNotExistError e) (ioError e)+              pure Removed++-- Any unclassified PostgreSQL launcher or initdb makes absence unprovable.+-- Inspect working directories even for workers with rewritten process titles.+-- Never infer absence from signal-zero alone.+directoryUnused :: Inspector -> FilePath -> IO Bool+directoryUnused inspector path =+  inspector.enumerate >>= \case+    Left _ -> pure False+    Right entries -> do+      uid <- getEffectiveUserID+      let own = filter (\entry -> entry.uid == uid && not entry.zombie) entries+          safe :: Identity -> Bool+          safe entry+            | takeFileName entry.command == "initdb" = False+            | isPostgres entry = case entry.workingDirectory of+                Just cwd -> cwd /= path && not (path `isInfixOf` entry.arguments)+                Nothing -> False+            | otherwise = True+      pure $ all safe own

@@ -9,21 +9,23 @@   ) where -import Control.Exception (SomeException, try)-import Data.ByteString.Lazy qualified as LBS+import Control.Exception (IOException, try)+import Data.ByteString qualified as BS import Data.Function ((&)) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T import System.Directory qualified as Dir import System.Exit (ExitCode (..))+import System.IO (SeekMode (AbsoluteSeek), hFlush, hSeek)+import System.IO.Temp (withSystemTempFile) import System.Posix.User (getEffectiveUserName) import System.Process.Typed-  ( byteStringOutput,-    proc,-    readProcess,+  ( proc,+    runProcess,     setStderr,     setStdout,+    useHandleOpen,   )  -- | Run a process and capture its output.@@ -34,17 +36,23 @@   [String] ->   -- | (exit code, stdout, stderr)   IO (ExitCode, Text, Text)-runProcessCapture exe args = do-  let config =-        proc exe args-          & setStdout byteStringOutput-          & setStderr byteStringOutput-  (exitCode, stdout, stderr) <- readProcess config-  pure-    ( exitCode,-      T.decodeUtf8Lenient $ LBS.toStrict stdout,-      T.decodeUtf8Lenient $ LBS.toStrict stderr-    )+runProcessCapture exe args =+  withSystemTempFile "ephpg-stdout" $ \outPath out -> do+    Dir.removeFile outPath+    withSystemTempFile "ephpg-stderr" $ \errPath err -> do+      Dir.removeFile errPath+      -- Anonymous file-backed output avoids pipe-reader cleanup waiting for a+      -- child that has not yet been terminated during asynchronous cancellation.+      -- Unlink before launching so SIGKILL cannot leave output files behind.+      let config = proc exe args & setStdout (useHandleOpen out) & setStderr (useHandleOpen err)+      exitCode <- runProcess config+      hFlush out+      hFlush err+      hSeek out AbsoluteSeek 0+      hSeek err AbsoluteSeek 0+      stdout <- BS.hGetContents out+      stderr <- BS.hGetContents err+      pure (exitCode, T.decodeUtf8Lenient stdout, T.decodeUtf8Lenient stderr)  -- | Find an executable in PATH. findExecutable :: String -> IO (Maybe FilePath)@@ -55,5 +63,5 @@ getCurrentUser = do   result <- try getEffectiveUserName   case result of-    Left (_ :: SomeException) -> pure "postgres"+    Left (_ :: IOException) -> pure "postgres"     Right name -> pure $ T.pack name

@@ -11,7 +11,7 @@ where  import Control.Concurrent (threadDelay)-import Control.Exception (SomeException, mask_, try)+import Control.Exception (IOException, mask, mask_, onException, try) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (throwE) import Data.Function ((&))@@ -38,7 +38,8 @@ import System.Posix.Types (CPid (..)) import System.Process (getPid) import System.Process.Typed-  ( nullStream,+  ( getExitCode,+    nullStream,     proc,     runProcess,     setCreateGroup,@@ -63,7 +64,7 @@   -- | Username   Text ->   IO (Either StartError PostgresProcess)-startPostgres config dataDir socketDir port username = runStartup $ do+startPostgres config dataDir socketDir port username = mask $ \restore -> runStartup $ do   -- Find postgres executable   postgresPath <-     liftMaybe (PostgresStartError PostgresNotFound)@@ -81,7 +82,7 @@   -- Start the process   typedProcess <-     liftIO (try $ startProcess processConfig) >>= \case-      Left (ex :: SomeException) ->+      Left (ex :: IOException) ->         throwE $           PostgresStartError $             PostgresStartFailed@@ -117,7 +118,7 @@         maybe defaultConnectionTimeoutSeconds id $           getLast config.connectionTimeoutSeconds -  liftE (waitForPostgres socketDir port timeoutSecs)+  liftE (restore (waitForPostgres socketDir port timeoutSecs) `onException` stopPostgres pgProcess ShutdownImmediate 5)     `onError` do       -- Kill the server since it didn't start properly       _ <- stopPostgres pgProcess ShutdownImmediate 5@@ -175,7 +176,7 @@                   "1" -- 1 second timeout per attempt                 ]           result <--            try @SomeException $+            try @IOException $               runProcess $                 proc pgIsReadyPath args                   & setStdout nullStream@@ -188,7 +189,14 @@  -- | Stop the PostgreSQL server. stopPostgres :: PostgresProcess -> ShutdownMode -> Int -> IO (Maybe StopError)-stopPostgres PostgresProcess {..} mode timeoutSecs = mask_ $ do+stopPostgres pg@PostgresProcess {..} mode timeoutSecs = mask_ $ do+  exited <- getExitCode process+  case exited of+    Just _ -> pure Nothing+    Nothing -> stopRunning pg mode timeoutSecs++stopRunning :: PostgresProcess -> ShutdownMode -> Int -> IO (Maybe StopError)+stopRunning PostgresProcess {..} mode timeoutSecs = do   let signal = case mode of         ShutdownGraceful -> sigTERM         ShutdownFast -> sigINT@@ -197,9 +205,11 @@   -- Send the signal   result <- try $ signalProcess signal pid   case result of-    Left (_ :: SomeException) ->-      -- Process might already be dead-      pure Nothing+    Left (err :: IOException) -> do+      exited <- getExitCode process+      pure $ case exited of+        Just _ -> Nothing+        Nothing -> Just $ ShutdownSignalFailed (fromIntegral pid) (T.pack $ show err)     Right () -> do       -- Wait for the process to exit with timeout       let deadline = timeoutSecs * 1000000@@ -209,7 +219,7 @@         Just _ -> pure Nothing -- Exited normally         Nothing -> do           -- Timeout: force kill-          _ <- try @SomeException $ signalProcess sigKILL pid+          _ <- try @IOException $ signalProcess sigKILL pid           -- Wait a bit more for the forced kill           _ <- timeout 5000000 $ waitExitCode process           pure $ Just $ ShutdownTimedOut timeoutSecs

@@ -12,14 +12,22 @@     restoreFromCache,   ) import Hasql.Connection qualified as Connection+import StaleInstances qualified import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)+import System.Environment (getArgs, setEnv) import System.FilePath ((</>))-import System.IO.Temp (withSystemTempDirectory)+import System.IO.Temp (withSystemTempDirectory, withTempDirectory) import Test.Hspec import Test.QuickCheck  main :: IO ()-main = hspec $ do+main = do+  handled <- getArgs >>= StaleInstances.childMode+  if handled then pure () else withTempDirectory "/tmp" "epg-suite" $ \root -> setEnv "TMPDIR" root >> runTests++runTests :: IO ()+runTests = hspec $ do+  StaleInstances.spec   describe "EphemeralPg" $ do     it "can start and stop a database" $ do       result <- Pg.with $ \db -> do@@ -56,6 +64,7 @@                 Connection.release conn                 -- Port should be the same                 db'.port `shouldBe` port1+                Pg.stop db'       result `shouldSatisfy` isRight    describe "EphemeralPg caching" $ do

@@ -0,0 +1,368 @@+module StaleInstances (spec, childMode) where++import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar, threadDelay, throwTo)+import Control.Exception (AsyncException (ThreadKilled), bracket, finally, throwIO, try)+import Control.Monad (forM_, forever, when)+import Data.IORef+import Data.Monoid (Last (..))+import EphemeralPg qualified as Pg+import EphemeralPg.Config qualified as Config+import EphemeralPg.Database (PostgresProcess (..))+import EphemeralPg.Internal.Cache (getCacheDirectory, getCacheKey)+import EphemeralPg.Internal.Instance+import EphemeralPg.Internal.ProcessIdentity+import EphemeralPg.Internal.Sweep qualified as Sweep+import Hasql.Connection qualified as Connection+import System.Directory qualified as D+import System.Environment (getEnv, getExecutablePath, setEnv)+import System.FilePath+import System.IO+import System.IO.Temp (withTempDirectory)+import System.Posix.Files (setFileMode)+import System.Posix.Process (getProcessID)+import System.Posix.Signals (sigKILL, signalProcess)+import System.Posix.User (getEffectiveUserID)+import System.Process+import System.Timeout (timeout)+import Test.Hspec++childMode :: [String] -> IO Bool+childMode ["--stale-lock-child", root] = do+  (path, lease) <- registerInstance root+  putStrLn path+  hFlush stdout+  forever (threadDelay 1000000) `finally` releaseInstance lease+childMode ["--stale-db-child", root, mode] = do+  let config = Pg.defaultConfig {Pg.temporaryRoot = Last (Just root)}+      cache = Pg.defaultCacheConfig {Pg.root = Just (root </> "templates"), Pg.enabled = mode /= "disabled"}+      launch = if mode `elem` ["uncached", "legacy"] then Pg.start config else Pg.startCached config cache+  when (mode `elem` ["warm", "fallback"]) $ launch >>= either (fail . show) Pg.stop+  when (mode == "fallback") $ do+    let bin = root </> "bin"+    D.createDirectory bin+    writeFile (bin </> "cp") "#!/bin/sh\nexit 1\n"+    setFileMode (bin </> "cp") 0o700+    previous <- getEnv "PATH"+    setEnv "PATH" (bin <> ":" <> previous)+  db <- launch >>= either (fail . show) pure+  print (db.dataDirectory, db.process.pid)+  hFlush stdout+  forever (threadDelay 1000000) `finally` Pg.stop db+childMode _ = pure False++spec :: Spec+spec = describe "Stale instances" $ do+  it "excludes same-process claims and survives directory replacement" $+    withTempDirectory "/tmp" "epg" $ \rawRoot -> do+      root <- D.canonicalizePath rawRoot+      (path, lease) <- registerInstance root+      registry <- registryFor root+      let claim = claimInstance registry path $ \lock -> (lock == Nothing) `shouldBe` True+      ( do+          claim+          D.removeDirectory path+          claim+          D.createDirectory path+          claim+        )+        `finally` releaseInstance lease+      claimInstance registry path $ \lock -> (lock /= Nothing) `shouldBe` True+      releaseInstance lease+  it "releases ownership after a consumer is SIGKILLed" $+    withTempDirectory "/tmp" "epg" $ \rawRoot -> do+      root <- D.canonicalizePath rawRoot+      exe <- getExecutablePath+      bracket+        (createProcess (proc exe ["--stale-lock-child", root]) {std_out = CreatePipe})+        (\(_, output, _, process) -> terminateProcess process >> waitForProcess process >> mapM_ hClose output)+        $ \(_, output, _, process) -> case output of+          Nothing -> expectationFailure "Missing child pipe"+          Just handle -> do+            path <- timeout 5000000 (hGetLine handle) >>= maybe (fail "Child readiness timed out") pure+            registry <- registryFor root+            claimInstance registry path $ \lock -> (lock == Nothing) `shouldBe` True+            pid <- getPid process >>= maybe (fail "Missing child PID") pure+            signalProcess sigKILL pid+            _ <- waitForProcess process+            claimInstance registry path $ \lock -> (lock /= Nothing) `shouldBe` True+  it "classifies this live process without guessing identity" $ do+    pid <- getProcessID+    observation <- systemInspector.inspect pid+    case observation of+      Present ident -> ident.pid `shouldBe` pid+      other -> expectationFailure (show other)+  it "rejects malformed and unsafe PID records" $ do+    mapM_+      (\p -> parsePidRecord (p <> "\n/tmp/data\n1\n5432\n/tmp\nlocalhost\n1 1\nready\n") `shouldBe` Nothing)+      ["-2", "0", "1", "999999999999999999999999999"]+    parsePidRecord "123\n/tmp/data\n1\n" `shouldBe` Nothing++  it "removes dead tracked initialization debris exactly once across concurrent sweeps" $+    fixture $ \config path -> do+      first <- newEmptyMVar+      second <- newEmptyMVar+      _ <- forkIO $ Sweep.sweepWith goneInspector config >>= putMVar first+      _ <- forkIO $ Sweep.sweepWith goneInspector config >>= putMVar second+      results <- (<>) <$> takeMVar first <*> takeMVar second+      [p | (p, Sweep.Removed) <- results] `shouldBe` [path]+      Sweep.sweepWith goneInspector config `shouldReturn` []+  it "preserves missing legacy PID files, symlinks, permanent paths and malformed metadata" $+    fixture $ \config path -> do+      registry <- registryFor (takeDirectory path)+      writeFile (recordPath registry path) "invalid"+      Sweep.sweepWith goneInspector config `shouldReturn` [(path, Sweep.Failed)]+      D.removeFile (recordPath registry path)+      Sweep.sweepWith goneInspector config `shouldReturn` [(path, Sweep.Uncertain)]+      let link = takeDirectory path </> "ephpg-data-link"+      D.createDirectoryLink path link+      outcomes <- Sweep.sweepWith goneInspector config {Config.dataDirectory = Pg.DirectoryPermanent path}+      outcomes `shouldSatisfy` elem (path, Sweep.Active)+      outcomes `shouldSatisfy` elem (link, Sweep.Failed)+      D.doesDirectoryExist path `shouldReturn` True+  it "preserves uncertain owners and failed process enumeration" $+    fixture $ \config path -> do+      let uncertain = goneInspector {inspect = \_ -> pure (Unknown "permission denied")}+      Sweep.sweepWith uncertain config `shouldReturn` [(path, Sweep.Uncertain)]+      Sweep.sweepWith goneInspector {enumerate = pure (Left "enumeration failed")} config+        `shouldReturn` [(path, Sweep.Uncertain)]+      D.doesDirectoryExist path `shouldReturn` True+  it "rejects symlinked metadata and lifetime lock files" $+    fixture $ \config path -> do+      registry <- registryFor (takeDirectory path)+      let metadata = recordPath registry path+          saved = metadata <> ".saved"+          lock = registry </> takeFileName path <.> "lock"+      D.renameFile metadata saved+      D.createFileLink saved metadata+      Sweep.sweepWith goneInspector config `shouldReturn` [(path, Sweep.Failed)]+      D.removeFile metadata+      D.renameFile saved metadata+      D.renameFile lock (lock <> ".saved")+      D.createFileLink (lock <> ".saved") lock+      Sweep.sweepWith goneInspector config `shouldReturn` [(path, Sweep.Failed)]+      D.doesDirectoryExist path `shouldReturn` True+  it "does not remove data when ownership metadata changes during inspection" $+    fixture $ \config path -> do+      registry <- registryFor (takeDirectory path)+      let inspector = goneInspector {inspect = \_ -> writeFile (recordPath registry path) "changed" >> pure Gone}+      Sweep.sweepWith inspector config `shouldReturn` [(path, Sweep.Failed)]+      D.doesDirectoryExist path `shouldReturn` True+  it "propagates asynchronous cancellation" $+    fixture $ \config _ -> do+      result <- try @AsyncException $ Sweep.sweepWith goneInspector {inspect = \_ -> throwIO ThreadKilled} config+      result `shouldBe` Left ThreadKilled+  it "rejects replacement of the candidate during inspection" $+    fixture $ \config path -> do+      changed <- newIORef False+      let inspector =+            goneInspector+              { inspect = \_ -> do+                  old <- atomicModifyIORef' changed (\x -> (True, x))+                  if old then pure () else D.renameDirectory path (path <> "-saved") >> D.createDirectory path+                  pure Gone+              }+      results <- Sweep.sweepWith inspector config+      results `shouldSatisfy` elem (path, Sweep.Failed)+      D.doesDirectoryExist path `shouldReturn` True++  it "never signals reused PIDs, changed start identities, or non-orphan legacy servers" $+    fixture $ \config path -> do+      uid <- getEffectiveUserID+      let ident =+            Identity+              12345+              1+              uid+              1700000000+              "/test/postgres"+              ("/test/postgres -D " <> path <> " -k /tmp/socket")+              (Just path)+              False+      writeFile (path </> "postmaster.pid") (pidText path)+      signals <- newIORef []+      let run current =+            Sweep.sweepWith+              goneInspector+                { inspect = \pid -> pure $ if pid == 12345 then Present current else Gone,+                  interrupt = \pid -> modifyIORef' signals (pid :)+                }+              config+      run ident {command = "/test/unrelated"} `shouldReturn` [(path, Sweep.Uncertain)]+      run (Identity ident.pid ident.parent ident.uid 1800000000 ident.command ident.arguments ident.workingDirectory ident.zombie) `shouldReturn` [(path, Sweep.Uncertain)]+      registry <- registryFor (takeDirectory path)+      D.removeFile (recordPath registry path)+      writeFile (path </> "PG_VERSION") "17\n"+      run ident {parent = 42} `shouldReturn` [(path, Sweep.Active)]+      readIORef signals `shouldReturn` []+  it "leaves a timed-out server intact without escalating" $+    fixture $ \config path -> do+      uid <- getEffectiveUserID+      let ident =+            Identity+              12345+              1+              uid+              1700000000+              "/test/postgres"+              ("/test/postgres -D " <> path <> " -k /tmp/socket")+              (Just path)+              False+      writeFile (path </> "postmaster.pid") (pidText path)+      signals <- newIORef []+      Sweep.sweepWith+        goneInspector+          { inspect = \pid -> pure $ if pid == 12345 then Present ident else Gone,+            enumerate = pure (Right [ident]),+            interrupt = \pid -> modifyIORef' signals (pid :)+          }+        config+        `shouldReturn` [(path, Sweep.TimedOut)]+      readIORef signals `shouldReturn` [12345]+      D.doesDirectoryExist path `shouldReturn` True+  it "preserves an orphaned initialization child" $+    fixture $ \config path -> do+      uid <- getEffectiveUserID+      let ident = Identity 12345 1 uid 1700000000 "/test/initdb" "initdb" (Just path) False+      Sweep.sweepWith goneInspector {enumerate = pure (Right [ident])} config+        `shouldReturn` [(path, Sweep.Uncertain)]++  it "combines the automatic-sweep setting with right-biased identity" $ do+    let enabled = mempty {Pg.sweepStaleOnStart = Last (Just True)}+        disabled = mempty {Pg.sweepStaleOnStart = Last (Just False)}+    (mempty <> disabled).sweepStaleOnStart `shouldBe` Last (Just False)+    (disabled <> mempty).sweepStaleOnStart `shouldBe` Last (Just False)+    (enabled <> disabled).sweepStaleOnStart `shouldBe` Last (Just False)+    Pg.defaultConfig.sweepStaleOnStart `shouldBe` Last (Just True)+  it "preserves permanent data through both startup variants" $+    withTempDirectory "/tmp" "epg" $ \rawRoot -> do+      root <- D.canonicalizePath rawRoot+      forM_ [False, True] $ \cached -> do+        let path = root </> ("ephpg-data-permanent-" <> show cached)+            config = Pg.defaultConfig {Pg.temporaryRoot = Last (Just root), Config.dataDirectory = Pg.DirectoryPermanent path}+            launch = if cached then Pg.startCached config Pg.defaultCacheConfig else Pg.start config+        bracket (launch >>= either (fail . show) pure) Pg.stop $ \db -> db.dataDirectory `shouldBe` path+        Pg.sweepStaleInstances config `shouldReturn` []+        D.doesFileExist (path </> "PG_VERSION") `shouldReturn` True+  it "cleans failed startup before and after PostgreSQL launch" $+    withTempDirectory "/tmp" "epg" $ \rawRoot -> do+      root <- D.canonicalizePath rawRoot+      let config = Pg.defaultConfig {Pg.temporaryRoot = Last (Just root)}+      forM_+        [ config {Pg.initDbArgs = ["--invalid-ephemeral-test"]},+          config {Config.databaseName = "broken", Pg.createDbArgs = ["--invalid-ephemeral-test"]}+        ]+        $ \broken -> do+          result <- Pg.start broken+          case result of Left _ -> pure (); Right db -> Pg.stop db >> expectationFailure "Expected startup failure"+          names <- D.listDirectory root+          filter (\name -> take 11 name == "ephpg-data-") names `shouldBe` []++  forM_ ["initdb", "cp", "createdb"] $ \tool ->+    it ("protects ownership and propagates cancellation at the " <> tool <> " startup barrier") $+      withTempDirectory "/tmp" "epg" $ \rawRoot -> do+        root <- D.canonicalizePath rawRoot+        let config = Pg.defaultConfig {Pg.temporaryRoot = Last (Just root), Config.databaseName = "barrierdb"}+            cache = Pg.defaultCacheConfig {Pg.root = Just (root </> "templates")}+            launch = if tool == "cp" then Pg.startCached config cache else Pg.start config+            bin = root </> "bin"+            marker = root </> "barrier"+        when (tool == "cp") $ launch >>= either (fail . show) Pg.stop+        D.createDirectory bin+        writeFile (bin </> tool) ("#!/bin/sh\nprintf ready > " <> show marker <> "\nexec sleep 60\n")+        setFileMode (bin </> tool) 0o700+        bracket (getEnv "PATH") (setEnv "PATH") $ \previous -> do+          setEnv "PATH" (bin <> ":" <> previous)+          done <- newEmptyMVar+          worker <- forkIO $ try @AsyncException launch >>= putMVar done+          let awaitBarrier = D.doesFileExist marker >>= \ready -> if ready then pure () else threadDelay 10000 >> awaitBarrier+          flip finally (throwTo worker ThreadKilled) $ do+            timeout 15000000 awaitBarrier >>= maybe (fail "Startup barrier timed out") pure+            Pg.sweepStaleInstances config `shouldReturn` []+            throwTo worker ThreadKilled+            result <- timeout 10000000 (takeMVar done) >>= maybe (fail "Cancellation cleanup timed out") pure+            case result of Left ThreadKilled -> pure (); _ -> expectationFailure "Cancellation was swallowed"+            names <- D.listDirectory root+            filter (\name -> take 11 name == "ephpg-data-") names `shouldBe` []++  forM_ ["uncached", "cold", "warm", "disabled", "fallback", "legacy"] $ \mode ->+    forM_ [False, True] $ \automatic ->+      it ("recovers " <> mode <> " orphan with " <> (if automatic then "startup" else "explicit sweep") <> " and preserves live connections") $+        withTempDirectory "/tmp" "epg" $ \rawRoot -> do+          root <- D.canonicalizePath rawRoot+          let config = Pg.defaultConfig {Pg.temporaryRoot = Last (Just root)}+          bracket (Pg.start config >>= either (fail . show) pure) Pg.stop $ \survivor -> do+            exe <- getExecutablePath+            bracket+              (createProcess (proc exe ["--stale-db-child", root, mode]) {std_out = CreatePipe})+              (\(_, output, _, process) -> terminateProcess process >> waitForProcess process >> mapM_ hClose output)+              $ \(_, output, _, process) -> case output of+                Nothing -> expectationFailure "Missing child pipe"+                Just handle -> do+                  line <- timeout 15000000 (hGetLine handle) >>= maybe (fail "Child readiness timed out") pure+                  let (path, pgPid) = read line+                  let cleanup = do+                        _ <- Sweep.sweepStaleInstances config+                        exists <- D.doesFileExist (path </> "postmaster.pid")+                        if exists+                          then do+                            _ <- readProcessWithExitCode "pg_ctl" ["-D", path, "-m", "fast", "-w", "stop"] ""+                            pure ()+                          else pure ()+                  ( do+                      record <- boundedRead (path </> "postmaster.pid") >>= maybe (fail "Bad PID record") pure . parsePidRecord+                      observed <- systemInspector.inspect pgPid+                      case observed of+                        Present ident -> do+                          uid <- getEffectiveUserID+                          (ident, matchesServer uid record ident) `shouldSatisfy` snd+                          ident.pid `shouldBe` record.pid+                          -- Report enough evidence to diagnose OS identity disagreements.+                          abs (ident.started - record.started) `shouldSatisfy` (<= 2)+                        other -> expectationFailure (show other)+                      pid <- getPid process >>= maybe (fail "Missing child PID") pure+                      signalProcess sigKILL pid+                      _ <- waitForProcess process+                      systemInspector.inspect pgPid >>= (\case Present _ -> pure (); other -> expectationFailure (show other))+                      when (mode == "legacy") $ do+                        registry <- registryFor root+                        D.removeFile (recordPath registry path)+                      -- Opt-out startup must leave the orphan available for explicit cleanup.+                      bracket (Pg.start config {Pg.sweepStaleOnStart = Last (Just False)} >>= either (fail . show) pure) Pg.stop $ \_ ->+                        D.doesDirectoryExist path `shouldReturn` True+                      if automatic+                        then bracket (Pg.start config >>= either (fail . show) pure) Pg.stop $ \_ -> pure ()+                        else Pg.sweepStaleInstances config `shouldReturn` [path]+                      when (mode `elem` ["cold", "warm", "fallback"]) $ do+                        key <- getCacheKey config >>= either (fail . show) pure+                        cacheDir <- getCacheDirectory key (Just (root </> "templates"))+                        version <- readFile (cacheDir </> "data" </> "PG_VERSION")+                        bracket (Pg.startCached config Pg.defaultCacheConfig {Pg.root = Just (root </> "templates")} >>= either (fail . show) pure) Pg.stop $ \_ -> pure ()+                        readFile (cacheDir </> "data" </> "PG_VERSION") `shouldReturn` version+                      connected <- Connection.acquire (Pg.connectionSettings survivor)+                      either (fail . show) Connection.release connected+                      D.doesDirectoryExist path `shouldReturn` False+                      Sweep.sweepStaleInstances config `shouldReturn` []+                      D.doesDirectoryExist survivor.dataDirectory `shouldReturn` True+                    )+                    `finally` cleanup++goneInspector :: Inspector+goneInspector =+  Inspector+    { inspect = \_ -> pure Gone,+      enumerate = pure (Right []),+      interrupt = \_ -> expectationFailure "Unexpected signal"+    }++fixture :: (Pg.Config -> FilePath -> IO a) -> IO a+fixture action = withTempDirectory "/tmp" "epg" $ \rawRoot -> do+  root <- D.canonicalizePath rawRoot+  (path, lease) <- registerInstance root+  registry <- registryFor root+  record <- readRecord registry path+  releaseInstance lease+  writeFile (recordPath registry path) (show record {owner = 999999})+  action Pg.defaultConfig {Pg.temporaryRoot = Last (Just root)} path++pidText :: FilePath -> String+pidText path = "12345\n" <> path <> "\n1700000000\n5432\n/tmp/socket\n127.0.0.1\n1 1\nready\n"