Cache latest version

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

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 ::

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) -> ()

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: