diff --git a/datafiles/static/browse.js b/datafiles/static/browse.js index 4c79adcb..90bcec8b 100644 --- a/datafiles/static/browse.js +++ b/datafiles/static/browse.js @@ -135,6 +135,7 @@ const replaceRows = (response) => { tr.appendChild(createLastUpload(row.lastUpload)); tr.appendChild(createSimpleText(row.referenceVersion)); tr.appendChild(createMaintainers(row.maintainers)); + tr.appendChild(createSimpleText(row.packageRank)); l.appendChild(tr); } }; diff --git a/datafiles/templates/Html/browse.html.st b/datafiles/templates/Html/browse.html.st index ddc240e7..aa919775 100644 --- a/datafiles/templates/Html/browse.html.st +++ b/datafiles/templates/Html/browse.html.st @@ -93,6 +93,9 @@ #arrow-maintainers { width: 100px; } + #arrow-packageRank { + width: 150px; + } .lastUpload, #sliderAndOutput { white-space: nowrap; } @@ -214,6 +217,7 @@ Last U/L Reference Version Maintainers + Package Rank diff --git a/datafiles/templates/Html/noscript-search-form.html.st b/datafiles/templates/Html/noscript-search-form.html.st index 7c1f318e..55c242af 100644 --- a/datafiles/templates/Html/noscript-search-form.html.st +++ b/datafiles/templates/Html/noscript-search-form.html.st @@ -23,6 +23,7 @@ + diff --git a/hackage-server.cabal b/hackage-server.cabal index 50576dfd..49093162 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -348,6 +348,8 @@ library Distribution.Server.Features.PackageCandidates.Backup Distribution.Server.Features.PackageFeed Distribution.Server.Features.PackageList + Distribution.Server.Features.PackageList.PackageRank + Distribution.Server.Features.PackageList.MStats Distribution.Server.Features.Distro Distribution.Server.Features.Distro.Distributions Distribution.Server.Features.Distro.Backup diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs index 9755fce2..94e1df57 100644 --- a/src/Distribution/Server/Features.hs +++ b/src/Distribution/Server/Features.hs @@ -291,6 +291,8 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do versionsFeature usersFeature uploadFeature + documentationCoreFeature + tarIndexCacheFeature searchFeature <- mkSearchFeature coreFeature diff --git a/src/Distribution/Server/Features/Browse.hs b/src/Distribution/Server/Features/Browse.hs index 9b53e01b..33c41f5e 100644 --- a/src/Distribution/Server/Features/Browse.hs +++ b/src/Distribution/Server/Features/Browse.hs @@ -10,6 +10,7 @@ import qualified Data.Set as S import Data.Time (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show) import System.FilePath (()) +import GHC.Float.RealFracMethods (roundFloatInteger) import Data.Aeson (Value(Array), object, toJSON, (.=)) import qualified Data.Aeson.Key as Key @@ -139,7 +140,8 @@ packageIndexInfoToValue :: CoreResource -> TagsResource -> UserResource -> Packa packageIndexInfoToValue coreResource tagsResource userResource PackageItem{itemName, itemDownloads, itemVotes, - itemDesc, itemTags, itemLastUpload, itemReferenceVersion, itemMaintainer} = + itemDesc, itemTags, itemLastUpload, + itemReferenceVersion, itemMaintainer, itemPackageRank} = object [ Key.fromString "name" .= renderPackage itemName , Key.fromString "downloads" .= itemDownloads @@ -149,6 +151,7 @@ packageIndexInfoToValue , Key.fromString "lastUpload" .= iso8601Show itemLastUpload , Key.fromString "referenceVersion" .= itemReferenceVersion , Key.fromString "maintainers" .= map renderUser itemMaintainer + , Key.fromString "packageRank" .= (roundFloatInteger (1000 * itemPackageRank)) ] where renderTag :: Tag -> Value diff --git a/src/Distribution/Server/Features/Browse/ApplyFilter.hs b/src/Distribution/Server/Features/Browse/ApplyFilter.hs index f129109f..4b33c97d 100644 --- a/src/Distribution/Server/Features/Browse/ApplyFilter.hs +++ b/src/Distribution/Server/Features/Browse/ApplyFilter.hs @@ -65,6 +65,7 @@ sort isSearch sortColumn sortDirection = LastUpload -> comparing itemLastUpload ReferenceVersion -> comparing itemReferenceVersion Maintainers -> comparing itemMaintainer + PackageRank -> comparing itemPackageRank in sortBy (maybeReverse comparer) where maybeReverse = diff --git a/src/Distribution/Server/Features/Browse/Options.hs b/src/Distribution/Server/Features/Browse/Options.hs index 64416b35..e8145814 100644 --- a/src/Distribution/Server/Features/Browse/Options.hs +++ b/src/Distribution/Server/Features/Browse/Options.hs @@ -9,7 +9,8 @@ import Distribution.Server.Features.Browse.Parsers (Filter, conditions, condsToF data IsSearch = IsSearch | IsNotSearch -data NormalColumn = Name | Downloads | Rating | Description | Tags | LastUpload | ReferenceVersion | Maintainers +data NormalColumn = Name | Downloads | Rating | Description | Tags | + LastUpload | ReferenceVersion | Maintainers | PackageRank deriving (Show, Eq) data Column = DefaultColumn | NormalColumn NormalColumn @@ -38,6 +39,7 @@ instance FromJSON Column where "lastUpload" -> pure $ NormalColumn LastUpload "referenceVersion" -> pure $ NormalColumn ReferenceVersion "maintainers" -> pure $ NormalColumn Maintainers + "packageRank" -> pure $ NormalColumn PackageRank t -> fail $ "Column invalid: " ++ T.unpack t columnToTemplateName :: Column -> String @@ -51,6 +53,7 @@ columnToTemplateName = \case NormalColumn LastUpload -> "lastUpload" NormalColumn ReferenceVersion -> "referenceVersion" NormalColumn Maintainers -> "maintainers" + NormalColumn PackageRank -> "packageRank" instance FromJSON Direction where parseJSON = diff --git a/src/Distribution/Server/Features/HaskellPlatform.hs b/src/Distribution/Server/Features/HaskellPlatform.hs index 9d0840bd..15be3e81 100644 --- a/src/Distribution/Server/Features/HaskellPlatform.hs +++ b/src/Distribution/Server/Features/HaskellPlatform.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-} module Distribution.Server.Features.HaskellPlatform ( - PlatformFeature, + PlatformFeature(..), PlatformResource(..), initPlatformFeature, ) where diff --git a/src/Distribution/Server/Features/PackageList.hs b/src/Distribution/Server/Features/PackageList.hs index d2b063c2..d2ede35f 100644 --- a/src/Distribution/Server/Features/PackageList.hs +++ b/src/Distribution/Server/Features/PackageList.hs @@ -15,6 +15,10 @@ import Distribution.Server.Features.DownloadCount import Distribution.Server.Features.Tags import Distribution.Server.Features.Users import Distribution.Server.Features.Upload(UploadFeature(..)) +import Distribution.Server.Features.Documentation (DocumentationFeature(..)) +import Distribution.Server.Features.TarIndexCache (TarIndexCacheFeature(..)) +import Distribution.Server.Features.PackageList.PackageRank + import Distribution.Server.Users.Users (userIdToName) import qualified Distribution.Server.Users.UserIdSet as UserIdSet import Distribution.Server.Users.Group(UserGroup(..), GroupDescription(..)) @@ -31,6 +35,7 @@ import Distribution.PackageDescription.Configuration import Distribution.Pretty (prettyShow) import Distribution.Types.Version (Version) import Distribution.Utils.ShortText (fromShortText) +import Distribution.Simple.Utils (safeLast) import Control.Concurrent import qualified Data.List.NonEmpty as NE @@ -41,7 +46,6 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Time.Clock (UTCTime(..)) - data ListFeature = ListFeature { listFeatureInterface :: HackageFeature, @@ -91,11 +95,13 @@ data PackageItem = PackageItem { -- Hotness = recent downloads + stars + 2 * no rev deps itemHotness :: !Float, -- Reference version (non-deprecated highest numbered version) - itemReferenceVersion :: !String + itemReferenceVersion :: !String, + -- heuristic way to sort packages + itemPackageRank :: !Float } 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 r) = memSize12 a b c d e f g h i j (k, l, n, o) r emptyPackageItem :: PackageName -> PackageItem @@ -115,10 +121,10 @@ emptyPackageItem pkg = itemNumBenchmarks = 0, itemLastUpload = UTCTime (toEnum 0) 0, itemHotness = 0, - itemReferenceVersion = "" + itemReferenceVersion = "", + itemPackageRank = 0 } - initListFeature :: ServerEnv -> IO (CoreFeature -> ReverseFeature @@ -128,6 +134,8 @@ initListFeature :: ServerEnv -> VersionsFeature -> UserFeature -> UploadFeature + -> DocumentationFeature + -> TarIndexCacheFeature -> IO ListFeature) initListFeature _env = do itemCache <- newMemStateWHNF Map.empty @@ -140,11 +148,12 @@ initListFeature _env = do tagsf@TagsFeature{..} versions@VersionsFeature{..} users@UserFeature{..} - uploads@UploadFeature{..} -> do + uploads@UploadFeature{..} + documentation tar -> do let (feature, modifyItem, updateDesc) = listFeature core revs download votesf tagsf versions users uploads - itemCache itemUpdate + itemCache itemUpdate documentation tar _env registerHookJust packageChangeHook isPackageChangeAny $ \(pkgid, _) -> updateDesc (packageName pkgid) @@ -213,19 +222,23 @@ listFeature :: CoreFeature -> UploadFeature -> MemState (Map PackageName PackageItem) -> Hook (Set PackageName) () + -> DocumentationFeature + -> TarIndexCacheFeature + -> ServerEnv -> (ListFeature, PackageName -> (PackageItem -> PackageItem) -> IO (), PackageName -> IO ()) listFeature CoreFeature{..} - ReverseFeature{revDirectCount} + ReverseFeature{revDirectCount, revPackageStats} DownloadFeature{..} VotesFeature{..} TagsFeature{..} - VersionsFeature{..} + versions@VersionsFeature{..} UserFeature{..} UploadFeature{..} itemCache itemUpdate + documentation tar env = (ListFeature{..}, modifyItem, updateDesc) where listFeatureInterface = (emptyHackageFeature "list") { @@ -256,7 +269,7 @@ listFeature CoreFeature{..} let pkgs = PackageIndex.lookupPackageName index pkgname case pkgs of [] -> return () --this shouldn't happen - _ -> modifyMemState itemCache . uncurry Map.insert =<< constructItem (last pkgs) + _ -> modifyMemState itemCache . uncurry Map.insert =<< constructItem pkgs updateDesc pkgname = do index <- queryGetPackageIndex @@ -277,14 +290,16 @@ listFeature CoreFeature{..} constructItemIndex :: IO (Map PackageName PackageItem) constructItemIndex = do index <- queryGetPackageIndex - items <- mapM (constructItem . last) $ PackageIndex.allPackagesByName index + items <- mapM constructItem $ PackageIndex.allPackagesByName index return $ Map.fromList items - constructItem :: PkgInfo -> IO (PackageName, PackageItem) - constructItem pkg = do + constructItem :: [PkgInfo] -> IO (PackageName, PackageItem) + constructItem pkgs = do let pkgname = packageName pkg desc = pkgDesc pkg - intRevDirectCount <- revDirectCount pkgname + pkg = last pkgs + -- [reverse index disabled] revCount <- query . GetReverseCount $ pkgname + revCount@(ReverseCount intRevDirectCount _) <- revPackageStats pkgname users <- queryGetUserDb tags <- queryTagsForPackage pkgname downs <- recentPackageDownloads @@ -292,6 +307,8 @@ listFeature CoreFeature{..} deprs <- queryGetDeprecatedFor pkgname maintainers <- queryUserGroup (maintainersGroup pkgname) prefsinfo <- queryGetPreferredInfo pkgname + packageR <- rankPackage versions (cmFind pkgname downs) (UserIdSet.size maintainers) + documentation tar env pkgs (safeLast pkgs) revCount return $ (,) pkgname . updateReferenceVersion prefsinfo [pkgVersion (pkgInfoId pkg)] $ (updateDescriptionItem desc $ emptyPackageItem pkgname) { itemTags = tags @@ -302,6 +319,7 @@ listFeature CoreFeature{..} , itemLastUpload = fst (pkgOriginalUploadInfo pkg) , itemRevDepsCount = intRevDirectCount , itemHotness = votes + fromIntegral (cmFind pkgname downs) + fromIntegral intRevDirectCount * 2 + , itemPackageRank = packageR } ------------------------------ diff --git a/src/Distribution/Server/Features/PackageList/MStats.hs b/src/Distribution/Server/Features/PackageList/MStats.hs new file mode 100644 index 00000000..b9dc0493 --- /dev/null +++ b/src/Distribution/Server/Features/PackageList/MStats.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, ConstraintKinds #-} +module Distribution.Server.Features.PackageList.MStats + ( parseM + , sumMStat + , getListsTables + , getCode + , getHCode + , getSections + , MStats(..) + ) where + +import Commonmark +import Commonmark.Extensions +import Control.Monad.Identity +import qualified Data.ByteString.Lazy as BS + ( ByteString + , toStrict ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T + ( lenientDecode ) + +-- parses markdown into statistics needed for readmeScore +parseM :: BS.ByteString -> FilePath -> Either ParseError [MarkdownStats] +parseM md name = runIdentity + (commonmarkWith (pipeTableSpec <> defaultSyntaxSpec) name txt) + where txt = T.decodeUtf8With T.lenientDecode . BS.toStrict $ md + +data MarkdownStats = NotImportant MStats | + HCode MStats | + Code MStats | + Section MStats | + Table Int MStats | -- Int of rows + PText MStats | + List Int MStats -- Int of elements + deriving (Show) + +data MStats = MStats Int Int --number of pictures, number of chars + deriving Show + +instance Monoid MStats where + mempty = MStats 0 0 + +instance Rangeable MStats where + ranged = const id + +instance HasAttributes MStats where + addAttributes = const id + +instance Semigroup MStats where + (MStats a b) <> (MStats c d) = MStats (a + c) (b + d) + +-- Getter functions + +getCode :: [MarkdownStats] -> (Int, Int) -- number of code blocks, size of code +getCode [] = (0, 0) +getCode (Code (MStats codeT _) : xs) = (1, codeT) >< getCode xs +getCode (HCode (MStats codeT _) : xs) = (1, codeT) >< getCode xs +getCode (_ : xs) = getCode xs + +getHCode :: [MarkdownStats] -> (Int, Int) -- number of code blocks, size of code +getHCode [] = (0, 0) +getHCode (HCode (MStats codeT _) : xs) = (1, codeT) >< getHCode xs +getHCode (_ : xs) = getHCode xs + +getSections :: [MarkdownStats] -> Int -- number of code blocks, size of code +getSections [] = 0 +getSections (Section _ : xs) = 1 + getSections xs +getSections (_ : xs) = getSections xs + +sumMStat :: [MarkdownStats] -> MStats +sumMStat [] = mempty +sumMStat (x : xs) = case x of + (NotImportant a) -> a <> sumMStat xs + (Section a) -> a <> sumMStat xs + (List _ a ) -> a <> sumMStat xs + (Table _ a ) -> a <> sumMStat xs + (HCode a ) -> a <> sumMStat xs + (Code a ) -> a <> sumMStat xs + (PText a ) -> a <> sumMStat xs + +getListsTables :: [MarkdownStats] -> Int +getListsTables [] = 0 +getListsTables ((List a _) : ys) = a + getListsTables ys +getListsTables ((Table a _) : ys) = a + getListsTables ys +getListsTables (_ : ys) = getListsTables ys + +-- helper +(><) :: (Int, Int) -> (Int, Int) -> (Int, Int) +(><) (a, b) (c, d) = (a + c, b + d) + +-- INSTANCES +instance Rangeable [MarkdownStats] where + ranged = const id + +instance HasAttributes [MarkdownStats] where + addAttributes = const id + +instance HasPipeTable MStats [MarkdownStats] where + pipeTable _ _ rows = [Table (length rows) (mconcat $ mconcat <$> rows)] + +instance IsInline MStats where + lineBreak = MStats 0 1 + softBreak = MStats 0 1 + str t = MStats 0 (T.length t) + entity t = MStats 0 (T.length t) + escapedChar _ = MStats 0 1 + emph = id + strong = id + link _ _ a = a + image _ _ (MStats a b) = MStats (a + 1) b + code t = MStats 0 (T.length t) + rawInline _ t = MStats 0 (T.length t) + +instance IsBlock MStats [MarkdownStats] where + paragraph a = [PText a] + plain a = [PText a] + thematicBreak = [NotImportant mempty] + blockQuote = id + codeBlock language codeT | language == T.pack "haskell" = [HCode (code codeT)] + | otherwise = [Code (code codeT)] + heading _ a = [Section a] + rawBlock _ _ = [NotImportant mempty] + referenceLinkDefinition _ _ = [NotImportant mempty] + list _ _ l = [List (length l + sumLT l) (mconcat $ sumMStat <$> l)] + where sumLT a = sum (getListsTables <$> a) diff --git a/src/Distribution/Server/Features/PackageList/PackageRank.hs b/src/Distribution/Server/Features/PackageList/PackageRank.hs new file mode 100644 index 00000000..b105e247 --- /dev/null +++ b/src/Distribution/Server/Features/PackageList/PackageRank.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +module Distribution.Server.Features.PackageList.PackageRank + ( rankPackage + ) where + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Server.Features.Documentation + ( DocumentationFeature(..) ) +import Distribution.Server.Features.PackageList.MStats +import Distribution.Server.Features.ReverseDependencies (ReverseCount(..)) +import Distribution.Server.Features.PreferredVersions +import Distribution.Server.Features.PreferredVersions.State +import Distribution.Server.Features.TarIndexCache +import qualified Distribution.Server.Framework.BlobStorage + as BlobStorage +import Distribution.Server.Framework.ServerEnv + ( ServerEnv(..) ) +import Distribution.Server.Packages.Types +import Distribution.Server.Util.Markdown + ( supposedToBeMarkdown ) +import Distribution.Server.Util.ServeTarball + ( loadTarEntry ) +import Distribution.Simple.Utils ( safeHead + , safeLast ) +import Distribution.Types.Version +import qualified Distribution.Utils.ShortText as S + +import qualified Codec.Archive.Tar as Tar +import Control.Exception ( SomeException(..) + , handle ) +import qualified Data.ByteString.Lazy as BSL +import Data.List ( maximumBy + , sortBy ) +import Data.Maybe ( isNothing ) +import Data.Ord ( comparing ) +import qualified Data.Time.Clock as CL +import Distribution.Server.Packages.Readme +import GHC.Float ( int2Float ) +import System.FilePath ( isExtensionOf ) + +-- HELPER FUNCTIONS + +handleConst :: a -> IO a -> IO a +handleConst c = handle (\(_ :: SomeException) -> return c) + +-- Scorer stores rank information +data Scorer = Scorer + { maximumS :: !Float + , score :: !Float + } + deriving Show + +instance Semigroup Scorer where + (Scorer a b) <> (Scorer c d) = Scorer (a + c) (b + d) + +scorer :: Float -> Float -> Scorer +scorer maxim scr = + if maxim >= scr then Scorer maxim scr else Scorer maxim maxim + +fracScor :: Float -> Float -> Scorer +fracScor maxim frac = scorer maxim (min (maxim * frac) maxim) + +boolScor :: Float -> Bool -> Scorer +boolScor k True = Scorer k k +boolScor k False = Scorer k 0 + +total :: Scorer -> Float +total (Scorer a b) = b / a + +scale :: Float -> Scorer -> Scorer +scale mx sc = fracScor mx (total sc) + +-- calculates number of versions from version list + +major :: Num a => [a] -> a +major (x : _) = x +major _ = 0 +minor :: Num a => [a] -> a +minor (_ : y : _) = y +minor _ = 0 +patches :: Num a => [a] -> a +patches (_ : _ : xs) = sum xs +patches _ = 0 + +numDays :: Maybe CL.UTCTime -> Maybe CL.UTCTime -> Float +numDays (Just first) (Just end) = + fromRational $ toRational $ CL.diffUTCTime first end / fromRational + (toRational CL.nominalDay) +numDays _ _ = 0 + +-- Score Calculations + +freshness :: [Version] -> CL.UTCTime -> Bool -> IO Float +freshness [] _ _ = return 0 +freshness (x : xs) lastUpd app = + daysPastExpiration + >>= (\dExp -> return $ max 0 $ (decayDays - dExp) / decayDays) + where + versionLatest = versionNumbers x + daysPastExpiration = + age >>= (\a -> return $ max 0 a - expectedUpdateInterval) + expectedUpdateInterval = + int2Float (min (versionStabilityInterval versionLatest) $ length (x : xs)) + versionStabilityInterval v | patches v > 3 && major v > 0 = 700 + | patches v > 3 = 450 + | patches v > 0 = 300 + | major v > 0 = 200 + | minor v > 3 = 140 + | otherwise = 80 + age = flip numDays (Just lastUpd) . Just <$> CL.getCurrentTime + decayDays = expectedUpdateInterval / 2 + (if app then 300 else 200) + +cabalScore :: PackageDescription -> Bool -> Scorer +cabalScore p docum = + tests <> benchs <> desc <> homeP <> sourceRp <> cats <> boolScor 30 docum + where + tests = boolScor 30 (hasTests p) + benchs = boolScor 10 (hasBenchmarks p) + desc = scorer 30 (min 1 (int2Float (S.length $ description p) / 300)) + homeP = boolScor 30 (not $ S.null $ homepage p) + sourceRp = boolScor 8 (not $ null $ sourceRepos p) + cats = boolScor 5 (not $ S.null $ category p) + +readmeScore :: TarIndexCacheFeature -> PkgInfo -> Bool -> IO Scorer +readmeScore tarCache pkgI app = do + Just (tarfile, _, offset, name) <- readme + entr <- loadTarEntry tarfile offset + case entr of + (Right (size, str)) -> return $ calcScore str size name + _ -> return $ Scorer 1 0 + where + readme = findToplevelFile tarCache pkgI isReadmeFile + >>= either (\_ -> return Nothing) (return . Just) + calcScore str size filename = + scorer 75 (min 1 (fromInteger (toInteger size) / 3000)) + <> if supposedToBeMarkdown filename + then case parseM str filename of + Left _ -> Scorer 0 0 + Right mdStats -> format mdStats + else Scorer 0 0 + format stats = + fracScor (if app then 25 else 100) (min 1 $ int2Float hlength / 2000) + <> scorer (if app then 15 else 27) (int2Float blocks * 3) + <> boolScor (if app then 10 else 30) (clength > 150) + <> scorer 35 (int2Float images * 10) + <> scorer 30 (int2Float sections * 4) + <> scorer 25 (int2Float rows * 2) + where + (blocks, clength) = getCode stats + (_ , hlength) = getHCode stats + MStats _ images = sumMStat stats + rows = getListsTables stats + sections = getSections stats + +authorScore :: Int -> PackageDescription -> Scorer +authorScore maintainers desc = + boolScor 1 (not $ S.null $ author desc) <> maintScore + where + maintScore = boolScor 3 (maintainers > 1) <> scorer 5 (int2Float maintainers) + +codeScore :: Float -> Float -> Scorer +codeScore documentS haskellL = + boolScor 1 (haskellL > 700) + <> boolScor 1 (haskellL < 80000) + <> fracScor 2 (min 1 (haskellL / 5000)) + <> fracScor 2 (min 1 (documentS / ((3000 + haskellL) * 1600))) + +versionScore + :: [Version] + -> VersionsFeature + -> [CL.UTCTime] + -> PackageDescription + -> IO Scorer +versionScore versionList versions lastUploads desc = do + use <- intUsable + depre <- deprec + return $ calculateScore depre lastUploads use + where + pkgNm = pkgName $ package desc + partVers = + flip partitionVersions versionList <$> queryGetPreferredInfo versions pkgNm + intUsable = do + (norm, _, unpref) <- partVers + return $ versionNumbers <$> norm ++ unpref + deprec = do + (_, deprecN, _) <- partVers + return deprecN + calculateScore :: [Version] -> [CL.UTCTime] -> [[Int]] -> Scorer + calculateScore depre lUps intUse = + boolScor 20 (length intUse > 1) + <> scorer 40 (numDays (safeHead lUps) (safeLast lUps) / 11) + <> scorer + 15 + (int2Float $ length $ filter (\x -> major x > 0 || minor x > 0) + intUse + ) + <> scorer + 20 + (int2Float $ 4 * length + (filter (\x -> major x > 0 && patches x > 0) intUse) + ) + <> scorer 10 (int2Float $ patches $ maximumBy (comparing patches) intUse) + <> boolScor 8 (any (\x -> major x == 0 && patches x > 0) intUse) + <> boolScor 10 (any (\x -> major x > 0 && major x < 20) intUse) + <> boolScor 5 (not $ null depre) + +baseScore + :: VersionsFeature + -> Int + -> DocumentationFeature + -> ServerEnv + -> TarIndexCacheFeature + -> [Version] + -> [CL.UTCTime] + -> PkgInfo + -> IO Scorer + +baseScore vers maintainers docs env tarCache versionList lastUploads pkgI = do + + hasDocum <- handleConst False documHas -- Probably redundant + documS <- handleConst 0 documSize + srcL <- handleConst 0 srcLines + + versS <- handleConst (Scorer 1 0) + (versionScore versionList vers lastUploads pkg) + readmeS <- handleConst (Scorer 1 0) (readmeScore tarCache pkgI isApp) + return + $ scale 5 versS + <> scale 2 (codeScore documS srcL) + <> scale 3 (authorScore maintainers pkg) + <> scale 2 (cabalScore pkg hasDocum) + <> scale 5 readmeS + where + pkg = packageDescription $ pkgDesc pkgI + pkgId = package pkg + isApp = (isNothing . library) pkg && (not . null . executables) pkg + srcLines = do + Right (path, _, _) <- packageTarball tarCache pkgI + filterLines (isExtensionOf ".hs") countLines + . Tar.read + <$> BSL.readFile path + documSize = do + path <- documentPath + case path of + Nothing -> return 0 + Just pth -> + filterLines (isExtensionOf ".html") countSize + . Tar.read + <$> BSL.readFile pth + filterLines f g = Tar.foldEntries (g f) 0 (const 0) + countLines :: (FilePath -> Bool) -> Tar.Entry -> Float -> Float + countLines f entry l = if not . f . Tar.entryPath $ entry then l else lns + where + !lns = case Tar.entryContent entry of + (Tar.NormalFile str _) -> l + (int2Float . length $ BSL.split 10 str) + _ -> l + -- TODO might need to decode/add the other separator + countSize :: (FilePath -> Bool) -> Tar.Entry -> Float -> Float + countSize f entry l = if not . f . Tar.entryPath $ entry then l else s + where + !s = case Tar.entryContent entry of + (Tar.NormalFile _ siz) -> l + fromInteger (toInteger siz) + _ -> l + + documentBlob :: IO (Maybe BlobStorage.BlobId) + documentBlob = queryDocumentation docs pkgId + documentPath = do + blob <- documentBlob + return $ BlobStorage.filepath (serverBlobStore env) <$> blob + documHas = queryHasDocumentation docs pkgId + +temporalScore + :: PackageDescription -> [CL.UTCTime] -> [Version] -> Int -> ReverseCount -> IO Scorer +temporalScore p lastUploads versionList recentDownloads (ReverseCount dir tot) = do + fresh <- freshnessScore + tract <- tractionScore + return $ tract <> fresh <> downloadScore <> (if isApp then scorer 0 2 else dirScore <> indirScore) + where + isApp = (isNothing . library) p && (not . null . executables) p + downloadScore = calcDownScore recentDownloads + dirScore = fracScor 5 (logBase 2 (int2Float $ max 0 (dir - 32) + 32) - 5) + indirScore = fracScor 2 (logBase 2 (int2Float $ max 0 (tot - dir - 32) + 32) + - 5 / 3) + calcDownScore i = fracScor + 5 + ( logBase 2 (int2Float $ max 0 (i - 16) + 16) + - (if isApp then 3 else 4) + ) + packageFreshness = case safeHead lastUploads of + Nothing -> return 0 + (Just l) -> freshness versionList l isApp -- Getting time hopefully does not throw Exc. + freshnessScore = fracScor 10 <$> packageFreshness + -- Missing dependencyFreshnessScore for reasonable effectivity needs caching + tractionScore = do + fresh <- packageFreshness + return $ boolScor 1 (fresh * int2Float recentDownloads > 200) + +rankPackage + :: VersionsFeature + -> Int + -> Int + -> DocumentationFeature + -> TarIndexCacheFeature + -> ServerEnv + -> [PkgInfo] + -> Maybe PkgInfo + -> ReverseCount + -> IO Float +rankPackage _ _ _ _ _ _ _ Nothing _ = return 0 +rankPackage versions recentDownloads maintainers docs tarCache env pkgs (Just pkgUsed) revCount + = do + t <- temporalScore pkgD uploads versionList recentDownloads revCount + + b <- baseScore versions + maintainers + docs + env + tarCache + versionList + uploads + pkgUsed + depr <- handleConst Nothing deprP + return $ sAverage t b * case depr of + Nothing -> 1 + _ -> 0.2 + where + pkgname = pkgName . package $ pkgD + pkgD = packageDescription . pkgDesc $ pkgUsed + deprP = queryGetDeprecatedFor versions pkgname + sAverage x y = (total x + total y) * 0.5 + + versionList :: [Version] + versionList = sortBy (flip compare) + $ map (pkgVersion . package . packageDescription) (pkgDesc <$> pkgs) + uploads = + sortBy (flip compare) + $ (fst . pkgOriginalUploadInfo <$> pkgs) + ++ (fst . pkgLatestUploadInfo <$> pkgs)