{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}

{-|

This module provides tools for introducing PostgreSQL databases, either via a container (Docker or Podman) or
via a raw process (typically obtaining the binary from Nix).

The container method is traditional, but the raw method can be nice because it tends to leave less junk on the
system such as container images, networks, and volumes.

A note about raw processes and random TCP ports: starting a Postgres process on a randomly chosen port is tricky,
because Postgres currently lacks a setting for choosing its own port and reporting it back to us. So, the only way
to start it on a random TCP port is to first manually  find a free port on the system and then start Postgres
with it. Since this procedure is inherently racy, it can cause failures if your tests are starting lots of
Postgres instances (or other network-using processes) in parallel. This module takes a different approach: it starts
the Postgres instance on a Unix socket, which can never fail. You can connect to it via the Unix socket directly if
you like. If you use the TCP-based methods like 'introducePostgresViaNix', they will open a TCP socket inside the
test process and then run a proxy to forward packets to the Postgres server's Unix socket.

-}

module Test.Sandwich.Contexts.PostgreSQL (
#ifndef mingw32_HOST_OS
  -- * Raw PostgreSQL via Nix (TCP socket)
  introducePostgresViaNix
  , withPostgresViaNix

  -- * Raw PostgreSQL via Nix (Unix socket)
  , introducePostgresUnixSocketViaNix
  , withPostgresUnixSocketViaNix

  -- * Containerized PostgreSQL
  , introducePostgresViaContainer
  , withPostgresContainer

  -- * Types
  , PostgresNixOptions(..)
  , defaultPostgresNixOptions

  , postgres
  , PostgresContext(..)

  , PostgresContainerOptions(..)
  , defaultPostgresContainerOptions

  -- * Re-exports
  , NetworkAddress(..)
#endif
  ) where

#ifndef mingw32_HOST_OS
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import qualified Data.Map as M
import Data.String.Interpolate
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Relude hiding (withFile)
import System.Exit
import System.FilePath
import System.IO.Temp
import System.PosixCompat.Files (getFileStatus, isSocket)
import Test.Sandwich
import Test.Sandwich.Contexts.Container
import Test.Sandwich.Contexts.Nix
import Test.Sandwich.Contexts.ReverseProxy.TCP
import Test.Sandwich.Contexts.Types.Network
import Test.Sandwich.Contexts.Util.UUID (makeUUID)
import Test.Sandwich.Contexts.UnixSocketPath
import UnliftIO.Directory
import UnliftIO.Environment
import UnliftIO.Exception
import UnliftIO.IO (hClose, withFile)
import UnliftIO.Process

-- * Labels

postgres :: Label "postgres" PostgresContext
postgres :: Label "postgres" PostgresContext
postgres = Label "postgres" PostgresContext
forall {k} (l :: Symbol) (a :: k). Label l a
Label

-- * Types

data PostgresNixOptions = PostgresNixOptions {
  -- | Postgres version to use within the Nixpkgs snapshot of your 'NixContext'.
  -- Defaults to "postgresql", but you can pick specific versions like @postgresql_15@.
  -- See @\<nixpkgs\>\/top-level\/all-packages.nix@ for the available versions in your
  -- snapshot.
  PostgresNixOptions -> Text
postgresNixPostgres :: Text
  -- | Postgres username. Default to @postgres@.
  , PostgresNixOptions -> Text
postgresNixUsername :: Text
  -- | Postgres password. Default to @postgres@.
  , PostgresNixOptions -> Text
postgresNixPassword :: Text
  -- | Postgres default database. The @postgres@ database is always created, but you
  -- can create an additional one here. Defaults to @test@.
  , PostgresNixOptions -> Text
postgresNixDatabase :: Text
  }
defaultPostgresNixOptions :: PostgresNixOptions
defaultPostgresNixOptions :: PostgresNixOptions
defaultPostgresNixOptions = PostgresNixOptions {
  postgresNixPostgres :: Text
postgresNixPostgres = Text
"postgresql"
  , postgresNixUsername :: Text
postgresNixUsername = Text
"postgres"
  , postgresNixPassword :: Text
postgresNixPassword = Text
"postgres"
  , postgresNixDatabase :: Text
postgresNixDatabase = Text
"test"
  }

data PostgresContext = PostgresContext {
  PostgresContext -> Text
postgresUsername :: Text
  , PostgresContext -> Text
postgresPassword :: Text
  , PostgresContext -> Text
postgresDatabase :: Text
  , PostgresContext -> NetworkAddress
postgresAddress :: NetworkAddress
  , PostgresContext -> Text
postgresConnString :: Text
  -- | The address of the database server within its container (if it was started
  -- using a container).
  -- Useful when the test is also in a container, and containers are networked together.
  , PostgresContext -> Maybe NetworkAddress
postgresContainerAddress :: Maybe NetworkAddress
  } deriving (Int -> PostgresContext -> ShowS
[PostgresContext] -> ShowS
PostgresContext -> String
(Int -> PostgresContext -> ShowS)
-> (PostgresContext -> String)
-> ([PostgresContext] -> ShowS)
-> Show PostgresContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PostgresContext -> ShowS
showsPrec :: Int -> PostgresContext -> ShowS
$cshow :: PostgresContext -> String
show :: PostgresContext -> String
$cshowList :: [PostgresContext] -> ShowS
showList :: [PostgresContext] -> ShowS
Show)


-- * Binary

-- initdb -D mydb
-- echo "listen_addresses=''" >> mydb/postgresql.conf
-- pg_ctl -D mydb -l logfile -o "--unix_socket_directories='$PWD'" start --wait
-- pg_ctl -D mydb -l logfile stop --wait

-- | Introduce a PostgreSQL instance, using a suitable package from Nix.
introducePostgresViaNix :: (
  HasBaseContext context, HasNixContext context
  , MonadUnliftIO m, MonadMask m
  )
  -- | Options
  => PostgresNixOptions
  -> SpecFree (LabelValue "postgres" PostgresContext :> context) m ()
  -> SpecFree context m ()
introducePostgresViaNix :: forall context (m :: * -> *).
(HasBaseContext context, HasNixContext context, MonadUnliftIO m,
 MonadMask m) =>
PostgresNixOptions
-> SpecFree (LabelValue "postgres" PostgresContext :> context) m ()
-> SpecFree context m ()
introducePostgresViaNix PostgresNixOptions
opts = String
-> Label "postgres" PostgresContext
-> ((HasCallStack =>
     PostgresContext -> ExampleT context m [Result])
    -> ExampleT context m ())
-> Free
     (SpecCommand (LabelValue "postgres" PostgresContext :> context) m)
     ()
-> Free (SpecCommand context m) ()
forall (l :: Symbol) intro context (m :: * -> *).
HasCallStack =>
String
-> Label l intro
-> ((HasCallStack => intro -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduceWith String
"PostgreSQL via Nix" Label "postgres" PostgresContext
postgres (((HasCallStack => PostgresContext -> ExampleT context m [Result])
  -> ExampleT context m ())
 -> Free
      (SpecCommand (LabelValue "postgres" PostgresContext :> context) m)
      ()
 -> Free (SpecCommand context m) ())
-> ((HasCallStack =>
     PostgresContext -> ExampleT context m [Result])
    -> ExampleT context m ())
-> Free
     (SpecCommand (LabelValue "postgres" PostgresContext :> context) m)
     ()
-> Free (SpecCommand context m) ()
forall a b. (a -> b) -> a -> b
$ \HasCallStack => PostgresContext -> ExampleT context m [Result]
action ->
  PostgresNixOptions
-> (PostgresContext -> ExampleT context m ())
-> ExampleT context m ()
forall context (m :: * -> *) a.
(HasBaseContextMonad context m, HasNixContext context,
 MonadUnliftIO m, MonadMask m, MonadFail m, MonadLogger m) =>
PostgresNixOptions -> (PostgresContext -> m a) -> m a
withPostgresViaNix PostgresNixOptions
opts (ExampleT context m [Result] -> ExampleT context m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExampleT context m [Result] -> ExampleT context m ())
-> (PostgresContext -> ExampleT context m [Result])
-> PostgresContext
-> ExampleT context m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PostgresContext -> ExampleT context m [Result]
PostgresContext -> ExampleT context m [Result]
action)

-- | Bracket-style variant of 'introducePostgresViaNix'.
withPostgresViaNix :: (
  HasBaseContextMonad context m, HasNixContext context
  , MonadUnliftIO m, MonadMask m, MonadFail m, MonadLogger m
  )
  -- | Options
  => PostgresNixOptions
  -> (PostgresContext -> m a)
  -> m a
withPostgresViaNix :: forall context (m :: * -> *) a.
(HasBaseContextMonad context m, HasNixContext context,
 MonadUnliftIO m, MonadMask m, MonadFail m, MonadLogger m) =>
PostgresNixOptions -> (PostgresContext -> m a) -> m a
withPostgresViaNix opts :: PostgresNixOptions
opts@(PostgresNixOptions {Text
postgresNixPostgres :: PostgresNixOptions -> Text
postgresNixUsername :: PostgresNixOptions -> Text
postgresNixPassword :: PostgresNixOptions -> Text
postgresNixDatabase :: PostgresNixOptions -> Text
postgresNixPostgres :: Text
postgresNixUsername :: Text
postgresNixPassword :: Text
postgresNixDatabase :: Text
..}) PostgresContext -> m a
action = do
  PostgresNixOptions -> (String -> m a) -> m a
forall context (m :: * -> *) a.
(HasBaseContextMonad context m, HasNixContext context,
 MonadUnliftIO m, MonadFail m, MonadMask m, MonadLogger m) =>
PostgresNixOptions -> (String -> m a) -> m a
withPostgresUnixSocketViaNix PostgresNixOptions
opts ((String -> m a) -> m a) -> (String -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \String
unixSocket ->
    String -> (PortNumber -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (PortNumber -> m a) -> m a
withProxyToUnixSocket String
unixSocket ((PortNumber -> m a) -> m a) -> (PortNumber -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \PortNumber
port ->
      PostgresContext -> m a
action (PostgresContext -> m a) -> PostgresContext -> m a
forall a b. (a -> b) -> a -> b
$ PostgresContext {
        postgresUsername :: Text
postgresUsername = Text
postgresNixUsername
        , postgresPassword :: Text
postgresPassword = Text
postgresNixPassword
        , postgresDatabase :: Text
postgresDatabase = Text
postgresNixDatabase
        , postgresAddress :: NetworkAddress
postgresAddress = String -> PortNumber -> NetworkAddress
NetworkAddressTCP String
"localhost" PortNumber
port
        , postgresConnString :: Text
postgresConnString = [i|postgresql://#{postgresNixUsername}:#{postgresNixPassword}@localhost:#{port}/#{postgresNixDatabase}|]
        , postgresContainerAddress :: Maybe NetworkAddress
postgresContainerAddress = Maybe NetworkAddress
forall a. Maybe a
Nothing
        }

-- | Same as 'introducePostgresViaNix', but the 'postgresAddress' of the 'PostgresContext' will be a Unix socket.
introducePostgresUnixSocketViaNix :: (
  HasBaseContext context, HasNixContext context
  , MonadUnliftIO m, MonadMask m
  )
  -- | Options
  => PostgresNixOptions
  -> SpecFree (LabelValue "postgres" PostgresContext :> context) m ()
  -> SpecFree context m ()
introducePostgresUnixSocketViaNix :: forall context (m :: * -> *).
(HasBaseContext context, HasNixContext context, MonadUnliftIO m,
 MonadMask m) =>
PostgresNixOptions
-> SpecFree (LabelValue "postgres" PostgresContext :> context) m ()
-> SpecFree context m ()
introducePostgresUnixSocketViaNix opts :: PostgresNixOptions
opts@(PostgresNixOptions {Text
postgresNixPostgres :: PostgresNixOptions -> Text
postgresNixUsername :: PostgresNixOptions -> Text
postgresNixPassword :: PostgresNixOptions -> Text
postgresNixDatabase :: PostgresNixOptions -> Text
postgresNixPostgres :: Text
postgresNixUsername :: Text
postgresNixPassword :: Text
postgresNixDatabase :: Text
..}) = String
-> Label "postgres" PostgresContext
-> ((HasCallStack =>
     PostgresContext -> ExampleT context m [Result])
    -> ExampleT context m ())
-> Free
     (SpecCommand (LabelValue "postgres" PostgresContext :> context) m)
     ()
-> Free (SpecCommand context m) ()
forall (l :: Symbol) intro context (m :: * -> *).
HasCallStack =>
String
-> Label l intro
-> ((HasCallStack => intro -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduceWith String
"PostgreSQL via Nix" Label "postgres" PostgresContext
postgres (((HasCallStack => PostgresContext -> ExampleT context m [Result])
  -> ExampleT context m ())
 -> Free
      (SpecCommand (LabelValue "postgres" PostgresContext :> context) m)
      ()
 -> Free (SpecCommand context m) ())
-> ((HasCallStack =>
     PostgresContext -> ExampleT context m [Result])
    -> ExampleT context m ())
-> Free
     (SpecCommand (LabelValue "postgres" PostgresContext :> context) m)
     ()
-> Free (SpecCommand context m) ()
forall a b. (a -> b) -> a -> b
$ \HasCallStack => PostgresContext -> ExampleT context m [Result]
action -> do
  PostgresNixOptions
-> (String -> ExampleT context m ()) -> ExampleT context m ()
forall context (m :: * -> *) a.
(HasBaseContextMonad context m, HasNixContext context,
 MonadUnliftIO m, MonadFail m, MonadMask m, MonadLogger m) =>
PostgresNixOptions -> (String -> m a) -> m a
withPostgresUnixSocketViaNix PostgresNixOptions
opts ((String -> ExampleT context m ()) -> ExampleT context m ())
-> (String -> ExampleT context m ()) -> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ \String
unixSocket -> do
    ExampleT context m [Result] -> ExampleT context m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExampleT context m [Result] -> ExampleT context m ())
-> ExampleT context m [Result] -> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => PostgresContext -> ExampleT context m [Result]
PostgresContext -> ExampleT context m [Result]
action (PostgresContext -> ExampleT context m [Result])
-> PostgresContext -> ExampleT context m [Result]
forall a b. (a -> b) -> a -> b
$ PostgresContext {
      postgresUsername :: Text
postgresUsername = Text
postgresNixUsername
      , postgresPassword :: Text
postgresPassword = Text
postgresNixPassword
      , postgresDatabase :: Text
postgresDatabase = Text
postgresNixDatabase
      , postgresAddress :: NetworkAddress
postgresAddress = String -> NetworkAddress
NetworkAddressUnix String
unixSocket
      , postgresConnString :: Text
postgresConnString = [i|postgresql://#{postgresNixUsername}:#{postgresNixPassword}@/#{postgresNixDatabase}?host=#{takeDirectory unixSocket}|]
      , postgresContainerAddress :: Maybe NetworkAddress
postgresContainerAddress = Maybe NetworkAddress
forall a. Maybe a
Nothing
      }

-- | Bracket-style variant of 'introducePostgresUnixSocketViaNix'.
withPostgresUnixSocketViaNix :: (
  HasBaseContextMonad context m, HasNixContext context
  , MonadUnliftIO m, MonadFail m, MonadMask m, MonadLogger m
  )
  -- | Options
  => PostgresNixOptions
  -> (FilePath -> m a)
  -> m a
withPostgresUnixSocketViaNix :: forall context (m :: * -> *) a.
(HasBaseContextMonad context m, HasNixContext context,
 MonadUnliftIO m, MonadFail m, MonadMask m, MonadLogger m) =>
PostgresNixOptions -> (String -> m a) -> m a
withPostgresUnixSocketViaNix (PostgresNixOptions {Text
postgresNixPostgres :: PostgresNixOptions -> Text
postgresNixUsername :: PostgresNixOptions -> Text
postgresNixPassword :: PostgresNixOptions -> Text
postgresNixDatabase :: PostgresNixOptions -> Text
postgresNixPostgres :: Text
postgresNixUsername :: Text
postgresNixPassword :: Text
postgresNixDatabase :: Text
..}) String -> m a
action = do
  String
postgresBinDir <- (String -> ShowS
</> String
"bin") ShowS -> m String -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> m String
forall context (m :: * -> *).
(HasBaseContextMonad context m, HasNixContext context,
 MonadUnliftIO m, MonadLogger m) =>
[Text] -> m String
buildNixSymlinkJoin [Text
postgresNixPostgres]
  String -> Text -> Text -> Text -> (String -> m a) -> m a
forall context (m :: * -> *) a.
(HasBaseContextMonad context m, MonadUnliftIO m, MonadFail m,
 MonadMask m, MonadLogger m) =>
String -> Text -> Text -> Text -> (String -> m a) -> m a
withPostgresUnixSocket String
postgresBinDir Text
postgresNixUsername Text
postgresNixPassword Text
postgresNixDatabase String -> m a
action

-- | The lowest-level raw process version.
withPostgresUnixSocket :: (
  HasBaseContextMonad context m
  , MonadUnliftIO m, MonadFail m, MonadMask m, MonadLogger m
  )
  -- | Postgres binary dir
  => FilePath
  -- | Username
  -> Text
  -- | Password
  -> Text
  -- | Database
  -> Text
  -- | Action callback
  -> (FilePath -> m a)
  -> m a
withPostgresUnixSocket :: forall context (m :: * -> *) a.
(HasBaseContextMonad context m, MonadUnliftIO m, MonadFail m,
 MonadMask m, MonadLogger m) =>
String -> Text -> Text -> Text -> (String -> m a) -> m a
withPostgresUnixSocket String
postgresBinDir Text
username Text
password Text
database String -> m a
action = do
  Just String
dir <- m (Maybe String)
forall context (m :: * -> *).
HasBaseContextMonad context m =>
m (Maybe String)
getCurrentFolder
  String
baseDir <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
createTempDirectory String
dir String
"postgres-nix"
  let dbDirName :: String
dbDirName = String
baseDir String -> ShowS
</> String
"db"
  let logfileName :: String
logfileName = String
baseDir String -> ShowS
</> String
"logfile"

  -- The Unix socket can't live in the sandwich test tree because it has an absurdly short length
  -- requirement (107 bytes on Linux, 104 bytes on macOS). See
  -- https://unix.stackexchange.com/questions/367008/why-is-socket-path-length-limited-to-a-hundred-chars
  String -> Int -> (String -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> Int -> (String -> m a) -> m a
withUnixSocketDirectory String
"postgres-sock" Int
20 ((String -> m a) -> m a) -> (String -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \String
unixSockDir -> m String -> (String -> m ()) -> (String -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    (do
        Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
info [i|Unix sock dir: #{unixSockDir}|]

        -- Run initdb
        [(String, String)]
baseEnv <- m [(String, String)]
forall (m :: * -> *). MonadIO m => m [(String, String)]
getEnvironment
        let env :: [(String, String)]
env = (String
"LC_ALL", String
"C")
                (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: (String
"LC_CTYPE", String
"C")
                (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: [(String, String)]
baseEnv
        String -> String -> (String -> Handle -> m ()) -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> String -> (String -> Handle -> m a) -> m a
withTempFile String
baseDir String
"pwfile" ((String -> Handle -> m ()) -> m ())
-> (String -> Handle -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
pwfile Handle
h -> do
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStrLn Handle
h Text
password
          Handle -> m ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h
          CreateProcess -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging ((String -> [String] -> CreateProcess
proc (String
postgresBinDir String -> ShowS
</> String
"initdb") [String
dbDirName
                                                                          , String
"--username", Text -> String
forall a. ToString a => a -> String
toString Text
username
                                                                          , String
"-A", String
"md5"
                                                                          , String
"--pwfile", String
pwfile
                                                                          ]) {
                                       cwd = Just dir
                                       , env = Just env
                                       })
            m ProcessHandle -> (ProcessHandle -> m ExitCode) -> m ExitCode
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProcessHandle -> m ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess m ExitCode -> (ExitCode -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ExitCode -> ExitCode -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Eq a, Show a) =>
a -> a -> m ()
`shouldBe` ExitCode
ExitSuccess)

        -- Turn off the TCP interface; we'll have it listen solely on a Unix socket
        String -> IOMode -> (Handle -> m ()) -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withFile (String
dir String -> ShowS
</> String
dbDirName String -> ShowS
</> String
"postgresql.conf") IOMode
AppendMode ((Handle -> m ()) -> m ()) -> (Handle -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          Handle -> Text -> IO ()
T.hPutStr Handle
h Text
"\n"
          Handle -> Text -> IO ()
T.hPutStrLn Handle
h [i|listen_addresses=''|]

        -- Run pg_ctl to start the DB
        CreateProcess -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging ((String -> [String] -> CreateProcess
proc (String
postgresBinDir String -> ShowS
</> String
"pg_ctl") [
                                      String
"-D", String
dbDirName
                                      , String
"-l", String
logfileName
                                      , String
"-o", [i|--unix_socket_directories='#{unixSockDir}'|]
                                      , String
"start" , String
"--wait"
                                      ]) { cwd = Just dir })
          m ProcessHandle -> (ProcessHandle -> m ExitCode) -> m ExitCode
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProcessHandle -> m ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess m ExitCode -> (ExitCode -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ExitCode -> ExitCode -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Eq a, Show a) =>
a -> a -> m ()
`shouldBe` ExitCode
ExitSuccess)

        -- Create the default db
        CreateProcess -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging ((String -> [String] -> CreateProcess
proc (String
postgresBinDir String -> ShowS
</> String
"psql") [
                                      -- "-h", unixSockDir
                                      -- , "--username", toString postgresNixUsername
                                      [i|postgresql://#{username}:#{password}@/?host=#{unixSockDir}|]
                                      , String
"-c", [i|CREATE DATABASE #{database};|]
                                      ]) { cwd = Just dir })
          m ProcessHandle -> (ProcessHandle -> m ExitCode) -> m ExitCode
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProcessHandle -> m ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess m ExitCode -> (ExitCode -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ExitCode -> ExitCode -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Eq a, Show a) =>
a -> a -> m ()
`shouldBe` ExitCode
ExitSuccess)


        [String]
files <- String -> m [String]
forall (m :: * -> *). MonadIO m => String -> m [String]
listDirectory String
unixSockDir
        (String -> m Bool) -> [String] -> m [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((FileStatus -> Bool
isSocket (FileStatus -> Bool) -> m FileStatus -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m FileStatus -> m Bool)
-> (String -> m FileStatus) -> String -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO FileStatus -> m FileStatus
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> m FileStatus)
-> (String -> IO FileStatus) -> String -> m FileStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO FileStatus
getFileStatus) [String
unixSockDir String -> ShowS
</> String
f | String
f <- [String]
files] m [String] -> ([String] -> m String) -> m String
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          [String
f] -> String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
f
          [] -> String -> m String
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Couldn't find Unix socket for PostgreSQL server (check output and logfile for errors).|]
          [String]
xs -> String -> m String
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Found multiple Unix sockets for PostgreSQL server, not sure which one to use: #{xs}|]
    )
    (\String
_ -> do
        m String -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m String -> m ()) -> m String -> m ()
forall a b. (a -> b) -> a -> b
$ CreateProcess -> String -> m String
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> String -> m String
readCreateProcessWithLogging ((String -> [String] -> CreateProcess
proc (String
postgresBinDir String -> ShowS
</> String
"pg_ctl") [
                                                 String
"-D", String
dbDirName
                                                 , String
"-l", String
logfileName
                                                 , String
"stop" , String
"--wait"
                                                 ]) { cwd = Just dir }) String
""
    )
    String -> m a
action

-- * Container

data PostgresContainerOptions = PostgresContainerOptions {
  PostgresContainerOptions -> Text
postgresContainerUser :: Text
  , PostgresContainerOptions -> Text
postgresContainerPassword :: Text
  , PostgresContainerOptions -> Map Text Text
postgresContainerLabels :: Map Text Text
  , PostgresContainerOptions -> Maybe Text
postgresContainerContainerName :: Maybe Text
  , PostgresContainerOptions -> ContainerSystem
postgresContainerContainerSystem :: ContainerSystem
  , PostgresContainerOptions -> Text
postgresContainerImage :: Text
  } deriving (Int -> PostgresContainerOptions -> ShowS
[PostgresContainerOptions] -> ShowS
PostgresContainerOptions -> String
(Int -> PostgresContainerOptions -> ShowS)
-> (PostgresContainerOptions -> String)
-> ([PostgresContainerOptions] -> ShowS)
-> Show PostgresContainerOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PostgresContainerOptions -> ShowS
showsPrec :: Int -> PostgresContainerOptions -> ShowS
$cshow :: PostgresContainerOptions -> String
show :: PostgresContainerOptions -> String
$cshowList :: [PostgresContainerOptions] -> ShowS
showList :: [PostgresContainerOptions] -> ShowS
Show, PostgresContainerOptions -> PostgresContainerOptions -> Bool
(PostgresContainerOptions -> PostgresContainerOptions -> Bool)
-> (PostgresContainerOptions -> PostgresContainerOptions -> Bool)
-> Eq PostgresContainerOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PostgresContainerOptions -> PostgresContainerOptions -> Bool
== :: PostgresContainerOptions -> PostgresContainerOptions -> Bool
$c/= :: PostgresContainerOptions -> PostgresContainerOptions -> Bool
/= :: PostgresContainerOptions -> PostgresContainerOptions -> Bool
Eq)
defaultPostgresContainerOptions :: PostgresContainerOptions
defaultPostgresContainerOptions :: PostgresContainerOptions
defaultPostgresContainerOptions = PostgresContainerOptions {
  postgresContainerUser :: Text
postgresContainerUser = Text
"postgres"
  , postgresContainerPassword :: Text
postgresContainerPassword = Text
"password"
  , postgresContainerLabels :: Map Text Text
postgresContainerLabels = Map Text Text
forall a. Monoid a => a
mempty
  , postgresContainerContainerName :: Maybe Text
postgresContainerContainerName = Maybe Text
forall a. Maybe a
Nothing
  , postgresContainerContainerSystem :: ContainerSystem
postgresContainerContainerSystem = ContainerSystem
ContainerSystemPodman
  , postgresContainerImage :: Text
postgresContainerImage = Text
"docker.io/postgres:15"
  }

-- | Introduce a PostgresSQL instance via a container (either Docker or Podman).
introducePostgresViaContainer :: (
  HasBaseContext context
  , MonadUnliftIO m, MonadMask m
  )
  -- | Options
  => PostgresContainerOptions
  -> SpecFree (LabelValue "postgres" PostgresContext :> context) m ()
  -> SpecFree context m ()
introducePostgresViaContainer :: forall context (m :: * -> *).
(HasBaseContext context, MonadUnliftIO m, MonadMask m) =>
PostgresContainerOptions
-> SpecFree (LabelValue "postgres" PostgresContext :> context) m ()
-> SpecFree context m ()
introducePostgresViaContainer PostgresContainerOptions
opts = String
-> Label "postgres" PostgresContext
-> ((HasCallStack =>
     PostgresContext -> ExampleT context m [Result])
    -> ExampleT context m ())
-> Free
     (SpecCommand (LabelValue "postgres" PostgresContext :> context) m)
     ()
-> Free (SpecCommand context m) ()
forall (l :: Symbol) intro context (m :: * -> *).
HasCallStack =>
String
-> Label l intro
-> ((HasCallStack => intro -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduceWith String
"PostgreSQL via container" Label "postgres" PostgresContext
postgres (((HasCallStack => PostgresContext -> ExampleT context m [Result])
  -> ExampleT context m ())
 -> Free
      (SpecCommand (LabelValue "postgres" PostgresContext :> context) m)
      ()
 -> Free (SpecCommand context m) ())
-> ((HasCallStack =>
     PostgresContext -> ExampleT context m [Result])
    -> ExampleT context m ())
-> Free
     (SpecCommand (LabelValue "postgres" PostgresContext :> context) m)
     ()
-> Free (SpecCommand context m) ()
forall a b. (a -> b) -> a -> b
$ \HasCallStack => PostgresContext -> ExampleT context m [Result]
action -> do
  PostgresContainerOptions
-> (PostgresContext -> ExampleT context m ())
-> ExampleT context m ()
forall (m :: * -> *) context a.
(HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadMask m,
 HasBaseContextMonad context m) =>
PostgresContainerOptions -> (PostgresContext -> m a) -> m a
withPostgresContainer PostgresContainerOptions
opts (ExampleT context m [Result] -> ExampleT context m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExampleT context m [Result] -> ExampleT context m ())
-> (PostgresContext -> ExampleT context m [Result])
-> PostgresContext
-> ExampleT context m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PostgresContext -> ExampleT context m [Result]
PostgresContext -> ExampleT context m [Result]
action)

-- | Bracket-style variant of 'introducePostgresViaContainer'.
withPostgresContainer :: (
  HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadMask m, HasBaseContextMonad context m
  )
  -- | Options
  => PostgresContainerOptions
  -> (PostgresContext -> m a)
  -> m a
withPostgresContainer :: forall (m :: * -> *) context a.
(HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadMask m,
 HasBaseContextMonad context m) =>
PostgresContainerOptions -> (PostgresContext -> m a) -> m a
withPostgresContainer PostgresContainerOptions
options PostgresContext -> m a
action = do
  m (Text, ProcessHandle)
-> ((Text, ProcessHandle) -> m ())
-> ((Text, ProcessHandle) -> m a)
-> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (PostgresContainerOptions -> m (Text, ProcessHandle)
forall (m :: * -> *) context.
(HasCallStack, MonadUnliftIO m, MonadLogger m,
 HasBaseContextMonad context m) =>
PostgresContainerOptions -> m (Text, ProcessHandle)
createPostgresDatabase PostgresContainerOptions
options)
          (\(Text
containerName, ProcessHandle
_p) -> Text -> m () -> m ()
forall (m :: * -> *) context a.
(MonadUnliftIO m, HasBaseContextMonad context m,
 HasTestTimer context) =>
Text -> m a -> m a
timeAction Text
"cleanup Postgres database" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
              Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
info [i|Doing #{postgresContainerContainerSystem options} rm -f --volumes #{containerName}|]
              (ExitCode
exitCode, String
sout, String
serr) <-  IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, String, String) -> m (ExitCode, String, String))
-> IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> String -> IO (ExitCode, String, String)
forall (m :: * -> *).
MonadIO m =>
CreateProcess -> String -> m (ExitCode, String, String)
readCreateProcessWithExitCode (String -> CreateProcess
shell [i|#{postgresContainerContainerSystem options} rm -f --volumes #{containerName}|]) String
""
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
exitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                String -> m ()
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Failed to destroy Postgres container. Stdout: '#{sout}'. Stderr: '#{serr}'|]
          )
          (PostgresContainerOptions
-> (Text, ProcessHandle) -> m PostgresContext
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m, MonadMask m) =>
PostgresContainerOptions
-> (Text, ProcessHandle) -> m PostgresContext
waitForPostgresDatabase PostgresContainerOptions
options ((Text, ProcessHandle) -> m PostgresContext)
-> (PostgresContext -> m a) -> (Text, ProcessHandle) -> m a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> PostgresContext -> m a
action)

createPostgresDatabase :: (
  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
  ) => PostgresContainerOptions -> m (Text, ProcessHandle)
createPostgresDatabase :: forall (m :: * -> *) context.
(HasCallStack, MonadUnliftIO m, MonadLogger m,
 HasBaseContextMonad context m) =>
PostgresContainerOptions -> m (Text, ProcessHandle)
createPostgresDatabase (PostgresContainerOptions {Maybe Text
Map Text Text
Text
ContainerSystem
postgresContainerUser :: PostgresContainerOptions -> Text
postgresContainerPassword :: PostgresContainerOptions -> Text
postgresContainerLabels :: PostgresContainerOptions -> Map Text Text
postgresContainerContainerName :: PostgresContainerOptions -> Maybe Text
postgresContainerContainerSystem :: PostgresContainerOptions -> ContainerSystem
postgresContainerImage :: PostgresContainerOptions -> Text
postgresContainerUser :: Text
postgresContainerPassword :: Text
postgresContainerLabels :: Map Text Text
postgresContainerContainerName :: Maybe Text
postgresContainerContainerSystem :: ContainerSystem
postgresContainerImage :: Text
..}) = Text -> m (Text, ProcessHandle) -> m (Text, ProcessHandle)
forall (m :: * -> *) context a.
(MonadUnliftIO m, HasBaseContextMonad context m,
 HasTestTimer context) =>
Text -> m a -> m a
timeAction Text
"create Postgres database" (m (Text, ProcessHandle) -> m (Text, ProcessHandle))
-> m (Text, ProcessHandle) -> m (Text, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ do
  Text
containerName <- m Text -> (Text -> m Text) -> Maybe Text -> m Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Text
"postgres-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> m Text -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Text
forall (m :: * -> *). MonadIO m => m Text
makeUUID) Text -> m Text
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
postgresContainerContainerName

  let containerSystem :: ContainerSystem
containerSystem = ContainerSystem
postgresContainerContainerSystem
  let labelArgs :: [Text]
labelArgs = [[Text]] -> [Text]
forall a. Monoid a => [a] -> a
mconcat [[Text
"-l", [i|#{k}=#{v}|]] | (Text
k, Text
v) <- Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text Text
postgresContainerLabels]
  let args :: [Text]
args = [Text
"run"
             , Text
"-d"
             , Text
"-e", [i|POSTGRES_USER=#{postgresContainerUser}|]
             , Text
"-e", [i|POSTGRES_PASSWORD=#{postgresContainerPassword}|]
             , Text
"-p", Text
"5432"
             , Text
"--health-cmd", [i|pg_isready -U #{postgresContainerUser}|]
             , Text
"--health-interval=100ms"
             , Text
"--name", Text
containerName
             ]
             [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
labelArgs
             [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
postgresContainerImage]

  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
info [i|cmd: #{containerSystem} #{T.unwords args}|]

  ProcessHandle
p <- CreateProcess -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging (String -> [String] -> CreateProcess
proc (ContainerSystem -> String
forall b a. (Show a, IsString b) => a -> b
show ContainerSystem
containerSystem) ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
forall a. ToString a => a -> String
toString [Text]
args))
  (Text, ProcessHandle) -> m (Text, ProcessHandle)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
containerName, ProcessHandle
p)

waitForPostgresDatabase :: (
  MonadUnliftIO m, MonadLoggerIO m, MonadMask m
  ) => PostgresContainerOptions -> (Text, ProcessHandle) -> m PostgresContext
waitForPostgresDatabase :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m, MonadMask m) =>
PostgresContainerOptions
-> (Text, ProcessHandle) -> m PostgresContext
waitForPostgresDatabase (PostgresContainerOptions {Maybe Text
Map Text Text
Text
ContainerSystem
postgresContainerUser :: PostgresContainerOptions -> Text
postgresContainerPassword :: PostgresContainerOptions -> Text
postgresContainerLabels :: PostgresContainerOptions -> Map Text Text
postgresContainerContainerName :: PostgresContainerOptions -> Maybe Text
postgresContainerContainerSystem :: PostgresContainerOptions -> ContainerSystem
postgresContainerImage :: PostgresContainerOptions -> Text
postgresContainerUser :: Text
postgresContainerPassword :: Text
postgresContainerLabels :: Map Text Text
postgresContainerContainerName :: Maybe Text
postgresContainerContainerSystem :: ContainerSystem
postgresContainerImage :: Text
..}) (Text
containerName, ProcessHandle
p) = do
  Text
containerID <- ProcessHandle -> m ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess ProcessHandle
p m ExitCode -> (ExitCode -> m Text) -> m Text
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ExitCode
ExitSuccess -> ContainerSystem -> Text -> m Text
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ContainerSystem -> Text -> m Text
containerNameToContainerId ContainerSystem
postgresContainerContainerSystem Text
containerName
    ExitCode
_ -> String -> m Text
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Failed to start Postgres container.|]

  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Postgres container ID: #{containerID}|]

  PortNumber
localPort <- ContainerSystem -> Text -> PortNumber -> m PortNumber
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ContainerSystem -> Text -> PortNumber -> m PortNumber
containerPortToHostPort ContainerSystem
postgresContainerContainerSystem Text
containerName PortNumber
5432

  ContainerSystem -> Text -> m ()
forall (m :: * -> *).
(HasCallStack, MonadLoggerIO m, MonadMask m) =>
ContainerSystem -> Text -> m ()
waitForHealth ContainerSystem
postgresContainerContainerSystem Text
containerID

  let pc :: PostgresContext
pc = PostgresContext {
        postgresUsername :: Text
postgresUsername = Text
postgresContainerUser
        , postgresPassword :: Text
postgresPassword = Text
postgresContainerPassword
        , postgresDatabase :: Text
postgresDatabase = Text
postgresContainerUser
        , postgresAddress :: NetworkAddress
postgresAddress = String -> PortNumber -> NetworkAddress
NetworkAddressTCP String
"localhost" PortNumber
localPort
        , postgresConnString :: Text
postgresConnString = [i|postgresql://#{postgresContainerUser}:#{postgresContainerPassword}@localhost:#{localPort}/#{postgresContainerUser}|]
        , postgresContainerAddress :: Maybe NetworkAddress
postgresContainerAddress = NetworkAddress -> Maybe NetworkAddress
forall a. a -> Maybe a
Just (NetworkAddress -> Maybe NetworkAddress)
-> NetworkAddress -> Maybe NetworkAddress
forall a b. (a -> b) -> a -> b
$ String -> PortNumber -> NetworkAddress
NetworkAddressTCP (Text -> String
forall a. ToString a => a -> String
toString Text
containerName) PortNumber
5432
        }

  -- TODO: might be a good idea to do this here, rather than wrap a retry around the initial migrate later on
  -- waitForSimpleQuery pc

  PostgresContext -> m PostgresContext
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PostgresContext
pc

#endif