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

* Use sendWaiResponse * Simplify the Mongo code to avoid persistent-mongoDB * Avoid InternalState acquisition * Use runInUnboundThread for Yesod
Use stylish-haskell on yesod.hs
TechEmpower
diff --git a/frameworks/Haskell/wai/bash_profile.sh b/frameworks/Haskell/wai/bash_profile.sh
@@ -0,0 +1,3 @@
+# Where to find the ghc and cabal executables
+export PATH="/opt/ghc/7.8.3/bin:/opt/cabal/1.20/bin:$PATH"
+export LANG=en_US.UTF-8
diff --git a/frameworks/Haskell/wai/bench/bench.cabal b/frameworks/Haskell/wai/bench/bench.cabal
@@ -11,12 +11,12 @@ executable         bench

    extensions: OverloadedStrings

-    build-depends: base                          >= 4          && < 5
+    build-depends: base                          >= 4.7        && < 5
                 , aeson                         >= 0.6.1.0
-                 , conduit-extra                 >= 1.1
                 , http-types
                 , network                       >= 2.4
-                 , streaming-commons
                 , text                          >= 1.0
                 , wai                           >= 3.0
                 , warp                          >= 3.0
+                 , blaze-builder
+                 , bytestring                    >= 0.10
diff --git a/frameworks/Haskell/wai/bench/wai.hs b/frameworks/Haskell/wai/bench/wai.hs
@@ -1,20 +1,24 @@
 {-# LANGUAGE OverloadedStrings, BangPatterns #-}

+import Blaze.ByteString.Builder (copyByteString)
 import Control.Concurrent (runInUnboundThread)
 import Data.Aeson ((.=), object, encode)
-import Data.Streaming.Network (bindPortTCP)
+import qualified Data.ByteString.Lazy as L
 import Data.Text (Text)
 import Network.HTTP.Types (status200)
-import Network.Wai (responseLBS)
+import Network.Wai (responseBuilder)
 import qualified Network.Wai.Handler.Warp as W

 main :: IO ()
-main = runInUnboundThread $ do
-    s <- bindPortTCP 8000 "*"
-    W.runSettingsSocket settings s app
+main =
+    runInUnboundThread $ W.runSettings settings app
  where
-    settings = W.setOnException (\_ _ -> return ()) W.defaultSettings
+    settings = W.setPort 8000
+             $ W.setOnException (\_ _ -> return ()) W.defaultSettings
    app _ respond = respond response
-    !response = responseLBS status200 ct json
+    !response = responseBuilder status200 ct json
    ct = [("Content-Type", "application/json")]
-    !json = encode $ object ["message" .= ("Hello, World!" :: Text)]
+    !json = copyByteString
+          $ L.toStrict
+          $ encode
+          $ object ["message" .= ("Hello, World!" :: Text)]
diff --git a/frameworks/Haskell/wai/install.sh b/frameworks/Haskell/wai/install.sh
@@ -1,3 +1,3 @@
 #!/bin/bash

-fw_depends haskell
+fw_depends haskell78
diff --git a/frameworks/Haskell/wai/setup.py b/frameworks/Haskell/wai/setup.py
@@ -6,13 +6,11 @@

 def start(args, logfile, errfile):
  subprocess.check_call("cabal update", shell=True, cwd="wai/bench", stderr=errfile, stdout=logfile)
-  subprocess.check_call("cabal install --only-dependencies", shell=True, cwd="wai/bench", stderr=errfile, stdout=logfile)
-  subprocess.check_call("cabal configure", shell=True, cwd="wai/bench", stderr=errfile, stdout=logfile)
-  subprocess.check_call("cabal build", shell=True, cwd="wai/bench", stderr=errfile, stdout=logfile)
+  subprocess.check_call("cabal install", shell=True, cwd="wai/bench", stderr=errfile, stdout=logfile)

  db_host = args.database_host
  threads = str(args.max_threads)
-  subprocess.Popen("dist/build/bench/bench " + threads + " " + db_host + " +RTS -A32m -N", shell=True, cwd="wai/bench", stderr=errfile, stdout=logfile)
+  subprocess.Popen("dist/build/bench/bench " + threads + " " + db_host + " +RTS -A32m -N" + threads, shell=True, cwd="wai/bench", stderr=errfile, stdout=logfile)
  return 0

 def stop(logfile, errfile):
diff --git a/frameworks/Haskell/yesod/bench/bench.cabal b/frameworks/Haskell/yesod/bench/bench.cabal
@@ -19,12 +19,11 @@ executable         bench
                CPP

    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
+                 , persistent-template           >= 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
diff --git a/frameworks/Haskell/yesod/bench/src/yesod.hs b/frameworks/Haskell/yesod/bench/src/yesod.hs
@@ -1,48 +1,58 @@
-{-# LANGUAGE EmptyDataDecls        #-}
-{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE RankNTypes            #-}
-{-# LANGUAGE RecordWildCards       #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE ViewPatterns          #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE ViewPatterns               #-}
 {-# 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)
-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 qualified Network.Wai.Handler.Warp as Warp
-import           System.Environment       (getArgs)
-import qualified System.Random.MWC        as R
-import           Yesod                    hiding (Field)
+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           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.IORef                   (newIORef)
+import           Data.Pool                    (withResource)
+import           Data.Text                    (Text)
+import           Database.MongoDB             (Field ((:=)), (=:))
+import qualified Database.MongoDB             as Mongo
+import           Database.Persist             (Key, PersistEntity,
+                                               PersistEntityBackend,
+                                               PersistStore, get)
+import qualified Database.Persist.MySQL       as My
+import           Database.Persist.TH          (mkPersist, mpsGeneric,
+                                               persistLowerCase, sqlSettings)
+import           Network                      (PortID (PortNumber))
+import           Network.HTTP.Types
+import           Network.Wai
+import qualified Network.Wai.Handler.Warp     as Warp
+import           System.Environment           (getArgs)
+import           System.IO.Unsafe             (unsafePerformIO)
+import qualified System.Random.MWC            as R
+import           Yesod.Core

 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 +63,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 +80,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 +107,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 +118,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 +184,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 ())
diff --git a/frameworks/Haskell/yesod/setup.py b/frameworks/Haskell/yesod/setup.py
@@ -10,7 +10,7 @@ def start(args, logfile, errfile):

  db_host = args.database_host
  threads = str(args.max_threads)
-  subprocess.Popen("dist/build/bench/bench " + threads + " " + db_host + " +RTS -A32M -N", shell=True, cwd="yesod/bench", stderr=errfile, stdout=logfile)
+  subprocess.Popen("dist/build/bench/bench " + threads + " " + db_host + " +RTS -A32M -N" + threads, shell=True, cwd="yesod/bench", stderr=errfile, stdout=logfile)
  return 0

 def stop(logfile, errfile):