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 @@ -47,11 +47,9 @@ module Database.Postgres.Temp ( - -- * Main resource handle - DB (..) -- * Exception safe interface -- $options - , with + with , withConfig -- * Separate start and stop interface. , start @@ -72,8 +70,12 @@ , toConnectionString -- * Errors , StartError (..) + -- * Main resource handle + , DB (..) + , prettyPrintDB -- * Configuration Types , Config (..) + , prettyPrintConfig -- ** Directory configuration , DirectoryType (..) , PartialDirectoryType (..) @@ -150,10 +152,6 @@ This is common enough there is `defaultPostgresConf` which is a helper to do this. - - In general you'll want to 'mappend' a config to the 'defaultConfig' - since the 'defaultConfig' setups a client connection to the - @postgres@ database. As an alternative to using 'defaultConfig' one could create a config from connections parameters using 'optionsToDefaultConfig' 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 @@ -14,6 +14,7 @@ import Control.Monad.Trans.Cont import qualified Database.PostgreSQL.Simple as PG import qualified Data.Map.Strict as Map +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) -- | Handle for holding temporary resources, the @postgres@ process handle -- and postgres connection information. The 'DB' also includes the @@ -27,13 +28,23 @@ -- ^ @postgres@ process handle and the connection options. } +instance Pretty DB where + pretty DB {..} + = text "dbResources" + <> softline + <> indent 2 (pretty dbResources) + <> hardline + <> text "dbPostgresProcess" + <> softline + <> indent 2 (pretty dbPostgresProcess) + -- | Convert a 'DB' to a connection string. Alternatively one can access the -- 'Client.Options' using --- @postgresProcessClientConfig . dbPostgresProcess@ +-- @postgresProcessClientOptions . dbPostgresProcess@ toConnectionString :: DB -> ByteString toConnectionString = Client.toConnectionString - . postgresProcessClientConfig + . postgresProcessClientOptions . dbPostgresProcess ------------------------------------------------------------------------------- -- Life Cycle Management @@ -133,9 +144,9 @@ -> IO (Either StartError DB) startConfig extra = try $ evalContT $ do dbResources@Resources {..} <- - ContT $ bracketOnError (initConfig extra) shutdownResources + ContT $ bracketOnError (setupConfig extra) cleanupResources dbPostgresProcess <- - ContT $ bracketOnError (initPlan resourcesPlan) stopPostgresProcess + ContT $ bracketOnError (startPlan resourcesPlan) stopPostgresProcess pure DB {..} -- | Default start behavior. Equivalent to calling 'startConfig' with the @@ -148,7 +159,7 @@ stop :: DB -> IO () stop DB {..} = do void $ stopPostgresProcess dbPostgresProcess - shutdownResources dbResources + cleanupResources dbResources -- | Only stop the @postgres@ process but leave any temporary resources. -- Useful for testing backup strategies when used in conjunction with @@ -170,7 +181,7 @@ -- @pg_reload_conf()@. reloadConfig :: DB -> IO () reloadConfig db = - bracket (PG.connectPostgreSQL $ toConnectionString db) PG.close $ \conn -> do + bracket (PG.connectPostgreSQL $ toConnectionString db) PG.close $ \conn -> (void :: IO [PG.Only Bool] -> IO ()) $ PG.query_ conn "SELECT pg_reload_conf()" ------------------------------------------------------------------------------- @@ -178,7 +189,7 @@ ------------------------------------------------------------------------------- -- | Exception safe default database create. Takes an @action@ continuation -- which is given a 'DB' it can use to connect --- to (see 'toConnectionString' or 'postgresProcessClientConfig'). +-- to (see 'toConnectionString' or 'postgresProcessClientOptions'). -- All of the database resources are automatically cleaned up on -- completion even in the face of exceptions. withConfig :: Config @@ -217,3 +228,14 @@ } } in startingConfig <> generated + +------------------------------------------------------------------------------- +-- Pretty Printing +------------------------------------------------------------------------------- +-- | Display a 'Config'. +prettyPrintConfig :: Config -> String +prettyPrintConfig = show . pretty + +-- | Display a 'DB' +prettyPrintDB :: DB -> String +prettyPrintDB = show . pretty 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 @@ -1,17 +1,17 @@ +{-# OPTIONS_HADDOCK prune #-} {-| This module provides the low level functionality for running @initdb@, @postgres@ and @createdb@ to make a database. -See 'initPlan' for more details. +See 'startPlan' for more details. -} module Database.Postgres.Temp.Internal.Core where -import qualified Database.PostgreSQL.Simple.Options as PostgresClient +import qualified Database.PostgreSQL.Simple.Options as Client import qualified Database.PostgreSQL.Simple as PG import System.Process.Internals import System.Exit (ExitCode(..)) import Data.String import System.Posix.Signals (sigINT, signalProcess) import Control.Exception -import System.Process (getProcessExitCode, waitForProcess) import Data.Foldable (for_) import Control.Concurrent.Async (race_) import Control.Monad (forever, (>=>)) @@ -20,6 +20,8 @@ import System.IO import System.Process import Data.Monoid +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) +import qualified Data.ByteString.Char8 as BSC -- | Internal events for debugging data Event @@ -54,9 +56,9 @@ -- | @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. -waitForDB :: PostgresClient.Options -> IO () +waitForDB :: Client.Options -> IO () waitForDB options = do - let theConnectionString = PostgresClient.toConnectionString options + let theConnectionString = Client.toConnectionString options startAction = PG.connectPostgreSQL theConnectionString try (bracket startAction PG.close mempty) >>= \case Left (_ :: IOError) -> threadDelay 10000 >> waitForDB options @@ -77,6 +79,19 @@ -- ^ 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:" + <> softline + <> indent 2 (vsep (map (uncurry prettyKeyPair) processConfigEnvVars)) + <> hardline + <> text "processConfigCmdLine:" + <> softline + <> text (unwords processConfigCmdLine) + -- | Start a process interactively and return the 'ProcessHandle' startProcess :: String @@ -108,23 +123,40 @@ data PostgresPlan = PostgresPlan { postgresPlanProcessConfig :: ProcessConfig -- ^ The process config for @postgres@ - , postgresPlanClientConfig :: PostgresClient.Options + , postgresPlanClientOptions :: Client.Options -- ^ Connection options. Used to verify that @postgres@ is ready. } +instance Pretty PostgresPlan where + pretty PostgresPlan {..} + = text "postgresPlanProcessConfig:" + <> softline + <> indent 2 (pretty postgresPlanProcessConfig) + <> hardline + <> text "postgresPlanClientOptions:" + <+> prettyOptions postgresPlanClientOptions + +prettyOptions :: Client.Options -> Doc +prettyOptions = text . BSC.unpack . Client.toConnectionString + -- | The output of calling 'startPostgresProcess'. data PostgresProcess = PostgresProcess - { postgresProcessClientConfig :: PostgresClient.Options + { postgresProcessClientOptions :: Client.Options -- ^ Connection options , postgresProcessHandle :: ProcessHandle -- ^ @postgres@ process handle } --- | Force all connections to the database to close. --- Called during shutdown as well. -terminateConnections :: PostgresClient.Options-> IO () +instance Pretty PostgresProcess where + pretty PostgresProcess {..} + = text "postgresProcessClientOptions:" + <+> prettyOptions postgresProcessClientOptions + +-- Force all connections to the database to close. +-- Called during shutdown as well. +terminateConnections :: Client.Options-> IO () terminateConnections options = do - let theConnectionString = PostgresClient.toConnectionString options + let theConnectionString = Client.toConnectionString options terminationQuery = fromString $ unlines [ "SELECT pg_terminate_backend(pid)" , "FROM pg_stat_activity" @@ -132,7 +164,7 @@ ] e <- try $ bracket (PG.connectPostgreSQL theConnectionString) PG.close $ \conn -> PG.execute conn terminationQuery - [getLast $ PostgresClient.dbname options] + [getLast $ Client.dbname options] case e of Left (_ :: IOError) -> pure () Right _ -> pure () @@ -145,14 +177,13 @@ OpenHandle p -> do -- try to terminate the connects first. If we can't terminate still -- keep shutting down - terminateConnections postgresProcessClientConfig + terminateConnections postgresProcessClientOptions signalProcess sigINT p OpenExtHandle {} -> pure () -- TODO log windows is not supported ClosedHandle _ -> return () - exitCode <- waitForProcess postgresProcessHandle - pure exitCode + waitForProcess postgresProcessHandle -- | Start the @postgres@ process and block until a successful connection -- occurs. A separate thread we continously check to see if the @postgres@ @@ -161,7 +192,7 @@ startPostgresProcess logger PostgresPlan {..} = do logger StartPostgres - let startAction = PostgresProcess postgresPlanClientConfig + let startAction = PostgresProcess postgresPlanClientOptions <$> startProcess "postgres" postgresPlanProcessConfig -- Start postgres and stop if an exception occurs @@ -175,8 +206,8 @@ logger WaitForDB -- We assume that 'template1' exist and make connection -- options to test if postgres is ready. - let options = postgresPlanClientConfig - { PostgresClient.dbname = pure "template1" + let options = postgresPlanClientOptions + { Client.dbname = pure "template1" } -- Block until a connection succeeds or postgres crashes @@ -203,19 +234,40 @@ , planDataDirectory :: FilePath } --- | A simple helper to throw 'ExitCode's when they are 'ExitFailure'. +instance Pretty Plan where + pretty Plan {..} + = text "planInitDb:" + <> softline + <> indent 2 (pretty planInitDb) + <> hardline + <> text "planCreateDb:" + <> softline + <> indent 2 (pretty planCreateDb) + <> hardline + <> text "planPostgres:" + <> softline + <> indent 2 (pretty planPostgres) + <> hardline + <> text "planConfig:" + <> softline + <> indent 2 (pretty planConfig) + <> hardline + <> text "planDataDirectory:" + <+> pretty planDataDirectory + +-- 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 --- | 'initPlan' optionally calls @initdb@, optionally calls @createdb@ and +-- | 'startPlan' optionally calls @initdb@, optionally calls @createdb@ and -- unconditionally calls @postgres@. -- Additionally it writes a \"postgresql.conf\" and does not return until -- the @postgres@ process is ready. See 'startPostgresProcess' for more -- details. -initPlan :: Plan -> IO PostgresProcess -initPlan Plan {..} = do +startPlan :: Plan -> IO PostgresProcess +startPlan Plan {..} = do for_ planInitDb $ executeProcess "initdb" >=> throwIfNotSuccess InitDbFailed @@ -231,5 +283,5 @@ pure result -- | Stop the @postgres@ process. See 'stopPostgresProcess' for more details. -shutdownPlan :: PostgresProcess -> IO ExitCode -shutdownPlan = stopPostgresProcess +stopPlan :: PostgresProcess -> IO ExitCode +stopPlan = stopPostgresProcess 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,3 +1,4 @@ +{-# OPTIONS_HADDOCK prune #-} {-| This module provides types and functions for combining partial configs into a complete configs to ultimately make a 'Plan'. @@ -32,7 +33,13 @@ import System.IO.Error import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +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. @@ -53,6 +60,15 @@ 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' @@ -86,8 +102,20 @@ partialCommandLineArgsIndexBased y <> partialCommandLineArgsIndexBased x } --- | Take values as long as the index is the successor of the --- last index. +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 _ [] = [] @@ -122,6 +150,29 @@ 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. @@ -135,11 +186,11 @@ , partialProcessConfigStdErr = pure stderr } --- | A helper to add more info to all the error messages. +-- 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. +-- A helper for creating an error if a 'Last' is not defined. getOption :: String -> Last a -> Validation [String] a getOption optionName = \case Last (Just x) -> pure x @@ -173,6 +224,11 @@ Permanent x -> x Temporary x -> x +instance Pretty DirectoryType where + pretty = \case + Permanent x -> text "Permanent" <+> pretty x + Temporary x -> text "Temporary" <+> pretty 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. @@ -183,6 +239,11 @@ -- ^ 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 @@ -193,12 +254,12 @@ -- | Either create a'Temporary' directory or do nothing to a 'Permanent' -- one. -initDirectoryType :: String -> PartialDirectoryType -> IO DirectoryType -initDirectoryType pattern = \case +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 +-- Either create a temporary directory or do nothing rmDirIgnoreErrors :: FilePath -> IO () rmDirIgnoreErrors mainDir = do let ignoreDirIsMissing e @@ -208,8 +269,8 @@ -- | Either remove a 'Temporary' directory or do nothing to a 'Permanent' -- one. -shutdownDirectoryType :: DirectoryType -> IO () -shutdownDirectoryType = \case +cleanupDirectoryType :: DirectoryType -> IO () +cleanupDirectoryType = \case Permanent _ -> pure () Temporary filePath -> rmDirIgnoreErrors filePath @@ -225,6 +286,11 @@ -- ^ 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 @@ -256,6 +322,11 @@ -- ^ 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 @@ -269,18 +340,18 @@ -- | 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. -initPartialSocketClass :: PartialSocketClass -> IO SocketClass -initPartialSocketClass theClass = case theClass of +setupPartialSocketClass :: PartialSocketClass -> IO SocketClass +setupPartialSocketClass theClass = case theClass of PIpSocket mIp -> pure $ IpSocket $ fromMaybe "127.0.0.1" $ getLast mIp PUnixSocket mFilePath -> - UnixSocket <$> initDirectoryType "tmp-postgres-socket" mFilePath + UnixSocket <$> setupDirectoryType "tmp-postgres-socket" mFilePath -- | Cleanup the UNIX socket temporary directory if one was created. -shutdownSocketConfig :: SocketClass -> IO () -shutdownSocketConfig = \case +cleanupSocketConfig :: SocketClass -> IO () +cleanupSocketConfig = \case IpSocket {} -> pure () - UnixSocket dir -> shutdownDirectoryType dir + UnixSocket dir -> cleanupDirectoryType dir -- | PartialPostgresPlan data PartialPostgresPlan = PartialPostgresPlan @@ -293,11 +364,21 @@ 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 {..} = validationToEither $ do - let postgresPlanClientConfig = partialPostgresPlanClientConfig + let postgresPlanClientOptions = partialPostgresPlanClientConfig postgresPlanProcessConfig <- eitherToValidation $ addErrorContext "partialPostgresPlanProcessConfig: " $ completeProcessConfig envs partialPostgresPlanProcessConfig @@ -320,6 +401,26 @@ 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 {..} = validationToEither $ do @@ -336,22 +437,22 @@ pure Plan {..} --- | Returns 'True' if the 'PartialPlan' has a --- 'Just' 'partialPlanInitDb' +-- 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' +-- 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 'initPlan'. --- See 'initConfig' for an example of how to create a 'Resources'. +-- 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 'initPlan' for information on 'Plan's + -- ^ 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. @@ -359,6 +460,18 @@ -- ^ 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 + -- | The high level options for overriding default behavior. data Config = Config { configPlan :: PartialPlan @@ -377,6 +490,22 @@ 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 @@ -432,17 +561,17 @@ -- | Create all the temporary resources from a 'Config'. This also combines the -- 'PartialPlan' from 'toPlan' with the @extraConfig@ passed in. -initConfig +setupConfig :: Config -- ^ @extraConfig@ to 'mappend' after the default config -> IO Resources -initConfig Config {..} = evalContT $ do +setupConfig Config {..} = evalContT $ do envs <- lift getEnvironment port <- lift $ maybe getFreePort pure $ join $ getLast configPort resourcesSocket <- ContT $ bracketOnError - (initPartialSocketClass configSocket) shutdownSocketConfig + (setupPartialSocketClass configSocket) cleanupSocketConfig resourcesDataDir <- ContT $ bracketOnError - (initDirectoryType "tmp-postgres-data" configDataDir) shutdownDirectoryType + (setupDirectoryType "tmp-postgres-data" configDataDir) cleanupDirectoryType let hostAndDirPartial = toPlan (hasInitDb configPlan) (hasCreateDb configPlan) @@ -454,11 +583,11 @@ completePlan envs finalPlan pure Resources {..} --- | Free the temporary resources created by 'initConfig' -shutdownResources :: Resources -> IO () -shutdownResources Resources {..} = do - shutdownSocketConfig resourcesSocket - shutdownDirectoryType resourcesDataDir +-- | Free the temporary resources created by 'setupConfig' +cleanupResources :: Resources -> IO () +cleanupResources Resources {..} = do + cleanupSocketConfig resourcesSocket + cleanupDirectoryType resourcesDataDir ------------------------------------------------------------------------------- -- Config Generation ------------------------------------------------------------------------------- @@ -474,16 +603,16 @@ , configSocket = maybe mempty hostToSocketClass $ getLast host } ) --- | Convert the 'Client.Options' to a 'PartialPlan' that can --- be connected to with the 'Client.Options'. +-- 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' +-- Wrap the 'Client.Options' in an appropiate +-- 'PartialPostgresPlan' clientOptionsToPlan :: Client.Options -> PartialPlan clientOptionsToPlan opts = mempty { partialPlanPostgres = mempty @@ -491,7 +620,7 @@ } } --- | Create a 'PartialPlan' given a user +-- Create a 'PartialPlan' given a user userToPlan :: String -> PartialPlan userToPlan user = mempty { partialPlanCreateDb = pure $ mempty @@ -506,8 +635,8 @@ } } --- | Adds a @createdb@ PartialProcessPlan with the argument --- as the database name. +-- Adds a @createdb@ PartialProcessPlan with the argument +-- as the database name. dbnameToPlan :: String -> PartialPlan dbnameToPlan dbName = mempty { partialPlanCreateDb = pure $ mempty @@ -517,8 +646,8 @@ } } --- | Parse a host string as either an UNIX domain socket directory --- or a domain or IP. +-- 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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -47,18 +47,18 @@ let Resources {..} = dbResources Plan {..} = resourcesPlan PostgresPlan {..} = planPostgres - Client.dbname postgresPlanClientConfig `shouldBe` pure "postgres" + Client.dbname postgresPlanClientOptions `shouldBe` pure "postgres" let Temporary tmpDataDir = resourcesDataDir tmpDataDir `shouldStartWith` "/tmp/tmp-postgres-data" - let Just port = getLast $ Client.port postgresPlanClientConfig + let Just port = getLast $ Client.port postgresPlanClientOptions port `shouldSatisfy` (>32768) let UnixSocket (Temporary unixSocket) = resourcesSocket unixSocket `shouldStartWith` "/tmp/tmp-postgres-socket" - postgresPlanClientConfig `shouldBe` + postgresPlanClientOptions `shouldBe` (mempty - { Client.port = Client.port postgresPlanClientConfig - , Client.host = Client.host postgresPlanClientConfig - , Client.dbname = Client.dbname postgresPlanClientConfig + { Client.port = Client.port postgresPlanClientOptions + , Client.host = Client.host postgresPlanClientOptions + , Client.dbname = Client.dbname postgresPlanClientOptions } ) @@ -116,7 +116,7 @@ let Resources {..} = dbResources Plan {..} = resourcesPlan - actualOptions = postgresPlanClientConfig planPostgres + actualOptions = postgresPlanClientOptions planPostgres actualPostgresConfig = planConfig Client.user actualOptions `shouldBe` pure expectedUser Client.dbname actualOptions `shouldBe` pure expectedDbName @@ -368,8 +368,8 @@ reloadConfig db - let Just port = getLast $ Client.port $ postgresProcessClientConfig dbPostgresProcess - Just host = getLast $ Client.host $ postgresProcessClientConfig dbPostgresProcess + let Just port = getLast $ Client.port $ postgresProcessClientOptions dbPostgresProcess + Just host = getLast $ Client.host $ postgresProcessClientOptions dbPostgresProcess backupCommand = "pg_basebackup -D " ++ baseBackupFile ++ " --format=tar -p" ++ show port ++ " -h" ++ host 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.5.0.0 +version: 1.6.0.0 synopsis: Start and stop a temporary postgres description: @tmp-postgres@ provides functions creating a temporary @postgres@ instance. @@ -66,6 +66,7 @@ , either , transformers , containers + , ansi-wl-pprint ghc-options: -Wall default-language: Haskell2010