tmp-postgres 1.27.0.4 → 1.28.0.0
raw patch · 7 files changed
+94/−38 lines, 7 files
Files
- CHANGELOG.md +3/−0
- benchmark/Main.hs +26/−18
- src/Database/Postgres/Temp/Internal.hs +8/−5
- src/Database/Postgres/Temp/Internal/Config.hs +19/−10
- src/Database/Postgres/Temp/Internal/Core.hs +2/−0
- test/Main.hs +35/−4
- tmp-postgres.cabal +1/−1
CHANGELOG.md view
@@ -1,5 +1,8 @@ Changelog for tmp-postgres +1.28.0.0+ #200 Change behavior of Permanent. We now create the directory if it does not exist. Other changes+ 1.27.0.4 #193 and #194 Doc fixes
benchmark/Main.hs view
@@ -28,6 +28,9 @@ , ");" ] +snapshotDir :: DirectoryType+snapshotDir = Permanent "~/.tmp-postgres/bench-mark-1"+ migrateDb :: DB -> IO () migrateDb db = do let theConnectionString = toConnectionString db@@ -57,13 +60,13 @@ let theCacheConfig = defaultConfig <> cacheConfig cacheInfo sp <- either throwIO pure <=< withConfig theCacheConfig $ \db -> do migrateDb db- either throwIO pure =<< takeSnapshot Temporary db+ either throwIO pure =<< takeSnapshot snapshotDir 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 @@ -75,40 +78,45 @@ main :: IO () main = defaultMain- [ --bench "with" $ whnfIO $ with $ const $ pure ()- --, bench "withConfig no --no-sync" $ whnfIO $- -- withConfig defaultConfigDefaultInitDb $ const $ pure ()-{-- bench "withConfig silent" $ whnfIO $- withConfig defaultConfig $ const $ pure ()+ [ bench "with" $ whnfIO $ with $ const $ pure () - , setupWithCache $ \cacheConfig -> bench "withConfig silent cache" $ whnfIO $- withConfig cacheConfig $ const $ pure ()+ , bench "withConfig no --no-sync" $ whnfIO $+ withConfig defaultConfigDefaultInitDb $ const $ pure () + , bench "withConfig silent" $ whnfIO $+ withConfig defaultConfig $ const $ pure ()++ , setupWithCache $ \theCacheConfig -> bench "withConfig silent cache" $ whnfIO $+ withConfig theCacheConfig $ const $ pure ()+ , bench "with migrate 10x" $ whnfIO $ replicateM 10 $ withConfig defaultConfig $ \db -> migrateDb db >> testQuery db --}-- setupWithCache $ \theCacheConfig -> do+ , setupWithCache $ \theCacheConfig -> do bench "with migrate 10x and cache" $ whnfIO $ withConfig theCacheConfig $ \_ -> do replicateM_ 10 $ withConfig theCacheConfig $ \db -> migrateDb db >> testQuery db , setupWithCache $ \theCacheConfig -> bench "withSnapshot migrate 10x and cache" $ whnfIO $ withConfig theCacheConfig $ \db -> do migrateDb db- void $ withSnapshot Temporary db $ \snapshotDir -> do- let theSnapshotConfig = defaultConfig <> snapshotConfig snapshotDir+ void $ withSnapshot Temporary 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+ , setupWithCacheAndSP $ \theConfig -> bench "withConfig pre-setup with withSnapshot" $ whnfIO $ void $ withConfig theConfig $ const $ pure () - , setupWithCacheAndSP' $ \sp -> bench "snapshotConfig" $ whnfIO $ void $ snapshotConfig $ toFilePath sp+ , setupWithCacheAndSP' $ \sp -> bench "snapshotConfig" $ whnfIO $ void $ flip withConfig (const $ pure ())+ $ snapshotConfig sp , bench "migrateDb" $ perRunEnvWithCleanup (either throwIO (pure . Once) =<< startConfig defaultConfig) (stop . unOnce) $ \ ~(Once db) -> migrateDb db--}+ , bench "withSnapshot" $ perRunEnvWithCleanup (either throwIO (pure . Once) =<< startConfig defaultConfig) (stop . unOnce) $ \ ~(Once db) -> void $ withSnapshot Temporary db $ const $ pure ()
src/Database/Postgres/Temp/Internal.hs view
@@ -10,7 +10,7 @@ import Control.DeepSeq import Control.Exception-import Control.Monad (void)+import Control.Monad (void, unless) import Control.Monad.Trans.Cont import Data.ByteString (ByteString) import qualified Data.Map.Strict as Map@@ -20,6 +20,7 @@ import System.IO.Unsafe (unsafePerformIO) import System.Process import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))+import System.Directory -- | Handle for holding temporary resources, the @postgres@ process handle -- and @postgres@ connection information. The 'DB' also includes the@@ -594,10 +595,12 @@ directoryType ) cleanupDirectoryType $ \snapShotDir -> do- let snapshotCopyCmd = cpFlags <>- toDataDirectory db <> "/* " <> toFilePath snapShotDir- throwIfNotSuccess (SnapshotCopyFailed snapshotCopyCmd) =<<- system snapshotCopyCmd+ nonEmpty <- doesFileExist $ toFilePath snapShotDir <> "/PG_VERSION"+ unless nonEmpty $ do+ let snapshotCopyCmd = cpFlags <>+ toDataDirectory db <> "/* " <> toFilePath snapShotDir+ throwIfNotSuccess (SnapshotCopyFailed snapshotCopyCmd) =<<+ system snapshotCopyCmd pure $ Snapshot snapShotDir
src/Database/Postgres/Temp/Internal/Config.hs view
@@ -353,10 +353,11 @@ instance Monoid DirectoryType where mempty = Temporary --- | Either create a'CTemporary' directory or do nothing to a 'CPermanent'+-- | Either create a'CTemporary' directory or do create the directory+-- if it does not exist to a 'CPermanent' -- one. ----- @since 1.12.0.0+-- @since 1.28.0.0 setupDirectoryType :: String -- ^ Temporary directory configuration@@ -364,14 +365,23 @@ -- ^ Directory pattern -> DirectoryType -> IO CompleteDirectoryType-setupDirectoryType tempDir pat = \case- Temporary -> CTemporary <$> createTempDirectory tempDir pat- Permanent x -> CPermanent <$> case x of- '~':rest -> do- homeDir <- getHomeDirectory- pure $ homeDir <> "/" <> rest- xs -> pure xs+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++ pure $ CPermanent dir+ case e of+ Left err -> throwIO $ CompleteDirectoryFailed err+ Right res -> pure res+ -- Remove a temporary directory and ignore errors -- about it not being there. rmDirIgnoreErrors :: FilePath -> IO ()@@ -878,4 +888,3 @@ hostToSocketClass hostOrSocketPath = case hostOrSocketPath of '/' : _ -> Permanent hostOrSocketPath _ -> Temporary-
src/Database/Postgres/Temp/Internal/Core.hs view
@@ -93,6 +93,8 @@ -- 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,12 +446,13 @@ withConfig invalidConfig' (const $ pure ()) `shouldReturn` Left ConnectionTimedOut - it "throws StartPostgresFailed if the host path does not exist" $ do+ it "throws IOException if the path is not writable" $ do let invalidConfig = optionsToDefaultConfig mempty { Client.host = pure "/focalhost" }- withConfig invalidConfig (const $ pure ())- `shouldReturn` Left (StartPostgresFailed $ ExitFailure 1)+ withConfig invalidConfig (const $ pure ()) >>= \case+ Left CompleteDirectoryFailed {} -> pure ()+ _ -> fail "expected Left CompleteDirectoryFailed" it "No initdb plan causes failure" $ do let dontTimeout = defaultConfig@@ -544,7 +545,6 @@ withSnapshotSpecs :: Spec withSnapshotSpecs = describe "withSnapshot" $ do it "works" $ withConfig' defaultConfig $ \db -> do- -- TODO create a table withConn db $ \conn -> do _ <- PG.execute_ conn "BEGIN; CREATE TABLE foo ( id int );" void $ PG.execute_ conn "INSERT INTO foo (id) VALUES (1); END;"@@ -559,6 +559,37 @@ 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;"++ 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+ 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)++ testWithTemporaryDirectory+ snapshotConfigAndAssert+ testSuccessfulConfig spec :: Spec spec = do withConfigSpecs
tmp-postgres.cabal view
@@ -1,5 +1,5 @@ name: tmp-postgres-version: 1.27.0.4+version: 1.28.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