From f5e19a05977703cdf4e6ff3350d884ab90e0cc1e Mon Sep 17 00:00:00 2001 From: Benjamin Maurer Date: Fri, 5 Sep 2025 15:45:54 +0200 Subject: [PATCH 1/5] Bring warp base back to work. --- frameworks/Haskell/warp/.gitignore | 1 + frameworks/Haskell/warp/benchmark_config.json | 10 +- .../warp/shared/tfb-postgres-simple/README.md | 3 + .../warp/shared/tfb-postgres-simple/TFB/Db.hs | 155 ++++++++++++++++ .../tfb-postgres-simple.cabal} | 6 +- .../warp/shared/tfb-postgres-wire/README.md | 3 - .../warp/shared/tfb-postgres-wire/TFB/Db.hs | 174 ------------------ .../warp/shared/tfb-types/TFB/Types.hs | 95 +++------- .../warp/shared/tfb-types/tfb-types.cabal | 1 - frameworks/Haskell/warp/stack.yaml | 16 +- frameworks/Haskell/warp/stack.yaml.lock | 26 +++ .../Haskell/warp/warp-shared.dockerfile | 6 +- frameworks/Haskell/warp/warp-shared/README.md | 2 +- .../Haskell/warp/warp-shared/src/Lib.hs | 91 ++++----- .../Haskell/warp/warp-shared/src/Main.hs | 23 +-- .../warp/warp-shared/warp-shared.cabal | 36 ++-- 16 files changed, 307 insertions(+), 341 deletions(-) create mode 100644 frameworks/Haskell/warp/.gitignore create mode 100644 frameworks/Haskell/warp/shared/tfb-postgres-simple/README.md create mode 100644 frameworks/Haskell/warp/shared/tfb-postgres-simple/TFB/Db.hs rename frameworks/Haskell/warp/shared/{tfb-postgres-wire/tfb-postgres-wire.cabal => tfb-postgres-simple/tfb-postgres-simple.cabal} (89%) delete mode 100644 frameworks/Haskell/warp/shared/tfb-postgres-wire/README.md delete mode 100644 frameworks/Haskell/warp/shared/tfb-postgres-wire/TFB/Db.hs create mode 100644 frameworks/Haskell/warp/stack.yaml.lock 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..01c269b97f6 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": "GHC967", "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": "GHC967", "orm": "Raw", "platform": "Wai", "webserver": "Wai", @@ -62,7 +62,7 @@ "database": "MySQL", "framework": "Warp", "language": "Haskell", - "flavor": "GHC683", + "flavor": "GHC967", "orm": "Raw", "platform": "Wai", "webserver": "Wai", 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..f69be752f1d --- /dev/null +++ b/frameworks/Haskell/warp/shared/tfb-postgres-simple/TFB/Db.hs @@ -0,0 +1,155 @@ +{-# OPTIONS -funbox-strict-fields #-} +{-# OPTIONS -Wno-orphans #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module TFB.Db + ( Pool, + mkPool, + Config (..), + queryWorldById, + queryWorldByIds, + updateWorlds, + queryFortunes, + Error, + ) +where + +import Control.Exception (catch, try) +import Control.Monad (forM) +import qualified Data.Bifunctor as Bi +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Either as Either +import qualified Data.Pool as Pool +import Database.PostgreSQL.Simple (SomePostgreSqlException) +import qualified Database.PostgreSQL.Simple as PG +import Database.PostgreSQL.Simple.FromRow (FromRow (fromRow), field) +import qualified System.IO.Error as Error +import qualified TFB.Types 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 ws = pure . head $ ws + +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 89% 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..00fde0a4f49 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 @@ -18,7 +18,7 @@ library base >= 4.7 && < 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..f8465e27dd5 100644 --- a/frameworks/Haskell/warp/shared/tfb-types/tfb-types.cabal +++ b/frameworks/Haskell/warp/shared/tfb-types/tfb-types.cabal @@ -19,5 +19,4 @@ library , bytestring , attoparsec , buffer-builder - , type-of-html , text diff --git a/frameworks/Haskell/warp/stack.yaml b/frameworks/Haskell/warp/stack.yaml index ff09c250201..a1056f68dfd 100644 --- a/frameworks/Haskell/warp/stack.yaml +++ b/frameworks/Haskell/warp/stack.yaml @@ -1,18 +1,16 @@ -resolver: lts-13.13 +resolver: lts-22.44 packages: - ./shared/tfb-types -- ./shared/tfb-hasql -- ./shared/tfb-mysql-haskell -- ./shared/tfb-postgres-wire +# - ./shared/tfb-hasql +# - ./shared/tfb-mysql-haskell +- ./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 +- socket-0.8.3.0 +- socket-unix-0.2.1.0 # 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.6.7 # 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..3e2871d97b1 --- /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: socket-0.8.3.0@sha256:c7c8433770729eef056445b15ceb0e77807ec3b0bea4e47a2f4c609bbeab2638,3414 + pantry-tree: + sha256: 718e90009b0023f73783ce0934cc6b9d03de6a28ba864130b7ebc5bfe5986cb6 + size: 2064 + original: + hackage: socket-0.8.3.0 +- completed: + hackage: socket-unix-0.2.1.0@sha256:3f83390ee646e220ff7bbe53d4f56daaa44086dc379a908b655cca7d698bc1aa,2598 + pantry-tree: + sha256: e71d03b0ac0a46c89a39acf0c06f1bcf56f80b277d89617a411ee4f64c1ad6dc + size: 848 + original: + hackage: socket-unix-0.2.1.0 +snapshots: +- completed: + sha256: 238fa745b64f91184f9aa518fe04bdde6552533d169b0da5256670df83a0f1a9 + size: 721141 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/44.yaml + original: lts-22.44 diff --git a/frameworks/Haskell/warp/warp-shared.dockerfile b/frameworks/Haskell/warp/warp-shared.dockerfile index 9c8091768d9..254be6c8fa0 100644 --- a/frameworks/Haskell/warp/warp-shared.dockerfile +++ b/frameworks/Haskell/warp/warp-shared.dockerfile @@ -1,4 +1,4 @@ -FROM haskell:8.6.3 +FROM haskell:9.6 RUN apt-get update -yqq && apt-get install -yqq xz-utils make RUN apt-get install -yqq libpq-dev @@ -9,7 +9,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 +17,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..84a3a739f30 100644 --- a/frameworks/Haskell/warp/warp-shared/src/Lib.hs +++ b/frameworks/Haskell/warp/warp-shared/src/Lib.hs @@ -1,27 +1,28 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -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) +module Lib + ( main, + Db.Config (..), + ) +where +import Control.Monad (join, replicateM) +import Data.BufferBuilder.Json ((.=)) +import qualified Data.BufferBuilder.Json as Json 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 Data.Either as Either +import Data.List (sortOn) import qualified Network.HTTP.Types.Header as Header +import qualified Network.HTTP.Types.Status as Status 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 ((#)) +import qualified TFB.Db as Db +import qualified TFB.Types as Types +import qualified Text.Blaze.Html.Renderer.Utf8 as Html +import qualified Text.Blaze.Html5 as Html -- entry point main :: Db.Config -> IO () @@ -41,18 +42,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 +69,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 +77,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 +139,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..94e62d20635 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 qualified Lib +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..5e9a4fb0bcb 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 @@ -23,32 +23,32 @@ common deps , text , attoparsec , buffer-builder - , type-of-html + , blaze-html , mwc-random , wai , warp , http-types -executable warp-hasql - import: deps - main-is: - Main.hs - build-depends: - tfb-types - , tfb-hasql +-- executable warp-hasql +-- import: deps +-- main-is: +-- Main.hs +-- build-depends: +-- tfb-types +-- , tfb-hasql -executable warp-mysql-haskell - import: deps - main-is: - Main.hs - build-depends: - tfb-types - , tfb-mysql-haskell +-- executable warp-mysql-haskell +-- import: deps +-- main-is: +-- Main.hs +-- build-depends: +-- 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 From 5a0c3be9f2398609cbdfb50e13323aab120c120d Mon Sep 17 00:00:00 2001 From: Benjamin Maurer Date: Fri, 5 Sep 2025 17:40:24 +0200 Subject: [PATCH 2/5] Try to fix mysql-haskell, but auth protocol not supported. --- .../warp/shared/tfb-mysql-haskell/README.md | 3 + .../warp/shared/tfb-mysql-haskell/TFB/Db.hs | 120 ++++++++++-------- frameworks/Haskell/warp/stack.yaml | 2 +- .../warp/warp-shared/warp-shared.cabal | 14 +- 4 files changed, 81 insertions(+), 58 deletions(-) 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..3dd91ea7519 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,94 @@ {-# OPTIONS -funbox-strict-fields #-} -{-# LANGUAGE OverloadedStrings #-} - -module TFB.Db ( - Pool - , mkPool - , Config(..) - , queryWorldById - , queryWorldByIds - , updateWorlds - , queryFortunes - , Error -) where - -import qualified TFB.Types as Types +{-# 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 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 Data.Text (Text) +import qualified Data.Text as Text import qualified Database.MySQL.Base as MySQL import qualified System.IO.Streams as Streams -import Data.Text (Text) -import qualified Data.Text as Text +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 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 +100,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 +124,7 @@ queryWorldById dbPool wId = Pool.withResource dbPool $ \conn -> do return $ case err of [] -> case oks of [] -> Left "World not found!" - ws -> pure $ head ws + ws -> pure $ head ws _ -> Left . mconcat $ err where s = "SELECT * FROM World WHERE id = ?" @@ -134,15 +153,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 diff --git a/frameworks/Haskell/warp/stack.yaml b/frameworks/Haskell/warp/stack.yaml index a1056f68dfd..4c1f0c80b3c 100644 --- a/frameworks/Haskell/warp/stack.yaml +++ b/frameworks/Haskell/warp/stack.yaml @@ -3,7 +3,7 @@ resolver: lts-22.44 packages: - ./shared/tfb-types # - ./shared/tfb-hasql -# - ./shared/tfb-mysql-haskell +- ./shared/tfb-mysql-haskell - ./shared/tfb-postgres-simple - ./warp-shared diff --git a/frameworks/Haskell/warp/warp-shared/warp-shared.cabal b/frameworks/Haskell/warp/warp-shared/warp-shared.cabal index 5e9a4fb0bcb..569fe110a55 100644 --- a/frameworks/Haskell/warp/warp-shared/warp-shared.cabal +++ b/frameworks/Haskell/warp/warp-shared/warp-shared.cabal @@ -37,13 +37,13 @@ common deps -- tfb-types -- , tfb-hasql --- executable warp-mysql-haskell --- import: deps --- main-is: --- Main.hs --- build-depends: --- tfb-types --- , tfb-mysql-haskell +executable warp-mysql-haskell + import: deps + main-is: + Main.hs + build-depends: + tfb-types + , tfb-mysql-haskell executable warp-postgres-simple import: deps From 4597956db3be62e16fac635cbaef6aeca2502785 Mon Sep 17 00:00:00 2001 From: Benjamin Maurer Date: Mon, 8 Sep 2025 12:37:36 +0200 Subject: [PATCH 3/5] Upgrade ghc to 9.10 --- .../warp/shared/tfb-mysql-haskell/TFB/Db.hs | 5 ++-- .../tfb-mysql-haskell/tfb-mysql-haskell.cabal | 3 ++- .../warp/shared/tfb-postgres-simple/TFB/Db.hs | 5 +--- .../tfb-postgres-simple.cabal | 3 ++- frameworks/Haskell/warp/stack.yaml | 8 +++---- frameworks/Haskell/warp/stack.yaml.lock | 24 +++++++++---------- .../Haskell/warp/warp-shared.dockerfile | 10 +++++--- .../Haskell/warp/warp-shared/src/Lib.hs | 1 - .../warp/warp-shared/warp-shared.cabal | 2 +- 9 files changed, 31 insertions(+), 30 deletions(-) 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 3dd91ea7519..c2120834cd7 100644 --- a/frameworks/Haskell/warp/shared/tfb-mysql-haskell/TFB/Db.hs +++ b/frameworks/Haskell/warp/shared/tfb-mysql-haskell/TFB/Db.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -funbox-strict-fields #-} {-# LANGUAGE OverloadedStrings #-} module TFB.Db @@ -124,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 = ?" @@ -172,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..5d9a25577b7 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,7 +12,8 @@ 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 diff --git a/frameworks/Haskell/warp/shared/tfb-postgres-simple/TFB/Db.hs b/frameworks/Haskell/warp/shared/tfb-postgres-simple/TFB/Db.hs index f69be752f1d..958cf20e3af 100644 --- a/frameworks/Haskell/warp/shared/tfb-postgres-simple/TFB/Db.hs +++ b/frameworks/Haskell/warp/shared/tfb-postgres-simple/TFB/Db.hs @@ -1,9 +1,6 @@ -{-# OPTIONS -funbox-strict-fields #-} {-# OPTIONS -Wno-orphans #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} module TFB.Db ( Pool, @@ -111,7 +108,7 @@ queryWorldByIdInner wId conn = do pure $ Either.either (Left . DbError . BSC.pack . show) mkW res where mkW [] = Left NotFound - mkW ws = pure . head $ ws + mkW (w : _) = pure w queryWorldById :: Pool -> Types.QId -> IO (Either Error Types.World) queryWorldById dbPool wId = Pool.withResource dbPool (queryWorldByIdInner wId) diff --git a/frameworks/Haskell/warp/shared/tfb-postgres-simple/tfb-postgres-simple.cabal b/frameworks/Haskell/warp/shared/tfb-postgres-simple/tfb-postgres-simple.cabal index 00fde0a4f49..c97de5d27aa 100644 --- a/frameworks/Haskell/warp/shared/tfb-postgres-simple/tfb-postgres-simple.cabal +++ b/frameworks/Haskell/warp/shared/tfb-postgres-simple/tfb-postgres-simple.cabal @@ -12,7 +12,8 @@ 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 diff --git a/frameworks/Haskell/warp/stack.yaml b/frameworks/Haskell/warp/stack.yaml index 4c1f0c80b3c..1d5dbbb014b 100644 --- a/frameworks/Haskell/warp/stack.yaml +++ b/frameworks/Haskell/warp/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-22.44 +resolver: lts-24.9 packages: - ./shared/tfb-types @@ -8,9 +8,9 @@ packages: - ./warp-shared extra-deps: -- socket-0.8.3.0 -- socket-unix-0.2.1.0 +- buffer-builder-0.2.4.9 +- mysql-haskell-1.1.7 # the following flags are meant for use with warp.dockerfile -compiler: ghc-9.6.7 # 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 index 3e2871d97b1..97d0793af4a 100644 --- a/frameworks/Haskell/warp/stack.yaml.lock +++ b/frameworks/Haskell/warp/stack.yaml.lock @@ -5,22 +5,22 @@ packages: - completed: - hackage: socket-0.8.3.0@sha256:c7c8433770729eef056445b15ceb0e77807ec3b0bea4e47a2f4c609bbeab2638,3414 + hackage: buffer-builder-0.2.4.9@sha256:22600bcca6b8657865d1dce07cfa791767bdb6241c0cd5cadd6444678bf9a8a7,5257 pantry-tree: - sha256: 718e90009b0023f73783ce0934cc6b9d03de6a28ba864130b7ebc5bfe5986cb6 - size: 2064 + sha256: f5eddef2db3cd6e0c2e2199a5a59cae0329b057045aa67705492d069f9e204f0 + size: 1155 original: - hackage: socket-0.8.3.0 + hackage: buffer-builder-0.2.4.9 - completed: - hackage: socket-unix-0.2.1.0@sha256:3f83390ee646e220ff7bbe53d4f56daaa44086dc379a908b655cca7d698bc1aa,2598 + hackage: mysql-haskell-1.1.7@sha256:e1fc81c03063a50a169464e9983466249339c718b28012e2b69cd58e7c18487c,5498 pantry-tree: - sha256: e71d03b0ac0a46c89a39acf0c06f1bcf56f80b277d89617a411ee4f64c1ad6dc - size: 848 + sha256: 8720dcd88265638550d96b2ef560fafd1b708bcf196a1c3add5f98c82d014711 + size: 4968 original: - hackage: socket-unix-0.2.1.0 + hackage: mysql-haskell-1.1.7 snapshots: - completed: - sha256: 238fa745b64f91184f9aa518fe04bdde6552533d169b0da5256670df83a0f1a9 - size: 721141 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/44.yaml - original: lts-22.44 + sha256: 188228e10dbb5b533bae584049b112e72000902e64b17348679a69f92fbc0d32 + size: 726076 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/9.yaml + original: lts-24.9 diff --git a/frameworks/Haskell/warp/warp-shared.dockerfile b/frameworks/Haskell/warp/warp-shared.dockerfile index 254be6c8fa0..635674f2f46 100644 --- a/frameworks/Haskell/warp/warp-shared.dockerfile +++ b/frameworks/Haskell/warp/warp-shared.dockerfile @@ -1,7 +1,11 @@ -FROM haskell:9.6 +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 diff --git a/frameworks/Haskell/warp/warp-shared/src/Lib.hs b/frameworks/Haskell/warp/warp-shared/src/Lib.hs index 84a3a739f30..7b3f84bc92c 100644 --- a/frameworks/Haskell/warp/warp-shared/src/Lib.hs +++ b/frameworks/Haskell/warp/warp-shared/src/Lib.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Lib ( main, diff --git a/frameworks/Haskell/warp/warp-shared/warp-shared.cabal b/frameworks/Haskell/warp/warp-shared/warp-shared.cabal index 569fe110a55..214ea1b3c22 100644 --- a/frameworks/Haskell/warp/warp-shared/warp-shared.cabal +++ b/frameworks/Haskell/warp/warp-shared/warp-shared.cabal @@ -15,7 +15,7 @@ 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 From 298c9f95dbb4dc8b770796403a3ceae91185c41b Mon Sep 17 00:00:00 2001 From: Benjamin Maurer Date: Fri, 17 Oct 2025 16:11:27 +0200 Subject: [PATCH 4/5] Fix hasql and update stackage snapshot. --- frameworks/Haskell/warp/benchmark_config.json | 8 +- .../Haskell/warp/shared/tfb-hasql/TFB/Db.hs | 141 +++++++++++------- .../warp/shared/tfb-hasql/tfb-hasql.cabal | 7 +- .../tfb-mysql-haskell/tfb-mysql-haskell.cabal | 2 +- .../tfb-postgres-simple.cabal | 2 +- .../warp/shared/tfb-types/tfb-types.cabal | 2 +- frameworks/Haskell/warp/stack.yaml | 4 +- frameworks/Haskell/warp/stack.yaml.lock | 8 +- .../warp/warp-shared/warp-shared.cabal | 16 +- 9 files changed, 109 insertions(+), 81 deletions(-) diff --git a/frameworks/Haskell/warp/benchmark_config.json b/frameworks/Haskell/warp/benchmark_config.json index 01c269b97f6..e96726ac64d 100644 --- a/frameworks/Haskell/warp/benchmark_config.json +++ b/frameworks/Haskell/warp/benchmark_config.json @@ -14,7 +14,7 @@ "database": "Postgres", "framework": "Warp", "language": "Haskell", - "flavor": "GHC967", + "flavor": "GHC910", "orm": "Raw", "platform": "Wai", "webserver": "Wai", @@ -38,7 +38,7 @@ "database": "Postgres", "framework": "Warp", "language": "Haskell", - "flavor": "GHC967", + "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": "GHC967", + "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/tfb-mysql-haskell.cabal b/frameworks/Haskell/warp/shared/tfb-mysql-haskell/tfb-mysql-haskell.cabal index 5d9a25577b7..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 @@ -16,7 +16,7 @@ library 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/tfb-postgres-simple.cabal b/frameworks/Haskell/warp/shared/tfb-postgres-simple/tfb-postgres-simple.cabal index c97de5d27aa..53e42d1c36d 100644 --- a/frameworks/Haskell/warp/shared/tfb-postgres-simple/tfb-postgres-simple.cabal +++ b/frameworks/Haskell/warp/shared/tfb-postgres-simple/tfb-postgres-simple.cabal @@ -16,7 +16,7 @@ library ghc-options: -funbox-strict-fields exposed-modules: TFB.Db build-depends: - base >= 4.7 && < 5 + base >= 4.18 && < 5 , tfb-types , resource-pool , postgresql-simple diff --git a/frameworks/Haskell/warp/shared/tfb-types/tfb-types.cabal b/frameworks/Haskell/warp/shared/tfb-types/tfb-types.cabal index f8465e27dd5..3fc2c9446f9 100644 --- a/frameworks/Haskell/warp/shared/tfb-types/tfb-types.cabal +++ b/frameworks/Haskell/warp/shared/tfb-types/tfb-types.cabal @@ -15,7 +15,7 @@ library default-language: Haskell2010 exposed-modules: TFB.Types build-depends: - base >= 4.7 && < 5 + base >= 4.18 && < 5 , bytestring , attoparsec , buffer-builder diff --git a/frameworks/Haskell/warp/stack.yaml b/frameworks/Haskell/warp/stack.yaml index 1d5dbbb014b..7df4cd85668 100644 --- a/frameworks/Haskell/warp/stack.yaml +++ b/frameworks/Haskell/warp/stack.yaml @@ -1,8 +1,8 @@ -resolver: lts-24.9 +resolver: lts-24.11 packages: - ./shared/tfb-types -# - ./shared/tfb-hasql +- ./shared/tfb-hasql - ./shared/tfb-mysql-haskell - ./shared/tfb-postgres-simple - ./warp-shared diff --git a/frameworks/Haskell/warp/stack.yaml.lock b/frameworks/Haskell/warp/stack.yaml.lock index 97d0793af4a..16819ffff37 100644 --- a/frameworks/Haskell/warp/stack.yaml.lock +++ b/frameworks/Haskell/warp/stack.yaml.lock @@ -20,7 +20,7 @@ packages: hackage: mysql-haskell-1.1.7 snapshots: - completed: - sha256: 188228e10dbb5b533bae584049b112e72000902e64b17348679a69f92fbc0d32 - size: 726076 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/9.yaml - original: lts-24.9 + 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/warp-shared.cabal b/frameworks/Haskell/warp/warp-shared/warp-shared.cabal index 214ea1b3c22..bc7bf933d48 100644 --- a/frameworks/Haskell/warp/warp-shared/warp-shared.cabal +++ b/frameworks/Haskell/warp/warp-shared/warp-shared.cabal @@ -18,7 +18,7 @@ common deps 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 @@ -29,13 +29,13 @@ common deps , warp , http-types --- executable warp-hasql --- import: deps --- main-is: --- Main.hs --- build-depends: --- tfb-types --- , tfb-hasql +executable warp-hasql + import: deps + main-is: + Main.hs + build-depends: + tfb-types + , tfb-hasql executable warp-mysql-haskell import: deps From 29cda3963a7c294375fe458d8bdf6f42c24b7fc4 Mon Sep 17 00:00:00 2001 From: Benjamin Maurer Date: Fri, 17 Oct 2025 16:43:32 +0200 Subject: [PATCH 5/5] Auto-formatting --- .../warp/shared/tfb-mysql-haskell/TFB/Db.hs | 14 +++++----- .../warp/shared/tfb-postgres-simple/TFB/Db.hs | 17 +++++++----- .../Haskell/warp/warp-shared/src/Lib.hs | 26 +++++++++---------- .../Haskell/warp/warp-shared/src/Main.hs | 4 +-- 4 files changed, 32 insertions(+), 29 deletions(-) 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 c2120834cd7..2aa6e8d637d 100644 --- a/frameworks/Haskell/warp/shared/tfb-mysql-haskell/TFB/Db.hs +++ b/frameworks/Haskell/warp/shared/tfb-mysql-haskell/TFB/Db.hs @@ -14,14 +14,14 @@ where import Control.Monad (forM, forM_) import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BSC -import qualified Data.Either as Either -import qualified Data.Pool as Pool +import Data.ByteString.Char8 qualified as BSC +import Data.Either qualified as Either +import Data.Pool qualified as Pool import Data.Text (Text) -import qualified Data.Text as Text -import qualified Database.MySQL.Base as MySQL -import qualified System.IO.Streams as Streams -import qualified TFB.Types as Types +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 ------------------------------------------------------------------------------- diff --git a/frameworks/Haskell/warp/shared/tfb-postgres-simple/TFB/Db.hs b/frameworks/Haskell/warp/shared/tfb-postgres-simple/TFB/Db.hs index 958cf20e3af..3b1ed8e52f5 100644 --- a/frameworks/Haskell/warp/shared/tfb-postgres-simple/TFB/Db.hs +++ b/frameworks/Haskell/warp/shared/tfb-postgres-simple/TFB/Db.hs @@ -16,18 +16,19 @@ where import Control.Exception (catch, try) import Control.Monad (forM) -import qualified Data.Bifunctor as Bi +import Data.Bifunctor qualified as Bi import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BSC -import qualified Data.Either as Either -import qualified Data.Pool as Pool +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 qualified Database.PostgreSQL.Simple as PG +import Database.PostgreSQL.Simple qualified as PG import Database.PostgreSQL.Simple.FromRow (FromRow (fromRow), field) -import qualified System.IO.Error as Error -import qualified TFB.Types as Types +import System.IO.Error qualified as Error +import TFB.Types qualified as Types ------------------------------------------------------------------------------- + -- * Database data Config @@ -99,6 +100,7 @@ mkPool c = (configPoolSize c) ------------------------------------------------------------------------------- + -- * World queryWorldByIdInner :: Types.QId -> Connection -> IO (Either Error Types.World) @@ -143,6 +145,7 @@ updateWorlds dbPool wsUpdates = Pool.withResource dbPool $ \conn -> do pure $ Bi.bimap (DbError . BSC.pack . show) (const $ map (uncurry Types.World) worlds) res ------------------------------------------------------------------------------- + -- * Fortunes queryFortunes :: Pool -> IO (Either Error [Types.Fortune]) diff --git a/frameworks/Haskell/warp/warp-shared/src/Lib.hs b/frameworks/Haskell/warp/warp-shared/src/Lib.hs index 7b3f84bc92c..210db9b25ab 100644 --- a/frameworks/Haskell/warp/warp-shared/src/Lib.hs +++ b/frameworks/Haskell/warp/warp-shared/src/Lib.hs @@ -8,20 +8,20 @@ where import Control.Monad (join, replicateM) import Data.BufferBuilder.Json ((.=)) -import qualified Data.BufferBuilder.Json as Json -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBSC -import qualified Data.Either as Either +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 qualified Network.HTTP.Types.Header as Header -import qualified Network.HTTP.Types.Status as Status -import qualified Network.Wai as Wai -import qualified Network.Wai.Handler.Warp as Warp -import qualified System.Random.MWC as MWC -import qualified TFB.Db as Db -import qualified TFB.Types as Types -import qualified Text.Blaze.Html.Renderer.Utf8 as Html -import qualified Text.Blaze.Html5 as Html +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 () diff --git a/frameworks/Haskell/warp/warp-shared/src/Main.hs b/frameworks/Haskell/warp/warp-shared/src/Main.hs index 94e62d20635..4f85fa6e5de 100644 --- a/frameworks/Haskell/warp/warp-shared/src/Main.hs +++ b/frameworks/Haskell/warp/warp-shared/src/Main.hs @@ -2,8 +2,8 @@ module Main where -import qualified GHC.Conc -import qualified Lib +import GHC.Conc qualified +import Lib qualified import System.Environment (getArgs, lookupEnv) main :: IO ()