From 26d4a2312e2a7d7d4f08a26a03836631f68d1c82 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 27 Aug 2020 10:25:06 +0300 Subject: [PATCH] Cache latest version --- src/Stackage/Database/Cron.hs | 5 +-- src/Stackage/Database/Query.hs | 62 ++++++++++++++++++++------------- src/Stackage/Database/Schema.hs | 9 +++++ stack.yaml | 2 +- 4 files changed, 51 insertions(+), 27 deletions(-) diff --git a/src/Stackage/Database/Cron.hs b/src/Stackage/Database/Cron.hs index 9cabe0d..dfe6ef7 100644 --- a/src/Stackage/Database/Cron.hs +++ b/src/Stackage/Database/Cron.hs @@ -39,7 +39,7 @@ import Network.HTTP.Types (status200, status404) import Pantry (CabalFileInfo(..), DidUpdateOccur(..), HpackExecutable(HpackBundled), PackageIdentifierRevision(..), defaultCasaMaxPerRequest, defaultCasaRepoPrefix, - defaultHackageSecurityConfig) + defaultHackageSecurityConfig, defaultSnapshotLocation) import Pantry.Internal.Stackage (HackageTarballResult(..), PantryConfig(..), Storage(..), forceUpdateHackageIndex, getHackageTarball, packageTreeKey) @@ -189,6 +189,7 @@ stackageServerCron StackageCronOptions {..} = do , pcConnectionCount = connectionCount , pcCasaRepoPrefix = defaultCasaRepoPrefix , pcCasaMaxPerRequest = defaultCasaMaxPerRequest + , pcSnapshotLocation = defaultSnapshotLocation } currentHoogleVersionId <- runRIO logFunc $ getCurrentHoogleVersionIdWithPantryConfig pantryConfig @@ -228,7 +229,7 @@ runStackageUpdate doNotUpload = do runConduit $ sourceSnapshots .| foldMC (createOrUpdateSnapshot corePackageGetters) (pure ()) unless doNotUpload uploadSnapshotsJSON buildAndUploadHoogleDB doNotUpload - run $ mapM_ (`rawExecute` []) ["COMMIT", "VACUUM", "BEGIN"] + run $ mapM_ (`rawExecute` []) ["TRUNCATE TABLE latest_version", "COMMIT", "VACUUM", "BEGIN"] -- | This will look at 'global-hints.yaml' and will create core package getters that are reused diff --git a/src/Stackage/Database/Query.hs b/src/Stackage/Database/Query.hs index 3860f10..d993104 100644 --- a/src/Stackage/Database/Query.hs +++ b/src/Stackage/Database/Query.hs @@ -89,7 +89,7 @@ import qualified Database.Persist as P import Pantry.Internal.Stackage (EntityField(..), PackageName, Version, getBlobKey, getPackageNameById, getPackageNameId, getTreeForKey, getVersionId, - loadBlobById, storeBlob, mkSafeFilePath) + loadBlobById, storeBlob, mkSafeFilePath, versionVersion) import RIO hiding (on, (^.)) import qualified RIO.Map as Map import qualified RIO.Set as Set @@ -415,40 +415,54 @@ getPackageVersionForSnapshot snapshotId pname = getLatest :: FromPreprocess t - => PackageNameP + => PackageNameId -> (t -> SqlExpr (Value SnapshotId)) -> (t -> SqlQuery ()) - -> ReaderT SqlBackend (RIO env) (Maybe LatestInfo) -getLatest pname onWhich orderWhich = + -> ReaderT SqlBackend (RIO env) (Maybe SnapshotPackageId) +getLatest pnameid onWhich orderWhich = selectApplyMaybe - toLatestInfo - (from $ \(which `InnerJoin` snap `InnerJoin` sp `InnerJoin` pn `InnerJoin` v) -> do - on (sp ^. SnapshotPackageVersion ==. v ^. VersionId) - on (sp ^. SnapshotPackagePackageName ==. pn ^. PackageNameId) + unValue + (from $ \(which `InnerJoin` snap `InnerJoin` sp) -> do on (sp ^. SnapshotPackageSnapshot ==. snap ^. SnapshotId) on (snap ^. SnapshotId ==. onWhich which) - where_ (pn ^. PackageNameName ==. val pname) + where_ (sp ^. SnapshotPackagePackageName ==. val pnameid) orderWhich which limit 1 - pure (snap ^. SnapshotName, v ^. VersionVersion, sp ^. SnapshotPackageRevision)) - where - toLatestInfo (snapName, ver, mrev) = - LatestInfo (unValue snapName) $ toVersionMRev (unValue ver) (unValue mrev) + pure (sp ^. SnapshotPackageId)) getLatests :: PackageNameP -> ReaderT SqlBackend (RIO env) [LatestInfo] getLatests pname = do - mLts <- - getLatest - pname - (^. LtsSnap) - (\lts -> orderBy [desc (lts ^. LtsMajor), desc (lts ^. LtsMinor)]) - mNightly <- - getLatest - pname - (^. NightlySnap) - (\nightly -> orderBy [desc (nightly ^. NightlyDay)]) - pure $ catMaybes [mLts, mNightly] + pid <- getPackageNameId $ unPackageNameP pname + mlatest <- getBy $ UniqueLatestVersion pid + (mlts, mnightly) <- + case mlatest of + Nothing -> do + mLts <- + getLatest + pid + (^. LtsSnap) + (\lts -> orderBy [desc (lts ^. LtsMajor), desc (lts ^. LtsMinor)]) + mNightly <- + getLatest + pid + (^. NightlySnap) + (\nightly -> orderBy [desc (nightly ^. NightlyDay)]) + insert_ LatestVersion + { latestVersionPackageName = pid + , latestVersionLts = mLts + , latestVersionNightly = mNightly + } + pure (mLts, mNightly) + Just (Entity _ (LatestVersion _name mlts mnightly)) -> pure (mlts, mnightly) + for (catMaybes [mlts, mnightly]) $ \spid -> do + sp <- maybe (error "impossible") id <$> get spid + snap <- maybe (error "impossible") id <$> get (snapshotPackageSnapshot sp) + version <- maybe (error "impossible") id <$> get (snapshotPackageVersion sp) + pure LatestInfo + { liSnapName = snapshotName snap + , liVersionRev = toVersionMRev (versionVersion version) (snapshotPackageRevision sp) + } -- | Looks up in pantry the latest information about the package on Hackage. getHackageLatestVersion :: diff --git a/src/Stackage/Database/Schema.hs b/src/Stackage/Database/Schema.hs index 9a35b79..c7dd4f9 100644 --- a/src/Stackage/Database/Schema.hs +++ b/src/Stackage/Database/Schema.hs @@ -42,6 +42,8 @@ module Stackage.Database.Schema , DepId , Deprecated(..) , DeprecatedId + , LatestVersion(..) + , LatestVersionId -- ** Pantry , module PS ) where @@ -119,6 +121,13 @@ Deprecated package PackageNameId inFavourOf [PackageNameId] UniqueDeprecated package + +-- Cache table for efficiency +LatestVersion + packageName PackageNameId + lts SnapshotPackageId Maybe + nightly SnapshotPackageId Maybe + UniqueLatestVersion packageName |] _hideUnusedWarnings :: (SchemaId, LtsId, NightlyId, SnapshotHoogleDbId) -> () diff --git a/stack.yaml b/stack.yaml index 1c8f98a..57e34a1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,7 +7,7 @@ extra-deps: - yesod-gitrepo-0.3.0@sha256:7aad996935065726ce615c395d735cc01dcef3993b1788f670f6bfc866085e02,1191 - lukko-0.1.1.1@sha256:5c674bdd8a06b926ba55d872abe254155ed49a58df202b4d842b643e5ed6bcc9,4289 - github: commercialhaskell/pantry - commit: ed48bebc30e539280ad7e13680480be2b87b97ea + commit: c4e7c3dff9770e7937c93edfb6564dd6a1acd55e - github: fpco/casa commit: fc0ed26858bfc4f2966ed2dfb2871bae9266dda6 subdirs: