Merge pull request #2138 from haskell-servant/round-14

Add servant benchmark.

.travis.yml

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

frameworks/Haskell/servant/ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for servant-bench
+
+## 0.1.0.0  -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

frameworks/Haskell/servant/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2016, Julian K. Arni
+
+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 Julian K. Arni 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/servant/README.md

@@ -0,0 +1,8 @@
+# Servant Benchmarking Test
+
+This is the [`servant`](http://haskell-servant.github.io/) implementation of a
+[benchmarking test suite](https://www.techempower.com/benchmarks/) comparing a
+variety of web development platforms.
+
+This test uses PostgreSQL via the [`hasql`](https://hackage.haskell.org/package/hasql)
+library.

frameworks/Haskell/servant/Setup.hs

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

frameworks/Haskell/servant/benchmark_config.json

@@ -0,0 +1,28 @@
+{
+  "framework": "servant",
+  "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": 7041,
+      "approach": "Realistic",
+      "classification": "Micro",
+      "database": "Postgres",
+      "framework": "None",
+      "language": "Haskell",
+      "orm": "Raw",
+      "platform": "Wai",
+      "webserver": "Warp",
+      "os": "Linux",
+      "database_os": "Linux",
+      "display_name": "servant",
+      "notes": "",
+      "versus": ""
+    }
+  }]
+}

frameworks/Haskell/servant/driver/Main.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main (main) where
+
+import Data.ByteString
+import ServantBench
+import Hasql.Connection (settings)
+
+main :: IO ()
+main = run 7041 dbSettings
+
+dbSettings :: ByteString
+dbSettings
+  = settings "localhost" 5432 "benchmarkdbuser" "benchmarkdbpass" "hello_world"

frameworks/Haskell/servant/servant-bench.cabal

@@ -0,0 +1,48 @@
+-- Initial servant-bench.cabal generated by cabal init.  For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                servant-bench
+version:             0.1.0.0
+-- synopsis:
+-- description:
+license:             BSD3
+license-file:        LICENSE
+author:              Julian K. Arni
+maintainer:          [email protected]
+-- copyright:
+category:            Web
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     ServantBench
+  -- other-modules:
+  -- other-extensions:
+  build-depends:       base >=4.8 && <4.9
+                     , servant == 0.7.*
+                     , servant-server == 0.7.*
+                     , servant-lucid == 0.7.*
+                     , lucid
+                     , aeson == 0.11.*
+                     , hasql == 0.19.*
+                     , hasql-pool == 0.4.*
+                     , bytestring == 0.10.6.*
+                     , mwc-random == 0.13.*
+                     , warp == 3.2.*
+                     , transformers
+                     , text == 1.2.*
+                     , contravariant == 1.4.*
+                     , http-media == 0.6.*
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+
+executable servant-exe
+  main-is:             Main.hs
+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N -O2
+  build-depends:       base
+                     , servant-bench
+                     , bytestring
+                     , hasql
+  hs-source-dirs:      driver
+  default-language:    Haskell2010

frameworks/Haskell/servant/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 servant-exe -- +RTS -A32m -N${MAX_THREADS} &

frameworks/Haskell/servant/source_code

@@ -0,0 +1,4 @@
+./servant/driver/
+./servant/driver/Main.hs
+./servant/src/
+./servant/src/ServantBench.hs

frameworks/Haskell/servant/src/ServantBench.hs

@@ -0,0 +1,189 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeOperators         #-}
+module ServantBench (run) where
+
+import           Control.Exception          (bracket)
+import           Control.Monad              (replicateM)
+import           Control.Monad.IO.Class     (liftIO)
+import           Data.Aeson                 hiding (json)
+import qualified Data.ByteString            as BS
+import           Data.ByteString.Lazy
+import           Data.Functor.Contravariant (contramap)
+import           Data.Int                   (Int32)
+import           Data.List                  (sortOn)
+import           Data.Maybe                 (fromMaybe)
+import           Data.Monoid                ((<>))
+import qualified Data.Text                  as Text
+import           GHC.Exts                   (IsList (fromList))
+import           GHC.Generics               (Generic)
+import qualified Hasql.Decoders             as HasqlDec
+import qualified Hasql.Encoders             as HasqlEnc
+import           Hasql.Pool                 (Pool, acquire, release, use)
+import qualified Hasql.Query                as Hasql
+import           Hasql.Session              (query)
+import           Lucid
+import qualified Network.Wai.Handler.Warp   as Warp
+import           Network.HTTP.Media         ((//))
+import           Servant
+import           Servant.HTML.Lucid         (HTML)
+import           System.Random.MWC          (GenIO, createSystemRandom,
+                                             uniformR)
+
+type API =
+       "json" :> Get '[JSON] Value
+  :<|> "db" :> Get '[JSON] World
+  :<|> "queries" :> QueryParam "queries" Int :> Get '[JSON] [World]
+  :<|> "fortune" :> Get '[HTML] (Html ())
+  :<|> "updates" :> QueryParam "queries" Int :> Get '[JSON] [World]
+  :<|> "plaintext" :> Get '[Plain] ByteString
+
+api :: Proxy API
+api = Proxy
+
+server :: Pool -> GenIO -> Server API
+server pool gen =
+      json
+ :<|> singleDb pool gen
+ :<|> multipleDb pool gen
+ :<|> fortunes pool
+ :<|> updates pool gen
+ :<|> plaintext
+
+run :: Warp.Port -> BS.ByteString -> IO ()
+run port dbSettings = do
+  gen <- createSystemRandom
+  bracket (acquire settings) release $ \pool ->
+    Warp.run port $ serve api $ server pool gen
+  where
+    halfSecond = 0.5
+    settings = (30, halfSecond, dbSettings)
+
+
+data World = World { wId :: !Int32 , wRandomNumber :: !Int32 }
+  deriving (Show, Generic)
+
+instance ToJSON World where
+  toEncoding w =
+    pairs (  "id"           .= wId w
+          <> "randomNumber" .= wRandomNumber w
+          )
+
+data Fortune = Fortune { fId :: !Int32 , fMessage :: Text.Text }
+  deriving (Show, Generic)
+
+instance ToJSON Fortune where
+  toEncoding f =
+    pairs (  "id"      .= fId f
+          <> "message" .= fMessage f
+          )
+
+intValEnc :: HasqlEnc.Params Int32
+intValEnc = HasqlEnc.value HasqlEnc.int4
+intValDec :: HasqlDec.Row Int32
+intValDec = HasqlDec.value HasqlDec.int4
+
+-- * PlainText without charset
+
+data Plain
+instance Accept Plain where contentType _ = "text" // "plain"
+instance MimeRender Plain ByteString where
+  mimeRender _ = id
+  {-# INLINE mimeRender #-}
+
+------------------------------------------------------------------------------
+
+-- * Test 1: JSON serialization
+
+json :: Handler Value
+json = return . Object $ fromList [("message", "Hello, World!")]
+{-# INLINE json #-}
+
+
+-- * Test 2: Single database query
+
+selectSingle :: Hasql.Query Int32 World
+selectSingle = Hasql.statement q intValEnc decoder True
+  where
+   q = "SELECT * FROM World WHERE (id = $1)"
+   decoder = HasqlDec.singleRow $ World <$> intValDec <*> intValDec
+{-# INLINE selectSingle #-}
+
+singleDb :: Pool -> GenIO -> Handler World
+singleDb pool gen = do
+  v <- liftIO $ uniformR (1, 10000) gen
+  r <- liftIO $ use pool (query v selectSingle)
+  case r of
+    Left e -> throwError err500
+    Right world -> return world
+{-# INLINE singleDb #-}
+
+
+-- * Test 3: Multiple database query
+
+multipleDb :: Pool -> GenIO -> Maybe Int -> Handler [World]
+multipleDb pool gen mcount = replicateM count $ singleDb pool gen
+  where
+    count = let c = fromMaybe 1 mcount in max 1 (min c 500)
+{-# INLINE multipleDb #-}
+
+
+-- * Test 4: Fortunes
+
+selectFortunes :: Hasql.Query () [Fortune]
+selectFortunes = Hasql.statement q encoder decoder True
+  where
+   q = "SELECT * FROM Fortune"
+   encoder = HasqlEnc.unit
+   -- TODO: investigate whether 'rowsList' is worth the more expensive 'cons'.
+   decoder = HasqlDec.rowsList $ Fortune <$> intValDec <*> HasqlDec.value HasqlDec.text
+{-# INLINE selectFortunes #-}
+
+fortunes :: Pool -> Handler (Html ())
+fortunes pool = do
+  r <- liftIO $ use pool (query () selectFortunes)
+  case r of
+    Left e -> throwError err500
+    Right fs -> return $ do
+      let new = Fortune 0 "Additional fortune added at request time."
+      doctypehtml_ $ do
+        head_ $ title_ "Fortunes"
+        body_ $ do
+          table_ $ do
+            tr_ $ do
+              th_ "id"
+              th_ "message"
+            mapM_ (\f -> tr_ $ do
+              td_ (toHtml . show $ fId f)
+              td_ (toHtml $ fMessage f)) (sortOn fMessage (new : fs))
+{-# INLINE fortunes #-}
+
+
+-- * Test 5: Updates
+
+updateSingle :: Hasql.Query (Int32, Int32) World
+updateSingle = Hasql.statement q encoder decoder True
+  where
+    q = "UPDATE World SET randomNumber = $1 WHERE id = $2"
+    encoder = contramap fst intValEnc <> contramap snd intValEnc
+    decoder = HasqlDec.singleRow $ World <$> intValDec <*> intValDec
+{-# INLINE updateSingle #-}
+
+updates :: Pool -> GenIO -> Maybe Int -> Handler [World]
+updates pool gen mcount = replicateM count $ do
+  res <- singleDb pool gen
+  v <- liftIO $ uniformR (1, 10000) gen
+  r <- liftIO $ use pool (query (wId res, v) updateSingle)
+  return $ res { wRandomNumber = v }
+  where
+    count = let c = fromMaybe 1 mcount in max 1 (min c 500)
+{-# INLINE updates #-}
+
+-- * Test 6: Plaintext endpoint
+
+plaintext :: Handler ByteString
+plaintext = return "Hello, World!"
+{-# INLINE plaintext #-}

frameworks/Haskell/servant/stack.yaml

@@ -0,0 +1,9 @@
+resolver: lts-6.5
+packages:
+- '.'
+
+extra-deps:
+- hasql-pool-0.4.1
+
+flags: {}
+extra-package-dbs: []