Change servant benchmarks to be more idiomatic (#5098)

* Change servant test to use cabal to build stuff

- Make the servant more "what it's supposed to be", i.e. no tricks
- Use generics based (more friendly) api definition
- Unfortunately only plaintext and json benchmarks for now and...
- `/db` benchmark using `postgresql-simple` and `beam`
- Latest `servant` versions in use
- GHC-8.6.5

* Add /fortune to servant implementation

frameworks/Haskell/servant/benchmark_config.json

@@ -3,72 +3,63 @@
   "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",
+      "database": "None",
       "framework": "Servant",
       "language": "Haskell",
-      "flavor": "GHC863",
+      "flavor": "GHC865",
       "orm": "Raw",
       "platform": "Wai",
       "webserver": "Warp",
       "os": "Linux",
       "database_os": "Linux",
-      "display_name": "servant+hasql",
+      "display_name": "servant",
       "notes": "Uses libpq system dependency.",
-      "dockerfile": "servant-shared.dockerfile"
+      "dockerfile": "servant.dockerfile",
+      "versus": "warp"
     },
-    "mysql-haskell": {
-      "json_url": "/json",
+    "beam": {
       "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",
+      "database": "Postgres",
       "framework": "Servant",
       "language": "Haskell",
-      "flavor": "GHC863",
-      "orm": "Raw",
+      "flavor": "GHC865",
+      "orm": "Micro",
       "platform": "Wai",
       "webserver": "Warp",
       "os": "Linux",
       "database_os": "Linux",
-      "display_name": "servant+mysql-haskell",
-      "notes": "Pure Haskell.",
-      "dockerfile": "servant-shared.dockerfile"
+      "display_name": "servant-beam",
+      "notes": "Uses libpq system dependency.",
+      "dockerfile": "servant-beam.dockerfile",
+      "versus": "warp"
     },
-    "postgres-wire": {
-      "json_url": "/json",
+    "psql-simple": {
       "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",
+      "flavor": "GHC865",
       "orm": "Raw",
       "platform": "Wai",
       "webserver": "Warp",
       "os": "Linux",
       "database_os": "Linux",
-      "display_name": "servant+postgres-wire",
-      "notes": "Pure Haskell.",
-      "dockerfile": "servant-shared.dockerfile"
+      "display_name": "servant-postgresql-simple",
+      "notes": "Uses libpq system dependency.",
+      "dockerfile": "servant-psql-simple.dockerfile",
+      "versus": "warp"
     }
   }]
 }

frameworks/Haskell/servant/cabal.project

@@ -0,0 +1,12 @@
+with-compiler: ghc-8.6.5
+index-state:   2019-09-28T11:54:13Z
+optimization:  True
+packages:      servant-tfb/
+
+allow-newer: beam-core-0.8.0.0:hashable
+allow-newer: beam-core-0.8.0.0:vector-sized
+allow-newer: beam-postgres-0.4.0.0:hashable
+allow-newer: beam-migrate-0.4.0.1:hashable
+
+constraints: hashable ^>=1.3.0.0
+constraints: primitive ^>=0.7.0.0

frameworks/Haskell/servant/servant-beam.dockerfile

@@ -0,0 +1,25 @@
+FROM haskell:8.6.5
+
+RUN apt update -yqq && apt install -yqq xz-utils make
+RUN apt install -yqq libpq-dev
+
+WORKDIR /app
+
+# Update cabal here
+RUN cabal update
+
+# First add only
+COPY cabal.project ./
+COPY ./servant-tfb/servant-tfb.cabal ./servant-tfb/servant-tfb.cabal
+RUN find .
+RUN cabal v2-build warp
+RUN cabal v2-build wai-app-static
+RUN cabal v2-build beam-postgres
+RUN cabal v2-build servant-server
+
+ADD ./servant-tfb ./servant-tfb
+RUN cabal v2-build all
+
+RUN cp $(find dist-newstyle -name servant-tfb-beam -type f) /app/dist-newstyle/servant-tfb-beam
+
+CMD /app/dist-newstyle/servant-tfb-beam +RTS -A32m -N$(nproc) -qn2 -M2G -RTS

frameworks/Haskell/servant/servant-psql-simple.dockerfile

@@ -0,0 +1,25 @@
+FROM haskell:8.6.5
+
+RUN apt update -yqq && apt install -yqq xz-utils make
+RUN apt install -yqq libpq-dev
+
+WORKDIR /app
+
+# Update cabal here
+RUN cabal update
+
+# First add only
+COPY cabal.project ./
+COPY ./servant-tfb/servant-tfb.cabal ./servant-tfb/servant-tfb.cabal
+RUN find .
+RUN cabal v2-build warp
+RUN cabal v2-build wai-app-static
+RUN cabal v2-build beam-postgres
+RUN cabal v2-build servant-server
+
+ADD ./servant-tfb ./servant-tfb
+RUN cabal v2-build all
+
+RUN cp $(find dist-newstyle -name servant-tfb-psql-simple -type f) /app/dist-newstyle/servant-tfb-psql-simple
+
+CMD /app/dist-newstyle/servant-tfb-psql-simple +RTS -A32m -N$(nproc) -qn2 -M2G -RTS

frameworks/Haskell/servant/servant-shared.dockerfile

@@ -1,24 +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 ./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/servant-shared.cabal

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

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

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

@@ -1,25 +0,0 @@
-{-# 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-tfb/servant-tfb.cabal

@@ -0,0 +1,56 @@
+cabal-version:      2.4
+name:               servant-tfb
+version:            1
+homepage:
+  https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/servant/2pkg
+
+license:            BSD-3-Clause
+author:             Oleg.Grenrus
+maintainer:         [email protected]
+category:           Web, Servant
+build-type:         Simple
+extra-source-files: README.md
+
+common deps
+  hs-source-dirs:   src
+  default-language: Haskell2010
+  ghc-options:      -Wall -threaded -rtsopts -funbox-strict-fields
+  build-depends:
+    , aeson           ^>=1.4.5.0
+    , base            ^>=4.12
+    , bytestring      ^>=0.10.8.0
+    , lucid           ^>=2.9.11
+    , servant         ^>=0.16
+    , servant-lucid   ^>=0.9
+    , servant-server  ^>=0.16
+    , splitmix        ^>=0.0.3
+    , text            ^>=1.2.3.0
+    , transformers    ^>=0.5.6.2
+    , vector          ^>=0.12.0.3
+    , warp            ^>=3.3.2
+
+common db-deps
+  import:        deps
+  build-depends:
+    , postgresql-simple  ^>=0.6.2
+    , resource-pool      ^>=0.2.3.2
+
+executable servant-tfb
+  import:        deps
+  other-modules: Lib
+  main-is:       Main.hs
+
+executable servant-tfb-beam
+  import:        db-deps
+  other-modules: Lib
+  main-is:       Main.hs
+  cpp-options:   -DDB_BEAM
+  build-depends:
+    , beam-core      ^>=0.8
+    , beam-postgres  ^>=0.4.0.0
+
+executable servant-tfb-psql-simple
+  import:        db-deps
+  other-modules: Lib
+  main-is:       Main.hs
+  cpp-options:   -DDB_PSQL_SIMPLE

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

@@ -0,0 +1,341 @@
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE DeriveAnyClass     #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RankNTypes         #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE TypeOperators      #-}
+
+#if defined(DB_BEAM) || defined(DB_PSQL_SIMPLE)
+#define HAS_DB 1
+#endif
+
+module Lib (
+    main,
+    -- * Exports to hide warnings
+    withSMGen,
+    ) where
+
+import           Control.Concurrent         (myThreadId, threadCapability)
+import           Control.Concurrent.MVar    (MVar, modifyMVarMasked, newMVar)
+import           Data.Aeson                 (ToJSON (..), object, pairs, (.=))
+import           Data.Text                  (Text)
+import           Data.Vector                (Vector)
+import           Servant
+import           Servant.API.Generic
+import           Servant.Server.Generic
+
+import qualified Data.Vector                as V
+import qualified Network.Wai.Handler.Warp   as Warp
+import qualified System.Random.SplitMix     as SM
+
+#ifdef HAS_DB
+import           Data.Foldable              (for_)
+import           Data.Int                   (Int32)
+import           Data.List                  (sortOn)
+import           Data.Pool                  (Pool, createPool, withResource)
+import           Lucid                      hiding (for_)
+import           Servant.HTML.Lucid
+#endif
+
+#ifdef DB_BEAM
+import           Database.Beam
+import           Database.Beam.Postgres
+#endif
+
+#ifdef DB_PSQL_SIMPLE
+import           Control.Monad.IO.Class     (MonadIO (..))
+import           Database.PostgreSQL.Simple
+#endif
+
+-------------------------------------------------------------------------------
+-- API Definition
+-------------------------------------------------------------------------------
+
+data Routes route = Routes
+    { routePlaintext :: route :- "plaintext" :> Get '[PlainText] Text
+    , routeJson      :: route :- "json"      :> Get '[JSON]      JsonData
+#ifdef HAS_DB
+    , routeDb        :: route :- "db"        :> Get '[JSON]      World
+    , routeFortune   :: route :- "fortune"   :> Get '[HTML]      FortunePage
+#endif
+    }
+  deriving (Generic)
+
+serverRoutes :: Ctx -> Routes AsServer
+serverRoutes _ctx = Routes
+    { routePlaintext = handlerPlaintext
+    , routeJson      = handlerJson
+#ifdef HAS_DB
+    , routeDb        = handlerDb _ctx
+    , routeFortune   = handlerFortune _ctx
+#endif
+    }
+
+app :: Ctx -> Application
+app = genericServe . serverRoutes
+
+-- | entry point
+main
+    :: Int  -- ^ number of capabilities
+    -> IO ()
+main _cap = do
+    -- create 32 randon number generators
+    rng <- V.replicateM 32 (SM.newSMGen >>= newMVar)
+
+#ifdef HAS_DB
+    db <- createPool
+        (connect dbConnectInfo)
+        close
+        _cap
+        0.5
+        512
+#endif
+
+    let ctx = Ctx { ctxRng = rng
+#ifdef HAS_DB
+                  , ctxDb  = db
+#endif
+                  }
+
+    putStrLn "Servant is ready to serve you"
+    Warp.run 7041 $ app ctx
+  where
+#ifdef HAS_DB
+    dbConnectInfo :: ConnectInfo
+    dbConnectInfo = ConnectInfo
+        { connectHost     = "tfb-database"
+        , connectPort     = 5432
+        , connectUser     = "benchmarkdbuser"
+        , connectPassword = "benchmarkdbpass"
+        , connectDatabase = "hello_world"
+        }
+#endif
+
+-------------------------------------------------------------------------------
+-- Execution context
+-------------------------------------------------------------------------------
+
+data Ctx = Ctx
+    { ctxRng :: !(Vector (MVar SM.SMGen))
+#ifdef HAS_DB
+    , ctxDb  :: !(Pool Connection)
+#endif
+    }
+
+#ifdef HAS_DB
+withConnection :: Ctx -> (Connection -> IO r) -> IO r
+withConnection ctx = withResource (ctxDb ctx)
+#endif
+
+withSMGen :: Ctx -> (SM.SMGen -> IO r) -> IO r
+withSMGen ctx k = do
+    tid <- myThreadId
+    (cap, _) <- threadCapability tid
+    gen <- modifyMVarMasked (ctxRng ctx V.! mod cap 32) $ return . SM.splitSMGen
+    k gen
+
+-------------------------------------------------------------------------------
+-- Test 1: JSON serialization
+-------------------------------------------------------------------------------
+
+newtype JsonData = JsonData Text
+
+instance ToJSON JsonData where
+    toEncoding (JsonData t) = pairs ("message" .= t)
+    toJSON     (JsonData t) = object [ "message" .= t ]
+
+
+handlerJson :: Handler JsonData
+handlerJson = return $ JsonData "Hello, World!"
+
+-------------------------------------------------------------------------------
+-- Test 2: Single database query
+-------------------------------------------------------------------------------
+
+#ifdef HAS_DB
+handlerDb :: Ctx -> Handler World
+#endif
+
+#ifdef DB_BEAM
+handlerDb ctx = liftIO $
+    withConnection ctx $ \conn ->
+    withSMGen ctx $ \gen -> do
+        -- generate random id, first [0, 10000), then 'succ' to [1,10000]
+        let (randomId', _) = SM.bitmaskWithRejection32 10000 gen
+        let randomId :: Int32
+            randomId = succ (fromIntegral randomId')
+
+        ws <- runBeamPostgres conn $ runSelectReturningList $
+            lookup_ (tfbWorld tfbDb) (WorldId randomId)
+
+        case ws of
+            (w:_) -> return w
+            []    -> return $ World 0 0
+#endif
+
+#ifdef DB_PSQL_SIMPLE
+handlerDb ctx = liftIO $
+    withConnection ctx $ \conn ->
+    withSMGen ctx $ \gen -> do
+        -- generate random id, first [0, 10000), then 'succ' to [1,10000]
+        let (randomId', _) = SM.bitmaskWithRejection32 10000 gen
+        let randomId :: Int32
+            randomId = succ (fromIntegral randomId')
+
+        ws <- query conn "SELECT id, randomnumber FROM World where id = ?" (Only randomId)
+
+        case ws of
+            (w:_) -> return w
+            []    -> return $ World 0 0
+#endif
+
+-------------------------------------------------------------------------------
+-- Test 3: Multiple database query
+-------------------------------------------------------------------------------
+
+-------------------------------------------------------------------------------
+-- Test 4: Fortunes
+-------------------------------------------------------------------------------
+
+#ifdef HAS_DB
+
+newtype FortunePage = FortunePage (forall m. Monad m => HtmlT m ())
+
+instance ToHtml FortunePage where
+    toHtml = toHtmlRaw
+    toHtmlRaw (FortunePage h) = h
+
+renderFortunes :: [Fortune] -> FortunePage
+renderFortunes fs = FortunePage $ doctypehtml_ $ do
+    head_ $ title_ "Fortunes"
+    body_ $ table_ $ do
+        tr_ $ do
+            th_ "id"
+            th_ "message"
+        for_ fs' $ \f -> tr_ $ do
+            td_ $ toHtml $ show $ fortuneId f
+            td_ $ toHtml $ fortuneMessage f
+  where
+    fs' = sortOn fortuneMessage $
+        Fortune 0 "Additional fortune added at request time." : fs
+
+
+handlerFortune :: Ctx -> Handler FortunePage
+#endif
+
+#ifdef DB_BEAM
+handlerFortune ctx = liftIO $ withConnection ctx $ \conn -> do
+    fs <- runBeamPostgres conn $ runSelectReturningList $ select $
+        all_ (tfbFortune tfbDb)
+
+    return $ renderFortunes fs
+#endif
+
+#ifdef DB_PSQL_SIMPLE
+handlerFortune ctx = liftIO $ withConnection ctx $ \conn -> do
+    fs <- query_ conn "SELECT id, message FROM Fortune;"
+    return $ renderFortunes fs
+#endif
+
+-------------------------------------------------------------------------------
+-- Test 5: Updates
+-------------------------------------------------------------------------------
+
+-------------------------------------------------------------------------------
+-- Test 6: Plaintext endpoint
+-------------------------------------------------------------------------------
+
+handlerPlaintext :: Handler Text
+handlerPlaintext = return "Hello, World!"
+
+-------------------------------------------------------------------------------
+-- beam
+-------------------------------------------------------------------------------
+
+#ifdef DB_BEAM
+-- | World table.
+data WorldT f = World
+    { worldId           :: Columnar f Int32
+    , worldRandomNumber :: Columnar f Int32
+    }
+  deriving (Generic, Beamable)
+
+instance Table WorldT where
+   data PrimaryKey WorldT f = WorldId (Columnar f Int32) deriving (Generic, Beamable)
+   primaryKey = WorldId . worldId
+
+type World = WorldT Identity
+-- type WorldId = PrimaryKey WorldT Identity
+
+deriving instance Eq World
+deriving instance Show World
+
+-- | Fortune table.
+data FortuneT f = Fortune
+    { fortuneId      :: Columnar f Int32
+    , fortuneMessage :: Columnar f Text
+    }
+  deriving (Generic, Beamable)
+
+instance Table FortuneT where
+   data PrimaryKey FortuneT f = FortuneId (Columnar f Int32) deriving (Generic, Beamable)
+   primaryKey = FortuneId . fortuneId
+
+type Fortune = FortuneT Identity
+-- type FortuneId = PrimaryKey FortuneT Identity
+
+deriving instance Eq Fortune
+deriving instance Show Fortune
+
+-- Database definition.
+data TfbDb f = TfbDb
+    { tfbWorld   :: f (TableEntity WorldT)
+    , tfbFortune :: f (TableEntity FortuneT)
+    }
+ deriving (Generic, Database Postgres)
+
+tfbDb :: DatabaseSettings Postgres TfbDb
+tfbDb = defaultDbSettings `withDbModification` modification where
+    modification = (dbModification :: DatabaseModification (DatabaseEntity Postgres TfbDb) Postgres TfbDb)
+        { tfbWorld = modifyEntityName (\_ -> "World") <> modifyTableFields tableModification
+            { worldId           = "id"
+            , worldRandomNumber = "randomnumber"
+            }
+        , tfbFortune = modifyEntityName (\_ -> "Fortune") <> modifyTableFields tableModification
+            { fortuneId      = "id"
+            , fortuneMessage = "message"
+            }
+        }
+#endif
+
+-------------------------------------------------------------------------------
+-- postgresql-simple
+-------------------------------------------------------------------------------
+
+#ifdef DB_PSQL_SIMPLE
+data World = World
+    { worldId           :: Int32
+    , worldRandomNumber :: Int32
+    }
+  deriving (Eq, Show, Generic, FromRow)
+
+data Fortune = Fortune
+    { fortuneId      :: Int32
+    , fortuneMessage :: Text
+    }
+  deriving (Eq, Show, Generic, FromRow)
+#endif
+
+-------------------------------------------------------------------------------
+-- DB common
+-------------------------------------------------------------------------------
+
+#ifdef HAS_DB
+instance ToJSON World where
+    toEncoding (World i rn) = pairs ("id" .= i <> "randomNumber" .= rn)
+    toJSON     (World i rn) = object ["id" .= i, "randomNumber" .= rn]
+#endif

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

@@ -0,0 +1,15 @@
+{-# LANGUAGE OverloadedStrings     #-}
+
+module Main where
+
+import Control.Concurrent (getNumCapabilities)
+import           System.Environment (lookupEnv)
+
+import qualified Lib
+
+main :: IO ()
+main = do
+  testName <- lookupEnv "TFB_TEST_NAME"
+  putStrLn $ "Test is: " ++ show testName
+  capabilities <- getNumCapabilities
+  Lib.main capabilities

frameworks/Haskell/servant/servant.dockerfile

@@ -0,0 +1,25 @@
+FROM haskell:8.6.5
+
+RUN apt update -yqq && apt install -yqq xz-utils make
+RUN apt install -yqq libpq-dev
+
+WORKDIR /app
+
+# Update cabal here
+RUN cabal update
+
+# First add only
+COPY cabal.project ./
+COPY ./servant-tfb/servant-tfb.cabal ./servant-tfb/servant-tfb.cabal
+RUN find .
+RUN cabal v2-build warp
+RUN cabal v2-build wai-app-static
+RUN cabal v2-build beam-postgres
+RUN cabal v2-build servant-server
+
+ADD ./servant-tfb ./servant-tfb
+RUN cabal v2-build all
+
+RUN cp $(find dist-newstyle -name servant-tfb -type f) /app/dist-newstyle/servant-tfb-exe
+
+CMD /app/dist-newstyle/servant-tfb-exe +RTS -A32m -N$(nproc) -qn2 -M2G -RTS

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

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

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

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

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

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

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

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

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

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

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

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

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

@@ -1,23 +0,0 @@
-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,18 +0,0 @@
-resolver: lts-13.13
-
-packages:
-- ./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.
-allow-different-user: true