Restructure Haskell/Servant for db modularity. (#4614)

* Restructure servant for db modularity.

- Starting an identical refactoring effort as done for Warp in: https://github.com/TechEmpower/FrameworkBenchmarks/pull/4595
- For now we're just moving files we intend to re-use and purging the ones we will no longer need due to upcoming db modularity.

* Copy warp/shared into servant/shared.

Due to a docker restriction that disallows referencing shared code directories from a parent dir, and lack of tooling support to alter the scope dir of docker build invoke, we are unfortunately resorting to copy pasting code between frameworks. Documented this in the servant-shared README.

* Complete restructuring servant for code re-use.

- Updated benchmark config to reference updated docker file path.
- Updated benchmark config to add `postgres-wire` variation as we now support it.
- Updated stack.yaml to adopt the earlier directory layout changes. We now have backend specific libraries (`shared/tfb-*`) and a single re-usable server (`servant-shared`) executable.
- Updated cabal file with mutliple executables using various backend drivers and the same shared server code.
- Updated docker file to build and install the new `servant-shared` server -- the cabal file is responsible for producing backend specific executables that match `TFB_TEST_NAME`.
- Updated `servant-shared` Lib to delegate database queries to `shared/tfb-*` backends so we can keep the server code backend agnostic.
- Added MIME module to store all MIME things. Separated it out to keep the main Lib module focusing on pure server and response logic.

frameworks/Haskell/servant/benchmark_config.json

@@ -22,7 +22,7 @@
       "database_os": "Linux",
       "display_name": "servant+hasql",
       "notes": "Uses libpq system dependency.",
-      "dockerfile": "servant.dockerfile"
+      "dockerfile": "servant-shared.dockerfile"
     },
     "mysql-haskell": {
       "json_url": "/json",
@@ -45,7 +45,30 @@
       "database_os": "Linux",
       "display_name": "servant+mysql-haskell",
       "notes": "Pure Haskell.",
-      "dockerfile": "servant.dockerfile"
+      "dockerfile": "servant-shared.dockerfile"
+    },
+    "postgres-wire": {
+      "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": "Servant",
+      "language": "Haskell",
+      "flavor": "GHC863",
+      "orm": "Raw",
+      "platform": "Wai",
+      "webserver": "Warp",
+      "os": "Linux",
+      "database_os": "Linux",
+      "display_name": "servant+postgres-wire",
+      "notes": "Pure Haskell.",
+      "dockerfile": "servant-shared.dockerfile"
     }
   }]
 }

frameworks/Haskell/servant/hasql/ChangeLog.md

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

frameworks/Haskell/servant/hasql/LICENSE

@@ -1,30 +0,0 @@
-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/hasql/README.md

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

frameworks/Haskell/servant/hasql/Setup.hs

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

frameworks/Haskell/servant/hasql/driver/Main.hs

@@ -1,16 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Main (main) where
-
-import Data.ByteString.Char8
-import ServantBench
-import Hasql.Connection (settings)
-import System.Environment (getArgs)
-
-main :: IO ()
-main = do
-  [host] <- getArgs
-  run 7041 $ dbSettings (pack host)
-
-dbSettings :: ByteString -> ByteString
-dbSettings host
-  = settings host 5432 "benchmarkdbuser" "benchmarkdbpass" "hello_world"

frameworks/Haskell/servant/hasql/servant-hasql.cabal

@@ -1,47 +0,0 @@
--- Initial servant-hasql.cabal generated by cabal init.  For further
--- documentation, see http://haskell.org/cabal/users-guide/
-
-name:                servant-hasql
-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
-                     , servant >= 0.7
-                     , servant-server >= 0.7
-                     , type-of-html
-                     , 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-hasql
-  main-is:             Main.hs
-  ghc-options:         -Wall -threaded -rtsopts -O2
-  build-depends:       base
-                     , servant-hasql
-                     , bytestring
-                     , hasql
-  hs-source-dirs:      driver
-  default-language:    Haskell2010

frameworks/Haskell/servant/hasql/src/ServantBench.hs

@@ -1,255 +0,0 @@
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeOperators         #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE UndecidableInstances  #-}
-
-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       (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as LBSC
-import           Data.Functor.Contravariant (contramap)
-import           Data.Either                (fromRight, partitionEithers)
-import           Data.Int                   (Int32)
-import           Data.List                  (sortOn)
-import           Data.Maybe                 (maybe)
-import           Data.Monoid                ((<>))
-import qualified Data.Text                  as Text
-import           Data.Text                  (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.Statement            as HasqlStatement
-import           Hasql.Session              (statement)
-import qualified Html
-import           Html ((#), type (#), type (>))
-import qualified Network.Wai.Handler.Warp   as Warp
-import           Network.HTTP.Media         ((//), (/:))
-import           Servant
-import           System.Random.MWC          (GenIO, createSystemRandom,
-                                             uniformR)
-import qualified Data.List.NonEmpty as NE
-
-type API =
-       "json" :> Get '[JSON] Value
-  :<|> "db" :> Get '[JSON] World
-  :<|> "queries" :> QueryParam "queries" QueryId :> Get '[JSON] [World]
-  :<|> "fortune" :> Get '[HTML] FortunesHtml
-  :<|> "updates" :> QueryParam "queries" QueryId :> 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
-  putStrLn "Launching servant hasql"
-  gen <- createSystemRandom
-  bracket (acquire settings) release $ \pool ->
-    Warp.run port $ serve api $ server pool gen
-  where
-    halfSecond = 0.5
-    settings = (512, halfSecond, dbSettings)
-
-newtype QueryId = QueryId { unQueryId :: Int }
-instance FromHttpApiData QueryId where
-  parseQueryParam
-    = pure . QueryId . fromRight 1 . parseQueryParam
-
-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.param HasqlEnc.int4
-intValDec :: HasqlDec.Row Int32
-intValDec = HasqlDec.column HasqlDec.int4
-
--- * PlainText without charset
-
-data Plain
-instance Accept Plain where contentType _ = "text" // "plain"
-instance MimeRender Plain ByteString where
-  mimeRender _ = id
-  {-# INLINE mimeRender #-}
-  
--- * HTML
--- TODO: package the following block of code into a library akin to 'servant-lucid'
-
-data HTML
-instance Accept HTML where
-    contentTypes _ =
-      "text" // "html" /: ("charset", "utf-8") NE.:|
-      ["text" // "html"]
-instance Html.Document a => MimeRender HTML a where
-    mimeRender _ = Html.renderByteString
-
-------------------------------------------------------------------------------
-
--- * Test 1: JSON serialization
-
-json :: Handler Value
-json = return . Object $ fromList [("message", "Hello, World!")]
-{-# INLINE json #-}
-
-
--- * Test 2: Single database query
-
-selectSingle :: HasqlStatement.Statement Int32 World
-selectSingle = HasqlStatement.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 (statement v selectSingle)
-  case r of
-    Left e -> throwError err500 { errBody = LBSC.pack . show $ e }
-    Right world -> return world
-{-# INLINE singleDb #-}
-
-
--- * Test 3: Multiple database query
-
-multipleDb :: Pool -> GenIO -> Maybe QueryId -> Handler [World]
-multipleDb pool gen mQueryId = do
-  results <- getResults
-  let (errs, oks) = partitionEithers results
-  case errs of
-    [] -> return oks
-    _ -> throwError err500 { errBody = LBSC.pack . show $ errs }
-  where
-    c = maybe 1 unQueryId mQueryId
-    count_ = max 1 (min c 500)
-    getResults = replicateM count_ . liftIO . use pool $ do
-      v <- liftIO $ uniformR (1, 10000) gen
-      statement v selectSingle
-{-# INLINE multipleDb #-}
-
-
--- * Test 4: Fortunes
-
-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)
-                )
-              ]
-            )
-          )
-        )
-      )
-    )
-  )
-
-selectFortunes :: HasqlStatement.Statement () [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 $ Fortune <$> intValDec <*> HasqlDec.column HasqlDec.text
-{-# INLINE selectFortunes #-}
-
-fortunes :: Pool -> Handler FortunesHtml
-fortunes pool = do
-  r <- liftIO $ use pool (statement () selectFortunes)
-  case r of
-    Left e -> throwError err500 { errBody = LBSC.pack . show $ e }
-    Right fs -> return $ do
-      let new = 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 $ fId f) # Html.td_ (fMessage f)
-      let rows = fmap mkRow $ sortOn fMessage (new : fs)
-      Html.doctype_ #
-        Html.html_ (
-          Html.head_ (
-            Html.title_ (Html.Raw "Fortunes")
-          ) #
-          Html.body_ ( Html.table_ $
-            header # rows
-          )
-        )
-{-# INLINE fortunes #-}
-
-
--- * Test 5: Updates
-
-updateSingle :: HasqlStatement.Statement (Int32, Int32) ()
-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
-{-# INLINE updateSingle #-}
-
-updates :: Pool -> GenIO -> Maybe QueryId -> Handler [World]
-updates pool gen mQueryId = do
-  results <- getResults
-  let (errs, oks) = partitionEithers results
-  case errs of
-    [] -> return oks
-    _ -> throwError err500 { errBody = LBSC.pack . show $ errs }
-  where
-    c = maybe 1 unQueryId mQueryId
-    count_ = max 1 (min c 500)
-    getResults = replicateM count_ . liftIO . use pool $ do
-      v1 <- liftIO $ uniformR (1, 10000) gen
-      res <- statement v1 selectSingle
-      v2 <- liftIO $ uniformR (1, 10000) gen
-      _ <- statement (wId res, v2) updateSingle
-      return $ res { wRandomNumber = v2 }
-{-# INLINE updates #-}
-
--- * Test 6: Plaintext endpoint
-
-plaintext :: Handler ByteString
-plaintext = return "Hello, World!"
-{-# INLINE plaintext #-}

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

@@ -1,5 +0,0 @@
-# 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

@@ -1,35 +0,0 @@
-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
-    , type-of-html
-    , 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

@@ -1,297 +0,0 @@
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeOperators         #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE UndecidableInstances  #-}
-
-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 Html
-import           Html ((#), type (#), type (>))
-import qualified Network.Wai.Handler.Warp   as Warp
-import           Network.HTTP.Media         ((//), (/:))
-import           Servant
-import           System.Random.MWC          (GenIO, createSystemRandom,
-                                             uniformR)
-import qualified GHC.Conc
-import           System.Environment (getArgs)
-import qualified Data.List.NonEmpty as NE
-
-type API =
-       "json" :> Get '[JSON] Aeson.Value
-  :<|> "db" :> Get '[JSON] World
-  :<|> "queries" :> QueryParam "queries" Count :> Get '[JSON] [World]
-  :<|> "fortune" :> Get '[HTML] FortunesHtml
-  :<|> "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
-  putStrLn "Launching servant mysql-hasql"
-  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 #-}
-  
--- * HTML
--- TODO: package the following block of code into a library akin to 'servant-lucid'
-
-data HTML
-instance Accept HTML where
-    contentTypes _ =
-      "text" // "html" /: ("charset", "utf-8") NE.:|
-      ["text" // "html"]
-instance Html.Document a => MimeRender HTML a where
-    mimeRender _ = Html.renderByteString
-
-------------------------------------------------------------------------------
-
--- * 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 #-}
-
-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)
-                )
-              ]
-            )
-          )
-        )
-      )
-    )
-  )
-
-fortunes :: DbPool -> Handler FortunesHtml
-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."
-      let header = Html.tr_ $ Html.th_ (Html.Raw "id") # Html.th_ (Html.Raw "message")
-      let mkRow f = Html.tr_ $ Html.td_ (fromIntegral $ fId f) # Html.td_ (fMessage f)
-      let rows = fmap mkRow $ sortOn fMessage (new : fs)
-      Html.doctype_ #
-        Html.html_ (
-          Html.head_ (
-            Html.title_ (Html.Raw "Fortunes")
-          ) #
-          Html.body_ ( Html.table_ $
-            header # rows
-          )
-        )
-{-# 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/servant-shared.dockerfile

@@ -0,0 +1,24 @@
+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 ./shared/tfb-types/tfb-types.cabal ./shared/tfb-types/
+COPY ./shared/tfb-hasql/tfb-hasql.cabal ./shared/tfb-hasql/
+COPY ./shared/tfb-mysql-haskell/tfb-mysql-haskell.cabal ./shared/tfb-mysql-haskell/
+COPY ./shared/tfb-postgres-wire/tfb-postgres-wire.cabal ./shared/tfb-postgres-wire/
+COPY ./servant-shared/servant-shared.cabal ./servant-shared/
+RUN stack setup
+RUN stack install --dependencies-only
+
+ADD ./shared ./shared
+ADD ./servant-shared ./servant-shared
+RUN stack build --pedantic --copy-bins
+RUN ln -s ~/.local/bin/servant-hasql ~/.local/bin/servant
+
+ARG TFB_TEST_NAME
+ENV TFB_TEST_NAME=${TFB_TEST_NAME}
+CMD stack exec $TFB_TEST_NAME -- tfb-database +RTS -A32m -N$(nproc)

frameworks/Haskell/servant/servant-shared/README.md

@@ -0,0 +1,9 @@
+# Servant Shared
+
+This is a generic test that produces an executable for each supported backend library:
+
+- `servant-hasql`: PostgreSQL database via the [`hasql`](https://github.com/nikita-volkov/hasql) library.
+- `servant-mysql-haskell`: MySQL database via the [`mysql-haskell`](https://github.com/winterland1989/mysql-haskell) library.
+- `servant-postgres-wire` (default): PostgreSQL database via the [`postgres-wire`](https://github.com/postgres-haskell/postgres-wire) library.
+
+**NOTE**: the `shared` directory here is a full copy of the same directory within the `warp` framework dir. TODO: wait for TFB to [add support for language scope dockerfile](https://github.com/TechEmpower/FrameworkBenchmarks/pull/4595#issuecomment-478593547) before moving `shared` up into the Haskell language dir so both `servant` and `warp` can re-use the same modules.

frameworks/Haskell/servant/servant-shared/servant-shared.cabal

@@ -0,0 +1,54 @@
+cabal-version:       2.4
+-- `cabal-version` MUST match the version bundled with stack.
+-- run `stack exec -- cabal --version` to find out
+name:                servant-shared
+version:             0.1.0.0
+homepage:            https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/servant/servant-shared
+license:             BSD-3-Clause
+author:              Julian K. Arni
+maintainer:          [email protected]
+-- copyright:
+category:            Web
+build-type:          Simple
+extra-source-files:  README.md
+
+common deps
+  hs-source-dirs:      src
+  other-modules:       Lib, MIME
+  default-language:    Haskell2010
+  ghc-options:         -Wall -threaded -rtsopts -O2 -funbox-strict-fields
+  build-depends:       base >=4.8
+                     , servant >= 0.7
+                     , servant-server >= 0.7
+                     , type-of-html
+                     , buffer-builder
+                     , bytestring >= 0.10.6
+                     , mwc-random >= 0.13
+                     , warp >= 3.2
+                     , transformers
+                     , text >= 1.2
+                     , http-media >= 0.6
+
+executable servant-hasql
+  import: deps
+  main-is:
+    Main.hs
+  build-depends:
+      tfb-types
+    , tfb-hasql
+
+executable servant-mysql-haskell
+  import: deps
+  main-is:
+    Main.hs
+  build-depends:
+      tfb-types
+    , tfb-mysql-haskell
+
+executable servant-postgres-wire
+  import: deps
+  main-is:
+    Main.hs
+  build-depends:
+      tfb-types
+    , tfb-postgres-wire

frameworks/Haskell/servant/servant-shared/src/Lib.hs

@@ -0,0 +1,142 @@
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE TypeOperators         #-}
+
+module Lib (
+    main
+  , Db.Config(..)
+) where
+
+import qualified TFB.Types as Types
+import qualified TFB.Db as Db
+import           MIME (Plain, HTML, Json)
+import qualified Data.Either as Either
+import           Data.List (sortOn)
+import           Control.Monad (replicateM)
+
+import           Control.Monad.IO.Class     (liftIO)
+import qualified Data.BufferBuilder.Json    as Json
+import           Data.BufferBuilder.Json    ((.=))
+import           Data.ByteString.Lazy       (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as LBSC
+import qualified Html
+import           Html                       ((#))
+import qualified Network.Wai.Handler.Warp   as Warp
+import           Servant
+import qualified System.Random.MWC          as MWC
+
+-- * API contracts
+
+type API =
+       "json"       :> Get '[Json] Json.ObjectBuilder
+  :<|> "db"         :> Get '[Json] Types.World
+  :<|> "queries"    :> QueryParam "queries" Types.Count :> Get '[Json] [Types.World]
+  :<|> "fortune"    :> Get '[HTML] Types.FortunesHtml
+  :<|> "updates"    :> QueryParam "queries" Types.Count :> Get '[Json] [Types.World]
+  :<|> "plaintext"  :> Get '[Plain] ByteString
+
+api :: Proxy API
+api = Proxy
+
+server :: MWC.GenIO -> Db.Pool -> Server API
+server gen dbPool =
+      getJson
+ :<|> getWorld gen dbPool
+ :<|> getWorlds gen dbPool
+ :<|> getFortunes dbPool
+ :<|> updateWorlds gen dbPool
+ :<|> plaintext
+
+-- | 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 "Servant is ready to serve you"
+  Warp.run 7041 $ serve api $ server gen dbPool
+
+------------------------------------------------------------------------------
+
+-- * Test 1: JSON serialization
+
+getJson :: Handler Json.ObjectBuilder
+getJson = return $ "message" .= Types.unsafeJsonString "Hello, World!"
+{-# INLINE getJson #-}
+
+-- * Test 2: Single database query
+
+getWorld :: MWC.GenIO -> Db.Pool -> Handler Types.World
+getWorld gen dbPool = do
+  wId <- liftIO $ randomId gen
+  res <- liftIO $ Db.queryWorldById dbPool wId
+  Either.either respondDbError pure $ res
+{-# INLINE getWorld #-}
+
+-- * Test 3: Multiple database query
+
+getWorlds :: MWC.GenIO -> Db.Pool -> Maybe Types.Count -> Handler [Types.World]
+getWorlds gen dbPool mCount = do
+  wIds <- liftIO $ replicateM count $ randomId gen
+  res <- liftIO $ Db.queryWorldByIds dbPool wIds
+  Either.either respondDbError pure $ res
+  where
+    count = Types.getCount mCount
+{-# INLINE getWorlds #-}
+
+-- * Test 4: Fortunes
+
+getFortunes :: Db.Pool -> Handler Types.FortunesHtml
+getFortunes dbPool = do
+  res <- liftIO $ Db.queryFortunes dbPool
+  case res of
+    Left e -> respondDbError e
+    Right fs -> return $ 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 #-}
+
+-- * Test 5: Updates
+
+updateWorlds :: MWC.GenIO -> Db.Pool -> Maybe Types.Count -> Handler [Types.World]
+updateWorlds gen dbPool mCount = do
+  wIds <- liftIO $ replicateM count $ randomId gen
+  res <- liftIO $ Db.queryWorldByIds dbPool wIds
+  Either.either respondDbError (go dbPool) res
+  where
+    count = Types.getCount mCount
+    go conn ws = do
+      wNumbers <- liftIO $ replicateM count $ randomId gen
+      wsUp <- liftIO $ Db.updateWorlds conn . zip ws $ fmap fromIntegral wNumbers
+      Either.either respondDbError pure wsUp
+{-# INLINE updateWorlds #-}
+
+-- * Test 6: Plaintext endpoint
+
+plaintext :: Handler ByteString
+plaintext = return "Hello, World!"
+{-# INLINE plaintext #-}
+
+------------------------------------------------------------------------------
+
+-- * utils
+
+respondDbError :: Db.Error -> Handler a
+respondDbError e = throwError err500 { errBody = LBSC.pack . show $ e }
+
+randomId :: MWC.GenIO -> IO Types.QId
+randomId = MWC.uniformR (1, 10000)

frameworks/Haskell/servant/servant-shared/src/MIME.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE UndecidableInstances  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- This module contains one off boilerplate that is not usually required
+module MIME (
+    Plain
+  , HTML
+  , Json
+) where
+
+import qualified TFB.Types as Types
+import qualified Data.Either as Either
+import qualified Data.List.NonEmpty as NE
+
+import           Data.ByteString.Lazy       (ByteString)
+import qualified Data.ByteString.Lazy       as LBS
+import qualified Data.BufferBuilder.Json    as Json
+import qualified Html
+import           Servant                    as S
+import           Network.HTTP.Media         ((//), (/:))
+
+-- * PlainText without charset
+-- This is necessary to fulfill TFB requirements.
+-- The built-in servant Plaintext MIME is richer with encoding
+-- https://hackage.haskell.org/package/servant-0.15/docs/Servant-API.html#t:PlainText 
+
+data Plain
+instance S.Accept Plain where contentType _ = "text" // "plain"
+instance S.MimeRender Plain ByteString where
+  mimeRender _ = id
+  {-# INLINE mimeRender #-}
+
+-- * HTML
+-- TODO: package the following block of code into a library akin to 'servant-lucid'
+
+data HTML
+instance S.Accept HTML where
+    contentTypes _ =
+      "text" // "html" /: ("charset", "utf-8") NE.:|
+      ["text" // "html"]
+instance Html.Document a => S.MimeRender HTML a where
+  {-# SPECIALIZE S.mimeRender :: S.Proxy HTML -> Types.FortunesHtml -> ByteString #-}
+  mimeRender _ = Html.renderByteString
+
+-- * JSON
+-- The built-in servant JSON mime only works with Aeson.
+-- https://hackage.haskell.org/package/servant-0.15/docs/Servant-API.html#t:JSON
+-- For performance we use BufferBuilder; hence we need to describe our own Mime.
+-- TODO: package the following block of code into a library akin to 'servant-lucid'
+
+data Json
+instance S.Accept Json where
+  contentTypes _ = "application" // "json" NE.:| []
+instance Json.ToJson a => S.MimeRender Json a where
+  {-# SPECIALIZE S.mimeRender :: S.Proxy Json -> Json.ObjectBuilder -> ByteString #-}
+  {-# SPECIALIZE S.mimeRender :: S.Proxy Json -> Types.World -> ByteString #-}
+  mimeRender _ = LBS.fromStrict . Json.encodeJson
+
+instance S.FromHttpApiData Types.Count where
+  parseQueryParam
+    = pure . Types.mkCount . Either.fromRight 1 . parseQueryParam

frameworks/Haskell/servant/servant-shared/src/Main.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE OverloadedStrings     #-}
+
+module Main where
+
+import qualified Lib
+import qualified GHC.Conc
+import           System.Environment (getArgs, lookupEnv)
+
+main :: IO ()
+main = do
+  testName <- lookupEnv "TFB_TEST_NAME"
+  putStrLn $ "Test is: " ++ show testName
+  args <- getArgs
+  dbHost <- case args of
+    [x] -> pure x
+    _ -> pure "0.0.0.0"
+  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/servant/servant.dockerfile

@@ -1,21 +0,0 @@
-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 ./hasql/servant-hasql.cabal ./hasql/
-COPY ./mysql-haskell/servant-mysql-haskell.cabal ./mysql-haskell/
-RUN stack setup
-RUN stack install --dependencies-only
-
-ADD ./hasql/ ./hasql/
-ADD ./mysql-haskell/ ./mysql-haskell/
-RUN stack build --pedantic --copy-bins
-RUN ln -s ~/.local/bin/servant-hasql ~/.local/bin/servant
-
-ARG TFB_TEST_NAME
-ENV TFB_TEST_NAME=${TFB_TEST_NAME}
-CMD stack exec $TFB_TEST_NAME -- tfb-database +RTS -A32m -N$(nproc)

frameworks/Haskell/servant/shared/tfb-hasql/README.md

@@ -0,0 +1,3 @@
+# TFB Hasql
+
+`hasql` backend for TFB benchmarks that can re-used with any server.

frameworks/Haskell/servant/shared/tfb-hasql/TFB/Db.hs

@@ -0,0 +1,111 @@
+{-# OPTIONS -funbox-strict-fields #-}
+{-# LANGUAGE OverloadedStrings     #-}
+
+module TFB.Db (
+    Pool
+  , mkPool
+  , Config(..)
+  , queryWorldById
+  , queryWorldByIds
+  , updateWorlds
+  , queryFortunes
+  , Error
+) where
+
+import qualified TFB.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 = contramap fromIntegral $ HasqlEnc.param HasqlEnc.int2
+intValDec :: HasqlDec.Row Types.QId
+intValDec = fmap fromIntegral $ 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/servant/shared/tfb-hasql/tfb-hasql.cabal

@@ -0,0 +1,24 @@
+name:                tfb-hasql
+version:             0.1.0.0
+homepage:            https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/warp/shared/tfb-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:      .
+  default-language:    Haskell2010
+  exposed-modules:     TFB.Db
+  build-depends:
+      base >= 4.7 && < 5
+    , tfb-types
+    , bytestring
+    , text
+    , hasql >= 0.19
+    , hasql-pool >= 0.4
+    , contravariant

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

@@ -0,0 +1,3 @@
+# TFB MySQLHaskell
+
+`mysql-haskell` backend for TFB benchmarks that can re-used with any server.

frameworks/Haskell/servant/shared/tfb-mysql-haskell/TFB/Db.hs

@@ -0,0 +1,155 @@
+{-# OPTIONS -funbox-strict-fields #-}
+{-# LANGUAGE OverloadedStrings     #-}
+
+module TFB.Db (
+    Pool
+  , mkPool
+  , Config(..)
+  , queryWorldById
+  , queryWorldByIds
+  , updateWorlds
+  , queryFortunes
+  , Error
+) where
+
+import qualified TFB.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 :: Pool -> Types.QId -> IO (Either Error Types.World)
+queryWorldById dbPool wId = Pool.withResource dbPool $ \conn -> 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
+    [] -> case oks of
+      [] -> Left "World not found!"
+      ws  -> pure $ head ws
+    _ -> Left . mconcat $ err
+  where
+    s = "SELECT * FROM World WHERE id = ?"
+
+queryWorldByIds :: Pool -> [Types.QId] -> IO (Either Error [Types.World])
+queryWorldByIds _ [] = pure . pure $ mempty
+queryWorldByIds dbPool wIds = Pool.withResource dbPool $ \conn -> 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 . mconcat $ errs
+
+updateWorlds :: Pool -> [(Types.World, Int)] -> IO (Either Error [Types.World])
+updateWorlds _ [] = pure . pure $ mempty
+updateWorlds dbPool wsUpdates = Pool.withResource dbPool $ \conn -> 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 :: Pool -> IO (Either Error [Types.Fortune])
+queryFortunes dbPool = Pool.withResource dbPool $ \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 $ head err

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

@@ -0,0 +1,24 @@
+name:                tfb-mysql-haskell
+version:             0.1.0.0
+homepage:            https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/warp/shared/tfb-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:      .
+  default-language:    Haskell2010
+  exposed-modules:     TFB.Db
+  build-depends:
+      base >= 4.7 && < 5
+    , tfb-types
+    , bytestring
+    , text
+    , resource-pool
+    , mysql-haskell
+    , io-streams

frameworks/Haskell/servant/shared/tfb-postgres-wire/README.md

@@ -0,0 +1,3 @@
+# TFB PostgresWire
+
+`postgres-wire` backend for TFB benchmarks that can re-used with any server.

frameworks/Haskell/servant/shared/tfb-postgres-wire/TFB/Db.hs

@@ -0,0 +1,174 @@
+{-# OPTIONS -funbox-strict-fields #-}
+{-# LANGUAGE OverloadedStrings     #-}
+
+module TFB.Db (
+    Pool
+  , mkPool
+  , Config(..)
+  , queryWorldById
+  , queryWorldByIds
+  , updateWorlds
+  , queryFortunes
+  , Error
+) where
+
+import qualified TFB.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
+data Error
+  = DbError PG.Error
+  | DbErrors [PG.Error]
+  | NotFound
+  deriving Show
+
+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 :: Pool -> Types.QId -> IO (Either Error Types.World)
+queryWorldById dbPool wId = Pool.withResource dbPool $ \conn -> do
+  fmap go $ runQuery conn decodeWorld q
+  where
+    s = "SELECT * FROM World WHERE id = $1"
+    q = mkQuery s [encodeInt wId]
+    mkW [] = Left NotFound
+    mkW ws = pure . head $ ws
+    go = Either.either (Left . DbError) (mkW . V.toList)
+
+queryWorldByIds :: Pool -> [Types.QId] -> IO (Either Error [Types.World])
+queryWorldByIds _ [] = pure . pure $ mempty
+queryWorldByIds dbPool wIds = Pool.withResource dbPool $ \conn -> 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 . DbErrors $ errs
+
+updateWorlds :: Pool -> [(Types.World, Int)] -> IO (Either Error [Types.World])
+updateWorlds _ [] = pure . pure $ mempty
+updateWorlds dbPool wsUpdates = Pool.withResource dbPool $ \conn -> 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 . DbErrors $ 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 :: Pool -> IO (Either Error [Types.Fortune])
+queryFortunes dbPool = Pool.withResource dbPool $ \conn -> do
+  fmap go $ runQuery conn decodeFortune q
+  where
+    s = "SELECT * FROM Fortune"
+    q = mkQuery s []
+    go = Either.either (Left . DbError) (pure . V.toList)

frameworks/Haskell/servant/shared/tfb-postgres-wire/tfb-postgres-wire.cabal

@@ -0,0 +1,24 @@
+name:                tfb-postgres-wire
+version:             0.1.0.0
+homepage:            https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/warp/shared/tfb-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:      .
+  default-language:    Haskell2010
+  exposed-modules:     TFB.Db
+  build-depends:
+      base >= 4.7 && < 5
+    , tfb-types
+    , resource-pool
+    , postgres-wire
+    , bytestring
+    , vector
+    , text

frameworks/Haskell/servant/shared/tfb-types/README.md

@@ -0,0 +1,3 @@
+# TFB Types
+
+Haskell types for TFB benchmarks that can re-used with multiple databases and servers of choice.

frameworks/Haskell/servant/shared/tfb-types/TFB/Types.hs

@@ -0,0 +1,102 @@
+{-# OPTIONS -funbox-strict-fields #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE TypeOperators         #-}
+
+module TFB.Types (
+    unsafeJsonString
+  , parseCount
+  , getCount
+  , mkCount
+  , Count
+  , World(..)
+  , Fortune(..)
+  , FortunesHtml
+  , QId
+) where
+
+import qualified Data.Either as Either
+import qualified Data.Char as Char
+
+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
+
+mkCount :: Int -> Count
+mkCount = Count
+
+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 = Int
+
+-------------------------------------------------------------------------------
+-- * Outputs
+
+data World = World { wId :: QId , wRandomNumber :: QId }
+  deriving Show
+
+instance Json.ToJson World where
+  toJson w
+    = Json.toJson
+    $ "id"           .= wId w
+   <> "randomNumber" .= wRandomNumber w
+
+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 > QId)
+                # ('Html.Td > Text)
+                )
+              ]
+            )
+          )
+        )
+      )
+    )
+  )
+
+unsafeJsonString :: ByteString -> Json.Value
+unsafeJsonString = Json.unsafeValueUtf8Builder . Utf8.appendBS7 . quote
+  where
+    quote x = "\"" <> x <> "\""

frameworks/Haskell/servant/shared/tfb-types/tfb-types.cabal

@@ -0,0 +1,23 @@
+name:                tfb-types
+version:             0.1.0.0
+homepage:            https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/warp/shared/tfb-types
+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:      .
+  default-language:    Haskell2010
+  exposed-modules:     TFB.Types
+  build-depends:
+      base >= 4.7 && < 5
+    , bytestring
+    , attoparsec
+    , buffer-builder
+    , type-of-html
+    , text

frameworks/Haskell/servant/stack.yaml

@@ -1,7 +1,17 @@
 resolver: lts-13.13
+
 packages:
-- './hasql'
-- './mysql-haskell'
+- ./shared/tfb-types
+- ./shared/tfb-hasql
+- ./shared/tfb-mysql-haskell
+- ./shared/tfb-postgres-wire
+- ./servant-shared
+
+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 servant.dockerfile
 compiler: ghc-8.6.3 # this MUST match the resolver's GHC; minor hack to ensure GHC isn't downloaded into sandbox.