Merge pull request #1086 from snoyberg/master

Updates to Yesod and WAI
LGTM!

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

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

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)]

frameworks/Haskell/wai/install.sh

@@ -1,3 +1,3 @@
 #!/bin/bash
 
-fw_depends haskell
+fw_depends haskell78

frameworks/Haskell/wai/setup.py

@@ -6,13 +6,11 @@ import os
 
 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):

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

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,7 +184,7 @@ 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"
@@ -175,18 +192,19 @@ main = R.withSystemRandom $ \gen -> do
         , 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 ())

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):