Browse Source

Merge branch 'wai' of https://github.com/gregwebs/FrameworkBenchmarks into gregwebs-wai

Patrick Falls 12 years ago
parent
commit
6f987d2454
12 changed files with 225 additions and 41 deletions
  1. 1 0
      .gitignore
  2. 2 0
      wai/.gitignore
  3. 0 0
      wai/__init__.py
  4. 21 0
      wai/bench/bench.cabal
  5. 27 0
      wai/bench/wai.hs
  6. 11 0
      wai/benchmark_config
  7. 29 0
      wai/setup.py
  8. 1 0
      yesod/.gitignore
  9. 0 15
      yesod/README.md
  10. 6 1
      yesod/bench/bench.cabal
  11. 119 25
      yesod/bench/src/yesod.hs
  12. 8 0
      yesod/benchmark_config

+ 1 - 0
.gitignore

@@ -14,3 +14,4 @@ mods/
 /.project
 *.iml
 .idea/
+.hsenv/

+ 2 - 0
wai/.gitignore

@@ -0,0 +1,2 @@
+bench/cabal-dev
+bench/dist

+ 0 - 0
wai/__init__.py


+ 21 - 0
wai/bench/bench.cabal

@@ -0,0 +1,21 @@
+name:              bench-wai
+version:           0.0.0
+cabal-version:     >= 1.8
+build-type:        Simple
+
+executable         bench
+    main-is:           wai.hs
+    hs-source-dirs:    .
+
+    ghc-options:       -Wall -threaded -O2 -rtsopts
+
+    extensions: OverloadedStrings
+
+    build-depends: base                          >= 4          && < 5
+                 , warp                          >= 1.3        && < 1.4
+                 , wai                           >= 1.4
+                 , text                          >= 0.11       && < 0.12
+                 , aeson                         >= 0.6.1.0
+                 , unix                          >= 2.5
+                 , network-conduit               >= 1.0
+                 , http-types

+ 27 - 0
wai/bench/wai.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Data.Aeson
+import Data.Text (Text)
+
+import Control.Monad (replicateM_)
+import Network.HTTP.Types (status200)
+import qualified Network.Wai.Handler.Warp as Warp
+import System.Posix.Process (forkProcess)
+import Data.Conduit.Network (bindPort)
+import Network.Wai
+import System.Environment (getArgs)
+
+main :: IO ()
+main = do
+    socket <- bindPort 8001 "*"
+    [cores, _] <- getArgs
+    let run = Warp.runSettingsSocket Warp.defaultSettings
+                { Warp.settingsPort = 8001
+                , Warp.settingsHost = "*"
+                , Warp.settingsOnException = const $ return ()
+                } socket app
+    replicateM_ (read cores - 1) $ forkProcess run
+    run
+  where
+    app _ = return $ responseLBS
+      status200 [("Content-Type", "application/json")] $
+      encode $ object ["message" .= ("Hello, World!" :: Text)]

+ 11 - 0
wai/benchmark_config

@@ -0,0 +1,11 @@
+{
+  "framework": "wai",
+  "tests": [{
+    "default": {
+      "setup_file": "setup",
+      "json_url": "/json",
+      "port": 8001,
+      "sort": 37
+    }
+  }]
+}

+ 29 - 0
wai/setup.py

@@ -0,0 +1,29 @@
+
+import subprocess
+import sys
+import setup_util
+import os
+
+def start(args):
+  subprocess.check_call("cabal update", shell=True, cwd="wai/bench")
+  subprocess.check_call("cabal install --only-dependencies", shell=True, cwd="wai/bench")
+  subprocess.check_call("cabal configure", shell=True, cwd="wai/bench")
+  subprocess.check_call("cabal build", shell=True, cwd="wai/bench")
+
+  db_host = args.database_host
+  threads = str(args.max_threads)
+  subprocess.Popen("dist/build/bench/bench " + threads + " " + db_host + " +RTS -A4M -N -qg2 -I0 -G2 > /dev/null", shell=True, cwd="wai/bench")
+  return 0
+
+def stop():
+  p = subprocess.Popen(['ps', 'aux'], stdout=subprocess.PIPE)
+  out, err = p.communicate()
+  for line in out.splitlines():
+    if 'bench' in line:
+      try:
+        pid = int(line.split(None, 2)[1])
+        os.kill(pid, 9)
+      except OSError:
+        pass
+
+  return 0

+ 1 - 0
yesod/.gitignore

@@ -0,0 +1 @@
+bench/cabal-dev

+ 0 - 15
yesod/README.md

@@ -2,23 +2,8 @@
 
 This is the Yesod portion of a [benchmarking test suite](../) comparing a variety of web development platforms.
 
-* [Controllers](bench/Application.hs)
-* [Model](bench/config/models)
 
 ## Infrastructure Software Versions
 The tests were run with:
 * GHC 7.4.1
 * Yesod 1.1.9.2
-
-## Test URLs
-### JSON Encoding Test
-
-http://localhost:8000/json
-
-### Data-Store/Database Mapping Test
-
-http://localhost:8000/db
-
-### Variable Query Test
-
-http://localhost:8000/db2/2

+ 6 - 1
yesod/bench/bench.cabal

@@ -7,7 +7,7 @@ executable         bench
     main-is:           yesod.hs
     hs-source-dirs:    src
 
-    ghc-options:       -threaded -O2 -rtsopts
+    ghc-options:       -Wall -threaded -O2 -rtsopts
 
     extensions: TemplateHaskell
                 QuasiQuotes
@@ -22,9 +22,14 @@ executable         bench
                  , text                          >= 0.11       && < 0.12
                  , persistent                    >= 1.1        && < 1.2
                  , persistent-mysql              >= 1.1        && < 1.2
+                 , persistent-mongoDB            >= 1.1.6      && < 1.2
                  , warp                          >= 1.3        && < 1.4
                  , unix                          >= 2.5
                  , network-conduit               >= 1.0
                  , primitive                     >= 0.5
                  , mwc-random                    >= 0.12
                  , pool-conduit                  >= 0.1
+                 , network
+                 , lifted-async                  >= 0.1
+                 , mongoDB
+                 , aeson

+ 119 - 25
yesod/bench/src/yesod.hs

@@ -2,19 +2,27 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE EmptyDataDecls #-}
-import Yesod
+{-# LANGUAGE RankNTypes #-}
+import Yesod hiding (Field)
 import System.Environment (getArgs)
 import qualified Network.Wai.Handler.Warp as Warp
 import Data.Text (Text)
 import Data.Conduit.Pool (Pool)
-import Database.Persist.Store (get, PersistValue (PersistInt64))
-import Database.Persist.MySQL
+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)
 import Data.Conduit.Network (bindPort)
 import System.Posix.Process (forkProcess)
 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
@@ -22,14 +30,24 @@ World sql=World
 |]
 
 data App = App
-    { appConnPool :: Pool Connection
-    , appGen :: R.Gen (PrimState IO)
+    { appGen :: R.Gen (PrimState IO)
+    , mySqlPool :: Pool My.Connection
+    , mongoDBPool :: Pool Mongo.Connection
     }
 
+-- | Not actually using the non-raw mongoDB.
+-- persistent-mongoDB expects a field of '_id', not 'id'
 mkYesod "App" [parseRoutes|
-/json JsonR GET
-/db DbR GET
-/dbs/#Int DbsR GET
+/json               JsonR     GET
+
+/db                 DbR       GET
+/dbs/#Int           DbsR      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
@@ -40,35 +58,111 @@ 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
-    Just x <- flip runSqlPool appConnPool $ get (Key $ PersistInt64 i :: WorldId)
-    jsonToRepJson $ object ["id" .= i, "randomNumber" .= worldRandomNumber x]
+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
-    objs <- replicateM cnt $ do
-        i <- liftIO $ R.uniformR (1, 10000) appGen
-        Just x <- flip runSqlPool appConnPool $ get (Key $ PersistInt64 i :: WorldId)
-        return $ object ["id" .= i, "randomNumber" .= worldRandomNumber x]
-    jsonToRepJson $ array objs
+    multiRandomHandler (intQuery runMySQL) cnt
+
+getMongoDbsR :: Int -> Handler RepJson
+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
+  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 $ 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")
+    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.Float f)  = toJSON f
+  toJSON (Mongo.Doc d)   = documentToJson d
+  toJSON s = error $ "no convert for: " ++ show s
+
+
 
 main :: IO ()
 main = R.withSystemRandom $ \gen -> do
     socket <- bindPort 8000 "*"
     [cores, host] <- getArgs
-    pool <- createMySQLPool defaultConnectInfo
-        { connectUser = "benchmarkdbuser"
-        , connectPassword = "benchmarkdbpass"
-        , connectDatabase = "hello_world"
-        , connectHost = host
+    myPool <- 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
+
     app <- toWaiAppPlain App
-        { appConnPool = pool
-        , appGen = gen
+        { appGen = gen
+        , mySqlPool = myPool
+        , mongoDBPool = mongoPool
         }
     let run = Warp.runSettingsSocket Warp.defaultSettings
                 { Warp.settingsPort = 8000

+ 8 - 0
yesod/benchmark_config

@@ -8,6 +8,14 @@
       "query_url": "/dbs/",
       "port": 8000,
       "sort": 37
+    },
+    "mongodb-raw": {
+      "setup_file": "setup",
+      "json_url": "/json",
+      "db_url": "/mongo/raw/db",
+      "query_url": "/mongo/raw/dbs/",
+      "port": 8000,
+      "sort": 47
     }
   }]
 }