diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -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 + ] 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 @@ -49,6 +49,8 @@ with , withConfig , withRestart + , withNewDb + , withNewDbConfig -- * Separate start and stop interface. , start , startConfig 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,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 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 @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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" 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.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