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 @@ -60,6 +60,8 @@ , defaultConfig , defaultPostgresConf , standardProcessConfig + -- ** Custom Config builder helpers + , optionsToDefaultConfig -- * Starting and Stopping postgres without removing the temporary directory , restart , stopPostgres @@ -78,6 +80,10 @@ -- ** Listening socket configuration , SocketClass (..) , PartialSocketClass (..) + -- ** An environment variables monoid + , PartialEnvVars (..) + -- ** An command line monoid + , PartialCommandLineArgs (..) -- ** Process configuration , PartialProcessConfig (..) , ProcessConfig (..) @@ -89,8 +95,6 @@ -- ** Database plans. This is used to call @initdb@, @postgres@ and @createdb@ , PartialPlan (..) , Plan (..) - -- ** Custom Config builder helpers - , optionsToDefaultConfig ) where import Database.Postgres.Temp.Internal import Database.Postgres.Temp.Internal.Core 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 @@ -88,7 +88,7 @@ { configPlan = mempty { partialPlanLogger = pure mempty , partialPlanConfig = defaultPostgresConfig - , partialPlanCreateDb = Accum Nothing + , partialPlanCreateDb = Nothing , partialPlanInitDb = pure standardProcessConfig { partialProcessConfigCmdLine = mempty { partialCommandLineArgsKeyBased = Map.singleton "--no-sync" Nothing @@ -211,21 +211,9 @@ startingConfig = if partialPlanCreateDb (configPlan generated) == mempty then defaultConfig - else setCreateDb defaultConfig $ pure standardProcessConfig + else defaultConfig <> mempty + { configPlan = mempty + { partialPlanCreateDb = pure standardProcessConfig + } + } in startingConfig <> generated - --- | Set a 'Config's 'partialPlanCreateDb' value. -setCreateDb :: Config -> Accum PartialProcessConfig -> Config -setCreateDb config@Config {..} new = config - { configPlan = configPlan - { partialPlanCreateDb = new - } - } - --- | Set a 'Config's 'partialPlanInitDb' value. -setInitDb :: Config -> Accum PartialProcessConfig -> Config -setInitDb config@Config {..} new = config - { configPlan = configPlan - { partialPlanInitDb = new - } - } diff --git a/src/Database/Postgres/Temp/Internal/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,8 +1,7 @@ {-| This module provides types and functions for combining partial configs into a complete configs to ultimately make a 'Plan'. - This module has three classes of types. Types like 'Accum' that - are generic and could live in a module like "base". + This module has two classes of types. Types like 'PartialProcessConfig' that could be used by any library that needs to combine process options. @@ -34,20 +33,6 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map --- | Another 'Maybe' 'Monoid' newtype. This one combines 'Just's --- monoidially, with @Just mempty@ as @mempty@ and 'Nothing' --- annihilates. -newtype Accum a = Accum { getAccum :: Maybe a } - deriving (Show, Eq, Ord, Functor, Applicative) - -instance Semigroup a => Semigroup (Accum a) where - Accum x <> Accum y = Accum $ case (x, y) of - (Just a, Just b) -> Just $ a <> b - _ -> Nothing - -instance Monoid a => Monoid (Accum a) where - mempty = Accum $ Just $ mempty - -- | The environment variables can be declared to -- inherit from the running process or they -- can be specifically added. @@ -325,8 +310,8 @@ -- when creating a plan. data PartialPlan = PartialPlan { partialPlanLogger :: Last Logger - , partialPlanInitDb :: Accum PartialProcessConfig - , partialPlanCreateDb :: Accum PartialProcessConfig + , partialPlanInitDb :: Maybe PartialProcessConfig + , partialPlanCreateDb :: Maybe PartialProcessConfig , partialPlanPostgres :: PartialPostgresPlan , partialPlanConfig :: [String] , partialPlanDataDirectory :: Last String @@ -340,9 +325,9 @@ completePlan envs PartialPlan {..} = validationToEither $ do planLogger <- getOption "partialPlanLogger" partialPlanLogger planInitDb <- eitherToValidation $ addErrorContext "partialPlanInitDb: " $ - traverse (completeProcessConfig envs) (getAccum partialPlanInitDb) + traverse (completeProcessConfig envs) partialPlanInitDb planCreateDb <- eitherToValidation $ addErrorContext "partialPlanCreateDb: " $ - traverse (completeProcessConfig envs) (getAccum partialPlanCreateDb) + traverse (completeProcessConfig envs) partialPlanCreateDb planPostgres <- eitherToValidation $ addErrorContext "partialPlanPostgres: " $ completePostgresPlan envs partialPlanPostgres let planConfig = unlines partialPlanConfig @@ -351,6 +336,16 @@ 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 'initPlan'. -- See 'initConfig' for an example of how to create a 'Resources'. @@ -385,14 +380,18 @@ -- | Create a 'PartialPlan' that sets the command line options of all processes -- (@initdb@, @postgres@ and @createdb@) using a toPlan - :: Int + :: 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 port socketClass dataDirectory = mempty +toPlan makeInitDb makeCreateDb port socketClass dataDirectory = mempty { partialPlanConfig = socketClassToConfig socketClass , partialPlanDataDirectory = pure dataDirectory , partialPlanPostgres = mempty @@ -410,20 +409,24 @@ , Client.dbname = pure "postgres" } } - , partialPlanCreateDb = pure $ mempty - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsKeyBased = Map.fromList $ - socketClassToHostFlag socketClass <> - [("-p ", Just $ show port)] - } - } - , partialPlanInitDb = pure $ mempty - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsKeyBased = Map.fromList $ - [("--pgdata=", Just dataDirectory)] - } + , 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 } @@ -440,10 +443,15 @@ (initPartialSocketClass configSocket) shutdownSocketConfig resourcesDataDir <- ContT $ bracketOnError (initDirectoryType "tmp-postgres-data" configDataDir) shutdownDirectoryType - let hostAndDirPartial = toPlan port resourcesSocket $ - toFilePath resourcesDataDir + let hostAndDirPartial = toPlan + (hasInitDb configPlan) + (hasCreateDb configPlan) + port + resourcesSocket + (toFilePath resourcesDataDir) + finalPlan = hostAndDirPartial <> configPlan resourcesPlan <- lift $ either (throwIO . CompletePlanFailed) pure $ - completePlan envs $ hostAndDirPartial <> configPlan + completePlan envs finalPlan pure Resources {..} -- | Free the temporary resources created by 'initConfig' diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -29,6 +29,13 @@ -- Cleanup +fromCreateDb :: Maybe PartialProcessConfig -> Config +fromCreateDb createDb = mempty + { configPlan = mempty + { partialPlanCreateDb = createDb + } + } + newtype Runner = Runner (forall a. (DB -> IO a) -> IO a) withRunner :: (DB -> IO ()) -> Runner -> IO () @@ -83,24 +90,24 @@ , partialEnvVarsInherit = pure True } } + , partialPlanCreateDb = pure standardProcessConfig + { partialProcessConfigCmdLine = mempty + { partialCommandLineArgsKeyBased = + Map.singleton "--username=" $ Just "user-name" + , partialCommandLineArgsIndexBased = + Map.singleton 0 expectedDbName + } + , partialProcessConfigEnvVars = + mempty + { partialEnvVarsSpecific = Map.singleton "PGPASSWORD" "password" + , partialEnvVarsInherit = pure True + } + } , partialPlanConfig = [extraConfig] } } -- hmm maybe I should provide lenses - let createDb = pure standardProcessConfig - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsKeyBased = - Map.singleton "--username=" $ Just "user-name" - , partialCommandLineArgsIndexBased = - Map.singleton 0 expectedDbName - } - , partialProcessConfigEnvVars = - mempty - { partialEnvVarsSpecific = Map.singleton "PGPASSWORD" "password" - , partialEnvVarsInherit = pure True - } - } - combinedResources = setCreateDb defaultConfig createDb <> customPlan + let combinedResources = defaultConfig <> customPlan action combinedResources $ \db@DB {..} -> do bracket (PG.connectPostgreSQL $ toConnectionString db) PG.close $ \conn -> do @@ -268,19 +275,20 @@ [PG.Only actualDuration] <- PG.query_ conn "SHOW log_min_duration_statement" actualDuration `shouldBe` expectedDuration - let invalidCreateDbPlan = setCreateDb defaultConfig $ - pure $ standardProcessConfig - { partialProcessConfigCmdLine = mempty - { partialCommandLineArgsIndexBased = - Map.singleton 0 "template1" + let invalidCreateDbPlan = defaultConfig <> fromCreateDb + ( pure $ standardProcessConfig + { partialProcessConfigCmdLine = mempty + { partialCommandLineArgsIndexBased = + Map.singleton 0 "template1" + } } - } + ) before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startConfig invalidCreateDbPlan) stop f) $ createDbThrowsIfTheDbExists let noCreateTemplate1 = mempty { configPlan = mempty - { partialPlanCreateDb = Accum Nothing + { partialPlanCreateDb = Nothing , partialPlanPostgres = mempty { partialPostgresPlanClientConfig = mempty { Client.dbname = pure "template1" @@ -323,7 +331,7 @@ let nonEmptyFolderPlan = defaultConfig { configDataDir = PPermanent dirPath , configPlan = (configPlan defaultConfig) - { partialPlanInitDb = Accum Nothing + { partialPlanInitDb = Nothing } } bracket (either throwIO pure =<< startConfig nonEmptyFolderPlan) stop $ \db -> do 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.4.0.0 +version: 1.5.0.0 synopsis: Start and stop a temporary postgres description: @tmp-postgres@ provides functions creating a temporary @postgres@ instance.