summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJonathanFischoff <>2019-11-08 17:09:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-11-08 17:09:00 (GMT)
commit2ad2fadc29d27e2a691810ad6e20a09ca11abfab (patch)
tree0c27af307733200357d8841c32297d71eedcaf87
parent142321554c5865d1c20e1076fe20adea5f180755 (diff)
version 1.5.0.01.5.0.0
-rw-r--r--src/Database/Postgres/Temp.hs8
-rw-r--r--src/Database/Postgres/Temp/Internal.hs24
-rw-r--r--src/Database/Postgres/Temp/Internal/Partial.hs84
-rw-r--r--test/Spec.hs52
-rw-r--r--tmp-postgres.cabal2
5 files changed, 89 insertions, 81 deletions
diff --git a/src/Database/Postgres/Temp.hs b/src/Database/Postgres/Temp.hs
index 6c243f2..6f88398 100644
--- a/src/Database/Postgres/Temp.hs
+++ b/src/Database/Postgres/Temp.hs
@@ -60,6 +60,8 @@ module Database.Postgres.Temp
, defaultConfig
, defaultPostgresConf
, standardProcessConfig
+ -- ** Custom Config builder helpers
+ , optionsToDefaultConfig
-- * Starting and Stopping postgres without removing the temporary directory
, restart
, stopPostgres
@@ -78,6 +80,10 @@ module Database.Postgres.Temp
-- ** Listening socket configuration
, SocketClass (..)
, PartialSocketClass (..)
+ -- ** An environment variables monoid
+ , PartialEnvVars (..)
+ -- ** An command line monoid
+ , PartialCommandLineArgs (..)
-- ** Process configuration
, PartialProcessConfig (..)
, ProcessConfig (..)
@@ -89,8 +95,6 @@ module Database.Postgres.Temp
-- ** 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
index cb8a991..be5c1b8 100644
--- a/src/Database/Postgres/Temp/Internal.hs
+++ b/src/Database/Postgres/Temp/Internal.hs
@@ -88,7 +88,7 @@ defaultConfig = mempty
{ 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 @@ optionsToDefaultConfig opts@Client.Options {..} =
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
- }
- } \ No newline at end of file
diff --git a/src/Database/Postgres/Temp/Internal/Partial.hs b/src/Database/Postgres/Temp/Internal/Partial.hs
index 6ef71df..da7e2e5 100644
--- 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 System.IO.Error
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 @@ completePostgresPlan envs PartialPostgresPlan {..} = validationToEither $ do
-- 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 :: [(String, String)] -> PartialPlan -> Either [String] Plan
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 @@ completePlan envs PartialPlan {..} = validationToEither $ do
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 @@ data Config = Config
-- | 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 @@ toPlan port socketClass dataDirectory = mempty
, 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 @@ initConfig Config {..} = evalContT $ do
(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
index 9f6e23d..1a4e20a 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -29,6 +29,13 @@ main = hspec spec
-- 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 @@ customConfigWork action = do
, 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 @@ spec = do
[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 @@ spec = do
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
index 7020c72..7116a7a 100644
--- 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.