diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ Changelog for tmp-postgres +1.20.0.0 + #144 Make a CacheResources type + #162 Make a Snapshot alias + 1.19.0.1 #146 Better version hashing for making cache directories Documentation fixes diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -43,7 +43,7 @@ bracket (PG.connectPostgreSQL theConnectionString) PG.close $ \conn -> void $ PG.execute_ conn "INSERT INTO foo1 (id) VALUES (1)" -setupCache :: IO (Bool, CompleteDirectoryType) +setupCache :: IO CacheResources setupCache = do cacheInfo <- setupInitDbCache defaultCacheConfig void (withConfig (silentConfig <> toCacheConfig cacheInfo) (const $ pure ())) @@ -52,7 +52,7 @@ setupWithCache :: (Config -> Benchmark) -> Benchmark setupWithCache f = envWithCleanup setupCache cleanupInitDbCache $ f . (silentConfig <>) . toCacheConfig -setupCacheAndSP :: IO ((Bool, CompleteDirectoryType), CompleteDirectoryType, Once Config) +setupCacheAndSP :: IO (CacheResources, Snapshot, Once Config) setupCacheAndSP = do cacheInfo <- setupCache let cacheConfig = silentConfig <> toCacheConfig cacheInfo @@ -60,19 +60,18 @@ migrateDb db either throwIO pure =<< takeSnapshot Temporary db - snapshotConfig <- (silentConfig <>) - <$> configFromSavePoint (toFilePath sp) - let theConfig = snapshotConfig <> cacheConfig + let theConfig = silentConfig <> snapshotConfig sp <> cacheConfig + pure (cacheInfo, sp, Once theConfig) -cleanupCacheAndSP :: ((Bool, CompleteDirectoryType), CompleteDirectoryType, Once Config) -> IO () +cleanupCacheAndSP :: (CacheResources, Snapshot, Once Config) -> IO () cleanupCacheAndSP (x, y, _) = cleanupSnapshot y >> cleanupInitDbCache x setupWithCacheAndSP :: (Config -> Benchmark) -> Benchmark setupWithCacheAndSP f = envWithCleanup setupCacheAndSP cleanupCacheAndSP $ \ ~(_, _, Once x) -> f x -setupWithCacheAndSP' :: (CompleteDirectoryType -> Benchmark) -> Benchmark +setupWithCacheAndSP' :: (Snapshot -> Benchmark) -> Benchmark setupWithCacheAndSP' f = envWithCleanup setupCacheAndSP cleanupCacheAndSP $ \ ~(_, x, _) -> f x main :: IO () @@ -100,13 +99,13 @@ , setupWithCache $ \cacheConfig -> bench "withSnapshot migrate 10x and cache" $ whnfIO $ withConfig cacheConfig $ \db -> do migrateDb db void $ withSnapshot Temporary db $ \snapshotDir -> do - snapshotConfig <- (silentConfig <>) <$> configFromSavePoint (toFilePath snapshotDir) - replicateM_ 10 $ withConfig snapshotConfig testQuery + let theSnapshotConfig = silentConfig <> snapshotConfig snapshotDir + replicateM_ 10 $ withConfig theSnapshotConfig testQuery {- , setupWithCacheAndSP $ \theConfig -> bench "withConfig pre-setup with withSnapshot" $ whnfIO $ void $ withConfig theConfig $ const $ pure () - , setupWithCacheAndSP' $ \sp -> bench "configFromSavePoint" $ whnfIO $ void $ configFromSavePoint $ toFilePath sp + , setupWithCacheAndSP' $ \sp -> bench "snapshotConfig" $ whnfIO $ void $ snapshotConfig $ toFilePath sp , bench "migrateDb" $ perRunEnvWithCleanup (either throwIO (pure . Once) =<< startConfig silentConfig) (stop . unOnce) $ \ ~(Once db) -> migrateDb db 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 @@ -76,6 +76,10 @@ , reloadConfig -- ** 'DB' debugging , prettyPrintDB + -- ** 'Snapshot' handle + , Snapshot + -- ** @initdb@ cache handle + , CacheResources -- * Errors , StartError (..) -- * Configuration @@ -86,7 +90,7 @@ , silentConfig , silentProcessConfig , defaultCacheConfig - , configFromSavePoint + , snapshotConfig -- ** Custom Config builder helpers , optionsToDefaultConfig -- ** 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 @@ -8,6 +8,7 @@ import Database.Postgres.Temp.Internal.Core import Database.Postgres.Temp.Internal.Config +import Control.DeepSeq import Control.Exception import Control.Monad (void) import Control.Monad.Trans.Cont @@ -15,6 +16,7 @@ import qualified Data.Map.Strict as Map import qualified Database.PostgreSQL.Simple as PG import qualified Database.PostgreSQL.Simple.Options as Client +import GHC.Generics import System.Exit (ExitCode(..)) import System.IO.Unsafe (unsafePerformIO) import System.Process @@ -442,7 +444,7 @@ {-| Configuration for the @initdb@ data directory cache. -@since 1.15.1.0 +@since 1.20.0.0 -} data CacheConfig = CacheConfig { cacheTemporaryDirectory :: FilePath @@ -459,6 +461,19 @@ -- and sets this to 'True' if it does. } +{-| +A handle to cache temporary resources and configuration. + +@since 1.20.0.0 +-} +data CacheResources = CacheResources + { cacheResourcesCow :: Bool + , cacheResourcesDirectory :: CompleteDirectoryType + } deriving stock (Generic) + deriving anyclass (NFData) + +-- | A bool that is 'True' if the @cp@ on the path supports \"copy on write\" +-- flags. cowCheck :: Bool cowCheck = unsafePerformIO $ do let @@ -493,11 +508,10 @@ , cacheUseCopyOnWrite = cowCheck } - -- | Setup the @initdb@ cache folder. setupInitDbCache :: CacheConfig - -> IO (Bool, CompleteDirectoryType) + -> IO CacheResources setupInitDbCache CacheConfig {..} = bracketOnError (setupDirectoryType @@ -505,15 +519,15 @@ "tmp-postgres-cache" cacheDirectoryType ) - cleanupDirectoryType $ pure . (cacheUseCopyOnWrite,) + cleanupDirectoryType $ pure . CacheResources cacheUseCopyOnWrite {-| Cleanup the cache directory if it was 'Temporary'. -@since 1.15.1.0 +@since 1.20.0.0 -} -cleanupInitDbCache :: (Bool, CompleteDirectoryType) -> IO () -cleanupInitDbCache = cleanupDirectoryType . snd +cleanupInitDbCache :: CacheResources -> IO () +cleanupInitDbCache = cleanupDirectoryType . cacheResourcesDirectory {-| Enable @initdb@ data directory caching. This can lead to a 4x speedup. @@ -524,12 +538,12 @@ 'withDbCacheConfig' = bracket ('setupInitDbCache' config) 'cleanupInitDbCache' @ -@since 1.15.1.0 +@since 1.20.0.0 -} withDbCacheConfig :: CacheConfig -- ^ Configuration - -> ((Bool, CompleteDirectoryType) -> IO a) + -> (CacheResources -> IO a) -- ^ action for which caching is enabled -> IO a withDbCacheConfig config = @@ -539,35 +553,45 @@ Equivalent to 'withDbCacheConfig' with the 'CacheConfig' 'defaultCacheConfig' makes. -@since 1.15.1.0 +@since 1.20.0.0 -} -withDbCache :: ((Bool, CompleteDirectoryType) -> IO a) -> IO a +withDbCache :: (CacheResources -> IO a) -> IO a withDbCache = withDbCacheConfig defaultCacheConfig {-| Helper to make a 'Config' out of caching info. -@since 1.15.1.0 +@since 1.20.0.0 -} -toCacheConfig :: (Bool, CompleteDirectoryType) -> Config -toCacheConfig cacheInfo = mempty - { initDbCache = pure $ pure $ fmap toFilePath cacheInfo +toCacheConfig :: CacheResources -> Config +toCacheConfig CacheResources {..} = mempty + { initDbCache = pure $ pure + (cacheResourcesCow, toFilePath cacheResourcesDirectory) } ------------------------------------------------------------------------------- -- withSnapshot ------------------------------------------------------------------------------- +{-| +A type to track a possibly temporary snapshot directory + +@since 1.20.0.0 +-} +newtype Snapshot = Snapshot { unSnapshot :: CompleteDirectoryType } + deriving stock (Generic) + deriving anyclass (NFData) + {- | Shutdown the database and copy the directory to a folder. -@since 1.17.0.0 +@since 1.20.0.0 -} takeSnapshot :: DirectoryType -- ^ Either a 'Temporary' or preexisting 'Permanent' directory. -> DB -- ^ The handle. The @postgres@ is shutdown and the data directory is copied. - -> IO (Either StartError CompleteDirectoryType) + -> IO (Either StartError Snapshot) takeSnapshot directoryType db = try $ do throwIfNotSuccess id =<< stopPostgresGracefully db let @@ -588,15 +612,15 @@ throwIfNotSuccess (SnapshotCopyFailed snapshotCopyCmd) =<< system snapshotCopyCmd - pure snapShotDir + pure $ Snapshot snapShotDir {-| Cleanup any temporary resources used for the snapshot. -@since 1.17.0.0 +@since 1.20.0.0 -} -cleanupSnapshot :: CompleteDirectoryType -> IO () -cleanupSnapshot = cleanupDirectoryType +cleanupSnapshot :: Snapshot -> IO () +cleanupSnapshot = cleanupDirectoryType . unSnapshot {- | Exception safe method for taking a file system level copy of the database cluster. @@ -604,12 +628,12 @@ Snapshots are useful if you would like to start every test from a migrated database and the migration process is more time consuming then copying the additional data. -@since 1.17.0.0 +@since 1.20.0.0 -} withSnapshot :: DirectoryType -> DB - -> (CompleteDirectoryType -> IO a) + -> (Snapshot -> IO a) -> IO (Either StartError a) withSnapshot dirType db f = bracket (takeSnapshot dirType db) @@ -620,17 +644,16 @@ Convert a snapshot into a 'Config' that includes a 'copyConfig' for copying the snapshot directory to a temporary directory. -@since 1.17.0.0 +@since 1.20.0.0 -} -configFromSavePoint :: FilePath -> IO Config -configFromSavePoint savePointPath = do - pure mempty - { plan = mempty - { copyConfig = pure $ pure CopyDirectoryCommand - { sourceDirectory = savePointPath - , destinationDirectory = Nothing - , useCopyOnWrite = cowCheck - } - , initDbConfig = Zlich - } - } +snapshotConfig :: Snapshot -> Config +snapshotConfig (Snapshot savePointPath) = mempty + { plan = mempty + { copyConfig = pure $ pure CopyDirectoryCommand + { sourceDirectory = toFilePath savePointPath + , destinationDirectory = Nothing + , useCopyOnWrite = cowCheck + } + , initDbConfig = Zlich + } + } diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -567,10 +567,8 @@ void $ PG.execute_ conn "INSERT INTO foo (id) VALUES (1); END;" either throwIO pure <=< withSnapshot Temporary db $ \snapshotDir -> do - snapshotConfig <- (defaultConfig <>) - <$> configFromSavePoint (toFilePath snapshotDir) - - let snapshotConfigAndAssert = ConfigAndAssertion snapshotConfig $ flip withConn $ \conn -> 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" oneAgain `shouldBe` (1 :: Int) 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.19.0.1 +version: 1.20.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