From 585ba6e266f5730b3dc1bfd9906ced2ac3f66dce Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Thu, 30 Nov 2023 23:22:12 +0100 Subject: [PATCH] fix: replace list lastVersion by referenceVersion (#1264) --- datafiles/static/browse.js | 2 +- datafiles/templates/Html/browse.html.st | 2 +- src/Distribution/Server/Features/Browse.hs | 4 +- .../Server/Features/Browse/ApplyFilter.hs | 2 +- .../Server/Features/Browse/Options.hs | 6 +- .../Server/Features/Html/HtmlUtilities.hs | 2 +- .../Server/Features/PackageList.hs | 61 +++++++++++++++---- .../Server/Features/PreferredVersions.hs | 6 ++ 8 files changed, 65 insertions(+), 20 deletions(-) diff --git a/datafiles/static/browse.js b/datafiles/static/browse.js index 868768a44..4c79adcbe 100644 --- a/datafiles/static/browse.js +++ b/datafiles/static/browse.js @@ -133,7 +133,7 @@ const replaceRows = (response) => { tr.appendChild(createSimpleText(row.description)); tr.appendChild(createTags(row.tags)); tr.appendChild(createLastUpload(row.lastUpload)); - tr.appendChild(createSimpleText(row.lastVersion)); + tr.appendChild(createSimpleText(row.referenceVersion)); tr.appendChild(createMaintainers(row.maintainers)); l.appendChild(tr); } diff --git a/datafiles/templates/Html/browse.html.st b/datafiles/templates/Html/browse.html.st index 8f79ce634..ddc240e75 100644 --- a/datafiles/templates/Html/browse.html.st +++ b/datafiles/templates/Html/browse.html.st @@ -212,7 +212,7 @@ Description Tags Last U/L - Last Version + Reference Version Maintainers diff --git a/src/Distribution/Server/Features/Browse.hs b/src/Distribution/Server/Features/Browse.hs index 0ff354f3b..9b53e01b3 100644 --- a/src/Distribution/Server/Features/Browse.hs +++ b/src/Distribution/Server/Features/Browse.hs @@ -139,7 +139,7 @@ packageIndexInfoToValue :: CoreResource -> TagsResource -> UserResource -> Packa packageIndexInfoToValue coreResource tagsResource userResource PackageItem{itemName, itemDownloads, itemVotes, - itemDesc, itemTags, itemLastUpload, itemLastVersion, itemMaintainer} = + itemDesc, itemTags, itemLastUpload, itemReferenceVersion, itemMaintainer} = object [ Key.fromString "name" .= renderPackage itemName , Key.fromString "downloads" .= itemDownloads @@ -147,7 +147,7 @@ packageIndexInfoToValue , Key.fromString "description" .= itemDesc , Key.fromString "tags" .= map renderTag (S.toAscList itemTags) , Key.fromString "lastUpload" .= iso8601Show itemLastUpload - , Key.fromString "lastVersion" .= itemLastVersion + , Key.fromString "referenceVersion" .= itemReferenceVersion , Key.fromString "maintainers" .= map renderUser itemMaintainer ] where diff --git a/src/Distribution/Server/Features/Browse/ApplyFilter.hs b/src/Distribution/Server/Features/Browse/ApplyFilter.hs index c86082fc8..f129109fb 100644 --- a/src/Distribution/Server/Features/Browse/ApplyFilter.hs +++ b/src/Distribution/Server/Features/Browse/ApplyFilter.hs @@ -63,7 +63,7 @@ sort isSearch sortColumn sortDirection = Description -> comparing itemDesc Tags -> comparing (S.toAscList . itemTags) LastUpload -> comparing itemLastUpload - LastVersion -> comparing itemLastVersion + ReferenceVersion -> comparing itemReferenceVersion Maintainers -> comparing itemMaintainer in sortBy (maybeReverse comparer) where diff --git a/src/Distribution/Server/Features/Browse/Options.hs b/src/Distribution/Server/Features/Browse/Options.hs index dd93401ef..64416b355 100644 --- a/src/Distribution/Server/Features/Browse/Options.hs +++ b/src/Distribution/Server/Features/Browse/Options.hs @@ -9,7 +9,7 @@ import Distribution.Server.Features.Browse.Parsers (Filter, conditions, condsToF data IsSearch = IsSearch | IsNotSearch -data NormalColumn = Name | Downloads | Rating | Description | Tags | LastUpload | LastVersion | Maintainers +data NormalColumn = Name | Downloads | Rating | Description | Tags | LastUpload | ReferenceVersion | Maintainers deriving (Show, Eq) data Column = DefaultColumn | NormalColumn NormalColumn @@ -36,7 +36,7 @@ instance FromJSON Column where "description" -> pure $ NormalColumn Description "tags" -> pure $ NormalColumn Tags "lastUpload" -> pure $ NormalColumn LastUpload - "lastVersion" -> pure $ NormalColumn LastVersion + "referenceVersion" -> pure $ NormalColumn ReferenceVersion "maintainers" -> pure $ NormalColumn Maintainers t -> fail $ "Column invalid: " ++ T.unpack t @@ -49,7 +49,7 @@ columnToTemplateName = \case NormalColumn Description -> "description" NormalColumn Tags -> "tags" NormalColumn LastUpload -> "lastUpload" - NormalColumn LastVersion -> "lastVersion" + NormalColumn ReferenceVersion -> "referenceVersion" NormalColumn Maintainers -> "maintainers" instance FromJSON Direction where diff --git a/src/Distribution/Server/Features/Html/HtmlUtilities.hs b/src/Distribution/Server/Features/Html/HtmlUtilities.hs index d0fd2f44f..298810ff0 100644 --- a/src/Distribution/Server/Features/Html/HtmlUtilities.hs +++ b/src/Distribution/Server/Features/Html/HtmlUtilities.hs @@ -52,7 +52,7 @@ htmlUtilities CoreFeature{coreResource} , td $ toHtml $ itemDesc item , td $ " (" +++ renderTags (itemTags item) +++ ")" , td $ toHtml $ formatTime defaultTimeLocale "%F" (itemLastUpload item) - , td $ toHtml $ itemLastVersion item + , td $ toHtml $ itemReferenceVersion item , td $ "" +++ intersperse (toHtml ", ") (map renderUser (itemMaintainer item)) ] where diff --git a/src/Distribution/Server/Features/PackageList.hs b/src/Distribution/Server/Features/PackageList.hs index 57b1c1b8a..1fe2bd58e 100644 --- a/src/Distribution/Server/Features/PackageList.hs +++ b/src/Distribution/Server/Features/PackageList.hs @@ -29,6 +29,7 @@ import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Configuration import Distribution.Pretty (prettyShow) +import Distribution.Types.Version (Version) import Distribution.Utils.ShortText (fromShortText) import Control.Concurrent @@ -89,17 +90,36 @@ data PackageItem = PackageItem { itemLastUpload :: !UTCTime, -- Hotness = recent downloads + stars + 2 * no rev deps itemHotness :: !Float, - -- Last version - itemLastVersion :: !String + -- All versions + itemVersions :: ![Version], + -- Reference version (non-deprecated highest numbered version) + itemReferenceVersion :: !String } instance MemSize PackageItem where - memSize (PackageItem a b c d e f g h i j k l _m n o) = memSize11 a b c d e f g h i j (k, l, n, o) + memSize (PackageItem a b c d e f g h i j k l _m n o p) = memSize13 a b c d e f g h i j k l (n, o, p) emptyPackageItem :: PackageName -> PackageItem -emptyPackageItem pkg = PackageItem pkg Set.empty Nothing "" [] - 0 0 0 False 0 0 0 (UTCTime (toEnum 0) 0) 0 "" +emptyPackageItem pkg = + PackageItem { + itemName = pkg, + itemTags = Set.empty, + itemDeprecated = Nothing, + itemDesc = "", + itemMaintainer = [], + itemVotes = 0, + itemDownloads = 0, + itemRevDepsCount = 0, + itemHasLibrary = False, + itemNumExecutables = 0, + itemNumTests = 0, + itemNumBenchmarks = 0, + itemLastUpload = UTCTime (toEnum 0) 0, + itemHotness = 0, + itemVersions = [], + itemReferenceVersion = "" + } initListFeature :: ServerEnv @@ -134,10 +154,13 @@ initListFeature _env = do registerHookJust packageChangeHook isPackageAdd $ \pkg -> do let pkgname = packageName . packageId $ pkg - modifyItem pkgname $ \x -> x - {itemLastUpload = fst (pkgOriginalUploadInfo pkg) - ,itemLastVersion = prettyShow $ pkgVersion $ pkgInfoId pkg - } + prefsinfo <- queryGetPreferredInfo pkgname + modifyItem pkgname $ \x -> + updateReferenceVersion prefsinfo $ + x + { itemLastUpload = fst (pkgOriginalUploadInfo pkg) + , itemVersions = pkgVersion (pkgInfoId pkg) : itemVersions x + } runHook_ itemUpdate (Set.singleton pkgname) registerHook groupChangedHook $ \(gd,_,_,_,_) -> @@ -174,6 +197,9 @@ initListFeature _env = do modifyItem pkgname (updateDeprecation mpkgs) runHook_ itemUpdate (Set.singleton pkgname) + registerHook updatePreferredHook $ \(pkgname, prefsinfo) -> do + modifyItem pkgname $ updateReferenceVersion prefsinfo + return feature @@ -265,8 +291,9 @@ listFeature CoreFeature{..} votes <- pkgNumScore pkgname deprs <- queryGetDeprecatedFor pkgname maintainers <- queryUserGroup (maintainersGroup pkgname) + prefsinfo <- queryGetPreferredInfo pkgname - return $ (,) pkgname $ (updateDescriptionItem desc $ emptyPackageItem pkgname) { + return $ (,) pkgname $ (updateReferenceVersion prefsinfo . updateDescriptionItem desc $ emptyPackageItem pkgname) { itemTags = tags , itemMaintainer = map (userIdToName users) (UserIdSet.toList maintainers) , itemDeprecated = deprs @@ -275,7 +302,7 @@ listFeature CoreFeature{..} , itemLastUpload = fst (pkgOriginalUploadInfo pkg) , itemRevDepsCount = intRevDirectCount , itemHotness = votes + fromIntegral (cmFind pkgname downs) + fromIntegral intRevDirectCount * 2 - , itemLastVersion = prettyShow $ pkgVersion $ pkgInfoId pkg + , itemVersions = [pkgVersion (pkgInfoId pkg)] } ------------------------------ @@ -329,6 +356,18 @@ updateDeprecation pkgs item = itemDeprecated = pkgs } +updateReferenceVersion :: PreferredInfo -> PackageItem -> PackageItem +updateReferenceVersion prefsinfo item = + item { + itemReferenceVersion = + case nonDeprecatedVersion of + [] -> "" + xs -> prettyShow $ maximum xs + } + where + versions = itemVersions item + nonDeprecatedVersion = filter (`notElem` deprecatedVersions prefsinfo) versions + updateReverseItem :: Int -> PackageItem -> PackageItem updateReverseItem revDirectCount item = item { diff --git a/src/Distribution/Server/Features/PreferredVersions.hs b/src/Distribution/Server/Features/PreferredVersions.hs index 78c5ddeac..6097afa0c 100644 --- a/src/Distribution/Server/Features/PreferredVersions.hs +++ b/src/Distribution/Server/Features/PreferredVersions.hs @@ -55,6 +55,7 @@ data VersionsFeature = VersionsFeature { versionsResource :: VersionsResource, deprecatedHook :: Hook (PackageName, Maybe [PackageName]) (), putDeprecated :: PackageName -> ServerPartE Bool, + updatePreferredHook :: Hook (PackageName, PreferredInfo) (), putPreferred :: PackageName -> ServerPartE (), updateDeprecatedTags :: IO (), @@ -101,12 +102,14 @@ initVersionsFeature :: ServerEnv initVersionsFeature env@ServerEnv{serverStateDir} = do preferredState <- preferredStateComponent False serverStateDir deprecatedHook <- newHook + updatePreferredHook <- newHook return $ \core upload tags user -> do let feature = versionsFeature env core upload tags user preferredState deprecatedHook + updatePreferredHook return feature preferredStateComponent :: Bool -> FilePath -> IO (StateComponent AcidState PreferredVersions) @@ -130,6 +133,7 @@ versionsFeature :: ServerEnv -> UserFeature -> StateComponent AcidState PreferredVersions -> Hook (PackageName, Maybe [PackageName]) () + -> Hook (PackageName, PreferredInfo) () -> VersionsFeature versionsFeature ServerEnv{ serverVerbosity = verbosity } CoreFeature{..} @@ -138,6 +142,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } UserFeature{ guardAuthorised_ } preferredState deprecatedHook + updatePreferredHook = VersionsFeature{..} where versionsFeatureInterface = (emptyHackageFeature "versions") { @@ -315,6 +320,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } (prefs, deprs) <- lookPrefRangeDeprecatedVersions pkgs prefinfo <- updateState preferredState (SetPreferredInfo pkgname prefs deprs) + runHook_ updatePreferredHook (pkgname, prefinfo { deprecatedVersions = deprs }) -- It seems they are not set updateIndexPackagePreferredVersions pkgname prefinfo where lookPrefRangeDeprecatedVersions pkgs = do