diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ execute_ conn "CREATE TABLE foo (id int)" ``` -To extend or override the defaults use `withPlan` (or `startWith`). +To extend or override the defaults use `withConfig` (or `startConfig`). `tmp-postgres` ultimately calls `initdb`, `postgres` and `createdb`. All of the command line, environment variables and configuration files diff --git a/src/Database/Postgres/Temp.hs b/src/Database/Postgres/Temp.hs --- a/src/Database/Postgres/Temp.hs +++ b/src/Database/Postgres/Temp.hs @@ -1,17 +1,18 @@ {-| This module provides functions for creating a temporary @postgres@ instance. -By default it will create a temporary data directory, -choose a random free port and a temporary directory for a UNIX -domain socket for @postgres@ to listen on. +By default it will create a temporary data directory and +a temporary directory for a UNIX domain socket for @postgres@ to listen on. Here is an example using the expection safe 'with' function: @ - 'with' $ \\db -> 'Control.Exception.bracket' ('PG.connectPostgreSQL' ('toConnectionString' db)) 'PG.close' $ \\conn -> - 'PG.execute_' conn "CREATE TABLE foo (id int)" + 'with' $ \\db -> 'Control.Exception.bracket' + ('PG.connectPostgreSQL' ('toConnectionString' db)) + 'PG.close' $ + \\conn -> 'PG.execute_' conn "CREATE TABLE foo (id int)" @ -To extend or override the defaults use `withPlan` (or `startWith`). +To extend or override the defaults use `withConfig` (or `startConfig`). @tmp-postgres@ ultimately calls (optionally) @initdb@, @postgres@ and (optionally) @createdb@. @@ -51,13 +52,14 @@ -- * Exception safe interface -- $options , with - , withPlan + , withConfig -- * Separate start and stop interface. , start - , startWith + , startConfig , stop , defaultConfig , defaultPostgresConf + , standardProcessConfig -- * Starting and Stopping postgres without removing the temporary directory , restart , stopPostgres @@ -70,8 +72,6 @@ , StartError (..) -- * Configuration Types , Config (..) - -- ** General extend or override monoid - , Lastoid (..) -- ** Directory configuration , DirectoryType (..) , PartialDirectoryType (..) @@ -112,12 +112,7 @@ unix_socket_directories = SOCKET_DIRECTORY @ - are added. This occurs as a side effect of calling 'withPlan'. - - The config can be either appended to replaced. If you replace it you will - have to specify the listen_addresses (or rely on the default) yourself. - Use 'Mappend' if you want to add to the config or the 'Replace' - constructor if you want to replace the config entirely. + are added. This occurs as a side effect of calling 'withConfig'. 'defaultConfig' appends the following config by default @@ -138,7 +133,7 @@ @ let custom = defaultConfig <> mempty { configPlan = mempty - { partialPlanConfig = Mappend + { partialPlanConfig = [ "wal_level=replica" , "archive_mode=on" , "max_wal_senders=2" diff --git a/src/Database/Postgres/Temp/Internal.hs b/src/Database/Postgres/Temp/Internal.hs --- a/src/Database/Postgres/Temp/Internal.hs +++ b/src/Database/Postgres/Temp/Internal.hs @@ -12,7 +12,6 @@ import System.Exit (ExitCode(..)) import Data.ByteString (ByteString) import Control.Monad.Trans.Cont -import Control.Monad.Trans.Class import qualified Database.PostgreSQL.Simple as PG import qualified Data.Map.Strict as Map @@ -79,35 +78,28 @@ Alternatively you can eschew 'defaultConfig' altogether, however your @postgres@ might start and run faster if you use 'defaultConfig'. + + 'defaultConfig' also sets the 'partialPlanInitDb' to + 'pure' 'standardProcessConfig' and + 'partialPostgresPlanProcessConfig' to 'standardProcessConfig'. -} defaultConfig :: Config defaultConfig = mempty { configPlan = mempty { partialPlanLogger = pure mempty - , partialPlanConfig = Mappend defaultPostgresConfig - , partialPlanInitDb = Mappend $ pure mempty - { partialProcessConfigCmdLine = Mappend $ mempty + , partialPlanConfig = defaultPostgresConfig + , partialPlanCreateDb = Accum Nothing + , partialPlanInitDb = pure standardProcessConfig + { partialProcessConfigCmdLine = mempty { partialCommandLineArgsKeyBased = Map.singleton "--no-sync" Nothing } } + , partialPlanPostgres = mempty + { partialPostgresPlanProcessConfig = standardProcessConfig + } } } --- | 'standardConfig' makes a default config with 'standardProcessConfig'. --- It is used by default but can be overriden by the extra config. -standardConfig :: IO Config -standardConfig = do - theStandardProcessConfig <- standardProcessConfig - pure mempty - { configPlan = mempty - { partialPlanCreateDb = Mappend $ pure theStandardProcessConfig - , partialPlanInitDb = Mappend $ pure theStandardProcessConfig - , partialPlanPostgres = mempty - { partialPostgresPlanProcessConfig = theStandardProcessConfig - } - } - } - {-| 'mappend' the 'defaultConfig' with a 'Config' that provides additional \"postgresql.conf\" lines. Equivalent to @@ -115,7 +107,7 @@ @ defaultPostgresConf extra = defaultConfig <> mempty { configPlan = mempty - { partialPlanConfig = Mappend extra + { partialPlanConfig = extra } } @ @@ -124,7 +116,7 @@ defaultPostgresConf :: [String] -> Config defaultPostgresConf extra = defaultConfig <> mempty { configPlan = mempty - { partialPlanConfig = Mappend extra + { partialPlanConfig = extra } } @@ -134,24 +126,22 @@ -- The output 'DB' includes references to the temporary resources for -- cleanup and the final plan that was used to generate the database and -- processes -startWith :: Config +startConfig :: Config -- ^ @extraConfiguration@ that is 'mappend'ed to the generated `Config`. -- The extra config is 'mappend'ed second, e.g. -- @generatedConfig <> extraConfiguration@ -> IO (Either StartError DB) -startWith extra = try $ evalContT $ do - theStandards <- lift standardConfig - let finalExtra = theStandards <> extra +startConfig extra = try $ evalContT $ do dbResources@Resources {..} <- - ContT $ bracketOnError (initConfig finalExtra) shutdownResources + ContT $ bracketOnError (initConfig extra) shutdownResources dbPostgresProcess <- ContT $ bracketOnError (initPlan resourcesPlan) stopPostgresProcess pure DB {..} --- | Default start behavior. Equivalent to calling 'startWith' with the +-- | Default start behavior. Equivalent to calling 'startConfig' with the -- 'defaultConfig' start :: IO (Either StartError DB) -start = startWith defaultConfig +start = startConfig defaultConfig -- | Stop the @postgres@ process and cleanup any temporary directories that -- might have been created. @@ -191,31 +181,51 @@ -- to (see 'toConnectionString' or 'postgresProcessClientConfig'). -- All of the database resources are automatically cleaned up on -- completion even in the face of exceptions. -withPlan :: Config +withConfig :: Config -- ^ @extraConfiguration@. Combined with the generated 'Config'. See - -- 'startWith' for more info + -- 'startConfig' for more info -> (DB -> IO a) -- ^ @action@ continuation -> IO (Either StartError a) -withPlan plan f = bracket (startWith plan) (either mempty stop) $ +withConfig plan f = bracket (startConfig plan) (either mempty stop) $ either (pure . Left) (fmap Right . f) --- | Default expectation safe interface. Equivalent to 'withPlan' the +-- | Default expectation safe interface. Equivalent to 'withConfig' the -- 'defaultConfig' with :: (DB -> IO a) -- ^ @action@ continuation. -> IO (Either StartError a) -with = withPlan defaultConfig +with = withConfig defaultConfig -- | Exception safe version of 'restart' withRestart :: DB -> (DB -> IO a) -> IO (Either StartError a) withRestart db f = bracket (restart db) (either mempty stop) $ either (pure . Left) (fmap Right . f) --- | 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. +-- | Attempt to create a 'Config' from a 'Client.Options'. Useful if you +-- want to create a database owned by a specific user you will also login +-- with among other use cases. optionsToDefaultConfig :: Client.Options -> Config optionsToDefaultConfig opts@Client.Options {..} = - defaultConfig <> optionsToConfig opts + let generated = optionsToConfig opts + startingConfig = + if partialPlanCreateDb (configPlan generated) == mempty + then defaultConfig + else setCreateDb defaultConfig $ pure standardProcessConfig + in startingConfig <> generated + +-- | Set a 'Config's 'partialPlanCreateDb' value. +setCreateDb :: Config -> Accum PartialProcessConfig -> Config +setCreateDb config@Config {..} new = config + { configPlan = configPlan + { partialPlanCreateDb = new + } + } + +-- | Set a 'Config's 'partialPlanInitDb' value. +setInitDb :: Config -> Accum PartialProcessConfig -> Config +setInitDb config@Config {..} new = config + { configPlan = configPlan + { partialPlanInitDb = new + } + } diff --git a/src/Database/Postgres/Temp/Internal/Core.hs b/src/Database/Postgres/Temp/Internal/Core.hs --- a/src/Database/Postgres/Temp/Internal/Core.hs +++ b/src/Database/Postgres/Temp/Internal/Core.hs @@ -103,7 +103,7 @@ ------------------------------------------------------------------------------- -- PostgresProcess Life cycle management ------------------------------------------------------------------------------- --- | PostgresPlan is used be 'startPostgresProcess' to start the @postgres@ +-- | 'PostgresPlan' is used be 'startPostgresProcess' to start the @postgres@ -- and then attempt to connect to it. data PostgresPlan = PostgresPlan { postgresPlanProcessConfig :: ProcessConfig @@ -120,8 +120,7 @@ -- ^ @postgres@ process handle } --- | Force all connections to the database to close. Can be useful in some --- testing situations. +-- | Force all connections to the database to close. -- Called during shutdown as well. terminateConnections :: PostgresClient.Options-> IO () terminateConnections options = do @@ -157,7 +156,7 @@ -- | Start the @postgres@ process and block until a successful connection -- occurs. A separate thread we continously check to see if the @postgres@ --- process has +-- process has crashed. startPostgresProcess :: Logger -> PostgresPlan -> IO PostgresProcess startPostgresProcess logger PostgresPlan {..} = do logger StartPostgres diff --git a/src/Database/Postgres/Temp/Internal/Partial.hs b/src/Database/Postgres/Temp/Internal/Partial.hs --- a/src/Database/Postgres/Temp/Internal/Partial.hs +++ b/src/Database/Postgres/Temp/Internal/Partial.hs @@ -1,7 +1,7 @@ {-| This module provides types and functions for combining partial configs into a complete configs to ultimately make a 'Plan'. - This module has three classes of types. Types like 'Lastoid' that + This module has three classes of types. Types like 'Accum' that are generic and could live in a module like "base". Types like 'PartialProcessConfig' that could be used by any @@ -9,7 +9,7 @@ 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.startWith' and related + behavior of 'Database.Postgres.Temp.startConfig' and related functions. |-} module Database.Postgres.Temp.Internal.Partial where @@ -34,40 +34,48 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -{- | -'Lastoid' is helper for overriding configuration values. -It's 'Semigroup' instance let's one either combine the -@a@ of two 'Lastoid's using '<>' via the 'Mappend' constructor -or one can wholly replace the value with the last value using the 'Replace' -constructor. -Roughly +-- | Another 'Maybe' 'Monoid' newtype. This one combines 'Just's +-- monoidially, with @Just mempty@ as @mempty@ and 'Nothing' +-- annihilates. +newtype Accum a = Accum { getAccum :: Maybe a } + deriving (Show, Eq, Ord, Functor, Applicative) - @ - x <> Replace y = Replace y - Replace x <> Mappend y = Replace (x <> y) - Mappend x <> Mappend y = Mappend (x <> y) - @ +instance Semigroup a => Semigroup (Accum a) where + Accum x <> Accum y = Accum $ case (x, y) of + (Just a, Just b) -> Just $ a <> b + _ -> Nothing --} -data Lastoid a = Replace a | Mappend a - deriving (Show, Eq, Functor) +instance Monoid a => Monoid (Accum a) where + mempty = Accum $ Just $ mempty -instance Semigroup a => Semigroup (Lastoid a) where - x <> y = case (x, y) of - (_ , r@Replace {}) -> r - (Replace a, Mappend b ) -> Replace $ a <> b - (Mappend a, Mappend b ) -> Mappend $ a <> b +-- | The environment variables can be declared to +-- inherit from the running process or they +-- can be specifically added. +data PartialEnvVars = PartialEnvVars + { partialEnvVarsInherit :: Bool + , partialEnvVarsSpecific :: Map String String + } + deriving stock (Generic, Show, Eq) -instance Monoid a => Monoid (Lastoid a) where - mempty = Mappend mempty +instance Semigroup PartialEnvVars where + x <> y = PartialEnvVars + { partialEnvVarsInherit = + partialEnvVarsInherit x || partialEnvVarsInherit y + , partialEnvVarsSpecific = + partialEnvVarsSpecific y <> partialEnvVarsSpecific x + } --- | Get the value of a 'Lastoid' regardless if it is a 'Replace' or --- a 'Mappend'. -getLastoid :: Lastoid a -> a -getLastoid = \case - Replace a -> a - Mappend a -> a +instance Monoid PartialEnvVars where + mempty = PartialEnvVars False mempty +-- | Combine the current environment +-- (if indicated by 'partialEnvVarsInherit') +-- with 'partialEnvVarsSpecific' +completePartialEnvVars :: [(String, String)] -> PartialEnvVars -> [(String, String)] +completePartialEnvVars envs PartialEnvVars {..} + = if partialEnvVarsInherit then envs else [] + <> Map.toList partialEnvVarsSpecific + -- | A type to help combine command line arguments. data PartialCommandLineArgs = PartialCommandLineArgs { partialCommandLineArgsKeyBased :: Map String (Maybe String) @@ -112,10 +120,10 @@ -- | The monoidial version of 'ProcessConfig'. Used to combine overrides with -- defaults when creating a 'ProcessConfig'. data PartialProcessConfig = PartialProcessConfig - { partialProcessConfigEnvVars :: Lastoid (Map String String) + { 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 :: Lastoid PartialCommandLineArgs + , partialProcessConfigCmdLine :: PartialCommandLineArgs -- ^ A monoid for combine command line arguments or replacing them , partialProcessConfigStdIn :: Last Handle -- ^ A monoid for configuring the standard input 'Handle' @@ -124,36 +132,22 @@ , partialProcessConfigStdErr :: Last Handle -- ^ A monoid for configuring the standard error 'Handle' } - deriving stock (Generic) + deriving stock (Generic, Eq, Show) + deriving Semigroup via GenericSemigroup PartialProcessConfig deriving Monoid via GenericMonoid PartialProcessConfig -instance Semigroup PartialProcessConfig where - x <> y = PartialProcessConfig - { partialProcessConfigEnvVars = fmap getDual $ - fmap Dual (partialProcessConfigEnvVars x) <> - fmap Dual (partialProcessConfigEnvVars y) - , partialProcessConfigCmdLine = - partialProcessConfigCmdLine x <> partialProcessConfigCmdLine y - , partialProcessConfigStdIn = - partialProcessConfigStdIn x <> partialProcessConfigStdIn y - , partialProcessConfigStdOut = - partialProcessConfigStdOut x <> partialProcessConfigStdOut y - , partialProcessConfigStdErr = - partialProcessConfigStdErr x <> partialProcessConfigStdErr y - } - -- | The 'standardProcessConfig' sets the handles to 'stdin', 'stdout' and -- 'stderr' and inherits the environment variables from the calling -- process. -standardProcessConfig :: IO PartialProcessConfig -standardProcessConfig = do - env <- getEnvironment - pure mempty - { partialProcessConfigEnvVars = Replace $ Map.fromList env - , partialProcessConfigStdIn = pure stdin - , partialProcessConfigStdOut = pure stdout - , partialProcessConfigStdErr = pure stderr - } +standardProcessConfig :: PartialProcessConfig +standardProcessConfig = mempty + { partialProcessConfigEnvVars = mempty + { partialEnvVarsInherit = 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 @@ -168,11 +162,10 @@ -- | Turn a 'PartialProcessConfig' into a 'ProcessConfig'. Fails if -- any values are missing. completeProcessConfig - :: PartialProcessConfig -> Either [String] ProcessConfig -completeProcessConfig PartialProcessConfig {..} = validationToEither $ do - let processConfigEnvVars = Map.toList $ getLastoid partialProcessConfigEnvVars - processConfigCmdLine = completeCommandLineArgs $ - getLastoid partialProcessConfigCmdLine + :: [(String, String)] -> PartialProcessConfig -> Either [String] ProcessConfig +completeProcessConfig envs PartialProcessConfig {..} = validationToEither $ do + let processConfigEnvVars = completePartialEnvVars envs partialProcessConfigEnvVars + processConfigCmdLine = completeCommandLineArgs partialProcessConfigCmdLine processConfigStdIn <- getOption "partialProcessConfigStdIn" partialProcessConfigStdIn processConfigStdOut <- @@ -315,12 +308,12 @@ -- | Turn a 'PartialPostgresPlan' into a 'PostgresPlan'. Fails if any -- values are missing. -completePostgresPlan :: PartialPostgresPlan -> Either [String] PostgresPlan -completePostgresPlan PartialPostgresPlan {..} = validationToEither $ do +completePostgresPlan :: [(String, String)] -> PartialPostgresPlan -> Either [String] PostgresPlan +completePostgresPlan envs PartialPostgresPlan {..} = validationToEither $ do let postgresPlanClientConfig = partialPostgresPlanClientConfig postgresPlanProcessConfig <- eitherToValidation $ addErrorContext "partialPostgresPlanProcessConfig: " $ - completeProcessConfig partialPostgresPlanProcessConfig + completeProcessConfig envs partialPostgresPlanProcessConfig pure PostgresPlan {..} ------------------------------------------------------------------------------- @@ -330,10 +323,10 @@ -- when creating a plan. data PartialPlan = PartialPlan { partialPlanLogger :: Last Logger - , partialPlanInitDb :: Lastoid (Maybe PartialProcessConfig) - , partialPlanCreateDb :: Lastoid (Maybe PartialProcessConfig) + , partialPlanInitDb :: Accum PartialProcessConfig + , partialPlanCreateDb :: Accum PartialProcessConfig , partialPlanPostgres :: PartialPostgresPlan - , partialPlanConfig :: Lastoid [String] + , partialPlanConfig :: [String] , partialPlanDataDirectory :: Last String } deriving stock (Generic) @@ -341,16 +334,16 @@ deriving Monoid via GenericMonoid PartialPlan -- | Turn a 'PartialPlan' into a 'Plan'. Fails if any values are missing. -completePlan :: PartialPlan -> Either [String] Plan -completePlan PartialPlan {..} = validationToEither $ do +completePlan :: [(String, String)] -> PartialPlan -> Either [String] Plan +completePlan envs PartialPlan {..} = validationToEither $ do planLogger <- getOption "partialPlanLogger" partialPlanLogger planInitDb <- eitherToValidation $ addErrorContext "partialPlanInitDb: " $ - traverse completeProcessConfig $ getLastoid partialPlanInitDb + traverse (completeProcessConfig envs) (getAccum partialPlanInitDb) planCreateDb <- eitherToValidation $ addErrorContext "partialPlanCreateDb: " $ - traverse completeProcessConfig $ getLastoid partialPlanCreateDb + traverse (completeProcessConfig envs) (getAccum partialPlanCreateDb) planPostgres <- eitherToValidation $ addErrorContext "partialPlanPostgres: " $ - completePostgresPlan partialPlanPostgres - let planConfig = unlines $ getLastoid partialPlanConfig + completePostgresPlan envs partialPlanPostgres + let planConfig = unlines partialPlanConfig planDataDirectory <- getOption "partialPlanDataDirectory" partialPlanDataDirectory @@ -398,11 +391,11 @@ -- ^ The @postgres@ data directory -> PartialPlan toPlan port socketClass dataDirectory = mempty - { partialPlanConfig = Mappend $ socketClassToConfig socketClass + { partialPlanConfig = socketClassToConfig socketClass , partialPlanDataDirectory = pure dataDirectory , partialPlanPostgres = mempty { partialPostgresPlanProcessConfig = mempty - { partialProcessConfigCmdLine = Mappend $ mempty + { partialProcessConfigCmdLine = mempty { partialCommandLineArgsKeyBased = Map.fromList [ ("-p", Just $ show port) , ("-D", Just dataDirectory) @@ -415,15 +408,15 @@ , Client.dbname = pure "postgres" } } - , partialPlanCreateDb = Mappend $ Just $ mempty - { partialProcessConfigCmdLine = Mappend $ mempty + , partialPlanCreateDb = pure $ mempty + { partialProcessConfigCmdLine = mempty { partialCommandLineArgsKeyBased = Map.fromList $ socketClassToHostFlag socketClass <> [("-p ", Just $ show port)] } } - , partialPlanInitDb = Mappend $ Just $ mempty - { partialProcessConfigCmdLine = Mappend $ mempty + , partialPlanInitDb = pure $ mempty + { partialProcessConfigCmdLine = mempty { partialCommandLineArgsKeyBased = Map.fromList $ [("--pgdata=", Just dataDirectory)] } @@ -439,6 +432,7 @@ -- ^ @extraConfig@ to 'mappend' after the default config -> IO Resources initConfig Config {..} = evalContT $ do + envs <- lift getEnvironment port <- lift $ maybe getFreePort pure $ join $ getLast configPort resourcesSocket <- ContT $ bracketOnError (initPartialSocketClass configSocket) shutdownSocketConfig @@ -447,7 +441,7 @@ let hostAndDirPartial = toPlan port resourcesSocket $ toFilePath resourcesDataDir resourcesPlan <- lift $ either (throwIO . CompletePlanFailed) pure $ - completePlan $ hostAndDirPartial <> configPlan + completePlan envs $ hostAndDirPartial <> configPlan pure Resources {..} -- | Free the temporary resources created by 'initConfig' @@ -490,13 +484,13 @@ -- | Create a 'PartialPlan' given a user userToPlan :: String -> PartialPlan userToPlan user = mempty - { partialPlanCreateDb = Mappend $ Just $ mempty - { partialProcessConfigCmdLine = Mappend $ mempty + { partialPlanCreateDb = pure $ mempty + { partialProcessConfigCmdLine = mempty { partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just user } } - , partialPlanInitDb = Mappend $ Just $ mempty - { partialProcessConfigCmdLine = Mappend $ mempty + , partialPlanInitDb = pure $ mempty + { partialProcessConfigCmdLine = mempty { partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just user } } @@ -506,8 +500,8 @@ -- as the database name. dbnameToPlan :: String -> PartialPlan dbnameToPlan dbName = mempty - { partialPlanCreateDb = Mappend $ Just $ mempty - { partialProcessConfigCmdLine = Mappend $ mempty + { partialPlanCreateDb = pure $ mempty + { partialProcessConfigCmdLine = mempty { partialCommandLineArgsIndexBased = Map.singleton 0 dbName } } diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -34,16 +34,6 @@ withRunner :: (DB -> IO ()) -> Runner -> IO () withRunner g (Runner f) = f g -updateCreateDb :: Config -> Lastoid (Maybe PartialProcessConfig) -> Config -updateCreateDb options partialProcessConfig = - let originalPlan = configPlan options - newPlan = originalPlan - { partialPlanCreateDb = partialProcessConfig - } - in options - { configPlan = newPlan - } - defaultConfigShouldMatchDefaultPlan :: SpecWith Runner defaultConfigShouldMatchDefaultPlan = it "default options should match default plan" $ withRunner $ \DB{..} -> do @@ -74,7 +64,7 @@ extraConfig = "log_min_duration_statement='" <> expectedDuration <> "'" it "returns the right client options for the plan" $ do - initialCreateDbConfig <- standardProcessConfig + let initialCreateDbConfig = standardProcessConfig let customPlan = mempty { configPlan = mempty { partialPlanPostgres = mempty @@ -84,28 +74,28 @@ , Client.dbname = pure expectedDbName } } - , partialPlanInitDb = Mappend $ pure $ mempty - { partialProcessConfigCmdLine = Mappend $ mempty + , partialPlanInitDb = pure mempty + { partialProcessConfigCmdLine = mempty { partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just "user-name" } - , partialProcessConfigEnvVars = Mappend $ - Map.singleton "PGPASSWORD" "password" + , partialProcessConfigEnvVars = + mempty { partialEnvVarsSpecific = Map.singleton "PGPASSWORD" "password" } } - , partialPlanConfig = Mappend [extraConfig] + , partialPlanConfig = [extraConfig] } } -- hmm maybe I should provide lenses let combinedResources = defaultConfig <> customPlan - finalCombinedResources = updateCreateDb combinedResources $ Mappend $ pure $ initialCreateDbConfig - { partialProcessConfigCmdLine = Mappend $ mempty + finalCombinedResources = setCreateDb combinedResources $ pure initialCreateDbConfig + { partialProcessConfigCmdLine = mempty { partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just "user-name" , partialCommandLineArgsIndexBased = Map.singleton 0 expectedDbName } - , partialProcessConfigEnvVars = Mappend $ - Map.singleton "PGPASSWORD" "password" + , partialProcessConfigEnvVars = + mempty { partialEnvVarsSpecific = Map.singleton "PGPASSWORD" "password" } } action finalCombinedResources $ \db@DB {..} -> do @@ -126,7 +116,7 @@ invalidConfigFailsQuickly action = it "quickly fails with an invalid option" $ do let customPlan = mempty { configPlan = mempty - { partialPlanConfig = Mappend + { partialPlanConfig = [ "log_directory = /this/does/not/exist" , "logging_collector = true" ] @@ -201,8 +191,6 @@ spec :: Spec spec = do - theStandardProcessConfig <- runIO standardProcessConfig - let defaultIpPlan = defaultConfig { configSocket = PIpSocket $ Last Nothing } @@ -214,27 +202,24 @@ describe "start" $ do let startAction = bracket (either throwIO pure =<< start) stop (const $ pure ()) throwsIfInitDbIsNotOnThePath startAction - throwsIfCreateDbIsNotOnThePath startAction - describe "startWith" $ do - let startAction plan = bracket (either throwIO pure =<< startWith plan) stop pure + describe "startConfig" $ do + let startAction plan = bracket (either throwIO pure =<< startConfig plan) stop pure throwsIfInitDbIsNotOnThePath $ startAction defaultConfig - throwsIfCreateDbIsNotOnThePath $ startAction defaultConfig invalidConfigFailsQuickly $ void . startAction customConfigWork $ \plan f -> - bracket (either throwIO pure =<< startWith plan) stop f + bracket (either throwIO pure =<< startConfig plan) stop f describe "with" $ do let startAction = either throwIO pure =<< with (const $ pure ()) throwsIfInitDbIsNotOnThePath startAction - throwsIfCreateDbIsNotOnThePath startAction - describe "withPlan" $ do + describe "withConfig" $ do let startAction plan = either throwIO pure =<< - withPlan plan pure + withConfig plan pure throwsIfInitDbIsNotOnThePath $ startAction defaultConfig - throwsIfCreateDbIsNotOnThePath $ startAction defaultConfig +-- throwsIfCreateDbIsNotOnThePath $ startAction defaultConfig invalidConfigFailsQuickly $ void . startAction customConfigWork $ \plan f -> either throwIO pure =<< - withPlan plan f + withConfig plan f let someStandardTests dbName= do withAnyPlan @@ -279,19 +264,19 @@ [PG.Only actualDuration] <- PG.query_ conn "SHOW log_min_duration_statement" actualDuration `shouldBe` expectedDuration - let invalidCreateDbPlan = updateCreateDb defaultConfig $ - Mappend $ pure $ theStandardProcessConfig - { partialProcessConfigCmdLine = Mappend $ mempty + let invalidCreateDbPlan = setCreateDb defaultConfig $ + pure $ standardProcessConfig + { partialProcessConfigCmdLine = mempty { partialCommandLineArgsIndexBased = Map.singleton 0 "template1" } } - before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith invalidCreateDbPlan) stop f) $ + before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startConfig invalidCreateDbPlan) stop f) $ createDbThrowsIfTheDbExists let noCreateTemplate1 = mempty { configPlan = mempty - { partialPlanCreateDb = Replace Nothing + { partialPlanCreateDb = Accum Nothing , partialPlanPostgres = mempty { partialPostgresPlanClientConfig = mempty { Client.dbname = pure "template1" @@ -300,13 +285,13 @@ } } noCreateDbPlan = defaultConfig <> noCreateTemplate1 - before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith noCreateDbPlan) stop f) $ + before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startConfig noCreateDbPlan) stop f) $ someStandardTests "template1" - before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith defaultIpPlan) stop f) $ + before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startConfig defaultIpPlan) stop f) $ someStandardTests "postgres" - before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith specificHostIpPlan) stop f) $ + before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startConfig specificHostIpPlan) stop f) $ someStandardTests "postgres" thePort <- runIO getFreePort @@ -316,7 +301,7 @@ , Client.port = pure thePort } - before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith planFromCustomUserDbConnection) stop f) $ + before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startConfig planFromCustomUserDbConnection) stop f) $ someStandardTests "fancy" before (createTempDirectory "/tmp" "tmp-postgres-test") $ after rmDirIgnoreErrors $ do @@ -325,7 +310,7 @@ let nonEmptyFolderPlan = defaultConfig { configDataDir = PPermanent dirPath } - startAction = bracket (either throwIO pure =<< startWith nonEmptyFolderPlan) stop $ const $ pure () + startAction = bracket (either throwIO pure =<< startConfig nonEmptyFolderPlan) stop $ const $ pure () startAction `shouldThrow` (== InitDbFailed (ExitFailure 1)) @@ -334,10 +319,10 @@ let nonEmptyFolderPlan = defaultConfig { configDataDir = PPermanent dirPath , configPlan = (configPlan defaultConfig) - { partialPlanInitDb = Replace Nothing + { partialPlanInitDb = Accum Nothing } } - bracket (either throwIO pure =<< startWith nonEmptyFolderPlan) stop $ \db -> do + bracket (either throwIO pure =<< startConfig nonEmptyFolderPlan) stop $ \db -> do one <- fmap (PG.fromOnly . head) $ bracket (PG.connectPostgreSQL $ toConnectionString db ) PG.close $ \conn -> PG.query_ conn "SELECT 1" @@ -346,7 +331,7 @@ let justBackupResources = mempty { configPlan = mempty - { partialPlanConfig = Mappend + { partialPlanConfig = [ "wal_level=replica" , "archive_mode=on" , "max_wal_senders=2" @@ -356,7 +341,7 @@ } } backupResources = defaultConfig <> justBackupResources - before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith backupResources) stop f) $ + before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startConfig backupResources) stop f) $ it "can support backup and restore" $ withRunner $ \db@DB {..} -> do let dataDir = toFilePath (resourcesDataDir dbResources) appendFile (dataDir ++ "/pg_hba.conf") $ "local replication all trust" diff --git a/tmp-postgres.cabal b/tmp-postgres.cabal --- a/tmp-postgres.cabal +++ b/tmp-postgres.cabal @@ -1,5 +1,5 @@ name: tmp-postgres -version: 1.2.1.0 +version: 1.3.0.0 synopsis: Start and stop a temporary postgres description: @tmp-postgres@ provides functions creating a temporary @postgres@ instance. @@ -51,6 +51,7 @@ , ApplicativeDo , DeriveFunctor , ViewPatterns + , GeneralizedNewtypeDeriving build-depends: base >= 4.6 && < 5 , temporary , process >= 1.2.0.0