tmp-postgres 1.11.0.0 → 1.12.0.0
raw patch · 6 files changed
+247/−18 lines, 6 filesdep +criteriondep +randomdep ~basedep ~postgres-options
Dependencies added: criterion, random
Dependency ranges changed: base, postgres-options
Files
- benchmark/Main.hs +53/−0
- src/Database/Postgres/Temp.hs +2/−0
- src/Database/Postgres/Temp/Internal.hs +131/−12
- src/Database/Postgres/Temp/Internal/Core.hs +18/−5
- test/Spec.hs +15/−0
- tmp-postgres.cabal +28/−1
+ benchmark/Main.hs view
@@ -0,0 +1,53 @@+module Main where+import Control.Exception+import Control.Monad (void, replicateM)+import Criterion.Main+import Data.String+import Database.Postgres.Temp.Internal+import Database.Postgres.Temp.Config+import qualified Database.PostgreSQL.Simple as PG++defaultConfigDefaultInitDb :: Config+defaultConfigDefaultInitDb = mempty+ { plan = mempty+ { logger = pure mempty+ , postgresConfigFile = defaultPostgresConfig+ , createDbConfig = Nothing+ , initDbConfig = pure mempty+ }+ }++createFooDb :: PG.Connection -> Int -> IO ()+createFooDb conn index = void $ PG.execute_ conn $ fromString $ unlines+ [ "CREATE TABLE foo" <> show index+ , "( id int"+ , ");"+ ]++migrateDb :: DB -> IO ()+migrateDb db = do+ let theConnectionString = toConnectionString db++ bracket (PG.connectPostgreSQL theConnectionString) PG.close $+ \conn -> mapM_ (createFooDb conn) [0 .. 100]++testQuery :: DB -> IO ()+testQuery db = do+ let theConnectionString = toConnectionString db++ bracket (PG.connectPostgreSQL theConnectionString) PG.close $+ \conn -> void $ PG.execute_ conn "INSERT INTO foo1 (id) VALUES (1)"++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 silentConfig $ const $ pure ()+ bench "with migrate 10x" $ whnfIO $ replicateM 10 $ with $ \db ->+ migrateDb db >> testQuery db+ , bench "withNewDb migrate 10x" $ whnfIO $ with $ \db -> do+ migrateDb db+ replicateM 10 $ withNewDb db testQuery+ ]
src/Database/Postgres/Temp.hs view
@@ -49,6 +49,8 @@ with , withConfig , withRestart+ , withNewDb+ , withNewDbConfig -- * Separate start and stop interface. , start , startConfig
src/Database/Postgres/Temp/Internal.hs view
@@ -8,14 +8,20 @@ import Database.Postgres.Temp.Internal.Core import Database.Postgres.Temp.Internal.Config +import Control.Concurrent.Async import Control.Exception import Control.Monad (void) import Control.Monad.Trans.Cont import Data.ByteString (ByteString) import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Monoid+import Data.String import qualified Database.PostgreSQL.Simple as PG import qualified Database.PostgreSQL.Simple.Options as Client+import System.Environment import System.Exit (ExitCode(..))+import System.Random import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) -- | Handle for holding temporary resources, the @postgres@ process handle@@ -222,18 +228,6 @@ generated '<>' extra @ -Returns a 'DB' that requires cleanup. `startConfig` should be-used with a `bracket` and 'stop', e.g.-- @- `withConfig` :: `Config` -> (`DB` -> IO a) -> IO (Either `StartError` a)- 'withConfig' plan f = `bracket` (`startConfig` plan) (either mempty `stop`) $- either (pure . Left) (fmap Right . f)- @--or just use 'withConfig'. If you are calling 'startConfig' you-probably want 'withConfig' anyway.- Based on the value of 'socketClass' a \"postgresql.conf\" is created with @@@ -250,6 +244,7 @@ are added. Additionally the @generated@ `Config` also does the following:+ * Sets a `connectionTimeout` of one minute. * Logs internal `Event`s. * Sets the processes to use the standard input and output handles.@@ -257,6 +252,18 @@ All of these values can be overrided by the @extra@ config. +The returned 'DB' requires cleanup. `startConfig` should be+used with a `bracket` and 'stop', e.g.++ @+ `withConfig` :: `Config` -> (`DB` -> IO a) -> IO (Either `StartError` a)+ 'withConfig' plan f = `bracket` (`startConfig` plan) (either mempty `stop`) $+ either (pure . Left) (fmap Right . f)+ @++or just use 'withConfig'. If you are calling 'startConfig' you+probably want 'withConfig' anyway.+ -} startConfig :: Config -- ^ @extra@ configuration that is 'mappend'ed last to the generated `Config`.@@ -363,3 +370,115 @@ -- | Display a 'DB' prettyPrintDB :: DB -> String prettyPrintDB = show . pretty++-------------------------------------------------------------------------------+-- withNewDb+-------------------------------------------------------------------------------+-- | Drop the db if it exists. Terminates all connections to the db first.+dropDbIfExists :: Client.Options -> String -> IO ()+dropDbIfExists options dbName = do+ let theConnectionString = Client.toConnectionString options+ dropDbQuery = fromString $ "DROP DATABASE IF EXISTS " <> dbName <> ";"++ terminateConnections $ options+ { Client.dbname = pure dbName+ }++ mapException DeleteDbError $+ bracket (PG.connectPostgreSQL theConnectionString) PG.close $+ \conn -> void $ PG.execute_ conn dropDbQuery++{-|+Use the current database as a template and make a copy. Give the+copy a random name.++Equivalent to:++@+ 'withNewDb' = 'withNewDbConfig' mempty+@++See 'withNewDbConfig' for more details.+-}+withNewDb+ :: DB+ -- ^ The original 'DB' handle. The connection options database+ -- is used as the template for the @generated@ 'ProcessConfig'+ -> (DB -> IO a)+ -- ^ The modified 'DB' handle that has the new database name+ -- in it's connection options.+ -> IO (Either StartError a)+withNewDb = withNewDbConfig mempty++{-|+Use the current database as a template and make a copy. Give the+copy a random name.++Copying a database from a template can be faster than creating a new+@postgres@ and migrating a database from scratch. In artifical benchmarks+it appears to be about 2x faster.++To use the current database as a template all connections to the database+must be terminated first.++To override the arguments passed to @createdb@ one can pass in @extra@+'ProcessConfig'. The @combined@ process is created by 'mappend'ed the+@generated@ with the @extra@ 'ProcessConfig', e.g.++@+ combined = generated '<>' extra+@++The current implementation has a few known issues.++If a connection is made between the termination command and the @createdb@+call the @createdb@ call will fail.++Additionally the generated name is 32 character random name of characters+\"a\" to \"z\". It is possible, although unlikeily that a duplicate+database name could be generated and this would also cause a failure.+-}+withNewDbConfig+ :: ProcessConfig+ -- ^ @extra@ @createdb@ 'ProcessConfig'+ -> DB+ -- ^ The original 'DB' handle. The connection options database+ -- is used as the template for the @generated@ 'ProcessConfig'+ -> (DB -> IO a)+ -- ^ The modified 'DB' handle that has the new database name+ -- in it's connection options.+ -> IO (Either StartError a)+withNewDbConfig extra db f = try $ do+ stdGen <- getStdGen+ let oldOptions@Client.Options {..} = toConnectionOptions db+ theDbName = fromMaybe "postgres" $ getLast dbname+ newDbName = take 32 $ randomRs ('a', 'z') stdGen+ newOptions = oldOptions+ { Client.dbname = pure newDbName+ }+ template1Options = oldOptions+ { Client.dbname = pure "template1"+ }+ generated = standardProcessConfig+ { commandLine = mempty+ { keyBased = Map.fromList+ [ ("-T", Just theDbName)+ , ("-h", Just $ fromMaybe "127.0.0.1" $ getLast host)+ , ("-p ", Just $ maybe "5432" show $ getLast port)+ ]+ , indexBased = Map.singleton 0 newDbName+ }+ }+ combined = generated <> extra+ newDb = db+ { dbPostgresProcess = (dbPostgresProcess db)+ { postgresProcessClientOptions = newOptions+ }+ }+ envs <- getEnvironment+ final <- case completeProcessConfig envs combined of+ Left errs -> throwIO $ CompleteProcessConfigFailed (show $ pretty combined) errs+ Right x -> pure x+ terminateConnections oldOptions+ bracket_ (wait =<< asyncWithUnmask (\unmask -> unmask (executeCreateDb final))) (dropDbIfExists template1Options newDbName) $+ f newDb
src/Database/Postgres/Temp/Internal/Core.hs view
@@ -67,8 +67,13 @@ | CompletePlanFailed String [String] -- ^ The 'Database.Postgres.Temp.Config.Plan' was missing info and a complete 'CompletePlan' could -- not be created.+ | CompleteProcessConfigFailed String [String]+ -- ^ The 'Database.Postgres.Temp.Config.ProcessConfig' was missing info and a+ -- 'CompleteProcessConfig' could not be created. | ConnectionTimedOut- deriving (Show, Eq, Ord, Typeable)+ -- ^ Timed out waiting for @postgres@ to accept a connection+ | DeleteDbError PG.SqlError+ deriving (Show, Eq, Typeable) instance Exception StartError @@ -214,17 +219,19 @@ terminateConnections :: Client.Options-> IO () terminateConnections options = do let theConnectionString = Client.toConnectionString options+ { Client.dbname = pure "template1"+ } terminationQuery = fromString $ unlines [ "SELECT pg_terminate_backend(pid)" , "FROM pg_stat_activity" , "WHERE datname=?;" ] e <- try $ bracket (PG.connectPostgreSQL theConnectionString) PG.close $- \conn -> PG.execute conn terminationQuery+ \conn -> PG.query conn terminationQuery [getLast $ Client.dbname options] case e of Left (_ :: IOError) -> pure ()- Right _ -> pure ()+ Right (_ :: [PG.Only Bool]) -> pure () -- | Stop the @postgres@ process after attempting to terminate all the -- connections.@@ -322,6 +329,13 @@ ExitSuccess -> pure () e -> throwIO $ f e +-- | Call 'createdb' and tee the output to return if there is an+-- an exception. Throws 'CreateDbFailed'.+executeCreateDb :: CompleteProcessConfig -> IO ()+executeCreateDb config = do+ (res, stdOut, stdErr) <- executeProcessAndTee "createdb" config+ throwIfNotSuccess (CreateDbFailed stdOut stdErr) res+ -- | 'startPlan' optionally calls @initdb@, optionally calls @createdb@ and -- unconditionally calls @postgres@. -- Additionally it writes a \"postgresql.conf\" and does not return until@@ -340,8 +354,7 @@ completePlanConnectionTimeout completePlanLogger completePlanPostgres bracketOnError startAction stopPostgresProcess $ \result -> do- for_ completePlanCreateDb $ executeProcessAndTee "createdb" >=>- \(res, stdOut, stdErr) -> throwIfNotSuccess (CreateDbFailed stdOut stdErr) res+ for_ completePlanCreateDb executeCreateDb pure result
test/Spec.hs view
@@ -306,6 +306,21 @@ before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startConfig specificHostIpPlan) stop f) $ someStandardTests "postgres" + before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startConfig silentConfig) stop f) $+ it "withNewDb works" $ withRunner $ \db -> do+ bracket (PG.connectPostgreSQL $ toConnectionString db ) PG.close $+ \conn -> do+ _ <- PG.execute_ conn "CREATE TABLE foo ( id int );"+ void $ PG.execute_ conn "INSERT INTO foo (id) VALUES (1);"++ void $ withNewDb db $ \newDb -> do+ one <- fmap (PG.fromOnly . head) $+ bracket (PG.connectPostgreSQL $ toConnectionString newDb ) PG.close $+ \conn -> PG.query_ conn "SELECT id FROM foo"++ one `shouldBe` (1 :: Int)++ thePort <- runIO getFreePort let planFromCustomUserDbConnection = optionsToDefaultConfig mempty { Client.dbname = pure "fancy"
tmp-postgres.cabal view
@@ -1,5 +1,5 @@ name: tmp-postgres-version: 1.11.0.0+version: 1.12.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@@ -47,6 +47,7 @@ , postgres-options >= 0.2.0.0 , postgresql-simple , process >= 1.2.0.0+ , random , temporary , transformers , unix@@ -85,6 +86,32 @@ , RecordWildCards , ScopedTypeVariables +benchmark benchmark+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: benchmark+ default-language: Haskell2010+ ghc-options: -O2 -Wall+ build-depends: base+ , criterion+ , postgres-options+ , postgresql-simple+ , tmp-postgres+ default-extensions:+ ApplicativeDo+ , DeriveFunctor+ , DeriveGeneric+ , DerivingStrategies+ , DerivingVia+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , OverloadedStrings+ , RankNTypes+ , RecordWildCards+ , ScopedTypeVariables+ , TemplateHaskell+ , TupleSections+ , ViewPatterns source-repository head type: git