diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ Changelog for tmp-postgres +1.23.0.0 + #175 Flatten Config + #178 Documentation Fixes + #179 Remove Public Config.hs + #180 Remove Lenses + 1.22.0.0 #174 Better postgresql.conf type. diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -15,12 +15,11 @@ defaultConfigDefaultInitDb :: Config defaultConfigDefaultInitDb = mempty - { plan = mempty - { logger = pure mempty - , postgresConfigFile = fastPostgresConfig - , initDbConfig = pure mempty - } + { logger = pure mempty + , postgresConfigFile = fastPostgresConfig + , initDbConfig = pure mempty } + createFooDb :: PG.Connection -> Int -> IO () createFooDb conn index = void $ PG.execute_ conn $ fromString $ unlines diff --git a/resource-soak-test/Main.hs b/resource-soak-test/Main.hs --- a/resource-soak-test/Main.hs +++ b/resource-soak-test/Main.hs @@ -38,9 +38,7 @@ forM_ [0, 10 .. 1000000] $ \theDelay -> do let theConfig = defaultConfig { temporaryDirectory = pure directoryPath - , plan = (plan defaultConfig) - { logger = pure print - } + , logger = pure print } initialContents <- listDirectory directoryPath 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 @@ -59,8 +59,25 @@ , verboseConfig -- *** Custom Config builder helpers , optionsToDefaultConfig - -- *** General Configuration Types - , module Database.Postgres.Temp.Config + -- *** 'Config' + , Config (..) + , prettyPrintConfig + -- *** 'ProcessConfig' + , ProcessConfig (..) + -- *** 'EnvironmentVariables' + , EnvironmentVariables (..) + -- *** 'CommandLineArgs' + , CommandLineArgs (..) + -- *** 'DirectoryType' + , DirectoryType (..) + -- *** 'CompleteDirectoryType' + , CompleteDirectoryType (..) + -- *** 'Accum' + , Accum (..) + -- *** 'Logger' + , Logger + -- ** Internal events passed to the 'logger' . + , Event (..) -- ** Main resource handle , DB -- *** 'DB' accessors @@ -109,4 +126,4 @@ ) where import Database.Postgres.Temp.Internal import Database.Postgres.Temp.Internal.Core -import Database.Postgres.Temp.Config +import Database.Postgres.Temp.Internal.Config diff --git a/src/Database/Postgres/Temp/Config.hs b/src/Database/Postgres/Temp/Config.hs deleted file mode 100644 --- a/src/Database/Postgres/Temp/Config.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-| 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.Config - ( -- ** 'Config' - Config (..) - , prettyPrintConfig - -- *** 'Config' Lenses - , planL - , socketDirectoryL - , dataDirectoryL - , portL - , connectionTimeoutL - -- ** 'Plan' - , Plan (..) - -- *** 'Plan' lenses - , postgresConfigFileL - , createDbConfigL - , dataDirectoryStringL - , copyConfigL - , initDbConfigL - , loggerL - , postgresPlanL - -- ** 'PostgresPlan' - , PostgresPlan (..) - -- *** 'PostgresPlan' lenses - , connectionOptionsL - , postgresConfigL - -- ** 'CopyDirectoryCommand' - , sourceDirectoryL - , destinationDirectoryL - , useCopyOnWriteL - -- ** 'ProcessConfig' - , ProcessConfig (..) - -- *** 'ProcessConfig' Lenses - , commandLineL - , environmentVariablesL - , stdErrL - , stdInL - , stdOutL - -- ** 'EnvironmentVariables' - , EnvironmentVariables (..) - -- *** 'EnvironmentVariables' Lenses - , inheritL - , specificL - -- ** 'CommandLineArgs' - , CommandLineArgs (..) - -- *** 'CommandLineArgs' Lenses - , indexBasedL - , keyBasedL - -- ** 'DirectoryType' - , DirectoryType (..) - -- ** 'CompleteDirectoryType - , CompleteDirectoryType (..) - -- ** 'Accum' - , Accum (..) - -- ** 'Logger' - , Logger - -- * Internal events passed to the 'logger' . - , Event (..) - ) where -import Database.Postgres.Temp.Internal.Config -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 @@ -169,30 +169,17 @@ @ custom = defaultConfig <> mempty - { 'plan' = mempty - { 'postgresConfigFile' = - [ "wal_level = replica" - , "archive_mode = on" - , "max_wal_senders = 2" - , "fsync = on" - , "synchronous_commit = on" - ] - } + { 'postgresConfigFile' = + [ ("wal_level, "replica") + , ("archive_mode", on") + , ("max_wal_senders", "2") + , ("fsync", "on") + , ("synchronous_commit", "on") + ] } @ -Or using the provided lenses and your favorite lens library: - @ - custom = defaultConfig & 'planL' . 'postgresConfigFileL' <>~ - [ "wal_level = replica" - , "archive_mode = on" - , "max_wal_senders = 2" - , "fsync = on" - , "synchronous_commit = on" - ] - @ - This is common enough there is `defaultPostgresConf` which is a helper to do this. @@ -203,16 +190,15 @@ -} defaultConfig :: Config defaultConfig = mempty - { plan = mempty - { postgresConfigFile = fastPostgresConfig - , initDbConfig = pure mempty - { commandLine = mempty - { keyBased = Map.singleton "--no-sync" Nothing - } + { postgresConfigFile = fastPostgresConfig + , initDbConfig = pure mempty + { commandLine = mempty + { keyBased = Map.singleton "--no-sync" Nothing } } } + {-| Default configuration for PostgreSQL versions 9.3 and greater but less than 10. @@ -224,41 +210,30 @@ -} defaultConfig_9_3_10 :: Config defaultConfig_9_3_10 = mempty - { plan = mempty - { postgresConfigFile = fastPostgresConfig - , initDbConfig = pure mempty - { commandLine = mempty - { keyBased = Map.singleton "--nosync" Nothing - } + { postgresConfigFile = fastPostgresConfig + , initDbConfig = pure mempty + { commandLine = mempty + { keyBased = Map.singleton "--nosync" Nothing } } } + {-| 'mappend' the 'defaultConfig' with a 'Config' that provides additional \"postgresql.conf\" lines. Equivalent to: @ 'defaultPostgresConf' extra = 'defaultConfig' <> mempty - { 'plan' = mempty - { 'postgresConfigFile' = extra - } + { 'postgresConfigFile' = extra } @ -or with lenses: - -@ -'defaultPostgresConf' extra = 'defaultConfig' & 'planL' . 'postgresConfigFileL' <>~ extra -@ - @since 1.21.0.0 -} defaultPostgresConf :: [(String, String)] -> Config defaultPostgresConf extra = defaultConfig <> mempty - { plan = mempty - { postgresConfigFile = extra - } + { postgresConfigFile = extra } -- | Default postgres options @@ -283,17 +258,14 @@ -} verboseConfig :: Config verboseConfig = defaultConfig <> mempty - { plan = mempty - { logger = pure print - , postgresConfigFile = verbosePostgresConfig - , initDbConfig = pure standardProcessConfig - , createDbConfig = pure standardProcessConfig - , postgresPlan = mempty - { postgresConfig = standardProcessConfig - } - } + { logger = pure print + , postgresConfigFile = verbosePostgresConfig + , initDbConfig = pure standardProcessConfig + , createDbConfig = pure standardProcessConfig + , postgresConfig = standardProcessConfig } + {-| Create zero or more temporary resources and use them to make a 'Config'. @@ -317,7 +289,7 @@ * Sets a `connectionTimeout` of one minute. * Logs internal `Event`s. * Sets the processes to use the standard input and output handles. -* Sets the 'dataDirectoryString' to file path generated from 'dataDirectory'. +* Sets the 'dataDirectory' to file path generated from 'dataDirectory'. All of these values can be overrided by the @extra@ config. @@ -378,7 +350,7 @@ stopPostgresGracefully :: DB -> IO ExitCode stopPostgresGracefully = stopPostgresProcess True . dbPostgresProcess --- | Restart the @postgres@ from 'DB' using the prior 'Plan'. +-- | Restart the @postgres@ from 'DB' using the prior 'Config'. -- -- @since 1.12.0.0 restart :: DB -> IO (Either StartError DB) @@ -664,12 +636,10 @@ -} snapshotConfig :: Snapshot -> Config snapshotConfig (Snapshot savePointPath) = mempty - { plan = mempty - { copyConfig = pure $ pure CopyDirectoryCommand - { sourceDirectory = toFilePath savePointPath - , destinationDirectory = Nothing - , useCopyOnWrite = cowCheck - } - , initDbConfig = Zlich + { copyConfig = pure $ pure CopyDirectoryCommand + { sourceDirectory = toFilePath savePointPath + , destinationDirectory = Nothing + , useCopyOnWrite = cowCheck } + , initDbConfig = Zlich } diff --git a/src/Database/Postgres/Temp/Internal/Config.hs b/src/Database/Postgres/Temp/Internal/Config.hs --- a/src/Database/Postgres/Temp/Internal/Config.hs +++ b/src/Database/Postgres/Temp/Internal/Config.hs @@ -393,94 +393,26 @@ CPermanent _ -> pure () CTemporary filePath -> rmDirIgnoreErrors filePath --- | @postgres@ process config and corresponding client connection --- 'Client.Options'. --- --- @since 1.12.0.0 -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 +-- | Turn a 'Config' into a 'CompletePostgresPlan'. Fails if any -- values are missing. -completePostgresPlan :: [(String, String)] -> PostgresPlan -> Either [String] CompletePostgresPlan -completePostgresPlan envs PostgresPlan {..} = runErrors $ do +completePostgresPlan :: [(String, String)] -> Config -> Either [String] CompletePostgresPlan +completePostgresPlan envs Config {..} = runErrors $ do let completePostgresPlanClientOptions = connectionOptions completePostgresPlanProcessConfig <- eitherToErrors $ addErrorContext "postgresConfig: " $ completeProcessConfig envs postgresConfig pure CompletePostgresPlan {..} -------------------------------------------------------------------------------- --- Plan -------------------------------------------------------------------------------- --- | Describe how to run @initdb@, @createdb@ and @postgres@ --- --- @since 1.16.0.0 -data Plan = Plan - { logger :: Last Logger - , initDbConfig :: Accum ProcessConfig - , copyConfig :: Last (Maybe CopyDirectoryCommand) - , createDbConfig :: Accum ProcessConfig - , postgresPlan :: PostgresPlan - , postgresConfigFile :: [(String, String)] - , dataDirectoryString :: Last String - , connectionTimeout :: Last Int - -- ^ Max time to spend attempting to connection to @postgres@. - -- Time is in microseconds. - } - 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 $ getAccum initDbConfig) - <> hardline - <> text "initDbConfig:" - <> softline - <> indent 2 (pretty $ getAccum createDbConfig) - <> text "copyConfig:" - <> softline - <> indent 2 (pretty (getLast copyConfig)) - <> hardline - <> text "postgresPlan:" - <> softline - <> indent 2 (pretty postgresPlan) - <> hardline - <> text "postgresConfigFile:" - <> softline - <> indent 2 (vsep $ map (\(x, y) -> text x <> "=" <> text y) postgresConfigFile) - <> hardline - <> text "dataDirectoryString:" <+> pretty (getLast dataDirectoryString) - <> hardline - <> text "connectionTimeout:" <+> pretty (getLast connectionTimeout) flattenConfig :: [(String, String)] -> String flattenConfig = unlines . map (\(x, y) -> x <> "=" <> y) . Map.toList . Map.fromList --- | Turn a 'Plan' into a 'CompletePlan'. Fails if any values are missing. -completePlan :: [(String, String)] -> Plan -> Either [String] CompletePlan -completePlan envs Plan {..} = do +-- | Turn a 'Config' into a 'CompletePlan'. Fails if any values are missing. +completePlan :: [(String, String)] -> String -> Config -> Either [String] CompletePlan +completePlan envs dataDirectoryString config@Config {..} = do ( completePlanLogger , completePlanInitDb , completePlanCreateDb @@ -495,8 +427,8 @@ <*> eitherToErrors (addErrorContext "createDbConfig: " $ traverse (completeProcessConfig envs) $ getAccum createDbConfig) <*> eitherToErrors (addErrorContext "postgresPlan: " - (completePostgresPlan envs postgresPlan)) - <*> getOption "dataDirectoryString" dataDirectoryString + (completePostgresPlan envs config)) + <*> pure dataDirectoryString <*> getOption "connectionTimeout" connectionTimeout let completePlanConfig = flattenConfig postgresConfigFile @@ -505,23 +437,28 @@ pure CompletePlan {..} --- Returns 'True' if the 'Plan' has a +-- Returns 'True' if the 'Config' has a -- 'Just' 'initDbConfig'. -hasInitDb :: Plan -> Bool -hasInitDb Plan {..} = isJust $ getAccum initDbConfig +hasInitDb :: Config -> Bool +hasInitDb Config {..} = isJust $ getAccum initDbConfig --- Returns 'True' if the 'Plan' has a +-- Returns 'True' if the 'Config' has a -- 'Just' 'createDbConfig'. -hasCreateDb :: Plan -> Bool -hasCreateDb Plan {..} = isJust $ getAccum createDbConfig +hasCreateDb :: Config -> Bool +hasCreateDb Config {..} = isJust $ getAccum createDbConfig -- | The high level options for overriding default behavior. -- -- @since 1.16.0.0 data Config = Config - { plan :: Plan - -- ^ Extend or replace any of the configuration used to create a final - -- 'CompletePlan'. + { logger :: Last Logger + , initDbConfig :: Accum ProcessConfig + , copyConfig :: Last (Maybe CopyDirectoryCommand) + , createDbConfig :: Accum ProcessConfig + , postgresConfig :: ProcessConfig + , connectionOptions :: Client.Options + , postgresConfigFile :: [(String, String)] + , connectionTimeout :: Last Int , socketDirectory :: DirectoryType -- ^ Override the default temporary UNIX socket directory by setting this. , dataDirectory :: DirectoryType @@ -541,11 +478,7 @@ instance Pretty Config where pretty Config {..} - = text "plan:" - <> softline - <> pretty plan - <> hardline - <> text "socketDirectory:" + = text "socketDirectory:" <> softline <> pretty socketDirectory <> hardline @@ -560,6 +493,31 @@ <> pretty (getLast temporaryDirectory) <> hardline <> text "initDbCache:" <+> pretty (getLast initDbCache) + <> hardline + <> text "initDbConfig:" + <> softline + <> indent 2 (pretty $ getAccum initDbConfig) + <> hardline + <> text "initDbConfig:" + <> softline + <> indent 2 (pretty $ getAccum createDbConfig) + <> text "copyConfig:" + <> softline + <> indent 2 (pretty (getLast copyConfig)) + <> hardline + <> text "postgresConfig:" + <> softline + <> indent 2 (pretty postgresConfig) + <> hardline + <> text "connectionOptions:" + <> softline + <> indent 2 (prettyOptions connectionOptions) + <> hardline + <> text "postgresConfigFile:" + <> softline + <> indent 2 (vsep $ map (\(x, y) -> text x <> "=" <> text y) postgresConfigFile) + <> hardline + <> text "connectionTimeout:" <+> pretty (getLast connectionTimeout) socketDirectoryToConfig :: FilePath -> [(String, String)] socketDirectoryToConfig dir = @@ -574,7 +532,7 @@ Copy command used to create a data directory. If @initdb@ used to create the data directory directly this is not needed. -If 'destinationDirectory' is Nothing then the 'dataDirectoryString' +If 'destinationDirectory' is Nothing then the 'dataDirectory' (which might be generated) is used. @since 1.16.0.0 @@ -702,7 +660,7 @@ , completePlanInitDb = theInitDbPlan } --- | Create a 'Plan' that sets the command line options of all processes +-- | Create a 'Config' that sets the command line options of all processes -- (@initdb@, @postgres@ and @createdb@). This the @generated@ plan -- that is combined with the @extra@ plan from -- 'Database.Postgres.Temp.startConfig'. @@ -717,27 +675,24 @@ -- ^ Socket directory. -> FilePath -- ^ The @postgres@ data directory. - -> Plan + -> Config toPlan _makeInitDb makeCreateDb port socketDirectory dataDirectoryString = mempty { postgresConfigFile = socketDirectoryToConfig socketDirectory - , dataDirectoryString = pure dataDirectoryString , connectionTimeout = pure (60 * 1000000) -- 1 minute , logger = pure $ const $ pure () - , postgresPlan = mempty - { postgresConfig = silentProcessConfig - { commandLine = mempty - { keyBased = Map.fromList - [ ("-p", Just $ show port) - , ("-D", Just dataDirectoryString) - ] - } - } - , connectionOptions = mempty - { Client.host = pure socketDirectory - , Client.port = pure port - , Client.dbname = pure "postgres" - } - } + , postgresConfig = silentProcessConfig + { commandLine = mempty + { keyBased = Map.fromList + [ ("-p", Just $ show port) + , ("-D", Just dataDirectoryString) + ] + } + } + , connectionOptions = mempty + { Client.host = pure socketDirectory + , Client.port = pure port + , Client.dbname = pure "postgres" + } , createDbConfig = if makeCreateDb then pure silentProcessConfig { commandLine = mempty @@ -759,12 +714,12 @@ } -- | Create all the temporary resources from a 'Config'. This also combines the --- 'Plan' from 'toPlan' with the @extra@ 'Config' passed in. +-- 'Config' from 'toPlan' with the @extra@ 'Config' passed in. setupConfig :: Config -- ^ @extra@ 'Config' to 'mappend' after the @generated@ 'Config'. -> IO Resources -setupConfig Config {..} = evalContT $ do +setupConfig config@Config {..} = evalContT $ do envs <- lift getEnvironment thePort <- lift $ maybe getFreePort pure $ join $ getLast port let resourcesTemporaryDir = fromMaybe "/tmp" $ getLast temporaryDirectory @@ -774,15 +729,15 @@ resourcesDataDir <- ContT $ bracketOnError (setupDirectoryType resourcesTemporaryDir "tmp-postgres-data" dataDirectory) cleanupDirectoryType let hostAndDir = toPlan - (hasInitDb plan) - (hasCreateDb plan) + (hasInitDb config) + (hasCreateDb config) thePort (toFilePath resourcesSocketDirectory) (toFilePath resourcesDataDir) - finalPlan = hostAndDir <> plan + finalPlan = hostAndDir <> config uncachedPlan <- lift $ either (throwIO . CompletePlanFailed (show $ pretty finalPlan)) pure $ - completePlan envs finalPlan + completePlan envs (toFilePath resourcesDataDir) finalPlan resourcesPlan <- lift $ maybe (pure uncachedPlan) (uncurry $ cachePlan uncachedPlan) resourcesInitDbCache pure Resources {..} @@ -846,14 +801,13 @@ optionsToConfig :: Client.Options -> Config optionsToConfig opts@Client.Options {..} = ( mempty - { plan = optionsToPlan opts - , port = maybe (Last Nothing) (pure . pure) $ getLast port + { port = maybe (Last Nothing) (pure . pure) $ getLast port , socketDirectory = maybe mempty hostToSocketClass $ getLast host } - ) --- Convert the 'Client.Options' to a 'Plan' that can + ) <> optionsToPlan opts +-- Convert the 'Client.Options' to a 'Config' that can -- be connected to with the 'Client.Options'. -optionsToPlan :: Client.Options -> Plan +optionsToPlan :: Client.Options -> Config optionsToPlan opts@Client.Options {..} = maybe mempty (dbnameToPlan (getLast user) (getLast password)) (getLast dbname) <> maybe mempty userToPlan (getLast user) @@ -862,15 +816,13 @@ -- Wrap the 'Client.Options' in an appropiate -- 'PostgresPlan'. -clientOptionsToPlan :: Client.Options -> Plan +clientOptionsToPlan :: Client.Options -> Config clientOptionsToPlan opts = mempty - { postgresPlan = mempty - { connectionOptions = opts - } + { connectionOptions = opts } --- Create a 'Plan' given a user. -userToPlan :: String -> Plan +-- Create a 'Config' given a user. +userToPlan :: String -> Config userToPlan user = mempty { initDbConfig = pure mempty { commandLine = mempty @@ -883,7 +835,7 @@ -- as the database name. -- It does nothing if the db names are "template1" or -- "postgres" -dbnameToPlan :: Maybe String -> Maybe String -> String -> Plan +dbnameToPlan :: Maybe String -> Maybe String -> String -> Config dbnameToPlan muser mpassword dbName | dbName == "template1" || dbName == "postgres" = mempty | otherwise = mempty @@ -899,7 +851,7 @@ } -- Adds the 'PGPASSWORD' to both @initdb@ and @createdb@ -passwordToPlan :: String -> Plan +passwordToPlan :: String -> Config passwordToPlan password = mempty { initDbConfig = pure mempty { environmentVariables = mempty @@ -914,323 +866,3 @@ hostToSocketClass hostOrSocketPath = case hostOrSocketPath of '/' : _ -> Permanent hostOrSocketPath _ -> Temporary - -------------------------------------------------------------------------------- --- 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' --- --- @since 1.12.0.0 -inheritL :: Lens' EnvironmentVariables (Last Bool) -inheritL f_aj5e (EnvironmentVariables x_aj5f x_aj5g) - = fmap (`EnvironmentVariables` x_aj5g) - (f_aj5e x_aj5f) -{-# INLINE inheritL #-} - --- | Lens for 'specific'. --- --- @since 1.12.0.0 -specificL :: Lens' EnvironmentVariables (Map String String) -specificL f_aj5i (EnvironmentVariables x_aj5j x_aj5k) - = fmap (EnvironmentVariables x_aj5j) - (f_aj5i x_aj5k) -{-# INLINE specificL #-} - --- | Lens for 'commandLine'. --- --- @since 1.12.0.0 -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'. --- --- @since 1.12.0.0 -environmentVariablesL :: - Lens' ProcessConfig EnvironmentVariables -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' --- --- @since 1.12.0.0 -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'. --- --- @since 1.12.0.0 -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'. --- --- @since 1.12.0.0 -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'. --- --- @since 1.12.0.0 -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'. --- --- @since 1.12.0.0 -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'. --- --- @since 1.12.0.0 -postgresConfigFileL :: Lens' Plan [(String, String)] -postgresConfigFileL f plan@Plan{..} - = fmap (\x -> plan { postgresConfigFile = x }) - (f postgresConfigFile) -{-# INLINE postgresConfigFileL #-} - --- | Lens for 'createDbConfig'. --- --- @since 1.17.0.0 -createDbConfigL :: - Lens' Plan (Accum ProcessConfig) -createDbConfigL f plan@Plan{..} - = fmap (\x -> plan { createDbConfig = x }) - (f createDbConfig) -{-# INLINE createDbConfigL #-} - --- | Lens for 'dataDirectoryString'. --- --- @since 1.12.0.0 -dataDirectoryStringL :: Lens' Plan (Last String) -dataDirectoryStringL f plan@Plan{..} - = fmap (\x -> plan { dataDirectoryString = x }) - (f dataDirectoryString) -{-# INLINE dataDirectoryStringL #-} - --- | Lens for 'copyConfig'. --- --- @since 1.16.0.0 -copyConfigL :: Lens' Plan (Last (Maybe CopyDirectoryCommand)) -copyConfigL f plan@Plan{..} - = fmap (\x -> plan { copyConfig = x }) - (f copyConfig) -{-# INLINE copyConfigL #-} - --- | Lens for 'initDbConfig'. --- --- @since 1.12.0.0 -initDbConfigL :: Lens' Plan (Accum ProcessConfig) -initDbConfigL f plan@Plan{..} - = fmap (\x -> plan { initDbConfig = x }) - (f initDbConfig) -{-# INLINE initDbConfigL #-} - --- | Lens for 'logger'. --- --- @since 1.12.0.0 -loggerL :: Lens' Plan (Last Logger) -loggerL f plan@Plan{..} - = fmap (\x -> plan { logger = x }) - (f logger) -{-# INLINE loggerL #-} - --- | Lens for 'postgresPlan'. --- --- @since 1.12.0.0 -postgresPlanL :: Lens' Plan PostgresPlan -postgresPlanL f plan@Plan{..} - = fmap (\x -> plan { postgresPlan = x }) - (f postgresPlan) -{-# INLINE postgresPlanL #-} - --- | Lens for 'connectionTimeout'. --- --- @since 1.12.0.0 -connectionTimeoutL :: Lens' Plan (Last Int) -connectionTimeoutL f plan@Plan{..} - = fmap (\x -> plan { connectionTimeout = x }) - (f connectionTimeout) -{-# INLINE connectionTimeoutL #-} - --- | Lens for 'resourcesDataDir'. --- --- @since 1.12.0.0 -resourcesDataDirL :: Lens' Resources CompleteDirectoryType -resourcesDataDirL f resources@Resources {..} - = fmap (\x -> resources { resourcesDataDir = x }) - (f resourcesDataDir) -{-# INLINE resourcesDataDirL #-} - --- | Lens for 'resourcesPlan'. --- --- @since 1.12.0.0 -resourcesPlanL :: Lens' Resources CompletePlan -resourcesPlanL f resources@Resources {..} - = fmap (\x -> resources { resourcesPlan = x }) - (f resourcesPlan) -{-# INLINE resourcesPlanL #-} - --- | Lens for 'resourcesSocketDirectory'. --- --- @since 1.15.0.0 -resourcesSocketDirectoryL :: Lens' Resources CompleteDirectoryType -resourcesSocketDirectoryL f resources@Resources {..} - = fmap (\x -> resources { resourcesSocketDirectory = x }) - (f resourcesSocketDirectory) -{-# INLINE resourcesSocketDirectoryL #-} - --- | Lens for 'dataDirectory'. --- --- @since 1.12.0.0 -dataDirectoryL :: Lens' Config DirectoryType -dataDirectoryL f config@Config{..} - = fmap (\ x -> config { dataDirectory = x } ) - (f dataDirectory) -{-# INLINE dataDirectoryL #-} - --- | Lens for 'plan'. --- --- @since 1.12.0.0 -planL :: Lens' Config Plan -planL f config@Config{..} - = fmap (\ x -> config { plan = x } ) - (f plan) -{-# INLINE planL #-} - --- | Lens for 'port'. --- --- @since 1.12.0.0 -portL :: Lens' Config (Last (Maybe Int)) -portL f config@Config{..} - = fmap (\ x -> config { port = x } ) - (f port) -{-# INLINE portL #-} - --- | Lens for 'socketDirectory'. --- --- @since 1.12.0.0 -socketDirectoryL :: Lens' Config DirectoryType -socketDirectoryL f config@Config{..} - = fmap (\ x -> config { socketDirectory = x } ) - (f socketDirectory) -{-# INLINE socketDirectoryL #-} - --- | Lens for 'socketDirectory'. --- --- @since 1.12.0.0 -temporaryDirectoryL :: Lens' Config (Last FilePath) -temporaryDirectoryL f config@Config{..} - = fmap (\ x -> config { temporaryDirectory = x } ) - (f temporaryDirectory) -{-# INLINE temporaryDirectoryL #-} - --- | Lens for 'indexBased'. --- --- @since 1.12.0.0 -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'. --- --- @since 1.12.0.0 -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 #-} - --- | Lens for 'sourceDirectory'. --- --- @since 1.16.0.0 -sourceDirectoryL :: Lens' CopyDirectoryCommand FilePath -sourceDirectoryL f cmd@CopyDirectoryCommand{..} - = fmap (\x -> cmd { sourceDirectory = x }) - (f sourceDirectory) -{-# INLINE sourceDirectoryL #-} - --- | Lens for 'destinationDirectory'. --- --- @since 1.16.0.0 -destinationDirectoryL :: Lens' CopyDirectoryCommand (Maybe FilePath) -destinationDirectoryL f cmd@CopyDirectoryCommand{..} - = fmap (\x -> cmd { destinationDirectory = x }) - (f destinationDirectory) -{-# INLINE destinationDirectoryL #-} - --- | Lens for 'useCopyOnWrite'. --- --- @since 1.16.0.0 -useCopyOnWriteL :: Lens' CopyDirectoryCommand Bool -useCopyOnWriteL f cmd@CopyDirectoryCommand{..} - = fmap (\x -> cmd { useCopyOnWrite = x }) - (f useCopyOnWrite) -{-# INLINE useCopyOnWriteL #-} diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -176,10 +176,8 @@ extraConfigAssert = let cConfig = mempty - { plan = mempty { postgresConfigFile = [("log_min_duration_statement","'100ms'")] } - } cAssert db = withConn db $ \conn -> do [PG.Only actualDuration] <- PG.query_ conn "SHOW log_min_duration_statement" @@ -191,13 +189,9 @@ defaultIpConfig = let cConfig = mempty - { plan = mempty - { postgresPlan = mempty - { connectionOptions = mempty - { Client.host = pure "127.0.0.1" - } - } - } + { connectionOptions = mempty + { Client.host = pure "127.0.0.1" + } } cAssert db = do @@ -231,7 +225,6 @@ let expectedDescription = "newdb description" cConfig = mempty - { plan = mempty { createDbConfig = pure silentProcessConfig { commandLine = mempty { indexBased = Map.fromList @@ -241,7 +234,6 @@ } } } - } cAssert db = withConn db $ \conn -> do [PG.Only actualDescription] <- PG.query_ conn $ fromString $ unlines @@ -314,9 +306,7 @@ let nonEmptyFolderConfig = memptyConfigAndAssertion { cConfig = defaultConfig { dataDirectory = Permanent dirPath - , plan = (plan defaultConfig) - { initDbConfig = Zlich - } + , initDbConfig = Zlich } } testWithTemporaryDirectory nonEmptyFolderConfig testSuccessfulConfig @@ -397,29 +387,23 @@ -- attempt was made? probably. it "timesout if the connection parameters are wrong" $ do let invalidConfig = mempty - { plan = mempty - { connectionTimeout = pure 0 - , postgresPlan = mempty - { connectionOptions = mempty - { Client.dbname = pure "doesnotexist" - } + { connectionTimeout = pure 0 + , connectionOptions = mempty + { Client.dbname = pure "doesnotexist" } - } } + withConfig (defaultConfig <> invalidConfig) (const $ pure ()) `shouldReturn` Left ConnectionTimedOut it "does not timeout quickly with an invalid connection and large timeout" $ do let invalidConfig = mempty - { plan = mempty - { connectionTimeout = pure maxBound - , postgresPlan = mempty - { connectionOptions = mempty - { Client.dbname = pure "doesnotexist" - } + { connectionTimeout = pure maxBound + , connectionOptions = mempty + { Client.dbname = pure "doesnotexist" } - } } + timeout 100000 (withConfig (defaultConfig <> invalidConfig) (const $ pure ())) `shouldReturn` Nothing {- @@ -445,9 +429,7 @@ } invalidConfig' = invalidConfig - { plan = (plan invalidConfig) - { connectionTimeout = pure 100000 - } + { connectionTimeout = pure 100000 } withConfig invalidConfig' (const $ pure ()) `shouldReturn` Left ConnectionTimedOut @@ -458,10 +440,9 @@ } invalidConfig' = invalidConfig - { plan = (plan invalidConfig) - { connectionTimeout = pure 100000 - } + { connectionTimeout = pure 100000 } + withConfig invalidConfig' (const $ pure ()) `shouldReturn` Left ConnectionTimedOut @@ -474,10 +455,8 @@ it "No initdb plan causes failure" $ do let dontTimeout = defaultConfig - { plan = (plan defaultConfig) - { connectionTimeout = pure maxBound - , initDbConfig = Zlich - } + { connectionTimeout = pure maxBound + , initDbConfig = Zlich } withConfig dontTimeout (const $ pure ()) @@ -500,14 +479,13 @@ it "invalid initdb options cause an error" $ do let invalidConfig = defaultConfig - { plan = (plan defaultConfig) - { initDbConfig = pure silentProcessConfig - { commandLine = mempty - { keyBased = Map.singleton "--super-sync" Nothing - } - } + { initDbConfig = pure silentProcessConfig + { commandLine = mempty + { keyBased = Map.singleton "--super-sync" Nothing } + } } + withConfig invalidConfig (const $ pure ()) >>= \case Right () -> fail "Should not succeed" Left (InitDbFailed {}) -> pure () @@ -515,16 +493,14 @@ it "invalid createdb plan causes an error" $ do let invalidConfig = defaultConfig - { plan = (plan defaultConfig) - { createDbConfig = pure silentProcessConfig - { commandLine = mempty - { indexBased = - Map.singleton 0 "template1" - } - } + { createDbConfig = pure silentProcessConfig + { commandLine = mempty + { indexBased = + Map.singleton 0 "template1" } - + } } + withConfig invalidConfig (const $ pure ()) >>= \case Right () -> fail "Should not succeed" Left (CreateDbFailed {}) -> pure () @@ -549,10 +525,8 @@ path <- getEnv "PATH" let config = defaultConfig - { plan = (plan defaultConfig) { createDbConfig = pure mempty } - } bracket (setEnv "PATH" dir) (const $ setEnv "PATH" path) $ \_ -> withConfig config (const $ pure ()) @@ -615,14 +589,12 @@ , "connectionOptions:" , "connectionTimeout:" , "dataDirectory:" - , "dataDirectoryString:" , "environmentVariables:" , "inherit:" , "initDbConfig:" , "port:" , "postgresConfig:" , "postgresConfigFile:" - , "postgresPlan:" , "socketDirectory:" , "specific:" , "stdErr:" 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.22.0.0 +version: 1.23.0.0 synopsis: Start and stop a temporary postgres description: Start and stop a temporary postgres. See README.md homepage: https://github.com/jfischoff/tmp-postgres#readme @@ -17,7 +17,6 @@ library hs-source-dirs: src exposed-modules: Database.Postgres.Temp - , Database.Postgres.Temp.Config , Database.Postgres.Temp.Internal , Database.Postgres.Temp.Internal.Core , Database.Postgres.Temp.Internal.Config