tmp-postgres 1.15.1.0 → 1.15.1.1
raw patch · 6 files changed
+174/−132 lines, 6 files
Files
- CHANGELOG.md +3/−0
- src/Database/Postgres/Temp.hs +1/−1
- src/Database/Postgres/Temp/Internal.hs +18/−18
- src/Database/Postgres/Temp/Internal/Config.hs +117/−10
- src/Database/Postgres/Temp/Internal/Core.hs +34/−102
- tmp-postgres.cabal +1/−1
CHANGELOG.md view
@@ -1,5 +1,8 @@ Changelog for tmp-postgres +1.15.1.1+ #141 Documentation fixes.+ 1.15.1.0 #119 Add `initdb` cache #134 Expand tilde in Permanent DirectoryType setup.
src/Database/Postgres/Temp.hs view
@@ -2,7 +2,7 @@ This module provides functions for creating a temporary @postgres@ instance. By default it will create a temporary data directory and a temporary directory for a UNIX domain socket for @postgres@ to listen on in addition to-listening on 127.0.0.1 and ::1.+listening on @127.0.0.1@ and @::1@. Here is an example using the expection safe 'with' function:
src/Database/Postgres/Temp/Internal.hs view
@@ -164,7 +164,7 @@ Or using the provided lenses and your favorite lens library: @- custom = defaultConfig & 'planL' . 'postgresConfigFile' '<>~'+ custom = defaultConfig & 'planL' . 'postgresConfigFile' <>~ [ "wal_level = replica" , "archive_mode = on" , "max_wal_senders = 2"@@ -211,7 +211,7 @@ or with lenses: @-'defaultPostgresConf' extra = 'defaultConfig' & 'planL' . 'postgresConfigFile' '<>~' extra+'defaultPostgresConf' extra = 'defaultConfig' & 'planL' . 'postgresConfigFile' <>~ extra @ @since 1.12.0.0@@ -242,7 +242,7 @@ ] {-|-The similar to 'defaultConfig' but all the handles are set to @/dev/null@.+The similar to 'defaultConfig' but all the handles are set to @\/dev\/null@. and uses a @postgresql.conf@ which disables logging: @@@ -620,7 +620,11 @@ ------------------------------------------------------------------------------- -- initdb cache ---------------------------------------------------------------------------------- | Configuration for the @initdb@ data directory cache.+{-|+Configuration for the @initdb@ data directory cache.++@since 1.15.1.0+-} data CacheConfig = CacheConfig { cacheTemporaryDirectory :: FilePath -- ^ Root temporary directory used if 'cacheDirectoryType' is set to@@ -644,6 +648,8 @@ It sets 'cacheDirectoryType' to 'Permanent' @~\/.tmp-postgres@ and 'cacheTemporaryDirectory' to @\/tmp@ (but this is not used when 'Permanent' is set).++@since 1.15.1.0 -} createDefaultCacheConfig :: IO CacheConfig createDefaultCacheConfig = do@@ -678,6 +684,8 @@ {-| Cleanup the cache directory if it was 'Temporary'.++@since 1.15.1.0 -} cleanupInitDbCache :: (Bool, CompleteDirectoryType) -> IO () cleanupInitDbCache = cleanupDirectoryType . snd@@ -688,9 +696,10 @@ Exception safe version of 'setupInitDbCache'. Equivalent to @- 'withDbCacheConfig' = bracket_ ('setupInitDbCache' config) 'cleanupInitDbCache'+ 'withDbCacheConfig' = bracket ('setupInitDbCache' config) 'cleanupInitDbCache' @ +@since 1.15.1.0 -} withDbCacheConfig :: CacheConfig@@ -704,6 +713,8 @@ {-| Equivalent to 'withDbCacheConfig' with the 'CacheConfig' 'createDefaultCacheConfig' makes.++@since 1.15.1.0 -} withDbCache :: ((Bool, CompleteDirectoryType) -> IO a) -> IO a withDbCache action =@@ -712,20 +723,9 @@ {-| Helper to make a 'Config' out of caching info. -Equivalent to--@- toCacheConfig cacheInfo = mempty- { plan = mempty- { initDbCache = pure $ Just $ fmap toFilePath cacheInfo- }- }-@-+@since 1.15.1.0 -} toCacheConfig :: (Bool, CompleteDirectoryType) -> Config toCacheConfig cacheInfo = mempty- { plan = mempty- { initDbCache = pure $ pure $ fmap toFilePath cacheInfo- }+ { initDbCache = pure $ pure $ fmap toFilePath cacheInfo }
src/Database/Postgres/Temp/Internal/Config.hs view
@@ -20,22 +20,29 @@ import Control.DeepSeq import Control.Exception import Control.Monad (join)+import Crypto.Hash.SHA1 (hash) import Control.Monad.Trans.Class import Control.Monad.Trans.Cont+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Base64.URL as Base64+import Data.Char import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) import Data.Maybe import Data.Monoid import Data.Monoid.Generic+import Data.List import qualified Database.PostgreSQL.Simple.Options as Client import GHC.Generics (Generic) import Network.Socket.Free (getFreePort) import System.Directory import System.Environment+import System.Exit (ExitCode(..)) import System.IO import System.IO.Error import System.IO.Temp (createTempDirectory) import System.IO.Unsafe (unsafePerformIO)+import System.Process import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) prettyMap :: (Pretty a, Pretty b) => Map a b -> Doc@@ -203,14 +210,14 @@ , stdErr = pure stderr } --- | A global reference to @/dev/null@ 'Handle'.+-- | A global reference to @\/dev\/null@ 'Handle'. -- -- @since 1.12.0.0 devNull :: Handle devNull = unsafePerformIO (openFile "/dev/null" WriteMode) {-# NOINLINE devNull #-} --- | 'silentProcessConfig' sets the handles to @/dev/null@ and+-- | 'silentProcessConfig' sets the handles to @\/dev\/null@ and -- inherits the environment variables from the calling process. -- -- @since 1.12.0.0@@ -389,6 +396,7 @@ data Plan = Plan { logger :: Last Logger , initDbConfig :: Maybe ProcessConfig+ , copyConfig :: Last (Maybe CopyDirectoryCommand) , createDbConfig :: Maybe ProcessConfig , postgresPlan :: PostgresPlan , postgresConfigFile :: [String]@@ -396,7 +404,6 @@ , connectionTimeout :: Last Int -- ^ Max time to spend attempting to connection to @postgres@. -- Time is in microseconds.- , initDbCache :: Last (Maybe (Bool, FilePath)) } deriving stock (Generic) deriving Semigroup via GenericSemigroup Plan@@ -411,6 +418,9 @@ <> text "initDbConfig:" <> softline <> indent 2 (pretty createDbConfig)+ <> text "copyConfig:"+ <> softline+ <> indent 2 (pretty (getLast copyConfig)) <> hardline <> text "postgresPlan:" <> softline@@ -423,8 +433,6 @@ <> text "dataDirectoryString:" <+> pretty (getLast dataDirectoryString) <> hardline <> text "connectionTimeout:" <+> pretty (getLast connectionTimeout)- <> hardline- <> text "initDbCache:" <+> pretty (getLast initDbCache) -- | Turn a 'Plan' into a 'CompletePlan'. Fails if any values are missing. completePlan :: [(String, String)] -> Plan -> Either [String] CompletePlan@@ -432,6 +440,7 @@ completePlanLogger <- getOption "logger" logger completePlanInitDb <- eitherToErrors $ addErrorContext "initDbConfig: " $ traverse (completeProcessConfig envs) initDbConfig+ completePlanCopy <- getOption "dataDirectoryString" copyConfig completePlanCreateDb <- eitherToErrors $ addErrorContext "createDbConfig: " $ traverse (completeProcessConfig envs) createDbConfig completePlanPostgres <- eitherToErrors $ addErrorContext "postgresPlan: " $@@ -441,8 +450,6 @@ dataDirectoryString completePlanConnectionTimeout <- getOption "connectionTimeout" connectionTimeout- completePlanCacheDirectory <- getOption "initDbCache"- initDbCache pure CompletePlan {..} @@ -474,6 +481,7 @@ , temporaryDirectory :: Last FilePath -- ^ The directory used to create other temporary directories. Defaults -- to @/tmp@.+ , initDbCache :: Last (Maybe (Bool, FilePath)) } deriving stock (Generic) deriving Semigroup via GenericSemigroup Config@@ -498,6 +506,8 @@ <> text "temporaryDirectory:" <> softline <> pretty (getLast temporaryDirectory)+ <> hardline+ <> text "initDbCache:" <+> pretty (getLast initDbCache) socketDirectoryToConfig :: FilePath -> [String] socketDirectoryToConfig dir =@@ -505,6 +515,101 @@ , "unix_socket_directories = '" <> dir <> "'" ] +-------------------------------------------------------------------------------+-- Caching+-------------------------------------------------------------------------------+getInitDbVersion :: IO String+getInitDbVersion = readProcessWithExitCode "initdb" ["--version"] "" >>= \case+ (ExitSuccess, outputString, _) -> do+ let+ theLastPart = last $ words outputString+ versionPart = takeWhile (\x -> isDigit x || x == '.' || x == '-') theLastPart+ pure $ if last versionPart == '.'+ then init versionPart+ else versionPart++ (startErrorExitCode, startErrorStdOut, startErrorStdErr) ->+ throwIO InitDbFailed {..}++makeCommandLine :: String -> CompleteProcessConfig -> String+makeCommandLine command CompleteProcessConfig {..} =+ let envs = unwords $ map (\(x, y) -> x <> "=" <> y) completeProcessConfigEnvVars+ args = unwords completeProcessConfigCmdLine+ in envs <> " " <> command <> args++makeInitDbCommandLine :: CompleteProcessConfig -> String+makeInitDbCommandLine = makeCommandLine "initdb"++makeArgumentHash :: String -> String+makeArgumentHash = BSC.unpack . Base64.encode . hash . BSC.pack++makeCachePath :: FilePath -> String -> IO String+makeCachePath cacheFolder cmdLine = do+ version <- getInitDbVersion+ let theHash = makeArgumentHash cmdLine+ pure $ cacheFolder <> "/" <> version <> "/" <> theHash+++splitDataDirectory :: CompleteProcessConfig -> (Maybe String, CompleteProcessConfig)+splitDataDirectory old =+ let isDataDirectoryFlag xs = "-D" `isPrefixOf` xs || "--pgdata=" `isPrefixOf` xs+ (dataDirectoryArgs, otherArgs) =+ partition isDataDirectoryFlag $ completeProcessConfigCmdLine old++ firstDataDirectoryArg = flip fmap (listToMaybe dataDirectoryArgs) $ \case+ '-':'D':' ':theDir -> theDir+ '-':'D':theDir -> theDir+ '-':'-':'p':'g':'d':'a':'t':'a':'=':theDir -> theDir+ _ -> error "splitDataDirectory not possible"++ filteredEnvs = filter (not . ("PGDATA"==) . fst) $+ completeProcessConfigEnvVars old++ clearedConfig = old+ { completeProcessConfigCmdLine = otherArgs+ , completeProcessConfigEnvVars = filteredEnvs+ }++ in (firstDataDirectoryArg, clearedConfig)++addDataDirectory :: String -> CompleteProcessConfig -> CompleteProcessConfig+addDataDirectory theDataDirectory x = x+ { completeProcessConfigCmdLine =+ ("--pgdata=" <> theDataDirectory) : completeProcessConfigCmdLine x+ }++cachePlan :: CompletePlan -> Bool -> FilePath -> IO CompletePlan+cachePlan plan@CompletePlan {..} cow cacheDirectory = case completePlanInitDb of+ Nothing -> pure plan+ Just theConfig -> do+ let (mtheDataDirectory, clearedConfig) = splitDataDirectory theConfig+ theDataDirectory <- maybe+ (throwIO $ FailedToFindDataDirectory (show $ pretty clearedConfig))+ pure+ mtheDataDirectory++ let theCommandLine = makeInitDbCommandLine clearedConfig++ cachePath <- makeCachePath cacheDirectory theCommandLine++ let cachedDataDirectory = cachePath <> "/data"++ theInitDbPlan <- doesDirectoryExist cachePath >>= \case+ True -> pure $ Nothing+ False -> do+ createDirectoryIfMissing True cachePath+ writeFile (cachePath <> "/commandLine.log") theCommandLine+ pure $ pure $ addDataDirectory cachedDataDirectory clearedConfig++ pure plan+ { completePlanCopy = pure $ CopyDirectoryCommand+ { copyDirectoryCommandSrc = cachedDataDirectory+ , copyDirectoryCommandDst = theDataDirectory+ , copyDirectoryCommandCow = cow+ }+ , completePlanInitDb = theInitDbPlan+ }+ -- | Create a 'Plan' 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@@ -526,7 +631,6 @@ , dataDirectoryString = pure dataDirectoryString , connectionTimeout = pure (60 * 1000000) -- 1 minute , logger = pure print- , initDbCache = pure Nothing , postgresPlan = mempty { postgresConfig = standardProcessConfig { commandLine = mempty@@ -560,9 +664,9 @@ } } else Nothing+ , copyConfig = pure Nothing } - -- | Create all the temporary resources from a 'Config'. This also combines the -- 'Plan' from 'toPlan' with the @extra@ 'Config' passed in. setupConfig@@ -573,6 +677,7 @@ envs <- lift getEnvironment thePort <- lift $ maybe getFreePort pure $ join $ getLast port let resourcesTemporaryDir = fromMaybe "/tmp" $ getLast temporaryDirectory+ resourcesInitDbCache = join $ getLast initDbCache resourcesSocketDirectory <- ContT $ bracketOnError (setupDirectoryType resourcesTemporaryDir "tmp-postgres-socket" socketDirectory) cleanupDirectoryType resourcesDataDir <- ContT $ bracketOnError@@ -584,9 +689,10 @@ (toFilePath resourcesSocketDirectory) (toFilePath resourcesDataDir) finalPlan = hostAndDir <> plan- resourcesPlan <- lift $+ uncachedPlan <- lift $ either (throwIO . CompletePlanFailed (show $ pretty finalPlan)) pure $ completePlan envs finalPlan+ resourcesPlan <- lift $ maybe (pure uncachedPlan) (uncurry $ cachePlan uncachedPlan) resourcesInitDbCache pure Resources {..} -- | Free the temporary resources created by 'setupConfig'.@@ -616,6 +722,7 @@ , resourcesTemporaryDir :: FilePath -- ^ The directory where other temporary directories are created. -- Usually @/tmp.+ , resourcesInitDbCache :: Maybe (Bool, FilePath) } instance Pretty Resources where
src/Database/Postgres/Temp/Internal/Core.hs view
@@ -9,16 +9,11 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_, withAsync) import Control.Exception-import Control.Monad (forever, unless, void)-import Crypto.Hash.SHA1 (hash)+import Control.Monad import qualified Data.ByteString.Char8 as BSC-import qualified Data.ByteString.Base64.URL as Base64-import Data.Char import Data.Foldable (for_) import Data.IORef-import Data.Maybe import Data.Monoid-import Data.List import Data.String import Data.Typeable import qualified Database.PostgreSQL.Simple as PG@@ -154,12 +149,6 @@ <> softline <> text (unwords completeProcessConfigCmdLine) -makeCommandLine :: String -> CompleteProcessConfig -> String-makeCommandLine command CompleteProcessConfig {..} =- let envs = unwords $ map (\(x, y) -> x <> "=" <> y) completeProcessConfigEnvVars- args = unwords completeProcessConfigCmdLine- in envs <> " " <> command <> args- -- | Start a process interactively and return the 'ProcessHandle' startProcess :: String@@ -309,98 +298,42 @@ return result ---------------------------------------------------------------------------------- initdb cache+-- Init command --------------------------------------------------------------------------------getInitDbVersion :: IO String-getInitDbVersion = readProcessWithExitCode "initdb" ["--version"] "" >>= \case- (ExitSuccess, outputString, _) -> do- let- theLastPart = last $ words outputString- versionPart = takeWhile (\x -> isDigit x || x == '.' || x == '-') theLastPart- pure $ if last versionPart == '.'- then init versionPart- else versionPart-- (startErrorExitCode, startErrorStdOut, startErrorStdErr) ->- throwIO InitDbFailed {..}---- TODO We need to remove the data directory!-makeInitDbCommandLine :: CompleteProcessConfig -> String-makeInitDbCommandLine = makeCommandLine "initdb"--makeArgumentHash :: String -> String-makeArgumentHash = BSC.unpack . Base64.encode . hash . BSC.pack--splitDataDirectory :: CompleteProcessConfig -> (Maybe String, CompleteProcessConfig)-splitDataDirectory old =- let isDataDirectoryFlag xs = "-D" `isPrefixOf` xs || "--pgdata=" `isPrefixOf` xs- (dataDirectoryArgs, otherArgs) =- partition isDataDirectoryFlag $ completeProcessConfigCmdLine old-- firstDataDirectoryArg = flip fmap (listToMaybe dataDirectoryArgs) $ \case- '-':'D':' ':theDir -> theDir- '-':'D':theDir -> theDir- '-':'-':'p':'g':'d':'a':'t':'a':'=':theDir -> theDir- _ -> error "splitDataDirectory not possible"-- filteredEnvs = filter (not . ("PGDATA"==) . fst) $- completeProcessConfigEnvVars old-- clearedConfig = old- { completeProcessConfigCmdLine = otherArgs- , completeProcessConfigEnvVars = filteredEnvs- }-- in (firstDataDirectoryArg, clearedConfig)--makeCachePath :: FilePath -> String -> IO String-makeCachePath cacheFolder cmdLine = do- version <- getInitDbVersion- let theHash = makeArgumentHash cmdLine- pure $ cacheFolder <> "/" <> version <> "/" <> theHash--addDataDirectory :: String -> CompleteProcessConfig -> CompleteProcessConfig-addDataDirectory theDataDirectory x = x- { completeProcessConfigCmdLine =- ("--pgdata=" <> theDataDirectory) : completeProcessConfigCmdLine x- }--executeInitDb :: Maybe (Bool, FilePath) -> CompleteProcessConfig -> IO ()-executeInitDb cache config = do- -- helper- let runInitDb theConfig = do- (res, stdOut, stdErr) <- executeProcessAndTee "initdb" theConfig- throwIfNotSuccess (InitDbFailed stdOut stdErr) res+executeInitDb :: CompleteProcessConfig -> IO ()+executeInitDb config = do+ (res, stdOut, stdErr) <- executeProcessAndTee "initdb" config+ throwIfNotSuccess (InitDbFailed stdOut stdErr) res - -- Probably want a MVar to lock this whole operation- void $ case cache of- Nothing -> runInitDb config- Just (copyOnWrite, directoryType) -> do- let (mtheDataDirectory, clearedConfig) = splitDataDirectory config- theDataDirectory <- maybe- (throwIO $ FailedToFindDataDirectory (show $ pretty config))- pure- mtheDataDirectory+data CopyDirectoryCommand = CopyDirectoryCommand+ { copyDirectoryCommandSrc :: FilePath+ , copyDirectoryCommandDst :: FilePath+ , copyDirectoryCommandCow :: Bool+ } deriving (Show, Eq, Ord) - let theCommandLine = makeInitDbCommandLine clearedConfig+instance Pretty CopyDirectoryCommand where+ pretty CopyDirectoryCommand {..}+ = text "copyDirectoryCommandSrc:"+ <> softline+ <> indent 2 (text copyDirectoryCommandSrc)+ <> hardline+ <> text "copyDirectoryCommandDst:"+ <> softline+ <> indent 2 (text copyDirectoryCommandDst)+ <> hardline+ <> text "copyDirectoryCommandCow:"+ <+> (pretty copyDirectoryCommandCow) - cachePath <- makeCachePath directoryType theCommandLine- let newDataDirectory = cachePath <> "/data"- doesDirectoryExist cachePath >>= \case- True -> pure ()- False -> do- createDirectoryIfMissing True cachePath- writeFile (cachePath <> "/commandLine.log") theCommandLine- runInitDb $ addDataDirectory newDataDirectory clearedConfig- -- TODO do a check for macos or linux- let+executeCopyDirectoryCommand :: CopyDirectoryCommand -> IO ()+executeCopyDirectoryCommand CopyDirectoryCommand {..} = do+ let #ifdef darwin_HOST_OS- cpFlags = if copyOnWrite then "cp -Rc " else "cp -R "+ cpFlags = if copyDirectoryCommandCow then "cp -Rc " else "cp -R " #else- cpFlags = if copyOnWrite then "cp -R --reflink=auto " else "cp -R "+ cpFlags = if copyDirectoryCommandCow then "cp -R --reflink=auto " else "cp -R " #endif- copyCommand = cpFlags <> newDataDirectory <> "/* " <> theDataDirectory- throwIfNotSuccess (CopyCachedInitDbFailed copyCommand) =<< system copyCommand+ copyCommand = cpFlags <> copyDirectoryCommandSrc <> "/* " <> copyDirectoryCommandDst+ throwIfNotSuccess (CopyCachedInitDbFailed copyCommand) =<< system copyCommand ------------------------------------------------------------------------------- -- CompletePlan@@ -414,12 +347,12 @@ data CompletePlan = CompletePlan { completePlanLogger :: Logger , completePlanInitDb :: Maybe CompleteProcessConfig+ , completePlanCopy :: Maybe CopyDirectoryCommand , completePlanCreateDb :: Maybe CompleteProcessConfig , completePlanPostgres :: CompletePostgresPlan , completePlanConfig :: String , completePlanDataDirectory :: FilePath , completePlanConnectionTimeout :: Int- , completePlanCacheDirectory :: Maybe (Bool, FilePath) } instance Pretty CompletePlan where@@ -442,9 +375,6 @@ <> hardline <> text "completePlanDataDirectory:" <+> pretty completePlanDataDirectory- <> hardline- <> text "completePlanCacheDirectory:"- <+> pretty completePlanCacheDirectory -- A simple helper to throw 'ExitCode's when they are 'ExitFailure'. throwIfNotSuccess :: Exception e => (ExitCode -> e) -> ExitCode -> IO ()@@ -467,7 +397,9 @@ startPlan :: CompletePlan -> IO PostgresProcess startPlan plan@CompletePlan {..} = do completePlanLogger $ StartPlan $ show $ pretty plan- for_ completePlanInitDb $ executeInitDb completePlanCacheDirectory+ for_ completePlanInitDb executeInitDb++ for_ completePlanCopy executeCopyDirectoryCommand -- Try to give a better error if @initdb@ was not -- configured to run.
tmp-postgres.cabal view
@@ -1,5 +1,5 @@ name: tmp-postgres-version: 1.15.1.0+version: 1.15.1.1 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