tmp-postgres 1.8.0.0 → 1.9.0.0
raw patch · 6 files changed
+136/−105 lines, 6 files
Files
- CHANGELOG.md +4/−0
- src/Database/Postgres/Temp.hs +5/−4
- src/Database/Postgres/Temp/Internal.hs +6/−2
- src/Database/Postgres/Temp/Internal/Config.hs +111/−86
- test/Spec.hs +9/−12
- tmp-postgres.cabal +1/−1
CHANGELOG.md view
@@ -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
src/Database/Postgres/Temp.hs view
@@ -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'
src/Database/Postgres/Temp/Internal.hs view
@@ -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 = ''
src/Database/Postgres/Temp/Internal/Config.hs view
@@ -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'
test/Spec.hs view
@@ -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
tmp-postgres.cabal view
@@ -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