From dd638caf0bc4934d3fad447e4897231ac79aad5e Mon Sep 17 00:00:00 2001 From: naushadh Date: Mon, 11 Mar 2019 09:49:26 -0400 Subject: [PATCH] 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`. --- .../Haskell/servant/servant-bench.cabal | 26 +++--- frameworks/Haskell/servant/servant.dockerfile | 4 +- .../Haskell/servant/src/ServantBench.hs | 85 ++++++++++++------- frameworks/Haskell/servant/stack.yaml | 5 +- 4 files changed, 70 insertions(+), 50 deletions(-) diff --git a/frameworks/Haskell/servant/servant-bench.cabal b/frameworks/Haskell/servant/servant-bench.cabal index 9e40f3d4489..75e7863a40a 100644 --- a/frameworks/Haskell/servant/servant-bench.cabal +++ b/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 diff --git a/frameworks/Haskell/servant/servant.dockerfile b/frameworks/Haskell/servant/servant.dockerfile index 18e2f1510ae..1831c55c7e8 100644 --- a/frameworks/Haskell/servant/servant.dockerfile +++ b/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) diff --git a/frameworks/Haskell/servant/src/ServantBench.hs b/frameworks/Haskell/servant/src/ServantBench.hs index 0c10c3ed1ff..b2b63686425 100644 --- a/frameworks/Haskell/servant/src/ServantBench.hs +++ b/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 diff --git a/frameworks/Haskell/servant/stack.yaml b/frameworks/Haskell/servant/stack.yaml index 555e8c4a5dd..3d022febd55 100644 --- a/frameworks/Haskell/servant/stack.yaml +++ b/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: []