diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. 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 @@ -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'. diff --git a/src/Database/Postgres/Temp/Internal/Core.hs b/src/Database/Postgres/Temp/Internal/Core.hs --- a/src/Database/Postgres/Temp/Internal/Core.hs +++ b/src/Database/Postgres/Temp/Internal/Core.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 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.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