tmp-postgres 1.28.1.0 → 1.29.0.0
raw patch · 9 files changed
+197/−96 lines, 9 files
Files
- CHANGELOG.md +4/−0
- benchmark/Main.hs +31/−12
- profiling/Main.hs +2/−2
- src/Database/Postgres/Temp.hs +2/−0
- src/Database/Postgres/Temp/Internal.hs +80/−32
- src/Database/Postgres/Temp/Internal/Config.hs +10/−16
- src/Database/Postgres/Temp/Internal/Core.hs +1/−3
- test/Main.hs +65/−30
- tmp-postgres.cabal +2/−1
CHANGELOG.md view
@@ -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.
benchmark/Main.hs view
@@ -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 () ]
profiling/Main.hs view
@@ -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 =<<
src/Database/Postgres/Temp.hs view
@@ -101,6 +101,8 @@ -- *** Separate start and stop interface. , takeSnapshot , cleanupSnapshot+ -- ** Conditional caching of 'DB' actions+ , cacheAction -- * Errors , StartError (..) -- * Configuration Types
src/Database/Postgres/Temp/Internal.hs view
@@ -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
src/Database/Postgres/Temp/Internal/Config.hs view
@@ -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.
src/Database/Postgres/Temp/Internal/Core.hs view
@@ -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
test/Main.hs view
@@ -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
tmp-postgres.cabal view
@@ -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