Skip to content

Commit b6cb61e

Browse files
cptwunderlichBenjamin Maurer
cptwunderlich
and
Benjamin Maurer
authored
Fix warp (#10185)
* Bring warp base back to work. * Try to fix mysql-haskell, but auth protocol not supported. * Upgrade ghc to 9.10 * Fix hasql and update stackage snapshot. * Auto-formatting --------- Co-authored-by: Benjamin Maurer <[email protected]>
1 parent 72cffb8 commit b6cb61e

File tree

21 files changed

+481
-460
lines changed

21 files changed

+481
-460
lines changed

‎frameworks/Haskell/warp/.gitignore‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
.stack-work

‎frameworks/Haskell/warp/benchmark_config.json‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -14,16 +14,16 @@
1414
"database": "Postgres",
1515
"framework": "Warp",
1616
"language": "Haskell",
17-
"flavor": "GHC683",
17+
"flavor": "GHC910",
1818
"orm": "Raw",
1919
"platform": "Wai",
2020
"webserver": "Wai",
2121
"os": "Linux",
2222
"database_os": "Linux",
23-
"display_name": "Warp+Postgres-wire",
23+
"display_name": "Warp+Postgres-simple",
2424
"notes": "Pure haskell.",
2525
"dockerfile": "warp-shared.dockerfile",
26-
"tags": ["broken"]
26+
"tags": []
2727
},
2828
"hasql": {
2929
"json_url": "/json",
@@ -38,7 +38,7 @@
3838
"database": "Postgres",
3939
"framework": "Warp",
4040
"language": "Haskell",
41-
"flavor": "GHC683",
41+
"flavor": "GHC910",
4242
"orm": "Raw",
4343
"platform": "Wai",
4444
"webserver": "Wai",
@@ -47,7 +47,7 @@
4747
"display_name": "Warp+Hasql",
4848
"notes": "Uses libpq system dependency.",
4949
"dockerfile": "warp-shared.dockerfile",
50-
"tags": ["broken"]
50+
"tags": []
5151
},
5252
"mysql-haskell": {
5353
"json_url": "/json",
@@ -62,7 +62,7 @@
6262
"database": "MySQL",
6363
"framework": "Warp",
6464
"language": "Haskell",
65-
"flavor": "GHC683",
65+
"flavor": "GHC910",
6666
"orm": "Raw",
6767
"platform": "Wai",
6868
"webserver": "Wai",

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

Lines changed: 84 additions & 57 deletions
Original file line numberDiff line numberDiff line change
@@ -1,74 +1,101 @@
11
{-# OPTIONS -funbox-strict-fields #-}
2-
{-# LANGUAGE OverloadedStrings #-}
3-
4-
module TFB.Db (
5-
Pool
6-
, mkPool
7-
, Config(..)
8-
, queryWorldById
9-
, queryWorldByIds
10-
, updateWorlds
11-
, queryFortunes
12-
, Error
13-
) where
14-
15-
import qualified TFB.Types as Types
16-
import Control.Monad (forM, forM_)
17-
18-
import qualified Hasql.Decoders as HasqlDec
19-
import qualified Hasql.Encoders as HasqlEnc
20-
import Hasql.Pool (Pool, acquire, UsageError, use)
21-
import qualified Hasql.Statement as HasqlStatement
22-
import Hasql.Session (statement)
23-
import Hasql.Connection (settings, Settings)
24-
import Data.Functor.Contravariant (contramap)
25-
import Data.ByteString (ByteString)
2+
{-# LANGUAGE OverloadedStrings #-}
3+
4+
module TFB.Db
5+
( Pool,
6+
mkPool,
7+
Config (..),
8+
queryWorldById,
9+
queryWorldByIds,
10+
updateWorlds,
11+
queryFortunes,
12+
Error,
13+
)
14+
where
15+
16+
import Control.Monad (forM, forM_)
17+
import Data.ByteString (ByteString)
2618
import qualified Data.ByteString.Char8 as BSC
19+
import Data.Functor.Contravariant (contramap)
20+
import qualified Data.Text as T
21+
import qualified Data.Text.Encoding as TE
22+
import qualified Hasql.Connection.Setting as ConnectionSetting
23+
import Hasql.Connection.Setting.Connection (params)
24+
import qualified Hasql.Connection.Setting.Connection.Param as ConnectionParam
25+
import qualified Hasql.Decoders as HasqlDec
26+
import qualified Hasql.Encoders as HasqlEnc
27+
import Hasql.Pool (Pool, UsageError, acquire, use)
28+
import qualified Hasql.Pool.Config as PoolCfg
29+
import Hasql.Session (statement)
30+
import qualified Hasql.Statement as HasqlStatement
31+
import qualified TFB.Types as Types
2732

2833
-------------------------------------------------------------------------------
34+
2935
-- * Database
3036

3137
data Config
3238
= Config
33-
{ configHost :: String
34-
, configName :: ByteString
35-
, configUser :: ByteString
36-
, configPass :: ByteString
37-
, configStripes :: Int
38-
, configPoolSize :: Int
39+
{ configHost :: String,
40+
configName :: ByteString,
41+
configUser :: ByteString,
42+
configPass :: ByteString,
43+
configStripes :: Int,
44+
configPoolSize :: Int
3945
}
46+
4047
instance Show Config where
41-
show c
42-
= "Config {"
43-
<> " configHost = " <> configHost c
44-
<> ", configName = " <> BSC.unpack (configName c)
45-
<> ", configUser = " <> BSC.unpack (configUser c)
46-
<> ", configPass = REDACTED"
47-
<> ", configStripes = " <> show (configStripes c)
48-
<> ", configPoolSize = " <> show (configPoolSize c)
49-
<> " }"
48+
show c =
49+
"Config {"
50+
<> " configHost = "
51+
<> configHost c
52+
<> ", configName = "
53+
<> BSC.unpack (configName c)
54+
<> ", configUser = "
55+
<> BSC.unpack (configUser c)
56+
<> ", configPass = REDACTED"
57+
<> ", configStripes = "
58+
<> show (configStripes c)
59+
<> ", configPoolSize = "
60+
<> show (configPoolSize c)
61+
<> " }"
5062

5163
type Error = UsageError
5264

53-
mkSettings :: Config -> Settings
54-
mkSettings c = settings (BSC.pack $ configHost c) 5432 (configUser c) (configPass c) (configName c)
65+
mkSettings :: Config -> ConnectionSetting.Setting
66+
mkSettings c =
67+
ConnectionSetting.connection $
68+
params
69+
[ ConnectionParam.host (T.pack $ configHost c),
70+
ConnectionParam.port 5432,
71+
ConnectionParam.user (TE.decodeUtf8 $ configUser c),
72+
ConnectionParam.password (TE.decodeUtf8 $ configPass c),
73+
ConnectionParam.dbname (TE.decodeUtf8 $ configName c)
74+
]
5575

5676
mkPool :: Config -> IO Pool
57-
mkPool c = acquire (configPoolSize c, 0.5, mkSettings c)
77+
mkPool c =
78+
acquire $
79+
PoolCfg.settings
80+
[ PoolCfg.staticConnectionSettings [mkSettings c],
81+
PoolCfg.size (configPoolSize c)
82+
]
83+
84+
qidEnc :: HasqlEnc.Params Types.QId
85+
qidEnc = contramap fromIntegral (HasqlEnc.param (HasqlEnc.nonNullable HasqlEnc.int4))
5886

59-
intValEnc :: HasqlEnc.Params Types.QId
60-
intValEnc = contramap fromIntegral $ HasqlEnc.param HasqlEnc.int2
61-
intValDec :: HasqlDec.Row Types.QId
62-
intValDec = fmap fromIntegral $ HasqlDec.column HasqlDec.int2
87+
qidDec :: HasqlDec.Row Types.QId
88+
qidDec = fromIntegral <$> (HasqlDec.column . HasqlDec.nonNullable) HasqlDec.int4
6389

6490
-------------------------------------------------------------------------------
91+
6592
-- * World
6693

6794
selectSingle :: HasqlStatement.Statement Types.QId Types.World
68-
selectSingle = HasqlStatement.Statement q intValEnc decoder True
95+
selectSingle = HasqlStatement.Statement q qidEnc decoder True
6996
where
70-
q = "SELECT * FROM World WHERE (id = $1)"
71-
decoder = HasqlDec.singleRow $ Types.World <$> intValDec <*> intValDec
97+
q = "SELECT * FROM World WHERE (id = $1)"
98+
decoder = HasqlDec.singleRow $ Types.World <$> qidDec <*> qidDec
7299

73100
queryWorldById :: Pool -> Types.QId -> IO (Either Error Types.World)
74101
queryWorldById pool wId = use pool (statement wId selectSingle)
@@ -79,11 +106,10 @@ queryWorldByIds pool wIds = use pool $ do
79106
forM wIds $ \wId -> statement wId selectSingle
80107

81108
updateSingle :: HasqlStatement.Statement (Types.QId, Types.QId) ()
82-
updateSingle = HasqlStatement.Statement q encoder decoder True
109+
updateSingle = HasqlStatement.Statement q encoder HasqlDec.noResult True
83110
where
84111
q = "UPDATE World SET randomNumber = $1 WHERE id = $2"
85-
encoder = contramap fst intValEnc <> contramap snd intValEnc
86-
decoder = HasqlDec.unit
112+
encoder = contramap fst qidEnc <> contramap snd qidEnc
87113

88114
updateWorlds :: Pool -> [(Types.World, Types.QId)] -> IO (Either Error [Types.World])
89115
updateWorlds _ [] = pure . pure $ mempty
@@ -93,18 +119,19 @@ updateWorlds pool wsUpdates = use pool $ do
93119
statement (Types.wId w, wNum) updateSingle
94120
return ws
95121
where
96-
updateW (w,wNum) = w { Types.wRandomNumber = wNum }
122+
updateW (w, wNum) = w {Types.wRandomNumber = wNum}
97123

98124
-------------------------------------------------------------------------------
125+
99126
-- * Fortunes
100127

101128
selectFortunes :: HasqlStatement.Statement () [Types.Fortune]
102129
selectFortunes = HasqlStatement.Statement q encoder decoder True
103130
where
104-
q = "SELECT * FROM Fortune"
105-
encoder = HasqlEnc.unit
106-
-- TODO: investigate whether 'rowList' is worth the more expensive 'cons'.
107-
decoder = HasqlDec.rowList $ Types.Fortune <$> intValDec <*> HasqlDec.column HasqlDec.text
131+
q = "SELECT * FROM Fortune"
132+
encoder = HasqlEnc.noParams
133+
-- TODO: investigate whether 'rowList' is worth the more expensive 'cons'.
134+
decoder = HasqlDec.rowList $ Types.Fortune <$> qidDec <*> HasqlDec.column (HasqlDec.nonNullable HasqlDec.text)
108135
{-# INLINE selectFortunes #-}
109136

110137
queryFortunes :: Pool -> IO (Either Error [Types.Fortune])

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

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -15,10 +15,11 @@ library
1515
default-language: Haskell2010
1616
exposed-modules: TFB.Db
1717
build-depends:
18-
base >= 4.7 && < 5
18+
base >= 4.18 && < 5
1919
, tfb-types
2020
, bytestring
2121
, text
22-
, hasql >= 0.19
23-
, hasql-pool >= 0.4
22+
, hasql >= 1.9.3
23+
, hasql-pool >= 1.3.0
24+
, hasql-th >= 0.4.0
2425
, contravariant

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,6 @@
11
# TFB MySQLHaskell
22

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

0 commit comments

Comments
 (0)