tmp-postgres-1.34.0.1: resource-soak-test/Main.hs

module Main where

import Control.Exception
import Control.Concurrent
import Database.Postgres.Temp
import Control.Concurrent.Async
import qualified Database.PostgreSQL.Simple as PG
import System.Exit
import System.IO.Temp
import System.Process
import Control.Monad (unless, forM_, forever, void)
import System.Directory


withConn :: DB -> (PG.Connection -> IO a) -> IO a
withConn db = bracket (PG.connectPostgreSQL $ toConnectionString db ) PG.close

countPostgresProcesses :: IO Int
countPostgresProcesses = countProcesses "postgres"

countInitdbProcesses :: IO Int
countInitdbProcesses = countProcesses "initdb"

countCreatedbProcesses :: IO Int
countCreatedbProcesses = countProcesses "createdb"

countProcesses :: String -> IO Int
countProcesses processName = do
  -- TODO we should restrict to child process
  (exitCode, xs, _) <-  readProcessWithExitCode "pgrep" [processName] []

  unless (exitCode == ExitSuccess || exitCode == ExitFailure 1) $ throwIO exitCode

  pure $ length $ lines xs

main :: IO ()
main = withTempDirectory "/tmp" "tmp-postgres-spec" $ \directoryPath ->
  forM_ [0, 10 .. 1000000] $ \theDelay -> do
    let theConfig = defaultConfig
          { temporaryDirectory = pure directoryPath
          }

    initialContents <- listDirectory directoryPath

    initialPostgresCount <- countPostgresProcesses
    initialInitdbCount <- countInitdbProcesses
    initialCreatedbCount <- countCreatedbProcesses

    thread <- async $ withConfig theConfig $ flip withConn $ \conn -> forever $ do
      (_one :: Int) <- fmap (PG.fromOnly . head) $ PG.query_ conn "SELECT 1"
      threadDelay 1000

    threadDelay theDelay
    throwTo (asyncThreadId thread) $ userError "stop already"

    void $ waitCatch thread

    finalContents <- listDirectory directoryPath
    finalPostgresCount <- countPostgresProcesses
    finalInitdbCount <- countInitdbProcesses
    finalCreatedbCount <- countCreatedbProcesses

    unless (initialPostgresCount == finalPostgresCount) $
      throwIO $ userError $ unlines
        [ "failed to clean up postgres"
        , "had"
        , show initialPostgresCount
        , "initially and now have"
        , show finalPostgresCount
        ]

    unless (initialInitdbCount == finalInitdbCount) $
      throwIO $ userError $ unlines
        [ "failed to clean up initdb"
        , "had"
        , show initialInitdbCount
        , "initially and now have"
        , show finalInitdbCount
        ]

    unless (initialCreatedbCount == finalCreatedbCount) $
      throwIO $ userError $ unlines
        [ "failed to clean up createdb"
        , "had"
        , show initialCreatedbCount
        , "initially and now have"
        , show finalCreatedbCount
        ]

    unless (initialContents == finalContents) $ do
      renameDirectory directoryPath $ directoryPath <> "_failed"
      throwIO $ userError $ unlines
        [ "failed to clean up files"
        , "had"
        , unlines initialContents
        , "initially and now have"
        , unlines finalContents
        ]