From b6ae270125778050fd3299ef18b96a54f330e78d Mon Sep 17 00:00:00 2001 From: Jonathan Fischoff Date: Tue, 17 Dec 2019 07:56:34 -0800 Subject: [PATCH 1/2] progress --- src/Database/Postgres/Temp/Internal.hs | 4 --- src/Database/Postgres/Temp/Internal/Config.hs | 32 +++++++++++-------- src/Database/Postgres/Temp/Internal/Core.hs | 10 ++++-- test/Main.hs | 26 +++++++++++++++ 4 files changed, 52 insertions(+), 20 deletions(-) diff --git a/src/Database/Postgres/Temp/Internal.hs b/src/Database/Postgres/Temp/Internal.hs index bb44272..d5b5cb7 100644 --- a/src/Database/Postgres/Temp/Internal.hs +++ b/src/Database/Postgres/Temp/Internal.hs @@ -662,10 +662,6 @@ snapshotConfig = fromFilePathConfig . toFilePath . unSnapshot ------------------------------------------------------------------------------- -- cacheAction ------------------------------------------------------------------------------- -cacheLock :: MVar () -cacheLock = unsafePerformIO $ newMVar () -{-# NOINLINE cacheLock #-} - {-| Check to see if a cached data directory exists. diff --git a/src/Database/Postgres/Temp/Internal/Config.hs b/src/Database/Postgres/Temp/Internal/Config.hs index 6c8fc28..52658c3 100644 --- a/src/Database/Postgres/Temp/Internal/Config.hs +++ b/src/Database/Postgres/Temp/Internal/Config.hs @@ -17,6 +17,7 @@ module Database.Postgres.Temp.Internal.Config where import Database.Postgres.Temp.Internal.Core import Control.Applicative.Lift +import Control.Concurrent import Control.DeepSeq import Control.Exception import Control.Monad (join) @@ -679,6 +680,7 @@ addDataDirectory theDataDirectory x = x ("--pgdata=" <> theDataDirectory) : completeProcessConfigCmdLine x } + cachePlan :: Plan -> Bool -> FilePath -> IO Plan cachePlan plan@Plan {..} cow cacheDirectory = case completePlanInitDb of Nothing -> pure plan @@ -694,21 +696,23 @@ cachePlan plan@Plan {..} cow cacheDirectory = case completePlanInitDb of 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 + withMVar cacheLock $ \_ -> do + theInitDbPlan <- doesFileExist (cachedDataDirectory <> "/PG_VERSION") >>= \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 } - , completePlanInitDb = theInitDbPlan - } + -- | Create a 'Config' that sets the command line options of all processes -- (@initdb@, @postgres@ and @createdb@). This the @generated@ plan diff --git a/src/Database/Postgres/Temp/Internal/Core.hs b/src/Database/Postgres/Temp/Internal/Core.hs index c4f4e80..ea375e2 100644 --- a/src/Database/Postgres/Temp/Internal/Core.hs +++ b/src/Database/Postgres/Temp/Internal/Core.hs @@ -6,7 +6,7 @@ See 'startPlan' for more details. -} 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 qualified Database.PostgreSQL.Simple.Options as Client 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 @@ -330,6 +331,10 @@ instance Pretty CompleteCopyDirectoryCommand where <> text "copyDirectoryCommandCow:" <+> pretty copyDirectoryCommandCow +cacheLock :: MVar () +cacheLock = unsafePerformIO $ newMVar () +{-# NOINLINE cacheLock #-} + executeCopyDirectoryCommand :: CompleteCopyDirectoryCommand -> IO () executeCopyDirectoryCommand CompleteCopyDirectoryCommand {..} = do let @@ -339,7 +344,8 @@ executeCopyDirectoryCommand CompleteCopyDirectoryCommand {..} = do cpFlags = if copyDirectoryCommandCow then "cp -R --reflink=auto " else "cp -R " #endif copyCommand = cpFlags <> copyDirectoryCommandSrc <> "/* " <> copyDirectoryCommandDst - throwIfNotSuccess (CopyCachedInitDbFailed copyCommand) =<< system copyCommand + withMVar cacheLock $ \_ -> + throwIfNotSuccess (CopyCachedInitDbFailed copyCommand) =<< system copyCommand -- | Call @createdb@ and tee the output to return if there is an -- an exception. Throws 'CreateDbFailed'. diff --git a/test/Main.hs b/test/Main.hs index 8636cb7..9deee52 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -385,6 +385,18 @@ happyPaths = describe "succeeds with" $ do assertConnection db withConn db $ \conn -> countDbs conn `shouldReturn` 3 + it "withDbCache works if two threads try to create a cache at the same time" $ do + withTempDirectory "/tmp" "tmp-postgres-parallel-cache-test" $ \dirPath -> do + let theCacheConfig = CacheConfig + { cacheTemporaryDirectory = dirPath + , cacheDirectoryType = Temporary + , cacheUseCopyOnWrite = True + } + withDbCacheConfig theCacheConfig $ \cacheInfo -> do + let + theConfig = defaultConfig { temporaryDirectory = pure dirPath } <> cacheConfig cacheInfo + theCacheAction = withConfig' theConfig $ const $ pure () + Async.replicateConcurrently_ 10 theCacheAction -- -- Error Plans. Can't be combined. Just list them out inline since they can't be combined @@ -565,6 +577,20 @@ withSnapshotSpecs = describe "withSnapshot" $ do snapshotConfigAndAssert testSuccessfulConfig + it "works if two threads try to create a snapshot at the same time" $ do + withDbCache $ \cacheInfo -> do + lock <- newEmptyMVar + let + theConfig = defaultConfig <> cacheConfig cacheInfo + waitIfSecond _ = do + tryPutMVar lock () >>= \case + True -> pure () + False -> threadDelay 100000 + withConfig' theConfig $ \db -> do + let theCacheAction = withSnapshot db waitIfSecond + res <- Async.replicateConcurrently 3 theCacheAction + if all isRight res then pure () else fail "Failed to create caches concurrently" + cacheActionSpecs :: Spec cacheActionSpecs = describe "cacheAction" $ do it "creates the cache if it does not exist" $ do From 560a61d2d02593abd2aeb4f4c2d7a70ce3b03116 Mon Sep 17 00:00:00 2001 From: Jonathan Fischoff Date: Tue, 17 Dec 2019 09:03:37 -0800 Subject: [PATCH 2/2] serial initdb creation and do nothing is the dir is missing --- src/Database/Postgres/Temp/Internal/Config.hs | 23 +---------- src/Database/Postgres/Temp/Internal/Core.hs | 38 ++++++++++++++++++- 2 files changed, 37 insertions(+), 24 deletions(-) diff --git a/src/Database/Postgres/Temp/Internal/Config.hs b/src/Database/Postgres/Temp/Internal/Config.hs index 52658c3..3f18fa3 100644 --- a/src/Database/Postgres/Temp/Internal/Config.hs +++ b/src/Database/Postgres/Temp/Internal/Config.hs @@ -32,7 +32,6 @@ 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) @@ -652,27 +651,7 @@ envsToKeep = , "PGLOCALEDIR" ] -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 (("PGDATA" /=) . fst) $ - completeProcessConfigEnvVars old - - clearedConfig = old - { completeProcessConfigCmdLine = otherArgs - , completeProcessConfigEnvVars = filteredEnvs - } - - in (firstDataDirectoryArg, clearedConfig) addDataDirectory :: String -> CompleteProcessConfig -> CompleteProcessConfig addDataDirectory theDataDirectory x = x @@ -687,7 +666,7 @@ cachePlan plan@Plan {..} cow cacheDirectory = case completePlanInitDb of Just theConfig -> do let (mtheDataDirectory, clearedConfig) = splitDataDirectory theConfig theDataDirectory <- maybe - (throwIO $ FailedToFindDataDirectory (show $ pretty clearedConfig)) + (throwIO $ FailedToFindDataDirectory (show $ pretty theConfig)) pure mtheDataDirectory diff --git a/src/Database/Postgres/Temp/Internal/Core.hs b/src/Database/Postgres/Temp/Internal/Core.hs index ea375e2..9ce9529 100644 --- a/src/Database/Postgres/Temp/Internal/Core.hs +++ b/src/Database/Postgres/Temp/Internal/Core.hs @@ -13,6 +13,8 @@ import Control.Monad import qualified Data.ByteString.Char8 as BSC import Data.Foldable (for_) import Data.IORef +import Data.List +import Data.Maybe import Data.Typeable import qualified Database.PostgreSQL.Simple as PG import qualified Database.PostgreSQL.Simple.Options as Client @@ -307,10 +309,42 @@ startPostgresProcess time logger CompletePostgresPlan {..} = do ------------------------------------------------------------------------------- -- Non interactive subcommands ------------------------------------------------------------------------------- +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 (("PGDATA" /=) . fst) $ + completeProcessConfigEnvVars old + + clearedConfig = old + { completeProcessConfigCmdLine = otherArgs + , completeProcessConfigEnvVars = filteredEnvs + } + + in (firstDataDirectoryArg, clearedConfig) + executeInitDb :: CompleteProcessConfig -> IO () executeInitDb config = do - (res, stdOut, stdErr) <- executeProcessAndTee "initdb" config - throwIfNotSuccess (InitDbFailed stdOut stdErr) res + let (mtheDataDirectory, _) = splitDataDirectory config + theDataDirectory <- maybe + (throwIO $ FailedToFindDataDirectory (show $ pretty config)) + pure + mtheDataDirectory + + withMVar cacheLock $ \_ -> + doesFileExist (theDataDirectory <> "/PG_VERSION") >>= \case + True -> pure () + False -> do + (res, stdOut, stdErr) <- executeProcessAndTee "initdb" config + throwIfNotSuccess (InitDbFailed stdOut stdErr) res data CompleteCopyDirectoryCommand = CompleteCopyDirectoryCommand { copyDirectoryCommandSrc :: FilePath