Merge branch 'master' of https://github.com/stevely/FrameworkBenchmarks into stevely-master

snap/README.md

@@ -0,0 +1,30 @@
+# Snap Benchmarking Test
+
+This is the Snap portion of a [benchmarking test suite](../) comparing a variety of web development platforms.
+
+* [Source](bench/src/Main.hs)
+* [Configurations](bench/cfg/db.cfg)
+
+## Infrastructure Software Versions
+The tests were run with:
+* GHC 7.4.1
+* snap-core 0.9.3.1
+* snap-server 0.9.3.3
+* json 0.7
+* configurator 0.2.0.2
+* resource-pool 0.2.1.1
+* HDBC-mysql 0.6.6.1
+* HDBC 2.3.1.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/db?queries=2

snap/bench/cfg/db.cfg

@@ -0,0 +1,5 @@
+host="127.0.0.1"
+uname="benchmarkdbuser"
+pword="benchmarkdbpass"
+dbase="hello_world"
+dport="3306"

snap/bench/snap-bench.cabal

@@ -0,0 +1,38 @@
+Name:                snap-bench
+Version:             0.1
+Synopsis:            Snap test for benchmark tests
+Description:         Simple web services to benchmark the Snap web server
+License:             BSD3
+Author:              Steve Smith
+Maintainer:          [email protected]
+Stability:           Experimental
+Category:            Web
+Build-type:          Simple
+Cabal-version:       >=1.2
+data-dir:            cfg
+data-files:          db.cfg
+
+Executable snap-bench
+  hs-source-dirs: src
+  main-is: Main.hs
+
+  Build-depends:
+    base                      >= 4     && < 5,
+    bytestring                >= 0.9.1 && < 0.11,
+    MonadCatchIO-transformers >= 0.2.1 && < 0.4,
+    mtl                       >= 2     && < 3,
+    snap-core                 >= 0.9   && < 0.10,
+    snap-server               >= 0.9   && < 0.10,
+    json                      >= 0.7   && < 0.8,
+    configurator              >= 0.2   && < 0.3,
+    resource-pool             >= 0.2   && < 0.3,
+    HDBC-mysql                >= 0.6   && < 0.7,
+    HDBC                      >= 2     && < 3,
+    transformers              >= 0.3   && < 0.4,
+    random                    >= 1     && < 2
+
+  if impl(ghc >= 6.12.0)
+    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
+                 -fno-warn-unused-do-bind -rtsopts
+  else
+    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2

snap/bench/src/Main.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.IO.Class
+import Database.HDBC
+import Database.HDBC.MySQL
+import Data.Configurator
+import Data.Int
+import Data.Pool
+import Paths_snap_bench
+import Prelude hiding (lookup)
+import qualified Data.ByteString.Char8 as B
+import Snap.Core
+import Snap.Http.Server
+import System.Random
+import Text.JSON
+
+main :: IO ()
+main = do
+    fp <- getDataFileName "db.cfg"
+    db <- load [Required fp]
+    foos <- mapM (lookup db) ["host", "uname", "pword", "dbase", "dport"]
+    let foos' = sequence foos
+    maybe (putStrLn "No foo") dbSetup foos'
+
+dbSetup :: [String] -> IO ()
+dbSetup sets = let info = getConnInfo sets
+                   config = setAccessLog ConfigNoLog $
+                            setErrorLog ConfigNoLog $
+                            setPort 8000 $
+                            defaultConfig
+                in do pool <- createPool (connectMySQL info) disconnect 1 10 50
+                      httpServe config $ site pool
+
+getConnInfo :: [String] -> MySQLConnectInfo
+getConnInfo [host,uname,pword,dbase,dport] = defaultMySQLConnectInfo {
+    mysqlHost     = host,
+    mysqlUser     = uname,
+    mysqlPassword = pword,
+    mysqlDatabase = dbase,
+    mysqlPort     = read dport
+    }
+getConnInfo _ = defaultMySQLConnectInfo
+
+site :: IConnection a => Pool a -> Snap ()
+site pool = route [ ("json", jsonHandler)
+                  , ("db", dbHandler pool)
+                  ]
+
+jsonHandler :: Snap ()
+jsonHandler = do
+    modifyResponse (setContentType "application/json")
+    writeBS $ B.pack $ encode $ toJSObject [("message", "Hello, World!" :: String)]
+
+dbHandler :: IConnection a => Pool a -> Snap ()
+dbHandler pool = do
+    modifyResponse (setContentType "application/json")
+    queries <- getQueryParam "queries"
+    maybe (db 1) fn (gn queries)
+    where fn q = db q
+          gn s = fmap fst $ s >>= B.readInt
+          db = dbHandler' pool
+
+dbHandler' :: IConnection a => Pool a -> Int -> Snap ()
+dbHandler' pool i = do
+    rows <- liftIO $ withResource pool runQuery
+    writeBS $ B.pack $ encode $ map jsonRow $ concat rows
+    where runQuery conn = replicateM i $ do
+              (ix,_) <- randomR (1, 10000 :: Int32) <$> newStdGen
+              withSB $ quickQuery' conn query [SqlInt32 ix]
+          withSB = withRTSSignalsBlocked
+          query = "SELECT * FROM World where id=?"
+
+jsonRow :: [SqlValue] -> JSValue
+jsonRow [i, v] = JSObject $ toJSObject [("id", showJSON i), ("randomNumber", showJSON v)]
+jsonRow _ = JSNull
+
+instance JSON SqlValue where
+    readJSON = undefined -- Poor form, but unneeded
+    showJSON v = case v of -- We're just doing the obvious stuff since this is a 1-off
+        SqlString s -> JSString $ toJSString s
+        SqlByteString s -> showJSON s
+        SqlWord32 i -> showJSON i
+        SqlWord64 i -> showJSON i
+        SqlInt32 i -> showJSON i
+        SqlInt64 i -> showJSON i
+        SqlInteger i -> showJSON i
+        SqlChar c -> showJSON c
+        SqlBool b -> showJSON b
+        SqlDouble d -> showJSON d
+        _ -> JSNull

snap/benchmark_config

@@ -0,0 +1,13 @@
+{
+  "framework": "snap",
+  "tests": [{
+    "default": {
+      "setup_file": "setup",
+      "json_url": "/json",
+      "db_url": "/db",
+      "query_url": "/db?queries=",
+      "port": 8000,
+      "sort": 39
+    }
+  }]
+}

snap/setup.py

@@ -0,0 +1,26 @@
+import subprocess
+import sys
+import setup_util
+import os
+
+def start(args):
+  setup_util.replace_text("snap/bench/cfg/db.cfg", "host: .*", "host: \"" + args.database_host + "\"")
+  
+  subprocess.check_call("cabal configure", shell=True, cwd="snap/bench")
+  subprocess.check_call("cabal build", shell=True, cwd="snap/bench")
+
+  subprocess.Popen("dist/build/snap-bench/snap-bench +RTS -N" + str(args.max_threads) + " > /dev/null", shell=True, cwd="snap/bench")
+  return 0
+
+def stop():
+  p = subprocess.Popen(['ps', 'aux'], stdout=subprocess.PIPE)
+  out, err = p.communicate()
+  for line in out.splitlines():
+    if 'snap-bench' in line:
+      try:
+        pid = int(line.split(None, 2)[1])
+        os.kill(pid, 9)
+      except OSError:
+        pass
+
+  return 0