yesod 1.4 and disable non-raw MongoDB

Author: snoyberg

frameworks/Haskell/yesod/bench/bench.cabal

@@ -16,17 +16,21 @@ executable         bench
                 TypeFamilies
                 GADTs
                 EmptyDataDecls
+                CPP
 
     build-depends: base                          >= 4.7        && < 5
-                 , yesod                         >= 1.2.5.2    && < 1.3
-                 , yesod-core                    == 1.2.14     && < 1.3
-                 , text                          >= 0.11       && < 1.2
-                 , persistent                    >= 1.3        && < 1.4
-                 , persistent-mysql              >= 1.3        && < 1.4
-                 , persistent-mongoDB            >= 1.3        && < 1.4
-                 , warp                          >= 2.1        && < 2.2
+                 , yesod                         >= 1.4        && < 1.5
+                 , yesod-core                    >= 1.4        && < 1.5
+                 , text                          >= 0.11       && < 1.3
+                 , persistent                    >= 2.1        && < 2.2
+                 , persistent-mysql              >= 2.1        && < 2.2
+                 , persistent-mongoDB            >= 2.1        && < 2.2
+                 , warp                          >= 3.0.2.2    && < 3.1
+                 , auto-update                   >= 0.1.1.4    && < 0.2
                  , primitive                     >= 0.5
                  , mwc-random                    >= 0.12
                  , pool-conduit                  >= 0.1.2
                  , network
                  , mongoDB
+                 , monad-logger
+                 , mtl

frameworks/Haskell/yesod/bench/src/yesod.hs

@@ -1,16 +1,22 @@
 {-# LANGUAGE EmptyDataDecls        #-}
 {-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE QuasiQuotes           #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE ViewPatterns          #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Main (main, resourcesApp, Widget, WorldId) where
 import           Control.Monad            (replicateM)
+import           Control.Monad.Logger     (runNoLoggingT)
 import           Control.Monad.Primitive  (PrimState)
+import           Control.Monad.Reader     (ReaderT)
 import           Data.Conduit.Pool        (Pool)
 import           Data.Int                 (Int64)
 import           Data.Text                (Text)
@@ -24,14 +30,18 @@ import           System.Environment       (getArgs)
 import qualified System.Random.MWC        as R
 import           Yesod                    hiding (Field)
 
-mkPersist sqlSettings [persistLowerCase|
+mkPersist sqlSettings { mpsGeneric = True } [persistLowerCase|
 World sql=World
     randomNumber Int sql=randomNumber
+#ifdef MONGODB
+    id           Int64
+    UniqueId
+#endif
 |]
 
 data App = App
     { appGen      :: !(R.Gen (PrimState IO))
-    , mySqlPool   :: !(Pool My.Connection)
+    , mySqlPool   :: !(Pool My.SqlBackend)
     , mongoDBPool :: !(Pool Mongo.Connection)
     }
 
@@ -43,8 +53,10 @@ mkYesod "App" [parseRoutes|
 /db                 DbR       GET
 /dbs/#Int           DbsR      GET
 
+#ifdef MONGODB
 /mongo/db           MongoDbR  GET
 /mongo/dbs/#Int     MongoDbsR GET
+#endif
 
 /mongo/raw/db       MongoRawDbR  GET
 /mongo/raw/dbs/#Int MongoRawDbsR GET
@@ -60,21 +72,25 @@ getJsonR = return $ object ["message" .= ("Hello, World!" :: Text)]
 
 
 getDbR :: Handler Value
-getDbR = getDb (intQuery runMySQL )
+getDbR = getDb (intQuery runMySQL My.toSqlKey)
 
+#ifdef MONGODB
 getMongoDbR :: Handler Value
-getMongoDbR = getDb (intQuery runMongoDB )
+getMongoDbR = getDb (intQuery runMongoDB (getBy . UniqueId))
+#endif
 
 getMongoRawDbR :: Handler Value
 getMongoRawDbR = getDb rawMongoIntQuery
 
 getDbsR :: Int -> Handler Value
 getDbsR cnt = do
     App {..} <- getYesod
-    multiRandomHandler (intQuery runMySQL) cnt
+    multiRandomHandler (intQuery runMySQL My.toSqlKey) cnt
 
+#ifdef MONGODB
 getMongoDbsR :: Int -> Handler Value
-getMongoDbsR cnt = multiRandomHandler (intQuery runMongoDB) cnt
+getMongoDbsR cnt = multiRandomHandler (intQuery runMongoDB (getBy . UniqueId)) cnt
+#endif
 
 getMongoRawDbsR :: Int -> Handler Value
 getMongoRawDbsR cnt = multiRandomHandler rawMongoIntQuery cnt
@@ -100,21 +116,22 @@ 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)))
+intQuery :: (MonadIO m, PersistEntity val, PersistStore backend
+            , backend ~ PersistEntityBackend val
+            ) =>
+           (ReaderT backend m (Maybe val) -> m (Maybe (WorldGeneric backend)))
+           -> (Int64 -> Key val)
            -> Int64 -> m Value
-intQuery db i = do
-    Just x <- db $ get (Key $ PersistInt64 i)
+intQuery db toKey i = do
+    Just x <- db $ get $ toKey i
     return $ jsonResult (worldRandomNumber x)
   where
     jsonResult :: Int -> Value
     jsonResult 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")
+    Just x <- runMongoDB $ Mongo.findOne (Mongo.select ["id" =: i] "World")
     return $ documentToJson x
 
 multiRandomHandler :: ToJSON a
@@ -145,7 +162,7 @@ instance ToJSON Mongo.Value where
 main :: IO ()
 main = R.withSystemRandom $ \gen -> do
     [_cores, host] <- getArgs
-    myPool <- My.createMySQLPool My.defaultConnectInfo
+    myPool <- runNoLoggingT $ My.createMySQLPool My.defaultConnectInfo
         { My.connectUser = "benchmarkdbuser"
         , My.connectPassword = "benchmarkdbpass"
         , My.connectDatabase = "hello_world"