yesod mongodb implementation

yesod/bench/bench.cabal

@@ -7,7 +7,7 @@ executable         bench
     main-is:           yesod.hs
     hs-source-dirs:    src
 
-    ghc-options:       -threaded -O2 -rtsopts
+    ghc-options:       -Wall -threaded -O2 -rtsopts
 
     extensions: TemplateHaskell
                 QuasiQuotes
@@ -22,9 +22,12 @@ executable         bench
                  , text                          >= 0.11       && < 0.12
                  , persistent                    >= 1.1        && < 1.2
                  , persistent-mysql              >= 1.1        && < 1.2
+                 , persistent-mongoDB            >= 1.1.6      && < 1.2
                  , warp                          >= 1.3        && < 1.4
                  , unix                          >= 2.5
                  , network-conduit               >= 1.0
                  , primitive                     >= 0.5
                  , mwc-random                    >= 0.12
                  , pool-conduit                  >= 0.1
+                 , network
+                 , lifted-async                  >= 0.1

yesod/bench/src/yesod.hs

@@ -2,19 +2,24 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE RankNTypes #-}
 import Yesod
 import System.Environment (getArgs)
 import qualified Network.Wai.Handler.Warp as Warp
 import Data.Text (Text)
 import Data.Conduit.Pool (Pool)
-import Database.Persist.Store (get, PersistValue (PersistInt64))
-import Database.Persist.MySQL
+import Database.Persist.Store (PersistValue (PersistInt64))
+import qualified Database.Persist.MySQL as My
+import qualified Database.Persist.MongoDB as Mongo
 import qualified System.Random.MWC as R
 import Control.Monad.Primitive (PrimState)
 import Control.Monad (replicateM)
 import Data.Conduit.Network (bindPort)
 import System.Posix.Process (forkProcess)
 import Control.Monad (replicateM_)
+import Network (PortID (PortNumber))
+import Control.Concurrent.Async.Lifted (mapConcurrently)
+import Data.Int (Int64)
 
 mkPersist sqlSettings [persist|
 World sql=World
@@ -22,14 +27,19 @@ World sql=World
 |]
 
 data App = App
-    { appConnPool :: Pool Connection
-    , appGen :: R.Gen (PrimState IO)
+    { appGen :: R.Gen (PrimState IO)
+    , mySqlPool :: Pool My.Connection
+    , mongoDBPool :: Pool Mongo.Connection
     }
 
 mkYesod "App" [parseRoutes|
-/json JsonR GET
-/db DbR GET
-/dbs/#Int DbsR GET
+/json           JsonR     GET
+
+/db             DbR       GET
+/dbs/#Int       DbsR      GET
+
+/mongo/db       MongoDbR  GET
+/mongo/dbs/#Int MongoDbsR GET
 |]
 
 instance Yesod App where
@@ -44,31 +54,66 @@ getDbR :: Handler RepJson
 getDbR = do
     App {..} <- getYesod
     i <- liftIO $ R.uniformR (1, 10000) appGen
-    Just x <- flip runSqlPool appConnPool $ get (Key $ PersistInt64 i :: WorldId)
-    jsonToRepJson $ object ["id" .= i, "randomNumber" .= worldRandomNumber x]
+    jsonToRepJson =<< intQuery (flip My.runSqlPool mySqlPool) i
 
 getDbsR :: Int -> Handler RepJson
 getDbsR cnt = do
+  App {..} <- getYesod
+  multiRandomHandler (flip My.runSqlPool mySqlPool) appGen cnt
+
+getMongoDbR :: Handler RepJson
+getMongoDbR = do
     App {..} <- getYesod
-    objs <- replicateM cnt $ do
-        i <- liftIO $ R.uniformR (1, 10000) appGen
-        Just x <- flip runSqlPool appConnPool $ get (Key $ PersistInt64 i :: WorldId)
-        return $ object ["id" .= i, "randomNumber" .= worldRandomNumber x]
-    jsonToRepJson $ array objs
+    i <- liftIO $ R.uniformR (1, 10000) appGen
+    jsonToRepJson =<< intQuery (flip Mongo.runMongoDBPoolDef mongoDBPool) i
+
+getMongoDbsR :: Int -> Handler RepJson
+getMongoDbsR cnt = do
+  App {..} <- getYesod
+  multiRandomHandler (flip Mongo.runMongoDBPoolDef mongoDBPool) appGen cnt
+
+multiRandomHandler :: forall (m :: * -> *) backend.
+    (PersistStore m, PersistMonadBackend m ~ PersistEntityBackend (WorldGeneric backend))
+  => (m (Maybe (WorldGeneric backend))
+       -> Handler (Maybe (WorldGeneric backend)))
+  -> R.Gen (PrimState IO)
+  -> Int
+  -> Handler RepJson
+multiRandomHandler db appGen cnt = do
+    nums <- liftIO $ replicateM cnt $ R.uniformR (1, 10000) appGen
+    jsonToRepJson . array =<< mapConcurrently (intQuery db) nums
+
+intQuery :: forall (m :: * -> *) backend.
+    (PersistStore m, PersistMonadBackend m ~ PersistEntityBackend (WorldGeneric backend))
+  => (m (Maybe (WorldGeneric backend))
+       -> Handler (Maybe (WorldGeneric backend)))
+  -> Int64
+  -> Handler Value
+intQuery db i = do
+    Just x <- db $ get (Key $ PersistInt64 i)
+    return $ object ["id" .= i, "randomNumber" .= worldRandomNumber x]
 
 main :: IO ()
 main = R.withSystemRandom $ \gen -> do
     socket <- bindPort 8000 "*"
     [cores, host] <- getArgs
-    pool <- createMySQLPool defaultConnectInfo
-        { connectUser = "benchmarkdbuser"
-        , connectPassword = "benchmarkdbpass"
-        , connectDatabase = "hello_world"
-        , connectHost = host
+    myPool <- My.createMySQLPool My.defaultConnectInfo
+        { My.connectUser = "benchmarkdbuser"
+        , My.connectPassword = "benchmarkdbpass"
+        , My.connectDatabase = "hello_world"
+        , My.connectHost = host
         } 1000
+
+    mongoPool <- Mongo.createMongoDBPool "hello_world" host (PortNumber 27017)
+        (Just (Mongo.MongoAuth "benchmarkdbuser" "benchmarkdbpass"))
+           1  -- what is the optimal stripe count? 1 is said to be a good default
+           1000
+           3  -- 3 second timeout
+
     app <- toWaiAppPlain App
-        { appConnPool = pool
-        , appGen = gen
+        { appGen = gen
+        , mySqlPool = myPool
+        , mongoDBPool = mongoPool
         }
     let run = Warp.runSettingsSocket Warp.defaultSettings
                 { Warp.settingsPort = 8000

yesod/benchmark_config

@@ -9,5 +9,12 @@
       "port": 8000,
       "sort": 37
     }
+    "mongodb": {
+      "setup_file": "setup",
+      "db_url": "/mongo/db",
+      "query_url": "/mongo/dbs/",
+      "port": 8000,
+      "sort": 38
+    },
   }]
 }