Some Yesod cleanup/optimization

* Use sendWaiResponse
* Simplify the Mongo code to avoid persistent-mongoDB
* Avoid InternalState acquisition
* Use runInUnboundThread for Yesod

Author: snoyberg

frameworks/Haskell/yesod/bench/bench.cabal

@@ -20,11 +20,10 @@ executable         bench
 
     build-depends: base                          >= 4.7        && < 5
                  , yesod                         >= 1.4        && < 1.5
-                 , yesod-core                    >= 1.4        && < 1.5
+                 , yesod-core                    >= 1.4.2      && < 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
@@ -34,3 +33,10 @@ executable         bench
                  , mongoDB
                  , monad-logger
                  , mtl
+                 , wai
+                 , http-types
+                 , aeson
+                 , blaze-builder
+                 , bytestring                    >= 0.10
+                 , resource-pool
+                 , resourcet

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

@@ -13,36 +13,41 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Main (main, resourcesApp, Widget, WorldId) where
+import           Blaze.ByteString.Builder
+import           Control.Concurrent           (runInUnboundThread)
 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           Control.Monad.Trans.Resource (InternalState)
+import           Data.Aeson               (encode)
+import qualified Data.ByteString.Lazy     as L
+import           Data.Conduit.Pool        (Pool, createPool)
 import           Data.Int                 (Int64)
+import           Data.Pool                (withResource)
 import           Data.Text                (Text)
 import           Database.MongoDB         (Field ((:=)), (=:))
 import qualified Database.MongoDB         as Mongo
-import qualified Database.Persist.MongoDB as Mongo
 import qualified Database.Persist.MySQL   as My
 import           Network                  (PortID (PortNumber))
+import           Network.HTTP.Types
+import           Network.Wai
 import qualified Network.Wai.Handler.Warp as Warp
 import           System.Environment       (getArgs)
 import qualified System.Random.MWC        as R
 import           Yesod                    hiding (Field)
+import Data.IORef (newIORef)
+import System.IO.Unsafe (unsafePerformIO)
 
 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.SqlBackend)
-    , mongoDBPool :: !(Pool Mongo.Connection)
+    , mongoDBPool :: !(Pool Mongo.Pipe)
     }
 
 -- | Not actually using the non-raw mongoDB.
@@ -53,15 +58,14 @@ 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
 |]
 
+fakeInternalState :: InternalState
+fakeInternalState = unsafePerformIO $ newIORef $ error "fakeInternalState forced"
+{-# NOINLINE fakeInternalState #-}
+
 instance Yesod App where
     makeSessionBackend _ = return Nothing
     {-# INLINE makeSessionBackend #-}
@@ -71,20 +75,25 @@ instance Yesod App where
     {-# INLINE yesodMiddleware #-}
     cleanPath _ = Right
     {-# INLINE cleanPath #-}
-
-getJsonR :: Handler TypedContent
-getJsonR = return $ TypedContent typeJson
-         $ toContent $ object ["message" .= ("Hello, World!" :: Text)]
+    yesodWithInternalState _ _ = ($ fakeInternalState)
+    {-# INLINE yesodWithInternalState #-}
+    maximumContentLength _ _ = Nothing
+    {-# INLINE maximumContentLength #-}
+
+getJsonR :: Handler ()
+getJsonR = sendWaiResponse
+         $ responseBuilder
+            status200
+            [("Content-Type", typeJson)]
+         $ copyByteString
+         $ L.toStrict
+         $ encode
+         $ object ["message" .= ("Hello, World!" :: Text)]
 
 
 getDbR :: Handler Value
 getDbR = getDb (intQuery runMySQL My.toSqlKey)
 
-#ifdef MONGODB
-getMongoDbR :: Handler Value
-getMongoDbR = getDb (intQuery runMongoDB (getBy . UniqueId))
-#endif
-
 getMongoRawDbR :: Handler Value
 getMongoRawDbR = getDb rawMongoIntQuery
 
@@ -93,11 +102,6 @@ getDbsR cnt = do
     App {..} <- getYesod
     multiRandomHandler (intQuery runMySQL My.toSqlKey) cnt
 
-#ifdef MONGODB
-getMongoDbsR :: Int -> Handler Value
-getMongoDbsR cnt = multiRandomHandler (intQuery runMongoDB (getBy . UniqueId)) cnt
-#endif
-
 getMongoRawDbsR :: Int -> Handler Value
 getMongoRawDbsR cnt = multiRandomHandler rawMongoIntQuery cnt
 
@@ -109,13 +113,21 @@ getDb :: (Int64 -> Handler Value) -> Handler Value
 getDb query = do
     app <- getYesod
     i <- liftIO (randomNumber (appGen app))
-    query i
+    value <- query i
+    sendWaiResponse
+        $ responseBuilder
+            status200
+            [("Content-Type", typeJson)]
+        $ copyByteString
+        $ L.toStrict
+        $ encode value
 
 
 runMongoDB :: Mongo.Action Handler b -> Handler b
 runMongoDB f = do
   App {..} <- getYesod
-  Mongo.runMongoDBPoolDef f mongoDBPool
+  withResource mongoDBPool $ \pipe ->
+    Mongo.access pipe Mongo.ReadStaleOk "hello_world" f
 
 runMySQL :: My.SqlPersistT Handler b -> Handler b
 runMySQL f = do
@@ -167,26 +179,27 @@ instance ToJSON Mongo.Value where
 
 main :: IO ()
 main = R.withSystemRandom $ \gen -> do
-    [_cores, host] <- getArgs
+    [cores, host] <- getArgs
     myPool <- runNoLoggingT $ 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
+    mongoPool <- createPool
+        (Mongo.connect $ Mongo.Host host $ PortNumber 27017)
+        Mongo.close
+        (read cores) -- what is the optimal stripe count? 1 is said to be a good default
+        3  -- 3 second timeout
+        1000
 
     app <- toWaiAppPlain App
         { appGen = gen
         , mySqlPool = myPool
         , mongoDBPool = mongoPool
         }
-    Warp.runSettings
+    runInUnboundThread $ Warp.runSettings
         ( Warp.setPort 8000
         $ Warp.setHost "*"
         $ Warp.setOnException (\_ _ -> return ())