Upgrade servant/hasql benchmark with latest deps. (#4536)

* Bump to latest stable compiler, stackage resolver and libs.

- Removed upper bounds for libs since the stackage resolver already takes care of pinning versions for us.
- Removed extra-deps from stack config since resolver now contains `hasql-pool`.
- Addressed `hasql` incompatibilities arising from upgrades to latest version.
- Addressed runtime issue caused by `servant` upgrade changes where invalid parameters are now an error instead of no value. Added a datatype to handle invalid type coercion to 1 as the benchmark rules expect.
- Error responses now describe the cause for a 500 to help debug issues.

* Add `--pedantic` flag to catch even more warnings.

* Re-use a single session across statements to regain some lost performance from `114b1b8`.

- Switch to `unit` decoder for `updateSingle` statement as it now fails when being used in a session with other statements. We really dont need/use the result and as such can safely move to returning `()`.

* Bump pool size to workaround `libpq` locking.

- Pool size now matches the max concurrency of requests used by the benchmark. Many other framworks appear to do similar matching.
- Idea inspired by: https://github.com/haskell-servant/servant/issues/651#issuecomment-267644415
- This finally restores all performance regression caused by `114b1b8`. Additionally we now finally blow past the performance of master at `6250eb8`.

frameworks/Haskell/servant/servant-bench.cabal

@@ -19,21 +19,21 @@ library
   exposed-modules:     ServantBench
   -- other-modules:
   -- other-extensions:
-  build-depends:       base >=4.8 && <4.9
-                     , servant == 0.7.*
-                     , servant-server == 0.7.*
-                     , servant-lucid == 0.7.*
+  build-depends:       base >=4.8
+                     , servant >= 0.7
+                     , servant-server >= 0.7
+                     , servant-lucid >= 0.7
                      , lucid
-                     , aeson == 0.11.*
-                     , hasql == 0.19.*
-                     , hasql-pool == 0.4.*
-                     , bytestring == 0.10.6.*
-                     , mwc-random == 0.13.*
-                     , warp == 3.2.*
+                     , aeson >= 0.11
+                     , hasql >= 0.19
+                     , hasql-pool >= 0.4
+                     , bytestring >= 0.10.6
+                     , mwc-random >= 0.13
+                     , warp >= 3.2
                      , transformers
-                     , text == 1.2.*
-                     , contravariant == 1.4.*
-                     , http-media == 0.6.*
+                     , text >= 1.2
+                     , contravariant >= 1.4
+                     , http-media >= 0.6
   hs-source-dirs:      src
   default-language:    Haskell2010
 

frameworks/Haskell/servant/servant.dockerfile

@@ -1,4 +1,4 @@
-FROM haskell:8.2.1
+FROM haskell:8.6.3
 
 RUN apt update -yqq && apt install -yqq xz-utils make
 RUN apt install -yqq libpq-dev
@@ -7,6 +7,6 @@ ADD ./ /servant
 WORKDIR /servant
 
 RUN stack --allow-different-user setup
-RUN stack --allow-different-user build
+RUN stack --allow-different-user build --pedantic
 
 CMD stack --allow-different-user exec servant-exe -- tfb-database +RTS -A32m -N$(nproc)

frameworks/Haskell/servant/src/ServantBench.hs

@@ -12,10 +12,12 @@ import           Control.Monad.IO.Class     (liftIO)
 import           Data.Aeson                 hiding (json)
 import qualified Data.ByteString            as BS
 import           Data.ByteString.Lazy
+import qualified Data.ByteString.Lazy.Char8 as LBSC
 import           Data.Functor.Contravariant (contramap)
+import           Data.Either                (fromRight, partitionEithers)
 import           Data.Int                   (Int32)
 import           Data.List                  (sortOn)
-import           Data.Maybe                 (fromMaybe)
+import           Data.Maybe                 (maybe)
 import           Data.Monoid                ((<>))
 import qualified Data.Text                  as Text
 import           GHC.Exts                   (IsList (fromList))
@@ -23,8 +25,8 @@ import           GHC.Generics               (Generic)
 import qualified Hasql.Decoders             as HasqlDec
 import qualified Hasql.Encoders             as HasqlEnc
 import           Hasql.Pool                 (Pool, acquire, release, use)
-import qualified Hasql.Query                as Hasql
-import           Hasql.Session              (query)
+import qualified Hasql.Statement            as HasqlStatement
+import           Hasql.Session              (statement)
 import           Lucid
 import qualified Network.Wai.Handler.Warp   as Warp
 import           Network.HTTP.Media         ((//))
@@ -36,9 +38,9 @@ import           System.Random.MWC          (GenIO, createSystemRandom,
 type API =
        "json" :> Get '[JSON] Value
   :<|> "db" :> Get '[JSON] World
-  :<|> "queries" :> QueryParam "queries" Int :> Get '[JSON] [World]
+  :<|> "queries" :> QueryParam "queries" QueryId :> Get '[JSON] [World]
   :<|> "fortune" :> Get '[HTML] (Html ())
-  :<|> "updates" :> QueryParam "queries" Int :> Get '[JSON] [World]
+  :<|> "updates" :> QueryParam "queries" QueryId :> Get '[JSON] [World]
   :<|> "plaintext" :> Get '[Plain] ByteString
 
 api :: Proxy API
@@ -60,8 +62,12 @@ run port dbSettings = do
     Warp.run port $ serve api $ server pool gen
   where
     halfSecond = 0.5
-    settings = (30, halfSecond, dbSettings)
+    settings = (512, halfSecond, dbSettings)
 
+newtype QueryId = QueryId { unQueryId :: Int }
+instance FromHttpApiData QueryId where
+  parseQueryParam
+    = pure . QueryId . fromRight 1 . parseQueryParam
 
 data World = World { wId :: !Int32 , wRandomNumber :: !Int32 }
   deriving (Show, Generic)
@@ -82,9 +88,9 @@ instance ToJSON Fortune where
           )
 
 intValEnc :: HasqlEnc.Params Int32
-intValEnc = HasqlEnc.value HasqlEnc.int4
+intValEnc = HasqlEnc.param HasqlEnc.int4
 intValDec :: HasqlDec.Row Int32
-intValDec = HasqlDec.value HasqlDec.int4
+intValDec = HasqlDec.column HasqlDec.int4
 
 -- * PlainText without charset
 
@@ -105,8 +111,8 @@ json = return . Object $ fromList [("message", "Hello, World!")]
 
 -- * Test 2: Single database query
 
-selectSingle :: Hasql.Query Int32 World
-selectSingle = Hasql.statement q intValEnc decoder True
+selectSingle :: HasqlStatement.Statement Int32 World
+selectSingle = HasqlStatement.Statement q intValEnc decoder True
   where
    q = "SELECT * FROM World WHERE (id = $1)"
    decoder = HasqlDec.singleRow $ World <$> intValDec <*> intValDec
@@ -115,38 +121,47 @@ selectSingle = Hasql.statement q intValEnc decoder True
 singleDb :: Pool -> GenIO -> Handler World
 singleDb pool gen = do
   v <- liftIO $ uniformR (1, 10000) gen
-  r <- liftIO $ use pool (query v selectSingle)
+  r <- liftIO $ use pool (statement v selectSingle)
   case r of
-    Left e -> throwError err500
+    Left e -> throwError err500 { errBody = LBSC.pack . show $ e }
     Right world -> return world
 {-# INLINE singleDb #-}
 
 
 -- * Test 3: Multiple database query
 
-multipleDb :: Pool -> GenIO -> Maybe Int -> Handler [World]
-multipleDb pool gen mcount = replicateM count $ singleDb pool gen
+multipleDb :: Pool -> GenIO -> Maybe QueryId -> Handler [World]
+multipleDb pool gen mQueryId = do
+  results <- getResults
+  let (errs, oks) = partitionEithers results
+  case errs of
+    [] -> return oks
+    _ -> throwError err500 { errBody = LBSC.pack . show $ errs }
   where
-    count = let c = fromMaybe 1 mcount in max 1 (min c 500)
+    c = maybe 1 unQueryId mQueryId
+    count_ = max 1 (min c 500)
+    getResults = replicateM count_ . liftIO . use pool $ do
+      v <- liftIO $ uniformR (1, 10000) gen
+      statement v selectSingle
 {-# INLINE multipleDb #-}
 
 
 -- * Test 4: Fortunes
 
-selectFortunes :: Hasql.Query () [Fortune]
-selectFortunes = Hasql.statement q encoder decoder True
+selectFortunes :: HasqlStatement.Statement () [Fortune]
+selectFortunes = HasqlStatement.Statement q encoder decoder True
   where
    q = "SELECT * FROM Fortune"
    encoder = HasqlEnc.unit
-   -- TODO: investigate whether 'rowsList' is worth the more expensive 'cons'.
-   decoder = HasqlDec.rowsList $ Fortune <$> intValDec <*> HasqlDec.value HasqlDec.text
+   -- TODO: investigate whether 'rowList' is worth the more expensive 'cons'.
+   decoder = HasqlDec.rowList $ Fortune <$> intValDec <*> HasqlDec.column HasqlDec.text
 {-# INLINE selectFortunes #-}
 
 fortunes :: Pool -> Handler (Html ())
 fortunes pool = do
-  r <- liftIO $ use pool (query () selectFortunes)
+  r <- liftIO $ use pool (statement () selectFortunes)
   case r of
-    Left e -> throwError err500
+    Left e -> throwError err500 { errBody = LBSC.pack . show $ e }
     Right fs -> return $ do
       let new = Fortune 0 "Additional fortune added at request time."
       doctypehtml_ $ do
@@ -164,22 +179,30 @@ fortunes pool = do
 
 -- * Test 5: Updates
 
-updateSingle :: Hasql.Query (Int32, Int32) World
-updateSingle = Hasql.statement q encoder decoder True
+updateSingle :: HasqlStatement.Statement (Int32, Int32) ()
+updateSingle = HasqlStatement.Statement q encoder decoder True
   where
     q = "UPDATE World SET randomNumber = $1 WHERE id = $2"
     encoder = contramap fst intValEnc <> contramap snd intValEnc
-    decoder = HasqlDec.singleRow $ World <$> intValDec <*> intValDec
+    decoder = HasqlDec.unit
 {-# INLINE updateSingle #-}
 
-updates :: Pool -> GenIO -> Maybe Int -> Handler [World]
-updates pool gen mcount = replicateM count $ do
-  res <- singleDb pool gen
-  v <- liftIO $ uniformR (1, 10000) gen
-  r <- liftIO $ use pool (query (wId res, v) updateSingle)
-  return $ res { wRandomNumber = v }
+updates :: Pool -> GenIO -> Maybe QueryId -> Handler [World]
+updates pool gen mQueryId = do
+  results <- getResults
+  let (errs, oks) = partitionEithers results
+  case errs of
+    [] -> return oks
+    _ -> throwError err500 { errBody = LBSC.pack . show $ errs }
   where
-    count = let c = fromMaybe 1 mcount in max 1 (min c 500)
+    c = maybe 1 unQueryId mQueryId
+    count_ = max 1 (min c 500)
+    getResults = replicateM count_ . liftIO . use pool $ do
+      v1 <- liftIO $ uniformR (1, 10000) gen
+      res <- statement v1 selectSingle
+      v2 <- liftIO $ uniformR (1, 10000) gen
+      _ <- statement (wId res, v2) updateSingle
+      return $ res { wRandomNumber = v2 }
 {-# INLINE updates #-}
 
 -- * Test 6: Plaintext endpoint

frameworks/Haskell/servant/stack.yaml

@@ -1,9 +1,6 @@
-resolver: lts-6.5
+resolver: lts-13.10
 packages:
 - '.'
 
-extra-deps:
-- hasql-pool-0.4.1
-
 flags: {}
 extra-package-dbs: []