diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,3 +2,9 @@ 1.7.1.0 #35 Add Lenses for configuration + +1.8.0.0 + Get rid of `Partial` prefix. Add a `Complete` prefix to the internal configuration types. + Remove the `partial` prefix. + Expand abbreviations. + Order the Event type creation time. 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 @@ -76,53 +76,53 @@ , Config (..) , prettyPrintConfig -- *** 'Config' Lenses - , configPlanL - , configSocketL - , configDataDirL + , planL + , socketClassL + , dataDirectoryL , configPortL - -- ** 'PartialPlan' - , PartialPlan (..) - -- *** 'PartialPlan' lenses - , partialPlanConfigL - , partialPlanCreateDbL - , partialPlanDataDirectoryL - , partialPlanInitDbL + -- ** 'Plan' + , Plan (..) + -- *** 'Plan' lenses + , postgresConfigFileL + , createDbConfigL + , dataDirectoryStringL + , initDbConfigL , partialPlanLoggerL - , partialPlanPostgresL - -- ** 'PartialPostgresPlan' - , PartialPostgresPlan (..) - -- *** 'PartialPostgresPlan' lenses - , partialPostgresPlanClientConfigL - , partialPostgresPlanProcessConfigL - -- ** 'PartialProcessConfig' - , PartialProcessConfig (..) - -- *** 'PartialProcessConfig' Lenses - , partialProcessConfigCmdLineL - , partialProcessConfigEnvVarsL - , partialProcessConfigStdErrL - , partialProcessConfigStdInL - , partialProcessConfigStdOutL - -- ** 'PartialEnvVars' - , PartialEnvVars (..) - -- *** 'PartialEnvVars' Lenses - , partialEnvVarsInheritL - , partialEnvVarsSpecificL - -- ** 'PartialCommandLineArgs' - , PartialCommandLineArgs (..) - -- *** 'PartialCommandLineArgs' Lenses - , partialCommandLineArgsIndexBasedL - , partialCommandLineArgsKeyBasedL - -- ** 'PartialDirectoryType' - , PartialDirectoryType (..) - -- ** 'PartialSocketClass' - , PartialSocketClass (..) + , postgresPlanL + -- ** 'PostgresPlan' + , PostgresPlan (..) + -- *** 'PostgresPlan' lenses + , connectionOptionsL + , postgresConfigL + -- ** 'ProcessConfig' + , ProcessConfig (..) + -- *** 'ProcessConfig' Lenses + , commandLineL + , environmentVariablesL + , stdErrL + , stdInL + , stdOutL + -- ** 'EnvVars' + , EnvVars (..) + -- *** 'EnvVars' Lenses + , inheritL + , specificL + -- ** 'CommandLineArgs' + , CommandLineArgs (..) + -- *** 'CommandLineArgs' Lenses + , indexBasedL + , keyBasedL + -- ** 'DirectoryType' + , DirectoryType (..) + -- ** 'SocketClass' + , SocketClass (..) -- ** 'Logger' , Logger - -- * Internal events passed to the 'partialPlanLogger' . + -- * Internal events passed to the 'logger' . , Event (..) -- * Errors , StartError (..) ) where import Database.Postgres.Temp.Internal import Database.Postgres.Temp.Internal.Core -import Database.Postgres.Temp.Internal.Partial +import Database.Postgres.Temp.Internal.Config 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 @@ -6,7 +6,7 @@ module Database.Postgres.Temp.Internal where import Database.Postgres.Temp.Internal.Core -import Database.Postgres.Temp.Internal.Partial +import Database.Postgres.Temp.Internal.Config import Control.Exception import Control.Monad (void) @@ -20,12 +20,12 @@ -- | Handle for holding temporary resources, the @postgres@ process handle -- and postgres connection information. The 'DB' also includes the --- final 'Plan' that was used to start @initdb@, @createdb@ and +-- final 'CompletePlan' that was used to start @initdb@, @createdb@ and -- @postgres@. See 'toConnectionString' for converting a 'DB' to -- postgresql connection string. data DB = DB { dbResources :: Resources - -- ^ Temporary resources and the final 'Plan'. + -- ^ Temporary resources and the final 'CompletePlan'. , dbPostgresProcess :: PostgresProcess -- ^ @postgres@ process handle and the connection options. } @@ -118,17 +118,17 @@ your @postgres@ might start and run faster if you use 'defaultConfig'. -'defaultConfig' also sets the 'partialPlanInitDb' to +'defaultConfig' also sets the 'initDbConfig' to 'pure' 'standardProcessConfig' and -'partialPostgresPlanProcessConfig' to 'standardProcessConfig'. +'postgresConfig' to 'standardProcessConfig'. To append additional lines to \"postgresql.conf\" file create a custom 'Config' like the following. @ custom = defaultConfig <> mempty - { configPlan = mempty - { partialPlanConfig = + { plan = mempty + { postgresConfigFile = [ "wal_level = replica" , "archive_mode = on" , "max_wal_senders = 2" @@ -142,7 +142,7 @@ Or using the provided lenses and your favorite lens library @ - custom = defaultConfig & 'configPlanL' . 'partialPlanConfigL' <>~ + custom = defaultConfig & 'planL' . 'postgresConfigFile' <>~ [ "wal_level = replica" , "archive_mode = on" , "max_wal_senders = 2" @@ -159,17 +159,17 @@ -} defaultConfig :: Config defaultConfig = mempty - { configPlan = mempty - { partialPlanLogger = pure mempty - , partialPlanConfig = defaultPostgresConfig - , partialPlanCreateDb = Nothing - , partialPlanInitDb = pure standardProcessConfig - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsKeyBased = Map.singleton "--no-sync" Nothing + { plan = mempty + { logger = pure mempty + , postgresConfigFile = defaultPostgresConfig + , createDbConfig = Nothing + , initDbConfig = pure standardProcessConfig + { commandLine = mempty + { keyBased = Map.singleton "--no-sync" Nothing } } - , partialPlanPostgres = mempty - { partialPostgresPlanProcessConfig = standardProcessConfig + , postgresPlan = mempty + { postgresConfig = standardProcessConfig } } } @@ -180,8 +180,8 @@ @ defaultPostgresConf extra = defaultConfig <> mempty - { configPlan = mempty - { partialPlanConfig = extra + { plan = mempty + { postgresConfigFile = extra } } @ @@ -189,21 +189,53 @@ -} defaultPostgresConf :: [String] -> Config defaultPostgresConf extra = defaultConfig <> mempty - { configPlan = mempty - { partialPlanConfig = extra + { plan = mempty + { postgresConfigFile = extra } } --- | Create temporary resources and use them to make a 'Config'. --- The generated 'Config' is combined with the passed in @extraConfiguration@ --- to create a 'Plan' that is used to create a database. --- The output 'DB' includes references to the temporary resources for --- cleanup and the final plan that was used to generate the database and --- processes +{-| + +Create zero or more temporary resources and use them to make a 'Config'. + +The passed in config is inspected and a generated config is created. +The final config is built by + + @ + generated '<>' extra + @ + +Returns a 'DB' that requires cleanup. `startConfig` should be +used with a `bracket` and 'stop', e.g. + + @ + `withConfig` :: `Config` -> (`DB` -> IO a) -> IO (Either `StartError` a) + 'withConfig' plan f = `bracket` (`startConfig` plan) (either mempty `stop`) $ + either (pure . Left) (fmap Right . f) + @ + +or just use 'withConfig'. If you are calling 'startConfig' you +probably want 'withConfig' anyway. + +Based on the value of 'socketClass' a \"postgresql.conf\" is created with + + @ + listen_addresses = \'IP_ADDRESS\' + @ + + if it is 'CIpSocket'. If is 'CUnixSocket' then the lines + + @ + listen_addresses = '' + unix_socket_directories = \'SOCKET_DIRECTORY\' + @ + +are added. + +-} startConfig :: Config - -- ^ @extraConfiguration@ that is 'mappend'ed to the generated `Config`. - -- The extra config is 'mappend'ed second, e.g. - -- @generatedConfig <> extraConfiguration@ + -- ^ @extra@ configuration that is 'mappend'ed last to the generated `Config`. + -- @generated <> extra@ -> IO (Either StartError DB) startConfig extra = try $ evalContT $ do dbResources@Resources {..} <- @@ -217,7 +249,7 @@ start :: IO (Either StartError DB) start = startConfig defaultConfig --- | Stop the @postgres@ process and cleanup any temporary directories that +-- | Stop the @postgres@ process and cleanup any temporary resources that -- might have been created. stop :: DB -> IO () stop DB {..} = do @@ -230,13 +262,12 @@ stopPostgres :: DB -> IO ExitCode stopPostgres = stopPostgresProcess . dbPostgresProcess --- | Restart the @postgres@ using the 'Plan' from the 'DB' --- (e.g. @resourcesPlan . dbResources@) +-- | Restart the @postgres@ from 'DB' using the prior 'Plan' restart :: DB -> IO (Either StartError DB) restart db@DB{..} = try $ do void $ stopPostgres db let plan = resourcesPlan dbResources - bracketOnError (startPostgresProcess (planLogger plan) $ planPostgres plan) + bracketOnError (startPostgresProcess (completePlanLogger plan) $ completePlanPostgres plan) stopPostgresProcess $ \result -> pure $ db { dbPostgresProcess = result } @@ -251,25 +282,8 @@ -- Exception safe interface ------------------------------------------------------------------------------- {-| -Exception safe default database create. Takes an @action@ continuation -which is given a 'DB' it can use to connect -to (see 'toConnectionString' or 'postgresProcessClientOptions'). -All of the database resources are automatically cleaned up on -completion even in the face of exceptions. -Based on the value of 'configSocket' a \"postgresql.conf\" is created with - - @ - listen_addresses = \'IP_ADDRESS\' - @ - - if it is 'IpSocket'. If is 'UnixSocket' then the lines - - @ - listen_addresses = '' - unix_socket_directories = SOCKET_DIRECTORY - @ - -are added. This occurs as a side effect of calling 'withConfig'. +Exception safe database create with options. See 'startConfig' for more +details. Calls 'stop' even in the face of exceptions. -} withConfig :: Config -- ^ @extraConfiguration@. Combined with the generated 'Config'. See @@ -280,8 +294,13 @@ withConfig plan f = bracket (startConfig plan) (either mempty stop) $ either (pure . Left) (fmap Right . f) --- | Default expectation safe interface. Equivalent to 'withConfig' the --- 'defaultConfig' +{-| Default expectation safe interface. Equivalent to + + @ + 'with' = withConfig' 'defaultConfig' + @ + +-} with :: (DB -> IO a) -- ^ @action@ continuation. -> IO (Either StartError a) @@ -299,11 +318,11 @@ optionsToDefaultConfig opts@Client.Options {..} = let generated = optionsToConfig opts startingConfig = - if partialPlanCreateDb (configPlan generated) == mempty + if createDbConfig (plan generated) == mempty then defaultConfig else defaultConfig <> mempty - { configPlan = mempty - { partialPlanCreateDb = pure standardProcessConfig + { plan = mempty + { createDbConfig = pure standardProcessConfig } } in startingConfig <> generated diff --git a/src/Database/Postgres/Temp/Internal/Config.hs b/src/Database/Postgres/Temp/Internal/Config.hs new file mode 100644 --- /dev/null +++ b/src/Database/Postgres/Temp/Internal/Config.hs @@ -0,0 +1,917 @@ +{-# OPTIONS_HADDOCK prune #-} +{-| This module provides types and functions for combining partial + configs into a complete configs to ultimately make a 'CompletePlan'. + + This module has two classes of types. + + Types like 'ProcessConfig' that could be used by any + library that needs to combine process options. + + Finally it has types and functions for creating 'CompletePlan's that + use temporary resources. This is used to create the default + behavior of 'Database.Postgres.Temp.startConfig' and related + functions. +|-} +module Database.Postgres.Temp.Internal.Config where + +import Database.Postgres.Temp.Internal.Core + +import Control.Applicative.Lift +import Control.Exception +import Control.Monad (join) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Cont +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import Data.Maybe +import Data.Monoid +import Data.Monoid.Generic +import Data.Typeable +import qualified Database.PostgreSQL.Simple.Options as Client +import GHC.Generics (Generic) +import Network.Socket.Free (getFreePort) +import System.Directory +import System.Environment +import System.IO +import System.IO.Error +import System.IO.Temp (createTempDirectory) +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +prettyMap :: (Pretty a, Pretty b) => Map a b -> Doc +prettyMap theMap = + let xs = Map.toList theMap + in vsep $ map (uncurry prettyKeyPair) xs + +-- | The environment variables can be declared to +-- inherit from the running process or they +-- can be specifically added. +data EnvVars = EnvVars + { inherit :: Last Bool + , specific :: Map String String + } + deriving stock (Generic, Show, Eq) + +instance Semigroup EnvVars where + x <> y = EnvVars + { inherit = + inherit x <> inherit y + , specific = + specific y <> specific x + } + +instance Monoid EnvVars where + mempty = EnvVars mempty mempty + +instance Pretty EnvVars where + pretty EnvVars {..} + = text "inherit:" + <+> pretty (getLast inherit) + <> hardline + <> text "specific:" + <> softline + <> indent 2 (prettyMap specific) + +-- | Combine the current environment +-- (if indicated by 'inherit') +-- with 'specific' +completeEnvVars :: [(String, String)] -> EnvVars -> Either [String] [(String, String)] +completeEnvVars envs EnvVars {..} = case getLast inherit of + Nothing -> Left ["Inherit not specified"] + Just x -> Right $ (if x then envs else []) + <> Map.toList specific + +-- | A type to help combine command line arguments. +data CommandLineArgs = CommandLineArgs + { keyBased :: Map String (Maybe String) + -- ^ Arguments of the form @-h foo@, @--host=foo@ and @--switch@. + -- The key is `mappend`ed with value so the key should include + -- the space or equals (as shown in the first two examples + -- respectively). + -- The 'Dual' monoid is used so the last key wins. + , indexBased :: Map Int String + -- ^ Arguments that appear at the end of the key based + -- arguments. + -- The 'Dual' monoid is used so the last key wins. + } + deriving stock (Generic, Show, Eq) + deriving Monoid via GenericMonoid CommandLineArgs + +instance Semigroup CommandLineArgs where + x <> y = CommandLineArgs + { keyBased = + keyBased y <> keyBased x + , indexBased = + indexBased y <> indexBased x + } + +instance Pretty CommandLineArgs where + pretty p@CommandLineArgs {..} + = text "keyBased:" + <> softline + <> indent 2 (prettyMap keyBased) + <> hardline + <> text "indexBased:" + <> softline + <> indent 2 (prettyMap indexBased) + <> hardline + <> text "completed:" <+> text (unwords (completeCommandLineArgs p)) + +-- Take values as long as the index is the successor of the +-- last index. +takeWhileInSequence :: [(Int, a)] -> [a] +takeWhileInSequence ((0, x):xs) = x : go 0 xs where + go _ [] = [] + go prev ((next, a):rest) + | prev + 1 == next = a : go next rest + | otherwise = [] +takeWhileInSequence _ = [] + +-- | This convert the 'CommandLineArgs' to ' +completeCommandLineArgs :: CommandLineArgs -> [String] +completeCommandLineArgs CommandLineArgs {..} + = map (\(name, mvalue) -> maybe name (name <>) mvalue) + (Map.toList keyBased) + <> takeWhileInSequence (Map.toList indexBased) + +-- | The monoidial version of 'ProcessConfig'. Used to combine overrides with +-- defaults when creating a 'ProcessConfig'. +data ProcessConfig = ProcessConfig + { environmentVariables :: EnvVars + -- ^ A monoid for combine environment variables or replacing them. + -- for the maps the 'Dual' monoid is used. So the last key wins. + , commandLine :: CommandLineArgs + -- ^ A monoid for combine command line arguments or replacing them + , stdIn :: Last Handle + -- ^ A monoid for configuring the standard input 'Handle' + , stdOut :: Last Handle + -- ^ A monoid for configuring the standard output 'Handle' + , stdErr :: Last Handle + -- ^ A monoid for configuring the standard error 'Handle' + } + deriving stock (Generic, Eq, Show) + deriving Semigroup via GenericSemigroup ProcessConfig + deriving Monoid via GenericMonoid ProcessConfig + +prettyHandle :: Handle -> Doc +prettyHandle _ = text "[HANDLE]" + +instance Pretty ProcessConfig where + pretty ProcessConfig {..} + = text "environmentVariables:" + <> softline + <> indent 2 (pretty environmentVariables) + <> hardline + <> text "commandLine:" + <> softline + <> indent 2 (pretty environmentVariables) + <> hardline + <> text "stdIn:" <+> + pretty (prettyHandle <$> getLast stdIn) + <> hardline + <> text "stdOut:" <+> + pretty (prettyHandle <$> getLast stdOut) + <> hardline + <> text "stdErr:" <+> + pretty (prettyHandle <$> getLast stdErr) + + +-- | The 'standardProcessConfig' sets the handles to 'stdin', 'stdout' and +-- 'stderr' and inherits the environment variables from the calling +-- process. +standardProcessConfig :: ProcessConfig +standardProcessConfig = mempty + { environmentVariables = mempty + { inherit = pure True + } + , stdIn = pure stdin + , stdOut = pure stdout + , stdErr = pure stderr + } + +-- A helper to add more info to all the error messages. +addErrorContext :: String -> Either [String] a -> Either [String] a +addErrorContext cxt = either (Left . map (cxt <>)) Right + +-- A helper for creating an error if a 'Last' is not defined. +getOption :: String -> Last a -> Errors [String] a +getOption optionName = \case + Last (Just x) -> pure x + Last Nothing -> failure ["Missing " ++ optionName ++ " option"] + +-- | Turn a 'ProcessConfig' into a 'ProcessConfig'. Fails if +-- any values are missing. +completeProcessConfig + :: [(String, String)] -> ProcessConfig -> Either [String] CompleteProcessConfig +completeProcessConfig envs ProcessConfig {..} = runErrors $ do + let completeProcessConfigCmdLine = completeCommandLineArgs commandLine + completeProcessConfigEnvVars <- eitherToErrors $ + completeEnvVars envs environmentVariables + completeProcessConfigStdIn <- + getOption "stdIn" stdIn + completeProcessConfigStdOut <- + getOption "stdOut" stdOut + completeProcessConfigStdErr <- + getOption "stdErr" stdErr + + pure CompleteProcessConfig {..} + +-- | A type to track whether a file is temporary and needs to be cleaned up. +data CompleteDirectoryType = CPermanent FilePath | CTemporary FilePath + deriving(Show, Eq, Ord) + +-- | Get the file path of a 'CompleteDirectoryType', regardless if it is a +-- 'CPermanent' or 'CTemporary' type. +toFilePath :: CompleteDirectoryType -> FilePath +toFilePath = \case + CPermanent x -> x + CTemporary x -> x + +instance Pretty CompleteDirectoryType where + pretty = \case + CPermanent x -> text "CPermanent" <+> pretty x + CTemporary x -> text "CTemporary" <+> pretty x + +makePermanent :: CompleteDirectoryType -> CompleteDirectoryType +makePermanent = \case + CTemporary x -> CPermanent x + x -> x + +-- | The monoidial version of 'CompleteDirectoryType'. Used to combine overrides with +-- defaults when creating a 'CompleteDirectoryType'. The monoid instance treats +-- 'Temporary' as 'mempty' and takes the last 'Permanent' value. +data DirectoryType + = Permanent FilePath + -- ^ A permanent file that should not be generated. + | Temporary + -- ^ A temporary file that needs to generated. + deriving(Show, Eq, Ord) + +instance Pretty DirectoryType where + pretty = \case + Permanent x -> text "CPermanent" <+> pretty x + Temporary -> text "CTemporary" + +instance Semigroup DirectoryType where + x <> y = case (x, y) of + (a, Temporary ) -> a + (_, a@Permanent {}) -> a + +instance Monoid DirectoryType where + mempty = Temporary + +-- | Either create a'CTemporary' directory or do nothing to a 'CPermanent' +-- one. +setupDirectoryType :: String -> DirectoryType -> IO CompleteDirectoryType +setupDirectoryType p = \case + Temporary -> CTemporary <$> createTempDirectory "/tmp" p + Permanent x -> pure $ CPermanent x + +-- Either create a temporary directory or do nothing +rmDirIgnoreErrors :: FilePath -> IO () +rmDirIgnoreErrors mainDir = do + let ignoreDirIsMissing e + | isDoesNotExistError e = return () + | otherwise = throwIO e + removeDirectoryRecursive mainDir `catch` ignoreDirIsMissing + +-- | Either remove a 'CTemporary' directory or do nothing to a 'CPermanent' +-- one. +cleanupDirectoryType :: CompleteDirectoryType -> IO () +cleanupDirectoryType = \case + CPermanent _ -> pure () + CTemporary filePath -> rmDirIgnoreErrors filePath + +-- | A type for configuring the listening address of the @postgres@ process. +-- @postgres@ can listen on several types of sockets simulatanously but we +-- don't support that behavior. One can either listen on a IP based socket +-- or a UNIX domain socket. +data CompleteSocketClass + = CIpSocket String + -- ^ IP socket type. The 'String' is either an IP address or + -- a host that will resolve to an IP address. + | CUnixSocket CompleteDirectoryType + -- ^ UNIX domain socket + deriving (Show, Eq, Ord, Generic, Typeable) + +instance Pretty CompleteSocketClass where + pretty = \case + CIpSocket x -> text "CIpSocket:" <+> pretty x + CUnixSocket x -> text "CUnixSocket:" <+> pretty x + +-- | Create the extra config lines for listening based on the 'CompleteSocketClass' +socketClassToConfig :: CompleteSocketClass -> [String] +socketClassToConfig = \case + CIpSocket ip -> ["listen_addresses = '" <> ip <> "'"] + CUnixSocket dir -> + [ "listen_addresses = ''" + , "unix_socket_directories = '" <> toFilePath dir <> "'" + ] + +-- | Many processes require a \"host\" flag. We can generate one from the +-- 'CompleteSocketClass'. +socketClassToHostFlag :: CompleteSocketClass -> [(String, Maybe String)] +socketClassToHostFlag x = [("-h", Just (socketClassToHost x))] + +-- | Get the IP address, host name or UNIX domain socket directory +-- as a 'String' +socketClassToHost :: CompleteSocketClass -> String +socketClassToHost = \case + CIpSocket ip -> ip + CUnixSocket dir -> toFilePath dir + +-- | The monoidial version of 'CompleteSocketClass'. Used to combine overrides with +-- defaults when creating a 'CompleteSocketClass'. The monoid instance treats +-- 'UnixSocket mempty' as 'mempty' and combines the +data SocketClass + = IpSocket (Last String) + -- ^ The monoid for combining IP address configuration + | UnixSocket DirectoryType + -- ^ The monoid for combining UNIX socket configuration + deriving stock (Show, Eq, Ord, Generic, Typeable) + +instance Pretty SocketClass where + pretty = \case + IpSocket x -> "CIpSocket:" <+> pretty (getLast x) + UnixSocket x -> "CUnixSocket" <+> pretty x + +instance Semigroup SocketClass where + x <> y = case (x, y) of + (IpSocket a, IpSocket b) -> IpSocket $ a <> b + (a@(IpSocket _), UnixSocket _) -> a + (UnixSocket _, a@(IpSocket _)) -> a + (UnixSocket a, UnixSocket b) -> UnixSocket $ a <> b + +instance Monoid SocketClass where + mempty = UnixSocket mempty + +-- | Turn a 'SocketClass' to a 'CompleteSocketClass'. If the 'IpSocket' is +-- 'Nothing' default to \"127.0.0.1\". If the is a 'UnixSocket' +-- optionally create a temporary directory if configured to do so. +setupSocketClass :: SocketClass -> IO CompleteSocketClass +setupSocketClass theClass = case theClass of + IpSocket mIp -> pure $ CIpSocket $ fromMaybe "127.0.0.1" $ + getLast mIp + UnixSocket mFilePath -> + CUnixSocket <$> setupDirectoryType "tmp-postgres-socket" mFilePath + +-- | Cleanup the UNIX socket temporary directory if one was created. +cleanupSocketConfig :: CompleteSocketClass -> IO () +cleanupSocketConfig = \case + CIpSocket {} -> pure () + CUnixSocket dir -> cleanupDirectoryType dir + +-- | @postgres@ process config and corresponding client connection +-- 'Client.Options'. +data PostgresPlan = PostgresPlan + { postgresConfig :: ProcessConfig + -- ^ Monoid for the @postgres@ ProcessConfig. + , connectionOptions :: Client.Options + -- ^ Monoid for the @postgres@ client connection options. + } + deriving stock (Generic) + deriving Semigroup via GenericSemigroup PostgresPlan + deriving Monoid via GenericMonoid PostgresPlan + +instance Pretty PostgresPlan where + pretty PostgresPlan {..} + = text "postgresConfig:" + <> softline + <> indent 2 (pretty postgresConfig) + <> hardline + <> text "connectionOptions:" + <> softline + <> indent 2 (prettyOptions connectionOptions) + +-- | Turn a 'PostgresPlan' into a 'CompletePostgresPlan'. Fails if any +-- values are missing. +completePostgresPlan :: [(String, String)] -> PostgresPlan -> Either [String] CompletePostgresPlan +completePostgresPlan envs PostgresPlan {..} = runErrors $ do + let completePostgresPlanClientOptions = connectionOptions + completePostgresPlanProcessConfig <- + eitherToErrors $ addErrorContext "postgresConfig: " $ + completeProcessConfig envs postgresConfig + + pure CompletePostgresPlan {..} +------------------------------------------------------------------------------- +-- Plan +------------------------------------------------------------------------------- +-- | The monoidial version of 'CompletePlan'. Used to combine overrides with defaults +-- when creating a plan. +data Plan = Plan + { logger :: Last Logger + , initDbConfig :: Maybe ProcessConfig + , createDbConfig :: Maybe ProcessConfig + , postgresPlan :: PostgresPlan + , postgresConfigFile :: [String] + , dataDirectoryString :: Last String + } + deriving stock (Generic) + deriving Semigroup via GenericSemigroup Plan + deriving Monoid via GenericMonoid Plan + +instance Pretty Plan where + pretty Plan {..} + = text "initDbConfig:" + <> softline + <> indent 2 (pretty initDbConfig) + <> hardline + <> text "initDbConfig:" + <> softline + <> indent 2 (pretty createDbConfig) + <> hardline + <> text "postgresPlan:" + <> softline + <> indent 2 (pretty postgresPlan) + <> hardline + <> text "postgresConfigFile:" + <> softline + <> indent 2 (vsep $ map text postgresConfigFile) + <> hardline + <> text "dataDirectoryString:" <+> pretty (getLast dataDirectoryString) + +-- | Turn a 'Plan' into a 'CompletePlan'. Fails if any values are missing. +completePlan :: [(String, String)] -> Plan -> Either [String] CompletePlan +completePlan envs Plan {..} = runErrors $ do + completePlanLogger <- getOption "logger" logger + completePlanInitDb <- eitherToErrors $ addErrorContext "initDbConfig: " $ + traverse (completeProcessConfig envs) initDbConfig + completePlanCreateDb <- eitherToErrors $ addErrorContext "createDbConfig: " $ + traverse (completeProcessConfig envs) createDbConfig + completePlanPostgres <- eitherToErrors $ addErrorContext "postgresPlan: " $ + completePostgresPlan envs postgresPlan + let completePlanConfig = unlines postgresConfigFile + completePlanDataDirectory <- getOption "dataDirectoryString" + dataDirectoryString + + pure CompletePlan {..} + +-- Returns 'True' if the 'Plan' has a +-- 'Just' 'initDbConfig' +hasInitDb :: Plan -> Bool +hasInitDb Plan {..} = isJust initDbConfig + +-- Returns 'True' if the 'Plan' has a +-- 'Just' 'createDbConfig' +hasCreateDb :: Plan -> Bool +hasCreateDb Plan {..} = isJust createDbConfig + +-- | 'Resources' holds a description of the temporary folders (if there are any) +-- and includes the final 'CompletePlan' that can be used with 'startPlan'. +-- See 'setupConfig' for an example of how to create a 'Resources'. +data Resources = Resources + { resourcesPlan :: CompletePlan + -- ^ Final 'CompletePlan'. See 'startPlan' for information on 'CompletePlan's + , resourcesSocket :: CompleteSocketClass + -- ^ The 'CompleteSocketClass'. Used to track if a temporary directory was made + -- as the socket location. + , resourcesDataDir :: CompleteDirectoryType + -- ^ The data directory. Used to track if a temporary directory was used. + } + +instance Pretty Resources where + pretty Resources {..} + = text "resourcePlan:" + <> softline + <> indent 2 (pretty resourcesPlan) + <> hardline + <> text "resourcesSocket:" + <+> pretty resourcesSocket + <> hardline + <> text "resourcesDataDir:" + <+> pretty resourcesDataDir + +-- | Make the 'resourcesDataDir' 'CPermanent' so it will not +-- get cleaned up. +makeResourcesDataDirPermanent :: Resources -> Resources +makeResourcesDataDirPermanent r = r + { resourcesDataDir = makePermanent $ resourcesDataDir r + } + +-- | The high level options for overriding default behavior. +data Config = Config + { plan :: Plan + -- ^ Extend or replace any of the configuration used to create a final + -- 'CompletePlan' + , socketClass :: SocketClass + -- ^ Override the default 'CompleteSocketClass' by setting this. + , dataDirectory :: DirectoryType + -- ^ Override the default temporary data directory by passing in + -- 'CPermanent DIRECTORY' + , port :: Last (Maybe Int) + -- ^ A monoid for using an existing port (via 'Just' 'PORT_NUMBER') or + -- requesting a free port (via a 'Nothing') + } + deriving stock (Generic) + deriving Semigroup via GenericSemigroup Config + deriving Monoid via GenericMonoid Config + +instance Pretty Config where + pretty Config {..} + = text "plan:" + <> softline + <> pretty plan + <> hardline + <> text "socketClass:" + <> softline + <> pretty socketClass + <> hardline + <> text "dataDirectory:" + <> softline + <> pretty dataDirectory + <> hardline + <> text "port:" <+> pretty (getLast port) + +-- | Create a 'Plan' that sets the command line options of all processes +-- (@initdb@, @postgres@ and @createdb@) using a +toPlan + :: Bool + -- ^ Make @initdb@ options + -> Bool + -- ^ Make @createdb@ options + -> Int + -- ^ port + -> CompleteSocketClass + -- ^ Whether to listen on a IP address or UNIX domain socket + -> FilePath + -- ^ The @postgres@ data directory + -> Plan +toPlan makeInitDb makeCreateDb port socketClass dataDirectoryString = mempty + { postgresConfigFile = socketClassToConfig socketClass + , dataDirectoryString = pure dataDirectoryString + , postgresPlan = mempty + { postgresConfig = mempty + { commandLine = mempty + { keyBased = Map.fromList + [ ("-p", Just $ show port) + , ("-D", Just dataDirectoryString) + ] + } + } + , connectionOptions = mempty + { Client.host = pure $ socketClassToHost socketClass + , Client.port = pure port + , Client.dbname = pure "postgres" + } + } + , createDbConfig = if makeCreateDb + then pure $ mempty + { commandLine = mempty + { keyBased = Map.fromList $ + socketClassToHostFlag socketClass <> + [("-p ", Just $ show port)] + } + } + else Nothing + , initDbConfig = if makeInitDb + then pure $ mempty + { commandLine = mempty + { keyBased = Map.fromList + [("--pgdata=", Just dataDirectoryString)] + } + + } + else Nothing + } + + +-- | Create all the temporary resources from a 'Config'. This also combines the +-- 'Plan' from 'toPlan' with the @extraConfig@ passed in. +setupConfig + :: Config + -- ^ @extraConfig@ to 'mappend' after the default config + -> IO Resources +setupConfig Config {..} = evalContT $ do + envs <- lift getEnvironment + thePort <- lift $ maybe getFreePort pure $ join $ getLast port + resourcesSocket <- ContT $ bracketOnError + (setupSocketClass socketClass) cleanupSocketConfig + resourcesDataDir <- ContT $ bracketOnError + (setupDirectoryType "tmp-postgres-data" dataDirectory) cleanupDirectoryType + let hostAndDir = toPlan + (hasInitDb plan) + (hasCreateDb plan) + thePort + resourcesSocket + (toFilePath resourcesDataDir) + finalPlan = hostAndDir <> plan + resourcesPlan <- lift $ + either (throwIO . CompletePlanFailed (show $ pretty finalPlan)) pure $ + completePlan envs finalPlan + pure Resources {..} + +-- | Free the temporary resources created by 'setupConfig' +cleanupConfig :: Resources -> IO () +cleanupConfig Resources {..} = do + cleanupSocketConfig resourcesSocket + cleanupDirectoryType resourcesDataDir +------------------------------------------------------------------------------- +-- Config Generation +------------------------------------------------------------------------------- +-- | Attempt to create a config from a 'Client.Options'. This is useful if +-- want to create a database owned by a specific user you will also log in as +-- among other use cases. It is possible some 'Client.Options' are not +-- supported so don't hesitate to open an issue on github if you find one. +optionsToConfig :: Client.Options -> Config +optionsToConfig opts@Client.Options {..} + = ( mempty + { plan = optionsToPlan opts + , port = maybe (Last Nothing) (pure . pure) $ getLast port + , socketClass = maybe mempty hostToSocketClass $ getLast host + } + ) +-- Convert the 'Client.Options' to a 'Plan' that can +-- be connected to with the 'Client.Options'. +optionsToPlan :: Client.Options -> Plan +optionsToPlan opts@Client.Options {..} + = maybe mempty dbnameToPlan (getLast dbname) + <> maybe mempty userToPlan (getLast user) + <> clientOptionsToPlan opts + +-- Wrap the 'Client.Options' in an appropiate +-- 'PostgresPlan' +clientOptionsToPlan :: Client.Options -> Plan +clientOptionsToPlan opts = mempty + { postgresPlan = mempty + { connectionOptions = opts + } + } + +-- Create a 'Plan' given a user +userToPlan :: String -> Plan +userToPlan user = mempty + { createDbConfig = pure $ mempty + { commandLine = mempty + { keyBased = Map.singleton "--username=" $ Just user + } + } + , initDbConfig = pure $ mempty + { commandLine = mempty + { keyBased = Map.singleton "--username=" $ Just user + } + } + } + +-- Adds a @createdb@ ProcessPlan with the argument +-- as the database name. +dbnameToPlan :: String -> Plan +dbnameToPlan dbName = mempty + { createDbConfig = pure $ mempty + { commandLine = mempty + { indexBased = Map.singleton 0 dbName + } + } + } + +-- Parse a host string as either an UNIX domain socket directory +-- or a domain or IP. +hostToSocketClass :: String -> SocketClass +hostToSocketClass hostOrSocketPath = case hostOrSocketPath of + '/' : _ -> UnixSocket $ Permanent hostOrSocketPath + _ -> IpSocket $ pure hostOrSocketPath + +------------------------------------------------------------------------------- +-- Lenses +-- Most this code was generated with microlens-th +------------------------------------------------------------------------------- +-- | Local Lens alias +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t +-- | Local Lens' alias +type Lens' s a = Lens s s a a + +-- | Lens for 'inherit' +inheritL :: Lens' EnvVars (Last Bool) +inheritL f_aj5e (EnvVars x_aj5f x_aj5g) + = fmap (`EnvVars` x_aj5g) + (f_aj5e x_aj5f) +{-# INLINE inheritL #-} + +-- | Lens for 'specific' +specificL :: Lens' EnvVars (Map String String) +specificL f_aj5i (EnvVars x_aj5j x_aj5k) + = fmap (EnvVars x_aj5j) + (f_aj5i x_aj5k) +{-# INLINE specificL #-} + +-- | Lens for 'commandLine' +commandLineL :: + Lens' ProcessConfig CommandLineArgs +commandLineL + f_allv + (ProcessConfig x_allw x_allx x_ally x_allz x_allA) + = fmap + (\ y_allB + -> ProcessConfig x_allw y_allB x_ally x_allz + x_allA) + (f_allv x_allx) +{-# INLINE commandLineL #-} + +-- | Lens for 'environmentVariables' +environmentVariablesL :: + Lens' ProcessConfig EnvVars +environmentVariablesL + f_allC + (ProcessConfig x_allD x_allE x_allF x_allG x_allH) + = fmap + (\ y_allI + -> ProcessConfig y_allI x_allE x_allF x_allG + x_allH) + (f_allC x_allD) +{-# INLINE environmentVariablesL #-} + +-- | Lens for 'stdErr' +stdErrL :: + Lens' ProcessConfig (Last Handle) +stdErrL + f_allJ + (ProcessConfig x_allK x_allL x_allM x_allN x_allO) + = fmap + (ProcessConfig x_allK x_allL x_allM x_allN) + (f_allJ x_allO) +{-# INLINE stdErrL #-} + +-- | Lens for 'stdIn' +stdInL :: + Lens' ProcessConfig (Last Handle) +stdInL + f_allQ + (ProcessConfig x_allR x_allS x_allT x_allU x_allV) + = fmap + (\ y_allW + -> ProcessConfig x_allR x_allS y_allW x_allU + x_allV) + (f_allQ x_allT) +{-# INLINE stdInL #-} + +-- | Lens for 'stdOut' +stdOutL :: + Lens' ProcessConfig (Last Handle) +stdOutL + f_allX + (ProcessConfig x_allY x_allZ x_alm0 x_alm1 x_alm2) + = fmap + (\ y_alm3 + -> ProcessConfig x_allY x_allZ x_alm0 y_alm3 + x_alm2) + (f_allX x_alm1) +{-# INLINE stdOutL #-} + +-- | Lens for 'connectionOptions' +connectionOptionsL :: + Lens' PostgresPlan Client.Options +connectionOptionsL + f_am1y + (PostgresPlan x_am1z x_am1A) + = fmap (PostgresPlan x_am1z) + (f_am1y x_am1A) +{-# INLINE connectionOptionsL #-} + +-- | Lens for 'postgresConfig' +postgresConfigL :: + Lens' PostgresPlan ProcessConfig +postgresConfigL + f_am1C + (PostgresPlan x_am1D x_am1E) + = fmap (`PostgresPlan` x_am1E) + (f_am1C x_am1D) +{-# INLINE postgresConfigL #-} + +-- | Lens for 'postgresConfigFile' +postgresConfigFileL :: Lens' Plan [String] +postgresConfigFileL + f_amcw + (Plan x_amcx x_amcy x_amcz x_amcA x_amcB x_amcC) + = fmap + (\ y_amcD + -> Plan x_amcx x_amcy x_amcz x_amcA y_amcD + x_amcC) + (f_amcw x_amcB) +{-# INLINE postgresConfigFileL #-} + +-- | Lens for 'createDbConfig' +createDbConfigL :: + Lens' Plan (Maybe ProcessConfig) +createDbConfigL + f_amcE + (Plan x_amcF x_amcG x_amcH x_amcI x_amcJ x_amcK) + = fmap + (\ y_amcL + -> Plan x_amcF x_amcG y_amcL x_amcI x_amcJ + x_amcK) + (f_amcE x_amcH) +{-# INLINE createDbConfigL #-} + +-- | Lens for 'dataDirectoryString' +dataDirectoryStringL :: Lens' Plan (Last String) +dataDirectoryStringL + f_amcM + (Plan x_amcN x_amcO x_amcP x_amcQ x_amcR x_amcS) + = fmap + (Plan x_amcN x_amcO x_amcP x_amcQ x_amcR) + (f_amcM x_amcS) +{-# INLINE dataDirectoryStringL #-} + +-- | Lens for 'initDbConfig' +initDbConfigL :: + Lens' Plan (Maybe ProcessConfig) +initDbConfigL + f_amcU + (Plan x_amcV x_amcW x_amcX x_amcY x_amcZ x_amd0) + = fmap + (\ y_amd1 + -> Plan x_amcV y_amd1 x_amcX x_amcY x_amcZ + x_amd0) + (f_amcU x_amcW) +{-# INLINE initDbConfigL #-} + +-- | Lens for 'logger' +partialPlanLoggerL :: Lens' Plan (Last Logger) +partialPlanLoggerL + f_amd2 + (Plan x_amd3 x_amd4 x_amd5 x_amd6 x_amd7 x_amd8) + = fmap + (\ y_amd9 + -> Plan y_amd9 x_amd4 x_amd5 x_amd6 x_amd7 + x_amd8) + (f_amd2 x_amd3) +{-# INLINE partialPlanLoggerL #-} + +-- | Lens for 'postgresPlan' +postgresPlanL :: Lens' Plan PostgresPlan +postgresPlanL + f_amda + (Plan x_amdb x_amdc x_amdd x_amde x_amdf x_amdg) + = fmap + (\ y_amdh + -> Plan x_amdb x_amdc x_amdd y_amdh x_amdf + x_amdg) + (f_amda x_amde) +{-# INLINE postgresPlanL #-} + +-- | Lens for 'resourcesDataDir' +resourcesDataDirL :: Lens' Resources CompleteDirectoryType +resourcesDataDirL f_ampd (Resources x_ampe x_ampf x_ampg) + = fmap (Resources x_ampe x_ampf) + (f_ampd x_ampg) +{-# INLINE resourcesDataDirL #-} + +-- | Lens for 'resourcesPlan' +resourcesPlanL :: Lens' Resources CompletePlan +resourcesPlanL f_ampi (Resources x_ampj x_ampk x_ampl) + = fmap (\ y_ampm -> Resources y_ampm x_ampk x_ampl) + (f_ampi x_ampj) +{-# INLINE resourcesPlanL #-} + +-- | Lens for 'resourcesSocket' +resourcesSocketL :: Lens' Resources CompleteSocketClass +resourcesSocketL f_ampn (Resources x_ampo x_ampp x_ampq) + = fmap (\ y_ampr -> Resources x_ampo y_ampr x_ampq) + (f_ampn x_ampp) +{-# INLINE resourcesSocketL #-} + +-- | Lens for 'dataDirectory' +dataDirectoryL :: Lens' Config DirectoryType +dataDirectoryL f_amyD (Config x_amyE x_amyF x_amyG x_amyH) + = fmap (\ y_amyI -> Config x_amyE x_amyF y_amyI x_amyH) + (f_amyD x_amyG) +{-# INLINE dataDirectoryL #-} + +-- | Lens for 'plan' +planL :: Lens' Config Plan +planL f_amyJ (Config x_amyK x_amyL x_amyM x_amyN) + = fmap (\ y_amyO -> Config y_amyO x_amyL x_amyM x_amyN) + (f_amyJ x_amyK) +{-# INLINE planL #-} + +-- | Lens for 'port' +configPortL :: Lens' Config (Last (Maybe Int)) +configPortL f_amyP (Config x_amyQ x_amyR x_amyS x_amyT) + = fmap (Config x_amyQ x_amyR x_amyS) + (f_amyP x_amyT) +{-# INLINE configPortL #-} + +-- | Lens for 'socketClass' +socketClassL :: Lens' Config SocketClass +socketClassL f_amyV (Config x_amyW x_amyX x_amyY x_amyZ) + = fmap (\ y_amz0 -> Config x_amyW y_amz0 x_amyY x_amyZ) + (f_amyV x_amyX) +{-# INLINE socketClassL #-} + +-- | Lens for 'indexBased' +indexBasedL :: + Lens' CommandLineArgs (Map Int String) +indexBasedL + f_amNr + (CommandLineArgs x_amNs x_amNt) + = fmap (CommandLineArgs x_amNs) + (f_amNr x_amNt) +{-# INLINE indexBasedL #-} + +-- | Lens for 'keyBased' +keyBasedL :: + Lens' CommandLineArgs (Map String (Maybe String)) +keyBasedL + f_amNv + (CommandLineArgs x_amNw x_amNx) + = fmap (`CommandLineArgs` x_amNx) + (f_amNv x_amNw) +{-# INLINE keyBasedL #-} 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 @@ -26,10 +26,19 @@ -- | Internal events for debugging data Event - = StartPostgres + = StartPlan String + -- ^ The first event. This useful for debugging + -- what is actual passed to the @initdb@, @createdb@ and + -- @postgres@. + | StartPostgres + -- ^ The second event. Postgres is about to get called | WaitForDB - | StartPlan String + -- ^ The third event. Postgres started. We are not about to + -- setup a reconnect loop (racing with a process checker) | TryToConnect + -- ^ The fourth event and (possibly all subsequent events). + -- We are looping trying to successfully connect to the @postgres@ + -- process. deriving (Show, Eq, Ord) -- | A list of failures that can occur when starting. This is not @@ -46,7 +55,7 @@ -- ^ @createdb@ failed. This can be from invalid configuration or -- the database might already exist. | CompletePlanFailed String [String] - -- ^ The 'Database.Postgres.Temp.Partial.PartialPlan' was missing info and a complete 'Plan' could + -- ^ The 'Database.Postgres.Temp.Config.Plan' was missing info and a complete 'CompletePlan' could -- not be created. deriving (Show, Eq, Ord, Typeable) @@ -70,45 +79,45 @@ -- | 'ProcessConfig' contains the configuration necessary for starting a -- process. It is essentially a stripped down 'System.Process.CreateProcess'. -data ProcessConfig = ProcessConfig - { processConfigEnvVars :: [(String, String)] +data CompleteProcessConfig = CompleteProcessConfig + { completeProcessConfigEnvVars :: [(String, String)] -- ^ Environment variables - , processConfigCmdLine :: [String] + , completeProcessConfigCmdLine :: [String] -- ^ Command line arguements - , processConfigStdIn :: Handle + , completeProcessConfigStdIn :: Handle -- ^ The 'Handle' for standard input - , processConfigStdOut :: Handle + , completeProcessConfigStdOut :: Handle -- ^ The 'Handle' for standard output - , processConfigStdErr :: Handle + , completeProcessConfigStdErr :: Handle -- ^ The 'Handle' for standard error } prettyKeyPair ::(Pretty a, Pretty b) => a -> b -> Doc prettyKeyPair k v = pretty k <> text ": " <> pretty v -instance Pretty ProcessConfig where - pretty ProcessConfig {..} - = text "processConfigEnvVars:" +instance Pretty CompleteProcessConfig where + pretty CompleteProcessConfig {..} + = text "completeProcessConfigEnvVars:" <> softline - <> indent 2 (vsep (map (uncurry prettyKeyPair) processConfigEnvVars)) + <> indent 2 (vsep (map (uncurry prettyKeyPair) completeProcessConfigEnvVars)) <> hardline - <> text "processConfigCmdLine:" + <> text "completeProcessConfigCmdLine:" <> softline - <> text (unwords processConfigCmdLine) + <> text (unwords completeProcessConfigCmdLine) -- | Start a process interactively and return the 'ProcessHandle' startProcess :: String -- ^ Process name - -> ProcessConfig + -> CompleteProcessConfig -- ^ Process config -> IO ProcessHandle -startProcess name ProcessConfig {..} = (\(_, _, _, x) -> x) <$> - createProcess_ name (proc name processConfigCmdLine) - { std_err = UseHandle processConfigStdErr - , std_out = UseHandle processConfigStdOut - , std_in = UseHandle processConfigStdIn - , env = Just processConfigEnvVars +startProcess name CompleteProcessConfig {..} = (\(_, _, _, x) -> x) <$> + createProcess_ name (proc name completeProcessConfigCmdLine) + { std_err = UseHandle completeProcessConfigStdErr + , std_out = UseHandle completeProcessConfigStdOut + , std_in = UseHandle completeProcessConfigStdIn + , env = Just completeProcessConfigEnvVars } -- | Stop a 'ProcessHandle'. An alias for 'waitForProcess' @@ -119,30 +128,30 @@ executeProcess :: String -- ^ Process name - -> ProcessConfig + -> CompleteProcessConfig -- ^ Process config -> IO ExitCode executeProcess name = startProcess name >=> waitForProcess ------------------------------------------------------------------------------- -- PostgresProcess Life cycle management ------------------------------------------------------------------------------- --- | 'PostgresPlan' is used be 'startPostgresProcess' to start the @postgres@ +-- | 'CompletePostgresPlan' is used be 'startPostgresProcess' to start the @postgres@ -- and then attempt to connect to it. -data PostgresPlan = PostgresPlan - { postgresPlanProcessConfig :: ProcessConfig +data CompletePostgresPlan = CompletePostgresPlan + { completePostgresPlanProcessConfig :: CompleteProcessConfig -- ^ The process config for @postgres@ - , postgresPlanClientOptions :: Client.Options + , completePostgresPlanClientOptions :: Client.Options -- ^ Connection options. Used to verify that @postgres@ is ready. } -instance Pretty PostgresPlan where - pretty PostgresPlan {..} - = text "postgresPlanProcessConfig:" +instance Pretty CompletePostgresPlan where + pretty CompletePostgresPlan {..} + = text "completePostgresPlanProcessConfig:" <> softline - <> indent 2 (pretty postgresPlanProcessConfig) + <> indent 2 (pretty completePostgresPlanProcessConfig) <> hardline - <> text "postgresPlanClientOptions:" - <+> prettyOptions postgresPlanClientOptions + <> text "completePostgresPlanClientOptions:" + <+> prettyOptions completePostgresPlanClientOptions prettyOptions :: Client.Options -> Doc prettyOptions = text . BSC.unpack . Client.toConnectionString @@ -196,12 +205,12 @@ -- | Start the @postgres@ process and block until a successful connection -- occurs. A separate thread we continously check to see if the @postgres@ -- process has crashed. -startPostgresProcess :: Logger -> PostgresPlan -> IO PostgresProcess -startPostgresProcess logger PostgresPlan {..} = do +startPostgresProcess :: Logger -> CompletePostgresPlan -> IO PostgresProcess +startPostgresProcess logger CompletePostgresPlan {..} = do logger StartPostgres - let startAction = PostgresProcess postgresPlanClientOptions - <$> startProcess "postgres" postgresPlanProcessConfig + let startAction = PostgresProcess completePostgresPlanClientOptions + <$> startProcess "postgres" completePostgresPlanProcessConfig -- Start postgres and stop if an exception occurs bracketOnError startAction stopPostgresProcess $ @@ -214,7 +223,7 @@ logger WaitForDB -- We assume that 'template1' exist and make connection -- options to test if postgres is ready. - let options = postgresPlanClientOptions + let options = completePostgresPlanClientOptions { Client.dbname = pure "template1" } @@ -225,43 +234,43 @@ -- Postgres is now ready so return return result ------------------------------------------------------------------------------- --- Plan +-- CompletePlan ------------------------------------------------------------------------------- --- | 'Plan' is the low level configuration necessary for creating a database +-- | 'CompletePlan' is the low level configuration necessary for creating a database -- starting @postgres@ and creating a database. There is no validation done --- on the 'Plan'. It is recommend that one use the higher level functions +-- on the 'CompletePlan'. It is recommend that one use the higher level functions -- such as 'Database.Postgres.Temp.start' which will generate plans that --- are valid. 'Plan's are used internally but are exposed if the higher +-- are valid. 'CompletePlan's are used internally but are exposed if the higher -- level plan generation is not sufficent. -data Plan = Plan - { planLogger :: Logger - , planInitDb :: Maybe ProcessConfig - , planCreateDb :: Maybe ProcessConfig - , planPostgres :: PostgresPlan - , planConfig :: String - , planDataDirectory :: FilePath +data CompletePlan = CompletePlan + { completePlanLogger :: Logger + , completePlanInitDb :: Maybe CompleteProcessConfig + , completePlanCreateDb :: Maybe CompleteProcessConfig + , completePlanPostgres :: CompletePostgresPlan + , completePlanConfig :: String + , completePlanDataDirectory :: FilePath } -instance Pretty Plan where - pretty Plan {..} - = text "planInitDb:" +instance Pretty CompletePlan where + pretty CompletePlan {..} + = text "completePlanInitDb:" <> softline - <> indent 2 (pretty planInitDb) + <> indent 2 (pretty completePlanInitDb) <> hardline - <> text "planCreateDb:" + <> text "completePlanCreateDb:" <> softline - <> indent 2 (pretty planCreateDb) + <> indent 2 (pretty completePlanCreateDb) <> hardline - <> text "planPostgres:" + <> text "completePlanPostgres:" <> softline - <> indent 2 (pretty planPostgres) + <> indent 2 (pretty completePlanPostgres) <> hardline - <> text "planConfig:" + <> text "completePlanConfig:" <> softline - <> indent 2 (pretty planConfig) + <> indent 2 (pretty completePlanConfig) <> hardline - <> text "planDataDirectory:" - <+> pretty planDataDirectory + <> text "completePlanDataDirectory:" + <+> pretty completePlanDataDirectory -- A simple helper to throw 'ExitCode's when they are 'ExitFailure'. throwIfNotSuccess :: Exception e => (ExitCode -> e) -> ExitCode -> IO () @@ -274,19 +283,19 @@ -- Additionally it writes a \"postgresql.conf\" and does not return until -- the @postgres@ process is ready. See 'startPostgresProcess' for more -- details. -startPlan :: Plan -> IO PostgresProcess -startPlan plan@Plan {..} = do - planLogger $ StartPlan $ show $ pretty plan - for_ planInitDb $ executeProcess "initdb" >=> +startPlan :: CompletePlan -> IO PostgresProcess +startPlan plan@CompletePlan {..} = do + completePlanLogger $ StartPlan $ show $ pretty plan + for_ completePlanInitDb $ executeProcess "initdb" >=> throwIfNotSuccess InitDbFailed -- We must provide a config file before we can start postgres. - writeFile (planDataDirectory <> "/postgresql.conf") planConfig + writeFile (completePlanDataDirectory <> "/postgresql.conf") completePlanConfig - let startAction = startPostgresProcess planLogger planPostgres + let startAction = startPostgresProcess completePlanLogger completePlanPostgres bracketOnError startAction stopPostgresProcess $ \result -> do - for_ planCreateDb $ executeProcess "createdb" >=> + for_ completePlanCreateDb $ executeProcess "createdb" >=> throwIfNotSuccess CreateDbFailed pure result diff --git a/src/Database/Postgres/Temp/Internal/Partial.hs b/src/Database/Postgres/Temp/Internal/Partial.hs deleted file mode 100644 --- a/src/Database/Postgres/Temp/Internal/Partial.hs +++ /dev/null @@ -1,921 +0,0 @@ -{-# OPTIONS_HADDOCK prune #-} -{-| This module provides types and functions for combining partial - configs into a complete configs to ultimately make a 'Plan'. - - This module has two classes of types. - - Types like 'PartialProcessConfig' that could be used by any - library that needs to combine process options. - - Finally it has types and functions for creating 'Plan's that - use temporary resources. This is used to create the default - behavior of 'Database.Postgres.Temp.startConfig' and related - functions. -|-} -module Database.Postgres.Temp.Internal.Partial where - -import Database.Postgres.Temp.Internal.Core - -import Control.Applicative.Lift -import Control.Exception -import Control.Monad (join) -import Control.Monad.Trans.Class -import Control.Monad.Trans.Cont -import qualified Data.Map.Strict as Map -import Data.Map.Strict (Map) -import Data.Maybe -import Data.Monoid -import Data.Monoid.Generic -import Data.Typeable -import qualified Database.PostgreSQL.Simple.Options as Client -import GHC.Generics (Generic) -import Network.Socket.Free (getFreePort) -import System.Directory -import System.Environment -import System.IO -import System.IO.Error -import System.IO.Temp (createTempDirectory) -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) - -prettyMap :: (Pretty a, Pretty b) => Map a b -> Doc -prettyMap theMap = - let xs = Map.toList theMap - in vsep $ map (uncurry prettyKeyPair) xs - --- | The environment variables can be declared to --- inherit from the running process or they --- can be specifically added. -data PartialEnvVars = PartialEnvVars - { partialEnvVarsInherit :: Last Bool - , partialEnvVarsSpecific :: Map String String - } - deriving stock (Generic, Show, Eq) - -instance Semigroup PartialEnvVars where - x <> y = PartialEnvVars - { partialEnvVarsInherit = - partialEnvVarsInherit x <> partialEnvVarsInherit y - , partialEnvVarsSpecific = - partialEnvVarsSpecific y <> partialEnvVarsSpecific x - } - -instance Monoid PartialEnvVars where - mempty = PartialEnvVars mempty mempty - -instance Pretty PartialEnvVars where - pretty PartialEnvVars {..} - = text "partialEnvVarsInherit:" - <+> pretty (getLast partialEnvVarsInherit) - <> hardline - <> text "partialEnvVarsSpecific:" - <> softline - <> indent 2 (prettyMap partialEnvVarsSpecific) - --- | Combine the current environment --- (if indicated by 'partialEnvVarsInherit') --- with 'partialEnvVarsSpecific' -completePartialEnvVars :: [(String, String)] -> PartialEnvVars -> Either [String] [(String, String)] -completePartialEnvVars envs PartialEnvVars {..} = case getLast partialEnvVarsInherit of - Nothing -> Left ["Inherit not specified"] - Just x -> Right $ (if x then envs else []) - <> Map.toList partialEnvVarsSpecific - --- | A type to help combine command line arguments. -data PartialCommandLineArgs = PartialCommandLineArgs - { partialCommandLineArgsKeyBased :: Map String (Maybe String) - -- ^ Arguments of the form @-h foo@, @--host=foo@ and @--switch@. - -- The key is `mappend`ed with value so the key should include - -- the space or equals (as shown in the first two examples - -- respectively). - -- The 'Dual' monoid is used so the last key wins. - , partialCommandLineArgsIndexBased :: Map Int String - -- ^ Arguments that appear at the end of the key based - -- arguments. - -- The 'Dual' monoid is used so the last key wins. - } - deriving stock (Generic, Show, Eq) - deriving Monoid via GenericMonoid PartialCommandLineArgs - -instance Semigroup PartialCommandLineArgs where - x <> y = PartialCommandLineArgs - { partialCommandLineArgsKeyBased = - partialCommandLineArgsKeyBased y <> partialCommandLineArgsKeyBased x - , partialCommandLineArgsIndexBased = - partialCommandLineArgsIndexBased y <> partialCommandLineArgsIndexBased x - } - -instance Pretty PartialCommandLineArgs where - pretty p@PartialCommandLineArgs {..} - = text "partialCommandLineArgsKeyBased:" - <> softline - <> indent 2 (prettyMap partialCommandLineArgsKeyBased) - <> hardline - <> text "partialCommandLineArgsIndexBased:" - <> softline - <> indent 2 (prettyMap partialCommandLineArgsIndexBased) - <> hardline - <> text "completed:" <+> text (unwords (completeCommandLineArgs p)) - --- Take values as long as the index is the successor of the --- last index. -takeWhileInSequence :: [(Int, a)] -> [a] -takeWhileInSequence ((0, x):xs) = x : go 0 xs where - go _ [] = [] - go prev ((next, a):rest) - | prev + 1 == next = a : go next rest - | otherwise = [] -takeWhileInSequence _ = [] - --- | This convert the 'PartialCommandLineArgs' to ' -completeCommandLineArgs :: PartialCommandLineArgs -> [String] -completeCommandLineArgs PartialCommandLineArgs {..} - = map (\(name, mvalue) -> maybe name (name <>) mvalue) - (Map.toList partialCommandLineArgsKeyBased) - <> takeWhileInSequence (Map.toList partialCommandLineArgsIndexBased) - --- | The monoidial version of 'ProcessConfig'. Used to combine overrides with --- defaults when creating a 'ProcessConfig'. -data PartialProcessConfig = PartialProcessConfig - { partialProcessConfigEnvVars :: PartialEnvVars - -- ^ A monoid for combine environment variables or replacing them. - -- for the maps the 'Dual' monoid is used. So the last key wins. - , partialProcessConfigCmdLine :: PartialCommandLineArgs - -- ^ A monoid for combine command line arguments or replacing them - , partialProcessConfigStdIn :: Last Handle - -- ^ A monoid for configuring the standard input 'Handle' - , partialProcessConfigStdOut :: Last Handle - -- ^ A monoid for configuring the standard output 'Handle' - , partialProcessConfigStdErr :: Last Handle - -- ^ A monoid for configuring the standard error 'Handle' - } - deriving stock (Generic, Eq, Show) - deriving Semigroup via GenericSemigroup PartialProcessConfig - deriving Monoid via GenericMonoid PartialProcessConfig - -prettyHandle :: Handle -> Doc -prettyHandle _ = text "[HANDLE]" - -instance Pretty PartialProcessConfig where - pretty PartialProcessConfig {..} - = text "partialProcessConfigEnvVars:" - <> softline - <> indent 2 (pretty partialProcessConfigEnvVars) - <> hardline - <> text "partialProcessConfigCmdLine:" - <> softline - <> indent 2 (pretty partialProcessConfigEnvVars) - <> hardline - <> text "partialProcessConfigStdIn:" <+> - pretty (prettyHandle <$> getLast partialProcessConfigStdIn) - <> hardline - <> text "partialProcessConfigStdOut:" <+> - pretty (prettyHandle <$> getLast partialProcessConfigStdOut) - <> hardline - <> text "partialProcessConfigStdErr:" <+> - pretty (prettyHandle <$> getLast partialProcessConfigStdErr) - - --- | The 'standardProcessConfig' sets the handles to 'stdin', 'stdout' and --- 'stderr' and inherits the environment variables from the calling --- process. -standardProcessConfig :: PartialProcessConfig -standardProcessConfig = mempty - { partialProcessConfigEnvVars = mempty - { partialEnvVarsInherit = pure True - } - , partialProcessConfigStdIn = pure stdin - , partialProcessConfigStdOut = pure stdout - , partialProcessConfigStdErr = pure stderr - } - --- A helper to add more info to all the error messages. -addErrorContext :: String -> Either [String] a -> Either [String] a -addErrorContext cxt = either (Left . map (cxt <>)) Right - --- A helper for creating an error if a 'Last' is not defined. -getOption :: String -> Last a -> Errors [String] a -getOption optionName = \case - Last (Just x) -> pure x - Last Nothing -> failure ["Missing " ++ optionName ++ " option"] - --- | Turn a 'PartialProcessConfig' into a 'ProcessConfig'. Fails if --- any values are missing. -completeProcessConfig - :: [(String, String)] -> PartialProcessConfig -> Either [String] ProcessConfig -completeProcessConfig envs PartialProcessConfig {..} = runErrors $ do - let processConfigCmdLine = completeCommandLineArgs partialProcessConfigCmdLine - processConfigEnvVars <- eitherToErrors $ - completePartialEnvVars envs partialProcessConfigEnvVars - processConfigStdIn <- - getOption "partialProcessConfigStdIn" partialProcessConfigStdIn - processConfigStdOut <- - getOption "partialProcessConfigStdOut" partialProcessConfigStdOut - processConfigStdErr <- - getOption "partialProcessConfigStdErr" partialProcessConfigStdErr - - pure ProcessConfig {..} - --- | A type to track whether a file is temporary and needs to be cleaned up. -data DirectoryType = Permanent FilePath | Temporary FilePath - deriving(Show, Eq, Ord) - --- | Get the file path of a 'DirectoryType', regardless if it is a --- 'Permanent' or 'Temporary' type. -toFilePath :: DirectoryType -> FilePath -toFilePath = \case - Permanent x -> x - Temporary x -> x - -instance Pretty DirectoryType where - pretty = \case - Permanent x -> text "Permanent" <+> pretty x - Temporary x -> text "Temporary" <+> pretty x - -makePermanent :: DirectoryType -> DirectoryType -makePermanent = \case - Temporary x -> Permanent x - x -> x - --- | The monoidial version of 'DirectoryType'. Used to combine overrides with --- defaults when creating a 'DirectoryType'. The monoid instance treats --- 'PTemporary' as 'mempty' and takes the last 'PPermanent' value. -data PartialDirectoryType - = PPermanent FilePath - -- ^ A permanent file that should not be generated. - | PTemporary - -- ^ A temporary file that needs to generated. - deriving(Show, Eq, Ord) - -instance Pretty PartialDirectoryType where - pretty = \case - PPermanent x -> text "Permanent" <+> pretty x - PTemporary -> text "Temporary" - -instance Semigroup PartialDirectoryType where - x <> y = case (x, y) of - (a, PTemporary ) -> a - (_, a@PPermanent {}) -> a - -instance Monoid PartialDirectoryType where - mempty = PTemporary - --- | Either create a'Temporary' directory or do nothing to a 'Permanent' --- one. -setupDirectoryType :: String -> PartialDirectoryType -> IO DirectoryType -setupDirectoryType pattern = \case - PTemporary -> Temporary <$> createTempDirectory "/tmp" pattern - PPermanent x -> pure $ Permanent x - --- Either create a temporary directory or do nothing -rmDirIgnoreErrors :: FilePath -> IO () -rmDirIgnoreErrors mainDir = do - let ignoreDirIsMissing e - | isDoesNotExistError e = return () - | otherwise = throwIO e - removeDirectoryRecursive mainDir `catch` ignoreDirIsMissing - --- | Either remove a 'Temporary' directory or do nothing to a 'Permanent' --- one. -cleanupDirectoryType :: DirectoryType -> IO () -cleanupDirectoryType = \case - Permanent _ -> pure () - Temporary filePath -> rmDirIgnoreErrors filePath - --- | A type for configuring the listening address of the @postgres@ process. --- @postgres@ can listen on several types of sockets simulatanously but we --- don't support that behavior. One can either listen on a IP based socket --- or a UNIX domain socket. -data SocketClass - = IpSocket String - -- ^ IP socket type. The 'String' is either an IP address or - -- a host that will resolve to an IP address. - | UnixSocket DirectoryType - -- ^ UNIX domain socket - deriving (Show, Eq, Ord, Generic, Typeable) - -instance Pretty SocketClass where - pretty = \case - IpSocket x -> text "IpSocket:" <+> pretty x - UnixSocket x -> text "UnixSocket:" <+> pretty x - --- | Create the extra config lines for listening based on the 'SocketClass' -socketClassToConfig :: SocketClass -> [String] -socketClassToConfig = \case - IpSocket ip -> ["listen_addresses = '" <> ip <> "'"] - UnixSocket dir -> - [ "listen_addresses = ''" - , "unix_socket_directories = '" <> toFilePath dir <> "'" - ] - --- | Many processes require a \"host\" flag. We can generate one from the --- 'SocketClass'. -socketClassToHostFlag :: SocketClass -> [(String, Maybe String)] -socketClassToHostFlag x = [("-h", Just (socketClassToHost x))] - --- | Get the IP address, host name or UNIX domain socket directory --- as a 'String' -socketClassToHost :: SocketClass -> String -socketClassToHost = \case - IpSocket ip -> ip - UnixSocket dir -> toFilePath dir - --- | The monoidial version of 'SocketClass'. Used to combine overrides with --- defaults when creating a 'SocketClass'. The monoid instance treats --- 'PUnixSocket mempty' as 'mempty' and combines the -data PartialSocketClass - = PIpSocket (Last String) - -- ^ The monoid for combining IP address configuration - | PUnixSocket PartialDirectoryType - -- ^ The monoid for combining UNIX socket configuration - deriving stock (Show, Eq, Ord, Generic, Typeable) - -instance Pretty PartialSocketClass where - pretty = \case - PIpSocket x -> "IpSocket:" <+> pretty (getLast x) - PUnixSocket x -> "UnixSocket" <+> pretty x - -instance Semigroup PartialSocketClass where - x <> y = case (x, y) of - (PIpSocket a, PIpSocket b) -> PIpSocket $ a <> b - (a@(PIpSocket _), PUnixSocket _) -> a - (PUnixSocket _, a@(PIpSocket _)) -> a - (PUnixSocket a, PUnixSocket b) -> PUnixSocket $ a <> b - -instance Monoid PartialSocketClass where - mempty = PUnixSocket mempty - --- | Turn a 'PartialSocketClass' to a 'SocketClass'. If the 'PIpSocket' is --- 'Nothing' default to \"127.0.0.1\". If the is a 'PUnixSocket' --- optionally create a temporary directory if configured to do so. -setupPartialSocketClass :: PartialSocketClass -> IO SocketClass -setupPartialSocketClass theClass = case theClass of - PIpSocket mIp -> pure $ IpSocket $ fromMaybe "127.0.0.1" $ - getLast mIp - PUnixSocket mFilePath -> - UnixSocket <$> setupDirectoryType "tmp-postgres-socket" mFilePath - --- | Cleanup the UNIX socket temporary directory if one was created. -cleanupSocketConfig :: SocketClass -> IO () -cleanupSocketConfig = \case - IpSocket {} -> pure () - UnixSocket dir -> cleanupDirectoryType dir - --- | @postgres@ process config and corresponding client connection --- 'Client.Options'. -data PartialPostgresPlan = PartialPostgresPlan - { partialPostgresPlanProcessConfig :: PartialProcessConfig - -- ^ Monoid for the @postgres@ ProcessConfig. - , partialPostgresPlanClientConfig :: Client.Options - -- ^ Monoid for the @postgres@ client connection options. - } - deriving stock (Generic) - deriving Semigroup via GenericSemigroup PartialPostgresPlan - deriving Monoid via GenericMonoid PartialPostgresPlan - -instance Pretty PartialPostgresPlan where - pretty PartialPostgresPlan {..} - = text "partialPostgresPlanProcessConfig:" - <> softline - <> indent 2 (pretty partialPostgresPlanProcessConfig) - <> hardline - <> text "partialPostgresPlanClientConfig:" - <> softline - <> indent 2 (prettyOptions partialPostgresPlanClientConfig) - --- | Turn a 'PartialPostgresPlan' into a 'PostgresPlan'. Fails if any --- values are missing. -completePostgresPlan :: [(String, String)] -> PartialPostgresPlan -> Either [String] PostgresPlan -completePostgresPlan envs PartialPostgresPlan {..} = runErrors $ do - let postgresPlanClientOptions = partialPostgresPlanClientConfig - postgresPlanProcessConfig <- - eitherToErrors $ addErrorContext "partialPostgresPlanProcessConfig: " $ - completeProcessConfig envs partialPostgresPlanProcessConfig - - pure PostgresPlan {..} -------------------------------------------------------------------------------- --- PartialPlan -------------------------------------------------------------------------------- --- | The monoidial version of 'Plan'. Used to combine overrides with defaults --- when creating a plan. -data PartialPlan = PartialPlan - { partialPlanLogger :: Last Logger - , partialPlanInitDb :: Maybe PartialProcessConfig - , partialPlanCreateDb :: Maybe PartialProcessConfig - , partialPlanPostgres :: PartialPostgresPlan - , partialPlanConfig :: [String] - , partialPlanDataDirectory :: Last String - } - deriving stock (Generic) - deriving Semigroup via GenericSemigroup PartialPlan - deriving Monoid via GenericMonoid PartialPlan - -instance Pretty PartialPlan where - pretty PartialPlan {..} - = text "partialPlanInitDb:" - <> softline - <> indent 2 (pretty partialPlanInitDb) - <> hardline - <> text "partialPlanInitDb:" - <> softline - <> indent 2 (pretty partialPlanCreateDb) - <> hardline - <> text "partialPlanPostgres:" - <> softline - <> indent 2 (pretty partialPlanPostgres) - <> hardline - <> text "partialPlanConfig:" - <> softline - <> indent 2 (vsep $ map text partialPlanConfig) - <> hardline - <> text "partialPlanDataDirectory:" <+> pretty (getLast partialPlanDataDirectory) - --- | Turn a 'PartialPlan' into a 'Plan'. Fails if any values are missing. -completePlan :: [(String, String)] -> PartialPlan -> Either [String] Plan -completePlan envs PartialPlan {..} = runErrors $ do - planLogger <- getOption "partialPlanLogger" partialPlanLogger - planInitDb <- eitherToErrors $ addErrorContext "partialPlanInitDb: " $ - traverse (completeProcessConfig envs) partialPlanInitDb - planCreateDb <- eitherToErrors $ addErrorContext "partialPlanCreateDb: " $ - traverse (completeProcessConfig envs) partialPlanCreateDb - planPostgres <- eitherToErrors $ addErrorContext "partialPlanPostgres: " $ - completePostgresPlan envs partialPlanPostgres - let planConfig = unlines partialPlanConfig - planDataDirectory <- getOption "partialPlanDataDirectory" - partialPlanDataDirectory - - pure Plan {..} - --- Returns 'True' if the 'PartialPlan' has a --- 'Just' 'partialPlanInitDb' -hasInitDb :: PartialPlan -> Bool -hasInitDb PartialPlan {..} = isJust partialPlanInitDb - --- Returns 'True' if the 'PartialPlan' has a --- 'Just' 'partialPlanCreateDb' -hasCreateDb :: PartialPlan -> Bool -hasCreateDb PartialPlan {..} = isJust partialPlanCreateDb - --- | 'Resources' holds a description of the temporary folders (if there are any) --- and includes the final 'Plan' that can be used with 'startPlan'. --- See 'setupConfig' for an example of how to create a 'Resources'. -data Resources = Resources - { resourcesPlan :: Plan - -- ^ Final 'Plan'. See 'startPlan' for information on 'Plan's - , resourcesSocket :: SocketClass - -- ^ The 'SocketClass'. Used to track if a temporary directory was made - -- as the socket location. - , resourcesDataDir :: DirectoryType - -- ^ The data directory. Used to track if a temporary directory was used. - } - -instance Pretty Resources where - pretty Resources {..} - = text "resourcePlan:" - <> softline - <> indent 2 (pretty resourcesPlan) - <> hardline - <> text "resourcesSocket:" - <+> pretty resourcesSocket - <> hardline - <> text "resourcesDataDir:" - <+> pretty resourcesDataDir - --- | Make the 'resourcesDataDir' 'Permanent' so it will not --- get cleaned up. -makeResourcesDataDirPermanent :: Resources -> Resources -makeResourcesDataDirPermanent r = r - { resourcesDataDir = makePermanent $ resourcesDataDir r - } - --- | The high level options for overriding default behavior. -data Config = Config - { configPlan :: PartialPlan - -- ^ Extend or replace any of the configuration used to create a final - -- 'Plan' - , configSocket :: PartialSocketClass - -- ^ Override the default 'SocketClass' by setting this. - , configDataDir :: PartialDirectoryType - -- ^ Override the default temporary data directory by passing in - -- 'Permanent DIRECTORY' - , configPort :: Last (Maybe Int) - -- ^ A monoid for using an existing port (via 'Just PORT_NUMBER') or - -- requesting a free port (via a 'Nothing') - } - deriving stock (Generic) - deriving Semigroup via GenericSemigroup Config - deriving Monoid via GenericMonoid Config - -instance Pretty Config where - pretty Config {..} - = text "configPlan:" - <> softline - <> pretty configPlan - <> hardline - <> text "configSocket:" - <> softline - <> pretty configSocket - <> hardline - <> text "configDataDir:" - <> softline - <> pretty configDataDir - <> hardline - <> text "configPort:" <+> pretty (getLast configPort) - --- | Create a 'PartialPlan' that sets the command line options of all processes --- (@initdb@, @postgres@ and @createdb@) using a -toPlan - :: Bool - -- ^ Make @initdb@ options - -> Bool - -- ^ Make @createdb@ options - -> Int - -- ^ port - -> SocketClass - -- ^ Whether to listen on a IP address or UNIX domain socket - -> FilePath - -- ^ The @postgres@ data directory - -> PartialPlan -toPlan makeInitDb makeCreateDb port socketClass dataDirectory = mempty - { partialPlanConfig = socketClassToConfig socketClass - , partialPlanDataDirectory = pure dataDirectory - , partialPlanPostgres = mempty - { partialPostgresPlanProcessConfig = mempty - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsKeyBased = Map.fromList - [ ("-p", Just $ show port) - , ("-D", Just dataDirectory) - ] - } - } - , partialPostgresPlanClientConfig = mempty - { Client.host = pure $ socketClassToHost socketClass - , Client.port = pure port - , Client.dbname = pure "postgres" - } - } - , partialPlanCreateDb = if makeCreateDb - then pure $ mempty - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsKeyBased = Map.fromList $ - socketClassToHostFlag socketClass <> - [("-p ", Just $ show port)] - } - } - else Nothing - , partialPlanInitDb = if makeInitDb - then pure $ mempty - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsKeyBased = Map.fromList $ - [("--pgdata=", Just dataDirectory)] - } - - } - else Nothing - } - - --- | Create all the temporary resources from a 'Config'. This also combines the --- 'PartialPlan' from 'toPlan' with the @extraConfig@ passed in. -setupConfig - :: Config - -- ^ @extraConfig@ to 'mappend' after the default config - -> IO Resources -setupConfig Config {..} = evalContT $ do - envs <- lift getEnvironment - port <- lift $ maybe getFreePort pure $ join $ getLast configPort - resourcesSocket <- ContT $ bracketOnError - (setupPartialSocketClass configSocket) cleanupSocketConfig - resourcesDataDir <- ContT $ bracketOnError - (setupDirectoryType "tmp-postgres-data" configDataDir) cleanupDirectoryType - let hostAndDirPartial = toPlan - (hasInitDb configPlan) - (hasCreateDb configPlan) - port - resourcesSocket - (toFilePath resourcesDataDir) - finalPlan = hostAndDirPartial <> configPlan - resourcesPlan <- lift $ - either (throwIO . CompletePlanFailed (show $ pretty finalPlan)) pure $ - completePlan envs finalPlan - pure Resources {..} - --- | Free the temporary resources created by 'setupConfig' -cleanupConfig :: Resources -> IO () -cleanupConfig Resources {..} = do - cleanupSocketConfig resourcesSocket - cleanupDirectoryType resourcesDataDir -------------------------------------------------------------------------------- --- Config Generation -------------------------------------------------------------------------------- --- | Attempt to create a config from a 'Client.Options'. This is useful if --- want to create a database owned by a specific user you will also log in as --- among other use cases. It is possible some 'Client.Options' are not --- supported so don't hesitate to open an issue on github if you find one. -optionsToConfig :: Client.Options -> Config -optionsToConfig opts@Client.Options {..} - = ( mempty - { configPlan = optionsToPlan opts - , configPort = maybe (Last Nothing) (pure . pure) $ getLast port - , configSocket = maybe mempty hostToSocketClass $ getLast host - } - ) --- Convert the 'Client.Options' to a 'PartialPlan' that can --- be connected to with the 'Client.Options'. -optionsToPlan :: Client.Options -> PartialPlan -optionsToPlan opts@Client.Options {..} - = maybe mempty dbnameToPlan (getLast dbname) - <> maybe mempty userToPlan (getLast user) - <> clientOptionsToPlan opts - --- Wrap the 'Client.Options' in an appropiate --- 'PartialPostgresPlan' -clientOptionsToPlan :: Client.Options -> PartialPlan -clientOptionsToPlan opts = mempty - { partialPlanPostgres = mempty - { partialPostgresPlanClientConfig = opts - } - } - --- Create a 'PartialPlan' given a user -userToPlan :: String -> PartialPlan -userToPlan user = mempty - { partialPlanCreateDb = pure $ mempty - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just user - } - } - , partialPlanInitDb = pure $ mempty - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just user - } - } - } - --- Adds a @createdb@ PartialProcessPlan with the argument --- as the database name. -dbnameToPlan :: String -> PartialPlan -dbnameToPlan dbName = mempty - { partialPlanCreateDb = pure $ mempty - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsIndexBased = Map.singleton 0 dbName - } - } - } - --- Parse a host string as either an UNIX domain socket directory --- or a domain or IP. -hostToSocketClass :: String -> PartialSocketClass -hostToSocketClass hostOrSocketPath = case hostOrSocketPath of - '/' : _ -> PUnixSocket $ PPermanent hostOrSocketPath - _ -> PIpSocket $ pure hostOrSocketPath - -------------------------------------------------------------------------------- --- Lenses --- Most this code was generated with microlens-th -------------------------------------------------------------------------------- --- | Local Lens alias -type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t --- | Local Lens' alias -type Lens' s a = Lens s s a a - --- | Lens for 'partialEnvVarsInherit' -partialEnvVarsInheritL :: Lens' PartialEnvVars (Last Bool) -partialEnvVarsInheritL f_aj5e (PartialEnvVars x_aj5f x_aj5g) - = (fmap (\ y_aj5h -> (PartialEnvVars y_aj5h) x_aj5g)) - (f_aj5e x_aj5f) -{-# INLINE partialEnvVarsInheritL #-} - --- | Lens for 'partialEnvVarsSpecific' -partialEnvVarsSpecificL :: Lens' PartialEnvVars (Map String String) -partialEnvVarsSpecificL f_aj5i (PartialEnvVars x_aj5j x_aj5k) - = (fmap (\ y_aj5l -> (PartialEnvVars x_aj5j) y_aj5l)) - (f_aj5i x_aj5k) -{-# INLINE partialEnvVarsSpecificL #-} - --- | Lens for 'partialProcessConfigCmdLine' -partialProcessConfigCmdLineL :: - Lens' PartialProcessConfig PartialCommandLineArgs -partialProcessConfigCmdLineL - f_allv - (PartialProcessConfig x_allw x_allx x_ally x_allz x_allA) - = (fmap - (\ y_allB - -> ((((PartialProcessConfig x_allw) y_allB) x_ally) x_allz) - x_allA)) - (f_allv x_allx) -{-# INLINE partialProcessConfigCmdLineL #-} - --- | Lens for 'partialProcessConfigEnvVars' -partialProcessConfigEnvVarsL :: - Lens' PartialProcessConfig PartialEnvVars -partialProcessConfigEnvVarsL - f_allC - (PartialProcessConfig x_allD x_allE x_allF x_allG x_allH) - = (fmap - (\ y_allI - -> ((((PartialProcessConfig y_allI) x_allE) x_allF) x_allG) - x_allH)) - (f_allC x_allD) -{-# INLINE partialProcessConfigEnvVarsL #-} - --- | Lens for 'partialProcessConfigStdErr' -partialProcessConfigStdErrL :: - Lens' PartialProcessConfig (Last Handle) -partialProcessConfigStdErrL - f_allJ - (PartialProcessConfig x_allK x_allL x_allM x_allN x_allO) - = (fmap - (\ y_allP - -> ((((PartialProcessConfig x_allK) x_allL) x_allM) x_allN) - y_allP)) - (f_allJ x_allO) - --- | Lens for 'partialProcessConfigStdIn' -{-# INLINE partialProcessConfigStdErrL #-} -partialProcessConfigStdInL :: - Lens' PartialProcessConfig (Last Handle) -partialProcessConfigStdInL - f_allQ - (PartialProcessConfig x_allR x_allS x_allT x_allU x_allV) - = (fmap - (\ y_allW - -> ((((PartialProcessConfig x_allR) x_allS) y_allW) x_allU) - x_allV)) - (f_allQ x_allT) -{-# INLINE partialProcessConfigStdInL #-} - --- | Lens for 'partialProcessConfigStdOut' -partialProcessConfigStdOutL :: - Lens' PartialProcessConfig (Last Handle) -partialProcessConfigStdOutL - f_allX - (PartialProcessConfig x_allY x_allZ x_alm0 x_alm1 x_alm2) - = (fmap - (\ y_alm3 - -> ((((PartialProcessConfig x_allY) x_allZ) x_alm0) y_alm3) - x_alm2)) - (f_allX x_alm1) -{-# INLINE partialProcessConfigStdOutL #-} - --- | Lens for 'partialPostgresPlanClientConfig' -partialPostgresPlanClientConfigL :: - Lens' PartialPostgresPlan Client.Options -partialPostgresPlanClientConfigL - f_am1y - (PartialPostgresPlan x_am1z x_am1A) - = (fmap (\ y_am1B -> (PartialPostgresPlan x_am1z) y_am1B)) - (f_am1y x_am1A) -{-# INLINE partialPostgresPlanClientConfigL #-} - --- | Lens for 'partialPostgresPlanProcessConfig' -partialPostgresPlanProcessConfigL :: - Lens' PartialPostgresPlan PartialProcessConfig -partialPostgresPlanProcessConfigL - f_am1C - (PartialPostgresPlan x_am1D x_am1E) - = (fmap (\ y_am1F -> (PartialPostgresPlan y_am1F) x_am1E)) - (f_am1C x_am1D) -{-# INLINE partialPostgresPlanProcessConfigL #-} - --- | Lens for 'partialPlanConfig' -partialPlanConfigL :: Lens' PartialPlan [String] -partialPlanConfigL - f_amcw - (PartialPlan x_amcx x_amcy x_amcz x_amcA x_amcB x_amcC) - = (fmap - (\ y_amcD - -> (((((PartialPlan x_amcx) x_amcy) x_amcz) x_amcA) y_amcD) - x_amcC)) - (f_amcw x_amcB) -{-# INLINE partialPlanConfigL #-} - --- | Lens for 'partialPlanCreateDb' -partialPlanCreateDbL :: - Lens' PartialPlan (Maybe PartialProcessConfig) -partialPlanCreateDbL - f_amcE - (PartialPlan x_amcF x_amcG x_amcH x_amcI x_amcJ x_amcK) - = (fmap - (\ y_amcL - -> (((((PartialPlan x_amcF) x_amcG) y_amcL) x_amcI) x_amcJ) - x_amcK)) - (f_amcE x_amcH) -{-# INLINE partialPlanCreateDbL #-} - --- | Lens for 'partialPlanDataDirectory' -partialPlanDataDirectoryL :: Lens' PartialPlan (Last String) -partialPlanDataDirectoryL - f_amcM - (PartialPlan x_amcN x_amcO x_amcP x_amcQ x_amcR x_amcS) - = (fmap - (\ y_amcT - -> (((((PartialPlan x_amcN) x_amcO) x_amcP) x_amcQ) x_amcR) - y_amcT)) - (f_amcM x_amcS) -{-# INLINE partialPlanDataDirectoryL #-} - --- | Lens for 'partialPlanInitDb' -partialPlanInitDbL :: - Lens' PartialPlan (Maybe PartialProcessConfig) -partialPlanInitDbL - f_amcU - (PartialPlan x_amcV x_amcW x_amcX x_amcY x_amcZ x_amd0) - = (fmap - (\ y_amd1 - -> (((((PartialPlan x_amcV) y_amd1) x_amcX) x_amcY) x_amcZ) - x_amd0)) - (f_amcU x_amcW) -{-# INLINE partialPlanInitDbL #-} - --- | Lens for 'partialPlanLogger' -partialPlanLoggerL :: Lens' PartialPlan (Last Logger) -partialPlanLoggerL - f_amd2 - (PartialPlan x_amd3 x_amd4 x_amd5 x_amd6 x_amd7 x_amd8) - = (fmap - (\ y_amd9 - -> (((((PartialPlan y_amd9) x_amd4) x_amd5) x_amd6) x_amd7) - x_amd8)) - (f_amd2 x_amd3) -{-# INLINE partialPlanLoggerL #-} - --- | Lens for 'partialPlanPostgres' -partialPlanPostgresL :: Lens' PartialPlan PartialPostgresPlan -partialPlanPostgresL - f_amda - (PartialPlan x_amdb x_amdc x_amdd x_amde x_amdf x_amdg) - = (fmap - (\ y_amdh - -> (((((PartialPlan x_amdb) x_amdc) x_amdd) y_amdh) x_amdf) - x_amdg)) - (f_amda x_amde) -{-# INLINE partialPlanPostgresL #-} - --- | Lens for 'resourcesDataDir' -resourcesDataDirL :: Lens' Resources DirectoryType -resourcesDataDirL f_ampd (Resources x_ampe x_ampf x_ampg) - = (fmap (\ y_amph -> ((Resources x_ampe) x_ampf) y_amph)) - (f_ampd x_ampg) -{-# INLINE resourcesDataDirL #-} - --- | Lens for 'resourcesPlan' -resourcesPlanL :: Lens' Resources Plan -resourcesPlanL f_ampi (Resources x_ampj x_ampk x_ampl) - = (fmap (\ y_ampm -> ((Resources y_ampm) x_ampk) x_ampl)) - (f_ampi x_ampj) -{-# INLINE resourcesPlanL #-} - --- | Lens for 'resourcesSocket' -resourcesSocketL :: Lens' Resources SocketClass -resourcesSocketL f_ampn (Resources x_ampo x_ampp x_ampq) - = (fmap (\ y_ampr -> ((Resources x_ampo) y_ampr) x_ampq)) - (f_ampn x_ampp) -{-# INLINE resourcesSocketL #-} - --- | Lens for 'configDataDir' -configDataDirL :: Lens' Config PartialDirectoryType -configDataDirL f_amyD (Config x_amyE x_amyF x_amyG x_amyH) - = (fmap (\ y_amyI -> (((Config x_amyE) x_amyF) y_amyI) x_amyH)) - (f_amyD x_amyG) -{-# INLINE configDataDirL #-} - --- | Lens for 'configPlan' -configPlanL :: Lens' Config PartialPlan -configPlanL f_amyJ (Config x_amyK x_amyL x_amyM x_amyN) - = (fmap (\ y_amyO -> (((Config y_amyO) x_amyL) x_amyM) x_amyN)) - (f_amyJ x_amyK) -{-# INLINE configPlanL #-} - --- | Lens for 'configPort' -configPortL :: Lens' Config (Last (Maybe Int)) -configPortL f_amyP (Config x_amyQ x_amyR x_amyS x_amyT) - = (fmap (\ y_amyU -> (((Config x_amyQ) x_amyR) x_amyS) y_amyU)) - (f_amyP x_amyT) -{-# INLINE configPortL #-} - --- | Lens for 'configSocket' -configSocketL :: Lens' Config PartialSocketClass -configSocketL f_amyV (Config x_amyW x_amyX x_amyY x_amyZ) - = (fmap (\ y_amz0 -> (((Config x_amyW) y_amz0) x_amyY) x_amyZ)) - (f_amyV x_amyX) -{-# INLINE configSocketL #-} - --- | Lens for 'partialCommandLineArgsIndexBased' -partialCommandLineArgsIndexBasedL :: - Lens' PartialCommandLineArgs (Map Int String) -partialCommandLineArgsIndexBasedL - f_amNr - (PartialCommandLineArgs x_amNs x_amNt) - = (fmap (\ y_amNu -> (PartialCommandLineArgs x_amNs) y_amNu)) - (f_amNr x_amNt) -{-# INLINE partialCommandLineArgsIndexBasedL #-} - --- | Lens for 'partialCommandLineArgsKeyBased' -partialCommandLineArgsKeyBasedL :: - Lens' PartialCommandLineArgs (Map String (Maybe String)) -partialCommandLineArgsKeyBasedL - f_amNv - (PartialCommandLineArgs x_amNw x_amNx) - = (fmap (\ y_amNy -> (PartialCommandLineArgs y_amNy) x_amNx)) - (f_amNv x_amNw) -{-# INLINE partialCommandLineArgsKeyBasedL #-} diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,6 @@ import Test.Hspec import Database.Postgres.Temp.Internal.Core -import Database.Postgres.Temp.Internal.Partial +import Database.Postgres.Temp.Internal.Config import Database.Postgres.Temp.Internal import Control.Exception import System.IO.Error @@ -29,10 +29,10 @@ -- Cleanup -fromCreateDb :: Maybe PartialProcessConfig -> Config +fromCreateDb :: Maybe ProcessConfig -> Config fromCreateDb createDb = mempty - { configPlan = mempty - { partialPlanCreateDb = createDb + { plan = mempty + { createDbConfig = createDb } } @@ -45,20 +45,20 @@ defaultConfigShouldMatchDefaultPlan = it "default options should match default plan" $ withRunner $ \DB{..} -> do let Resources {..} = dbResources - Plan {..} = resourcesPlan - PostgresPlan {..} = planPostgres - Client.dbname postgresPlanClientOptions `shouldBe` pure "postgres" - let Temporary tmpDataDir = resourcesDataDir + CompletePlan {..} = resourcesPlan + CompletePostgresPlan {..} = completePlanPostgres + Client.dbname completePostgresPlanClientOptions `shouldBe` pure "postgres" + let CTemporary tmpDataDir = resourcesDataDir tmpDataDir `shouldStartWith` "/tmp/tmp-postgres-data" - let Just port = getLast $ Client.port postgresPlanClientOptions + let Just port = getLast $ Client.port completePostgresPlanClientOptions port `shouldSatisfy` (>32768) - let UnixSocket (Temporary unixSocket) = resourcesSocket + let CUnixSocket (CTemporary unixSocket) = resourcesSocket unixSocket `shouldStartWith` "/tmp/tmp-postgres-socket" - postgresPlanClientOptions `shouldBe` + completePostgresPlanClientOptions `shouldBe` (mempty - { Client.port = Client.port postgresPlanClientOptions - , Client.host = Client.host postgresPlanClientOptions - , Client.dbname = Client.dbname postgresPlanClientOptions + { Client.port = Client.port completePostgresPlanClientOptions + , Client.host = Client.host completePostgresPlanClientOptions + , Client.dbname = Client.dbname completePostgresPlanClientOptions } ) @@ -72,38 +72,38 @@ it "returns the right client options for the plan" $ do let customPlan = mempty - { configPlan = mempty - { partialPlanPostgres = mempty - { partialPostgresPlanClientConfig = mempty + { plan = mempty + { postgresPlan = mempty + { connectionOptions = mempty { Client.user = pure expectedUser , Client.password = pure expectedPassword , Client.dbname = pure expectedDbName } } - , partialPlanInitDb = pure standardProcessConfig - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsKeyBased = + , initDbConfig = pure standardProcessConfig + { commandLine = mempty + { keyBased = Map.singleton "--username=" $ Just "user-name" } - , partialProcessConfigEnvVars = mempty - { partialEnvVarsSpecific = Map.singleton "PGPASSWORD" "password" - , partialEnvVarsInherit = pure True + , environmentVariables = mempty + { specific = Map.singleton "PGPASSWORD" "password" + , inherit = pure True } } - , partialPlanCreateDb = pure standardProcessConfig - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsKeyBased = + , createDbConfig = pure standardProcessConfig + { commandLine = mempty + { keyBased = Map.singleton "--username=" $ Just "user-name" - , partialCommandLineArgsIndexBased = + , indexBased = Map.singleton 0 expectedDbName } - , partialProcessConfigEnvVars = + , environmentVariables = mempty - { partialEnvVarsSpecific = Map.singleton "PGPASSWORD" "password" - , partialEnvVarsInherit = pure True + { specific = Map.singleton "PGPASSWORD" "password" + , inherit = pure True } } - , partialPlanConfig = [extraConfig] + , postgresConfigFile = [extraConfig] } } -- hmm maybe I should provide lenses @@ -115,9 +115,9 @@ actualDuration `shouldBe` expectedDuration let Resources {..} = dbResources - Plan {..} = resourcesPlan - actualOptions = postgresPlanClientOptions planPostgres - actualPostgresConfig = planConfig + CompletePlan {..} = resourcesPlan + actualOptions = completePostgresPlanClientOptions completePlanPostgres + actualPostgresConfig = completePlanConfig Client.user actualOptions `shouldBe` pure expectedUser Client.dbname actualOptions `shouldBe` pure expectedDbName Client.password actualOptions `shouldBe` pure expectedPassword @@ -126,8 +126,8 @@ invalidConfigFailsQuickly :: (Config -> IO ()) -> Spec invalidConfigFailsQuickly action = it "quickly fails with an invalid option" $ do let customPlan = mempty - { configPlan = mempty - { partialPlanConfig = + { plan = mempty + { postgresConfigFile = [ "log_directory = /this/does/not/exist" , "logging_collector = true" ] @@ -175,10 +175,13 @@ one `shouldBe` (1 :: Int) +{- + Reenable after temp files are configurable #41 it "cleans up temp files" $ \(Runner runner) -> do initialFiles <- listDirectory "/tmp" runner $ const $ pure () listDirectory "/tmp" `shouldReturn` initialFiles + -} -- This assumes that the directory is initially empty withInitDbEmptyInitially :: SpecWith Runner @@ -201,13 +204,13 @@ runner (const $ pure ()) `shouldThrow` (== CreateDbFailed (ExitFailure 1)) spec :: Spec -spec = do +spec = parallel $ do let defaultIpPlan = defaultConfig - { configSocket = PIpSocket $ Last Nothing + { socketClass = IpSocket $ Last Nothing } specificHostIpPlan = defaultConfig - { configSocket = PIpSocket $ pure "localhost" + { socketClass = IpSocket $ pure "localhost" } describe "start" $ do @@ -217,8 +220,8 @@ let startAction plan = bracket (either throwIO pure =<< startConfig plan) stop pure throwsIfInitDbIsNotOnThePath $ startAction defaultConfig invalidConfigFailsQuickly $ void . startAction - customConfigWork $ \plan@Config{..} f -> - bracket (either throwIO pure =<< startConfig plan) stop f + customConfigWork $ \config@Config{..} f -> + bracket (either throwIO pure =<< startConfig config) stop f describe "with" $ do let startAction = either throwIO pure =<< with (const $ pure ()) throwsIfInitDbIsNotOnThePath startAction @@ -254,7 +257,7 @@ someStandardTests "postgres" defaultConfigShouldMatchDefaultPlan - describe "start/stop" $ do + describe "start/stop" $ parallel $ do before (pure $ Runner $ \f -> bracket (either throwIO pure =<< start) stop f) $ do someStandardTests "postgres" defaultConfigShouldMatchDefaultPlan @@ -277,8 +280,8 @@ let invalidCreateDbPlan = defaultConfig <> fromCreateDb ( pure $ standardProcessConfig - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsIndexBased = + { commandLine = mempty + { indexBased = Map.singleton 0 "template1" } } @@ -287,10 +290,10 @@ createDbThrowsIfTheDbExists let noCreateTemplate1 = mempty - { configPlan = mempty - { partialPlanCreateDb = Nothing - , partialPlanPostgres = mempty - { partialPostgresPlanClientConfig = mempty + { plan = mempty + { createDbConfig = Nothing + , postgresPlan = mempty + { connectionOptions = mempty { Client.dbname = pure "template1" } } @@ -320,7 +323,7 @@ it "fails on non-empty data directory" $ \dirPath -> do writeFile (dirPath <> "/PG_VERSION") "1 million" let nonEmptyFolderPlan = defaultConfig - { configDataDir = PPermanent dirPath + { dataDirectory = Permanent dirPath } startAction = bracket (either throwIO pure =<< startConfig nonEmptyFolderPlan) stop $ const $ pure () @@ -329,9 +332,9 @@ it "works if on non-empty if initdb is disabled" $ \dirPath -> do throwIfNotSuccess id =<< system ("initdb " <> dirPath) let nonEmptyFolderPlan = defaultConfig - { configDataDir = PPermanent dirPath - , configPlan = (configPlan defaultConfig) - { partialPlanInitDb = Nothing + { dataDirectory = Permanent dirPath + , plan = (plan defaultConfig) + { initDbConfig = Nothing } } bracket (either throwIO pure =<< startConfig nonEmptyFolderPlan) stop $ \db -> do @@ -342,8 +345,8 @@ one `shouldBe` (1 :: Int) let justBackupResources = mempty - { configPlan = mempty - { partialPlanConfig = + { plan = mempty + { postgresConfigFile = [ "wal_level=replica" , "archive_mode=on" , "max_wal_senders=2" diff --git a/tmp-postgres.cabal b/tmp-postgres.cabal --- a/tmp-postgres.cabal +++ b/tmp-postgres.cabal @@ -1,7 +1,7 @@ name: tmp-postgres -version: 1.7.1.0 +version: 1.8.0.0 synopsis: Start and stop a temporary postgres -description: See README.md +description: Start and stop a temporary postgres. See README.md homepage: https://github.com/jfischoff/tmp-postgres#readme license: BSD3 license-file: LICENSE @@ -19,7 +19,7 @@ exposed-modules: Database.Postgres.Temp , Database.Postgres.Temp.Internal , Database.Postgres.Temp.Internal.Core - , Database.Postgres.Temp.Internal.Partial + , Database.Postgres.Temp.Internal.Config default-extensions: ApplicativeDo , DeriveFunctor