Fix warp (#10185)

* Bring warp base back to work.

* Try to fix mysql-haskell, but auth protocol not supported.

* Upgrade ghc to 9.10

* Fix hasql and update stackage snapshot.

* Auto-formatting

---------

Co-authored-by: Benjamin Maurer <[email protected]>

frameworks/Haskell/warp/.gitignore

@@ -0,0 +1 @@
+.stack-work

frameworks/Haskell/warp/benchmark_config.json

@@ -14,16 +14,16 @@
       "database": "Postgres",
       "framework": "Warp",
       "language": "Haskell",
-      "flavor": "GHC683",
+      "flavor": "GHC910",
       "orm": "Raw",
       "platform": "Wai",
       "webserver": "Wai",
       "os": "Linux",
       "database_os": "Linux",
-      "display_name": "Warp+Postgres-wire",
+      "display_name": "Warp+Postgres-simple",
       "notes": "Pure haskell.",
       "dockerfile": "warp-shared.dockerfile",
-      "tags": ["broken"]
+      "tags": []
     },
     "hasql": {
       "json_url": "/json",
@@ -38,7 +38,7 @@
       "database": "Postgres",
       "framework": "Warp",
       "language": "Haskell",
-      "flavor": "GHC683",
+      "flavor": "GHC910",
       "orm": "Raw",
       "platform": "Wai",
       "webserver": "Wai",
@@ -47,7 +47,7 @@
       "display_name": "Warp+Hasql",
       "notes": "Uses libpq system dependency.",
       "dockerfile": "warp-shared.dockerfile",
-      "tags": ["broken"]
+      "tags": []
     },
     "mysql-haskell": {
       "json_url": "/json",
@@ -62,7 +62,7 @@
       "database": "MySQL",
       "framework": "Warp",
       "language": "Haskell",
-      "flavor": "GHC683",
+      "flavor": "GHC910",
       "orm": "Raw",
       "platform": "Wai",
       "webserver": "Wai",

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

@@ -1,74 +1,101 @@
 {-# 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)
+{-# LANGUAGE OverloadedStrings #-}
+
+module TFB.Db
+  ( Pool,
+    mkPool,
+    Config (..),
+    queryWorldById,
+    queryWorldByIds,
+    updateWorlds,
+    queryFortunes,
+    Error,
+  )
+where
+
+import Control.Monad (forM, forM_)
+import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BSC
+import Data.Functor.Contravariant (contramap)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Hasql.Connection.Setting as ConnectionSetting
+import Hasql.Connection.Setting.Connection (params)
+import qualified Hasql.Connection.Setting.Connection.Param as ConnectionParam
+import qualified Hasql.Decoders as HasqlDec
+import qualified Hasql.Encoders as HasqlEnc
+import Hasql.Pool (Pool, UsageError, acquire, use)
+import qualified Hasql.Pool.Config as PoolCfg
+import Hasql.Session (statement)
+import qualified Hasql.Statement as HasqlStatement
+import qualified TFB.Types as Types
 
 -------------------------------------------------------------------------------
+
 -- * Database
 
 data Config
   = Config
-  { configHost      :: String
-  , configName      :: ByteString
-  , configUser      :: ByteString
-  , configPass      :: ByteString
-  , configStripes   :: Int
-  , configPoolSize  :: Int
+  { 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)
-    <> " }"
+  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)
+mkSettings :: Config -> ConnectionSetting.Setting
+mkSettings c =
+  ConnectionSetting.connection $
+    params
+      [ ConnectionParam.host (T.pack $ configHost c),
+        ConnectionParam.port 5432,
+        ConnectionParam.user (TE.decodeUtf8 $ configUser c),
+        ConnectionParam.password (TE.decodeUtf8 $ configPass c),
+        ConnectionParam.dbname (TE.decodeUtf8 $ configName c)
+      ]
 
 mkPool :: Config -> IO Pool
-mkPool c = acquire (configPoolSize c, 0.5, mkSettings c)
+mkPool c =
+  acquire $
+    PoolCfg.settings
+      [ PoolCfg.staticConnectionSettings [mkSettings c],
+        PoolCfg.size (configPoolSize c)
+      ]
+
+qidEnc :: HasqlEnc.Params Types.QId
+qidEnc = contramap fromIntegral (HasqlEnc.param (HasqlEnc.nonNullable HasqlEnc.int4))
 
-intValEnc :: HasqlEnc.Params Types.QId
-intValEnc = contramap fromIntegral $ HasqlEnc.param HasqlEnc.int2
-intValDec :: HasqlDec.Row Types.QId
-intValDec = fmap fromIntegral $ HasqlDec.column HasqlDec.int2
+qidDec :: HasqlDec.Row Types.QId
+qidDec = fromIntegral <$> (HasqlDec.column . HasqlDec.nonNullable) HasqlDec.int4
 
 -------------------------------------------------------------------------------
+
 -- * World
 
 selectSingle :: HasqlStatement.Statement Types.QId Types.World
-selectSingle = HasqlStatement.Statement q intValEnc decoder True
+selectSingle = HasqlStatement.Statement q qidEnc decoder True
   where
-   q = "SELECT * FROM World WHERE (id = $1)"
-   decoder = HasqlDec.singleRow $ Types.World <$> intValDec <*> intValDec
+    q = "SELECT * FROM World WHERE (id = $1)"
+    decoder = HasqlDec.singleRow $ Types.World <$> qidDec <*> qidDec
 
 queryWorldById :: Pool -> Types.QId -> IO (Either Error Types.World)
 queryWorldById pool wId = use pool (statement wId selectSingle)
@@ -79,11 +106,10 @@ 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
+updateSingle = HasqlStatement.Statement q encoder HasqlDec.noResult True
   where
     q = "UPDATE World SET randomNumber = $1 WHERE id = $2"
-    encoder = contramap fst intValEnc <> contramap snd intValEnc
-    decoder = HasqlDec.unit
+    encoder = contramap fst qidEnc <> contramap snd qidEnc
 
 updateWorlds :: Pool -> [(Types.World, Types.QId)] -> IO (Either Error [Types.World])
 updateWorlds _ [] = pure . pure $ mempty
@@ -93,18 +119,19 @@ updateWorlds pool wsUpdates = use pool $ do
     statement (Types.wId w, wNum) updateSingle
   return ws
   where
-    updateW (w,wNum) = w { Types.wRandomNumber = wNum }
+    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
+    q = "SELECT * FROM Fortune"
+    encoder = HasqlEnc.noParams
+    -- TODO: investigate whether 'rowList' is worth the more expensive 'cons'.
+    decoder = HasqlDec.rowList $ Types.Fortune <$> qidDec <*> HasqlDec.column (HasqlDec.nonNullable HasqlDec.text)
 {-# INLINE selectFortunes #-}
 
 queryFortunes :: Pool -> IO (Either Error [Types.Fortune])

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

@@ -15,10 +15,11 @@ library
   default-language:    Haskell2010
   exposed-modules:     TFB.Db
   build-depends:
-      base >= 4.7 && < 5
+      base >= 4.18 && < 5
     , tfb-types
     , bytestring
     , text
-    , hasql >= 0.19
-    , hasql-pool >= 0.4
+    , hasql >= 1.9.3
+    , hasql-pool >= 1.3.0
+    , hasql-th >= 0.4.0
     , contravariant

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

@@ -1,3 +1,6 @@
 # TFB MySQLHaskell
 
 `mysql-haskell` backend for TFB benchmarks that can re-used with any server.
+
+Note: Currently broken, as test server uses `caching_sha2_password` authentication,
+but library mysql-haskell does not support this yet.

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

@@ -1,76 +1,93 @@
-{-# 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
+{-# LANGUAGE OverloadedStrings #-}
+
+module TFB.Db
+  ( Pool,
+    mkPool,
+    Config (..),
+    queryWorldById,
+    queryWorldByIds,
+    updateWorlds,
+    queryFortunes,
+    Error,
+  )
+where
+
+import Control.Monad (forM, forM_)
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as BSC
+import Data.Either qualified as Either
+import Data.Pool qualified as Pool
+import Data.Text (Text)
+import Data.Text qualified as Text
+import Database.MySQL.Base qualified as MySQL
+import System.IO.Streams qualified as Streams
+import TFB.Types qualified as Types
 
 -------------------------------------------------------------------------------
+
 -- * Database
 
 data Config
   = Config
-  { configHost      :: String
-  , configName      :: ByteString
-  , configUser      :: ByteString
-  , configPass      :: ByteString
-  , configStripes   :: Int
-  , configPoolSize  :: Int
+  { 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)
-    <> " }"
+  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
+    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)
+mkPool c =
+  Pool.newPool $
+    Pool.setNumStripes (Just $ configStripes c) $
+      Pool.defaultPoolConfig
+        (connect c)
+        close
+        0.5
+        (configPoolSize c)
 
 {-# SPECIALIZE intValEnc :: Int -> MySQL.MySQLValue #-}
 {-# SPECIALIZE intValEnc :: Types.QId -> MySQL.MySQLValue #-}
-intValEnc :: Integral a => a -> MySQL.MySQLValue
+intValEnc :: (Integral a) => a -> MySQL.MySQLValue
 intValEnc = MySQL.MySQLInt16U . fromIntegral
 
 intValDec :: MySQL.MySQLValue -> Either Text Int
@@ -82,19 +99,20 @@ 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)
+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)
+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
+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
@@ -105,7 +123,7 @@ queryWorldById dbPool wId = Pool.withResource dbPool $ \conn -> do
   return $ case err of
     [] -> case oks of
       [] -> Left "World not found!"
-      ws  -> pure $ head ws
+      w : _ -> pure w
     _ -> Left . mconcat $ err
   where
     s = "SELECT * FROM World WHERE id = ?"
@@ -134,15 +152,16 @@ updateWorlds dbPool wsUpdates = Pool.withResource dbPool $ \conn -> do
   MySQL.closeStmt conn sId
   return . pure $ ws
   where
-    updateW (w,wNum) = w { Types.wRandomNumber = wNum }
+    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
+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
@@ -152,4 +171,4 @@ queryFortunes dbPool = Pool.withResource dbPool $ \conn -> do
   let (err, oks) = Either.partitionEithers eFortunes
   return $ case err of
     [] -> pure oks
-    _ -> Left $ head err
+    w : _ -> Left w

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

@@ -12,10 +12,11 @@ extra-source-files:  README.md
 
 library
   hs-source-dirs:      .
-  default-language:    Haskell2010
+  default-language:    GHC2021
+  ghc-options:         -funbox-strict-fields
   exposed-modules:     TFB.Db
   build-depends:
-      base >= 4.7 && < 5
+      base >= 4.18 && < 5
     , tfb-types
     , bytestring
     , text

frameworks/Haskell/warp/shared/tfb-postgres-simple/README.md

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

frameworks/Haskell/warp/shared/tfb-postgres-simple/TFB/Db.hs

@@ -0,0 +1,155 @@
+{-# OPTIONS -Wno-orphans #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module TFB.Db
+  ( Pool,
+    mkPool,
+    Config (..),
+    queryWorldById,
+    queryWorldByIds,
+    updateWorlds,
+    queryFortunes,
+    Error,
+  )
+where
+
+import Control.Exception (catch, try)
+import Control.Monad (forM)
+import Data.Bifunctor qualified as Bi
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as BSC
+import Data.Either qualified as Either
+import Data.Pool qualified as Pool
+import Database.PostgreSQL.Simple (SomePostgreSqlException)
+import Database.PostgreSQL.Simple qualified as PG
+import Database.PostgreSQL.Simple.FromRow (FromRow (fromRow), field)
+import System.IO.Error qualified as Error
+import TFB.Types qualified as Types
+
+-------------------------------------------------------------------------------
+
+-- * 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)
+      <> " }"
+
+instance FromRow Types.World where
+  fromRow = Types.World <$> field <*> field
+
+instance FromRow Types.Fortune where
+  fromRow = Types.Fortune <$> field <*> field
+
+type Connection = PG.Connection
+
+type Pool = Pool.Pool Connection
+
+data Error
+  = DbError ByteString
+  | DbErrors [ByteString]
+  | NotFound
+  deriving (Show)
+
+connect :: Config -> IO Connection
+connect c = catch (PG.connect pgc) failError
+  where
+    failError :: PG.SomePostgreSqlException -> IO a
+    failError = Error.ioError . Error.userError . show
+    pgc =
+      PG.defaultConnectInfo
+        { PG.connectHost = configHost c,
+          PG.connectDatabase = BSC.unpack $ configName c,
+          PG.connectUser = BSC.unpack $ configUser c,
+          PG.connectPassword = BSC.unpack $ configPass c
+        }
+
+close :: Connection -> IO ()
+close = PG.close
+
+mkPool :: Config -> IO Pool
+mkPool c =
+  Pool.newPool $
+    Pool.setNumStripes (Just $ configStripes c) $
+      Pool.defaultPoolConfig
+        (connect c)
+        close
+        0.5
+        (configPoolSize c)
+
+-------------------------------------------------------------------------------
+
+-- * World
+
+queryWorldByIdInner :: Types.QId -> Connection -> IO (Either Error Types.World)
+queryWorldByIdInner wId conn = do
+  let query = PG.query conn "SELECT * FROM World WHERE id = ?" (PG.Only wId :: PG.Only Types.QId) :: IO [Types.World]
+  res <- try @SomePostgreSqlException query
+  pure $ Either.either (Left . DbError . BSC.pack . show) mkW res
+  where
+    mkW [] = Left NotFound
+    mkW (w : _) = pure w
+
+queryWorldById :: Pool -> Types.QId -> IO (Either Error Types.World)
+queryWorldById dbPool wId = Pool.withResource dbPool (queryWorldByIdInner wId)
+
+queryWorldByIds :: Pool -> [Types.QId] -> IO (Either Error [Types.World])
+queryWorldByIds dbPool wIds = Pool.withResource dbPool $ \conn -> do
+  rows <- forM wIds $ \wId -> queryWorldByIdInner wId conn
+  let (errs, rowsList) = Either.partitionEithers rows
+  return $ case errs of
+    [] -> pure rowsList
+    _ ->
+      Left . DbErrors $
+        map
+          ( \case
+              DbError e -> e
+              _ -> error "Unexpected error"
+          )
+          errs
+
+updateWorlds :: Pool -> [(Types.World, Int)] -> IO (Either Error [Types.World])
+updateWorlds dbPool wsUpdates = Pool.withResource dbPool $ \conn -> do
+  let worlds = Bi.first Types.wId <$> wsUpdates
+  res <-
+    try @SomePostgreSqlException $
+      PG.executeMany
+        conn
+        "UPDATE World SET randomNumber = upd.rnd FROM (VALUES (?,?)) as upd(wid,rnd) WHERE World.id = upd.wid"
+        worlds
+  _ <- case res of
+    Left e -> print e
+    Right _ -> return ()
+  pure $ Bi.bimap (DbError . BSC.pack . show) (const $ map (uncurry Types.World) worlds) res
+
+-------------------------------------------------------------------------------
+
+-- * Fortunes
+
+queryFortunes :: Pool -> IO (Either Error [Types.Fortune])
+queryFortunes dbPool = Pool.withResource dbPool $ \conn -> do
+  let query = PG.query_ conn "SELECT * FROM Fortune" :: IO [Types.Fortune]
+  res <- try @SomePostgreSqlException query
+  pure $ Bi.first (DbError . BSC.pack . show) res

frameworks/Haskell/warp/shared/tfb-postgres-wire/tfb-postgres-wire.cabal → frameworks/Haskell/warp/shared/tfb-postgres-simple/tfb-postgres-simple.cabal

@@ -1,6 +1,6 @@
-name:                tfb-postgres-wire
+name:                tfb-postgres-simple
 version:             0.1.0.0
-homepage:            https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/warp/shared/tfb-postgres-wire
+homepage:            https://github.com/TechEmpower/FrameworkBenchmarks/tree/master/frameworks/Haskell/warp/shared/tfb-postgres-simple
 license:             BSD3
 author:              Naushadh
 maintainer:          [email protected]
@@ -12,13 +12,14 @@ extra-source-files:  README.md
 
 library
   hs-source-dirs:      .
-  default-language:    Haskell2010
+  default-language:    GHC2021
+  ghc-options:         -funbox-strict-fields
   exposed-modules:     TFB.Db
   build-depends:
-      base >= 4.7 && < 5
+      base >= 4.18 && < 5
     , tfb-types
     , resource-pool
-    , postgres-wire
+    , postgresql-simple
     , bytestring
     , vector
     , text

frameworks/Haskell/warp/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/warp/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/warp/shared/tfb-types/TFB/Types.hs

@@ -1,30 +1,24 @@
 {-# OPTIONS -funbox-strict-fields #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE TypeOperators         #-}
-
-module TFB.Types (
-    unsafeJsonString
-  , parseCount
-  , getCount
-  , Count
-  , World(..)
-  , Fortune(..)
-  , FortunesHtml
-  , QId
-) where
-
-import qualified Data.Either as Either
-import qualified Data.Char as Char
+{-# LANGUAGE OverloadedStrings #-}
+
+module TFB.Types
+  ( unsafeJsonString,
+    parseCount,
+    getCount,
+    Count,
+    World (..),
+    Fortune (..),
+    QId,
+  )
+where
 
-import           Data.ByteString (ByteString)
 import qualified Data.Attoparsec.ByteString.Char8 as Parsec
-import qualified Data.BufferBuilder.Utf8 as Utf8
+import Data.BufferBuilder.Json ((.=))
 import qualified Data.BufferBuilder.Json as Json
-import           Data.BufferBuilder.Json ((.=))
-import qualified Html
-import           Html (type (#), type (>))
-import           Data.Text (Text)
+import qualified Data.BufferBuilder.Utf8 as Utf8
+import Data.ByteString (ByteString)
+import qualified Data.Either as Either
+import Data.Text (Text)
 
 -------------------------------------------------------------------------------
 -- * Inputs
@@ -32,65 +26,28 @@ import           Data.Text (Text)
 newtype Count = Count Int
 
 parseCount :: ByteString -> Maybe Count
-parseCount = fmap Count . Either.either (const Nothing) pure . Parsec.parseOnly parseInt
+parseCount = fmap Count . Either.either (const Nothing) pure . Parsec.parseOnly Parsec.decimal
 
 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
+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
+  toJson w =
+    Json.toJson $
+      "id" .= wId w
+        <> "randomNumber" .= wRandomNumber w
 
-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)
-                )
-              ]
-            )
-          )
-        )
-      )
-    )
-  )
+data Fortune = Fortune {fId :: QId, fMessage :: Text}
+  deriving (Show)
 
 unsafeJsonString :: ByteString -> Json.Value
 unsafeJsonString = Json.unsafeValueUtf8Builder . Utf8.appendBS7 . quote

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

@@ -15,9 +15,8 @@ library
   default-language:    Haskell2010
   exposed-modules:     TFB.Types
   build-depends:
-      base >= 4.7 && < 5
+      base >= 4.18 && < 5
     , bytestring
     , attoparsec
     , buffer-builder
-    , type-of-html
     , text

frameworks/Haskell/warp/stack.yaml

@@ -1,18 +1,16 @@
-resolver: lts-13.13
+resolver: lts-24.11
 
 packages:
 - ./shared/tfb-types
 - ./shared/tfb-hasql
 - ./shared/tfb-mysql-haskell
-- ./shared/tfb-postgres-wire
+- ./shared/tfb-postgres-simple
 - ./warp-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
+- buffer-builder-0.2.4.9
+- mysql-haskell-1.1.7
 
 # the following flags are meant for use with warp.dockerfile
-compiler: ghc-8.6.3 # this MUST match the resolver's GHC; minor hack to ensure GHC isn't downloaded into sandbox.
+compiler: ghc-9.10.2 # this MUST match the resolver's GHC; minor hack to ensure GHC isn't downloaded into sandbox.
 allow-different-user: true

frameworks/Haskell/warp/stack.yaml.lock

@@ -0,0 +1,26 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/topics/lock_files
+
+packages:
+- completed:
+    hackage: buffer-builder-0.2.4.9@sha256:22600bcca6b8657865d1dce07cfa791767bdb6241c0cd5cadd6444678bf9a8a7,5257
+    pantry-tree:
+      sha256: f5eddef2db3cd6e0c2e2199a5a59cae0329b057045aa67705492d069f9e204f0
+      size: 1155
+  original:
+    hackage: buffer-builder-0.2.4.9
+- completed:
+    hackage: mysql-haskell-1.1.7@sha256:e1fc81c03063a50a169464e9983466249339c718b28012e2b69cd58e7c18487c,5498
+    pantry-tree:
+      sha256: 8720dcd88265638550d96b2ef560fafd1b708bcf196a1c3add5f98c82d014711
+      size: 4968
+  original:
+    hackage: mysql-haskell-1.1.7
+snapshots:
+- completed:
+    sha256: 468e1afa06cd069e57554f10e84fdf1ac5e8893e3eefc503ef837e2449f7e60c
+    size: 726310
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/11.yaml
+  original: lts-24.11

frameworks/Haskell/warp/warp-shared.dockerfile

@@ -1,7 +1,11 @@
-FROM haskell:8.6.3
+FROM haskell:9.10-slim-bullseye
 
-RUN apt-get update -yqq && apt-get install -yqq xz-utils make
-RUN apt-get install -yqq libpq-dev
+RUN apt-get update -yqq && apt-get install -yqq xz-utils make curl ca-certificates
+RUN install -d /usr/share/postgresql-common/pgdg
+RUN curl -o /usr/share/postgresql-common/pgdg/apt.postgresql.org.asc --fail https://www.postgresql.org/media/keys/ACCC4CF8.asc
+RUN . /etc/os-release
+RUN sh -c "echo 'deb [signed-by=/usr/share/postgresql-common/pgdg/apt.postgresql.org.asc] https://apt.postgresql.org/pub/repos/apt bullseye-pgdg main' > /etc/apt/sources.list.d/pgdg.list"
+RUN apt-get update && apt-get install -yqq libpq-dev
 
 WORKDIR /app
 
@@ -9,7 +13,7 @@ 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 ./shared/tfb-postgres-simple/tfb-postgres-simple.cabal ./shared/tfb-postgres-simple/
 COPY ./warp-shared/warp-shared.cabal ./warp-shared/
 RUN stack setup
 RUN stack install --dependencies-only
@@ -17,7 +21,7 @@ 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
+RUN ln -s ~/.local/bin/warp-postgres-simple ~/.local/bin/warp
 
 ARG TFB_TEST_NAME
 ENV TFB_TEST_NAME=${TFB_TEST_NAME}

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

@@ -4,4 +4,4 @@ This is a generic test that produces an executable for each supported backend li
 
 - `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.
+- `warp-postgres-simple` (default): PostgreSQL database via the [`postgres-simple`](https://github.com/postgres-haskell/postgres-simple) library.

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

@@ -1,27 +1,27 @@
-{-# LANGUAGE OverloadedStrings     #-}
-
-module Lib (
-    main
-  , Db.Config(..)
-) where
-
-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)
-
-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 ((#))
+{-# LANGUAGE OverloadedStrings #-}
+
+module Lib
+  ( main,
+    Db.Config (..),
+  )
+where
+
+import Control.Monad (join, replicateM)
+import Data.BufferBuilder.Json ((.=))
+import Data.BufferBuilder.Json qualified as Json
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy.Char8 qualified as LBSC
+import Data.Either qualified as Either
+import Data.List (sortOn)
+import Network.HTTP.Types.Header qualified as Header
+import Network.HTTP.Types.Status qualified as Status
+import Network.Wai qualified as Wai
+import Network.Wai.Handler.Warp qualified as Warp
+import System.Random.MWC qualified as MWC
+import TFB.Db qualified as Db
+import TFB.Types qualified as Types
+import Text.Blaze.Html.Renderer.Utf8 qualified as Html
+import Text.Blaze.Html5 qualified as Html
 
 -- entry point
 main :: Db.Config -> IO ()
@@ -41,18 +41,18 @@ 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", ["fortunes"])
-      -> respond =<< getFortunes dbPool
-    ("GET", ["queries"])
-      -> respond =<< getWorlds gen dbPool mCount
-    ("GET", ["updates"])
-      -> respond =<< updateWorlds gen dbPool mCount
+    ("GET", ["plaintext"]) ->
+      respond getPlaintext
+    ("GET", ["json"]) ->
+      respond getJson
+    ("GET", ["db"]) ->
+      respond =<< getWorld gen dbPool
+    ("GET", ["fortunes"]) ->
+      respond =<< getFortunes dbPool
+    ("GET", ["queries"]) ->
+      respond =<< getWorlds gen dbPool mCount
+    ("GET", ["updates"]) ->
+      respond =<< updateWorlds gen dbPool mCount
     _ -> respond routeNotFound
 
 -- * response helpers
@@ -68,7 +68,7 @@ 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 :: (Json.ToJson a) => a -> Wai.Response
 respondJson = Wai.responseLBS Status.status200 contentJson . mkBs
   where
     mkBs = LBS.fromStrict . Json.encodeJson
@@ -76,8 +76,8 @@ respondJson = Wai.responseLBS Status.status200 contentJson . mkBs
 contentHtml :: Header.ResponseHeaders
 contentHtml = [(Header.hContentType, "text/html; charset=UTF-8")]
 
-respondHtml :: Types.FortunesHtml -> Wai.Response
-respondHtml = Wai.responseLBS Status.status200 contentHtml . Html.renderByteString
+respondHtml :: Html.Html -> Wai.Response
+respondHtml = Wai.responseBuilder Status.status200 contentHtml . Html.renderHtmlBuilder
 
 -- * error responses
 
@@ -138,20 +138,22 @@ getFortunes dbPool = do
   res <- Db.queryFortunes dbPool
   return $ case res of
     Left e -> respondDbError e
-    Right fs -> respondHtml $ do
+    Right fs ->
       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
-          )
-        )
+          header = Html.tr $ do
+            Html.th $ Html.preEscapedToHtml ("id" :: String)
+            Html.th $ Html.preEscapedToHtml ("message" :: String)
+          mkRow f = Html.tr $ do
+            Html.td $ Html.toHtml ((fromIntegral $ Types.fId f) :: Int)
+            Html.td $ Html.toHtml (Types.fMessage f)
+          rows = (mkRow <$> sortOn Types.fMessage (new : fs))
+       in respondHtml $ Html.docTypeHtml $ do
+            Html.head $ do
+              Html.title $ Html.preEscapedToHtml ("Fortunes" :: String)
+            Html.body $ do
+              Html.table $ do
+                header
+                sequence_ rows
 {-# INLINE getFortunes #-}
 
 randomId :: MWC.GenIO -> IO Types.QId

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

@@ -1,10 +1,10 @@
-{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Main where
 
-import qualified Lib
-import qualified GHC.Conc
-import           System.Environment (getArgs, lookupEnv)
+import GHC.Conc qualified
+import Lib qualified
+import System.Environment (getArgs, lookupEnv)
 
 main :: IO ()
 main = do
@@ -15,11 +15,12 @@ main = do
     [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
-  }
+  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-shared/warp-shared.cabal

@@ -1,4 +1,4 @@
-cabal-version:       2.4
+cabal-version:       3.8
 -- `cabal-version` MUST match the version bundled with stack.
 -- run `stack exec -- cabal --version` to find out
 name:                warp-shared
@@ -15,15 +15,15 @@ extra-source-files:  README.md
 common deps
   hs-source-dirs:      src
   other-modules:       Lib
-  default-language:    Haskell2010
+  default-language:    GHC2021
   ghc-options:         -Wall -threaded -rtsopts -O2 -funbox-strict-fields
   build-depends:
-      base >= 4.7 && < 5
+      base >= 4.18 && < 5
     , bytestring
     , text
     , attoparsec
     , buffer-builder
-    , type-of-html
+    , blaze-html
     , mwc-random
     , wai
     , warp
@@ -45,10 +45,10 @@ executable warp-mysql-haskell
       tfb-types
     , tfb-mysql-haskell
 
-executable warp-postgres-wire
+executable warp-postgres-simple
   import: deps
   main-is:
     Main.hs
   build-depends:
       tfb-types
-    , tfb-postgres-wire
+    , tfb-postgres-simple