tmp-postgres 1.32.0.0 → 1.32.0.1
raw patch · 5 files changed
+101/−43 lines, 5 files
Files
- CHANGELOG.md +4/−0
- src/Database/Postgres/Temp/Internal/Config.hs +50/−37
- src/Database/Postgres/Temp/Internal/Core.hs +44/−4
- test/Main.hs +2/−1
- tmp-postgres.cabal +1/−1
CHANGELOG.md view
@@ -1,5 +1,9 @@ Changelog for tmp-postgres +1.32.0.1+ #234 Extend core with a initdb cache primitive+ #232 Fix multithread initdb creation bug+ 1.32.0.0 #235 Fixed bug where nested calls to cacheAction would deadlock. cacheAction no longer creates parent directories.
src/Database/Postgres/Temp/Internal/Config.hs view
@@ -32,6 +32,7 @@ import Data.Monoid import Data.Monoid.Generic import Data.List+import Data.Traversable import qualified Database.PostgreSQL.Simple.Options as Client import GHC.Generics (Generic) import Network.Socket.Free (getFreePort)@@ -421,16 +422,13 @@ completePlan :: [(String, String)] -> String -> Config -> Either [String] Plan completePlan envs dataDirectoryString config@Config {..} = do ( completePlanLogger- , completePlanInitDb , completePlanCreateDb , completePlanPostgres , completePlanDataDirectory , completePlanConnectionTimeout ) <- runErrors- $ (,,,,,)+ $ (,,,,) <$> getOption "logger" logger- <*> eitherToErrors (addErrorContext "initDbConfig: " $- traverse (completeProcessConfig envs) $ getAccum initDbConfig) <*> eitherToErrors (addErrorContext "createDbConfig: " $ traverse (completeProcessConfig envs) $ getAccum createDbConfig) <*> eitherToErrors (addErrorContext "postgresPlan: "@@ -442,8 +440,54 @@ completePlanCopy = completeCopyDirectory completePlanDataDirectory <$> join (getLast copyConfig) + completePlanInitDb <- addErrorContext "initDbConfig: " $ completeInitDb envs dataDirectoryString config+ pure Plan {..} +removeDataDirectory :: ProcessConfig -> ProcessConfig+removeDataDirectory processConfig@ProcessConfig{..} =+ let CommandLineArgs {..} = commandLine+ newCommandLine = commandLine+ { keyBased = Map.delete "--pgdata=" $ Map.delete "-D" keyBased+ }+ newEnvironmentVariables = environmentVariables+ { specific = Map.delete "PGDATA" $ specific environmentVariables+ }++ in processConfig+ { commandLine = newCommandLine+ , environmentVariables = newEnvironmentVariables+ }++-- This needs the complete data directory like completeCopyDirectory+completeInitDb :: [(String, String)] -> FilePath -> Config -> Either [String] (Maybe (Either CompleteProcessConfig InitDbCachePlan))+completeInitDb envs theDataDirectory Config {..} = for (getAccum initDbConfig) $ \theInitDbConfig -> case join $ getLast initDbCache of+ Nothing -> Left <$> completeProcessConfig envs theInitDbConfig+ Just (cow, cacheDirectory) -> do+ let+ clearedConfig = removeDataDirectory theInitDbConfig+++ completeClearedPlan <- completeProcessConfig envs clearedConfig+ let+ cachePath = makeCachePath cacheDirectory theCommandLine+ cachePlanDataDirectory = cachePath <> "/data"+ cachePlanCopy = CompleteCopyDirectoryCommand+ { copyDirectoryCommandSrc = cachePlanDataDirectory+ , copyDirectoryCommandDst = theDataDirectory+ , copyDirectoryCommandCow = cow+ }+ theCommandLine = makeInitDbCommandLine completeClearedPlan++ modifiedConfig = clearedConfig <> mempty+ { commandLine = mempty+ { keyBased = Map.fromList [("--pgdata=", Just cachePlanDataDirectory)]+ }+ }++ cachePlanInitDb <- completeProcessConfig envs modifiedConfig+ pure $ Right InitDbCachePlan {..}+ -- Returns 'True' if the 'Config' has a -- 'Just' 'initDbConfig'. hasInitDb :: Config -> Bool@@ -679,37 +723,6 @@ ("--pgdata=" <> theDataDirectory) : completeProcessConfigCmdLine x } -cachePlan :: Plan -> Bool -> FilePath -> IO Plan-cachePlan plan@Plan {..} 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- 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 $ CompleteCopyDirectoryCommand- { copyDirectoryCommandSrc = cachedDataDirectory- , copyDirectoryCommandDst = theDataDirectory- , copyDirectoryCommandCow = cow- }- , completePlanInitDb = theInitDbPlan- }- -- | 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@@ -785,10 +798,10 @@ (toFilePath resourcesSocketDirectory) (toFilePath resourcesDataDir) finalPlan = hostAndDir <> config- uncachedPlan <- lift $+ resourcesPlan <- lift $ either (throwIO . PlanFailed (show $ pretty finalPlan)) pure $ completePlan envs (toFilePath resourcesDataDir) finalPlan- resourcesPlan <- lift $ maybe (pure uncachedPlan) (uncurry $ cachePlan uncachedPlan) resourcesInitDbCache+-- resourcesPlan <- lift $ maybe (pure uncachedPlan) (uncurry $ cachePlan uncachedPlan) resourcesInitDbCache pure Resources {..} -- | Free the temporary resources created by 'setupConfig'.
src/Database/Postgres/Temp/Internal/Core.hs view
@@ -6,7 +6,7 @@ -} module Database.Postgres.Temp.Internal.Core where -import Control.Concurrent (threadDelay)+import Control.Concurrent import Control.Concurrent.Async (race_, withAsync) import Control.Exception import Control.Monad@@ -19,6 +19,7 @@ import System.Directory import System.Exit (ExitCode(..)) import System.IO+import System.IO.Unsafe (unsafePerformIO) import System.Posix.Signals (sigINT, sigQUIT, signalProcess) import System.Process import System.Process.Internals@@ -347,6 +348,42 @@ executeCreateDb config = do (res, stdOut, stdErr) <- executeProcessAndTee "createdb" config throwIfNotSuccess (CreateDbFailed stdOut stdErr) res++-- The DataDirectory and the initdb data directory must match!+data InitDbCachePlan = InitDbCachePlan+ { cachePlanDataDirectory :: FilePath+ , cachePlanInitDb :: CompleteProcessConfig+ , cachePlanCopy :: CompleteCopyDirectoryCommand+ }++instance Pretty InitDbCachePlan where+ pretty InitDbCachePlan {..}+ = text "cachePlanDataDirectory:"+ <> softline+ <> indent 2 (pretty cachePlanDataDirectory)+ <> hardline+ <> text "cachePlanInitDb:"+ <> softline+ <> indent 2 (pretty cachePlanInitDb)+ <> hardline+ <> text "cachePlanCopy:"+ <> softline+ <> indent 2 (pretty cachePlanCopy)++cacheLock :: MVar ()+cacheLock = unsafePerformIO $ newMVar ()+{-# NOINLINE cacheLock #-}++executeInitDbCachePlan :: InitDbCachePlan -> IO ()+executeInitDbCachePlan InitDbCachePlan {..} = do+ withMVar cacheLock $ \_ -> do+ -- Check if the data directory exists+ exists <- doesDirectoryExist cachePlanDataDirectory+ -- If it does not call initdb+ unless exists $ executeInitDb cachePlanInitDb+ -- call the copy++ executeCopyDirectoryCommand cachePlanCopy ------------------------------------------------------------------------------- -- Plan -------------------------------------------------------------------------------@@ -360,7 +397,7 @@ -- higher level plan generation is not sufficent. data Plan = Plan { completePlanLogger :: Logger- , completePlanInitDb :: Maybe CompleteProcessConfig+ , completePlanInitDb :: Maybe (Either CompleteProcessConfig InitDbCachePlan) , completePlanCopy :: Maybe CompleteCopyDirectoryCommand , completePlanCreateDb :: Maybe CompleteProcessConfig , completePlanPostgres :: CompletePostgresPlan@@ -369,11 +406,14 @@ , completePlanConnectionTimeout :: Int } +eitherPretty :: (Pretty a, Pretty b) => Either a b -> Doc+eitherPretty = either pretty pretty+ instance Pretty Plan where pretty Plan {..} = text "completePlanInitDb:" <> softline- <> indent 2 (pretty completePlanInitDb)+ <> indent 2 (pretty $ fmap eitherPretty completePlanInitDb) <> hardline <> text "completePlanCopy:" <> softline@@ -402,7 +442,7 @@ startPlan :: Plan -> IO PostgresProcess startPlan plan@Plan {..} = do completePlanLogger $ StartPlan $ show $ pretty plan- for_ completePlanInitDb executeInitDb+ for_ completePlanInitDb $ either executeInitDb executeInitDbCachePlan for_ completePlanCopy executeCopyDirectoryCommand
test/Main.hs view
@@ -338,7 +338,7 @@ , cacheUseCopyOnWrite = True } withDbCacheConfig theCacheConfig $ \cacheInfo -> do- withConfig' (config <> cacheConfig cacheInfo) $ const $ pure ()+ withConfig' (config <> cacheConfig cacheInfo <> verboseConfig) $ const $ pure () -- see if there is a cache tmpFiles <- listDirectory dirPath @@ -624,6 +624,7 @@ let action db = withConn db $ \conn -> do _ <- PG.execute_ conn "BEGIN; CREATE TABLE foo ( id int );" void $ PG.execute_ conn "INSERT INTO foo (id) VALUES (1); END;"+ putStrLn "hey" withTempDirectory "/tmp" "tmp-postgres-cache-action" $ \cachePath -> do let theFinalCachePath = cachePath <> "/cached" cacheAction theFinalCachePath action (defaultConfig { dataDirectory = Permanent theFinalCachePath } ) >>= \case
tmp-postgres.cabal view
@@ -1,5 +1,5 @@ name: tmp-postgres-version: 1.32.0.0+version: 1.32.0.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