Merge pull request #293 from fpco/bench

Benchmark stackage queries

.github/workflows/runtime.yml

@@ -2,7 +2,7 @@ name: Runtime image
 
 on:
   push:
-    branches: [master]
+    branches: [master, bench]
 
 jobs:
   push:

bench/main.hs

@@ -0,0 +1,117 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+import Control.Monad.Logger (runNoLoggingT, runStdoutLoggingT)
+import Data.Pool (destroyAllResources)
+import Database.Persist.Postgresql (PostgresConf(..), createPostgresqlPool)
+import Database.Persist.Sql (ConnectionPool, SqlBackend, runSqlPool)
+import Gauge
+import Pantry.Internal.Stackage (PackageNameP(..))
+import RIO
+import Settings (getAppSettings, AppSettings(..), configSettingsYmlValue)
+import Stackage.Database.Query
+import Stackage.Database.Schema (withStackageDatabase, runDatabase)
+import Stackage.Database.Types (LatestInfo, SnapName(..), SnapshotPackageInfo(..))
+import Yesod.Default.Config2
+
+main :: IO ()
+main = do
+    appSettings <- getAppSettings
+    let pgConf =
+            PostgresConf
+                { pgPoolSize = appPostgresPoolsize appSettings
+                , pgConnStr = encodeUtf8 $ appPostgresString appSettings
+                }
+    let snapName = SNLts 16 4
+    mSnapInfo <-
+        runSimpleApp $
+        withStackageDatabase
+            True
+            pgConf
+            (\db -> runDatabase db $ getSnapshotPackageInfoQuery snapName (PackageNameP "yesod"))
+    let snapInfo = fromMaybe (error "snapInfo not retrieved") mSnapInfo
+    defaultMain [benchs snapInfo]
+
+runBenchApp :: ConnectionPool -> ReaderT SqlBackend (RIO SimpleApp) a -> IO a
+runBenchApp pool m = runSimpleApp $ runSqlPool m pool
+
+createBenchPool :: IO ConnectionPool
+createBenchPool = do
+    baSettings <- loadYamlSettingsArgs [configSettingsYmlValue] useEnv
+    pool <-
+        runNoLoggingT $
+        createPostgresqlPool
+            (encodeUtf8 $ appPostgresString baSettings)
+            (appPostgresPoolsize baSettings)
+    pure pool
+
+releasePool :: ConnectionPool -> IO ()
+releasePool = destroyAllResources
+
+-- TODO: Upstream fix ? Or add new function to gauge (although it
+-- seems it might be a breaking change there) ?
+instance NFData ConnectionPool where
+    rnf _ = ()
+
+getLatestsBench :: Benchmark
+getLatestsBench =
+    bench "getLatests" $
+    perBatchEnvWithCleanup
+        (\runs -> createBenchPool)
+        (\_ pool -> releasePool pool)
+        (\pool -> runBenchApp pool (void $ getLatests $ PackageNameP "yesod"))
+
+getDeprecatedBench :: Benchmark
+getDeprecatedBench =
+    bench "getDeprecated" $
+    perBatchEnvWithCleanup
+        (\runs -> createBenchPool)
+        (\_ pool -> releasePool pool)
+        (\pool -> runBenchApp pool (void $ getDeprecatedQuery $ PackageNameP "yesod"))
+
+getSnapshotPackageLatestVersionBench :: Benchmark
+getSnapshotPackageLatestVersionBench =
+    bench "getSnapshotPackageLatestVersion" $
+    perBatchEnvWithCleanup
+        (\runs -> createBenchPool)
+        (\_ pool -> releasePool pool)
+        (\pool ->
+             runBenchApp pool (void $ getSnapshotPackageLatestVersionQuery $ PackageNameP "yesod"))
+
+getSnapshotPackagePageInfoBench :: SnapshotPackageInfo -> Benchmark
+getSnapshotPackagePageInfoBench snapshotInfo =
+    bench "getSnapshotPackagePageInfo" $
+    perBatchEnvWithCleanup
+        (\runs -> createBenchPool)
+        (\_ pool -> releasePool pool)
+        (\pool -> runBenchApp pool (void $ getSnapshotPackagePageInfoQuery snapshotInfo 40))
+
+getPackageInfoBench :: SnapshotPackageInfo -> Benchmark
+getPackageInfoBench snapInfo =
+    bench "getPackageInfo" $
+    perBatchEnvWithCleanup
+        (\runs -> createBenchPool)
+        (\_ pool -> releasePool pool)
+        (\pool -> runBenchApp pool (void $ getPackageInfoQuery (Right snapInfo)))
+
+getHackageLatestVersionBench :: Benchmark
+getHackageLatestVersionBench =
+    bench "getHackageLatestVersion" $
+    perBatchEnvWithCleanup
+        (\runs -> createBenchPool)
+        (\_ pool -> releasePool pool)
+        (\pool -> runBenchApp pool (void $ getHackageLatestVersion $ PackageNameP "yesod"))
+
+benchs :: SnapshotPackageInfo -> Benchmark
+benchs snap =
+    bgroup
+        "SQL Query Benchmark"
+        [ getLatestsBench
+        , getDeprecatedBench
+        , getHackageLatestVersionBench
+        , getPackageInfoBench snap
+        , getSnapshotPackagePageInfoBench snap
+        , getSnapshotPackageLatestVersionBench
+        ]

package.yaml

@@ -145,3 +145,16 @@ executables:
       buildable: false
     - condition: flag(dev)
       cpp-options: -DDEVELOPMENT
+
+benchmarks:
+  stackage-bench:
+    main: main.hs
+    source-dirs: bench
+    dependencies:
+    - stackage-server
+    - gauge
+    - deepseq
+    - path-io
+    - casa-client
+    ghc-options:
+    - -O2

src/Handler/Package.hs

@@ -86,14 +86,16 @@ packagePage mspi pname =
 
 handlePackage :: Either HackageCabalInfo SnapshotPackageInfo -> Handler Html
 handlePackage epi = do
-    (isDeprecated, inFavourOf) <- getDeprecated pname
-    (msppi, mhciLatest) <-
-        case epi of
-            Right spi -> do
-                sppi <- getSnapshotPackagePageInfo spi maxDisplayedDeps
-                return (Just sppi, sppiLatestHackageCabalInfo sppi)
-            Left hci -> pure (Nothing, Just hci)
-    PackageInfo {..} <- getPackageInfo epi
+    (isDeprecated, inFavourOf, snapInfo, PackageInfo{..}) <- run $ do
+        (isDeprecated, inFavourOf) <- getDeprecatedQuery pname
+        snapInfo <- case epi of 
+          Right spi -> Right <$> getSnapshotPackagePageInfoQuery spi maxDisplayedDeps
+          Left hci -> pure $ Left hci
+        pinfo <- getPackageInfoQuery epi
+        pure (isDeprecated, inFavourOf, snapInfo, pinfo)
+    (msppi, mhciLatest) <- case snapInfo of
+                             Left hci -> pure (Nothing, Just hci)
+                             Right sppi -> pure (Just sppi, sppiLatestHackageCabalInfo sppi)
     let authors = enumerate piAuthors
         maintainers =
             let ms = enumerate piMaintainers

src/Stackage/Database/Query.hs

@@ -33,9 +33,13 @@ module Stackage.Database.Query
     , getLatests
     , getHackageLatestVersion
     , getSnapshotPackageInfo
+    , getSnapshotPackageInfoQuery
     , getSnapshotPackageLatestVersion
+    , getSnapshotPackageLatestVersionQuery
     , getSnapshotPackagePageInfo
+    , getSnapshotPackagePageInfoQuery
     , getPackageInfo
+    , getPackageInfoQuery
     , getSnapshotsForPackage
     -- ** Dependencies
 
@@ -46,6 +50,7 @@ module Stackage.Database.Query
     -- ** Deprecations
 
     , getDeprecated
+    , getDeprecatedQuery
     , setDeprecations
 
     -- * Needed for Cron Job
@@ -474,17 +479,18 @@ getHackageLatestVersion pname =
 
 getSnapshotPackageInfo ::
        GetStackageDatabase env m => SnapName -> PackageNameP -> m (Maybe SnapshotPackageInfo)
-getSnapshotPackageInfo snapName pname =
+getSnapshotPackageInfo snapName pname = run $ getSnapshotPackageInfoQuery snapName pname
+
+getSnapshotPackageInfoQuery ::
+       SnapName -> PackageNameP -> ReaderT SqlBackend (RIO env) (Maybe SnapshotPackageInfo)
+getSnapshotPackageInfoQuery snapName pname =
     fmap snd . listToMaybe <$>
-    run (snapshotPackageInfoQuery $ \_sp s pn _v spiQ -> do
-             where_ ((s ^. SnapshotName ==. val snapName) &&. (pn ^. PackageNameName ==. val pname))
-             pure ((), spiQ))
+    (snapshotPackageInfoQuery $ \_sp s pn _v spiQ -> do
+         where_ ((s ^. SnapshotName ==. val snapName) &&. (pn ^. PackageNameName ==. val pname))
+         pure ((), spiQ))
 
-
-getSnapshotPackagePageInfo ::
-       GetStackageDatabase env m => SnapshotPackageInfo -> Int -> m SnapshotPackagePageInfo
-getSnapshotPackagePageInfo spi maxDisplayedDeps =
-    run $ do
+getSnapshotPackagePageInfoQuery :: SnapshotPackageInfo -> Int -> ReaderT SqlBackend (RIO env) SnapshotPackagePageInfo
+getSnapshotPackagePageInfoQuery spi maxDisplayedDeps = do
         mhciLatest <- getHackageLatestVersion $ spiPackageName spi
         -- TODO: check for `spiOrigin spi` once other than `Hackage` are implemented
         forwardDepsCount <- getForwardDepsCount spi
@@ -519,6 +525,10 @@ getSnapshotPackagePageInfo spi maxDisplayedDeps =
   where
     VersionRev curVer mcurRev = spiVersionRev spi
 
+getSnapshotPackagePageInfo ::
+       GetStackageDatabase env m => SnapshotPackageInfo -> Int -> m SnapshotPackagePageInfo
+getSnapshotPackagePageInfo spi maxDisplayedDeps = run $ getSnapshotPackagePageInfoQuery spi maxDisplayedDeps
+
 type SqlExprSPI
      = ( SqlExpr (Value SnapshotPackageId)
        , SqlExpr (Value SnapshotId)
@@ -576,21 +586,21 @@ snapshotPackageInfoQuery customize =
             }
 
 
+getSnapshotPackageLatestVersionQuery ::
+       PackageNameP -> ReaderT SqlBackend (RIO env) (Maybe SnapshotPackageInfo)
+getSnapshotPackageLatestVersionQuery pname =
+    fmap snd . listToMaybe <$>
+    (snapshotPackageInfoQuery $ \_sp s pn v spiQ -> do
+         where_ (pn ^. PackageNameName ==. val pname)
+         orderBy [desc (versionArray v), desc (s ^. SnapshotCreated)]
+         limit 1
+         pure ((), spiQ))
+
 getSnapshotPackageLatestVersion ::
        GetStackageDatabase env m
     => PackageNameP
     -> m (Maybe SnapshotPackageInfo)
-getSnapshotPackageLatestVersion pname =
-    fmap snd . listToMaybe <$>
-    run (snapshotPackageInfoQuery $ \_sp s pn v spiQ -> do
-             where_ (pn ^. PackageNameName ==. val pname)
-             orderBy
-                 [ desc (versionArray v)
-                 , desc (s ^. SnapshotCreated)
-                 ]
-             limit 1
-             pure ((), spiQ))
-
+getSnapshotPackageLatestVersion pname = run (getSnapshotPackageLatestVersionQuery pname)
 
 -- | A helper function that expects at most one element to be returned by a `select` and applies a
 -- function to the returned result
@@ -628,15 +638,11 @@ getSnapshotsForPackage pname mlimit =
              pure (s ^. SnapshotCompiler, spiQ))
 
 
-
-getPackageInfo ::
-       GetStackageDatabase env m => Either HackageCabalInfo SnapshotPackageInfo -> m PackageInfo
-getPackageInfo (Left hci) =
-    run $ do
-        cabalBlob <- loadBlobById (hciCabalBlobId hci)
-        pure $ toPackageInfo (parseCabalBlob cabalBlob) Nothing Nothing
-getPackageInfo (Right spi) =
-    run $
+getPackageInfoQuery :: Either HackageCabalInfo SnapshotPackageInfo -> ReaderT SqlBackend (RIO env) PackageInfo
+getPackageInfoQuery (Left hci) = do
+  cabalBlob <- loadBlobById (hciCabalBlobId hci)
+  pure $ toPackageInfo (parseCabalBlob cabalBlob) Nothing Nothing
+getPackageInfoQuery (Right spi) = do
     case spiCabalBlobId spi of
         Just cabalBlobId -> do
             gpd <- parseCabalBlob <$> loadBlobById cabalBlobId
@@ -652,6 +658,10 @@ getPackageInfo (Right spi) =
     toContentFile :: (ByteString -> Bool -> a) -> (SafeFilePath, ByteString) -> a
     toContentFile con (path, bs) = con bs (isMarkdownFilePath path)
 
+getPackageInfo ::
+       GetStackageDatabase env m => Either HackageCabalInfo SnapshotPackageInfo -> m PackageInfo
+getPackageInfo args = run $ getPackageInfoQuery args
+
 getFileByTreeEntryId ::
        TreeEntryId
     -> ReaderT SqlBackend (RIO env) (Maybe (SafeFilePath, ByteString))
@@ -753,10 +763,8 @@ getReverseDeps spi mlimit =
 
 ----- Deprecated
 
--- | See if a package is deprecated on hackage and in favour of which packages.
-getDeprecated :: GetStackageDatabase env m => PackageNameP -> m (Bool, [PackageNameP])
-getDeprecated pname =
-    run $
+getDeprecatedQuery :: PackageNameP -> ReaderT SqlBackend (RIO env) (Bool, [PackageNameP])
+getDeprecatedQuery pname =
     lookupPackageNameId pname >>= \case
         Just pnid ->
             P.getBy (UniqueDeprecated pnid) >>= \case
@@ -768,6 +776,10 @@ getDeprecated pname =
   where
     defRes = (False, [])
 
+-- | See if a package is deprecated on hackage and in favour of which packages.
+getDeprecated :: GetStackageDatabase env m => PackageNameP -> m (Bool, [PackageNameP])
+getDeprecated pname = run $ getDeprecatedQuery pname
+
 
 
 --------------------------