diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ Changelog for tmp-postgres +1.29.0.0 + #211 Revert behavior of Permanent to not create the directory if it does not exist + #210 The signature of takeSnapshot is not as useful as it could be breaking change + 1.28.1.0 #208 Only hash important envs for initdb cache. diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -7,6 +7,7 @@ import Database.Postgres.Temp.Internal import Database.Postgres.Temp.Internal.Config import qualified Database.PostgreSQL.Simple as PG +import System.IO.Temp (createTempDirectory, withTempDirectory) data Once a = Once { unOnce :: a } @@ -20,7 +21,6 @@ , initDbConfig = pure mempty } - createFooDb :: PG.Connection -> Int -> IO () createFooDb conn index = void $ PG.execute_ conn $ fromString $ unlines [ "CREATE TABLE foo" <> show index @@ -28,9 +28,6 @@ , ");" ] -snapshotDir :: DirectoryType -snapshotDir = Permanent "~/.tmp-postgres/bench-mark-1" - migrateDb :: DB -> IO () migrateDb db = do let theConnectionString = toConnectionString db @@ -60,13 +57,12 @@ let theCacheConfig = defaultConfig <> cacheConfig cacheInfo sp <- either throwIO pure <=< withConfig theCacheConfig $ \db -> do migrateDb db - either throwIO pure =<< takeSnapshot snapshotDir db + either throwIO pure =<< takeSnapshot db let theConfig = defaultConfig <> snapshotConfig sp <> theCacheConfig pure (cacheInfo, sp, Once theConfig) - cleanupCacheAndSP :: (Cache, Snapshot, Once Config) -> IO () cleanupCacheAndSP (x, y, _) = cleanupSnapshot y >> cleanupInitDbCache x @@ -76,6 +72,23 @@ setupWithCacheAndSP' :: (Snapshot -> Benchmark) -> Benchmark setupWithCacheAndSP' f = envWithCleanup setupCacheAndSP cleanupCacheAndSP $ \ ~(_, x, _) -> f x +setupCacheAndAction :: IO (Cache, FilePath, Once Config) +setupCacheAndAction = do + cacheInfo <- setupCache + snapshotDir <- createTempDirectory "/tmp" "tmp-postgres-bench-cache" + let theCacheConfig = defaultConfig <> cacheConfig cacheInfo + + theConfig <- either throwIO pure =<< cacheAction snapshotDir migrateDb theCacheConfig + + pure (cacheInfo, snapshotDir, Once theConfig) + +cleanupCacheAndAction :: (Cache, FilePath, Once Config) -> IO () +cleanupCacheAndAction (c, f, _) = rmDirIgnoreErrors f >> cleanupInitDbCache c + +setupWithCacheAndAction :: (FilePath -> Config -> Benchmark) -> Benchmark +setupWithCacheAndAction f = envWithCleanup setupCacheAndAction cleanupCacheAndAction $ + \ ~(_, filePath, Once x) -> f filePath x + main :: IO () main = defaultMain [ bench "with" $ whnfIO $ with $ const $ pure () @@ -99,15 +112,21 @@ , setupWithCache $ \theCacheConfig -> bench "withSnapshot migrate 10x and cache" $ whnfIO $ withConfig theCacheConfig $ \db -> do migrateDb db - void $ withSnapshot Temporary db $ \theSnapshotDir -> do + void $ withSnapshot db $ \theSnapshotDir -> do let theSnapshotConfig = defaultConfig <> snapshotConfig theSnapshotDir replicateM_ 10 $ withConfig theSnapshotConfig testQuery - , setupWithCacheAndSP $ \theCacheConfig -> bench "preexisting snapshot withSnapshot migrate 10x and cache" $ whnfIO $ withConfig theCacheConfig $ \db -> do - void $ withSnapshot snapshotDir db $ \theSnapshotDir -> do - let theSnapshotConfig = defaultConfig <> snapshotConfig theSnapshotDir - replicateM_ 10 $ withConfig theSnapshotConfig testQuery + , setupWithCache $ \theCacheConfig -> bench "cache action and recache and cache" $ whnfIO $ withTempDirectory "/tmp" "tmp-postgres-bench-cache" $ \snapshotDir -> do + newConfig <- either throwIO pure =<< cacheAction snapshotDir migrateDb theCacheConfig + replicateM_ 10 $ + either throwIO pure =<< flip withConfig testQuery + =<< either throwIO pure =<< cacheAction snapshotDir migrateDb newConfig + , setupWithCacheAndAction $ \snapshotDir theCacheConfig -> bench "pre-cache action and recache" $ whnfIO $ do + replicateM_ 10 $ + either throwIO pure =<< flip withConfig testQuery + =<< either throwIO pure =<< cacheAction snapshotDir migrateDb theCacheConfig + , setupWithCacheAndSP $ \theConfig -> bench "withConfig pre-setup with withSnapshot" $ whnfIO $ void $ withConfig theConfig $ const $ pure () @@ -118,6 +137,6 @@ \ ~(Once db) -> migrateDb db , bench "withSnapshot" $ perRunEnvWithCleanup (either throwIO (pure . Once) =<< startConfig defaultConfig) (stop . unOnce) $ - \ ~(Once db) -> void $ withSnapshot Temporary db $ const $ pure () + \ ~(Once db) -> void $ withSnapshot db $ const $ pure () ] diff --git a/profiling/Main.hs b/profiling/Main.hs --- a/profiling/Main.hs +++ b/profiling/Main.hs @@ -1,8 +1,8 @@ import Database.Postgres.Temp import Control.Exception -withLoop :: IO () -withLoop = either throwIO pure =<< with (const $ pure ()) +_withLoop :: IO () +_withLoop = either throwIO pure =<< with (const $ pure ()) withCacheLoop :: IO () withCacheLoop = withDbCache $ \cache -> either throwIO pure =<< diff --git a/src/Database/Postgres/Temp.hs b/src/Database/Postgres/Temp.hs --- a/src/Database/Postgres/Temp.hs +++ b/src/Database/Postgres/Temp.hs @@ -101,6 +101,8 @@ -- *** Separate start and stop interface. , takeSnapshot , cleanupSnapshot + -- ** Conditional caching of 'DB' actions + , cacheAction -- * Errors , StartError (..) -- * Configuration Types diff --git a/src/Database/Postgres/Temp/Internal.hs b/src/Database/Postgres/Temp/Internal.hs --- a/src/Database/Postgres/Temp/Internal.hs +++ b/src/Database/Postgres/Temp/Internal.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK prune #-} {-| This module provides the high level functions that are re-exported by @Database.Postgres.Temp@. Additionally it includes some @@ -10,7 +11,7 @@ import Control.DeepSeq import Control.Exception -import Control.Monad (void, unless) +import Control.Monad (void, join) import Control.Monad.Trans.Cont import Data.ByteString (ByteString) import qualified Data.Map.Strict as Map @@ -466,6 +467,15 @@ || missingFile == take (length missingFile) errorOutput {-# NOINLINE cowCheck #-} +cpFlags :: String +cpFlags = if cowCheck +#ifdef darwin_HOST_OS + then "cp -Rc " +#else + then "cp -R --reflink=auto " +#endif + else "cp -R " + {-| 'defaultCacheConfig' attempts to determine if the @cp@ on the path supports \"copy on write\" flags and if it does, sets 'cacheUseCopyOnWrite' @@ -572,35 +582,25 @@ {- | Shutdown the database and copy the directory to a folder. -@since 1.20.0.0 +@since 1.29.0.0 -} takeSnapshot - :: DirectoryType - -- ^ Either a 'Temporary' or preexisting 'Permanent' directory. - -> DB + :: DB -- ^ The handle. The @postgres@ is shutdown and the data directory is copied. -> IO (Either StartError Snapshot) -takeSnapshot directoryType db = try $ do +takeSnapshot db = try $ do throwIfNotSuccess id =<< stopPostgresGracefully db - let -#ifdef darwin_HOST_OS - cpFlags = if cowCheck then "cp -Rc " else "cp -R " -#else - cpFlags = if cowCheck then "cp -R --reflink=auto " else "cp -R " -#endif bracketOnError (setupDirectoryType (toTemporaryDirectory db) "tmp-postgres-snapshot" - directoryType + Temporary ) cleanupDirectoryType $ \snapShotDir -> do - nonEmpty <- doesFileExist $ toFilePath snapShotDir <> "/PG_VERSION" - unless nonEmpty $ do - let snapshotCopyCmd = cpFlags <> - toDataDirectory db <> "/* " <> toFilePath snapShotDir - throwIfNotSuccess (SnapshotCopyFailed snapshotCopyCmd) =<< - system snapshotCopyCmd + let snapshotCopyCmd = cpFlags <> + toDataDirectory db <> "/* " <> toFilePath snapShotDir + throwIfNotSuccess (SnapshotCopyFailed snapshotCopyCmd) =<< + system snapshotCopyCmd pure $ Snapshot snapShotDir @@ -629,18 +629,28 @@ withConfig (snapshotConfig db) $ \\migratedDb -> ... @ -@since 1.20.0.0 +@since 1.29.0.0 -} withSnapshot - :: DirectoryType - -> DB + :: DB -> (Snapshot -> IO a) -> IO (Either StartError a) -withSnapshot dirType db f = bracket - (takeSnapshot dirType db) +withSnapshot db f = bracket + (takeSnapshot db) (either mempty cleanupSnapshot) (either (pure . Left) (fmap Right . f)) +-- Helper for 'snapshotConfig' and 'cacheAction' +fromFilePathConfig :: FilePath -> Config +fromFilePathConfig filePath = mempty + { copyConfig = pure $ pure CopyDirectoryCommand + { sourceDirectory = filePath + , destinationDirectory = Nothing + , useCopyOnWrite = cowCheck + } + , initDbConfig = Zlich + } + {-| Convert a snapshot into a 'Config' that includes a 'copyConfig' for copying the snapshot directory to a temporary directory. @@ -648,11 +658,49 @@ @since 1.20.0.0 -} snapshotConfig :: Snapshot -> Config -snapshotConfig (Snapshot savePointPath) = mempty - { copyConfig = pure $ pure CopyDirectoryCommand - { sourceDirectory = toFilePath savePointPath - , destinationDirectory = Nothing - , useCopyOnWrite = cowCheck - } - , initDbConfig = Zlich - } +snapshotConfig = fromFilePathConfig . toFilePath . unSnapshot + +------------------------------------------------------------------------------- +-- cacheAction +------------------------------------------------------------------------------- +{-| +Check to see if a cached data directory exists. + +If the file path does not exist the @initial@ config is used to start a @postgres@ +instance. After which the @action@ is applied, the data directory is cached +and @postgres@ is shutdown. + +'cacheAction' 'mappend's a config to copy the cached data directory +on startup onto the @initial@ config and returns it. In other words: + +@ +initialConfig <> configFromCachePath +@ + +@since 1.29.0.0 +-} +cacheAction + :: FilePath + -- ^ Location of the data directory cache. + -> (DB -> IO ()) + -- ^ @action@ to cache. + -> Config + -- ^ @initial@ 'Config'. + -> IO (Either StartError Config) +cacheAction cachePath action config = do + let result = config <> fromFilePathConfig cachePath + nonEmpty <- doesFileExist $ cachePath <> "/PG_VERSION" + + case nonEmpty of + True -> pure $ pure result + False -> fmap join $ withConfig config $ \db -> do + action db + -- TODO see if parallel is better + throwIfNotSuccess id =<< stopPostgresGracefully db + createDirectoryIfMissing True cachePath + + let snapshotCopyCmd = cpFlags <> + toDataDirectory db <> "/* " <> cachePath + system snapshotCopyCmd >>= \case + ExitSuccess -> pure $ pure result + x -> pure $ Left $ SnapshotCopyFailed snapshotCopyCmd x 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 @@ -357,7 +357,7 @@ -- if it does not exist to a 'CPermanent' -- one. -- --- @since 1.28.0.0 +-- @since 1.29.0.0 setupDirectoryType :: String -- ^ Temporary directory configuration @@ -365,22 +365,16 @@ -- ^ Directory pattern -> DirectoryType -> IO CompleteDirectoryType -setupDirectoryType tempDir pat dirType = do - e <- try $ case dirType of - Temporary -> CTemporary <$> createTempDirectory tempDir pat - Permanent x -> do - dir <- case x of - '~':rest -> do - homeDir <- getHomeDirectory - pure $ homeDir <> "/" <> rest - xs -> pure xs - - createDirectoryIfMissing True dir +setupDirectoryType tempDir pat dirType = case dirType of + Temporary -> CTemporary <$> createTempDirectory tempDir pat + Permanent x -> do + dir <- case x of + '~':rest -> do + homeDir <- getHomeDirectory + pure $ homeDir <> "/" <> rest + xs -> pure xs - pure $ CPermanent dir - case e of - Left err -> throwIO $ CompleteDirectoryFailed err - Right res -> pure res + pure $ CPermanent dir -- Remove a temporary directory and ignore errors -- about it not being there. 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 @@ -55,7 +55,7 @@ -- and exhaustive list but covers the errors that the system -- catches for the user. -- --- @since 1.12.0.0 +-- @since 1.29.0.0 data StartError = StartPostgresFailed ExitCode -- ^ @postgres@ failed before a connection succeeded. Most likely this @@ -93,8 +93,6 @@ -- a cached @initdb@ folder. | SnapshotCopyFailed String ExitCode -- ^ We tried to copy a data directory to a snapshot folder and it failed - | CompleteDirectoryFailed IOException - -- ^ Something went wrong when trying to create a directory deriving (Show, Eq, Typeable) instance Exception StartError diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -446,13 +446,12 @@ withConfig invalidConfig' (const $ pure ()) `shouldReturn` Left ConnectionTimedOut - it "throws IOException if the path is not writable" $ do + it "throws StartPostgresFailed if the host path does not exist" $ do let invalidConfig = optionsToDefaultConfig mempty { Client.host = pure "/focalhost" } - withConfig invalidConfig (const $ pure ()) >>= \case - Left CompleteDirectoryFailed {} -> pure () - _ -> fail "expected Left CompleteDirectoryFailed" + withConfig invalidConfig (const $ pure ()) + `shouldReturn` Left (StartPostgresFailed $ ExitFailure 1) it "No initdb plan causes failure" $ do let dontTimeout = defaultConfig @@ -547,7 +546,7 @@ _ <- PG.execute_ conn "BEGIN; CREATE TABLE foo ( id int );" void $ PG.execute_ conn "INSERT INTO foo (id) VALUES (1); END;" - either throwIO pure <=< withSnapshot Temporary db $ \snapshotDir -> do + either throwIO pure <=< withSnapshot db $ \snapshotDir -> do let theSnapshotConfig = defaultConfig <> snapshotConfig snapshotDir snapshotConfigAndAssert = ConfigAndAssertion theSnapshotConfig $ flip withConn $ \conn -> do oneAgain <- fmap (PG.fromOnly . head) $ PG.query_ conn "SELECT id FROM foo" @@ -557,42 +556,78 @@ snapshotConfigAndAssert testSuccessfulConfig - it "doesn't create the snapshot if it exists" $ withConfig' defaultConfig $ \db -> do - withConn db $ \conn -> do - _ <- PG.execute_ conn "BEGIN; CREATE TABLE foo ( id int );" - void $ PG.execute_ conn "INSERT INTO foo (id) VALUES (1); END;" +cacheActionSpecs :: Spec +cacheActionSpecs = describe "cacheAction" $ do + it "creates the cache if it does not exist" $ do + 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;" + withTempDirectory "/tmp" "tmp-postgres-cache-action" $ \cachePath -> do + let theFinalCachePath = cachePath <> "/cached" + cacheAction theFinalCachePath action defaultConfig >>= \case + Left err -> fail $ "cacheAction failed with:" <> show err + Right newCache -> do + nonEmpty <- doesFileExist $ theFinalCachePath <> "/PG_VERSION" + nonEmpty `shouldBe` True - either throwIO pure <=< withSnapshot (Permanent $ "~/.tmp-postgres/test-snapshot/") db $ \snapshotDir -> do - let theSnapshotConfig = defaultConfig <> snapshotConfig snapshotDir - -- A file to the snapshot directory - writeFile (toFilePath (unSnapshot snapshotDir) <> "/testModification.txt") "yes" - -- start postgres - withConfig' theSnapshotConfig $ \newDb -> do - -- modify it in the data directory - writeFile (toDataDirectory newDb <> "/testModification.txt") "no" - -- add a new file - writeFile (toDataDirectory newDb <> "/newFile.txt") "yes" - -- take another snapshot - either throwIO pure <=< withSnapshot (Permanent $ "~/.tmp-postgres/test-snapshot") db $ \snapshotDir1 -> do - -- ensure the original is still there - readFile (toFilePath (unSnapshot snapshotDir1) <> "/testModification.txt") - `shouldReturn` "yes" - -- ensure the file is not`` - doesFileExist (toFilePath (unSnapshot snapshotDir1) <> "/newFile.txt") `shouldReturn` False + -- Write a file and make sure it shows up in the data directory + writeFile (theFinalCachePath <> "/newFile.txt") "yes" + let - theSnapshotConfig1 = defaultConfig <> snapshotConfig snapshotDir1 - snapshotConfigAndAssert = ConfigAndAssertion theSnapshotConfig1 $ flip withConn $ \conn -> do - oneAgain <- fmap (PG.fromOnly . head) $ PG.query_ conn "SELECT id FROM foo" - oneAgain `shouldBe` (1 :: Int) + asserts db = do + doesFileExist (toDataDirectory db <> "/newFile.txt") `shouldReturn` True + withConn db $ \conn -> do + oneAgain <- fmap (PG.fromOnly . head) $ PG.query_ conn "SELECT id FROM foo" + oneAgain `shouldBe` (1 :: Int) + snapshotConfigAndAssert = ConfigAndAssertion newCache asserts testWithTemporaryDirectory snapshotConfigAndAssert testSuccessfulConfig + + it "doesn't create the cache if it exists" $ do + 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;" + withTempDirectory "/tmp" "tmp-postgres-cache-action" $ \cachePath -> do + let theFinalCachePath = cachePath <> "/cached" + cacheAction theFinalCachePath action defaultConfig >>= \case + Left err -> fail $ "cacheAction failed with:" <> show err + Right newCache -> do + let nextAction db = withConn db $ \conn -> + void $ PG.execute_ conn "INSERT INTO foo (id) VALUES (2); END;" + + cacheAction theFinalCachePath nextAction newCache >>= \case + Left err -> fail $ "cacheAction failed with:" <> show err + Right newCache1 -> do + let + asserts db = do + withConn db $ \conn -> do + oneAgain <- fmap (PG.fromOnly . head) $ PG.query_ conn "SELECT COUNT(*) FROM foo" + oneAgain `shouldBe` (1 :: Int) + snapshotConfigAndAssert = ConfigAndAssertion newCache1 asserts + + testWithTemporaryDirectory + snapshotConfigAndAssert + testSuccessfulConfig + + it "fails if the cache director and data directory are the same" $ do + 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;" + withTempDirectory "/tmp" "tmp-postgres-cache-action" $ \cachePath -> do + let theFinalCachePath = cachePath <> "/cached" + cacheAction theFinalCachePath action (defaultConfig { dataDirectory = Permanent theFinalCachePath } ) >>= \case + Left (SnapshotCopyFailed {}) -> pure () + _ -> fail $ "cacheAction should have failed with SnapshotCopyFailed" + spec :: Spec spec = do withConfigSpecs withSnapshotSpecs + + cacheActionSpecs it "stopPostgres cannot be connected to" $ withConfig' defaultConfig $ \db -> do stopPostgres db `shouldReturn` ExitSuccess 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.28.1.0 +version: 1.29.0.0 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 @@ -105,6 +105,7 @@ , deepseq , postgres-options , postgresql-simple + , temporary , tmp-postgres default-extensions: ApplicativeDo