Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
101 lines (85 sloc) 5.16 KB
{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, OverloadedStrings, FlexibleContexts, FlexibleInstances, RankNTypes, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
module Main where
import qualified Database.Groundhog.Core as G
import qualified Database.Groundhog.Generic as G
import qualified Database.Groundhog.Sqlite as G
import qualified Database.Groundhog.Postgresql as G
import qualified Database.Groundhog.TH as G
import Database.Groundhog.TH (groundhog)
import Control.Monad.Logger (MonadLogger(..), NoLoggingT, runNoLoggingT)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import qualified Database.Persist as P
import Database.Persist (PersistEntityBackend)
import qualified Database.Persist.Sqlite as P
import qualified Database.Persist.Postgresql as P
import qualified Database.Persist.Sql as P
import qualified Database.Persist.TH as P
import Database.Persist.TH (persistUpperCase)
--import Database.Esqueleto as E
import Criterion.Main
import Criterion.Main.Options
import Criterion.Types
import Control.Monad
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Reader (runReaderT)
data GPerson = GPerson { name :: String, age :: Int, height :: Int }
G.mkPersist (G.defaultCodegenConfig {G.migrationFunction = Just "migrateG"}) [groundhog|
- entity: GPerson
|]
P.share [P.mkPersist P.sqlSettings, P.mkMigrate "migrateP"] [persistUpperCase|
PPerson
name String
age Int
height Int
|]
myConfig = defaultConfig {
reportFile = Just "bench.html"
}
gPerson = GPerson "John Doe" 23 180
gCond :: G.DbDescriptor db => G.Cond db (G.RestrictionHolder GPerson GPersonConstructor)
gCond = NameField G.==. ("abc" :: String) G.&&. AgeField G.==. (40 :: Int) G.&&. HeightField G.==. (160 :: Int)
pPerson = PPerson "John Doe" 23 180
pCond = [PPersonName P.==. "abc", PPersonAge P.==. 40, PPersonHeight P.==. 160]
gMigrate :: (G.PersistBackend m, MonadIO m) => m () -> m (G.Key GPerson G.BackendSpecific)
gMigrate truncate = G.runMigration migrateG >> truncate >> G.insert gPerson
pMigrate :: P.SqlPersistT (NoLoggingT (ResourceT IO)) () -> P.SqlPersistT (NoLoggingT (ResourceT IO)) (P.Key PPerson)
pMigrate truncate = P.runMigration migrateP >> truncate >> P.insert pPerson
instance MonadLogger IO where
monadLoggerLog _ _ _ _ = return ()
-- open transaction to reduce execution time on the DB side
eachStatementInTransaction :: Bool
eachStatementInTransaction = True
-- operatons are replicated to reduce influence of running a monad on the actual library and database performance measurements
numberOfOperations :: Int
numberOfOperations = 1
main =
-- G.withSqliteConn ":memory:" $ \gConn ->
-- P.withSqliteConn ":memory:" $ \pConn -> do
-- gKey <- G.runDbConn (gMigrate $ return ()) gConn
-- pKey <- runResourceT $ runNoLoggingT $ P.runSqlConn (pMigrate $ return ()) pConn
G.withPostgresqlConn "dbname=test user=test password=test host=localhost" $ \gConn ->
P.withPostgresqlConn "dbname=test user=test password=test host=localhost" $ \pConn -> do
gKey <- G.runDbConn (gMigrate $ G.executeRaw False "truncate table \"GPerson\"" []) gConn
pKey <- runResourceT $ runNoLoggingT $ P.runSqlConn (pMigrate $ P.rawExecute "truncate table \"PPerson\"" []) pConn
unless eachStatementInTransaction $ do
runNoLoggingT $ G.runDbPersist (G.executeRaw False "BEGIN" []) gConn
runResourceT $ runNoLoggingT $ runReaderT (P.rawExecute "BEGIN" []) pConn
let mkBench :: (forall m . G.PersistBackend m => m a1) -> P.SqlPersistT (NoLoggingT (ResourceT IO)) a2 -> [Benchmark]
mkBench gm pm = [bench "groundhog" $ whnfIO $ runSqlite gm, bench "persistent" $ whnfIO $ runPersistent pm] where
(runSqlite, runPersistent) = if eachStatementInTransaction
then (\gm -> G.runDbConn (replicateM_ numberOfOperations gm) gConn, \pm -> runResourceT $ runNoLoggingT $ P.runSqlConn (replicateM_ numberOfOperations pm) pConn)
else (\gm -> G.runDbConn' (replicateM_ numberOfOperations gm) gConn, \pm -> runResourceT $ runNoLoggingT $ runReaderT (replicateM_ numberOfOperations pm) pConn)
defaultMainWith myConfig
[ bgroup "get" $ mkBench (G.get gKey) (P.get pKey)
-- , bgroup "get" [bench "esqueleto" $ whnfIO $ runPers (E.select $ E.from $ \p -> E.where_ (p ^. PPersonId ==. val pKey) >> return p)]
, bgroup "replace" $ mkBench (G.replace gKey gPerson) (P.replace pKey pPerson)
, bgroup "select" $ mkBench (G.project (G.AutoKeyField, GPersonConstructor) gCond) (P.selectList pCond [])
, bgroup "updateByKey" $ mkBench (G.update [NameField G.=. ("abc" :: String)] $ G.AutoKeyField G.==. gKey) (P.update pKey [PPersonName P.=. "abc"])
, bgroup "updateWhere" $ mkBench (G.update [NameField G.=. ("abc" :: String)] gCond) (P.updateWhere pCond [PPersonName P.=. "abc"])
, bgroup "count" $ mkBench (G.count gCond) (P.count pCond)
, bgroup "deleteBy" $ mkBench (G.deleteBy gKey) (P.delete pKey)
, bgroup "deleteWhere" $ mkBench (G.delete gCond) (P.deleteWhere pCond)
, bgroup "insert" $ mkBench (G.insert gPerson) (P.insert pPerson)
, bgroup "insert_" $ mkBench (G.insert_ gPerson) (P.insert_ pPerson)
]