Merge pull request #1268 from blackheaven/replace-last-version

fix: replace list lastVersion by referenceVersion (#1264)

Author: ysangkok

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);
   }

datafiles/templates/Html/browse.html.st

@@ -212,7 +212,7 @@
               <th id=arrow-description><a href="javascript: sort('description')">Description</a></th>
               <th id=arrow-tags><a href="javascript: sort('tags')">Tags</a></th>
               <th id=arrow-lastUpload><a href="javascript: sort('lastUpload')">Last U/L</a></th>
-              <th id=arrow-lastVersion><a href="javascript: sort('lastVersion')">Last Version</a></th>
+              <th id=arrow-referenceVersion><a href="javascript: sort('referenceVersion')">Reference Version</a></th>
               <th id=arrow-maintainers><a href="javascript: sort('maintainers')">Maintainers</a></th>
             </tr>
           </thead>

src/Distribution/Server/Features/Browse.hs

@@ -139,15 +139,15 @@ 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
     , Key.fromString "votes" .= itemVotes
     , 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

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

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

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

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,33 @@ data PackageItem = PackageItem {
     itemLastUpload :: !UTCTime,
     -- Hotness = recent downloads + stars + 2 * no rev deps
     itemHotness :: !Float,
-    -- Last version
-    itemLastVersion :: !String
+    -- 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)
 
 
 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,
+      itemReferenceVersion = ""
+  }
 
 
 initListFeature :: ServerEnv
@@ -134,10 +151,14 @@ 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
+        index <- queryGetPackageIndex
+        let allVersions = packageVersion <$> PackageIndex.lookupPackageName index pkgname
+        modifyItem pkgname $ \x ->
+            updateReferenceVersion prefsinfo allVersions $
+              x
+                { itemLastUpload = fst (pkgOriginalUploadInfo pkg)
+                }
         runHook_ itemUpdate (Set.singleton pkgname)
 
       registerHook groupChangedHook $ \(gd,_,_,_,_) ->
@@ -174,6 +195,11 @@ initListFeature _env = do
           modifyItem pkgname (updateDeprecation mpkgs)
           runHook_ itemUpdate (Set.singleton pkgname)
 
+      registerHook updatePreferredHook $ \(pkgname, prefsinfo) -> do
+          index <- queryGetPackageIndex
+          let allVersions = packageVersion <$> PackageIndex.lookupPackageName index pkgname
+          modifyItem pkgname $ updateReferenceVersion prefsinfo allVersions
+
       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 [pkgVersion (pkgInfoId pkg)] $ (updateDescriptionItem desc $ emptyPackageItem pkgname) {
             itemTags       = tags
           , itemMaintainer = map (userIdToName users) (UserIdSet.toList maintainers)
           , itemDeprecated = deprs
@@ -275,7 +302,6 @@ listFeature CoreFeature{..}
           , itemLastUpload = fst (pkgOriginalUploadInfo pkg)
           , itemRevDepsCount = intRevDirectCount
           , itemHotness = votes + fromIntegral (cmFind pkgname downs) + fromIntegral intRevDirectCount * 2
-          , itemLastVersion = prettyShow $ pkgVersion $ pkgInfoId pkg
           }
 
     ------------------------------
@@ -329,6 +355,17 @@ updateDeprecation pkgs item =
         itemDeprecated = pkgs
     }
 
+updateReferenceVersion :: PreferredInfo -> [Version] -> PackageItem -> PackageItem
+updateReferenceVersion prefsinfo allVersions item =
+    item {
+        itemReferenceVersion =
+          case nonDeprecatedVersion of
+            [] -> ""
+            xs -> prettyShow $ maximum xs
+    }
+  where
+    nonDeprecatedVersion = filter (`notElem` deprecatedVersions prefsinfo) allVersions
+
 updateReverseItem :: Int -> PackageItem -> PackageItem
 updateReverseItem revDirectCount item =
     item {

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