diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,3 +8,7 @@ Remove the `partial` prefix. Expand abbreviations. Order the Event type creation time. + +1.9.0.0 + #41 Configurable temporary directory + #59 Change EnvVars to EnvironmentVariables 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 @@ -70,6 +70,7 @@ , toConnectionString , toConnectionOptions , toDataDirectory + , toTemporaryDirectory , makeDataDirPermanent -- * Monoidial Configuration Types -- ** 'Config' @@ -79,7 +80,7 @@ , planL , socketClassL , dataDirectoryL - , configPortL + , portL -- ** 'Plan' , Plan (..) -- *** 'Plan' lenses @@ -102,9 +103,9 @@ , stdErrL , stdInL , stdOutL - -- ** 'EnvVars' - , EnvVars (..) - -- *** 'EnvVars' Lenses + -- ** 'EnvironmentVariables' + , EnvironmentVariables (..) + -- *** 'EnvironmentVariables' Lenses , inheritL , specificL -- ** 'CommandLineArgs' 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 @@ -20,7 +20,7 @@ -- | Handle for holding temporary resources, the @postgres@ process handle -- and postgres connection information. The 'DB' also includes the --- final 'CompletePlan' that was used to start @initdb@, @createdb@ and +-- final plan used to start @initdb@, @createdb@ and -- @postgres@. See 'toConnectionString' for converting a 'DB' to -- postgresql connection string. data DB = DB @@ -73,6 +73,10 @@ makeDataDirPermanent db = db { dbResources = makeResourcesDataDirPermanent $ dbResources db } + +-- | Get the directory that is used to create other temporary directories +toTemporaryDirectory :: DB -> FilePath +toTemporaryDirectory = resourcesTemporaryDir . dbResources ------------------------------------------------------------------------------- -- Life Cycle Management ------------------------------------------------------------------------------- @@ -223,7 +227,7 @@ listen_addresses = \'IP_ADDRESS\' @ - if it is 'CIpSocket'. If is 'CUnixSocket' then the lines + if it is 'IpSocket'. If is 'UnixSocket' then the lines @ listen_addresses = '' 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 @@ -45,25 +45,25 @@ -- | The environment variables can be declared to -- inherit from the running process or they -- can be specifically added. -data EnvVars = EnvVars +data EnvironmentVariables = EnvironmentVariables { inherit :: Last Bool , specific :: Map String String } deriving stock (Generic, Show, Eq) -instance Semigroup EnvVars where - x <> y = EnvVars +instance Semigroup EnvironmentVariables where + x <> y = EnvironmentVariables { inherit = inherit x <> inherit y , specific = specific y <> specific x } -instance Monoid EnvVars where - mempty = EnvVars mempty mempty +instance Monoid EnvironmentVariables where + mempty = EnvironmentVariables mempty mempty -instance Pretty EnvVars where - pretty EnvVars {..} +instance Pretty EnvironmentVariables where + pretty EnvironmentVariables {..} = text "inherit:" <+> pretty (getLast inherit) <> hardline @@ -74,23 +74,26 @@ -- | 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 +completeEnvironmentVariables + :: [(String, String)] + -> EnvironmentVariables + -> Either [String] [(String, String)] +completeEnvironmentVariables envs EnvironmentVariables {..} = 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. +-- | A type to help combine command line Args. data CommandLineArgs = CommandLineArgs { keyBased :: Map String (Maybe String) - -- ^ Arguments of the form @-h foo@, @--host=foo@ and @--switch@. + -- ^ Args 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. + -- ^ Args that appear at the end of the key based + -- Args. -- The 'Dual' monoid is used so the last key wins. } deriving stock (Generic, Show, Eq) @@ -136,11 +139,11 @@ -- | The monoidial version of 'ProcessConfig'. Used to combine overrides with -- defaults when creating a 'ProcessConfig'. data ProcessConfig = ProcessConfig - { environmentVariables :: EnvVars + { environmentVariables :: EnvironmentVariables -- ^ 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 + -- ^ A monoid for combine command line Args or replacing them , stdIn :: Last Handle -- ^ A monoid for configuring the standard input 'Handle' , stdOut :: Last Handle @@ -205,7 +208,7 @@ completeProcessConfig envs ProcessConfig {..} = runErrors $ do let completeProcessConfigCmdLine = completeCommandLineArgs commandLine completeProcessConfigEnvVars <- eitherToErrors $ - completeEnvVars envs environmentVariables + completeEnvironmentVariables envs environmentVariables completeProcessConfigStdIn <- getOption "stdIn" stdIn completeProcessConfigStdOut <- @@ -261,9 +264,15 @@ -- | 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 +setupDirectoryType + :: String + -- ^ Temporary directory configuration + -> String + -- ^ Directory pattern + -> DirectoryType + -> IO CompleteDirectoryType +setupDirectoryType tempDir pat = \case + Temporary -> CTemporary <$> createTempDirectory tempDir pat Permanent x -> pure $ CPermanent x -- Either create a temporary directory or do nothing @@ -347,12 +356,17 @@ -- | 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 +setupSocketClass + :: String + -- ^ Temporary directory + -> SocketClass + -- ^ The type of socket + -> IO CompleteSocketClass +setupSocketClass tempDir theClass = case theClass of IpSocket mIp -> pure $ CIpSocket $ fromMaybe "127.0.0.1" $ getLast mIp UnixSocket mFilePath -> - CUnixSocket <$> setupDirectoryType "tmp-postgres-socket" mFilePath + CUnixSocket <$> setupDirectoryType tempDir "tmp-postgres-socket" mFilePath -- | Cleanup the UNIX socket temporary directory if one was created. cleanupSocketConfig :: CompleteSocketClass -> IO () @@ -455,38 +469,6 @@ 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 @@ -500,6 +482,9 @@ , port :: Last (Maybe Int) -- ^ A monoid for using an existing port (via 'Just' 'PORT_NUMBER') or -- requesting a free port (via a 'Nothing') + , temporaryDirectory :: Last FilePath + -- ^ The directory used to create other temporary directories. Defaults + -- to \"/tmp\". } deriving stock (Generic) deriving Semigroup via GenericSemigroup Config @@ -520,6 +505,10 @@ <> pretty dataDirectory <> hardline <> text "port:" <+> pretty (getLast port) + <> hardline + <> text "dataDirectory:" + <> softline + <> pretty (getLast temporaryDirectory) -- | Create a 'Plan' that sets the command line options of all processes -- (@initdb@, @postgres@ and @createdb@) using a @@ -583,10 +572,11 @@ setupConfig Config {..} = evalContT $ do envs <- lift getEnvironment thePort <- lift $ maybe getFreePort pure $ join $ getLast port + let resourcesTemporaryDir = fromMaybe "/tmp" $ getLast temporaryDirectory resourcesSocket <- ContT $ bracketOnError - (setupSocketClass socketClass) cleanupSocketConfig + (setupSocketClass resourcesTemporaryDir socketClass) cleanupSocketConfig resourcesDataDir <- ContT $ bracketOnError - (setupDirectoryType "tmp-postgres-data" dataDirectory) cleanupDirectoryType + (setupDirectoryType resourcesTemporaryDir "tmp-postgres-data" dataDirectory) cleanupDirectoryType let hostAndDir = toPlan (hasInitDb plan) (hasCreateDb plan) @@ -604,6 +594,41 @@ cleanupConfig Resources {..} = do cleanupSocketConfig resourcesSocket cleanupDirectoryType resourcesDataDir + +-- | '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. + , resourcesTemporaryDir :: FilePath + -- ^ The directory where other temporary directories are created. + -- Usually \"/tmp\". + } + +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 + } ------------------------------------------------------------------------------- -- Config Generation ------------------------------------------------------------------------------- @@ -679,16 +704,16 @@ 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) +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' -specificL :: Lens' EnvVars (Map String String) -specificL f_aj5i (EnvVars x_aj5j x_aj5k) - = fmap (EnvVars x_aj5j) +specificL :: Lens' EnvironmentVariables (Map String String) +specificL f_aj5i (EnvironmentVariables x_aj5j x_aj5k) + = fmap (EnvironmentVariables x_aj5j) (f_aj5i x_aj5k) {-# INLINE specificL #-} @@ -707,7 +732,7 @@ -- | Lens for 'environmentVariables' environmentVariablesL :: - Lens' ProcessConfig EnvVars + Lens' ProcessConfig EnvironmentVariables environmentVariablesL f_allC (ProcessConfig x_allD x_allE x_allF x_allG x_allH) @@ -849,51 +874,51 @@ -- | 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) +resourcesDataDirL f (resources@Resources {..}) + = fmap (\x -> resources { resourcesDataDir = x }) + (f resourcesDataDir) {-# 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) +resourcesPlanL f (resources@Resources {..}) + = fmap (\x -> resources { resourcesPlan = x }) + (f resourcesPlan) {-# 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) +resourcesSocketL f (resources@Resources {..}) + = fmap (\x -> resources { resourcesSocket = x }) + (f resourcesSocket) {-# 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) +dataDirectoryL f (config@Config{..}) + = fmap (\ x -> config { dataDirectory = x } ) + (f dataDirectory) {-# 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) +planL f (config@Config{..}) + = fmap (\ x -> config { plan = x } ) + (f plan) {-# 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 #-} +portL :: Lens' Config (Last (Maybe Int)) +portL f (config@Config{..}) + = fmap (\ x -> config { port = x } ) + (f port) +{-# INLINE portL #-} -- | 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) +socketClassL f (config@Config{..}) + = fmap (\ x -> config { socketClass = x } ) + (f socketClass) {-# INLINE socketClassL #-} -- | Lens for 'indexBased' diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -70,9 +70,10 @@ expectedDuration = "100ms" extraConfig = "log_min_duration_statement='" <> expectedDuration <> "'" - it "returns the right client options for the plan" $ do + it "returns the right client options for the plan" $ withTempDirectory "/tmp" "tmp-postgres-spec" $ \tmpDir -> do let customPlan = mempty - { plan = mempty + { temporaryDirectory = pure tmpDir + , plan = mempty { postgresPlan = mempty { connectionOptions = mempty { Client.user = pure expectedUser @@ -109,6 +110,8 @@ -- hmm maybe I should provide lenses let combinedResources = defaultConfig <> customPlan + initialFiles <- listDirectory tmpDir + action combinedResources $ \db@DB {..} -> do bracket (PG.connectPostgreSQL $ toConnectionString db) PG.close $ \conn -> do [PG.Only actualDuration] <- PG.query_ conn "SHOW log_min_duration_statement" @@ -123,6 +126,8 @@ Client.password actualOptions `shouldBe` pure expectedPassword lines actualPostgresConfig `shouldContain` defaultPostgresConfig <> [extraConfig] + listDirectory tmpDir `shouldReturn` initialFiles + invalidConfigFailsQuickly :: (Config -> IO ()) -> Spec invalidConfigFailsQuickly action = it "quickly fails with an invalid option" $ do let customPlan = mempty @@ -175,14 +180,6 @@ 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 withInitDbEmptyInitially = describe "with active initDb non-empty folder initially" $ @@ -204,7 +201,7 @@ runner (const $ pure ()) `shouldThrow` (== CreateDbFailed (ExitFailure 1)) spec :: Spec -spec = parallel $ do +spec = do let defaultIpPlan = defaultConfig { socketClass = IpSocket $ Last Nothing } @@ -257,7 +254,7 @@ someStandardTests "postgres" defaultConfigShouldMatchDefaultPlan - describe "start/stop" $ parallel $ do + describe "start/stop" $ do before (pure $ Runner $ \f -> bracket (either throwIO pure =<< start) stop f) $ do someStandardTests "postgres" defaultConfigShouldMatchDefaultPlan 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.8.0.0 +version: 1.9.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