tmp-postgres 1.7.1.0 → 1.8.0.0

raw patch · 8 files changed

+1177/−1144 lines, 8 files

Files

• CHANGELOG.md +6/−0
• src/Database/Postgres/Temp.hs +40/−40
• src/Database/Postgres/Temp/Internal.hs +77/−58
• src/Database/Postgres/Temp/Internal/Config.hs +917/−0
• src/Database/Postgres/Temp/Internal/Core.hs +77/−68
• src/Database/Postgres/Temp/Internal/Partial.hs +0/−921
• test/Spec.hs +57/−54
• tmp-postgres.cabal +3/−3

@@ -2,3 +2,9 @@  1.7.1.0   #35 Add Lenses for configuration++1.8.0.0+  Get rid of `Partial` prefix. Add a `Complete` prefix to the internal configuration types.+  Remove the `partial` prefix.+  Expand abbreviations.+  Order the Event type creation time.

@@ -76,53 +76,53 @@   , Config (..)   , prettyPrintConfig     -- *** 'Config' Lenses-  , configPlanL-  , configSocketL-  , configDataDirL+  , planL+  , socketClassL+  , dataDirectoryL   , configPortL-  -- ** 'PartialPlan'-  , PartialPlan (..)-  -- *** 'PartialPlan' lenses-  , partialPlanConfigL-  , partialPlanCreateDbL-  , partialPlanDataDirectoryL-  , partialPlanInitDbL+  -- ** 'Plan'+  , Plan (..)+  -- *** 'Plan' lenses+  , postgresConfigFileL+  , createDbConfigL+  , dataDirectoryStringL+  , initDbConfigL   , partialPlanLoggerL-  , partialPlanPostgresL-  -- ** 'PartialPostgresPlan'-  , PartialPostgresPlan (..)-  -- *** 'PartialPostgresPlan' lenses-  , partialPostgresPlanClientConfigL-  , partialPostgresPlanProcessConfigL-  -- ** 'PartialProcessConfig'-  , PartialProcessConfig (..)-  -- *** 'PartialProcessConfig' Lenses-  , partialProcessConfigCmdLineL-  , partialProcessConfigEnvVarsL-  , partialProcessConfigStdErrL-  , partialProcessConfigStdInL-  , partialProcessConfigStdOutL-  -- ** 'PartialEnvVars'-  , PartialEnvVars (..)-  -- *** 'PartialEnvVars' Lenses-  , partialEnvVarsInheritL-  , partialEnvVarsSpecificL-  -- ** 'PartialCommandLineArgs'-  , PartialCommandLineArgs (..)-  -- *** 'PartialCommandLineArgs' Lenses-  , partialCommandLineArgsIndexBasedL-  , partialCommandLineArgsKeyBasedL-  -- ** 'PartialDirectoryType'-  , PartialDirectoryType (..)-  -- ** 'PartialSocketClass'-  , PartialSocketClass (..)+  , postgresPlanL+  -- ** 'PostgresPlan'+  , PostgresPlan (..)+  -- *** 'PostgresPlan' lenses+  , connectionOptionsL+  , postgresConfigL+  -- ** 'ProcessConfig'+  , ProcessConfig (..)+  -- *** 'ProcessConfig' Lenses+  , commandLineL+  , environmentVariablesL+  , stdErrL+  , stdInL+  , stdOutL+  -- ** 'EnvVars'+  , EnvVars (..)+  -- *** 'EnvVars' Lenses+  , inheritL+  , specificL+  -- ** 'CommandLineArgs'+  , CommandLineArgs (..)+  -- *** 'CommandLineArgs' Lenses+  , indexBasedL+  , keyBasedL+  -- ** 'DirectoryType'+  , DirectoryType (..)+  -- ** 'SocketClass'+  , SocketClass (..)   -- ** 'Logger'   , Logger-  -- * Internal events passed to the 'partialPlanLogger' .+  -- * Internal events passed to the 'logger' .   , Event (..)     -- * Errors   , StartError (..)   ) where import Database.Postgres.Temp.Internal import Database.Postgres.Temp.Internal.Core-import Database.Postgres.Temp.Internal.Partial+import Database.Postgres.Temp.Internal.Config

@@ -6,7 +6,7 @@ module Database.Postgres.Temp.Internal where  import Database.Postgres.Temp.Internal.Core-import Database.Postgres.Temp.Internal.Partial+import Database.Postgres.Temp.Internal.Config  import           Control.Exception import           Control.Monad (void)@@ -20,12 +20,12 @@  -- | Handle for holding temporary resources, the @postgres@ process handle --   and postgres connection information. The 'DB' also includes the---   final 'Plan' that was used to start @initdb@, @createdb@ and+--   final 'CompletePlan' that was used to start @initdb@, @createdb@ and --   @postgres@. See 'toConnectionString' for converting a 'DB' to --   postgresql connection string. data DB = DB   { dbResources :: Resources-  -- ^ Temporary resources and the final 'Plan'.+  -- ^ Temporary resources and the final 'CompletePlan'.   , dbPostgresProcess :: PostgresProcess   -- ^ @postgres@ process handle and the connection options.   }@@ -118,17 +118,17 @@ your @postgres@ might start and run faster if you use 'defaultConfig'. -'defaultConfig' also sets the 'partialPlanInitDb' to+'defaultConfig' also sets the 'initDbConfig' to 'pure' 'standardProcessConfig' and-'partialPostgresPlanProcessConfig' to 'standardProcessConfig'.+'postgresConfig' to 'standardProcessConfig'.  To append additional lines to \"postgresql.conf\" file create a custom 'Config' like the following.   @   custom = defaultConfig <> mempty-    { configPlan = mempty-      { partialPlanConfig =+    { plan = mempty+      { postgresConfigFile =           [ "wal_level = replica"           , "archive_mode = on"           , "max_wal_senders = 2"@@ -142,7 +142,7 @@ Or using the provided lenses and your favorite lens library   @-  custom = defaultConfig & 'configPlanL' . 'partialPlanConfigL' <>~+  custom = defaultConfig & 'planL' . 'postgresConfigFile' <>~     [ "wal_level = replica"     , "archive_mode = on"     , "max_wal_senders = 2"@@ -159,17 +159,17 @@ -} defaultConfig :: Config defaultConfig = mempty-  { configPlan = mempty-    { partialPlanLogger = pure mempty-    , partialPlanConfig = defaultPostgresConfig-    , partialPlanCreateDb = Nothing-    , partialPlanInitDb = pure standardProcessConfig-      { partialProcessConfigCmdLine = mempty-          { partialCommandLineArgsKeyBased = Map.singleton "--no-sync" Nothing+  { plan = mempty+    { logger = pure mempty+    , postgresConfigFile = defaultPostgresConfig+    , createDbConfig = Nothing+    , initDbConfig = pure standardProcessConfig+      { commandLine = mempty+          { keyBased = Map.singleton "--no-sync" Nothing           }       }-    , partialPlanPostgres = mempty-        { partialPostgresPlanProcessConfig = standardProcessConfig+    , postgresPlan = mempty+        { postgresConfig = standardProcessConfig         }     }   }@@ -180,8 +180,8 @@  @ defaultPostgresConf extra = defaultConfig <> mempty-  { configPlan = mempty-    { partialPlanConfig = extra+  { plan = mempty+    { postgresConfigFile = extra     }   } @@@ -189,21 +189,53 @@ -} defaultPostgresConf :: [String] -> Config defaultPostgresConf extra = defaultConfig <> mempty-  { configPlan = mempty-    { partialPlanConfig = extra+  { plan = mempty+    { postgresConfigFile = extra     }   } --- | Create temporary resources and use them to make a 'Config'.---   The generated 'Config' is combined with the passed in @extraConfiguration@---   to create a 'Plan' that is used to create a database.---   The output 'DB' includes references to the temporary resources for---   cleanup and the final plan that was used to generate the database and---   processes+{-|++Create zero or more temporary resources and use them to make a 'Config'.++The passed in config is inspected and a generated config is created.+The final config is built by++ @+   generated '<>' extra+ @++Returns a 'DB' that requires cleanup. `startConfig` should be+used with a `bracket` and 'stop', e.g.++ @+   `withConfig` :: `Config` -> (`DB` -> IO a) -> IO (Either `StartError` a)+   'withConfig' plan f = `bracket` (`startConfig` plan) (either mempty `stop`) $+      either (pure . Left) (fmap Right . f)+ @++or just use 'withConfig'. If you are calling 'startConfig' you+probably want 'withConfig' anyway.++Based on the value of 'socketClass' a \"postgresql.conf\" is created with++ @+   listen_addresses = \'IP_ADDRESS\'+ @++ if it is 'CIpSocket'. If is 'CUnixSocket' then the lines++ @+   listen_addresses = ''+   unix_socket_directories = \'SOCKET_DIRECTORY\'+ @++are added.++-} startConfig :: Config-          -- ^ @extraConfiguration@ that is 'mappend'ed to the generated `Config`.-          -- The extra config is 'mappend'ed second, e.g.-          -- @generatedConfig <> extraConfiguration@+          -- ^ @extra@ configuration that is 'mappend'ed last to the generated `Config`.+          -- @generated <> extra@           -> IO (Either StartError DB) startConfig extra = try $ evalContT $ do   dbResources@Resources {..} <-@@ -217,7 +249,7 @@ start :: IO (Either StartError DB) start = startConfig defaultConfig --- | Stop the @postgres@ process and cleanup any temporary directories that+-- | Stop the @postgres@ process and cleanup any temporary resources that --   might have been created. stop :: DB -> IO () stop DB {..} = do@@ -230,13 +262,12 @@ stopPostgres :: DB -> IO ExitCode stopPostgres = stopPostgresProcess . dbPostgresProcess --- | Restart the @postgres@ using the 'Plan' from the 'DB'---  (e.g. @resourcesPlan . dbResources@)+-- | Restart the @postgres@ from 'DB' using the prior 'Plan' restart :: DB -> IO (Either StartError DB) restart db@DB{..} = try $ do   void $ stopPostgres db   let plan = resourcesPlan dbResources-  bracketOnError (startPostgresProcess (planLogger plan) $ planPostgres plan)+  bracketOnError (startPostgresProcess (completePlanLogger plan) $ completePlanPostgres plan)     stopPostgresProcess $ \result ->       pure $ db { dbPostgresProcess = result } @@ -251,25 +282,8 @@ -- Exception safe interface ------------------------------------------------------------------------------- {-|-Exception safe default database create. Takes an @action@ continuation-which is given a 'DB' it can use to connect-to (see 'toConnectionString' or 'postgresProcessClientOptions').-All of the database resources are automatically cleaned up on-completion even in the face of exceptions.-Based on the value of 'configSocket' a \"postgresql.conf\" is created with-- @-   listen_addresses = \'IP_ADDRESS\'- @-- if it is 'IpSocket'. If is 'UnixSocket' then the lines-- @-   listen_addresses = ''-   unix_socket_directories = SOCKET_DIRECTORY- @--are added. This occurs as a side effect of calling 'withConfig'.+Exception safe database create with options. See 'startConfig' for more+details. Calls 'stop' even in the face of exceptions. -} withConfig :: Config          -- ^ @extraConfiguration@. Combined with the generated 'Config'. See@@ -280,8 +294,13 @@ withConfig plan f = bracket (startConfig plan) (either mempty stop) $   either (pure . Left) (fmap Right . f) --- | Default expectation safe interface. Equivalent to 'withConfig' the---   'defaultConfig'+{-| Default expectation safe interface. Equivalent to++ @+   'with' = withConfig' 'defaultConfig'+ @++-} with :: (DB -> IO a)      -- ^ @action@ continuation.      -> IO (Either StartError a)@@ -299,11 +318,11 @@ optionsToDefaultConfig opts@Client.Options {..} =   let generated = optionsToConfig opts       startingConfig =-        if partialPlanCreateDb (configPlan generated) == mempty+        if createDbConfig (plan generated) == mempty           then defaultConfig           else defaultConfig <> mempty-            { configPlan = mempty-              { partialPlanCreateDb = pure standardProcessConfig+            { plan = mempty+              { createDbConfig = pure standardProcessConfig               }             }   in startingConfig <> generated

@@ -0,0 +1,917 @@+{-# OPTIONS_HADDOCK prune #-}+{-| This module provides types and functions for combining partial+    configs into a complete configs to ultimately make a 'CompletePlan'.++    This module has two classes of types.++    Types like 'ProcessConfig' that could be used by any+    library that  needs to combine process options.++    Finally it has types and functions for creating 'CompletePlan's that+    use temporary resources. This is used to create the default+    behavior of 'Database.Postgres.Temp.startConfig' and related+    functions.+|-}+module Database.Postgres.Temp.Internal.Config where++import Database.Postgres.Temp.Internal.Core++import           Control.Applicative.Lift+import           Control.Exception+import           Control.Monad (join)+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Cont+import qualified Data.Map.Strict as Map+import           Data.Map.Strict (Map)+import           Data.Maybe+import           Data.Monoid+import           Data.Monoid.Generic+import           Data.Typeable+import qualified Database.PostgreSQL.Simple.Options as Client+import           GHC.Generics (Generic)+import           Network.Socket.Free (getFreePort)+import           System.Directory+import           System.Environment+import           System.IO+import           System.IO.Error+import           System.IO.Temp (createTempDirectory)+import           Text.PrettyPrint.ANSI.Leijen hiding ((<$>))++prettyMap :: (Pretty a, Pretty b) => Map a b -> Doc+prettyMap theMap =+  let xs = Map.toList theMap+  in vsep $ map (uncurry prettyKeyPair) xs++-- | The environment variables can be declared to+--   inherit from the running process or they+--   can be specifically added.+data EnvVars = EnvVars+  { inherit  :: Last Bool+  , specific :: Map String String+  }+  deriving stock (Generic, Show, Eq)++instance Semigroup EnvVars where+  x <> y = EnvVars+    { inherit  =+        inherit x <> inherit y+    , specific =+        specific y <> specific x+    }++instance Monoid EnvVars where+  mempty = EnvVars mempty mempty++instance Pretty EnvVars where+  pretty EnvVars {..}+    = text "inherit:"+        <+> pretty (getLast inherit)+    <> hardline+    <> text "specific:"+    <> softline+    <> indent 2 (prettyMap specific)++-- | Combine the current environment+--   (if indicated by 'inherit')+--   with 'specific'+completeEnvVars :: [(String, String)] -> EnvVars -> Either [String] [(String, String)]+completeEnvVars envs EnvVars {..} = case getLast inherit of+  Nothing -> Left ["Inherit not specified"]+  Just x -> Right $ (if x then envs else [])+    <> Map.toList specific++-- | A type to help combine command line arguments.+data CommandLineArgs = CommandLineArgs+  { keyBased   :: Map String (Maybe String)+  -- ^ Arguments of the form @-h foo@, @--host=foo@ and @--switch@.+  --   The key is `mappend`ed with value so the key should include+  --   the space or equals (as shown in the first two examples+  --   respectively).+  --   The 'Dual' monoid is used so the last key wins.+  , indexBased :: Map Int String+  -- ^ Arguments that appear at the end of the key based+  --   arguments.+  --   The 'Dual' monoid is used so the last key wins.+  }+  deriving stock (Generic, Show, Eq)+  deriving Monoid via GenericMonoid CommandLineArgs++instance Semigroup CommandLineArgs where+  x <> y = CommandLineArgs+    { keyBased   =+        keyBased y <> keyBased x+    , indexBased =+        indexBased y <> indexBased x+    }++instance Pretty CommandLineArgs where+  pretty p@CommandLineArgs {..}+    = text "keyBased:"+    <> softline+    <> indent 2 (prettyMap keyBased)+    <> hardline+    <> text "indexBased:"+    <> softline+    <> indent 2 (prettyMap indexBased)+    <> hardline+    <> text "completed:" <+> text (unwords (completeCommandLineArgs p))++-- Take values as long as the index is the successor of the+-- last index.+takeWhileInSequence :: [(Int, a)] -> [a]+takeWhileInSequence ((0, x):xs) = x : go 0 xs where+  go _ [] = []+  go prev ((next, a):rest)+    | prev + 1 == next = a : go next rest+    | otherwise = []+takeWhileInSequence _ = []++-- | This convert the 'CommandLineArgs' to '+completeCommandLineArgs :: CommandLineArgs -> [String]+completeCommandLineArgs CommandLineArgs {..}+  =  map (\(name, mvalue) -> maybe name (name <>) mvalue)+       (Map.toList keyBased)+  <> takeWhileInSequence (Map.toList indexBased)++-- | The monoidial version of 'ProcessConfig'. Used to combine overrides with+--   defaults when creating a 'ProcessConfig'.+data ProcessConfig = ProcessConfig+  { environmentVariables :: EnvVars+  -- ^ A monoid for combine environment variables or replacing them.+  --   for the maps the 'Dual' monoid is used. So the last key wins.+  , commandLine :: CommandLineArgs+  -- ^ A monoid for combine command line arguments or replacing them+  , stdIn :: Last Handle+  -- ^ A monoid for configuring the standard input 'Handle'+  , stdOut :: Last Handle+  -- ^ A monoid for configuring the standard output 'Handle'+  , stdErr :: Last Handle+  -- ^ A monoid for configuring the standard error 'Handle'+  }+  deriving stock (Generic, Eq, Show)+  deriving Semigroup via GenericSemigroup ProcessConfig+  deriving Monoid    via GenericMonoid ProcessConfig++prettyHandle :: Handle -> Doc+prettyHandle _ = text "[HANDLE]"++instance Pretty ProcessConfig where+  pretty ProcessConfig {..}+    = text "environmentVariables:"+    <> softline+    <> indent 2 (pretty environmentVariables)+    <> hardline+    <> text "commandLine:"+    <> softline+    <> indent 2 (pretty environmentVariables)+    <> hardline+    <> text "stdIn:" <+>+        pretty (prettyHandle <$> getLast stdIn)+    <> hardline+    <> text "stdOut:" <+>+        pretty (prettyHandle <$> getLast stdOut)+    <> hardline+    <> text "stdErr:" <+>+        pretty (prettyHandle <$> getLast stdErr)+++-- | The 'standardProcessConfig' sets the handles to 'stdin', 'stdout' and+--   'stderr' and inherits the environment variables from the calling+--   process.+standardProcessConfig :: ProcessConfig+standardProcessConfig = mempty+  { environmentVariables = mempty+      { inherit = pure True+      }+  , stdIn  = pure stdin+  , stdOut = pure stdout+  , stdErr = pure stderr+  }++-- A helper to add more info to all the error messages.+addErrorContext :: String -> Either [String] a -> Either [String] a+addErrorContext cxt = either (Left . map (cxt <>)) Right++-- A helper for creating an error if a 'Last' is not defined.+getOption :: String -> Last a -> Errors [String] a+getOption optionName = \case+    Last (Just x) -> pure x+    Last Nothing  -> failure ["Missing " ++ optionName ++ " option"]++-- | Turn a 'ProcessConfig' into a 'ProcessConfig'. Fails if+--   any values are missing.+completeProcessConfig+  :: [(String, String)] -> ProcessConfig -> Either [String] CompleteProcessConfig+completeProcessConfig envs ProcessConfig {..} = runErrors $ do+  let completeProcessConfigCmdLine = completeCommandLineArgs commandLine+  completeProcessConfigEnvVars <- eitherToErrors $+    completeEnvVars envs environmentVariables+  completeProcessConfigStdIn  <-+    getOption "stdIn" stdIn+  completeProcessConfigStdOut <-+    getOption "stdOut" stdOut+  completeProcessConfigStdErr <-+    getOption "stdErr" stdErr++  pure CompleteProcessConfig {..}++-- | A type to track whether a file is temporary and needs to be cleaned up.+data CompleteDirectoryType = CPermanent FilePath | CTemporary FilePath+  deriving(Show, Eq, Ord)++-- | Get the file path of a 'CompleteDirectoryType', regardless if it is a+-- 'CPermanent' or 'CTemporary' type.+toFilePath :: CompleteDirectoryType -> FilePath+toFilePath = \case+  CPermanent x -> x+  CTemporary x -> x++instance Pretty CompleteDirectoryType where+  pretty = \case+    CPermanent x -> text "CPermanent" <+> pretty x+    CTemporary x -> text "CTemporary" <+> pretty x++makePermanent :: CompleteDirectoryType -> CompleteDirectoryType+makePermanent = \case+  CTemporary x -> CPermanent x+  x -> x++-- | The monoidial version of 'CompleteDirectoryType'. Used to combine overrides with+--   defaults when creating a 'CompleteDirectoryType'. The monoid instance treats+--   'Temporary' as 'mempty' and takes the last 'Permanent' value.+data DirectoryType+  = Permanent FilePath+  -- ^ A permanent file that should not be generated.+  | Temporary+  -- ^ A temporary file that needs to generated.+  deriving(Show, Eq, Ord)++instance Pretty DirectoryType where+  pretty = \case+    Permanent x -> text "CPermanent" <+> pretty x+    Temporary   -> text "CTemporary"++instance Semigroup DirectoryType where+  x <> y = case (x, y) of+    (a, Temporary     ) -> a+    (_, a@Permanent {}) -> a++instance Monoid DirectoryType where+  mempty = Temporary++-- | Either create a'CTemporary' directory or do nothing to a 'CPermanent'+--   one.+setupDirectoryType :: String -> DirectoryType -> IO CompleteDirectoryType+setupDirectoryType p = \case+  Temporary -> CTemporary <$> createTempDirectory "/tmp" p+  Permanent x  -> pure $ CPermanent x++-- Either create a temporary directory or do nothing+rmDirIgnoreErrors :: FilePath -> IO ()+rmDirIgnoreErrors mainDir = do+  let ignoreDirIsMissing e+        | isDoesNotExistError e = return ()+        | otherwise = throwIO e+  removeDirectoryRecursive mainDir `catch` ignoreDirIsMissing++-- | Either remove a 'CTemporary' directory or do nothing to a 'CPermanent'+-- one.+cleanupDirectoryType :: CompleteDirectoryType -> IO ()+cleanupDirectoryType = \case+  CPermanent _ -> pure ()+  CTemporary filePath -> rmDirIgnoreErrors filePath++-- | A type for configuring the listening address of the @postgres@ process.+--   @postgres@ can listen on several types of sockets simulatanously but we+--   don't support that behavior. One can either listen on a IP based socket+--   or a UNIX domain socket.+data CompleteSocketClass+  = CIpSocket String+  -- ^ IP socket type. The 'String' is either an IP address or+  -- a host that will resolve to an IP address.+  | CUnixSocket CompleteDirectoryType+  -- ^ UNIX domain socket+  deriving (Show, Eq, Ord, Generic, Typeable)++instance Pretty CompleteSocketClass where+  pretty = \case+    CIpSocket x   -> text "CIpSocket:" <+> pretty x+    CUnixSocket x -> text "CUnixSocket:" <+> pretty x++-- | Create the extra config lines for listening based on the 'CompleteSocketClass'+socketClassToConfig :: CompleteSocketClass -> [String]+socketClassToConfig = \case+  CIpSocket ip    -> ["listen_addresses = '" <> ip <> "'"]+  CUnixSocket dir ->+    [ "listen_addresses = ''"+    , "unix_socket_directories = '" <> toFilePath dir <> "'"+    ]++-- | Many processes require a \"host\" flag. We can generate one from the+--   'CompleteSocketClass'.+socketClassToHostFlag :: CompleteSocketClass -> [(String, Maybe String)]+socketClassToHostFlag x = [("-h", Just (socketClassToHost x))]++-- | Get the IP address, host name or UNIX domain socket directory+--   as a 'String'+socketClassToHost :: CompleteSocketClass -> String+socketClassToHost = \case+  CIpSocket ip    -> ip+  CUnixSocket dir -> toFilePath dir++-- | The monoidial version of 'CompleteSocketClass'. Used to combine overrides with+--   defaults when creating a 'CompleteSocketClass'. The monoid instance treats+--   'UnixSocket mempty' as 'mempty' and combines the+data SocketClass+  = IpSocket (Last String)+  -- ^ The monoid for combining IP address configuration+  | UnixSocket DirectoryType+  -- ^ The monoid for combining UNIX socket configuration+    deriving stock (Show, Eq, Ord, Generic, Typeable)++instance Pretty SocketClass where+  pretty = \case+    IpSocket x -> "CIpSocket:" <+> pretty (getLast x)+    UnixSocket x -> "CUnixSocket" <+> pretty x++instance Semigroup SocketClass where+  x <> y = case (x, y) of+    (IpSocket   a, IpSocket b) -> IpSocket $ a <> b+    (a@(IpSocket _), UnixSocket _) -> a+    (UnixSocket _, a@(IpSocket _)) -> a+    (UnixSocket a, UnixSocket b) -> UnixSocket $ a <> b++instance Monoid SocketClass where+ mempty = UnixSocket mempty++-- | Turn a 'SocketClass' to a 'CompleteSocketClass'. If the 'IpSocket' is+--   'Nothing' default to \"127.0.0.1\". If the is a 'UnixSocket'+--    optionally create a temporary directory if configured to do so.+setupSocketClass :: SocketClass -> IO CompleteSocketClass+setupSocketClass theClass = case theClass of+  IpSocket mIp -> pure $ CIpSocket $ fromMaybe "127.0.0.1" $+    getLast mIp+  UnixSocket mFilePath ->+    CUnixSocket <$> setupDirectoryType "tmp-postgres-socket" mFilePath++-- | Cleanup the UNIX socket temporary directory if one was created.+cleanupSocketConfig :: CompleteSocketClass -> IO ()+cleanupSocketConfig = \case+  CIpSocket   {}  -> pure ()+  CUnixSocket dir -> cleanupDirectoryType dir++-- | @postgres@ process config and corresponding client connection+--   'Client.Options'.+data PostgresPlan = PostgresPlan+  { postgresConfig :: ProcessConfig+  -- ^ Monoid for the @postgres@ ProcessConfig.+  , connectionOptions :: Client.Options+  -- ^ Monoid for the @postgres@ client connection options.+  }+  deriving stock (Generic)+  deriving Semigroup via GenericSemigroup PostgresPlan+  deriving Monoid    via GenericMonoid PostgresPlan++instance Pretty PostgresPlan where+  pretty PostgresPlan {..}+    = text "postgresConfig:"+    <> softline+    <> indent 2 (pretty postgresConfig)+    <> hardline+    <> text "connectionOptions:"+    <> softline+    <> indent 2 (prettyOptions connectionOptions)++-- | Turn a 'PostgresPlan' into a 'CompletePostgresPlan'. Fails if any+--   values are missing.+completePostgresPlan :: [(String, String)] -> PostgresPlan -> Either [String] CompletePostgresPlan+completePostgresPlan envs PostgresPlan {..} = runErrors $ do+  let completePostgresPlanClientOptions = connectionOptions+  completePostgresPlanProcessConfig <-+    eitherToErrors $ addErrorContext "postgresConfig: " $+      completeProcessConfig envs postgresConfig++  pure CompletePostgresPlan {..}+-------------------------------------------------------------------------------+-- Plan+-------------------------------------------------------------------------------+-- | The monoidial version of 'CompletePlan'. Used to combine overrides with defaults+--   when creating a plan.+data Plan = Plan+  { logger :: Last Logger+  , initDbConfig :: Maybe ProcessConfig+  , createDbConfig :: Maybe ProcessConfig+  , postgresPlan :: PostgresPlan+  , postgresConfigFile :: [String]+  , dataDirectoryString :: Last String+  }+  deriving stock (Generic)+  deriving Semigroup via GenericSemigroup Plan+  deriving Monoid    via GenericMonoid Plan++instance Pretty Plan where+  pretty Plan {..}+    =  text "initDbConfig:"+    <> softline+    <> indent 2 (pretty initDbConfig)+    <> hardline+    <> text "initDbConfig:"+    <> softline+    <> indent 2 (pretty createDbConfig)+    <> hardline+    <> text "postgresPlan:"+    <> softline+    <> indent 2 (pretty postgresPlan)+    <> hardline+    <> text "postgresConfigFile:"+    <> softline+    <> indent 2 (vsep $ map text postgresConfigFile)+    <> hardline+    <> text "dataDirectoryString:" <+> pretty (getLast dataDirectoryString)++-- | Turn a 'Plan' into a 'CompletePlan'. Fails if any values are missing.+completePlan :: [(String, String)] -> Plan -> Either [String] CompletePlan+completePlan envs Plan {..} = runErrors $ do+  completePlanLogger   <- getOption "logger" logger+  completePlanInitDb   <- eitherToErrors $ addErrorContext "initDbConfig: " $+    traverse (completeProcessConfig envs) initDbConfig+  completePlanCreateDb <- eitherToErrors $ addErrorContext "createDbConfig: " $+    traverse (completeProcessConfig envs) createDbConfig+  completePlanPostgres <- eitherToErrors $ addErrorContext "postgresPlan: " $+    completePostgresPlan envs postgresPlan+  let completePlanConfig = unlines postgresConfigFile+  completePlanDataDirectory <- getOption "dataDirectoryString"+    dataDirectoryString++  pure CompletePlan {..}++-- Returns 'True' if the 'Plan' has a+-- 'Just' 'initDbConfig'+hasInitDb :: Plan -> Bool+hasInitDb Plan {..} = isJust initDbConfig++-- Returns 'True' if the 'Plan' has a+-- 'Just' 'createDbConfig'+hasCreateDb :: Plan -> Bool+hasCreateDb Plan {..} = isJust createDbConfig++-- | 'Resources' holds a description of the temporary folders (if there are any)+--   and includes the final 'CompletePlan' that can be used with 'startPlan'.+--   See 'setupConfig' for an example of how to create a 'Resources'.+data Resources = Resources+  { resourcesPlan    :: CompletePlan+  -- ^ Final 'CompletePlan'. See 'startPlan' for information on 'CompletePlan's+  , resourcesSocket  :: CompleteSocketClass+  -- ^ The 'CompleteSocketClass'. Used to track if a temporary directory was made+  --   as the socket location.+  , resourcesDataDir :: CompleteDirectoryType+  -- ^ The data directory. Used to track if a temporary directory was used.+  }++instance Pretty Resources where+  pretty Resources {..}+    =   text "resourcePlan:"+    <>  softline+    <>  indent 2 (pretty resourcesPlan)+    <>  hardline+    <>  text "resourcesSocket:"+    <+> pretty resourcesSocket+    <>  hardline+    <>  text "resourcesDataDir:"+    <+> pretty resourcesDataDir++-- | Make the 'resourcesDataDir' 'CPermanent' so it will not+--   get cleaned up.+makeResourcesDataDirPermanent :: Resources -> Resources+makeResourcesDataDirPermanent r = r+  { resourcesDataDir = makePermanent $ resourcesDataDir r+  }++-- | The high level options for overriding default behavior.+data Config = Config+  { plan    :: Plan+  -- ^ Extend or replace any of the configuration used to create a final+  --   'CompletePlan'+  , socketClass  :: SocketClass+  -- ^ Override the default 'CompleteSocketClass' by setting this.+  , dataDirectory :: DirectoryType+  -- ^ Override the default temporary data directory by passing in+  -- 'CPermanent DIRECTORY'+  , port    :: Last (Maybe Int)+  -- ^ A monoid for using an existing port (via 'Just' 'PORT_NUMBER') or+  -- requesting a free port (via a 'Nothing')+  }+  deriving stock (Generic)+  deriving Semigroup via GenericSemigroup Config+  deriving Monoid    via GenericMonoid Config++instance Pretty Config where+  pretty Config {..}+    =  text "plan:"+    <> softline+    <> pretty plan+    <> hardline+    <> text "socketClass:"+    <> softline+    <> pretty socketClass+    <> hardline+    <> text "dataDirectory:"+    <> softline+    <> pretty dataDirectory+    <> hardline+    <> text "port:" <+> pretty (getLast port)++-- | Create a 'Plan' that sets the command line options of all processes+--   (@initdb@, @postgres@ and @createdb@) using a+toPlan+  :: Bool+  -- ^ Make @initdb@ options+  -> Bool+  -- ^ Make @createdb@ options+  -> Int+  -- ^ port+  -> CompleteSocketClass+  -- ^ Whether to listen on a IP address or UNIX domain socket+  -> FilePath+  -- ^ The @postgres@ data directory+  -> Plan+toPlan makeInitDb makeCreateDb port socketClass dataDirectoryString = mempty+  { postgresConfigFile = socketClassToConfig socketClass+  , dataDirectoryString = pure dataDirectoryString+  , postgresPlan = mempty+      { postgresConfig = mempty+          { commandLine = mempty+              { keyBased = Map.fromList+                  [ ("-p", Just $ show port)+                  , ("-D", Just dataDirectoryString)+                  ]+              }+          }+      , connectionOptions = mempty+          { Client.host   = pure $ socketClassToHost socketClass+          , Client.port   = pure port+          , Client.dbname = pure "postgres"+          }+      }+  , createDbConfig = if makeCreateDb+      then pure $ mempty+        { commandLine = mempty+            { keyBased = Map.fromList $+                socketClassToHostFlag socketClass <>+                [("-p ", Just $ show port)]+            }+        }+      else Nothing+  , initDbConfig = if makeInitDb+      then pure $ mempty+        { commandLine = mempty+            { keyBased = Map.fromList+                [("--pgdata=", Just dataDirectoryString)]+            }++        }+      else Nothing+  }+++-- | Create all the temporary resources from a 'Config'. This also combines the+-- 'Plan' from 'toPlan' with the @extraConfig@ passed in.+setupConfig+  :: Config+  -- ^ @extraConfig@ to 'mappend' after the default config+  -> IO Resources+setupConfig Config {..} = evalContT $ do+  envs <- lift getEnvironment+  thePort <- lift $ maybe getFreePort pure $ join $ getLast port+  resourcesSocket <- ContT $ bracketOnError+    (setupSocketClass socketClass) cleanupSocketConfig+  resourcesDataDir <- ContT $ bracketOnError+    (setupDirectoryType "tmp-postgres-data" dataDirectory) cleanupDirectoryType+  let hostAndDir = toPlan+        (hasInitDb plan)+        (hasCreateDb plan)+        thePort+        resourcesSocket+        (toFilePath resourcesDataDir)+      finalPlan = hostAndDir <> plan+  resourcesPlan <- lift $+    either (throwIO . CompletePlanFailed (show $ pretty finalPlan)) pure $+      completePlan envs finalPlan+  pure Resources {..}++-- | Free the temporary resources created by 'setupConfig'+cleanupConfig :: Resources -> IO ()+cleanupConfig Resources {..} = do+  cleanupSocketConfig resourcesSocket+  cleanupDirectoryType resourcesDataDir+-------------------------------------------------------------------------------+-- Config Generation+-------------------------------------------------------------------------------+-- | Attempt to create a config from a 'Client.Options'. This is useful if+--   want to create a database owned by a specific user you will also log in as+--   among other use cases. It is possible some 'Client.Options' are not+--   supported so don't hesitate to open an issue on github if you find one.+optionsToConfig :: Client.Options -> Config+optionsToConfig opts@Client.Options {..}+  =  ( mempty+       { plan = optionsToPlan opts+       , port = maybe (Last Nothing) (pure . pure) $ getLast port+       , socketClass = maybe mempty hostToSocketClass $ getLast host+       }+     )+-- Convert the 'Client.Options' to a 'Plan' that can+-- be connected to with the 'Client.Options'.+optionsToPlan :: Client.Options -> Plan+optionsToPlan opts@Client.Options {..}+  =  maybe mempty dbnameToPlan (getLast dbname)+  <> maybe mempty userToPlan (getLast user)+  <> clientOptionsToPlan opts++-- Wrap the 'Client.Options' in an appropiate+-- 'PostgresPlan'+clientOptionsToPlan :: Client.Options -> Plan+clientOptionsToPlan opts = mempty+  { postgresPlan = mempty+    { connectionOptions = opts+    }+  }++-- Create a 'Plan' given a user+userToPlan :: String -> Plan+userToPlan user = mempty+  { createDbConfig = pure $ mempty+    { commandLine = mempty+        { keyBased = Map.singleton "--username=" $ Just user+        }+    }+  , initDbConfig = pure $ mempty+    { commandLine = mempty+        { keyBased = Map.singleton "--username=" $ Just user+        }+    }+  }++-- Adds a @createdb@ ProcessPlan with the argument+-- as the database name.+dbnameToPlan :: String -> Plan+dbnameToPlan dbName = mempty+  { createDbConfig = pure $ mempty+    { commandLine = mempty+      { indexBased = Map.singleton 0 dbName+      }+    }+  }++-- Parse a host string as either an UNIX domain socket directory+-- or a domain or IP.+hostToSocketClass :: String -> SocketClass+hostToSocketClass hostOrSocketPath = case hostOrSocketPath of+  '/' : _ -> UnixSocket $ Permanent hostOrSocketPath+  _ -> IpSocket $ pure hostOrSocketPath++-------------------------------------------------------------------------------+-- Lenses+-- Most this code was generated with microlens-th+-------------------------------------------------------------------------------+-- | Local Lens alias+type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t+-- | Local Lens' alias+type Lens' s a = Lens s s a a++-- | Lens for 'inherit'+inheritL :: Lens' EnvVars (Last Bool)+inheritL f_aj5e (EnvVars x_aj5f x_aj5g)+  = fmap (`EnvVars` x_aj5g)+      (f_aj5e x_aj5f)+{-# INLINE inheritL #-}++-- | Lens for 'specific'+specificL :: Lens' EnvVars (Map String String)+specificL f_aj5i (EnvVars x_aj5j x_aj5k)+  = fmap (EnvVars x_aj5j)+      (f_aj5i x_aj5k)+{-# INLINE specificL #-}++-- | Lens for 'commandLine'+commandLineL ::+  Lens' ProcessConfig CommandLineArgs+commandLineL+  f_allv+  (ProcessConfig x_allw x_allx x_ally x_allz x_allA)+  = fmap+       (\ y_allB+          -> ProcessConfig x_allw y_allB x_ally x_allz+               x_allA)+      (f_allv x_allx)+{-# INLINE commandLineL #-}++-- | Lens for 'environmentVariables'+environmentVariablesL ::+  Lens' ProcessConfig EnvVars+environmentVariablesL+  f_allC+  (ProcessConfig x_allD x_allE x_allF x_allG x_allH)+  = fmap+       (\ y_allI+          -> ProcessConfig y_allI x_allE x_allF x_allG+               x_allH)+      (f_allC x_allD)+{-# INLINE environmentVariablesL #-}++-- | Lens for 'stdErr'+stdErrL ::+  Lens' ProcessConfig (Last Handle)+stdErrL+  f_allJ+  (ProcessConfig x_allK x_allL x_allM x_allN x_allO)+  = fmap+       (ProcessConfig x_allK x_allL x_allM x_allN)+      (f_allJ x_allO)+{-# INLINE stdErrL #-}++-- | Lens for 'stdIn'+stdInL ::+  Lens' ProcessConfig (Last Handle)+stdInL+  f_allQ+  (ProcessConfig x_allR x_allS x_allT x_allU x_allV)+  = fmap+       (\ y_allW+          -> ProcessConfig x_allR x_allS y_allW x_allU+               x_allV)+      (f_allQ x_allT)+{-# INLINE stdInL #-}++-- | Lens for 'stdOut'+stdOutL ::+  Lens' ProcessConfig (Last Handle)+stdOutL+  f_allX+  (ProcessConfig x_allY x_allZ x_alm0 x_alm1 x_alm2)+  = fmap+       (\ y_alm3+          -> ProcessConfig x_allY x_allZ x_alm0 y_alm3+               x_alm2)+      (f_allX x_alm1)+{-# INLINE stdOutL #-}++-- | Lens for 'connectionOptions'+connectionOptionsL ::+  Lens' PostgresPlan Client.Options+connectionOptionsL+  f_am1y+  (PostgresPlan x_am1z x_am1A)+  = fmap (PostgresPlan x_am1z)+      (f_am1y x_am1A)+{-# INLINE connectionOptionsL #-}++-- | Lens for 'postgresConfig'+postgresConfigL ::+  Lens' PostgresPlan ProcessConfig+postgresConfigL+  f_am1C+  (PostgresPlan x_am1D x_am1E)+  = fmap (`PostgresPlan` x_am1E)+      (f_am1C x_am1D)+{-# INLINE postgresConfigL #-}++-- | Lens for 'postgresConfigFile'+postgresConfigFileL :: Lens' Plan [String]+postgresConfigFileL+  f_amcw+  (Plan x_amcx x_amcy x_amcz x_amcA x_amcB x_amcC)+  = fmap+       (\ y_amcD+          -> Plan x_amcx x_amcy x_amcz x_amcA y_amcD+               x_amcC)+      (f_amcw x_amcB)+{-# INLINE postgresConfigFileL #-}++-- | Lens for 'createDbConfig'+createDbConfigL ::+  Lens' Plan (Maybe ProcessConfig)+createDbConfigL+  f_amcE+  (Plan x_amcF x_amcG x_amcH x_amcI x_amcJ x_amcK)+  = fmap+       (\ y_amcL+          -> Plan x_amcF x_amcG y_amcL x_amcI x_amcJ+               x_amcK)+      (f_amcE x_amcH)+{-# INLINE createDbConfigL #-}++-- | Lens for 'dataDirectoryString'+dataDirectoryStringL :: Lens' Plan (Last String)+dataDirectoryStringL+  f_amcM+  (Plan x_amcN x_amcO x_amcP x_amcQ x_amcR x_amcS)+  = fmap+       (Plan x_amcN x_amcO x_amcP x_amcQ x_amcR)+      (f_amcM x_amcS)+{-# INLINE dataDirectoryStringL #-}++-- | Lens for 'initDbConfig'+initDbConfigL ::+  Lens' Plan (Maybe ProcessConfig)+initDbConfigL+  f_amcU+  (Plan x_amcV x_amcW x_amcX x_amcY x_amcZ x_amd0)+  = fmap+       (\ y_amd1+          -> Plan x_amcV y_amd1 x_amcX x_amcY x_amcZ+               x_amd0)+      (f_amcU x_amcW)+{-# INLINE initDbConfigL #-}++-- | Lens for 'logger'+partialPlanLoggerL :: Lens' Plan (Last Logger)+partialPlanLoggerL+  f_amd2+  (Plan x_amd3 x_amd4 x_amd5 x_amd6 x_amd7 x_amd8)+  = fmap+       (\ y_amd9+          -> Plan y_amd9 x_amd4 x_amd5 x_amd6 x_amd7+               x_amd8)+      (f_amd2 x_amd3)+{-# INLINE partialPlanLoggerL #-}++-- | Lens for 'postgresPlan'+postgresPlanL :: Lens' Plan PostgresPlan+postgresPlanL+  f_amda+  (Plan x_amdb x_amdc x_amdd x_amde x_amdf x_amdg)+  = fmap+       (\ y_amdh+          -> Plan x_amdb x_amdc x_amdd y_amdh x_amdf+               x_amdg)+      (f_amda x_amde)+{-# INLINE postgresPlanL #-}++-- | Lens for 'resourcesDataDir'+resourcesDataDirL :: Lens' Resources CompleteDirectoryType+resourcesDataDirL f_ampd (Resources x_ampe x_ampf x_ampg)+  = fmap (Resources x_ampe x_ampf)+      (f_ampd x_ampg)+{-# INLINE resourcesDataDirL #-}++-- | Lens for 'resourcesPlan'+resourcesPlanL :: Lens' Resources CompletePlan+resourcesPlanL f_ampi (Resources x_ampj x_ampk x_ampl)+  = fmap (\ y_ampm -> Resources y_ampm x_ampk x_ampl)+      (f_ampi x_ampj)+{-# INLINE resourcesPlanL #-}++-- | Lens for 'resourcesSocket'+resourcesSocketL :: Lens' Resources CompleteSocketClass+resourcesSocketL f_ampn (Resources x_ampo x_ampp x_ampq)+  = fmap (\ y_ampr -> Resources x_ampo y_ampr x_ampq)+      (f_ampn x_ampp)+{-# INLINE resourcesSocketL #-}++-- | Lens for 'dataDirectory'+dataDirectoryL :: Lens' Config DirectoryType+dataDirectoryL f_amyD (Config x_amyE x_amyF x_amyG x_amyH)+  = fmap (\ y_amyI -> Config x_amyE x_amyF y_amyI x_amyH)+      (f_amyD x_amyG)+{-# INLINE dataDirectoryL #-}++-- | Lens for 'plan'+planL :: Lens' Config Plan+planL f_amyJ (Config x_amyK x_amyL x_amyM x_amyN)+  = fmap (\ y_amyO -> Config y_amyO x_amyL x_amyM x_amyN)+      (f_amyJ x_amyK)+{-# INLINE planL #-}++-- | Lens for 'port'+configPortL :: Lens' Config (Last (Maybe Int))+configPortL f_amyP (Config x_amyQ x_amyR x_amyS x_amyT)+  = fmap (Config x_amyQ x_amyR x_amyS)+      (f_amyP x_amyT)+{-# INLINE configPortL #-}++-- | Lens for 'socketClass'+socketClassL :: Lens' Config SocketClass+socketClassL f_amyV (Config x_amyW x_amyX x_amyY x_amyZ)+  = fmap (\ y_amz0 -> Config x_amyW y_amz0 x_amyY x_amyZ)+      (f_amyV x_amyX)+{-# INLINE socketClassL #-}++-- | Lens for 'indexBased'+indexBasedL ::+  Lens' CommandLineArgs (Map Int String)+indexBasedL+  f_amNr+  (CommandLineArgs x_amNs x_amNt)+  = fmap (CommandLineArgs x_amNs)+      (f_amNr x_amNt)+{-# INLINE indexBasedL #-}++-- | Lens for 'keyBased'+keyBasedL ::+  Lens' CommandLineArgs (Map String (Maybe String))+keyBasedL+  f_amNv+  (CommandLineArgs x_amNw x_amNx)+  = fmap (`CommandLineArgs` x_amNx)+      (f_amNv x_amNw)+{-# INLINE keyBasedL #-}

@@ -26,10 +26,19 @@  -- | Internal events for debugging data Event-  = StartPostgres+  = StartPlan String+  -- ^ The first event. This useful for debugging+  --   what is actual passed to the @initdb@, @createdb@ and+  --   @postgres@.+  | StartPostgres+  -- ^ The second event. Postgres is about to get called   | WaitForDB-  | StartPlan String+  -- ^ The third event. Postgres started. We are not about to+  -- setup a reconnect loop (racing with a process checker)   | TryToConnect+  -- ^ The fourth event and (possibly all subsequent events).+  -- We are looping trying to successfully connect to the @postgres@+  -- process.   deriving (Show, Eq, Ord)  -- | A list of failures that can occur when starting. This is not@@ -46,7 +55,7 @@   -- ^ @createdb@ failed. This can be from invalid configuration or   --   the database might already exist.   | CompletePlanFailed String [String]-  -- ^ The 'Database.Postgres.Temp.Partial.PartialPlan' was missing info and a complete 'Plan' could+  -- ^ The 'Database.Postgres.Temp.Config.Plan' was missing info and a complete 'CompletePlan' could   --   not be created.   deriving (Show, Eq, Ord, Typeable) @@ -70,45 +79,45 @@  -- | 'ProcessConfig' contains the configuration necessary for starting a --   process. It is essentially a stripped down 'System.Process.CreateProcess'.-data ProcessConfig = ProcessConfig-  { processConfigEnvVars :: [(String, String)]+data CompleteProcessConfig = CompleteProcessConfig+  { completeProcessConfigEnvVars :: [(String, String)]   -- ^ Environment variables-  , processConfigCmdLine :: [String]+  , completeProcessConfigCmdLine :: [String]   -- ^ Command line arguements-  , processConfigStdIn   :: Handle+  , completeProcessConfigStdIn   :: Handle   -- ^ The 'Handle' for standard input-  , processConfigStdOut  :: Handle+  , completeProcessConfigStdOut  :: Handle   -- ^ The 'Handle' for standard output-  , processConfigStdErr  :: Handle+  , completeProcessConfigStdErr  :: Handle   -- ^ The 'Handle' for standard error   }  prettyKeyPair ::(Pretty a, Pretty b) => a -> b -> Doc prettyKeyPair k v = pretty k <> text ": " <> pretty v -instance Pretty ProcessConfig where-  pretty ProcessConfig {..}-    =  text "processConfigEnvVars:"+instance Pretty CompleteProcessConfig where+  pretty CompleteProcessConfig {..}+    =  text "completeProcessConfigEnvVars:"     <> softline-    <> indent 2 (vsep (map (uncurry prettyKeyPair) processConfigEnvVars))+    <> indent 2 (vsep (map (uncurry prettyKeyPair) completeProcessConfigEnvVars))     <> hardline-    <> text "processConfigCmdLine:"+    <> text "completeProcessConfigCmdLine:"     <> softline-    <> text (unwords processConfigCmdLine)+    <> text (unwords completeProcessConfigCmdLine)  -- | Start a process interactively and return the 'ProcessHandle' startProcess   :: String   -- ^ Process name-  -> ProcessConfig+  -> CompleteProcessConfig   -- ^ Process config   -> IO ProcessHandle-startProcess name ProcessConfig {..} = (\(_, _, _, x) -> x) <$>-  createProcess_ name (proc name processConfigCmdLine)-    { std_err = UseHandle processConfigStdErr-    , std_out = UseHandle processConfigStdOut-    , std_in  = UseHandle processConfigStdIn-    , env     = Just processConfigEnvVars+startProcess name CompleteProcessConfig {..} = (\(_, _, _, x) -> x) <$>+  createProcess_ name (proc name completeProcessConfigCmdLine)+    { std_err = UseHandle completeProcessConfigStdErr+    , std_out = UseHandle completeProcessConfigStdOut+    , std_in  = UseHandle completeProcessConfigStdIn+    , env     = Just completeProcessConfigEnvVars     }  -- | Stop a 'ProcessHandle'. An alias for 'waitForProcess'@@ -119,30 +128,30 @@ executeProcess   :: String   -- ^ Process name-  -> ProcessConfig+  -> CompleteProcessConfig   -- ^ Process config   -> IO ExitCode executeProcess name = startProcess name >=> waitForProcess ------------------------------------------------------------------------------- -- PostgresProcess Life cycle management ---------------------------------------------------------------------------------- | 'PostgresPlan' is used be 'startPostgresProcess' to start the @postgres@+-- | 'CompletePostgresPlan' is used be 'startPostgresProcess' to start the @postgres@ --   and then attempt to connect to it.-data PostgresPlan = PostgresPlan-  { postgresPlanProcessConfig :: ProcessConfig+data CompletePostgresPlan = CompletePostgresPlan+  { completePostgresPlanProcessConfig :: CompleteProcessConfig   -- ^ The process config for @postgres@-  , postgresPlanClientOptions  :: Client.Options+  , completePostgresPlanClientOptions  :: Client.Options   -- ^ Connection options. Used to verify that @postgres@ is ready.   } -instance Pretty PostgresPlan where-  pretty PostgresPlan {..}-    =  text "postgresPlanProcessConfig:"+instance Pretty CompletePostgresPlan where+  pretty CompletePostgresPlan {..}+    =  text "completePostgresPlanProcessConfig:"     <> softline-    <> indent 2 (pretty postgresPlanProcessConfig)+    <> indent 2 (pretty completePostgresPlanProcessConfig)     <> hardline-    <> text "postgresPlanClientOptions:"-    <+> prettyOptions postgresPlanClientOptions+    <> text "completePostgresPlanClientOptions:"+    <+> prettyOptions completePostgresPlanClientOptions  prettyOptions :: Client.Options -> Doc prettyOptions = text . BSC.unpack . Client.toConnectionString@@ -196,12 +205,12 @@ -- | Start the @postgres@ process and block until a successful connection --   occurs. A separate thread we continously check to see if the @postgres@ --   process has crashed.-startPostgresProcess :: Logger -> PostgresPlan -> IO PostgresProcess-startPostgresProcess logger PostgresPlan {..} = do+startPostgresProcess :: Logger -> CompletePostgresPlan -> IO PostgresProcess+startPostgresProcess logger CompletePostgresPlan {..} = do   logger StartPostgres -  let startAction = PostgresProcess postgresPlanClientOptions-        <$> startProcess "postgres" postgresPlanProcessConfig+  let startAction = PostgresProcess completePostgresPlanClientOptions+        <$> startProcess "postgres" completePostgresPlanProcessConfig    -- Start postgres and stop if an exception occurs   bracketOnError startAction stopPostgresProcess $@@ -214,7 +223,7 @@       logger WaitForDB       -- We assume that 'template1' exist and make connection       -- options to test if postgres is ready.-      let options = postgresPlanClientOptions+      let options = completePostgresPlanClientOptions             { Client.dbname = pure "template1"             } @@ -225,43 +234,43 @@       -- Postgres is now ready so return       return result ---------------------------------------------------------------------------------- Plan+-- CompletePlan ---------------------------------------------------------------------------------- | 'Plan' is the low level configuration necessary for creating a database+-- | 'CompletePlan' is the low level configuration necessary for creating a database --   starting @postgres@ and creating a database. There is no validation done---   on the 'Plan'. It is recommend that one use the higher level functions+--   on the 'CompletePlan'. It is recommend that one use the higher level functions --   such as 'Database.Postgres.Temp.start' which will generate plans that---   are valid. 'Plan's are used internally but are exposed if the higher+--   are valid. 'CompletePlan's are used internally but are exposed if the higher --   level plan generation is not sufficent.-data Plan = Plan-  { planLogger        :: Logger-  , planInitDb        :: Maybe ProcessConfig-  , planCreateDb      :: Maybe ProcessConfig-  , planPostgres      :: PostgresPlan-  , planConfig        :: String-  , planDataDirectory :: FilePath+data CompletePlan = CompletePlan+  { completePlanLogger        :: Logger+  , completePlanInitDb        :: Maybe CompleteProcessConfig+  , completePlanCreateDb      :: Maybe CompleteProcessConfig+  , completePlanPostgres      :: CompletePostgresPlan+  , completePlanConfig        :: String+  , completePlanDataDirectory :: FilePath   } -instance Pretty Plan where-  pretty Plan {..}-    =   text "planInitDb:"+instance Pretty CompletePlan where+  pretty CompletePlan {..}+    =   text "completePlanInitDb:"     <>  softline-    <>  indent 2 (pretty planInitDb)+    <>  indent 2 (pretty completePlanInitDb)     <>  hardline-    <>  text "planCreateDb:"+    <>  text "completePlanCreateDb:"     <>  softline-    <>  indent 2 (pretty planCreateDb)+    <>  indent 2 (pretty completePlanCreateDb)     <>  hardline-    <>  text "planPostgres:"+    <>  text "completePlanPostgres:"     <>  softline-    <>  indent 2 (pretty planPostgres)+    <>  indent 2 (pretty completePlanPostgres)     <>  hardline-    <>  text "planConfig:"+    <>  text "completePlanConfig:"     <>  softline-    <>  indent 2 (pretty planConfig)+    <>  indent 2 (pretty completePlanConfig)     <>  hardline-    <>  text "planDataDirectory:"-    <+> pretty planDataDirectory+    <>  text "completePlanDataDirectory:"+    <+> pretty completePlanDataDirectory  -- A simple helper to throw 'ExitCode's when they are 'ExitFailure'. throwIfNotSuccess :: Exception e => (ExitCode -> e) -> ExitCode -> IO ()@@ -274,19 +283,19 @@ --   Additionally it writes a \"postgresql.conf\" and does not return until --   the @postgres@ process is ready. See 'startPostgresProcess' for more --   details.-startPlan :: Plan -> IO PostgresProcess-startPlan plan@Plan {..} = do-  planLogger $ StartPlan $ show $ pretty plan-  for_ planInitDb  $ executeProcess "initdb" >=>+startPlan :: CompletePlan -> IO PostgresProcess+startPlan plan@CompletePlan {..} = do+  completePlanLogger $ StartPlan $ show $ pretty plan+  for_ completePlanInitDb  $ executeProcess "initdb" >=>     throwIfNotSuccess InitDbFailed    -- We must provide a config file before we can start postgres.-  writeFile (planDataDirectory <> "/postgresql.conf") planConfig+  writeFile (completePlanDataDirectory <> "/postgresql.conf") completePlanConfig -  let startAction = startPostgresProcess planLogger planPostgres+  let startAction = startPostgresProcess completePlanLogger completePlanPostgres    bracketOnError startAction stopPostgresProcess $ \result -> do-    for_ planCreateDb $  executeProcess "createdb" >=>+    for_ completePlanCreateDb $  executeProcess "createdb" >=>       throwIfNotSuccess CreateDbFailed      pure result

@@ -1,921 +0,0 @@-{-# OPTIONS_HADDOCK prune #-}-{-| This module provides types and functions for combining partial-    configs into a complete configs to ultimately make a 'Plan'.--    This module has two classes of types.--    Types like 'PartialProcessConfig' that could be used by any-    library that  needs to combine process options.--    Finally it has types and functions for creating 'Plan's that-    use temporary resources. This is used to create the default-    behavior of 'Database.Postgres.Temp.startConfig' and related-    functions.-|-}-module Database.Postgres.Temp.Internal.Partial where--import Database.Postgres.Temp.Internal.Core--import           Control.Applicative.Lift-import           Control.Exception-import           Control.Monad (join)-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Cont-import qualified Data.Map.Strict as Map-import           Data.Map.Strict (Map)-import           Data.Maybe-import           Data.Monoid-import           Data.Monoid.Generic-import           Data.Typeable-import qualified Database.PostgreSQL.Simple.Options as Client-import           GHC.Generics (Generic)-import           Network.Socket.Free (getFreePort)-import           System.Directory-import           System.Environment-import           System.IO-import           System.IO.Error-import           System.IO.Temp (createTempDirectory)-import           Text.PrettyPrint.ANSI.Leijen hiding ((<$>))--prettyMap :: (Pretty a, Pretty b) => Map a b -> Doc-prettyMap theMap =-  let xs = Map.toList theMap-  in vsep $ map (uncurry prettyKeyPair) xs---- | The environment variables can be declared to---   inherit from the running process or they---   can be specifically added.-data PartialEnvVars = PartialEnvVars-  { partialEnvVarsInherit  :: Last Bool-  , partialEnvVarsSpecific :: Map String String-  }-  deriving stock (Generic, Show, Eq)--instance Semigroup PartialEnvVars where-  x <> y = PartialEnvVars-    { partialEnvVarsInherit  =-        partialEnvVarsInherit x <> partialEnvVarsInherit y-    , partialEnvVarsSpecific =-        partialEnvVarsSpecific y <> partialEnvVarsSpecific x-    }--instance Monoid PartialEnvVars where-  mempty = PartialEnvVars mempty mempty--instance Pretty PartialEnvVars where-  pretty PartialEnvVars {..}-    = text "partialEnvVarsInherit:"-        <+> pretty (getLast partialEnvVarsInherit)-    <> hardline-    <> text "partialEnvVarsSpecific:"-    <> softline-    <> indent 2 (prettyMap partialEnvVarsSpecific)---- | Combine the current environment---   (if indicated by 'partialEnvVarsInherit')---   with 'partialEnvVarsSpecific'-completePartialEnvVars :: [(String, String)] -> PartialEnvVars -> Either [String] [(String, String)]-completePartialEnvVars envs PartialEnvVars {..} = case getLast partialEnvVarsInherit of-  Nothing -> Left ["Inherit not specified"]-  Just x -> Right $ (if x then envs else [])-    <> Map.toList partialEnvVarsSpecific---- | A type to help combine command line arguments.-data PartialCommandLineArgs = PartialCommandLineArgs-  { partialCommandLineArgsKeyBased   :: Map String (Maybe String)-  -- ^ Arguments of the form @-h foo@, @--host=foo@ and @--switch@.-  --   The key is `mappend`ed with value so the key should include-  --   the space or equals (as shown in the first two examples-  --   respectively).-  --   The 'Dual' monoid is used so the last key wins.-  , partialCommandLineArgsIndexBased :: Map Int String-  -- ^ Arguments that appear at the end of the key based-  --   arguments.-  --   The 'Dual' monoid is used so the last key wins.-  }-  deriving stock (Generic, Show, Eq)-  deriving Monoid via GenericMonoid PartialCommandLineArgs--instance Semigroup PartialCommandLineArgs where-  x <> y = PartialCommandLineArgs-    { partialCommandLineArgsKeyBased   =-        partialCommandLineArgsKeyBased y <> partialCommandLineArgsKeyBased x-    , partialCommandLineArgsIndexBased =-        partialCommandLineArgsIndexBased y <> partialCommandLineArgsIndexBased x-    }--instance Pretty PartialCommandLineArgs where-  pretty p@PartialCommandLineArgs {..}-    = text "partialCommandLineArgsKeyBased:"-    <> softline-    <> indent 2 (prettyMap partialCommandLineArgsKeyBased)-    <> hardline-    <> text "partialCommandLineArgsIndexBased:"-    <> softline-    <> indent 2 (prettyMap partialCommandLineArgsIndexBased)-    <> hardline-    <> text "completed:" <+> text (unwords (completeCommandLineArgs p))---- Take values as long as the index is the successor of the--- last index.-takeWhileInSequence :: [(Int, a)] -> [a]-takeWhileInSequence ((0, x):xs) = x : go 0 xs where-  go _ [] = []-  go prev ((next, a):rest)-    | prev + 1 == next = a : go next rest-    | otherwise = []-takeWhileInSequence _ = []---- | This convert the 'PartialCommandLineArgs' to '-completeCommandLineArgs :: PartialCommandLineArgs -> [String]-completeCommandLineArgs PartialCommandLineArgs {..}-  =  map (\(name, mvalue) -> maybe name (name <>) mvalue)-       (Map.toList partialCommandLineArgsKeyBased)-  <> takeWhileInSequence (Map.toList partialCommandLineArgsIndexBased)---- | The monoidial version of 'ProcessConfig'. Used to combine overrides with---   defaults when creating a 'ProcessConfig'.-data PartialProcessConfig = PartialProcessConfig-  { partialProcessConfigEnvVars :: PartialEnvVars-  -- ^ A monoid for combine environment variables or replacing them.-  --   for the maps the 'Dual' monoid is used. So the last key wins.-  , partialProcessConfigCmdLine :: PartialCommandLineArgs-  -- ^ A monoid for combine command line arguments or replacing them-  , partialProcessConfigStdIn   :: Last Handle-  -- ^ A monoid for configuring the standard input 'Handle'-  , partialProcessConfigStdOut  :: Last Handle-  -- ^ A monoid for configuring the standard output 'Handle'-  , partialProcessConfigStdErr  :: Last Handle-  -- ^ A monoid for configuring the standard error 'Handle'-  }-  deriving stock (Generic, Eq, Show)-  deriving Semigroup via GenericSemigroup PartialProcessConfig-  deriving Monoid    via GenericMonoid PartialProcessConfig--prettyHandle :: Handle -> Doc-prettyHandle _ = text "[HANDLE]"--instance Pretty PartialProcessConfig where-  pretty PartialProcessConfig {..}-    = text "partialProcessConfigEnvVars:"-    <> softline-    <> indent 2 (pretty partialProcessConfigEnvVars)-    <> hardline-    <> text "partialProcessConfigCmdLine:"-    <> softline-    <> indent 2 (pretty partialProcessConfigEnvVars)-    <> hardline-    <> text "partialProcessConfigStdIn:" <+>-        pretty (prettyHandle <$> getLast partialProcessConfigStdIn)-    <> hardline-    <> text "partialProcessConfigStdOut:" <+>-        pretty (prettyHandle <$> getLast partialProcessConfigStdOut)-    <> hardline-    <> text "partialProcessConfigStdErr:" <+>-        pretty (prettyHandle <$> getLast partialProcessConfigStdErr)----- | The 'standardProcessConfig' sets the handles to 'stdin', 'stdout' and---   'stderr' and inherits the environment variables from the calling---   process.-standardProcessConfig :: PartialProcessConfig-standardProcessConfig = mempty-  { partialProcessConfigEnvVars = mempty-      { partialEnvVarsInherit = pure True-      }-  , partialProcessConfigStdIn  = pure stdin-  , partialProcessConfigStdOut = pure stdout-  , partialProcessConfigStdErr = pure stderr-  }---- A helper to add more info to all the error messages.-addErrorContext :: String -> Either [String] a -> Either [String] a-addErrorContext cxt = either (Left . map (cxt <>)) Right---- A helper for creating an error if a 'Last' is not defined.-getOption :: String -> Last a -> Errors [String] a-getOption optionName = \case-    Last (Just x) -> pure x-    Last Nothing  -> failure ["Missing " ++ optionName ++ " option"]---- | Turn a 'PartialProcessConfig' into a 'ProcessConfig'. Fails if---   any values are missing.-completeProcessConfig-  :: [(String, String)] -> PartialProcessConfig -> Either [String] ProcessConfig-completeProcessConfig envs PartialProcessConfig {..} = runErrors $ do-  let processConfigCmdLine = completeCommandLineArgs partialProcessConfigCmdLine-  processConfigEnvVars <- eitherToErrors $-    completePartialEnvVars envs partialProcessConfigEnvVars-  processConfigStdIn  <--    getOption "partialProcessConfigStdIn" partialProcessConfigStdIn-  processConfigStdOut <--    getOption "partialProcessConfigStdOut" partialProcessConfigStdOut-  processConfigStdErr <--    getOption "partialProcessConfigStdErr" partialProcessConfigStdErr--  pure ProcessConfig {..}---- | A type to track whether a file is temporary and needs to be cleaned up.-data DirectoryType = Permanent FilePath | Temporary FilePath-  deriving(Show, Eq, Ord)---- | Get the file path of a 'DirectoryType', regardless if it is a--- 'Permanent' or 'Temporary' type.-toFilePath :: DirectoryType -> FilePath-toFilePath = \case-  Permanent x -> x-  Temporary x -> x--instance Pretty DirectoryType where-  pretty = \case-    Permanent x -> text "Permanent" <+> pretty x-    Temporary x -> text "Temporary" <+> pretty x--makePermanent :: DirectoryType -> DirectoryType-makePermanent = \case-  Temporary x -> Permanent x-  x -> x---- | The monoidial version of 'DirectoryType'. Used to combine overrides with---   defaults when creating a 'DirectoryType'. The monoid instance treats---   'PTemporary' as 'mempty' and takes the last 'PPermanent' value.-data PartialDirectoryType-  = PPermanent FilePath-  -- ^ A permanent file that should not be generated.-  | PTemporary-  -- ^ A temporary file that needs to generated.-  deriving(Show, Eq, Ord)--instance Pretty PartialDirectoryType where-  pretty = \case-    PPermanent x -> text "Permanent" <+> pretty x-    PTemporary   -> text "Temporary"--instance Semigroup PartialDirectoryType where-  x <> y = case (x, y) of-    (a, PTemporary     ) -> a-    (_, a@PPermanent {}) -> a--instance Monoid PartialDirectoryType where-  mempty = PTemporary---- | Either create a'Temporary' directory or do nothing to a 'Permanent'---   one.-setupDirectoryType :: String -> PartialDirectoryType -> IO DirectoryType-setupDirectoryType pattern = \case-  PTemporary -> Temporary <$> createTempDirectory "/tmp" pattern-  PPermanent x  -> pure $ Permanent x---- Either create a temporary directory or do nothing-rmDirIgnoreErrors :: FilePath -> IO ()-rmDirIgnoreErrors mainDir = do-  let ignoreDirIsMissing e-        | isDoesNotExistError e = return ()-        | otherwise = throwIO e-  removeDirectoryRecursive mainDir `catch` ignoreDirIsMissing---- | Either remove a 'Temporary' directory or do nothing to a 'Permanent'--- one.-cleanupDirectoryType :: DirectoryType -> IO ()-cleanupDirectoryType = \case-  Permanent _ -> pure ()-  Temporary filePath -> rmDirIgnoreErrors filePath---- | A type for configuring the listening address of the @postgres@ process.---   @postgres@ can listen on several types of sockets simulatanously but we---   don't support that behavior. One can either listen on a IP based socket---   or a UNIX domain socket.-data SocketClass-  = IpSocket String-  -- ^ IP socket type. The 'String' is either an IP address or-  -- a host that will resolve to an IP address.-  | UnixSocket DirectoryType-  -- ^ UNIX domain socket-  deriving (Show, Eq, Ord, Generic, Typeable)--instance Pretty SocketClass where-  pretty = \case-    IpSocket x   -> text "IpSocket:" <+> pretty x-    UnixSocket x -> text "UnixSocket:" <+> pretty x---- | Create the extra config lines for listening based on the 'SocketClass'-socketClassToConfig :: SocketClass -> [String]-socketClassToConfig = \case-  IpSocket ip    -> ["listen_addresses = '" <> ip <> "'"]-  UnixSocket dir ->-    [ "listen_addresses = ''"-    , "unix_socket_directories = '" <> toFilePath dir <> "'"-    ]---- | Many processes require a \"host\" flag. We can generate one from the---   'SocketClass'.-socketClassToHostFlag :: SocketClass -> [(String, Maybe String)]-socketClassToHostFlag x = [("-h", Just (socketClassToHost x))]---- | Get the IP address, host name or UNIX domain socket directory---   as a 'String'-socketClassToHost :: SocketClass -> String-socketClassToHost = \case-  IpSocket ip    -> ip-  UnixSocket dir -> toFilePath dir---- | The monoidial version of 'SocketClass'. Used to combine overrides with---   defaults when creating a 'SocketClass'. The monoid instance treats---   'PUnixSocket mempty' as 'mempty' and combines the-data PartialSocketClass-  = PIpSocket (Last String)-  -- ^ The monoid for combining IP address configuration-  | PUnixSocket PartialDirectoryType-  -- ^ The monoid for combining UNIX socket configuration-    deriving stock (Show, Eq, Ord, Generic, Typeable)--instance Pretty PartialSocketClass where-  pretty = \case-    PIpSocket x -> "IpSocket:" <+> pretty (getLast x)-    PUnixSocket x -> "UnixSocket" <+> pretty x--instance Semigroup PartialSocketClass where-  x <> y = case (x, y) of-    (PIpSocket   a, PIpSocket b) -> PIpSocket $ a <> b-    (a@(PIpSocket _), PUnixSocket _) -> a-    (PUnixSocket _, a@(PIpSocket _)) -> a-    (PUnixSocket a, PUnixSocket b) -> PUnixSocket $ a <> b--instance Monoid PartialSocketClass where- mempty = PUnixSocket mempty---- | Turn a 'PartialSocketClass' to a 'SocketClass'. If the 'PIpSocket' is---   'Nothing' default to \"127.0.0.1\". If the is a 'PUnixSocket'---    optionally create a temporary directory if configured to do so.-setupPartialSocketClass :: PartialSocketClass -> IO SocketClass-setupPartialSocketClass theClass = case theClass of-  PIpSocket mIp -> pure $ IpSocket $ fromMaybe "127.0.0.1" $-    getLast mIp-  PUnixSocket mFilePath ->-    UnixSocket <$> setupDirectoryType "tmp-postgres-socket" mFilePath---- | Cleanup the UNIX socket temporary directory if one was created.-cleanupSocketConfig :: SocketClass -> IO ()-cleanupSocketConfig = \case-  IpSocket   {}  -> pure ()-  UnixSocket dir -> cleanupDirectoryType dir---- | @postgres@ process config and corresponding client connection---   'Client.Options'.-data PartialPostgresPlan = PartialPostgresPlan-  { partialPostgresPlanProcessConfig :: PartialProcessConfig-  -- ^ Monoid for the @postgres@ ProcessConfig.-  , partialPostgresPlanClientConfig  :: Client.Options-  -- ^ Monoid for the @postgres@ client connection options.-  }-  deriving stock (Generic)-  deriving Semigroup via GenericSemigroup PartialPostgresPlan-  deriving Monoid    via GenericMonoid PartialPostgresPlan--instance Pretty PartialPostgresPlan where-  pretty PartialPostgresPlan {..}-    = text "partialPostgresPlanProcessConfig:"-    <> softline-    <> indent 2 (pretty partialPostgresPlanProcessConfig)-    <> hardline-    <> text "partialPostgresPlanClientConfig:"-    <> softline-    <> indent 2 (prettyOptions partialPostgresPlanClientConfig)---- | Turn a 'PartialPostgresPlan' into a 'PostgresPlan'. Fails if any---   values are missing.-completePostgresPlan :: [(String, String)] -> PartialPostgresPlan -> Either [String] PostgresPlan-completePostgresPlan envs PartialPostgresPlan {..} = runErrors $ do-  let postgresPlanClientOptions = partialPostgresPlanClientConfig-  postgresPlanProcessConfig <--    eitherToErrors $ addErrorContext "partialPostgresPlanProcessConfig: " $-      completeProcessConfig envs partialPostgresPlanProcessConfig--  pure PostgresPlan {..}----------------------------------------------------------------------------------- PartialPlan----------------------------------------------------------------------------------- | The monoidial version of 'Plan'. Used to combine overrides with defaults---   when creating a plan.-data PartialPlan = PartialPlan-  { partialPlanLogger        :: Last Logger-  , partialPlanInitDb        :: Maybe PartialProcessConfig-  , partialPlanCreateDb      :: Maybe PartialProcessConfig-  , partialPlanPostgres      :: PartialPostgresPlan-  , partialPlanConfig        :: [String]-  , partialPlanDataDirectory :: Last String-  }-  deriving stock (Generic)-  deriving Semigroup via GenericSemigroup PartialPlan-  deriving Monoid    via GenericMonoid PartialPlan--instance Pretty PartialPlan where-  pretty PartialPlan {..}-    =  text "partialPlanInitDb:"-    <> softline-    <> indent 2 (pretty partialPlanInitDb)-    <> hardline-    <> text "partialPlanInitDb:"-    <> softline-    <> indent 2 (pretty partialPlanCreateDb)-    <> hardline-    <> text "partialPlanPostgres:"-    <> softline-    <> indent 2 (pretty partialPlanPostgres)-    <> hardline-    <> text "partialPlanConfig:"-    <> softline-    <> indent 2 (vsep $ map text partialPlanConfig)-    <> hardline-    <> text "partialPlanDataDirectory:" <+> pretty (getLast partialPlanDataDirectory)---- | Turn a 'PartialPlan' into a 'Plan'. Fails if any values are missing.-completePlan :: [(String, String)] -> PartialPlan -> Either [String] Plan-completePlan envs PartialPlan {..} = runErrors $ do-  planLogger   <- getOption "partialPlanLogger" partialPlanLogger-  planInitDb   <- eitherToErrors $ addErrorContext "partialPlanInitDb: " $-    traverse (completeProcessConfig envs) partialPlanInitDb-  planCreateDb <- eitherToErrors $ addErrorContext "partialPlanCreateDb: " $-    traverse (completeProcessConfig envs) partialPlanCreateDb-  planPostgres <- eitherToErrors $ addErrorContext "partialPlanPostgres: " $-    completePostgresPlan envs partialPlanPostgres-  let planConfig = unlines partialPlanConfig-  planDataDirectory <- getOption "partialPlanDataDirectory"-    partialPlanDataDirectory--  pure Plan {..}---- Returns 'True' if the 'PartialPlan' has a--- 'Just' 'partialPlanInitDb'-hasInitDb :: PartialPlan -> Bool-hasInitDb PartialPlan {..} = isJust partialPlanInitDb---- Returns 'True' if the 'PartialPlan' has a--- 'Just' 'partialPlanCreateDb'-hasCreateDb :: PartialPlan -> Bool-hasCreateDb PartialPlan {..} = isJust partialPlanCreateDb---- | 'Resources' holds a description of the temporary folders (if there are any)---   and includes the final 'Plan' that can be used with 'startPlan'.---   See 'setupConfig' for an example of how to create a 'Resources'.-data Resources = Resources-  { resourcesPlan    :: Plan-  -- ^ Final 'Plan'. See 'startPlan' for information on 'Plan's-  , resourcesSocket  :: SocketClass-  -- ^ The 'SocketClass'. Used to track if a temporary directory was made-  --   as the socket location.-  , resourcesDataDir :: DirectoryType-  -- ^ The data directory. Used to track if a temporary directory was used.-  }--instance Pretty Resources where-  pretty Resources {..}-    =   text "resourcePlan:"-    <>  softline-    <>  indent 2 (pretty resourcesPlan)-    <>  hardline-    <>  text "resourcesSocket:"-    <+> pretty resourcesSocket-    <>  hardline-    <>  text "resourcesDataDir:"-    <+> pretty resourcesDataDir---- | Make the 'resourcesDataDir' 'Permanent' so it will not---   get cleaned up.-makeResourcesDataDirPermanent :: Resources -> Resources-makeResourcesDataDirPermanent r = r-  { resourcesDataDir = makePermanent $ resourcesDataDir r-  }---- | The high level options for overriding default behavior.-data Config = Config-  { configPlan    :: PartialPlan-  -- ^ Extend or replace any of the configuration used to create a final-  --   'Plan'-  , configSocket  :: PartialSocketClass-  -- ^ Override the default 'SocketClass' by setting this.-  , configDataDir :: PartialDirectoryType-  -- ^ Override the default temporary data directory by passing in-  -- 'Permanent DIRECTORY'-  , configPort    :: Last (Maybe Int)-  -- ^ A monoid for using an existing port (via 'Just PORT_NUMBER') or-  -- requesting a free port (via a 'Nothing')-  }-  deriving stock (Generic)-  deriving Semigroup via GenericSemigroup Config-  deriving Monoid    via GenericMonoid Config--instance Pretty Config where-  pretty Config {..}-    =  text "configPlan:"-    <> softline-    <> pretty configPlan-    <> hardline-    <> text "configSocket:"-    <> softline-    <> pretty configSocket-    <> hardline-    <> text "configDataDir:"-    <> softline-    <> pretty configDataDir-    <> hardline-    <> text "configPort:" <+> pretty (getLast configPort)---- | Create a 'PartialPlan' that sets the command line options of all processes---   (@initdb@, @postgres@ and @createdb@) using a-toPlan-  :: Bool-  -- ^ Make @initdb@ options-  -> Bool-  -- ^ Make @createdb@ options-  -> Int-  -- ^ port-  -> SocketClass-  -- ^ Whether to listen on a IP address or UNIX domain socket-  -> FilePath-  -- ^ The @postgres@ data directory-  -> PartialPlan-toPlan makeInitDb makeCreateDb port socketClass dataDirectory = mempty-  { partialPlanConfig = socketClassToConfig socketClass-  , partialPlanDataDirectory = pure dataDirectory-  , partialPlanPostgres = mempty-      { partialPostgresPlanProcessConfig = mempty-          { partialProcessConfigCmdLine = mempty-              { partialCommandLineArgsKeyBased = Map.fromList-                  [ ("-p", Just $ show port)-                  , ("-D", Just dataDirectory)-                  ]-              }-          }-      , partialPostgresPlanClientConfig = mempty-          { Client.host   = pure $ socketClassToHost socketClass-          , Client.port   = pure port-          , Client.dbname = pure "postgres"-          }-      }-  , partialPlanCreateDb = if makeCreateDb-      then pure $ mempty-        { partialProcessConfigCmdLine = mempty-            { partialCommandLineArgsKeyBased = Map.fromList $-                socketClassToHostFlag socketClass <>-                [("-p ", Just $ show port)]-            }-        }-      else Nothing-  , partialPlanInitDb = if makeInitDb-      then pure $ mempty-        { partialProcessConfigCmdLine = mempty-            { partialCommandLineArgsKeyBased = Map.fromList $-                [("--pgdata=", Just dataDirectory)]-            }--        }-      else Nothing-  }----- | Create all the temporary resources from a 'Config'. This also combines the--- 'PartialPlan' from 'toPlan' with the @extraConfig@ passed in.-setupConfig-  :: Config-  -- ^ @extraConfig@ to 'mappend' after the default config-  -> IO Resources-setupConfig Config {..} = evalContT $ do-  envs <- lift getEnvironment-  port <- lift $ maybe getFreePort pure $ join $ getLast configPort-  resourcesSocket <- ContT $ bracketOnError-    (setupPartialSocketClass configSocket) cleanupSocketConfig-  resourcesDataDir <- ContT $ bracketOnError-    (setupDirectoryType "tmp-postgres-data" configDataDir) cleanupDirectoryType-  let hostAndDirPartial = toPlan-          (hasInitDb configPlan)-          (hasCreateDb configPlan)-          port-          resourcesSocket-          (toFilePath resourcesDataDir)-      finalPlan = hostAndDirPartial <> configPlan-  resourcesPlan <- lift $-    either (throwIO . CompletePlanFailed (show $ pretty finalPlan)) pure $-      completePlan envs finalPlan-  pure Resources {..}---- | Free the temporary resources created by 'setupConfig'-cleanupConfig :: Resources -> IO ()-cleanupConfig Resources {..} = do-  cleanupSocketConfig resourcesSocket-  cleanupDirectoryType resourcesDataDir----------------------------------------------------------------------------------- Config Generation----------------------------------------------------------------------------------- | Attempt to create a config from a 'Client.Options'. This is useful if---   want to create a database owned by a specific user you will also log in as---   among other use cases. It is possible some 'Client.Options' are not---   supported so don't hesitate to open an issue on github if you find one.-optionsToConfig :: Client.Options -> Config-optionsToConfig opts@Client.Options {..}-  =  ( mempty-       { configPlan = optionsToPlan opts-       , configPort = maybe (Last Nothing) (pure . pure) $ getLast port-       , configSocket = maybe mempty hostToSocketClass $ getLast host-       }-     )--- Convert the 'Client.Options' to a 'PartialPlan' that can--- be connected to with the 'Client.Options'.-optionsToPlan :: Client.Options -> PartialPlan-optionsToPlan opts@Client.Options {..}-  =  maybe mempty dbnameToPlan (getLast dbname)-  <> maybe mempty userToPlan (getLast user)-  <> clientOptionsToPlan opts---- Wrap the 'Client.Options' in an appropiate--- 'PartialPostgresPlan'-clientOptionsToPlan :: Client.Options -> PartialPlan-clientOptionsToPlan opts = mempty-  { partialPlanPostgres = mempty-    { partialPostgresPlanClientConfig = opts-    }-  }---- Create a 'PartialPlan' given a user-userToPlan :: String -> PartialPlan-userToPlan user = mempty-  { partialPlanCreateDb = pure $ mempty-    { partialProcessConfigCmdLine = mempty-        { partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just user-        }-    }-  , partialPlanInitDb = pure $ mempty-    { partialProcessConfigCmdLine = mempty-        { partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just user-        }-    }-  }---- Adds a @createdb@ PartialProcessPlan with the argument--- as the database name.-dbnameToPlan :: String -> PartialPlan-dbnameToPlan dbName = mempty-  { partialPlanCreateDb = pure $ mempty-    { partialProcessConfigCmdLine = mempty-      { partialCommandLineArgsIndexBased = Map.singleton 0 dbName-      }-    }-  }---- Parse a host string as either an UNIX domain socket directory--- or a domain or IP.-hostToSocketClass :: String -> PartialSocketClass-hostToSocketClass hostOrSocketPath = case hostOrSocketPath of-  '/' : _ -> PUnixSocket $ PPermanent hostOrSocketPath-  _ -> PIpSocket $ pure hostOrSocketPath------------------------------------------------------------------------------------ Lenses--- Most this code was generated with microlens-th----------------------------------------------------------------------------------- | Local Lens alias-type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t--- | Local Lens' alias-type Lens' s a = Lens s s a a---- | Lens for 'partialEnvVarsInherit'-partialEnvVarsInheritL :: Lens' PartialEnvVars (Last Bool)-partialEnvVarsInheritL f_aj5e (PartialEnvVars x_aj5f x_aj5g)-  = (fmap (\ y_aj5h -> (PartialEnvVars y_aj5h) x_aj5g))-      (f_aj5e x_aj5f)-{-# INLINE partialEnvVarsInheritL #-}---- | Lens for 'partialEnvVarsSpecific'-partialEnvVarsSpecificL :: Lens' PartialEnvVars (Map String String)-partialEnvVarsSpecificL f_aj5i (PartialEnvVars x_aj5j x_aj5k)-  = (fmap (\ y_aj5l -> (PartialEnvVars x_aj5j) y_aj5l))-      (f_aj5i x_aj5k)-{-# INLINE partialEnvVarsSpecificL #-}---- | Lens for 'partialProcessConfigCmdLine'-partialProcessConfigCmdLineL ::-  Lens' PartialProcessConfig PartialCommandLineArgs-partialProcessConfigCmdLineL-  f_allv-  (PartialProcessConfig x_allw x_allx x_ally x_allz x_allA)-  = (fmap-       (\ y_allB-          -> ((((PartialProcessConfig x_allw) y_allB) x_ally) x_allz)-               x_allA))-      (f_allv x_allx)-{-# INLINE partialProcessConfigCmdLineL #-}---- | Lens for 'partialProcessConfigEnvVars'-partialProcessConfigEnvVarsL ::-  Lens' PartialProcessConfig PartialEnvVars-partialProcessConfigEnvVarsL-  f_allC-  (PartialProcessConfig x_allD x_allE x_allF x_allG x_allH)-  = (fmap-       (\ y_allI-          -> ((((PartialProcessConfig y_allI) x_allE) x_allF) x_allG)-               x_allH))-      (f_allC x_allD)-{-# INLINE partialProcessConfigEnvVarsL #-}---- | Lens for 'partialProcessConfigStdErr'-partialProcessConfigStdErrL ::-  Lens' PartialProcessConfig (Last Handle)-partialProcessConfigStdErrL-  f_allJ-  (PartialProcessConfig x_allK x_allL x_allM x_allN x_allO)-  = (fmap-       (\ y_allP-          -> ((((PartialProcessConfig x_allK) x_allL) x_allM) x_allN)-               y_allP))-      (f_allJ x_allO)---- | Lens for 'partialProcessConfigStdIn'-{-# INLINE partialProcessConfigStdErrL #-}-partialProcessConfigStdInL ::-  Lens' PartialProcessConfig (Last Handle)-partialProcessConfigStdInL-  f_allQ-  (PartialProcessConfig x_allR x_allS x_allT x_allU x_allV)-  = (fmap-       (\ y_allW-          -> ((((PartialProcessConfig x_allR) x_allS) y_allW) x_allU)-               x_allV))-      (f_allQ x_allT)-{-# INLINE partialProcessConfigStdInL #-}---- | Lens for 'partialProcessConfigStdOut'-partialProcessConfigStdOutL ::-  Lens' PartialProcessConfig (Last Handle)-partialProcessConfigStdOutL-  f_allX-  (PartialProcessConfig x_allY x_allZ x_alm0 x_alm1 x_alm2)-  = (fmap-       (\ y_alm3-          -> ((((PartialProcessConfig x_allY) x_allZ) x_alm0) y_alm3)-               x_alm2))-      (f_allX x_alm1)-{-# INLINE partialProcessConfigStdOutL #-}---- | Lens for 'partialPostgresPlanClientConfig'-partialPostgresPlanClientConfigL ::-  Lens' PartialPostgresPlan Client.Options-partialPostgresPlanClientConfigL-  f_am1y-  (PartialPostgresPlan x_am1z x_am1A)-  = (fmap (\ y_am1B -> (PartialPostgresPlan x_am1z) y_am1B))-      (f_am1y x_am1A)-{-# INLINE partialPostgresPlanClientConfigL #-}---- | Lens for 'partialPostgresPlanProcessConfig'-partialPostgresPlanProcessConfigL ::-  Lens' PartialPostgresPlan PartialProcessConfig-partialPostgresPlanProcessConfigL-  f_am1C-  (PartialPostgresPlan x_am1D x_am1E)-  = (fmap (\ y_am1F -> (PartialPostgresPlan y_am1F) x_am1E))-      (f_am1C x_am1D)-{-# INLINE partialPostgresPlanProcessConfigL #-}---- | Lens for 'partialPlanConfig'-partialPlanConfigL :: Lens' PartialPlan [String]-partialPlanConfigL-  f_amcw-  (PartialPlan x_amcx x_amcy x_amcz x_amcA x_amcB x_amcC)-  = (fmap-       (\ y_amcD-          -> (((((PartialPlan x_amcx) x_amcy) x_amcz) x_amcA) y_amcD)-               x_amcC))-      (f_amcw x_amcB)-{-# INLINE partialPlanConfigL #-}---- | Lens for 'partialPlanCreateDb'-partialPlanCreateDbL ::-  Lens' PartialPlan (Maybe PartialProcessConfig)-partialPlanCreateDbL-  f_amcE-  (PartialPlan x_amcF x_amcG x_amcH x_amcI x_amcJ x_amcK)-  = (fmap-       (\ y_amcL-          -> (((((PartialPlan x_amcF) x_amcG) y_amcL) x_amcI) x_amcJ)-               x_amcK))-      (f_amcE x_amcH)-{-# INLINE partialPlanCreateDbL #-}---- | Lens for 'partialPlanDataDirectory'-partialPlanDataDirectoryL :: Lens' PartialPlan (Last String)-partialPlanDataDirectoryL-  f_amcM-  (PartialPlan x_amcN x_amcO x_amcP x_amcQ x_amcR x_amcS)-  = (fmap-       (\ y_amcT-          -> (((((PartialPlan x_amcN) x_amcO) x_amcP) x_amcQ) x_amcR)-               y_amcT))-      (f_amcM x_amcS)-{-# INLINE partialPlanDataDirectoryL #-}---- | Lens for 'partialPlanInitDb'-partialPlanInitDbL ::-  Lens' PartialPlan (Maybe PartialProcessConfig)-partialPlanInitDbL-  f_amcU-  (PartialPlan x_amcV x_amcW x_amcX x_amcY x_amcZ x_amd0)-  = (fmap-       (\ y_amd1-          -> (((((PartialPlan x_amcV) y_amd1) x_amcX) x_amcY) x_amcZ)-               x_amd0))-      (f_amcU x_amcW)-{-# INLINE partialPlanInitDbL #-}---- | Lens for 'partialPlanLogger'-partialPlanLoggerL :: Lens' PartialPlan (Last Logger)-partialPlanLoggerL-  f_amd2-  (PartialPlan x_amd3 x_amd4 x_amd5 x_amd6 x_amd7 x_amd8)-  = (fmap-       (\ y_amd9-          -> (((((PartialPlan y_amd9) x_amd4) x_amd5) x_amd6) x_amd7)-               x_amd8))-      (f_amd2 x_amd3)-{-# INLINE partialPlanLoggerL #-}---- | Lens for 'partialPlanPostgres'-partialPlanPostgresL :: Lens' PartialPlan PartialPostgresPlan-partialPlanPostgresL-  f_amda-  (PartialPlan x_amdb x_amdc x_amdd x_amde x_amdf x_amdg)-  = (fmap-       (\ y_amdh-          -> (((((PartialPlan x_amdb) x_amdc) x_amdd) y_amdh) x_amdf)-               x_amdg))-      (f_amda x_amde)-{-# INLINE partialPlanPostgresL #-}---- | Lens for 'resourcesDataDir'-resourcesDataDirL :: Lens' Resources DirectoryType-resourcesDataDirL f_ampd (Resources x_ampe x_ampf x_ampg)-  = (fmap (\ y_amph -> ((Resources x_ampe) x_ampf) y_amph))-      (f_ampd x_ampg)-{-# INLINE resourcesDataDirL #-}---- | Lens for 'resourcesPlan'-resourcesPlanL :: Lens' Resources Plan-resourcesPlanL f_ampi (Resources x_ampj x_ampk x_ampl)-  = (fmap (\ y_ampm -> ((Resources y_ampm) x_ampk) x_ampl))-      (f_ampi x_ampj)-{-# INLINE resourcesPlanL #-}---- | Lens for 'resourcesSocket'-resourcesSocketL :: Lens' Resources SocketClass-resourcesSocketL f_ampn (Resources x_ampo x_ampp x_ampq)-  = (fmap (\ y_ampr -> ((Resources x_ampo) y_ampr) x_ampq))-      (f_ampn x_ampp)-{-# INLINE resourcesSocketL #-}---- | Lens for 'configDataDir'-configDataDirL :: Lens' Config PartialDirectoryType-configDataDirL f_amyD (Config x_amyE x_amyF x_amyG x_amyH)-  = (fmap (\ y_amyI -> (((Config x_amyE) x_amyF) y_amyI) x_amyH))-      (f_amyD x_amyG)-{-# INLINE configDataDirL #-}---- | Lens for 'configPlan'-configPlanL :: Lens' Config PartialPlan-configPlanL f_amyJ (Config x_amyK x_amyL x_amyM x_amyN)-  = (fmap (\ y_amyO -> (((Config y_amyO) x_amyL) x_amyM) x_amyN))-      (f_amyJ x_amyK)-{-# INLINE configPlanL #-}---- | Lens for 'configPort'-configPortL :: Lens' Config (Last (Maybe Int))-configPortL f_amyP (Config x_amyQ x_amyR x_amyS x_amyT)-  = (fmap (\ y_amyU -> (((Config x_amyQ) x_amyR) x_amyS) y_amyU))-      (f_amyP x_amyT)-{-# INLINE configPortL #-}---- | Lens for 'configSocket'-configSocketL :: Lens' Config PartialSocketClass-configSocketL f_amyV (Config x_amyW x_amyX x_amyY x_amyZ)-  = (fmap (\ y_amz0 -> (((Config x_amyW) y_amz0) x_amyY) x_amyZ))-      (f_amyV x_amyX)-{-# INLINE configSocketL #-}---- | Lens for 'partialCommandLineArgsIndexBased'-partialCommandLineArgsIndexBasedL ::-  Lens' PartialCommandLineArgs (Map Int String)-partialCommandLineArgsIndexBasedL-  f_amNr-  (PartialCommandLineArgs x_amNs x_amNt)-  = (fmap (\ y_amNu -> (PartialCommandLineArgs x_amNs) y_amNu))-      (f_amNr x_amNt)-{-# INLINE partialCommandLineArgsIndexBasedL #-}---- | Lens for 'partialCommandLineArgsKeyBased'-partialCommandLineArgsKeyBasedL ::-  Lens' PartialCommandLineArgs (Map String (Maybe String))-partialCommandLineArgsKeyBasedL-  f_amNv-  (PartialCommandLineArgs x_amNw x_amNx)-  = (fmap (\ y_amNy -> (PartialCommandLineArgs y_amNy) x_amNx))-      (f_amNv x_amNw)-{-# INLINE partialCommandLineArgsKeyBasedL #-}

@@ -1,6 +1,6 @@ import Test.Hspec import Database.Postgres.Temp.Internal.Core-import Database.Postgres.Temp.Internal.Partial+import Database.Postgres.Temp.Internal.Config import Database.Postgres.Temp.Internal import Control.Exception import System.IO.Error@@ -29,10 +29,10 @@  -- Cleanup -fromCreateDb :: Maybe PartialProcessConfig -> Config+fromCreateDb :: Maybe ProcessConfig -> Config fromCreateDb createDb = mempty-  { configPlan = mempty-      { partialPlanCreateDb = createDb+  { plan = mempty+      { createDbConfig = createDb       }   } @@ -45,20 +45,20 @@ defaultConfigShouldMatchDefaultPlan =   it "default options should match default plan" $ withRunner $ \DB{..} -> do     let Resources {..} = dbResources-        Plan {..} = resourcesPlan-        PostgresPlan {..} = planPostgres-    Client.dbname postgresPlanClientOptions `shouldBe` pure "postgres"-    let Temporary tmpDataDir = resourcesDataDir+        CompletePlan {..} = resourcesPlan+        CompletePostgresPlan {..} = completePlanPostgres+    Client.dbname completePostgresPlanClientOptions `shouldBe` pure "postgres"+    let CTemporary tmpDataDir = resourcesDataDir     tmpDataDir `shouldStartWith` "/tmp/tmp-postgres-data"-    let Just port = getLast $ Client.port postgresPlanClientOptions+    let Just port = getLast $ Client.port completePostgresPlanClientOptions     port `shouldSatisfy` (>32768)-    let UnixSocket (Temporary unixSocket) = resourcesSocket+    let CUnixSocket (CTemporary unixSocket) = resourcesSocket     unixSocket `shouldStartWith` "/tmp/tmp-postgres-socket"-    postgresPlanClientOptions `shouldBe`+    completePostgresPlanClientOptions `shouldBe`       (mempty-        { Client.port = Client.port postgresPlanClientOptions-        , Client.host = Client.host postgresPlanClientOptions-        , Client.dbname = Client.dbname postgresPlanClientOptions+        { Client.port = Client.port completePostgresPlanClientOptions+        , Client.host = Client.host completePostgresPlanClientOptions+        , Client.dbname = Client.dbname completePostgresPlanClientOptions         }       ) @@ -72,38 +72,38 @@    it "returns the right client options for the plan" $ do     let customPlan = mempty-          { configPlan = mempty-              { partialPlanPostgres = mempty-                  { partialPostgresPlanClientConfig = mempty+          { plan = mempty+              { postgresPlan = mempty+                  { connectionOptions = mempty                       { Client.user     = pure expectedUser                       , Client.password = pure expectedPassword                       , Client.dbname   = pure expectedDbName                       }                   }-              , partialPlanInitDb = pure standardProcessConfig-                  { partialProcessConfigCmdLine = mempty-                      { partialCommandLineArgsKeyBased =+              , initDbConfig = pure standardProcessConfig+                  { commandLine = mempty+                      { keyBased =                           Map.singleton "--username=" $ Just "user-name"                       }-                  , partialProcessConfigEnvVars = mempty-                      { partialEnvVarsSpecific = Map.singleton "PGPASSWORD" "password"-                      , partialEnvVarsInherit = pure True+                  , environmentVariables = mempty+                      { specific = Map.singleton "PGPASSWORD" "password"+                      , inherit = pure True                       }                   }-              , partialPlanCreateDb = pure standardProcessConfig-                { partialProcessConfigCmdLine = mempty-                  { partialCommandLineArgsKeyBased =+              , createDbConfig = pure standardProcessConfig+                { commandLine = mempty+                  { keyBased =                       Map.singleton "--username=" $ Just "user-name"-                  , partialCommandLineArgsIndexBased =+                  , indexBased =                       Map.singleton 0 expectedDbName                   }-                , partialProcessConfigEnvVars =+                , environmentVariables =                     mempty-                      { partialEnvVarsSpecific = Map.singleton "PGPASSWORD" "password"-                      , partialEnvVarsInherit = pure True+                      { specific = Map.singleton "PGPASSWORD" "password"+                      , inherit = pure True                       }                 }-              , partialPlanConfig = [extraConfig]+              , postgresConfigFile = [extraConfig]               }           }     -- hmm maybe I should provide lenses@@ -115,9 +115,9 @@         actualDuration `shouldBe` expectedDuration        let Resources {..} = dbResources-          Plan {..} = resourcesPlan-          actualOptions = postgresPlanClientOptions planPostgres-          actualPostgresConfig = planConfig+          CompletePlan {..} = resourcesPlan+          actualOptions = completePostgresPlanClientOptions completePlanPostgres+          actualPostgresConfig = completePlanConfig       Client.user actualOptions `shouldBe` pure expectedUser       Client.dbname actualOptions `shouldBe` pure expectedDbName       Client.password actualOptions `shouldBe` pure expectedPassword@@ -126,8 +126,8 @@ invalidConfigFailsQuickly :: (Config -> IO ()) -> Spec invalidConfigFailsQuickly action = it "quickly fails with an invalid option" $ do   let customPlan = mempty-        { configPlan = mempty-            { partialPlanConfig =+        { plan = mempty+            { postgresConfigFile =                 [ "log_directory = /this/does/not/exist"                 , "logging_collector = true"                 ]@@ -175,10 +175,13 @@      one `shouldBe` (1 :: Int) +{-+  Reenable after temp files are configurable #41   it "cleans up temp files" $ \(Runner runner) -> do     initialFiles <- listDirectory "/tmp"     runner $ const $ pure ()     listDirectory "/tmp" `shouldReturn` initialFiles+ -}  -- This assumes that the directory is initially empty withInitDbEmptyInitially :: SpecWith Runner@@ -201,13 +204,13 @@     runner (const $ pure ()) `shouldThrow` (== CreateDbFailed (ExitFailure 1))  spec :: Spec-spec = do+spec = parallel $ do   let defaultIpPlan = defaultConfig-        { configSocket = PIpSocket $ Last Nothing+        { socketClass = IpSocket $ Last Nothing         }        specificHostIpPlan = defaultConfig-        { configSocket = PIpSocket $ pure "localhost"+        { socketClass = IpSocket $ pure "localhost"         }    describe "start" $ do@@ -217,8 +220,8 @@     let startAction plan = bracket (either throwIO pure =<< startConfig plan) stop pure     throwsIfInitDbIsNotOnThePath $ startAction defaultConfig     invalidConfigFailsQuickly $ void . startAction-    customConfigWork $ \plan@Config{..} f ->-      bracket (either throwIO pure =<< startConfig plan) stop f+    customConfigWork $ \config@Config{..} f ->+      bracket (either throwIO pure =<< startConfig config) stop f   describe "with" $ do     let startAction = either throwIO pure =<< with (const $ pure ())     throwsIfInitDbIsNotOnThePath startAction@@ -254,7 +257,7 @@       someStandardTests "postgres"       defaultConfigShouldMatchDefaultPlan -  describe "start/stop" $ do+  describe "start/stop" $ parallel $ do     before (pure $ Runner $ \f -> bracket (either throwIO pure =<< start) stop f) $ do       someStandardTests "postgres"       defaultConfigShouldMatchDefaultPlan@@ -277,8 +280,8 @@      let invalidCreateDbPlan = defaultConfig <> fromCreateDb           ( pure $ standardProcessConfig-              { partialProcessConfigCmdLine = mempty-                { partialCommandLineArgsIndexBased =+              { commandLine = mempty+                { indexBased =                     Map.singleton 0 "template1"                 }               }@@ -287,10 +290,10 @@       createDbThrowsIfTheDbExists      let noCreateTemplate1 = mempty-          { configPlan = mempty-              { partialPlanCreateDb = Nothing-              , partialPlanPostgres = mempty-                  { partialPostgresPlanClientConfig = mempty+          { plan = mempty+              { createDbConfig = Nothing+              , postgresPlan = mempty+                  { connectionOptions = mempty                     { Client.dbname = pure "template1"                     }                   }@@ -320,7 +323,7 @@       it "fails on non-empty data directory" $ \dirPath -> do         writeFile (dirPath <> "/PG_VERSION") "1 million"         let nonEmptyFolderPlan = defaultConfig-              { configDataDir = PPermanent dirPath+              { dataDirectory = Permanent dirPath               }             startAction = bracket (either throwIO pure =<< startConfig nonEmptyFolderPlan) stop $ const $ pure () @@ -329,9 +332,9 @@       it "works if on non-empty if initdb is disabled" $ \dirPath -> do         throwIfNotSuccess id =<< system ("initdb " <> dirPath)         let nonEmptyFolderPlan = defaultConfig-              { configDataDir = PPermanent dirPath-              , configPlan = (configPlan defaultConfig)-                  { partialPlanInitDb = Nothing+              { dataDirectory = Permanent dirPath+              , plan = (plan defaultConfig)+                  { initDbConfig = Nothing                   }               }         bracket (either throwIO pure =<< startConfig nonEmptyFolderPlan) stop $ \db -> do@@ -342,8 +345,8 @@           one `shouldBe` (1 :: Int)      let justBackupResources = mempty-          { configPlan = mempty-              { partialPlanConfig =+          { plan = mempty+              { postgresConfigFile =                   [ "wal_level=replica"                   , "archive_mode=on"                   , "max_wal_senders=2"

@@ -1,7 +1,7 @@ name:                tmp-postgres-version:             1.7.1.0+version:             1.8.0.0 synopsis: Start and stop a temporary postgres-description: See README.md+description: Start and stop a temporary postgres. See README.md homepage:            https://github.com/jfischoff/tmp-postgres#readme license:             BSD3 license-file:        LICENSE@@ -19,7 +19,7 @@   exposed-modules: Database.Postgres.Temp                  , Database.Postgres.Temp.Internal                  , Database.Postgres.Temp.Internal.Core-                 , Database.Postgres.Temp.Internal.Partial+                 , Database.Postgres.Temp.Internal.Config   default-extensions:       ApplicativeDo     , DeriveFunctor