diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,8 @@ Changelog for tmp-postgres +1.21.1.1 + #172 Fix verboseLogging not working + 1.21.1.0 #135 Add defaultConfig_9_3_10 #170 Expose cacheResourcesToConfig 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 @@ -196,7 +196,7 @@ defaultConfig :: Config defaultConfig = mempty { plan = mempty - { postgresConfigFile = fastPostgresConfig + { postgresConfigFile = verbosePostgresConfig , initDbConfig = pure mempty { commandLine = mempty { keyBased = Map.singleton "--no-sync" Nothing @@ -217,7 +217,7 @@ defaultConfig_9_3_10 :: Config defaultConfig_9_3_10 = mempty { plan = mempty - { postgresConfigFile = fastPostgresConfig + { postgresConfigFile = verbosePostgresConfig , initDbConfig = pure mempty { commandLine = mempty { keyBased = Map.singleton "--nosync" Nothing @@ -279,6 +279,7 @@ { logger = pure print , postgresConfigFile = verbosePostgresConfig , initDbConfig = pure standardProcessConfig + , createDbConfig = pure standardProcessConfig , postgresPlan = mempty { postgresConfig = standardProcessConfig } diff --git a/src/Database/Postgres/Temp/Internal/Config.hs b/src/Database/Postgres/Temp/Internal/Config.hs --- a/src/Database/Postgres/Temp/Internal/Config.hs +++ b/src/Database/Postgres/Temp/Internal/Config.hs @@ -215,9 +215,6 @@ deriving Semigroup via GenericSemigroup ProcessConfig deriving Monoid via GenericMonoid ProcessConfig -prettyHandle :: Handle -> Doc -prettyHandle _ = text "[HANDLE]" - instance Pretty ProcessConfig where pretty ProcessConfig {..} = text "environmentVariables:" @@ -562,7 +559,7 @@ socketDirectoryToConfig :: FilePath -> [String] socketDirectoryToConfig dir = - [ "listen_addresses = '127.0.0.1, ::1'" + [ "listen_addresses = '127.0.0.1,::1'" , "unix_socket_directories = '" <> dir <> "'" ] @@ -738,7 +735,7 @@ } } , createDbConfig = if makeCreateDb - then pure $ silentProcessConfig + then pure silentProcessConfig { commandLine = mempty { keyBased = Map.fromList [ ("-h", Just socketDirectory) @@ -748,7 +745,7 @@ } else mempty - , initDbConfig = pure $ silentProcessConfig + , initDbConfig = pure silentProcessConfig { commandLine = mempty { keyBased = Map.fromList [("--pgdata=", Just dataDirectoryString)] @@ -757,22 +754,6 @@ , copyConfig = pure Nothing } - --- | 'combinePlans' is almost '<>'. However the 'Last' monoid for --- @createdb@ and @initdb@ plans are not used. Instead something --- like Lastoid is. -combinePlans :: Plan -> Plan -> Plan -combinePlans x y = Plan - { logger = logger x <> logger y - , initDbConfig = initDbConfig x <> initDbConfig y - , copyConfig = copyConfig x <> copyConfig y - , createDbConfig = createDbConfig x <> createDbConfig y - , postgresPlan = postgresPlan x <> postgresPlan y - , postgresConfigFile = postgresConfigFile x <> postgresConfigFile y - , dataDirectoryString = dataDirectoryString x <> dataDirectoryString y - , connectionTimeout = connectionTimeout x <> connectionTimeout y - } - -- | Create all the temporary resources from a 'Config'. This also combines the -- 'Plan' from 'toPlan' with the @extra@ 'Config' passed in. setupConfig @@ -794,7 +775,7 @@ thePort (toFilePath resourcesSocketDirectory) (toFilePath resourcesDataDir) - finalPlan = combinePlans hostAndDir plan + finalPlan = hostAndDir <> plan uncachedPlan <- lift $ either (throwIO . CompletePlanFailed (show $ pretty finalPlan)) pure $ completePlan envs finalPlan 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 @@ -44,8 +44,15 @@ -- ^ The fourth event and (possibly all subsequent events). -- We are looping trying to successfully connect to the @postgres@ -- process. - deriving (Show, Eq, Ord) + deriving (Eq, Ord) +instance Show Event where + show = \case + StartPlan x -> "StartPlan:\n" <> x + StartPostgres -> "StartPostgres" + WaitForDB -> "WaitForDB" + TryToConnect -> "TryToConnect" + -- | A list of failures that can occur when starting. This is not -- and exhaustive list but covers the errors that the system -- catches for the user. @@ -97,6 +104,12 @@ -- @since 1.12.0.0 type Logger = Event -> IO () +-- A simple helper to throw 'ExitCode's when they are 'ExitFailure'. +throwIfNotSuccess :: Exception e => (ExitCode -> e) -> ExitCode -> IO () +throwIfNotSuccess f = \case + ExitSuccess -> pure () + e -> throwIO $ f e + -- | @postgres@ is not ready until we are able to successfully connect. -- 'waitForDB' attempts to connect over and over again and returns -- after the first successful connection. @@ -138,6 +151,9 @@ -- ^ The 'Handle' for standard error } +prettyHandle :: Handle -> Doc +prettyHandle _ = text "HANDLE" + prettyKeyPair ::(Pretty a, Pretty b) => a -> b -> Doc prettyKeyPair k v = pretty k <> text ": " <> pretty v @@ -150,6 +166,15 @@ <> text "completeProcessConfigCmdLine:" <> softline <> text (unwords completeProcessConfigCmdLine) + <> hardline + <> text "completeProcessConfigStdIn:" + <+> prettyHandle completeProcessConfigStdIn + <> hardline + <> text "completeProcessConfigStdOut:" + <+> prettyHandle completeProcessConfigStdOut + <> hardline + <> text "completeProcessConfigStdErr:" + <+> prettyHandle completeProcessConfigStdErr -- | Start a process interactively and return the 'ProcessHandle' startProcess @@ -198,8 +223,8 @@ ------------------------------------------------------------------------------- -- PostgresProcess Life cycle management ------------------------------------------------------------------------------- --- | 'CompletePostgresPlan' is used be 'startPostgresProcess' to start the @postgres@ --- and then attempt to connect to it. +-- | 'CompletePostgresPlan' is used be 'startPostgresProcess' to start the +-- @postgres@ and then attempt to connect to it. data CompletePostgresPlan = CompletePostgresPlan { completePostgresPlanProcessConfig :: CompleteProcessConfig -- ^ The process config for @postgres@ @@ -300,7 +325,7 @@ return result ------------------------------------------------------------------------------- --- Init command +-- Non interactive subcommands ------------------------------------------------------------------------------- executeInitDb :: CompleteProcessConfig -> IO () executeInitDb config = do @@ -337,15 +362,23 @@ copyCommand = cpFlags <> copyDirectoryCommandSrc <> "/* " <> copyDirectoryCommandDst throwIfNotSuccess (CopyCachedInitDbFailed copyCommand) =<< system copyCommand +-- | Call @createdb@ and tee the output to return if there is an +-- an exception. Throws 'CreateDbFailed'. +executeCreateDb :: CompleteProcessConfig -> IO () +executeCreateDb config = do + (res, stdOut, stdErr) <- executeProcessAndTee "createdb" config + throwIfNotSuccess (CreateDbFailed stdOut stdErr) res ------------------------------------------------------------------------------- -- CompletePlan ------------------------------------------------------------------------------- --- | 'CompletePlan' is the low level configuration necessary for creating a database +-- | 'CompletePlan' is the low level configuration necessary for initializing +-- a database cluster -- starting @postgres@ and creating a database. There is no validation done --- on the 'CompletePlan'. 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. 'CompletePlan's are used internally but are exposed if the higher --- level plan generation is not sufficent. +-- are valid. 'CompletePlan's are used internally but are exposed if the +-- higher level plan generation is not sufficent. data CompletePlan = CompletePlan { completePlanLogger :: Logger , completePlanInitDb :: Maybe CompleteProcessConfig @@ -382,19 +415,6 @@ <> text "completePlanDataDirectory:" <+> pretty completePlanDataDirectory --- A simple helper to throw 'ExitCode's when they are 'ExitFailure'. -throwIfNotSuccess :: Exception e => (ExitCode -> e) -> ExitCode -> IO () -throwIfNotSuccess f = \case - ExitSuccess -> pure () - e -> throwIO $ f e - --- | Call @createdb@ and tee the output to return if there is an --- an exception. Throws 'CreateDbFailed'. -executeCreateDb :: CompleteProcessConfig -> IO () -executeCreateDb config = do - (res, stdOut, stdErr) <- executeProcessAndTee "createdb" config - throwIfNotSuccess (CreateDbFailed stdOut stdErr) res - -- | 'startPlan' optionally calls @initdb@, optionally calls @createdb@ and -- unconditionally calls @postgres@. -- Additionally it writes a \"postgresql.conf\" and does not return until @@ -426,4 +446,3 @@ -- | Stop the @postgres@ process. See 'stopPostgresProcess' for more details. stopPlan :: PostgresProcess -> IO ExitCode stopPlan = stopPostgresProcess False - diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -6,7 +6,6 @@ import Data.Maybe import Data.Monoid import Data.Monoid.Generic --- import Data.Int import Data.List import qualified Data.Set as Set import Data.String @@ -310,7 +309,8 @@ it "works if on non-empty if initdb is disabled" $ withTempDirectory "/tmp" "tmp-postgres-preinitdb" $ \dirPath -> do - throwIfNotSuccess id =<< system ("initdb " <> dirPath) + throwIfNotSuccess id . (\(x, _, _) -> x) =<< + readProcessWithExitCode "initdb" [dirPath] "" let nonEmptyFolderConfig = memptyConfigAndAssertion { cConfig = defaultConfig { dataDirectory = Permanent dirPath @@ -382,7 +382,7 @@ it "withDbCache seems to work" $ withDbCache $ \cacheInfo -> - either throwIO pure =<< withConfig (defaultConfig <> cacheResourcesToConfig cacheInfo) assertConnection + either throwIO pure =<< withConfig (cacheResourcesToConfig cacheInfo) assertConnection -- -- Error Plans. Can't be combined. Just list them out inline since they can't be combined @@ -422,10 +422,17 @@ {- it "throws StartPostgresFailed if the port is taken" $ bracket openFreePort (N.close . snd) $ \(thePort, _) -> do - let invalidConfig = optionsToDefaultConfig mempty + let invalidConfig' = optionsToDefaultConfig mempty { Client.port = pure thePort , Client.host = pure "127.0.0.1" + } <> verboseConfig + + invalidConfig = invalidConfig' + { plan = (plan invalidConfig') + { connectionTimeout = pure 1000000 + } } + withConfig invalidConfig (const $ pure ()) `shouldReturn` Left (StartPostgresFailed $ ExitFailure 1) -} @@ -591,7 +598,7 @@ reloadConfig db - bracket (PG.connectPostgreSQL $ toConnectionString db) PG.close $ \conn -> do + withConn db $ \conn -> do [PG.Only actualDuration] <- PG.query_ conn "SHOW log_min_duration_statement" actualDuration `shouldBe` expectedDuration @@ -640,8 +647,6 @@ [ "wal_level=replica" , "archive_mode=on" , "max_wal_senders=2" - , "fsync=on" - , "synchronous_commit=on" ] backupResources = justBackupResources 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.21.1.0 +version: 1.21.1.1 synopsis: Start and stop a temporary postgres description: Start and stop a temporary postgres. See README.md homepage: https://github.com/jfischoff/tmp-postgres#readme