Add new servant benchmark: mysql-haskell

.gitignore

@@ -99,3 +99,6 @@ pubspec.lock
 # Gradle
 .gradle/
 build/
+
+# haskell
+.stack-work

frameworks/Haskell/servant/README.md

@@ -1,8 +1,7 @@
-# Servant Benchmarking Test
+# Servant
 
 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.
+Since `servant` is strictly a routing layer to typed function, it is upto the user to pick their persistance layer and data flow. Therefore we have multiple distinct implementations using different database backends/libraries.

frameworks/Haskell/servant/benchmark_config.json

@@ -20,9 +20,30 @@
       "webserver": "Warp",
       "os": "Linux",
       "database_os": "Linux",
-      "display_name": "servant",
-      "notes": "",
-      "versus": ""
+      "display_name": "servant+hasql",
+      "notes": "Uses libpq system dependency."
+    },
+    "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": "Servant",
+      "language": "Haskell",
+      "flavor": "GHC863",
+      "orm": "Raw",
+      "platform": "Wai",
+      "webserver": "Warp",
+      "os": "Linux",
+      "database_os": "Linux",
+      "display_name": "servant+mysql-haskell",
+      "notes": "Pure Haskell."
     }
   }]
 }

frameworks/Haskell/servant/hasql/README.md

@@ -0,0 +1,4 @@
+# Servant + Hasql
+
+This test uses PostgreSQL via the [`hasql`](https://hackage.haskell.org/package/hasql)
+library.

frameworks/Haskell/servant/hasql/stack.yaml

@@ -0,0 +1,7 @@
+resolver: lts-13.10
+packages:
+- '.'
+
+# the following flags are meant for use with ../servant-mysql-haskell.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 # carryover from hasql sibling test dir

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

@@ -0,0 +1,5 @@
+# Servant + mysql-haskell
+
+This test uses MySQL via the [`mysql-haskell`](https://hackage.haskell.org/package/mysql-haskell) library.
+
+Since both the server and the database clients are written in **pure** haskell, this implementation should easily beat `libpq`/`libmysql` dependent implementations without the overhead of foreign function calls.

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

@@ -0,0 +1,36 @@
+name:                servant-mysql-haskell
+version:             0.1.0.0
+-- synopsis:
+-- description:
+homepage:            https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/servant/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
+
+executable servant-mysql-haskell
+  hs-source-dirs:      src
+  main-is:             Main.hs
+  default-language:    Haskell2010
+  ghc-options:         -Wall -threaded -rtsopts -O2
+  build-depends:
+      base >= 4.7 && < 5
+    , servant >= 0.7
+    , servant-server >= 0.7
+    , servant-lucid >= 0.7
+    , lucid
+    , aeson >= 0.11
+    , resource-pool
+    , mysql-haskell
+    , io-streams
+    , bytestring >= 0.10.6
+    , mwc-random >= 0.13
+    , warp >= 3.2
+    , transformers
+    , text >= 1.2
+    , contravariant >= 1.4
+    , http-media >= 0.6

frameworks/Haskell/servant/mysql-haskell/src/Main.hs

@@ -0,0 +1,256 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeOperators         #-}
+
+module Main (main) where
+
+import           Control.Exception          (bracket)
+import           Control.Monad              (replicateM)
+import           Control.Monad.IO.Class     (liftIO)
+import           Data.Aeson                 ((.=))
+import qualified Data.Aeson                 as Aeson
+import qualified Data.ByteString.Lazy       as LBS
+import           Data.Int                   (Int32)
+import           Data.List                  (sortOn)
+import           Data.Either                (fromRight, partitionEithers)
+import           Data.Monoid                ((<>))
+import           Data.Text                  (Text)
+import qualified Data.Text                  as Text
+import qualified Data.Text.Encoding         as TextEnc
+import           GHC.Exts                   (IsList (fromList))
+import           GHC.Generics               (Generic)
+import qualified Data.Pool                  as Pool
+import qualified Database.MySQL.Base        as MySQL
+import qualified System.IO.Streams          as Streams
+import qualified 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)
+import qualified GHC.Conc
+import           System.Environment (getArgs)
+
+type API =
+       "json" :> Get '[JSON] Aeson.Value
+  :<|> "db" :> Get '[JSON] World
+  :<|> "queries" :> QueryParam "queries" Count :> Get '[JSON] [World]
+  :<|> "fortune" :> Get '[HTML] (Lucid.Html ())
+  :<|> "updates" :> QueryParam "queries" Count :> Get '[JSON] [World]
+  :<|> "plaintext" :> Get '[Plain] LBS.ByteString
+
+api :: Proxy API
+api = Proxy
+
+server :: DbPool -> GenIO -> Server API
+server pool gen =
+      json
+ :<|> singleDb pool gen
+ :<|> multipleDb pool gen
+ :<|> fortunes pool
+ :<|> updates pool gen
+ :<|> plaintext
+
+run :: Warp.Port -> MySQL.ConnectInfo -> IO ()
+run port dbSettings = do
+  gen <- createSystemRandom
+  numCaps <- GHC.Conc.getNumCapabilities
+  let mkPool = Pool.createPool (MySQL.connect dbSettings) MySQL.close numCaps 10 512
+  bracket mkPool Pool.destroyAllResources $ \pool ->
+    Warp.run port $ serve api $ server pool gen
+
+main :: IO ()
+main = do
+  [host] <- getArgs
+  run 7041 $ MySQL.defaultConnectInfoMB4 {
+    MySQL.ciHost = host,
+    MySQL.ciDatabase = "hello_world",
+    MySQL.ciUser = "benchmarkdbuser",
+    MySQL.ciPassword = "benchmarkdbpass"
+  }
+
+type DbPool = Pool.Pool MySQL.MySQLConn
+type DbRow = [MySQL.MySQLValue]
+
+newtype Count = Count Int
+instance FromHttpApiData Count where
+  parseQueryParam
+    = pure . Count . fromRight 1 . parseQueryParam
+
+getCount :: Maybe Count -> Int
+getCount Nothing = 1
+getCount (Just (Count c)) = max 1 (min c 500)
+
+data World = World { wId :: !Int32 , wRandomNumber :: !Int32 }
+  deriving (Show, Generic)
+
+instance Aeson.ToJSON World where
+  toEncoding w
+    = Aeson.pairs
+    (  "id"           .= wId w
+    <> "randomNumber" .= wRandomNumber w
+    )
+
+data Fortune = Fortune { fId :: !Int32 , fMessage :: Text }
+  deriving (Show, Generic)
+
+instance Aeson.ToJSON Fortune where
+  toEncoding f
+    = Aeson.pairs
+    (  "id"      .= fId f
+    <> "message" .= fMessage f
+    )
+
+intValEnc :: Int32 -> MySQL.MySQLValue
+intValEnc = MySQL.MySQLInt32 . fromIntegral
+
+intValDec :: MySQL.MySQLValue -> Either Text Int32
+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)
+
+-- * PlainText without charset
+
+data Plain
+instance Accept Plain where contentType _ = "text" // "plain"
+instance MimeRender Plain LBS.ByteString where
+  mimeRender _ = id
+  {-# INLINE mimeRender #-}
+
+------------------------------------------------------------------------------
+
+-- * Test 1: JSON serialization
+
+json :: Handler Aeson.Value
+json = return . Aeson.Object $ fromList [("message", "Hello, World!")]
+{-# INLINE json #-}
+
+
+-- * Test 2: Single database query
+
+decodeWorld :: DbRow -> Either Text World
+decodeWorld [] = Left "MarshalError: Expected 2 columns for World, found 0"
+decodeWorld (_:[]) = Left "MarshalError: Expected 2 columns for World, found 1"
+decodeWorld (c1:c2:_) = World <$> intValDec c1 <*> intValDec c2
+{-# INLINE decodeWorld #-}
+
+extractWorld :: Streams.InputStream DbRow -> IO (Either Text World)
+extractWorld rowsS = do
+  rows <- Streams.toList rowsS
+  return $ case rows of
+    [] -> Left "No rows found!"
+    (row:_) -> decodeWorld row
+
+singleDb :: DbPool -> GenIO -> Handler World
+singleDb pool gen = do
+  v <- liftIO $ uniformR (1, 10000) gen
+  r <- liftIO $ Pool.withResource pool $ \conn -> do
+    (_, rowsS) <- MySQL.query conn "SELECT * FROM World WHERE id = ?" [intValEnc v]
+    extractWorld rowsS
+  case r of
+    Left e -> throwError err500 { errBody = LBS.fromStrict $ TextEnc.encodeUtf8 e }
+    Right world -> return world
+{-# INLINE singleDb #-}
+
+-- * Test 3: Multiple database query
+
+multipleDb :: DbPool -> GenIO -> Maybe Count -> Handler [World]
+multipleDb pool gen mcount = do
+  res <- liftIO $ Pool.withResource pool $ \conn -> do
+    sId <- MySQL.prepareStmt conn "SELECT * FROM World WHERE id = ?"
+    res <- replicateM (getCount mcount) $ do
+      v <- uniformR (1, 10000) gen
+      (_, rowsS) <- MySQL.queryStmt conn sId [intValEnc v]
+      extractWorld rowsS
+    MySQL.closeStmt conn sId
+    return res
+  let (errs, oks) = partitionEithers res
+  case errs of
+    [] -> return oks
+    e -> throwError err500 { errBody = LBS.fromStrict . TextEnc.encodeUtf8 . Text.pack . show $ e }
+{-# INLINE multipleDb #-}
+
+
+-- * Test 4: Fortunes
+
+decodeFortune :: DbRow -> Either Text Fortune
+decodeFortune [] = Left "MarshalError: Expected 2 columns for Fortune, found 0"
+decodeFortune (_:[]) = Left "MarshalError: Expected 2 columns for Fortune, found 1"
+decodeFortune (c1:c2:_) = Fortune <$> intValDec c1 <*> textValDec c2
+{-# INLINE decodeFortune #-}
+
+selectFortunes :: MySQL.MySQLConn -> IO (Either [Text] [Fortune])
+selectFortunes conn = do
+  (_, rowsS) <- MySQL.query_ conn "SELECT * FROM Fortune"
+  rows <- Streams.toList rowsS
+  let eFortunes = fmap decodeFortune rows
+  let (err, oks) = partitionEithers eFortunes
+  return $ case err of
+    [] -> pure oks
+    _ -> Left err
+{-# INLINE selectFortunes #-}
+
+fortunes :: DbPool -> Handler (Lucid.Html ())
+fortunes pool = do
+  r <- liftIO $ Pool.withResource pool selectFortunes
+  case r of
+    Left e -> throwError err500 { errBody = LBS.fromStrict . TextEnc.encodeUtf8 . Text.pack . show $ e }
+    Right fs -> return $ do
+      let new = Fortune 0 "Additional fortune added at request time."
+      Lucid.doctypehtml_ $ do
+        Lucid.head_ $ Lucid.title_ "Fortunes"
+        Lucid.body_ $ do
+          Lucid.table_ $ do
+            Lucid.tr_ $ do
+              Lucid.th_ "id"
+              Lucid.th_ "message"
+            mapM_ (\f -> Lucid.tr_ $ do
+              Lucid.td_ (Lucid.toHtml . show $ fId f)
+              Lucid.td_ (Lucid.toHtml $ fMessage f)) (sortOn fMessage (new : fs))
+{-# INLINE fortunes #-}
+
+-- * Test 5: Updates
+
+updates :: DbPool -> GenIO -> Maybe Count -> Handler [World]
+updates pool gen mcount = do
+  res <- liftIO $ Pool.withResource pool $ \conn -> do
+    sIdGet <- MySQL.prepareStmt conn "SELECT * FROM World WHERE id = ?"
+    sIdPut <- MySQL.prepareStmt conn "UPDATE World SET randomNumber = ? WHERE id = ?"
+    res <- replicateM (getCount mcount) $ do
+      vGet <- uniformR (1, 10000) gen
+      vPut <- uniformR (1, 10000) gen
+      (_, rowsS) <- MySQL.queryStmt conn sIdGet [intValEnc vGet]
+      eWorld <- extractWorld rowsS
+      case eWorld of
+        Left e -> return $ Left e
+        Right world -> do
+          _ <- MySQL.executeStmt conn sIdPut [intValEnc vPut, intValEnc vGet]
+          return . pure $ world { wRandomNumber = vPut }
+    MySQL.closeStmt conn sIdGet
+    MySQL.closeStmt conn sIdPut
+    return res
+  let (errs, oks) = partitionEithers res
+  case errs of
+    [] -> return oks
+    e -> throwError err500 { errBody = LBS.fromStrict . TextEnc.encodeUtf8 . Text.pack . show $ e }
+{-# INLINE updates #-}
+
+-- * Test 6: Plaintext endpoint
+
+plaintext :: Handler LBS.ByteString
+plaintext = return "Hello, World!"
+{-# INLINE plaintext #-}

frameworks/Haskell/servant/mysql-haskell/stack.yaml

@@ -0,0 +1,7 @@
+resolver: lts-13.11
+packages:
+- '.'
+
+# the following flags are meant for use with ../servant-mysql-haskell.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 # carryover from hasql sibling test dir

frameworks/Haskell/servant/servant-mysql-haskell.dockerfile

@@ -0,0 +1,13 @@
+FROM haskell:8.6.3
+
+WORKDIR /servant
+
+COPY ./mysql-haskell/stack.yaml .
+COPY ./mysql-haskell/servant-mysql-haskell.cabal .
+RUN stack setup
+RUN stack install --dependencies-only
+
+ADD ./mysql-haskell/ .
+RUN stack build --pedantic
+
+CMD stack exec servant-mysql-haskell -- tfb-database +RTS -A32m -N$(nproc)