diff --git a/frameworks/Haskell/warp/.gitignore b/frameworks/Haskell/warp/.gitignore new file mode 100644 index 00000000000..c1d9b4c9b89 --- /dev/null +++ b/frameworks/Haskell/warp/.gitignore @@ -0,0 +1 @@ +.stack-work \ No newline at end of file diff --git a/frameworks/Haskell/warp/benchmark_config.json b/frameworks/Haskell/warp/benchmark_config.json index 686d95a1758..e96726ac64d 100644 --- a/frameworks/Haskell/warp/benchmark_config.json +++ b/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", diff --git a/frameworks/Haskell/warp/shared/tfb-hasql/TFB/Db.hs b/frameworks/Haskell/warp/shared/tfb-hasql/TFB/Db.hs index 8dcca736120..435d35e8f79 100644 --- a/frameworks/Haskell/warp/shared/tfb-hasql/TFB/Db.hs +++ b/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]) diff --git a/frameworks/Haskell/warp/shared/tfb-hasql/tfb-hasql.cabal b/frameworks/Haskell/warp/shared/tfb-hasql/tfb-hasql.cabal index 77e0b24cd9a..b9524dc33c3 100644 --- a/frameworks/Haskell/warp/shared/tfb-hasql/tfb-hasql.cabal +++ b/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 diff --git a/frameworks/Haskell/warp/shared/tfb-mysql-haskell/README.md b/frameworks/Haskell/warp/shared/tfb-mysql-haskell/README.md index 8c156e8b795..f506958767d 100644 --- a/frameworks/Haskell/warp/shared/tfb-mysql-haskell/README.md +++ b/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. diff --git a/frameworks/Haskell/warp/shared/tfb-mysql-haskell/TFB/Db.hs b/frameworks/Haskell/warp/shared/tfb-mysql-haskell/TFB/Db.hs index 057d0986911..2aa6e8d637d 100644 --- a/frameworks/Haskell/warp/shared/tfb-mysql-haskell/TFB/Db.hs +++ b/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 diff --git a/frameworks/Haskell/warp/shared/tfb-mysql-haskell/tfb-mysql-haskell.cabal b/frameworks/Haskell/warp/shared/tfb-mysql-haskell/tfb-mysql-haskell.cabal index 637c615e498..f1c17cf7ba8 100644 --- a/frameworks/Haskell/warp/shared/tfb-mysql-haskell/tfb-mysql-haskell.cabal +++ b/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 diff --git a/frameworks/Haskell/warp/shared/tfb-postgres-simple/README.md b/frameworks/Haskell/warp/shared/tfb-postgres-simple/README.md new file mode 100644 index 00000000000..e558b2ae6f0 --- /dev/null +++ b/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. diff --git a/frameworks/Haskell/warp/shared/tfb-postgres-simple/TFB/Db.hs b/frameworks/Haskell/warp/shared/tfb-postgres-simple/TFB/Db.hs new file mode 100644 index 00000000000..3b1ed8e52f5 --- /dev/null +++ b/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 diff --git a/frameworks/Haskell/warp/shared/tfb-postgres-wire/tfb-postgres-wire.cabal b/frameworks/Haskell/warp/shared/tfb-postgres-simple/tfb-postgres-simple.cabal similarity index 76% rename from frameworks/Haskell/warp/shared/tfb-postgres-wire/tfb-postgres-wire.cabal rename to frameworks/Haskell/warp/shared/tfb-postgres-simple/tfb-postgres-simple.cabal index ac031c383ab..53e42d1c36d 100644 --- a/frameworks/Haskell/warp/shared/tfb-postgres-wire/tfb-postgres-wire.cabal +++ b/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: naushadh@protonmail.com @@ -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 diff --git a/frameworks/Haskell/warp/shared/tfb-postgres-wire/README.md b/frameworks/Haskell/warp/shared/tfb-postgres-wire/README.md deleted file mode 100644 index 070d34f71a9..00000000000 --- a/frameworks/Haskell/warp/shared/tfb-postgres-wire/README.md +++ /dev/null @@ -1,3 +0,0 @@ -# TFB PostgresWire - -`postgres-wire` backend for TFB benchmarks that can re-used with any server. diff --git a/frameworks/Haskell/warp/shared/tfb-postgres-wire/TFB/Db.hs b/frameworks/Haskell/warp/shared/tfb-postgres-wire/TFB/Db.hs deleted file mode 100644 index 00d35a9aa75..00000000000 --- a/frameworks/Haskell/warp/shared/tfb-postgres-wire/TFB/Db.hs +++ /dev/null @@ -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) diff --git a/frameworks/Haskell/warp/shared/tfb-types/TFB/Types.hs b/frameworks/Haskell/warp/shared/tfb-types/TFB/Types.hs index 0d0718e7b37..e0f0cd55319 100644 --- a/frameworks/Haskell/warp/shared/tfb-types/TFB/Types.hs +++ b/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 diff --git a/frameworks/Haskell/warp/shared/tfb-types/tfb-types.cabal b/frameworks/Haskell/warp/shared/tfb-types/tfb-types.cabal index 250ed43cf8e..3fc2c9446f9 100644 --- a/frameworks/Haskell/warp/shared/tfb-types/tfb-types.cabal +++ b/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 diff --git a/frameworks/Haskell/warp/stack.yaml b/frameworks/Haskell/warp/stack.yaml index ff09c250201..7df4cd85668 100644 --- a/frameworks/Haskell/warp/stack.yaml +++ b/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 diff --git a/frameworks/Haskell/warp/stack.yaml.lock b/frameworks/Haskell/warp/stack.yaml.lock new file mode 100644 index 00000000000..16819ffff37 --- /dev/null +++ b/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 diff --git a/frameworks/Haskell/warp/warp-shared.dockerfile b/frameworks/Haskell/warp/warp-shared.dockerfile index 9c8091768d9..635674f2f46 100644 --- a/frameworks/Haskell/warp/warp-shared.dockerfile +++ b/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} diff --git a/frameworks/Haskell/warp/warp-shared/README.md b/frameworks/Haskell/warp/warp-shared/README.md index 49bf57aef21..cc08a916e62 100644 --- a/frameworks/Haskell/warp/warp-shared/README.md +++ b/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. diff --git a/frameworks/Haskell/warp/warp-shared/src/Lib.hs b/frameworks/Haskell/warp/warp-shared/src/Lib.hs index 3b419a88eaa..210db9b25ab 100644 --- a/frameworks/Haskell/warp/warp-shared/src/Lib.hs +++ b/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 diff --git a/frameworks/Haskell/warp/warp-shared/src/Main.hs b/frameworks/Haskell/warp/warp-shared/src/Main.hs index 654e19ac5da..4f85fa6e5de 100644 --- a/frameworks/Haskell/warp/warp-shared/src/Main.hs +++ b/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 + } diff --git a/frameworks/Haskell/warp/warp-shared/warp-shared.cabal b/frameworks/Haskell/warp/warp-shared/warp-shared.cabal index 75d6a72ff5d..bc7bf933d48 100644 --- a/frameworks/Haskell/warp/warp-shared/warp-shared.cabal +++ b/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