tmp-postgres 1.5.0.0 → 1.6.0.0
raw patch · 6 files changed
+291/−89 lines, 6 filesdep +ansi-wl-pprint
Dependencies added: ansi-wl-pprint
Files
- src/Database/Postgres/Temp.hs +5/−7
- src/Database/Postgres/Temp/Internal.hs +29/−7
- src/Database/Postgres/Temp/Internal/Core.hs +76/−24
- src/Database/Postgres/Temp/Internal/Partial.hs +170/−41
- test/Spec.hs +9/−9
- tmp-postgres.cabal +2/−1
src/Database/Postgres/Temp.hs view
@@ -47,11 +47,9 @@ module Database.Postgres.Temp (- -- * Main resource handle- DB (..) -- * Exception safe interface -- $options- , with+ with , withConfig -- * Separate start and stop interface. , start@@ -72,8 +70,12 @@ , toConnectionString -- * Errors , StartError (..)+ -- * Main resource handle+ , DB (..)+ , prettyPrintDB -- * Configuration Types , Config (..)+ , prettyPrintConfig -- ** Directory configuration , DirectoryType (..) , PartialDirectoryType (..)@@ -150,10 +152,6 @@ This is common enough there is `defaultPostgresConf` which is a helper to do this.-- In general you'll want to 'mappend' a config to the 'defaultConfig'- since the 'defaultConfig' setups a client connection to the- @postgres@ database. As an alternative to using 'defaultConfig' one could create a config from connections parameters using 'optionsToDefaultConfig'
src/Database/Postgres/Temp/Internal.hs view
@@ -14,6 +14,7 @@ import Control.Monad.Trans.Cont import qualified Database.PostgreSQL.Simple as PG import qualified Data.Map.Strict as Map+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) -- | Handle for holding temporary resources, the @postgres@ process handle -- and postgres connection information. The 'DB' also includes the@@ -27,13 +28,23 @@ -- ^ @postgres@ process handle and the connection options. } +instance Pretty DB where+ pretty DB {..}+ = text "dbResources"+ <> softline+ <> indent 2 (pretty dbResources)+ <> hardline+ <> text "dbPostgresProcess"+ <> softline+ <> indent 2 (pretty dbPostgresProcess)+ -- | Convert a 'DB' to a connection string. Alternatively one can access the -- 'Client.Options' using--- @postgresProcessClientConfig . dbPostgresProcess@+-- @postgresProcessClientOptions . dbPostgresProcess@ toConnectionString :: DB -> ByteString toConnectionString = Client.toConnectionString- . postgresProcessClientConfig+ . postgresProcessClientOptions . dbPostgresProcess ------------------------------------------------------------------------------- -- Life Cycle Management@@ -133,9 +144,9 @@ -> IO (Either StartError DB) startConfig extra = try $ evalContT $ do dbResources@Resources {..} <-- ContT $ bracketOnError (initConfig extra) shutdownResources+ ContT $ bracketOnError (setupConfig extra) cleanupResources dbPostgresProcess <-- ContT $ bracketOnError (initPlan resourcesPlan) stopPostgresProcess+ ContT $ bracketOnError (startPlan resourcesPlan) stopPostgresProcess pure DB {..} -- | Default start behavior. Equivalent to calling 'startConfig' with the@@ -148,7 +159,7 @@ stop :: DB -> IO () stop DB {..} = do void $ stopPostgresProcess dbPostgresProcess- shutdownResources dbResources+ cleanupResources dbResources -- | Only stop the @postgres@ process but leave any temporary resources. -- Useful for testing backup strategies when used in conjunction with@@ -170,7 +181,7 @@ -- @pg_reload_conf()@. reloadConfig :: DB -> IO () reloadConfig db =- bracket (PG.connectPostgreSQL $ toConnectionString db) PG.close $ \conn -> do+ bracket (PG.connectPostgreSQL $ toConnectionString db) PG.close $ \conn -> (void :: IO [PG.Only Bool] -> IO ()) $ PG.query_ conn "SELECT pg_reload_conf()" -------------------------------------------------------------------------------@@ -178,7 +189,7 @@ ------------------------------------------------------------------------------- -- | Exception safe default database create. Takes an @action@ continuation -- which is given a 'DB' it can use to connect--- to (see 'toConnectionString' or 'postgresProcessClientConfig').+-- to (see 'toConnectionString' or 'postgresProcessClientOptions'). -- All of the database resources are automatically cleaned up on -- completion even in the face of exceptions. withConfig :: Config@@ -217,3 +228,14 @@ } } in startingConfig <> generated++-------------------------------------------------------------------------------+-- Pretty Printing+-------------------------------------------------------------------------------+-- | Display a 'Config'.+prettyPrintConfig :: Config -> String+prettyPrintConfig = show . pretty++-- | Display a 'DB'+prettyPrintDB :: DB -> String+prettyPrintDB = show . pretty
src/Database/Postgres/Temp/Internal/Core.hs view
@@ -1,17 +1,17 @@+{-# OPTIONS_HADDOCK prune #-} {-| This module provides the low level functionality for running @initdb@, @postgres@ and @createdb@ to make a database. -See 'initPlan' for more details.+See 'startPlan' for more details. -} module Database.Postgres.Temp.Internal.Core where-import qualified Database.PostgreSQL.Simple.Options as PostgresClient+import qualified Database.PostgreSQL.Simple.Options as Client import qualified Database.PostgreSQL.Simple as PG import System.Process.Internals import System.Exit (ExitCode(..)) import Data.String import System.Posix.Signals (sigINT, signalProcess) import Control.Exception-import System.Process (getProcessExitCode, waitForProcess) import Data.Foldable (for_) import Control.Concurrent.Async (race_) import Control.Monad (forever, (>=>))@@ -20,6 +20,8 @@ import System.IO import System.Process import Data.Monoid+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))+import qualified Data.ByteString.Char8 as BSC -- | Internal events for debugging data Event@@ -54,9 +56,9 @@ -- | @postgres@ is not ready until we are able to successfully connect. -- 'waitForDB' attempts to connect over and over again and returns -- after the first successful connection.-waitForDB :: PostgresClient.Options -> IO ()+waitForDB :: Client.Options -> IO () waitForDB options = do- let theConnectionString = PostgresClient.toConnectionString options+ let theConnectionString = Client.toConnectionString options startAction = PG.connectPostgreSQL theConnectionString try (bracket startAction PG.close mempty) >>= \case Left (_ :: IOError) -> threadDelay 10000 >> waitForDB options@@ -77,6 +79,19 @@ -- ^ The 'Handle' for standard error } +prettyKeyPair ::(Pretty a, Pretty b) => a -> b -> Doc+prettyKeyPair k v = pretty k <> text ": " <> pretty v++instance Pretty ProcessConfig where+ pretty ProcessConfig {..}+ = text "processConfigEnvVars:"+ <> softline+ <> indent 2 (vsep (map (uncurry prettyKeyPair) processConfigEnvVars))+ <> hardline+ <> text "processConfigCmdLine:"+ <> softline+ <> text (unwords processConfigCmdLine)+ -- | Start a process interactively and return the 'ProcessHandle' startProcess :: String@@ -108,23 +123,40 @@ data PostgresPlan = PostgresPlan { postgresPlanProcessConfig :: ProcessConfig -- ^ The process config for @postgres@- , postgresPlanClientConfig :: PostgresClient.Options+ , postgresPlanClientOptions :: Client.Options -- ^ Connection options. Used to verify that @postgres@ is ready. } +instance Pretty PostgresPlan where+ pretty PostgresPlan {..}+ = text "postgresPlanProcessConfig:"+ <> softline+ <> indent 2 (pretty postgresPlanProcessConfig)+ <> hardline+ <> text "postgresPlanClientOptions:"+ <+> prettyOptions postgresPlanClientOptions++prettyOptions :: Client.Options -> Doc+prettyOptions = text . BSC.unpack . Client.toConnectionString+ -- | The output of calling 'startPostgresProcess'. data PostgresProcess = PostgresProcess- { postgresProcessClientConfig :: PostgresClient.Options+ { postgresProcessClientOptions :: Client.Options -- ^ Connection options , postgresProcessHandle :: ProcessHandle -- ^ @postgres@ process handle } --- | Force all connections to the database to close.--- Called during shutdown as well.-terminateConnections :: PostgresClient.Options-> IO ()+instance Pretty PostgresProcess where+ pretty PostgresProcess {..}+ = text "postgresProcessClientOptions:"+ <+> prettyOptions postgresProcessClientOptions++-- Force all connections to the database to close.+-- Called during shutdown as well.+terminateConnections :: Client.Options-> IO () terminateConnections options = do- let theConnectionString = PostgresClient.toConnectionString options+ let theConnectionString = Client.toConnectionString options terminationQuery = fromString $ unlines [ "SELECT pg_terminate_backend(pid)" , "FROM pg_stat_activity"@@ -132,7 +164,7 @@ ] e <- try $ bracket (PG.connectPostgreSQL theConnectionString) PG.close $ \conn -> PG.execute conn terminationQuery- [getLast $ PostgresClient.dbname options]+ [getLast $ Client.dbname options] case e of Left (_ :: IOError) -> pure () Right _ -> pure ()@@ -145,14 +177,13 @@ OpenHandle p -> do -- try to terminate the connects first. If we can't terminate still -- keep shutting down- terminateConnections postgresProcessClientConfig+ terminateConnections postgresProcessClientOptions signalProcess sigINT p OpenExtHandle {} -> pure () -- TODO log windows is not supported ClosedHandle _ -> return () - exitCode <- waitForProcess postgresProcessHandle- pure exitCode+ waitForProcess postgresProcessHandle -- | Start the @postgres@ process and block until a successful connection -- occurs. A separate thread we continously check to see if the @postgres@@@ -161,7 +192,7 @@ startPostgresProcess logger PostgresPlan {..} = do logger StartPostgres - let startAction = PostgresProcess postgresPlanClientConfig+ let startAction = PostgresProcess postgresPlanClientOptions <$> startProcess "postgres" postgresPlanProcessConfig -- Start postgres and stop if an exception occurs@@ -175,8 +206,8 @@ logger WaitForDB -- We assume that 'template1' exist and make connection -- options to test if postgres is ready.- let options = postgresPlanClientConfig- { PostgresClient.dbname = pure "template1"+ let options = postgresPlanClientOptions+ { Client.dbname = pure "template1" } -- Block until a connection succeeds or postgres crashes@@ -203,19 +234,40 @@ , planDataDirectory :: FilePath } --- | A simple helper to throw 'ExitCode's when they are 'ExitFailure'.+instance Pretty Plan where+ pretty Plan {..}+ = text "planInitDb:"+ <> softline+ <> indent 2 (pretty planInitDb)+ <> hardline+ <> text "planCreateDb:"+ <> softline+ <> indent 2 (pretty planCreateDb)+ <> hardline+ <> text "planPostgres:"+ <> softline+ <> indent 2 (pretty planPostgres)+ <> hardline+ <> text "planConfig:"+ <> softline+ <> indent 2 (pretty planConfig)+ <> hardline+ <> text "planDataDirectory:"+ <+> pretty planDataDirectory++-- A simple helper to throw 'ExitCode's when they are 'ExitFailure'. throwIfNotSuccess :: Exception e => (ExitCode -> e) -> ExitCode -> IO () throwIfNotSuccess f = \case ExitSuccess -> pure () e -> throwIO $ f e --- | 'initPlan' optionally calls @initdb@, optionally calls @createdb@ and+-- | 'startPlan' optionally calls @initdb@, optionally calls @createdb@ and -- unconditionally calls @postgres@. -- Additionally it writes a \"postgresql.conf\" and does not return until -- the @postgres@ process is ready. See 'startPostgresProcess' for more -- details.-initPlan :: Plan -> IO PostgresProcess-initPlan Plan {..} = do+startPlan :: Plan -> IO PostgresProcess+startPlan Plan {..} = do for_ planInitDb $ executeProcess "initdb" >=> throwIfNotSuccess InitDbFailed @@ -231,5 +283,5 @@ pure result -- | Stop the @postgres@ process. See 'stopPostgresProcess' for more details.-shutdownPlan :: PostgresProcess -> IO ExitCode-shutdownPlan = stopPostgresProcess+stopPlan :: PostgresProcess -> IO ExitCode+stopPlan = stopPostgresProcess
src/Database/Postgres/Temp/Internal/Partial.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK prune #-} {-| This module provides types and functions for combining partial configs into a complete configs to ultimately make a 'Plan'. @@ -32,7 +33,13 @@ import System.IO.Error import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) +prettyMap :: (Pretty a, Pretty b) => Map a b -> Doc+prettyMap theMap =+ let xs = Map.toList theMap+ in vsep $ map (uncurry prettyKeyPair) xs+ -- | The environment variables can be declared to -- inherit from the running process or they -- can be specifically added.@@ -53,6 +60,15 @@ instance Monoid PartialEnvVars where mempty = PartialEnvVars mempty mempty +instance Pretty PartialEnvVars where+ pretty PartialEnvVars {..}+ = text "partialEnvVarsInherit:"+ <+> pretty (getLast partialEnvVarsInherit)+ <> hardline+ <> text "partialEnvVarsSpecific:"+ <> softline+ <> indent 2 (prettyMap partialEnvVarsSpecific)+ -- | Combine the current environment -- (if indicated by 'partialEnvVarsInherit') -- with 'partialEnvVarsSpecific'@@ -86,8 +102,20 @@ partialCommandLineArgsIndexBased y <> partialCommandLineArgsIndexBased x } --- | Take values as long as the index is the successor of the--- last index.+instance Pretty PartialCommandLineArgs where+ pretty p@PartialCommandLineArgs {..}+ = text "partialCommandLineArgsKeyBased:"+ <> softline+ <> indent 2 (prettyMap partialCommandLineArgsKeyBased)+ <> hardline+ <> text "partialCommandLineArgsIndexBased:"+ <> softline+ <> indent 2 (prettyMap partialCommandLineArgsIndexBased)+ <> hardline+ <> text "completed:" <+> text (unwords (completeCommandLineArgs p))++-- Take values as long as the index is the successor of the+-- last index. takeWhileInSequence :: [(Int, a)] -> [a] takeWhileInSequence ((0, x):xs) = x : go 0 xs where go _ [] = []@@ -122,6 +150,29 @@ deriving Semigroup via GenericSemigroup PartialProcessConfig deriving Monoid via GenericMonoid PartialProcessConfig +prettyHandle :: Handle -> Doc+prettyHandle _ = text "[HANDLE]"++instance Pretty PartialProcessConfig where+ pretty PartialProcessConfig {..}+ = text "partialProcessConfigEnvVars:"+ <> softline+ <> indent 2 (pretty partialProcessConfigEnvVars)+ <> hardline+ <> text "partialProcessConfigCmdLine:"+ <> softline+ <> indent 2 (pretty partialProcessConfigEnvVars)+ <> hardline+ <> text "partialProcessConfigStdIn:" <+>+ pretty (prettyHandle <$> getLast partialProcessConfigStdIn)+ <> hardline+ <> text "partialProcessConfigStdOut:" <+>+ pretty (prettyHandle <$> getLast partialProcessConfigStdOut)+ <> hardline+ <> text "partialProcessConfigStdErr:" <+>+ pretty (prettyHandle <$> getLast partialProcessConfigStdErr)++ -- | The 'standardProcessConfig' sets the handles to 'stdin', 'stdout' and -- 'stderr' and inherits the environment variables from the calling -- process.@@ -135,11 +186,11 @@ , partialProcessConfigStdErr = pure stderr } --- | A helper to add more info to all the error messages.+-- A helper to add more info to all the error messages. addErrorContext :: String -> Either [String] a -> Either [String] a addErrorContext cxt = either (Left . map (cxt <>)) Right --- | A helper for creating an error if a 'Last' is not defined.+-- A helper for creating an error if a 'Last' is not defined. getOption :: String -> Last a -> Validation [String] a getOption optionName = \case Last (Just x) -> pure x@@ -173,6 +224,11 @@ Permanent x -> x Temporary x -> x +instance Pretty DirectoryType where+ pretty = \case+ Permanent x -> text "Permanent" <+> pretty x+ Temporary x -> text "Temporary" <+> pretty x+ -- | The monoidial version of 'DirectoryType'. Used to combine overrides with -- defaults when creating a 'DirectoryType'. The monoid instance treats -- 'PTemporary' as 'mempty' and takes the last 'PPermanent' value.@@ -183,6 +239,11 @@ -- ^ A temporary file that needs to generated. deriving(Show, Eq, Ord) +instance Pretty PartialDirectoryType where+ pretty = \case+ PPermanent x -> text "Permanent" <+> pretty x+ PTemporary -> text "Temporary"+ instance Semigroup PartialDirectoryType where x <> y = case (x, y) of (a, PTemporary ) -> a@@ -193,12 +254,12 @@ -- | Either create a'Temporary' directory or do nothing to a 'Permanent' -- one.-initDirectoryType :: String -> PartialDirectoryType -> IO DirectoryType-initDirectoryType pattern = \case+setupDirectoryType :: String -> PartialDirectoryType -> IO DirectoryType+setupDirectoryType pattern = \case PTemporary -> Temporary <$> createTempDirectory "/tmp" pattern PPermanent x -> pure $ Permanent x --- | Either create a temporary directory or do nothing+-- Either create a temporary directory or do nothing rmDirIgnoreErrors :: FilePath -> IO () rmDirIgnoreErrors mainDir = do let ignoreDirIsMissing e@@ -208,8 +269,8 @@ -- | Either remove a 'Temporary' directory or do nothing to a 'Permanent' -- one.-shutdownDirectoryType :: DirectoryType -> IO ()-shutdownDirectoryType = \case+cleanupDirectoryType :: DirectoryType -> IO ()+cleanupDirectoryType = \case Permanent _ -> pure () Temporary filePath -> rmDirIgnoreErrors filePath @@ -225,6 +286,11 @@ -- ^ UNIX domain socket deriving (Show, Eq, Ord, Generic, Typeable) +instance Pretty SocketClass where+ pretty = \case+ IpSocket x -> text "IpSocket:" <+> pretty x+ UnixSocket x -> text "UnixSocket:" <+> pretty x+ -- | Create the extra config lines for listening based on the 'SocketClass' socketClassToConfig :: SocketClass -> [String] socketClassToConfig = \case@@ -256,6 +322,11 @@ -- ^ The monoid for combining UNIX socket configuration deriving stock (Show, Eq, Ord, Generic, Typeable) +instance Pretty PartialSocketClass where+ pretty = \case+ PIpSocket x -> "IpSocket:" <+> pretty (getLast x)+ PUnixSocket x -> "UnixSocket" <+> pretty x+ instance Semigroup PartialSocketClass where x <> y = case (x, y) of (PIpSocket a, PIpSocket b) -> PIpSocket $ a <> b@@ -269,18 +340,18 @@ -- | Turn a 'PartialSocketClass' to a 'SocketClass'. If the 'PIpSocket' is -- 'Nothing' default to \"127.0.0.1\". If the is a 'PUnixSocket' -- optionally create a temporary directory if configured to do so.-initPartialSocketClass :: PartialSocketClass -> IO SocketClass-initPartialSocketClass theClass = case theClass of+setupPartialSocketClass :: PartialSocketClass -> IO SocketClass+setupPartialSocketClass theClass = case theClass of PIpSocket mIp -> pure $ IpSocket $ fromMaybe "127.0.0.1" $ getLast mIp PUnixSocket mFilePath ->- UnixSocket <$> initDirectoryType "tmp-postgres-socket" mFilePath+ UnixSocket <$> setupDirectoryType "tmp-postgres-socket" mFilePath -- | Cleanup the UNIX socket temporary directory if one was created.-shutdownSocketConfig :: SocketClass -> IO ()-shutdownSocketConfig = \case+cleanupSocketConfig :: SocketClass -> IO ()+cleanupSocketConfig = \case IpSocket {} -> pure ()- UnixSocket dir -> shutdownDirectoryType dir+ UnixSocket dir -> cleanupDirectoryType dir -- | PartialPostgresPlan data PartialPostgresPlan = PartialPostgresPlan@@ -293,11 +364,21 @@ deriving Semigroup via GenericSemigroup PartialPostgresPlan deriving Monoid via GenericMonoid PartialPostgresPlan +instance Pretty PartialPostgresPlan where+ pretty PartialPostgresPlan {..}+ = text "partialPostgresPlanProcessConfig:"+ <> softline+ <> indent 2 (pretty partialPostgresPlanProcessConfig)+ <> hardline+ <> text "partialPostgresPlanClientConfig:"+ <> softline+ <> indent 2 (prettyOptions partialPostgresPlanClientConfig)+ -- | Turn a 'PartialPostgresPlan' into a 'PostgresPlan'. Fails if any -- values are missing. completePostgresPlan :: [(String, String)] -> PartialPostgresPlan -> Either [String] PostgresPlan completePostgresPlan envs PartialPostgresPlan {..} = validationToEither $ do- let postgresPlanClientConfig = partialPostgresPlanClientConfig+ let postgresPlanClientOptions = partialPostgresPlanClientConfig postgresPlanProcessConfig <- eitherToValidation $ addErrorContext "partialPostgresPlanProcessConfig: " $ completeProcessConfig envs partialPostgresPlanProcessConfig@@ -320,6 +401,26 @@ deriving Semigroup via GenericSemigroup PartialPlan deriving Monoid via GenericMonoid PartialPlan +instance Pretty PartialPlan where+ pretty PartialPlan {..}+ = text "partialPlanInitDb:"+ <> softline+ <> indent 2 (pretty partialPlanInitDb)+ <> hardline+ <> text "partialPlanInitDb:"+ <> softline+ <> indent 2 (pretty partialPlanCreateDb)+ <> hardline+ <> text "partialPlanPostgres:"+ <> softline+ <> indent 2 (pretty partialPlanPostgres)+ <> hardline+ <> text "partialPlanConfig:"+ <> softline+ <> indent 2 (vsep $ map text partialPlanConfig)+ <> hardline+ <> text "partialPlanDataDirectory:" <+> pretty (getLast partialPlanDataDirectory)+ -- | Turn a 'PartialPlan' into a 'Plan'. Fails if any values are missing. completePlan :: [(String, String)] -> PartialPlan -> Either [String] Plan completePlan envs PartialPlan {..} = validationToEither $ do@@ -336,22 +437,22 @@ pure Plan {..} --- | Returns 'True' if the 'PartialPlan' has a--- 'Just' 'partialPlanInitDb'+-- 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'+-- 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'.+-- and includes the final 'Plan' that can be used with 'startPlan'.+-- See 'setupConfig' for an example of how to create a 'Resources'. data Resources = Resources { resourcesPlan :: Plan- -- ^ Final 'Plan'. See 'initPlan' for information on 'Plan's+ -- ^ Final 'Plan'. See 'startPlan' for information on 'Plan's , resourcesSocket :: SocketClass -- ^ The 'SocketClass'. Used to track if a temporary directory was made -- as the socket location.@@ -359,6 +460,18 @@ -- ^ 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+ -- | The high level options for overriding default behavior. data Config = Config { configPlan :: PartialPlan@@ -377,6 +490,22 @@ deriving Semigroup via GenericSemigroup Config deriving Monoid via GenericMonoid Config +instance Pretty Config where+ pretty Config {..}+ = text "configPlan:"+ <> softline+ <> pretty configPlan+ <> hardline+ <> text "configSocket:"+ <> softline+ <> pretty configSocket+ <> hardline+ <> text "configDataDir:"+ <> softline+ <> pretty configDataDir+ <> hardline+ <> text "configPort:" <+> pretty (getLast configPort)+ -- | Create a 'PartialPlan' that sets the command line options of all processes -- (@initdb@, @postgres@ and @createdb@) using a toPlan@@ -432,17 +561,17 @@ -- | Create all the temporary resources from a 'Config'. This also combines the -- 'PartialPlan' from 'toPlan' with the @extraConfig@ passed in.-initConfig+setupConfig :: Config -- ^ @extraConfig@ to 'mappend' after the default config -> IO Resources-initConfig Config {..} = evalContT $ do+setupConfig Config {..} = evalContT $ do envs <- lift getEnvironment port <- lift $ maybe getFreePort pure $ join $ getLast configPort resourcesSocket <- ContT $ bracketOnError- (initPartialSocketClass configSocket) shutdownSocketConfig+ (setupPartialSocketClass configSocket) cleanupSocketConfig resourcesDataDir <- ContT $ bracketOnError- (initDirectoryType "tmp-postgres-data" configDataDir) shutdownDirectoryType+ (setupDirectoryType "tmp-postgres-data" configDataDir) cleanupDirectoryType let hostAndDirPartial = toPlan (hasInitDb configPlan) (hasCreateDb configPlan)@@ -454,11 +583,11 @@ completePlan envs finalPlan pure Resources {..} --- | Free the temporary resources created by 'initConfig'-shutdownResources :: Resources -> IO ()-shutdownResources Resources {..} = do- shutdownSocketConfig resourcesSocket- shutdownDirectoryType resourcesDataDir+-- | Free the temporary resources created by 'setupConfig'+cleanupResources :: Resources -> IO ()+cleanupResources Resources {..} = do+ cleanupSocketConfig resourcesSocket+ cleanupDirectoryType resourcesDataDir ------------------------------------------------------------------------------- -- Config Generation -------------------------------------------------------------------------------@@ -474,16 +603,16 @@ , configSocket = maybe mempty hostToSocketClass $ getLast host } )--- | Convert the 'Client.Options' to a 'PartialPlan' that can--- be connected to with the 'Client.Options'.+-- Convert the 'Client.Options' to a 'PartialPlan' that can+-- be connected to with the 'Client.Options'. optionsToPlan :: Client.Options -> PartialPlan optionsToPlan opts@Client.Options {..} = maybe mempty dbnameToPlan (getLast dbname) <> maybe mempty userToPlan (getLast user) <> clientOptionsToPlan opts --- | Wrap the 'Client.Options' in an appropiate--- 'PartialPostgresPlan'+-- Wrap the 'Client.Options' in an appropiate+-- 'PartialPostgresPlan' clientOptionsToPlan :: Client.Options -> PartialPlan clientOptionsToPlan opts = mempty { partialPlanPostgres = mempty@@ -491,7 +620,7 @@ } } --- | Create a 'PartialPlan' given a user+-- Create a 'PartialPlan' given a user userToPlan :: String -> PartialPlan userToPlan user = mempty { partialPlanCreateDb = pure $ mempty@@ -506,8 +635,8 @@ } } --- | Adds a @createdb@ PartialProcessPlan with the argument--- as the database name.+-- Adds a @createdb@ PartialProcessPlan with the argument+-- as the database name. dbnameToPlan :: String -> PartialPlan dbnameToPlan dbName = mempty { partialPlanCreateDb = pure $ mempty@@ -517,8 +646,8 @@ } } --- | Parse a host string as either an UNIX domain socket directory--- or a domain or IP.+-- Parse a host string as either an UNIX domain socket directory+-- or a domain or IP. hostToSocketClass :: String -> PartialSocketClass hostToSocketClass hostOrSocketPath = case hostOrSocketPath of '/' : _ -> PUnixSocket $ PPermanent hostOrSocketPath
test/Spec.hs view
@@ -47,18 +47,18 @@ let Resources {..} = dbResources Plan {..} = resourcesPlan PostgresPlan {..} = planPostgres- Client.dbname postgresPlanClientConfig `shouldBe` pure "postgres"+ Client.dbname postgresPlanClientOptions `shouldBe` pure "postgres" let Temporary tmpDataDir = resourcesDataDir tmpDataDir `shouldStartWith` "/tmp/tmp-postgres-data"- let Just port = getLast $ Client.port postgresPlanClientConfig+ let Just port = getLast $ Client.port postgresPlanClientOptions port `shouldSatisfy` (>32768) let UnixSocket (Temporary unixSocket) = resourcesSocket unixSocket `shouldStartWith` "/tmp/tmp-postgres-socket"- postgresPlanClientConfig `shouldBe`+ postgresPlanClientOptions `shouldBe` (mempty- { Client.port = Client.port postgresPlanClientConfig- , Client.host = Client.host postgresPlanClientConfig- , Client.dbname = Client.dbname postgresPlanClientConfig+ { Client.port = Client.port postgresPlanClientOptions+ , Client.host = Client.host postgresPlanClientOptions+ , Client.dbname = Client.dbname postgresPlanClientOptions } ) @@ -116,7 +116,7 @@ let Resources {..} = dbResources Plan {..} = resourcesPlan- actualOptions = postgresPlanClientConfig planPostgres+ actualOptions = postgresPlanClientOptions planPostgres actualPostgresConfig = planConfig Client.user actualOptions `shouldBe` pure expectedUser Client.dbname actualOptions `shouldBe` pure expectedDbName@@ -368,8 +368,8 @@ reloadConfig db - let Just port = getLast $ Client.port $ postgresProcessClientConfig dbPostgresProcess- Just host = getLast $ Client.host $ postgresProcessClientConfig dbPostgresProcess+ let Just port = getLast $ Client.port $ postgresProcessClientOptions dbPostgresProcess+ Just host = getLast $ Client.host $ postgresProcessClientOptions dbPostgresProcess backupCommand = "pg_basebackup -D " ++ baseBackupFile ++ " --format=tar -p" ++ show port ++ " -h" ++ host
tmp-postgres.cabal view
@@ -1,5 +1,5 @@ name: tmp-postgres-version: 1.5.0.0+version: 1.6.0.0 synopsis: Start and stop a temporary postgres description: @tmp-postgres@ provides functions creating a temporary @postgres@ instance.@@ -66,6 +66,7 @@ , either , transformers , containers+ , ansi-wl-pprint ghc-options: -Wall default-language: Haskell2010