Merge pull request #1954 from Rydgel/master

Spock Haskell Framework - Adding new framework to the benchmark

.travis.yml

@@ -68,6 +68,7 @@ env:
     - "TESTDIR=Haskell/snap"
     - "TESTDIR=Haskell/wai"
     - "TESTDIR=Haskell/yesod"
+    - "TESTDIR=Haskell/spock"
     - "TESTDIR=Java/activeweb"
     - "TESTDIR=Java/baratine"
     - "TESTDIR=Java/bayou"

frameworks/Haskell/spock/.gitignore

@@ -0,0 +1,17 @@
+dist
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+.virtualenv
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+cabal.config
+.stack-work
+*.prof
+*.hp
+*.aux
+.DS_Store

frameworks/Haskell/spock/LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2016
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

frameworks/Haskell/spock/README.md

@@ -0,0 +1,5 @@
+# Spock Benchmarking Test
+
+This is the [Spock](http://spock.li) portion of a [benchmarking test suite](../) comparing a variety of web development platforms.
+
+This test is using PostgreSQL as the database backend.

frameworks/Haskell/spock/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

frameworks/Haskell/spock/benchmark_config.json

@@ -0,0 +1,28 @@
+{
+  "framework": "spock",
+  "tests": [{
+    "default": {
+      "setup_file": "setup",
+      "json_url": "/json",
+      "db_url": "/db",
+      "query_url": "/queries?queries=",
+      "fortune_url": "/fortune",
+      "update_url": "/updates?queries=",
+      "plaintext_url": "/plaintext",
+      "port": 3000,
+      "approach": "Realistic",
+      "classification": "Micro",
+      "database": "Postgres",
+      "framework": "spock",
+      "language": "Haskell",
+      "orm": "Raw",
+      "platform": "Wai",
+      "webserver": "Warp",
+      "os": "Linux",
+      "database_os": "Linux",
+      "display_name": "spock",
+      "notes": "",
+      "versus": ""
+    }
+  }]
+}

frameworks/Haskell/spock/setup.sh

@@ -0,0 +1,8 @@
+#!/bin/bash
+
+fw_depends stack
+
+${IROOT}/stack --allow-different-user setup
+${IROOT}/stack --allow-different-user build
+
+${IROOT}/stack --allow-different-user exec spock-exe -- +RTS -A32m -N${MAX_THREADS} &

frameworks/Haskell/spock/source_code

@@ -0,0 +1,7 @@
+./spock/src/
+./spock/src/Main.hs
+./spock/src/Models/
+./spock/src/Models/Fortune.hs
+./spock/src/Models/World.hs
+./spock/src/Views/
+./spock/src/Views/Fortune.hs

frameworks/Haskell/spock/spock.cabal

@@ -0,0 +1,41 @@
+name:                spock
+version:             0.1.0.0
+synopsis:            Spock - TechEmpower benchmark
+description:         Please see README.md
+homepage:            http://spock.li
+license:             BSD3
+license-file:        LICENSE
+author:              Jérôme Mahuet
+maintainer:          [email protected]
+copyright:           2016 Jérôme Mahuet
+category:            Web
+build-type:          Simple
+-- extra-source-files:
+cabal-version:       >=1.10
+
+executable spock-exe
+  hs-source-dirs:      src
+  main-is:             Main.hs
+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N -O2
+  build-depends:       base
+                     , Spock
+                     , resource-pool
+                     , text
+                     , aeson >= 0.11
+                     , postgresql-simple
+                     , random
+                     , transformers
+                     , async
+                     , mtl
+                     , resourcet
+                     , http-types
+                     , blaze-html
+                     , blaze-markup
+  other-modules:       Models.Fortune
+                     , Models.World
+                     , Views.Fortune
+  default-language:    Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/githubuser/spock

frameworks/Haskell/spock/src/Main.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main where
+
+import           Control.Concurrent.Async
+import           Control.Monad.IO.Class
+import           Data.Aeson                    hiding (json)
+import           Data.List                     (sort)
+import           Data.Maybe                    (catMaybes, fromMaybe)
+import           Data.Pool
+import qualified Database.PostgreSQL.Simple    as PG
+import           GHC.Exts
+import           Network.HTTP.Types.Status
+import           Text.Blaze.Html.Renderer.Utf8
+import qualified Text.Blaze.Html5              as H
+import           Web.Spock.Safe
+
+import           Models.Fortune
+import           Models.World
+import           Views.Fortune
+
+
+creds :: PG.ConnectInfo
+creds =
+    PG.ConnectInfo
+        { PG.connectHost     = "localhost"
+        , PG.connectPort     = 5432
+        , PG.connectUser     = "benchmarkdbuser"
+        , PG.connectPassword = "benchmarkdbpass"
+        , PG.connectDatabase = "hello_world"
+        }
+
+
+poolCfg :: PoolCfg
+poolCfg = PoolCfg 50 50 60
+
+pcconn :: ConnBuilder PG.Connection
+pcconn = ConnBuilder (PG.connect creds) PG.close poolCfg
+
+dbConn :: PoolOrConn PG.Connection
+dbConn = PCConn pcconn
+
+
+blaze :: MonadIO m => H.Html -> ActionCtxT ctx m a
+blaze h = do
+    setHeader "Content-Type" "text/html; charset=UTF-8"
+    lazyBytes $ renderHtml h
+{-# INLINE blaze #-}
+
+
+getQueriesNumber :: MonadIO m => ActionCtxT ctx m Int
+getQueriesNumber = do
+    queriesM <- param "queries"
+    return $ max 1 . min 500 $ fromMaybe 1 queriesM
+{-# INLINE getQueriesNumber #-}
+
+
+-- | Test 1: JSON serialization
+test1 :: MonadIO m => ActionCtxT ctx m a
+test1 = do
+    setHeader "Content-Type" "application/json"
+    lazyBytes $ encode $ Object (fromList [("message", "Hello, World!")])
+{-# INLINE test1 #-}
+
+-- | Test 2: Single database query
+test2 :: ActionCtxT ctx (WebStateM PG.Connection b ()) a
+test2 = do
+    maybeWorld <- runQuery getRandomWorld
+    setHeader "Content-Type" "application/json"
+    case maybeWorld of
+      Just w  -> lazyBytes $ encode w
+      Nothing -> setStatus status404 >> lazyBytes "{\"error\": \"World not found.\"}"
+{-# INLINE test2 #-}
+
+-- | Test 3: Multiple database queries
+test3 :: Pool PG.Connection -> ActionCtxT ctx (WebStateM PG.Connection b ()) a
+test3 pool = do
+    queries <- getQueriesNumber
+    worlds <- liftIO $ mapConcurrently (const (withResource pool getRandomWorld)) [1..queries]
+    setHeader "Content-Type" "application/json"
+    lazyBytes $ encode worlds
+{-# INLINE test3 #-}
+
+-- | Test 4: Fortunes
+test4 :: ActionCtxT ctx (WebStateM PG.Connection b ()) a
+test4 = do
+    fortunes <- runQuery fetchFortunes
+    blaze $ renderFortunes $ sort (newFortune : fortunes)
+    where
+      newFortune = Fortune 0 "Additional fortune added at request time."
+{-# INLINE test4 #-}
+
+-- | Test 5: Database Updates
+test5 :: Pool PG.Connection -> ActionCtxT ctx (WebStateM PG.Connection b ()) a
+test5 pool = do
+    queries <- getQueriesNumber
+    worlds <- liftIO $ mapConcurrently (const (withResource pool getRandomWorld)) [1..queries]
+    updatedWorlds <- liftIO $ mapConcurrently (withResource pool . updateWorldRandom) (catMaybes worlds)
+    setHeader "Content-Type" "application/json"
+    lazyBytes $ encode updatedWorlds
+{-# INLINE test5 #-}
+
+-- | Test 6: Plain text
+test6 :: MonadIO m => ActionCtxT ctx m a
+test6 = do
+    setHeader "Content-Type" "text/plain"
+    lazyBytes "Hello, World!"
+{-# INLINE test6 #-}
+
+
+main :: IO ()
+main = do
+    pool <- createPool (cb_createConn pcconn) (cb_destroyConn pcconn)
+                       (pc_stripes poolCfg) (pc_keepOpenTime poolCfg)
+                       (pc_resPerStripe poolCfg)
+    runSpock 3000 $ spock (defaultSpockCfg Nothing dbConn ()) $ do
+        get "json"        test1
+        get "db"          test2
+        get "queries"   $ test3 pool
+        get "fortune"     test4
+        get "updates"   $ test5 pool
+        get "plaintext"   test6

frameworks/Haskell/spock/src/Models/Fortune.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Models.Fortune
+    ( Fortune(..)
+    , fetchFortunes
+    ) where
+
+import           Data.Aeson
+import           Data.Monoid                        ((<>))
+import           Data.Ord
+import qualified Data.Text                          as T
+import qualified Database.PostgreSQL.Simple         as PG
+import           Database.PostgreSQL.Simple.FromRow
+import           GHC.Generics
+
+
+data Fortune = Fortune
+    { _idF      :: !Integer
+    , _messageF :: !T.Text
+    } deriving (Show, Generic)
+
+-- | JSON serialization
+instance ToJSON Fortune where
+    toEncoding f =
+        pairs (  "id"      .= _idF f
+              <> "message" .= _messageF f
+              )
+    {-# INLINE toEncoding #-}
+
+-- | Transforming a database row into a World datatype.
+instance FromRow Fortune where
+    fromRow = Fortune <$> field <*> field
+    {-# INLINE fromRow #-}
+
+-- | For sorting purposes
+instance Eq Fortune where
+    (==) fa fb =
+        _idF fa      == _idF fb
+     && _messageF fa == _messageF fb
+    {-# INLINE (==) #-}
+
+instance Ord Fortune where
+    compare = comparing _messageF
+    {-# INLINE compare #-}
+
+fetchFortunes :: PG.Connection -> IO [Fortune]
+fetchFortunes c = PG.query_ c "SELECT id, message FROM Fortune"
+{-# INLINE fetchFortunes #-}

frameworks/Haskell/spock/src/Models/World.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Models.World
+    ( World(..)
+    , fetchWorldById
+    , getRandomWorld
+    , updateWorldRandom
+    ) where
+
+import           Data.Aeson
+import           Data.Maybe
+import           Data.Monoid                        ((<>))
+import qualified Database.PostgreSQL.Simple         as PG
+import           Database.PostgreSQL.Simple.FromRow
+import           GHC.Generics
+import           System.Random
+
+
+data World = World
+    { _idW           :: !Integer
+    , _randomNumberW :: !Integer
+    } deriving (Show, Generic)
+
+-- | JSON serialization
+instance ToJSON World where
+    toEncoding w =
+        pairs (  "id"            .= _idW w
+              <> "randomNumber"  .= _randomNumberW w
+              )
+    {-# INLINE toEncoding #-}
+
+-- | Transforming a database row into a World datatype.
+instance FromRow World where
+    fromRow = World <$> field <*> field
+    {-# INLINE fromRow #-}
+
+-- | Get a World by Id, this will return a Just World, or Nothing
+-- if the id is not in the database.
+fetchWorldById :: Int -> PG.Connection -> IO (Maybe World)
+fetchWorldById i c =
+    listToMaybe <$> PG.query c
+        "SELECT id, randomNumber FROM World WHERE id = ?"
+        (PG.Only i)
+{-# INLINE fetchWorldById #-}
+
+-- | Get a random World from the database. For the tests
+-- the id must be bound between 1-10000
+getRandomWorld :: PG.Connection -> IO (Maybe World)
+getRandomWorld c = do
+    i <- randomRIO (1, 10000)
+    fetchWorldById i c
+{-# INLINE getRandomWorld #-}
+
+-- | Update a World with a random number
+updateWorldRandom :: World -> PG.Connection -> IO World
+updateWorldRandom (World _id _) c = do
+    i <- randomRIO (1, 10000)
+    _ <- PG.execute c "UPDATE World SET randomNumber = ? WHERE id = ?" (i, _id)
+    return $ World _id i
+{-# INLINE updateWorldRandom #-}

frameworks/Haskell/spock/src/Views/Fortune.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Views.Fortune
+    ( renderFortunes
+    ) where
+
+import           Control.Monad    (forM_)
+import           Text.Blaze.Html5 as H
+
+import           Models.Fortune
+
+
+renderFortunes :: [Fortune] -> Html
+renderFortunes fs =
+    docTypeHtml $ do
+        H.head $
+            H.title "Fortunes"
+        H.body $
+            H.table $ do
+                H.tr $ do
+                    H.th "id"
+                    H.th "message"
+                forM_ fs $ \f ->
+                    H.tr $ do
+                        H.td $ toHtml $ _idF f
+                        H.td $ toHtml $ _messageF f

frameworks/Haskell/spock/stack.yaml

@@ -0,0 +1,36 @@
+# This file was automatically generated by stack init
+# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
+resolver: lts-5.4
+
+# Local packages, usually specified by relative directory name
+packages:
+- '.'
+# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
+extra-deps:
+- aeson-0.11.0.0
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: >= 1.0.0
+
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor