Add framework Warp (#4571)

* Add `warp` framework.

* Fixed an issue with update test.

- Under high load (concurrency = 512), postgres-wire keeps running into `IncorrectUsage: "Expected DataRow message, but got ReadyForQuery"` error.
- Removing batching seems to have addressed the issue.

* Added `warp-hasql` framework.

- Updated docker file and config to gracefully support both test cases.
- We're sharing dockerfile and stack.yaml so we can re-use the deps and ensure the overall build time for `warp` framework is under 50 minutes (travis timeout).

* Fixed default executable linking.

- warp-hasql was accidentally linked as the bare `warp` default. the config states postgres-wire is default.
- added debug statement to manually test the right executable is launched.

* Added `warp-mysql-haskell` framework.

.travis.yml

@@ -39,6 +39,7 @@ env:
     - "TESTDIR=Haskell/yesod"
     - "TESTDIR=Haskell/servant"
     - "TESTDIR=Haskell/spock"
+    - "TESTDIR=Haskell/warp"
     - "TESTDIR=Java/act"
     - "TESTDIR=Java/activeweb"
     - "TESTDIR=Java/armeria"

frameworks/Haskell/warp/README.md

@@ -0,0 +1,5 @@
+# warp
+
+This is the [`warp`](http://haskell-warp.github.io/) implementation of the [benchmarking test suite](https://www.techempower.com/benchmarks/) comparing a variety of web development platforms.
+
+Since `warp` is strictly a request controller layer, it is upto the user to pick their persistance layer and data flow. Therefore we can have multiple distinct implementations using different database backends/libraries in each sub directory.

frameworks/Haskell/warp/benchmark_config.json

@@ -0,0 +1,74 @@
+{
+  "framework": "warp",
+  "tests": [{
+    "default": {
+      "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": "Warp",
+      "language": "Haskell",
+      "flavor": "GHC683",
+      "orm": "Raw",
+      "platform": "Wai",
+      "webserver": "Wai",
+      "os": "Linux",
+      "database_os": "Linux",
+      "display_name": "Warp+Postgres-wire",
+      "notes": "Pure haskell.",
+      "dockerfile": "warp.dockerfile"
+    },
+    "hasql": {
+      "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": "Warp",
+      "language": "Haskell",
+      "flavor": "GHC683",
+      "orm": "Raw",
+      "platform": "Wai",
+      "webserver": "Wai",
+      "os": "Linux",
+      "database_os": "Linux",
+      "display_name": "Warp+Hasql",
+      "notes": "Uses libpq system dependency.",
+      "dockerfile": "warp.dockerfile"
+    },
+    "mysql-haskell": {
+      "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": "MySQL",
+      "framework": "Warp",
+      "language": "Haskell",
+      "flavor": "GHC683",
+      "orm": "Raw",
+      "platform": "Wai",
+      "webserver": "Wai",
+      "os": "Linux",
+      "database_os": "Linux",
+      "display_name": "Warp+mysql-haskell",
+      "notes": "Pure Haskell.",
+      "dockerfile": "warp.dockerfile"
+    }
+  }]
+}

frameworks/Haskell/warp/stack.yaml

@@ -0,0 +1,16 @@
+resolver: lts-13.13
+
+packages:
+- ./warp-hasql
+- ./warp-postgres-wire
+- ./warp-mysql-haskell
+
+extra-deps:
+- socket-0.8.2.0
+- socket-unix-0.2.0.0
+- git: https://github.com/postgres-haskell/postgres-wire.git
+  commit: fda5e3b70c3cc0bab8365b4b872991d50da0348c
+
+# the following flags are meant for use with warp.dockerfile
+compiler: ghc-8.6.3 # this MUST match the resolver's GHC; minor hack to ensure GHC isn't downloaded into sandbox.
+allow-different-user: true

frameworks/Haskell/warp/warp-hasql/README.md

@@ -0,0 +1,3 @@
+# Warp with `hasql`
+
+This test uses PostgreSQL via the [`hasql`](https://github.com/nikita-volkov/hasql) library.

frameworks/Haskell/warp/warp-hasql/exe/Main.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedStrings     #-}
+
+module Main where
+
+import qualified Lib
+import qualified GHC.Conc
+import           System.Environment (getArgs)
+
+main :: IO ()
+main = do
+  args <- getArgs
+  dbHost <- case args of
+    [x] -> pure x
+    _ -> pure "0.0.0.0"
+    -- _ -> fail "Usage: warp-postgres-wire <DATABASE_HOST>"
+  numCaps <- GHC.Conc.getNumCapabilities
+  Lib.main $ Lib.Config {
+    Lib.configHost    = dbHost,
+    Lib.configName    = "hello_world",
+    Lib.configUser    = "benchmarkdbuser",
+    Lib.configPass    = "benchmarkdbpass",
+    Lib.configStripes = numCaps,
+    Lib.configPoolSize= 512
+  }

frameworks/Haskell/warp/warp-hasql/src/Lib.hs

@@ -0,0 +1,158 @@
+{-# LANGUAGE OverloadedStrings     #-}
+
+module Lib (
+    main
+  , Db.Config(..)
+) where
+
+import qualified Lib.Types as Types
+import qualified Lib.Db as Db
+import qualified Data.Either as Either
+import           Data.List (sortOn)
+import           Control.Monad (replicateM, join)
+
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as LBSC
+import qualified Network.HTTP.Types.Status as Status
+import qualified Network.HTTP.Types.Header as Header
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified Data.BufferBuilder.Json as Json
+import           Data.BufferBuilder.Json ((.=))
+import qualified System.Random.MWC as MWC
+import qualified Html
+import           Html ((#))
+
+-- entry point
+main :: Db.Config -> IO ()
+main dbConfig = do
+  putStrLn "Config is:"
+  print dbConfig
+  putStrLn "Initializing database connection pool..."
+  dbPool <- Db.mkPool dbConfig
+  putStrLn "Initializing PRNG seed..."
+  gen <- MWC.create
+  putStrLn "Warp core online: using hasql"
+  Warp.run 7041 $ app gen dbPool
+
+-- router
+app :: MWC.GenIO -> Db.Pool -> Wai.Application
+app gen dbPool req respond = do
+  let qParams = Wai.queryString req
+  let mCount = Types.parseCount =<< join (lookup "queries" qParams)
+  case (Wai.requestMethod req, Wai.pathInfo req) of
+    ("GET", ["plaintext"])
+      -> respond getPlaintext
+    ("GET", ["json"])
+      -> respond getJson
+    ("GET", ["db"])
+      -> respond =<< getWorld gen dbPool
+    ("GET", ["fortune"])
+      -> respond =<< getFortunes dbPool
+    ("GET", ["queries"])
+      -> respond =<< getWorlds gen dbPool mCount
+    ("GET", ["updates"])
+      -> respond =<< updateWorlds gen dbPool mCount
+    _ -> respond routeNotFound
+
+-- * response helpers
+
+contentText :: Header.ResponseHeaders
+contentText = [(Header.hContentType, "text/plain")]
+
+respondText :: Status.Status -> LBS.ByteString -> Wai.Response
+respondText code = Wai.responseLBS code contentText
+
+contentJson :: Header.ResponseHeaders
+contentJson = [(Header.hContentType, "application/json")]
+
+{-# SPECIALIZE respondJson :: Json.ObjectBuilder -> Wai.Response #-}
+{-# SPECIALIZE respondJson :: Types.World -> Wai.Response #-}
+respondJson :: Json.ToJson a => a -> Wai.Response
+respondJson = Wai.responseLBS Status.status200 contentJson . mkBs
+  where
+    mkBs = LBS.fromStrict . Json.encodeJson
+
+contentHtml :: Header.ResponseHeaders
+contentHtml = [(Header.hContentType, "text/html; charset=UTF-8")]
+
+respondHtml :: Types.FortunesHtml -> Wai.Response
+respondHtml = Wai.responseLBS Status.status200 contentHtml . Html.renderByteString
+
+-- * error responses
+
+routeNotFound :: Wai.Response
+routeNotFound = respondText Status.status400 "Bad route"
+
+respondInternalError :: LBS.ByteString -> Wai.Response
+respondInternalError = respondText Status.status500
+
+respondDbError :: Db.Error -> Wai.Response
+respondDbError = respondInternalError . LBSC.pack . show
+
+-- * route implementations
+
+getPlaintext :: Wai.Response
+getPlaintext = respondText Status.status200 "Hello, World!"
+{-# INLINE getPlaintext #-}
+
+getJson :: Wai.Response
+getJson = respondJson $ "message" .= Types.unsafeJsonString "Hello, World!"
+{-# INLINE getJson #-}
+
+getWorld :: MWC.GenIO -> Db.Pool -> IO Wai.Response
+getWorld gen dbPool = do
+  wId <- randomId gen
+  res <- Db.queryWorldById dbPool wId
+  pure . mkResponse $ res
+  where
+    mkResponse = Either.either respondDbError respondJson
+{-# INLINE getWorld #-}
+
+getWorlds :: MWC.GenIO -> Db.Pool -> Maybe Types.Count -> IO Wai.Response
+getWorlds gen dbPool mCount = do
+  wIds <- replicateM count $ randomId gen
+  res <- Db.queryWorldByIds dbPool wIds
+  pure . mkResponse $ res
+  where
+    count = Types.getCount mCount
+    mkResponse = Either.either respondDbError respondJson
+{-# INLINE getWorlds #-}
+
+updateWorlds :: MWC.GenIO -> Db.Pool -> Maybe Types.Count -> IO Wai.Response
+updateWorlds gen dbPool mCount = do
+  wIds <- replicateM count $ randomId gen
+  res <- Db.queryWorldByIds dbPool wIds
+  Either.either (pure . respondDbError) (go dbPool) res
+  where
+    count = Types.getCount mCount
+    mkResponse = Either.either respondDbError respondJson
+    go conn ws = do
+      wNumbers <- replicateM count $ randomId gen
+      wsUp <- Db.updateWorlds conn . zip ws $ fmap fromIntegral wNumbers
+      return $ mkResponse wsUp
+{-# INLINE updateWorlds #-}
+
+getFortunes :: Db.Pool -> IO Wai.Response
+getFortunes dbPool = do
+  res <- Db.queryFortunes dbPool
+  return $ case res of
+    Left e -> respondDbError e
+    Right fs -> respondHtml $ do
+      let new = Types.Fortune 0 "Additional fortune added at request time."
+      let header = Html.tr_ $ Html.th_ (Html.Raw "id") # Html.th_ (Html.Raw "message")
+      let mkRow f = Html.tr_ $ Html.td_ (fromIntegral $ Types.fId f) # Html.td_ (Types.fMessage $ f)
+      let rows = fmap mkRow $ sortOn Types.fMessage (new : fs)
+      Html.doctype_ #
+        Html.html_ (
+          Html.head_ (
+            Html.title_ (Html.Raw "Fortunes")
+          ) #
+          Html.body_ ( Html.table_ $
+            header # rows
+          )
+        )
+{-# INLINE getFortunes #-}
+
+randomId :: MWC.GenIO -> IO Types.QId
+randomId = MWC.uniformR (1, 10000)

frameworks/Haskell/warp/warp-hasql/src/Lib/Db.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE OverloadedStrings     #-}
+
+module Lib.Db (
+    Pool
+  , mkPool
+  , Config(..)
+  , queryWorldById
+  , queryWorldByIds
+  , updateWorlds
+  , queryFortunes
+  , Error
+) where
+
+import qualified Lib.Types as Types
+import           Control.Monad (forM, forM_)
+
+import qualified Hasql.Decoders             as HasqlDec
+import qualified Hasql.Encoders             as HasqlEnc
+import           Hasql.Pool                 (Pool, acquire, UsageError, use)
+import qualified Hasql.Statement            as HasqlStatement
+import           Hasql.Session              (statement)
+import           Hasql.Connection           (settings, Settings)
+import           Data.Functor.Contravariant (contramap)
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BSC
+
+-------------------------------------------------------------------------------
+-- * Database
+
+data Config
+  = Config
+  { configHost      :: String
+  , configName      :: ByteString
+  , configUser      :: ByteString
+  , configPass      :: ByteString
+  , configStripes   :: Int
+  , configPoolSize  :: Int
+  }
+instance Show Config where
+  show c
+    =  "Config {"
+    <>  " configHost = " <> configHost c
+    <> ", configName = " <> BSC.unpack (configName c)
+    <> ", configUser = " <> BSC.unpack (configUser c)
+    <> ", configPass = REDACTED"
+    <> ", configStripes = " <> show (configStripes c)
+    <> ", configPoolSize = " <> show (configPoolSize c)
+    <> " }"
+
+type Error = UsageError
+
+mkSettings :: Config -> Settings
+mkSettings c = settings (BSC.pack $ configHost c) 5432 (configUser c) (configPass c) (configName c)
+
+mkPool :: Config -> IO Pool
+mkPool c = acquire (configPoolSize c, 0.5, mkSettings c)
+
+intValEnc :: HasqlEnc.Params Types.QId
+intValEnc = HasqlEnc.param HasqlEnc.int2
+intValDec :: HasqlDec.Row Types.QId
+intValDec = HasqlDec.column HasqlDec.int2
+
+-------------------------------------------------------------------------------
+-- * World
+
+selectSingle :: HasqlStatement.Statement Types.QId Types.World
+selectSingle = HasqlStatement.Statement q intValEnc decoder True
+  where
+   q = "SELECT * FROM World WHERE (id = $1)"
+   decoder = HasqlDec.singleRow $ Types.World <$> intValDec <*> intValDec
+
+queryWorldById :: Pool -> Types.QId -> IO (Either Error Types.World)
+queryWorldById pool wId = use pool (statement wId selectSingle)
+
+queryWorldByIds :: Pool -> [Types.QId] -> IO (Either Error [Types.World])
+queryWorldByIds _ [] = pure . pure $ mempty
+queryWorldByIds pool wIds = use pool $ do
+  forM wIds $ \wId -> statement wId selectSingle
+
+updateSingle :: HasqlStatement.Statement (Types.QId, Types.QId) ()
+updateSingle = HasqlStatement.Statement q encoder decoder True
+  where
+    q = "UPDATE World SET randomNumber = $1 WHERE id = $2"
+    encoder = contramap fst intValEnc <> contramap snd intValEnc
+    decoder = HasqlDec.unit
+
+updateWorlds :: Pool -> [(Types.World, Types.QId)] -> IO (Either Error [Types.World])
+updateWorlds _ [] = pure . pure $ mempty
+updateWorlds pool wsUpdates = use pool $ do
+  let ws = fmap updateW wsUpdates
+  forM_ wsUpdates $ \(w, wNum) -> do
+    statement (Types.wId w, wNum) updateSingle
+  return ws
+  where
+    updateW (w,wNum) = w { Types.wRandomNumber = wNum }
+
+-------------------------------------------------------------------------------
+-- * Fortunes
+
+selectFortunes :: HasqlStatement.Statement () [Types.Fortune]
+selectFortunes = HasqlStatement.Statement q encoder decoder True
+  where
+   q = "SELECT * FROM Fortune"
+   encoder = HasqlEnc.unit
+   -- TODO: investigate whether 'rowList' is worth the more expensive 'cons'.
+   decoder = HasqlDec.rowList $ Types.Fortune <$> intValDec <*> HasqlDec.column HasqlDec.text
+{-# INLINE selectFortunes #-}
+
+queryFortunes :: Pool -> IO (Either Error [Types.Fortune])
+queryFortunes pool = use pool (statement () selectFortunes)

frameworks/Haskell/warp/warp-hasql/src/Lib/Types.hs

@@ -0,0 +1,98 @@
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE TypeOperators         #-}
+
+module Lib.Types (
+    unsafeJsonString
+  , parseCount
+  , getCount
+  , Count
+  , World(..)
+  , Fortune(..)
+  , FortunesHtml
+  , QId
+) where
+
+import qualified Data.Either as Either
+import qualified Data.Char as Char
+import           Data.Int (Int16)
+
+import           Data.ByteString (ByteString)
+import qualified Data.Attoparsec.ByteString.Char8 as Parsec
+import qualified Data.BufferBuilder.Utf8 as Utf8
+import qualified Data.BufferBuilder.Json as Json
+import           Data.BufferBuilder.Json ((.=))
+import qualified Html
+import           Html (type (#), type (>))
+import           Data.Text (Text)
+
+-------------------------------------------------------------------------------
+-- * Inputs
+
+newtype Count = Count Int
+
+parseCount :: ByteString -> Maybe Count
+parseCount = fmap Count . Either.either (const Nothing) pure . Parsec.parseOnly parseInt
+
+getCount :: Maybe Count -> Int
+getCount Nothing = 1
+getCount (Just (Count c)) = max 1 (min c 500)
+
+-- https://stackoverflow.com/a/24171263
+parseInt :: Parsec.Parser Int
+parseInt = do
+  digits <- Parsec.many1 parseIntDigit
+  let n = foldl (\x d -> 10*x + (Char.digitToInt d)) 0 digits
+  seq n (return n)
+
+parseIntDigit :: Parsec.Parser Char
+parseIntDigit = digit
+  where
+    digit = Parsec.satisfy isDigit
+    isDigit c = c >= '0' && c <= '9'
+
+type QId = Int16
+
+-------------------------------------------------------------------------------
+-- * Outputs
+
+data World = World { wId :: QId , wRandomNumber :: QId }
+  deriving Show
+
+instance Json.ToJson World where
+  toJson w
+    = Json.toJson
+    $ "id"           .= (fromIntegral $ wId w :: Int)
+   <> "randomNumber" .= (fromIntegral $ wRandomNumber w :: Int)
+
+data Fortune = Fortune { fId :: QId , fMessage :: Text }
+  deriving Show
+
+type FortunesHtml
+  = (('Html.DOCTYPE Html.> ())
+  # ('Html.Html
+    > (('Html.Head > ('Html.Title > Html.Raw Text))
+      # ('Html.Body
+        > ('Html.Table
+          > (
+              ('Html.Tr
+              > ( ('Html.Th > Html.Raw Text)
+                # ('Html.Th > Html.Raw Text)
+                )
+              )
+            # ['Html.Tr
+              > ( ('Html.Td > Int)
+                # ('Html.Td > Text)
+                )
+              ]
+            )
+          )
+        )
+      )
+    )
+  )
+
+unsafeJsonString :: ByteString -> Json.Value
+unsafeJsonString = Json.unsafeValueUtf8Builder . Utf8.appendBS7 . quote
+  where
+    quote x = "\"" <> x <> "\""

frameworks/Haskell/warp/warp-hasql/warp-hasql.cabal

@@ -0,0 +1,42 @@
+name:                warp-hasql
+version:             0.1.0.0
+homepage:            https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/warp/warp-hasql
+license:             BSD3
+author:              Naushadh
+maintainer:          [email protected]
+copyright:           2019 Naushadh
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+extra-source-files:  README.md
+
+library
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  exposed-modules:     Lib
+  other-modules:
+      Lib.Db
+    , Lib.Types
+  build-depends:
+      base >= 4.7 && < 5
+    , bytestring
+    , attoparsec
+    , buffer-builder
+    , mwc-random
+    , type-of-html
+    , wai
+    , warp
+    , http-types
+    , text
+    , hasql >= 0.19
+    , hasql-pool >= 0.4
+    , contravariant
+
+executable warp-hasql
+  hs-source-dirs:      exe
+  main-is:             Main.hs
+  default-language:    Haskell2010
+  ghc-options:         -Wall -threaded -rtsopts -O2 -funbox-strict-fields
+  build-depends:
+      base >= 4.7 && < 5
+    , warp-hasql

frameworks/Haskell/warp/warp-mysql-haskell/README.md

@@ -0,0 +1,3 @@
+# Warp with `mysql-haskell`
+
+This test uses MySQL via the [`mysql-haskell`](https://github.com/winterland1989/mysql-haskell) library.

frameworks/Haskell/warp/warp-mysql-haskell/exe/Main.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedStrings     #-}
+
+module Main where
+
+import qualified Lib
+import qualified GHC.Conc
+import           System.Environment (getArgs)
+
+main :: IO ()
+main = do
+  args <- getArgs
+  dbHost <- case args of
+    [x] -> pure x
+    _ -> pure "0.0.0.0"
+    -- _ -> fail "Usage: warp-postgres-wire <DATABASE_HOST>"
+  numCaps <- GHC.Conc.getNumCapabilities
+  Lib.main $ Lib.Config {
+    Lib.configHost    = dbHost,
+    Lib.configName    = "hello_world",
+    Lib.configUser    = "benchmarkdbuser",
+    Lib.configPass    = "benchmarkdbpass",
+    Lib.configStripes = numCaps,
+    Lib.configPoolSize= 512
+  }

frameworks/Haskell/warp/warp-mysql-haskell/src/Lib.hs

@@ -0,0 +1,173 @@
+{-# LANGUAGE OverloadedStrings     #-}
+
+module Lib (
+    main
+  , Db.Config(..)
+) where
+
+import qualified Lib.Types as Types
+import qualified Lib.Db as Db
+import qualified Data.Either as Either
+import qualified Data.Maybe as Maybe
+import           Data.List (sortOn)
+import           Control.Monad (replicateM, join)
+
+import qualified Data.Pool as Pool
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as LBSC
+import qualified Network.HTTP.Types.Status as Status
+import qualified Network.HTTP.Types.Header as Header
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified Data.BufferBuilder.Json as Json
+import           Data.BufferBuilder.Json ((.=))
+import qualified System.Random.MWC as MWC
+import qualified Html
+import           Html ((#))
+
+-- entry point
+main :: Db.Config -> IO ()
+main dbConfig = do
+  putStrLn "Config is:"
+  print dbConfig
+  putStrLn "Initializing database connection pool..."
+  dbPool <- Db.mkPool dbConfig
+  putStrLn "Initializing PRNG seed..."
+  gen <- MWC.create
+  putStrLn "Warp core online: using mysql-haskell"
+  Warp.run 7041 $ app gen dbPool
+
+-- router
+app :: MWC.GenIO -> Db.Pool -> Wai.Application
+app gen dbPool req respond = do
+  let qParams = Wai.queryString req
+  let mCount = Types.parseCount =<< join (lookup "queries" qParams)
+  case (Wai.requestMethod req, Wai.pathInfo req) of
+    ("GET", ["plaintext"])
+      -> respond getPlaintext
+    ("GET", ["json"])
+      -> respond getJson
+    ("GET", ["db"])
+      -> respond =<< getWorld gen dbPool
+    ("GET", ["fortune"])
+      -> respond =<< getFortunes dbPool
+    ("GET", ["queries"])
+      -> respond =<< getWorlds gen dbPool mCount
+    ("GET", ["updates"])
+      -> respond =<< updateWorlds gen dbPool mCount
+    _ -> respond routeNotFound
+
+-- * response helpers
+
+contentText :: Header.ResponseHeaders
+contentText = [(Header.hContentType, "text/plain")]
+
+respondText :: Status.Status -> LBS.ByteString -> Wai.Response
+respondText code = Wai.responseLBS code contentText
+
+contentJson :: Header.ResponseHeaders
+contentJson = [(Header.hContentType, "application/json")]
+
+{-# SPECIALIZE respondJson :: Json.ObjectBuilder -> Wai.Response #-}
+{-# SPECIALIZE respondJson :: Types.World -> Wai.Response #-}
+respondJson :: Json.ToJson a => a -> Wai.Response
+respondJson = Wai.responseLBS Status.status200 contentJson . mkBs
+  where
+    mkBs = LBS.fromStrict . Json.encodeJson
+
+contentHtml :: Header.ResponseHeaders
+contentHtml = [(Header.hContentType, "text/html; charset=UTF-8")]
+
+respondHtml :: Types.FortunesHtml -> Wai.Response
+respondHtml = Wai.responseLBS Status.status200 contentHtml . Html.renderByteString
+
+-- * error responses
+
+routeNotFound :: Wai.Response
+routeNotFound = respondText Status.status400 "Bad route"
+
+entityNotFound :: Wai.Response
+entityNotFound = respondText Status.status404 "Not Found"
+
+respondInternalError :: LBS.ByteString -> Wai.Response
+respondInternalError = respondText Status.status500
+
+respondDbError :: Db.Error -> Wai.Response
+respondDbError = respondInternalError . LBSC.pack . show
+
+respondDbErrors :: [Db.Error] -> Wai.Response
+respondDbErrors = respondInternalError . LBSC.pack . show
+
+-- * route implementations
+
+getPlaintext :: Wai.Response
+getPlaintext = respondText Status.status200 "Hello, World!"
+{-# INLINE getPlaintext #-}
+
+getJson :: Wai.Response
+getJson = respondJson $ "message" .= Types.unsafeJsonString "Hello, World!"
+{-# INLINE getJson #-}
+
+getWorld :: MWC.GenIO -> Db.Pool -> IO Wai.Response
+getWorld gen dbPool = do
+  wId <- randomId gen
+  Pool.withResource dbPool $ \conn -> do
+    res <- Db.queryWorldById conn wId
+    pure . mkResponse $ res
+  where
+    safeHead [] = Nothing
+    safeHead xs = pure $ head xs
+    mkSuccess = Maybe.maybe entityNotFound respondJson . safeHead
+    mkResponse = Either.either respondDbError mkSuccess
+{-# INLINE getWorld #-}
+
+getWorlds :: MWC.GenIO -> Db.Pool -> Maybe Types.Count -> IO Wai.Response
+getWorlds gen dbPool mCount = do
+  wIds <- replicateM count $ randomId gen
+  Pool.withResource dbPool $ \conn -> do
+    res <- Db.queryWorldByIds conn wIds
+    pure . mkResponse $ res
+  where
+    count = Types.getCount mCount
+    mkResponse = Either.either respondDbErrors respondJson
+{-# INLINE getWorlds #-}
+
+updateWorlds :: MWC.GenIO -> Db.Pool -> Maybe Types.Count -> IO Wai.Response
+updateWorlds gen dbPool mCount = do
+  wIds <- replicateM count $ randomId gen
+  Pool.withResource dbPool $ \conn -> do
+    res <- Db.queryWorldByIds conn wIds
+    Either.either (pure . respondDbErrors) (go conn) res
+  where
+    count = Types.getCount mCount
+    mkResponse = Either.either respondDbErrors respondJson
+    go conn ws = do
+      wNumbers <- replicateM count $ randomId gen
+      wsUp <- Db.updateWorlds conn . zip ws $ fmap fromIntegral wNumbers
+      return $ mkResponse wsUp
+{-# INLINE updateWorlds #-}
+
+getFortunes :: Db.Pool -> IO Wai.Response
+getFortunes dbPool = do
+  Pool.withResource dbPool $ \conn -> do
+    res <- Db.queryFortunes conn
+    return $ case res of
+      Left e -> respondDbErrors e
+      Right fs -> respondHtml $ do
+        let new = Types.Fortune 0 "Additional fortune added at request time."
+        let header = Html.tr_ $ Html.th_ (Html.Raw "id") # Html.th_ (Html.Raw "message")
+        let mkRow f = Html.tr_ $ Html.td_ (fromIntegral $ Types.fId f) # Html.td_ (Types.fMessage $ f)
+        let rows = fmap mkRow $ sortOn Types.fMessage (new : fs)
+        Html.doctype_ #
+          Html.html_ (
+            Html.head_ (
+              Html.title_ (Html.Raw "Fortunes")
+            ) #
+            Html.body_ ( Html.table_ $
+              header # rows
+            )
+          )
+{-# INLINE getFortunes #-}
+
+randomId :: MWC.GenIO -> IO Types.QId
+randomId = MWC.uniformR (1, 10000)

frameworks/Haskell/warp/warp-mysql-haskell/src/Lib/Db.hs

@@ -0,0 +1,152 @@
+{-# LANGUAGE OverloadedStrings     #-}
+
+module Lib.Db (
+    Pool
+  , mkPool
+  , Config(..)
+  , queryWorldById
+  , queryWorldByIds
+  , updateWorlds
+  , queryFortunes
+  , Error
+) where
+
+import qualified Lib.Types as Types
+import qualified Data.Either as Either
+import           Control.Monad (forM, forM_)
+
+import qualified Data.Pool as Pool
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BSC
+import qualified Database.MySQL.Base as MySQL
+import qualified System.IO.Streams as Streams
+import           Data.Text (Text)
+import qualified Data.Text as Text
+
+-------------------------------------------------------------------------------
+-- * Database
+
+data Config
+  = Config
+  { configHost      :: String
+  , configName      :: ByteString
+  , configUser      :: ByteString
+  , configPass      :: ByteString
+  , configStripes   :: Int
+  , configPoolSize  :: Int
+  }
+instance Show Config where
+  show c
+    =  "Config {"
+    <>  " configHost = " <> configHost c
+    <> ", configName = " <> BSC.unpack (configName c)
+    <> ", configUser = " <> BSC.unpack (configUser c)
+    <> ", configPass = REDACTED"
+    <> ", configStripes = " <> show (configStripes c)
+    <> ", configPoolSize = " <> show (configPoolSize c)
+    <> " }"
+
+type Connection = MySQL.MySQLConn
+type Pool = Pool.Pool Connection
+type Error = Text
+type DbRow = [MySQL.MySQLValue]
+
+connect :: Config -> IO Connection
+connect c = MySQL.connect myc
+  where
+    myc = MySQL.defaultConnectInfoMB4
+        { MySQL.ciHost     = configHost c
+        , MySQL.ciDatabase = configName c
+        , MySQL.ciUser     = configUser c
+        , MySQL.ciPassword = configPass c
+        }
+
+close :: Connection -> IO ()
+close = MySQL.close
+
+mkPool :: Config -> IO Pool
+mkPool c = Pool.createPool (connect c) close (configStripes c) 0.5 (configPoolSize c)
+
+{-# SPECIALIZE intValEnc :: Int -> MySQL.MySQLValue #-}
+{-# SPECIALIZE intValEnc :: Types.QId -> MySQL.MySQLValue #-}
+intValEnc :: Integral a => a -> MySQL.MySQLValue
+intValEnc = MySQL.MySQLInt16U . fromIntegral
+
+intValDec :: MySQL.MySQLValue -> Either Text Int
+intValDec (MySQL.MySQLInt8U i) = pure . fromIntegral $ i
+intValDec (MySQL.MySQLInt8 i) = pure . fromIntegral $ i
+intValDec (MySQL.MySQLInt16U i) = pure . fromIntegral $ i
+intValDec (MySQL.MySQLInt16 i) = pure . fromIntegral $ i
+intValDec (MySQL.MySQLInt32U i) = pure . fromIntegral $ i
+intValDec (MySQL.MySQLInt32 i) = pure . fromIntegral $ i
+intValDec (MySQL.MySQLInt64U i) = pure . fromIntegral $ i
+intValDec (MySQL.MySQLInt64 i) = pure . fromIntegral $ i
+intValDec x = Left $ "Expected MySQLInt*, received" <> (Text.pack $ show x)
+
+textValDec :: MySQL.MySQLValue -> Either Text Text
+textValDec (MySQL.MySQLText t) = pure t
+textValDec x = Left $ "Expected Text, received" <> (Text.pack $ show x)
+
+-------------------------------------------------------------------------------
+-- * World
+
+decodeWorld :: DbRow -> Either Error Types.World
+decodeWorld [] = Left "MarshalError: Expected 2 columns for World, found 0"
+decodeWorld (_:[]) = Left "MarshalError: Expected 2 columns for World, found 1"
+decodeWorld (c1:c2:_) = Types.World <$> intValDec c1 <*> intValDec c2
+
+queryWorldById :: Connection -> Types.QId -> IO (Either Error [Types.World])
+queryWorldById conn wId = do
+  (_, rowsS) <- MySQL.query conn s [intValEnc wId]
+  rows <- Streams.toList rowsS
+  let eWorlds = fmap decodeWorld rows
+  let (err, oks) = Either.partitionEithers eWorlds
+  return $ case err of
+    [] -> pure oks
+    _ -> Left . head $ err
+  where
+    s = "SELECT * FROM World WHERE id = ?"
+
+queryWorldByIds :: Connection -> [Types.QId] -> IO (Either [Error] [Types.World])
+queryWorldByIds _ [] = pure . pure $ mempty
+queryWorldByIds conn wIds = do
+  sId <- MySQL.prepareStmt conn "SELECT * FROM World WHERE id = ?"
+  res <- forM wIds $ \wId -> do
+    (_, rowsS) <- MySQL.queryStmt conn sId [intValEnc wId]
+    rows <- Streams.toList rowsS
+    return . fmap decodeWorld $ rows
+  MySQL.closeStmt conn sId
+  let (errs, ws) = Either.partitionEithers . mconcat $ res
+  return $ case errs of
+    [] -> pure ws
+    _ -> Left errs
+
+updateWorlds :: Connection -> [(Types.World, Int)] -> IO (Either [Error] [Types.World])
+updateWorlds _ [] = pure . pure $ mempty
+updateWorlds conn wsUpdates = do
+  let ws = fmap updateW wsUpdates
+  sId <- MySQL.prepareStmt conn "UPDATE World SET randomNumber = ? WHERE id = ?"
+  forM_ wsUpdates $ \(w, wNum) ->
+    MySQL.executeStmt conn sId [intValEnc wNum, intValEnc $ Types.wId w]
+  MySQL.closeStmt conn sId
+  return . pure $ ws
+  where
+    updateW (w,wNum) = w { Types.wRandomNumber = wNum }
+
+-------------------------------------------------------------------------------
+-- * Fortunes
+
+decodeFortune :: DbRow -> Either Error Types.Fortune
+decodeFortune [] = Left "MarshalError: Expected 2 columns for Fortune, found 0"
+decodeFortune (_:[]) = Left "MarshalError: Expected 2 columns for Fortune, found 1"
+decodeFortune (c1:c2:_) = Types.Fortune <$> intValDec c1 <*> textValDec c2
+
+queryFortunes :: Connection -> IO (Either [Error] [Types.Fortune])
+queryFortunes conn = do
+  (_, rowsS) <- MySQL.query_ conn "SELECT * FROM Fortune"
+  rows <- Streams.toList rowsS
+  let eFortunes = fmap decodeFortune rows
+  let (err, oks) = Either.partitionEithers eFortunes
+  return $ case err of
+    [] -> pure oks
+    _ -> Left err

frameworks/Haskell/warp/warp-mysql-haskell/src/Lib/Types.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE TypeOperators         #-}
+
+module Lib.Types (
+    unsafeJsonString
+  , parseCount
+  , getCount
+  , Count
+  , World(..)
+  , Fortune(..)
+  , FortunesHtml
+  , QId
+) where
+
+import qualified Data.Either as Either
+import qualified Data.Char as Char
+import           Data.Word (Word16)
+
+import           Data.ByteString (ByteString)
+import qualified Data.Attoparsec.ByteString.Char8 as Parsec
+import qualified Data.BufferBuilder.Utf8 as Utf8
+import qualified Data.BufferBuilder.Json as Json
+import           Data.BufferBuilder.Json ((.=))
+import qualified Html
+import           Html (type (#), type (>))
+import           Data.Text (Text)
+
+-------------------------------------------------------------------------------
+-- * Inputs
+
+newtype Count = Count Int
+
+parseCount :: ByteString -> Maybe Count
+parseCount = fmap Count . Either.either (const Nothing) pure . Parsec.parseOnly parseInt
+
+getCount :: Maybe Count -> Int
+getCount Nothing = 1
+getCount (Just (Count c)) = max 1 (min c 500)
+
+-- https://stackoverflow.com/a/24171263
+parseInt :: Parsec.Parser Int
+parseInt = do
+  digits <- Parsec.many1 parseIntDigit
+  let n = foldl (\x d -> 10*x + (Char.digitToInt d)) 0 digits
+  seq n (return n)
+
+parseIntDigit :: Parsec.Parser Char
+parseIntDigit = digit
+  where
+    digit = Parsec.satisfy isDigit
+    isDigit c = c >= '0' && c <= '9'
+
+type QId = Word16
+
+-------------------------------------------------------------------------------
+-- * Outputs
+
+data World = World { wId :: Int , wRandomNumber :: Int }
+  deriving Show
+
+instance Json.ToJson World where
+  toJson w
+    = Json.toJson
+    $ "id"           .= wId w
+   <> "randomNumber" .= wRandomNumber w
+
+data Fortune = Fortune { fId :: Int , fMessage :: Text }
+  deriving Show
+
+instance Json.ToJson Fortune where
+  toJson f
+    = Json.toJson
+    $ "id"      .= fId f
+   <> "message" .= fMessage f
+
+type FortunesHtml
+  = (('Html.DOCTYPE Html.> ())
+  # ('Html.Html
+    > (('Html.Head > ('Html.Title > Html.Raw Text))
+      # ('Html.Body
+        > ('Html.Table
+          > (
+              ('Html.Tr
+              > ( ('Html.Th > Html.Raw Text)
+                # ('Html.Th > Html.Raw Text)
+                )
+              )
+            # ['Html.Tr
+              > ( ('Html.Td > Int)
+                # ('Html.Td > Text)
+                )
+              ]
+            )
+          )
+        )
+      )
+    )
+  )
+
+unsafeJsonString :: ByteString -> Json.Value
+unsafeJsonString = Json.unsafeValueUtf8Builder . Utf8.appendBS7 . quote
+  where
+    quote x = "\"" <> x <> "\""

frameworks/Haskell/warp/warp-mysql-haskell/warp-mysql-haskell.cabal

@@ -0,0 +1,42 @@
+name:                warp-mysql-haskell
+version:             0.1.0.0
+homepage:            https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/warp/warp-mysql-haskell
+license:             BSD3
+author:              Naushadh
+maintainer:          [email protected]
+copyright:           2019 Naushadh
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+extra-source-files:  README.md
+
+library
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  exposed-modules:     Lib
+  other-modules:
+      Lib.Db
+    , Lib.Types
+  build-depends:
+      base >= 4.7 && < 5
+    , bytestring
+    , attoparsec
+    , buffer-builder
+    , mwc-random
+    , type-of-html
+    , wai
+    , warp
+    , http-types
+    , mysql-haskell
+    , resource-pool
+    , io-streams
+    , text
+
+executable warp-mysql-haskell
+  hs-source-dirs:      exe
+  main-is:             Main.hs
+  default-language:    Haskell2010
+  ghc-options:         -Wall -threaded -rtsopts -O2 -funbox-strict-fields
+  build-depends:
+      base >= 4.7 && < 5
+    , warp-mysql-haskell

frameworks/Haskell/warp/warp-postgres-wire/README.md

@@ -0,0 +1,3 @@
+# Warp with `postgres-wire`
+
+This test uses PostgreSQL via the [`postgres-wire`](https://github.com/postgres-haskell/postgres-wire) library.

frameworks/Haskell/warp/warp-postgres-wire/exe/Main.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedStrings     #-}
+
+module Main where
+
+import qualified Lib
+import qualified GHC.Conc
+import           System.Environment (getArgs)
+
+main :: IO ()
+main = do
+  args <- getArgs
+  dbHost <- case args of
+    [x] -> pure x
+    _ -> pure "0.0.0.0"
+    -- _ -> fail "Usage: warp-postgres-wire <DATABASE_HOST>"
+  numCaps <- GHC.Conc.getNumCapabilities
+  Lib.main $ Lib.Config {
+    Lib.configHost    = dbHost,
+    Lib.configName    = "hello_world",
+    Lib.configUser    = "benchmarkdbuser",
+    Lib.configPass    = "benchmarkdbpass",
+    Lib.configStripes = numCaps,
+    Lib.configPoolSize= 512
+  }

frameworks/Haskell/warp/warp-postgres-wire/src/Lib.hs

@@ -0,0 +1,172 @@
+{-# LANGUAGE OverloadedStrings     #-}
+
+module Lib (
+    main
+  , Db.Config(..)
+) where
+
+import qualified Lib.Types as Types
+import qualified Lib.Db as Db
+import qualified Data.Either as Either
+import qualified Data.Maybe as Maybe
+import           Data.List (sortOn)
+import           Control.Monad (replicateM, join)
+
+import qualified Data.Pool as Pool
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as LBSC
+import qualified Network.HTTP.Types.Status as Status
+import qualified Network.HTTP.Types.Header as Header
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified Data.BufferBuilder.Json as Json
+import           Data.BufferBuilder.Json ((.=))
+import qualified System.Random.MWC as MWC
+import qualified Data.Vector as V
+import qualified Html
+import           Html ((#))
+
+-- entry point
+main :: Db.Config -> IO ()
+main dbConfig = do
+  putStrLn "Config is:"
+  print dbConfig
+  putStrLn "Initializing database connection pool..."
+  dbPool <- Db.mkPool dbConfig
+  putStrLn "Initializing PRNG seed..."
+  gen <- MWC.create
+  putStrLn "Warp core online: using postgres-wire"
+  Warp.run 7041 $ app gen dbPool
+
+-- router
+app :: MWC.GenIO -> Db.Pool -> Wai.Application
+app gen dbPool req respond = do
+  let qParams = Wai.queryString req
+  let mCount = Types.parseCount =<< join (lookup "queries" qParams)
+  case (Wai.requestMethod req, Wai.pathInfo req) of
+    ("GET", ["plaintext"])
+      -> respond getPlaintext
+    ("GET", ["json"])
+      -> respond getJson
+    ("GET", ["db"])
+      -> respond =<< getWorld gen dbPool
+    ("GET", ["fortune"])
+      -> respond =<< getFortunes dbPool
+    ("GET", ["queries"])
+      -> respond =<< getWorlds gen dbPool mCount
+    ("GET", ["updates"])
+      -> respond =<< updateWorlds gen dbPool mCount
+    _ -> respond routeNotFound
+
+-- * response helpers
+
+contentText :: Header.ResponseHeaders
+contentText = [(Header.hContentType, "text/plain")]
+
+respondText :: Status.Status -> LBS.ByteString -> Wai.Response
+respondText code = Wai.responseLBS code contentText
+
+contentJson :: Header.ResponseHeaders
+contentJson = [(Header.hContentType, "application/json")]
+
+{-# SPECIALIZE respondJson :: Json.ObjectBuilder -> Wai.Response #-}
+{-# SPECIALIZE respondJson :: Types.World -> Wai.Response #-}
+respondJson :: Json.ToJson a => a -> Wai.Response
+respondJson = Wai.responseLBS Status.status200 contentJson . mkBs
+  where
+    mkBs = LBS.fromStrict . Json.encodeJson
+
+contentHtml :: Header.ResponseHeaders
+contentHtml = [(Header.hContentType, "text/html; charset=UTF-8")]
+
+respondHtml :: Types.FortunesHtml -> Wai.Response
+respondHtml = Wai.responseLBS Status.status200 contentHtml . Html.renderByteString
+
+-- * error responses
+
+routeNotFound :: Wai.Response
+routeNotFound = respondText Status.status400 "Bad route"
+
+entityNotFound :: Wai.Response
+entityNotFound = respondText Status.status404 "Not Found"
+
+respondInternalError :: LBS.ByteString -> Wai.Response
+respondInternalError = respondText Status.status500
+
+respondDbError :: Db.Error -> Wai.Response
+respondDbError = respondInternalError . LBSC.pack . show
+
+respondDbErrors :: [Db.Error] -> Wai.Response
+respondDbErrors = respondInternalError . LBSC.pack . show
+
+-- * route implementations
+
+getPlaintext :: Wai.Response
+getPlaintext = respondText Status.status200 "Hello, World!"
+{-# INLINE getPlaintext #-}
+
+getJson :: Wai.Response
+getJson = respondJson $ "message" .= Types.unsafeJsonString "Hello, World!"
+{-# INLINE getJson #-}
+
+getWorld :: MWC.GenIO -> Db.Pool -> IO Wai.Response
+getWorld gen dbPool = do
+  wId <- randomId gen
+  Pool.withResource dbPool $ \conn -> do
+    res <- Db.queryWorldById conn wId
+    pure . mkResponse $ res
+  where
+    mkSuccess = Maybe.maybe entityNotFound respondJson . flip (V.!?) 0
+    mkResponse = Either.either respondDbError mkSuccess
+{-# INLINE getWorld #-}
+
+getWorlds :: MWC.GenIO -> Db.Pool -> Maybe Types.Count -> IO Wai.Response
+getWorlds gen dbPool mCount = do
+  wIds <- replicateM count $ randomId gen
+  Pool.withResource dbPool $ \conn -> do
+    res <- Db.queryWorldByIds conn wIds
+    pure . mkResponse $ res
+  where
+    count = Types.getCount mCount
+    mkResponse = Either.either respondDbErrors respondJson
+{-# INLINE getWorlds #-}
+
+updateWorlds :: MWC.GenIO -> Db.Pool -> Maybe Types.Count -> IO Wai.Response
+updateWorlds gen dbPool mCount = do
+  wIds <- replicateM count $ randomId gen
+  Pool.withResource dbPool $ \conn -> do
+    res <- Db.queryWorldByIds conn wIds
+    Either.either (pure . respondDbErrors) (go conn) res
+  where
+    count = Types.getCount mCount
+    mkResponse = Either.either respondDbErrors respondJson
+    go conn ws = do
+      wNumbers <- replicateM count $ randomId gen
+      wsUp <- Db.updateWorlds conn . zip ws $ fmap fromIntegral wNumbers
+      return $ mkResponse wsUp
+{-# INLINE updateWorlds #-}
+
+getFortunes :: Db.Pool -> IO Wai.Response
+getFortunes dbPool = do
+  Pool.withResource dbPool $ \conn -> do
+    res <- Db.queryFortunes conn
+    return $ case res of
+      Left e -> respondDbError e
+      Right fs -> respondHtml $ do
+        let new = Types.Fortune 0 "Additional fortune added at request time."
+        let header = Html.tr_ $ Html.th_ (Html.Raw "id") # Html.th_ (Html.Raw "message")
+        let mkRow f = Html.tr_ $ Html.td_ (fromIntegral $ Types.fId f) # Html.td_ (Types.fMessage $ f)
+        let rows = fmap mkRow $ sortOn Types.fMessage (new : V.toList fs)
+        Html.doctype_ #
+          Html.html_ (
+            Html.head_ (
+              Html.title_ (Html.Raw "Fortunes")
+            ) #
+            Html.body_ ( Html.table_ $
+              header # rows
+            )
+          )
+{-# INLINE getFortunes #-}
+
+randomId :: MWC.GenIO -> IO Types.QId
+randomId = MWC.uniformR (1, 10000)

frameworks/Haskell/warp/warp-postgres-wire/src/Lib/Db.hs

@@ -0,0 +1,163 @@
+{-# LANGUAGE OverloadedStrings     #-}
+
+module Lib.Db (
+    Pool
+  , mkPool
+  , Config(..)
+  , queryWorldById
+  , queryWorldByIds
+  , updateWorlds
+  , queryFortunes
+  , Error
+) where
+
+import qualified Lib.Types as Types
+import qualified Data.Either as Either
+import qualified System.IO.Error as Error
+import           Control.Monad (replicateM, forM)
+
+import qualified Data.Pool as Pool
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BSC
+import qualified Database.PostgreSQL.Driver as PG
+import qualified Database.PostgreSQL.Protocol.Types as PGT
+import qualified Database.PostgreSQL.Protocol.DataRows as PGD
+import qualified Database.PostgreSQL.Protocol.Store.Decode as PGSD
+import qualified Database.PostgreSQL.Protocol.Store.Encode as PGSE
+import qualified Database.PostgreSQL.Protocol.Codecs.Decoders as PGCD
+import qualified Database.PostgreSQL.Protocol.Codecs.Encoders as PGCE
+import qualified Database.PostgreSQL.Protocol.Codecs.PgTypes as PGCT
+import qualified Data.Vector as V
+import           Data.Text (Text)
+import qualified Data.Text.Encoding as TE
+
+-------------------------------------------------------------------------------
+-- * Database
+
+data Config
+  = Config
+  { configHost      :: String
+  , configName      :: ByteString
+  , configUser      :: ByteString
+  , configPass      :: ByteString
+  , configStripes   :: Int
+  , configPoolSize  :: Int
+  }
+instance Show Config where
+  show c
+    =  "Config {"
+    <>  " configHost = " <> configHost c
+    <> ", configName = " <> BSC.unpack (configName c)
+    <> ", configUser = " <> BSC.unpack (configUser c)
+    <> ", configPass = REDACTED"
+    <> ", configStripes = " <> show (configStripes c)
+    <> ", configPoolSize = " <> show (configPoolSize c)
+    <> " }"
+
+type Connection = PG.Connection
+type Pool = Pool.Pool Connection
+type Error = PG.Error
+
+connect :: Config -> IO Connection
+connect c = simplifyError =<< PG.connect pgc
+  where
+    simplifyError = Either.either (Error.ioError . Error.userError . show) pure
+    pgc = PG.defaultConnectionSettings
+        { PG.settingsHost     = BSC.pack $ configHost c
+        , PG.settingsDatabase = configName c
+        , PG.settingsUser     = configUser c
+        , PG.settingsPassword = configPass c
+        }
+
+close :: Connection -> IO ()
+close = PG.close
+
+mkPool :: Config -> IO Pool
+mkPool c = Pool.createPool (connect c) close (configStripes c) 0.5 (configPoolSize c)
+
+runQuery :: Connection -> PGSD.Decode a -> PG.Query -> IO (Either PG.Error (V.Vector a))
+runQuery conn dec q = do
+  PG.sendBatchAndSync conn [q]
+  eRows <- PG.readNextData conn
+  _ <- PG.waitReadyForQuery conn
+  return $ fmap (PGD.decodeManyRows dec) eRows
+
+decodeInt :: PGSD.Decode Int
+decodeInt = fromIntegral <$> PGCD.getNonNullable PGCD.int4
+
+decodeText :: PGSD.Decode Text
+decodeText = TE.decodeUtf8 <$> PGCD.getNonNullable PGCD.bytea
+
+encodeInt :: Integral a => a -> (PGCT.Oids, PGSE.Encode)
+encodeInt qId = (PGCT.int2, PGCE.int2 $ fromIntegral qId)
+
+mkQuery :: ByteString -> [(PGCT.Oids, PGSE.Encode)] -> PG.Query
+mkQuery q es = PG.Query q ps PGT.Binary PGT.Binary PG.NeverCache
+  where
+    mkP (oid, e) = (PGCT.oidType oid, Just e)
+    ps = fmap mkP es
+
+-------------------------------------------------------------------------------
+-- * World
+
+decodeWorld :: PGSD.Decode Types.World
+decodeWorld = PGCD.dataRowHeader *> decoder
+  where 
+    decoder = Types.World
+        <$> decodeInt
+        <*> decodeInt
+
+queryWorldById :: Connection -> Types.QId -> IO (Either Error (V.Vector Types.World))
+queryWorldById conn wId = runQuery conn decodeWorld q
+  where
+    s = "SELECT * FROM World WHERE id = $1"
+    q = mkQuery s [encodeInt wId]
+
+queryWorldByIds :: Connection -> [Types.QId] -> IO (Either [Error] [Types.World])
+queryWorldByIds _ [] = pure . pure $ mempty
+queryWorldByIds conn wIds = do
+  let s = "SELECT * FROM World WHERE id = $1"
+  let mkQ wId = mkQuery s [encodeInt wId]
+  let qs = fmap mkQ wIds
+  PG.sendBatchAndSync conn qs
+  eRowsMany <- replicateM (length qs) $ PG.readNextData conn
+  _ <- PG.waitReadyForQuery conn
+  let (errs, rowsList) = Either.partitionEithers eRowsMany
+  return $ case errs of
+    [] -> pure . mconcat $ fmap (V.toList . PGD.decodeManyRows decodeWorld) rowsList
+    _ -> Left errs
+
+updateWorlds :: Connection -> [(Types.World, Int)] -> IO (Either [Error] [Types.World])
+updateWorlds _ [] = pure . pure $ mempty
+updateWorlds conn wsUpdates = do
+  let ws = fmap updateW wsUpdates
+  let qs = fmap mkQ ws
+  eRowsMany <- forM qs $ \q -> do
+    PG.sendBatchAndSync conn [q]
+    eRows <- PG.readNextData conn
+    _ <- PG.waitReadyForQuery conn
+    return eRows
+  let (errs, _) = Either.partitionEithers eRowsMany
+  return $ case errs of
+    [] -> pure ws
+    _ -> Left errs
+  where
+    s = "UPDATE World SET randomNumber = $1 WHERE id = $2"
+    updateW (w,wNum) = w { Types.wRandomNumber = wNum }
+    mkQ w = mkQuery s [encodeInt . Types.wRandomNumber $ w, encodeInt . Types.wId $ w]
+
+-------------------------------------------------------------------------------
+-- * Fortunes
+
+decodeFortune :: PGSD.Decode Types.Fortune
+decodeFortune = PGCD.dataRowHeader *> decoder
+  where 
+    decoder = Types.Fortune
+        <$> decodeInt
+        <*> decodeText
+
+queryFortunes :: Connection -> IO (Either Error (V.Vector Types.Fortune))
+queryFortunes conn = runQuery conn decodeFortune q
+  where
+    s = "SELECT * FROM Fortune"
+    q = mkQuery s []

frameworks/Haskell/warp/warp-postgres-wire/src/Lib/Types.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE TypeOperators         #-}
+
+module Lib.Types (
+    unsafeJsonString
+  , parseCount
+  , getCount
+  , Count
+  , World(..)
+  , Fortune(..)
+  , FortunesHtml
+  , QId
+) where
+
+import qualified Data.Either as Either
+import qualified Data.Char as Char
+import           Data.Word (Word16)
+
+import           Data.ByteString (ByteString)
+import qualified Data.Attoparsec.ByteString.Char8 as Parsec
+import qualified Data.BufferBuilder.Utf8 as Utf8
+import qualified Data.BufferBuilder.Json as Json
+import           Data.BufferBuilder.Json ((.=))
+import qualified Html
+import           Html (type (#), type (>))
+import           Data.Text (Text)
+
+-------------------------------------------------------------------------------
+-- * Inputs
+
+newtype Count = Count Int
+
+parseCount :: ByteString -> Maybe Count
+parseCount = fmap Count . Either.either (const Nothing) pure . Parsec.parseOnly parseInt
+
+getCount :: Maybe Count -> Int
+getCount Nothing = 1
+getCount (Just (Count c)) = max 1 (min c 500)
+
+-- https://stackoverflow.com/a/24171263
+parseInt :: Parsec.Parser Int
+parseInt = do
+  digits <- Parsec.many1 parseIntDigit
+  let n = foldl (\x d -> 10*x + (Char.digitToInt d)) 0 digits
+  seq n (return n)
+
+parseIntDigit :: Parsec.Parser Char
+parseIntDigit = digit
+  where
+    digit = Parsec.satisfy isDigit
+    isDigit c = c >= '0' && c <= '9'
+
+type QId = Word16
+
+-------------------------------------------------------------------------------
+-- * Outputs
+
+data World = World { wId :: Int , wRandomNumber :: Int }
+  deriving Show
+
+instance Json.ToJson World where
+  toJson w
+    = Json.toJson
+    $ "id"           .= wId w
+   <> "randomNumber" .= wRandomNumber w
+
+data Fortune = Fortune { fId :: Int , fMessage :: Text }
+  deriving Show
+
+instance Json.ToJson Fortune where
+  toJson f
+    = Json.toJson
+    $ "id"      .= fId f
+   <> "message" .= fMessage f
+
+type FortunesHtml
+  = (('Html.DOCTYPE Html.> ())
+  # ('Html.Html
+    > (('Html.Head > ('Html.Title > Html.Raw Text))
+      # ('Html.Body
+        > ('Html.Table
+          > (
+              ('Html.Tr
+              > ( ('Html.Th > Html.Raw Text)
+                # ('Html.Th > Html.Raw Text)
+                )
+              )
+            # ['Html.Tr
+              > ( ('Html.Td > Int)
+                # ('Html.Td > Text)
+                )
+              ]
+            )
+          )
+        )
+      )
+    )
+  )
+
+unsafeJsonString :: ByteString -> Json.Value
+unsafeJsonString = Json.unsafeValueUtf8Builder . Utf8.appendBS7 . quote
+  where
+    quote x = "\"" <> x <> "\""

frameworks/Haskell/warp/warp-postgres-wire/warp-postgres-wire.cabal

@@ -0,0 +1,42 @@
+name:                warp-postgres-wire
+version:             0.1.0.0
+homepage:            https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/warp/warp-postgres-wire
+license:             BSD3
+author:              Naushadh
+maintainer:          [email protected]
+copyright:           2019 Naushadh
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+extra-source-files:  README.md
+
+library
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  exposed-modules:     Lib
+  other-modules:
+      Lib.Db
+    , Lib.Types
+  build-depends:
+      base >= 4.7 && < 5
+    , bytestring
+    , attoparsec
+    , buffer-builder
+    , postgres-wire
+    , vector
+    , mwc-random
+    , type-of-html
+    , wai
+    , warp
+    , http-types
+    , resource-pool
+    , text
+
+executable warp-postgres-wire
+  hs-source-dirs:      exe
+  main-is:             Main.hs
+  default-language:    Haskell2010
+  ghc-options:         -Wall -threaded -rtsopts -O2 -funbox-strict-fields
+  build-depends:
+      base >= 4.7 && < 5
+    , warp-postgres-wire

frameworks/Haskell/warp/warp.dockerfile

@@ -0,0 +1,23 @@
+FROM haskell:8.6.3
+
+RUN apt update -yqq && apt install -yqq xz-utils make
+RUN apt install -yqq libpq-dev
+
+WORKDIR /app
+
+COPY ./stack.yaml .
+COPY ./warp-postgres-wire/warp-postgres-wire.cabal ./warp-postgres-wire/
+COPY ./warp-hasql/warp-hasql.cabal ./warp-hasql/
+COPY ./warp-mysql-haskell/warp-mysql-haskell.cabal ./warp-mysql-haskell/
+RUN stack setup
+RUN stack install --dependencies-only
+
+ADD ./warp-postgres-wire/ ./warp-postgres-wire
+ADD ./warp-hasql/ ./warp-hasql
+ADD ./warp-mysql-haskell/ ./warp-mysql-haskell
+RUN stack build --pedantic --copy-bins
+RUN ln -s ~/.local/bin/warp-postgres-wire ~/.local/bin/warp
+
+ARG TFB_TEST_NAME
+ENV TFB_TEST_NAME=${TFB_TEST_NAME}
+CMD stack exec $TFB_TEST_NAME -- tfb-database +RTS -A32m -N$(nproc)