Restructure Haskell/Warp for db modularity. (#4595)

* Restructure warp for db modularity.

- Haskell/Warp dir has a lot of code duplication for testing various backend libraries as separate backend specific libraries.
- Refactored the project structure to move database specific modules into their own libraries so we can have a single/shared backend agnostic warp project. This makes it easier to add new backends with minimal effort.

* Complete restructuring warp for code re-use.

This completes the code changes and docs following the earlier pure file moves (separate commit to preserve git history).

- Added `warp-shared` cabal file with mutliple executables using various backend drivers and the same shared server code.
- Updated stack.yaml to adopt the earlier directory layout changes. We now have backend specific libraries (`shared/tfb-*`) and a single re-usable server (`warp-shared`) lib.
- Updated docker file to build and install the new warp shared server -- the cabal file is responsible for producing backend specific executables that match `TFB_TEST_NAME`.
- Added ReadMes for each `shared/tfb-*` library.
- Updated `shared/tfb-types` to adopt to conform to uniform types that can play nice with all of the `shared/tfb-*` backends.
- Updated `shared/tfb-*` cabal files to adopt its new dir and concern of only being a backend driver.
- Updated `shared/tfb-*` `Db.hs` files to conform to the exact same public API so `warp-shared` can plug and play into any database driver without any custom code.
- Added ReadMe for `warp-shared` to document the executables/tests it produces.
- Updated `warp-shared` Lib to delegate connection pool management to `shared/tfb-*` backends as some use their own pools and others require use of `resource-pool` lib.
- Updated `warp-shared` Main to print test name so we can manually sanity check the right executable is running in the right TFB docker image.

frameworks/Haskell/warp/benchmark_config.json

@@ -22,7 +22,7 @@
       "database_os": "Linux",
       "display_name": "Warp+Postgres-wire",
       "notes": "Pure haskell.",
-      "dockerfile": "warp.dockerfile"
+      "dockerfile": "warp-shared.dockerfile"
     },
     "hasql": {
       "json_url": "/json",
@@ -45,7 +45,7 @@
       "database_os": "Linux",
       "display_name": "Warp+Hasql",
       "notes": "Uses libpq system dependency.",
-      "dockerfile": "warp.dockerfile"
+      "dockerfile": "warp-shared.dockerfile"
     },
     "mysql-haskell": {
       "json_url": "/json",
@@ -68,7 +68,7 @@
       "database_os": "Linux",
       "display_name": "Warp+mysql-haskell",
       "notes": "Pure Haskell.",
-      "dockerfile": "warp.dockerfile"
+      "dockerfile": "warp-shared.dockerfile"
     }
   }]
 }

frameworks/Haskell/warp/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/warp/warp-hasql/src/Lib/Db.hs → frameworks/Haskell/warp/shared/tfb-hasql/TFB/Db.hs

@@ -1,6 +1,7 @@
+{-# OPTIONS -funbox-strict-fields #-}
 {-# LANGUAGE OverloadedStrings     #-}
 
-module Lib.Db (
+module TFB.Db (
     Pool
   , mkPool
   , Config(..)
@@ -11,7 +12,7 @@ module Lib.Db (
   , Error
 ) where
 
-import qualified Lib.Types as Types
+import qualified TFB.Types as Types
 import           Control.Monad (forM, forM_)
 
 import qualified Hasql.Decoders             as HasqlDec
@@ -56,9 +57,9 @@ mkPool :: Config -> IO Pool
 mkPool c = acquire (configPoolSize c, 0.5, mkSettings c)
 
 intValEnc :: HasqlEnc.Params Types.QId
-intValEnc = HasqlEnc.param HasqlEnc.int2
+intValEnc = contramap fromIntegral $ HasqlEnc.param HasqlEnc.int2
 intValDec :: HasqlDec.Row Types.QId
-intValDec = HasqlDec.column HasqlDec.int2
+intValDec = fmap fromIntegral $ HasqlDec.column HasqlDec.int2
 
 -------------------------------------------------------------------------------
 -- * World

frameworks/Haskell/warp/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/warp/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/warp/warp-mysql-haskell/src/Lib/Db.hs → frameworks/Haskell/warp/shared/tfb-mysql-haskell/TFB/Db.hs

@@ -1,6 +1,7 @@
+{-# OPTIONS -funbox-strict-fields #-}
 {-# LANGUAGE OverloadedStrings     #-}
 
-module Lib.Db (
+module TFB.Db (
     Pool
   , mkPool
   , Config(..)
@@ -11,7 +12,7 @@ module Lib.Db (
   , Error
 ) where
 
-import qualified Lib.Types as Types
+import qualified TFB.Types as Types
 import qualified Data.Either as Either
 import           Control.Monad (forM, forM_)
 
@@ -95,21 +96,23 @@ decodeWorld [] = Left "MarshalError: Expected 2 columns for World, found 0"
 decodeWorld (_:[]) = Left "MarshalError: Expected 2 columns for World, found 1"
 decodeWorld (c1:c2:_) = Types.World <$> intValDec c1 <*> intValDec c2
 
-queryWorldById :: Connection -> Types.QId -> IO (Either Error [Types.World])
-queryWorldById conn wId = do
+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
-    [] -> pure oks
-    _ -> Left . head $ err
+    [] -> case oks of
+      [] -> Left "World not found!"
+      ws  -> pure $ head ws
+    _ -> Left . mconcat $ err
   where
     s = "SELECT * FROM World WHERE id = ?"
 
-queryWorldByIds :: Connection -> [Types.QId] -> IO (Either [Error] [Types.World])
+queryWorldByIds :: Pool -> [Types.QId] -> IO (Either Error [Types.World])
 queryWorldByIds _ [] = pure . pure $ mempty
-queryWorldByIds conn wIds = do
+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]
@@ -119,11 +122,11 @@ queryWorldByIds conn wIds = do
   let (errs, ws) = Either.partitionEithers . mconcat $ res
   return $ case errs of
     [] -> pure ws
-    _ -> Left errs
+    _ -> Left . mconcat $ errs
 
-updateWorlds :: Connection -> [(Types.World, Int)] -> IO (Either [Error] [Types.World])
+updateWorlds :: Pool -> [(Types.World, Int)] -> IO (Either Error [Types.World])
 updateWorlds _ [] = pure . pure $ mempty
-updateWorlds conn wsUpdates = do
+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) ->
@@ -141,12 +144,12 @@ decodeFortune [] = Left "MarshalError: Expected 2 columns for Fortune, found 0"
 decodeFortune (_:[]) = Left "MarshalError: Expected 2 columns for Fortune, found 1"
 decodeFortune (c1:c2:_) = Types.Fortune <$> intValDec c1 <*> textValDec c2
 
-queryFortunes :: Connection -> IO (Either [Error] [Types.Fortune])
-queryFortunes conn = do
+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 err
+    _ -> Left $ head err

frameworks/Haskell/warp/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/warp/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/warp/warp-postgres-wire/src/Lib/Db.hs → frameworks/Haskell/warp/shared/tfb-postgres-wire/TFB/Db.hs

@@ -1,6 +1,7 @@
+{-# OPTIONS -funbox-strict-fields #-}
 {-# LANGUAGE OverloadedStrings     #-}
 
-module Lib.Db (
+module TFB.Db (
     Pool
   , mkPool
   , Config(..)
@@ -11,7 +12,7 @@ module Lib.Db (
   , Error
 ) where
 
-import qualified Lib.Types as Types
+import qualified TFB.Types as Types
 import qualified Data.Either as Either
 import qualified System.IO.Error as Error
 import           Control.Monad (replicateM, forM)
@@ -56,7 +57,11 @@ instance Show Config where
 
 type Connection = PG.Connection
 type Pool = Pool.Pool Connection
-type Error = PG.Error
+data Error
+  = DbError PG.Error
+  | DbErrors [PG.Error]
+  | NotFound
+  deriving Show
 
 connect :: Config -> IO Connection
 connect c = simplifyError =<< PG.connect pgc
@@ -107,15 +112,19 @@ decodeWorld = PGCD.dataRowHeader *> decoder
         <$> decodeInt
         <*> decodeInt
 
-queryWorldById :: Connection -> Types.QId -> IO (Either Error (V.Vector Types.World))
-queryWorldById conn wId = runQuery conn decodeWorld q
+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 :: Connection -> [Types.QId] -> IO (Either [Error] [Types.World])
+queryWorldByIds :: Pool -> [Types.QId] -> IO (Either Error [Types.World])
 queryWorldByIds _ [] = pure . pure $ mempty
-queryWorldByIds conn wIds = do
+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
@@ -125,11 +134,11 @@ queryWorldByIds conn wIds = do
   let (errs, rowsList) = Either.partitionEithers eRowsMany
   return $ case errs of
     [] -> pure . mconcat $ fmap (V.toList . PGD.decodeManyRows decodeWorld) rowsList
-    _ -> Left errs
+    _ -> Left . DbErrors $ errs
 
-updateWorlds :: Connection -> [(Types.World, Int)] -> IO (Either [Error] [Types.World])
+updateWorlds :: Pool -> [(Types.World, Int)] -> IO (Either Error [Types.World])
 updateWorlds _ [] = pure . pure $ mempty
-updateWorlds conn wsUpdates = do
+updateWorlds dbPool wsUpdates = Pool.withResource dbPool $ \conn -> do
   let ws = fmap updateW wsUpdates
   let qs = fmap mkQ ws
   eRowsMany <- forM qs $ \q -> do
@@ -140,7 +149,7 @@ updateWorlds conn wsUpdates = do
   let (errs, _) = Either.partitionEithers eRowsMany
   return $ case errs of
     [] -> pure ws
-    _ -> Left errs
+    _ -> Left . DbErrors $ errs
   where
     s = "UPDATE World SET randomNumber = $1 WHERE id = $2"
     updateW (w,wNum) = w { Types.wRandomNumber = wNum }
@@ -156,8 +165,10 @@ decodeFortune = PGCD.dataRowHeader *> decoder
         <$> decodeInt
         <*> decodeText
 
-queryFortunes :: Connection -> IO (Either Error (V.Vector Types.Fortune))
-queryFortunes conn = runQuery conn decodeFortune q
+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/warp/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/warp/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/warp/warp-hasql/src/Lib/Types.hs → frameworks/Haskell/warp/shared/tfb-types/TFB/Types.hs

@@ -1,8 +1,9 @@
+{-# OPTIONS -funbox-strict-fields #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE TypeOperators         #-}
 
-module Lib.Types (
+module TFB.Types (
     unsafeJsonString
   , parseCount
   , getCount
@@ -15,7 +16,6 @@ module Lib.Types (
 
 import qualified Data.Either as Either
 import qualified Data.Char as Char
-import           Data.Int (Int16)
 
 import           Data.ByteString (ByteString)
 import qualified Data.Attoparsec.ByteString.Char8 as Parsec
@@ -51,7 +51,7 @@ parseIntDigit = digit
     digit = Parsec.satisfy isDigit
     isDigit c = c >= '0' && c <= '9'
 
-type QId = Int16
+type QId = Int
 
 -------------------------------------------------------------------------------
 -- * Outputs
@@ -62,8 +62,8 @@ data World = World { wId :: QId , wRandomNumber :: QId }
 instance Json.ToJson World where
   toJson w
     = Json.toJson
-    $ "id"           .= (fromIntegral $ wId w :: Int)
-   <> "randomNumber" .= (fromIntegral $ wRandomNumber w :: Int)
+    $ "id"           .= wId w
+   <> "randomNumber" .= wRandomNumber w
 
 data Fortune = Fortune { fId :: QId , fMessage :: Text }
   deriving Show
@@ -81,7 +81,7 @@ type FortunesHtml
                 )
               )
             # ['Html.Tr
-              > ( ('Html.Td > Int)
+              > ( ('Html.Td > QId)
                 # ('Html.Td > Text)
                 )
               ]

frameworks/Haskell/warp/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/warp/stack.yaml

@@ -1,9 +1,11 @@
 resolver: lts-13.13
 
 packages:
-- ./warp-hasql
-- ./warp-postgres-wire
-- ./warp-mysql-haskell
+- ./shared/tfb-types
+- ./shared/tfb-hasql
+- ./shared/tfb-mysql-haskell
+- ./shared/tfb-postgres-wire
+- ./warp-shared
 
 extra-deps:
 - socket-0.8.2.0

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

frameworks/Haskell/warp/warp-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 ./warp-shared/warp-shared.cabal ./warp-shared/
+RUN stack setup
+RUN stack install --dependencies-only
+
+ADD ./shared ./shared
+ADD ./warp-shared ./warp-shared
+RUN stack build --pedantic --copy-bins
+RUN ln -s ~/.local/bin/warp-postgres-wire ~/.local/bin/warp
+
+ARG TFB_TEST_NAME
+ENV TFB_TEST_NAME=${TFB_TEST_NAME}
+CMD stack exec $TFB_TEST_NAME -- tfb-database +RTS -A32m -N$(nproc)

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

@@ -0,0 +1,7 @@
+# Warp Shared
+
+This is a generic test that produces an executable for each supported backend library:
+
+- `warp-hasql`: PostgreSQL database via the [`hasql`](https://github.com/nikita-volkov/hasql) library.
+- `warp-mysql-haskell`: MySQL database via the [`mysql-haskell`](https://github.com/winterland1989/mysql-haskell) library.
+- `warp-postgres-wire` (default): PostgreSQL database via the [`postgres-wire`](https://github.com/postgres-haskell/postgres-wire) library.

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

@@ -5,8 +5,8 @@ module Lib (
   , Db.Config(..)
 ) where
 
-import qualified Lib.Types as Types
-import qualified Lib.Db as Db
+import qualified TFB.Types as Types
+import qualified TFB.Db as Db
 import qualified Data.Either as Either
 import           Data.List (sortOn)
 import           Control.Monad (replicateM, join)
@@ -32,7 +32,7 @@ main dbConfig = do
   dbPool <- Db.mkPool dbConfig
   putStrLn "Initializing PRNG seed..."
   gen <- MWC.create
-  putStrLn "Warp core online: using hasql"
+  putStrLn "Warp core online"
   Warp.run 7041 $ app gen dbPool
 
 -- router

frameworks/Haskell/warp/warp-hasql/exe/Main.hs → frameworks/Haskell/warp/warp-shared/src/Main.hs

@@ -4,15 +4,16 @@ module Main where
 
 import qualified Lib
 import qualified GHC.Conc
-import           System.Environment (getArgs)
+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"
-    -- _ -> fail "Usage: warp-postgres-wire <DATABASE_HOST>"
   numCaps <- GHC.Conc.getNumCapabilities
   Lib.main $ Lib.Config {
     Lib.configHost    = dbHost,

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

@@ -1,42 +1,54 @@
-name:                warp-mysql-haskell
+cabal-version:       2.4
+-- `cabal-version` MUST match the version bundled with stack.
+-- run `stack exec -- cabal --version` to find out
+name:                warp-shared
 version:             0.1.0.0
-homepage:            https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/warp/warp-mysql-haskell
-license:             BSD3
+homepage:            https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/warp/warp-shared
+license:             BSD-3-Clause
 author:              Naushadh
 maintainer:          [email protected]
 copyright:           2019 Naushadh
 category:            Web
 build-type:          Simple
-cabal-version:       >=1.10
 extra-source-files:  README.md
 
-library
+common deps
   hs-source-dirs:      src
+  other-modules:       Lib
   default-language:    Haskell2010
-  exposed-modules:     Lib
-  other-modules:
-      Lib.Db
-    , Lib.Types
+  ghc-options:         -Wall -threaded -rtsopts -O2 -funbox-strict-fields
   build-depends:
       base >= 4.7 && < 5
     , bytestring
+    , text
     , attoparsec
     , buffer-builder
-    , mwc-random
     , type-of-html
+    , mwc-random
     , wai
     , warp
     , http-types
-    , mysql-haskell
-    , resource-pool
-    , io-streams
-    , text
+
+executable warp-hasql
+  import: deps
+  main-is:
+    Main.hs
+  build-depends:
+      tfb-types
+    , tfb-hasql
 
 executable warp-mysql-haskell
-  hs-source-dirs:      exe
-  main-is:             Main.hs
-  default-language:    Haskell2010
-  ghc-options:         -Wall -threaded -rtsopts -O2 -funbox-strict-fields
+  import: deps
+  main-is:
+    Main.hs
   build-depends:
-      base >= 4.7 && < 5
-    , warp-mysql-haskell
+      tfb-types
+    , tfb-mysql-haskell
+
+executable warp-postgres-wire
+  import: deps
+  main-is:
+    Main.hs
+  build-depends:
+      tfb-types
+    , tfb-postgres-wire

frameworks/Haskell/warp/warp.dockerfile

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