add mongodb-raw for yesod

yesod/bench/bench.cabal

@@ -31,3 +31,5 @@ executable         bench
                  , pool-conduit                  >= 0.1
                  , network
                  , lifted-async                  >= 0.1
+                 , mongoDB
+                 , aeson

yesod/bench/src/yesod.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE RankNTypes #-}
-import Yesod
+import Yesod hiding (Field)
 import System.Environment (getArgs)
 import qualified Network.Wai.Handler.Warp as Warp
 import Data.Text (Text)
@@ -11,6 +11,8 @@ import Data.Conduit.Pool (Pool)
 import Database.Persist.Store (PersistValue (PersistInt64))
 import qualified Database.Persist.MySQL as My
 import qualified Database.Persist.MongoDB as Mongo
+import qualified Database.MongoDB as Mongo
+import Database.MongoDB ((=:), Field((:=)))
 import qualified System.Random.MWC as R
 import Control.Monad.Primitive (PrimState)
 import Control.Monad (replicateM)
@@ -20,6 +22,7 @@ import Control.Monad (replicateM_)
 import Network (PortID (PortNumber))
 import Control.Concurrent.Async.Lifted (mapConcurrently)
 import Data.Int (Int64)
+import Data.Aeson (ToJSON(..))
 
 mkPersist sqlSettings [persist|
 World sql=World
@@ -33,13 +36,16 @@ data App = App
     }
 
 mkYesod "App" [parseRoutes|
-/json           JsonR     GET
+/json               JsonR     GET
 
-/db             DbR       GET
-/dbs/#Int       DbsR      GET
+/db                 DbR       GET
+/dbs/#Int           DbsR      GET
 
-/mongo/db       MongoDbR  GET
-/mongo/dbs/#Int MongoDbsR GET
+/mongo/db           MongoDbR  GET
+/mongo/dbs/#Int     MongoDbsR GET
+
+/mongo/raw/db       MongoRawDbR  GET
+/mongo/raw/dbs/#Int MongoRawDbsR GET
 |]
 
 instance Yesod App where
@@ -50,48 +56,88 @@ instance Yesod App where
 getJsonR :: Handler RepJson
 getJsonR = jsonToRepJson $ object ["message" .= ("Hello, World!" :: Text)]
 
+
 getDbR :: Handler RepJson
-getDbR = do
-    App {..} <- getYesod
-    i <- liftIO $ R.uniformR (1, 10000) appGen
-    jsonToRepJson =<< intQuery (flip My.runSqlPool mySqlPool) i
+getDbR = getDb (intQuery runMySQL )
+
+getMongoDbR :: Handler RepJson
+getMongoDbR = getDb (intQuery runMongoDB )
+
+getMongoRawDbR :: Handler RepJson
+getMongoRawDbR = getDb rawMongoIntQuery
 
 getDbsR :: Int -> Handler RepJson
 getDbsR cnt = do
-  App {..} <- getYesod
-  multiRandomHandler (flip My.runSqlPool mySqlPool) appGen cnt
-
-getMongoDbR :: Handler RepJson
-getMongoDbR = do
     App {..} <- getYesod
-    i <- liftIO $ R.uniformR (1, 10000) appGen
-    jsonToRepJson =<< intQuery (flip Mongo.runMongoDBPoolDef mongoDBPool) i
+    multiRandomHandler (intQuery runMySQL) cnt
 
 getMongoDbsR :: Int -> Handler RepJson
-getMongoDbsR cnt = do
+getMongoDbsR cnt = multiRandomHandler (intQuery runMongoDB) cnt
+
+getMongoRawDbsR :: Int -> Handler RepJson
+getMongoRawDbsR cnt = multiRandomHandler rawMongoIntQuery cnt
+
+
+randomNumber :: R.Gen (PrimState IO) -> IO Int64
+randomNumber appGen = R.uniformR (1, 10000) appGen
+
+getDb :: ToJSON a => (Int64 -> Handler a) -> Handler RepJson
+getDb query = do
+    app <- getYesod
+    i <- liftIO (randomNumber (appGen app))
+    jsonToRepJson =<< query i
+
+
+runMongoDB :: Mongo.Action Handler b -> Handler b
+runMongoDB f = 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
+  Mongo.runMongoDBPoolDef f mongoDBPool
+
+runMySQL :: My.SqlPersist Handler b -> Handler b
+runMySQL f = do
+  App {..} <- getYesod
+  My.runSqlPool f mySqlPool
+
+intQuery :: forall (m :: * -> *) (m1 :: * -> *) val backend.
+           (Monad m, PersistEntity val, PersistStore m1,
+            PersistEntityBackend val ~ PersistMonadBackend m1) =>
+           (m1 (Maybe val) -> m (Maybe (WorldGeneric backend)))
+           -> Int64 -> m Value
 intQuery db i = do
     Just x <- db $ get (Key $ PersistInt64 i)
-    return $ object ["id" .= i, "randomNumber" .= worldRandomNumber x]
+    return $ jsonResult i (worldRandomNumber x)
+  where
+    jsonResult :: Int64 -> Int -> Value
+    jsonResult i n = object ["id" .= i, "randomNumber" .= n]
+
+rawMongoIntQuery :: Mongo.Val v => v -> Handler Value
+rawMongoIntQuery i = do
+    Just x <- runMongoDB $ Mongo.findOne (Mongo.select ["id" =: i] "World")
+    return $ documentToJson x
+
+multiRandomHandler :: ToJSON a
+                   => (Int64 -> Handler a)
+                   -> Int
+                   -> Handler RepJson
+multiRandomHandler operation cnt = do
+    App {..} <- getYesod
+    nums <- liftIO $ replicateM cnt (randomNumber appGen)
+    jsonToRepJson . array =<< mapConcurrently operation nums
+
+documentToJson :: [Field] -> Value
+documentToJson = object . map toAssoc
+  where
+    toAssoc :: Field -> (Text, Value)
+    toAssoc ("_id" := v) = ("id", toJSON v)
+    toAssoc (l := v) = (l, toJSON v)
+
+instance ToJSON Mongo.Value where
+  toJSON (Mongo.Int32 i)  = toJSON i
+  toJSON (Mongo.Int64 i)  = toJSON i
+  toJSON (Mongo.Doc d)   = documentToJson d
+  toJSON s = error $ "no convert for: " ++ show s
+
+
 
 main :: IO ()
 main = R.withSystemRandom $ \gen -> do

yesod/benchmark_config

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