tmp-postgres 1.2.1.0 → 1.3.0.0
raw patch · 7 files changed
+179/−195 lines, 7 files
Files
- README.md +1/−1
- src/Database/Postgres/Temp.hs +12/−17
- src/Database/Postgres/Temp/Internal.hs +48/−38
- src/Database/Postgres/Temp/Internal/Core.hs +3/−4
- src/Database/Postgres/Temp/Internal/Partial.hs +81/−87
- test/Spec.hs +32/−47
- tmp-postgres.cabal +2/−1
README.md view
@@ -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
src/Database/Postgres/Temp.hs view
@@ -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"
src/Database/Postgres/Temp/Internal.hs view
@@ -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+ }+ }
src/Database/Postgres/Temp/Internal/Core.hs view
@@ -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
src/Database/Postgres/Temp/Internal/Partial.hs view
@@ -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 } }
test/Spec.hs view
@@ -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"
tmp-postgres.cabal view
@@ -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