Fix warp

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.