diff --git a/bench/main.hs b/bench/main.hs new file mode 100644 index 0000000..b721506 --- /dev/null +++ b/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 + ] diff --git a/package.yaml b/package.yaml index 1951301..b86da32 100644 --- a/package.yaml +++ b/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 diff --git a/src/Stackage/Database/Query.hs b/src/Stackage/Database/Query.hs index b942233..747c564 100644 --- a/src/Stackage/Database/Query.hs +++ b/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 + --------------------------