Browse Source

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

Patrick Falls 12 years ago
parent
commit
82e5b43141
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
 /.project
 *.iml
 *.iml
 .idea/
 .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.
 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
 ## Infrastructure Software Versions
 The tests were run with:
 The tests were run with:
 * GHC 7.4.1
 * GHC 7.4.1
 * Yesod 1.1.9.2
 * 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
     main-is:           yesod.hs
     hs-source-dirs:    src
     hs-source-dirs:    src
 
 
-    ghc-options:       -threaded -O2 -rtsopts
+    ghc-options:       -Wall -threaded -O2 -rtsopts
 
 
     extensions: TemplateHaskell
     extensions: TemplateHaskell
                 QuasiQuotes
                 QuasiQuotes
@@ -22,9 +22,14 @@ executable         bench
                  , text                          >= 0.11       && < 0.12
                  , text                          >= 0.11       && < 0.12
                  , persistent                    >= 1.1        && < 1.2
                  , persistent                    >= 1.1        && < 1.2
                  , persistent-mysql              >= 1.1        && < 1.2
                  , persistent-mysql              >= 1.1        && < 1.2
+                 , persistent-mongoDB            >= 1.1.6      && < 1.2
                  , warp                          >= 1.3        && < 1.4
                  , warp                          >= 1.3        && < 1.4
                  , unix                          >= 2.5
                  , unix                          >= 2.5
                  , network-conduit               >= 1.0
                  , network-conduit               >= 1.0
                  , primitive                     >= 0.5
                  , primitive                     >= 0.5
                  , mwc-random                    >= 0.12
                  , mwc-random                    >= 0.12
                  , pool-conduit                  >= 0.1
                  , 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 GADTs #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE EmptyDataDecls #-}
-import Yesod
+{-# LANGUAGE RankNTypes #-}
+import Yesod hiding (Field)
 import System.Environment (getArgs)
 import System.Environment (getArgs)
 import qualified Network.Wai.Handler.Warp as Warp
 import qualified Network.Wai.Handler.Warp as Warp
 import Data.Text (Text)
 import Data.Text (Text)
 import Data.Conduit.Pool (Pool)
 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 qualified System.Random.MWC as R
 import Control.Monad.Primitive (PrimState)
 import Control.Monad.Primitive (PrimState)
 import Control.Monad (replicateM)
 import Control.Monad (replicateM)
 import Data.Conduit.Network (bindPort)
 import Data.Conduit.Network (bindPort)
 import System.Posix.Process (forkProcess)
 import System.Posix.Process (forkProcess)
 import Control.Monad (replicateM_)
 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|
 mkPersist sqlSettings [persist|
 World sql=World
 World sql=World
@@ -22,14 +30,24 @@ World sql=World
 |]
 |]
 
 
 data App = App
 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|
 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
 instance Yesod App where
@@ -40,35 +58,111 @@ instance Yesod App where
 getJsonR :: Handler RepJson
 getJsonR :: Handler RepJson
 getJsonR = jsonToRepJson $ object ["message" .= ("Hello, World!" :: Text)]
 getJsonR = jsonToRepJson $ object ["message" .= ("Hello, World!" :: Text)]
 
 
+
 getDbR :: Handler RepJson
 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 :: Int -> Handler RepJson
 getDbsR cnt = do
 getDbsR cnt = do
     App {..} <- getYesod
     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 :: IO ()
 main = R.withSystemRandom $ \gen -> do
 main = R.withSystemRandom $ \gen -> do
     socket <- bindPort 8000 "*"
     socket <- bindPort 8000 "*"
     [cores, host] <- getArgs
     [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
         } 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
     app <- toWaiAppPlain App
-        { appConnPool = pool
-        , appGen = gen
+        { appGen = gen
+        , mySqlPool = myPool
+        , mongoDBPool = mongoPool
         }
         }
     let run = Warp.runSettingsSocket Warp.defaultSettings
     let run = Warp.runSettingsSocket Warp.defaultSettings
                 { Warp.settingsPort = 8000
                 { Warp.settingsPort = 8000

+ 8 - 0
yesod/benchmark_config

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