diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 0aa3a3c9e..4f2631d62 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,18 +8,24 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.14.3.20220416 +# version: 0.15.20220822 # -# REGENDATA ("0.14.3.20220416",["github","hackage-server.cabal"]) +# REGENDATA ("0.15.20220822",["github","hackage-server.cabal"]) # name: Haskell-CI on: - - push - - pull_request + push: + branches: + - master + - ci* + pull_request: + branches: + - master + - ci* jobs: linux: name: Haskell-CI - Linux - ${{ matrix.compiler }} - runs-on: ubuntu-18.04 + runs-on: ubuntu-20.04 timeout-minutes: 60 container: @@ -28,9 +34,9 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.2.2 + - compiler: ghc-9.2.4 compilerKind: ghc - compilerVersion: 9.2.2 + compilerVersion: 9.2.4 setup-method: ghcup allow-failure: false - compiler: ghc-9.0.2 @@ -56,10 +62,10 @@ jobs: apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 if [ "${{ matrix.setup-method }}" = ghcup ]; then mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" - "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) apt-get update apt-get install -y libbrotli-dev else @@ -67,9 +73,9 @@ jobs: apt-get update apt-get install -y "$HCNAME" libbrotli-dev mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 + "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) fi env: HCKIND: ${{ matrix.compilerKind }} @@ -212,7 +218,7 @@ jobs: ${CABAL} -vnormal check - name: haddock run: | - $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all + $CABAL v2-haddock --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all - name: unconstrained build run: | rm -f cabal.project.local diff --git a/.github/workflows/nix-shell.yml b/.github/workflows/nix-shell.yml index 06b6e2781..80cb6f1ac 100644 --- a/.github/workflows/nix-shell.yml +++ b/.github/workflows/nix-shell.yml @@ -1,7 +1,13 @@ name: "Test nix-shell" on: - - push - - pull_request + push: + branches: + - master + - ci* + pull_request: + branches: + - master + - ci* jobs: nix-shell: runs-on: ubuntu-latest diff --git a/cabal.haskell-ci b/cabal.haskell-ci index bc8774bef..e8ddbd02d 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -1,3 +1,5 @@ +branches: master ci* + installed: +all -Cabal -text -parsec -- -- irc-channels works with GHA, but why send to a channel @@ -11,4 +13,9 @@ installed: +all -Cabal -text -parsec -- Use Ubuntu 20.04 distribution: focal -apt: libbrotli-dev \ No newline at end of file +apt: libbrotli-dev + +-- Make sure the haddock step is included, +-- even though we don't define any library. +haddock-components: all + -- since haskell-ci 0.15.20220822 diff --git a/datafiles/static/browse.js b/datafiles/static/browse.js index 905239afc..cfb8a7dfd 100644 --- a/datafiles/static/browse.js +++ b/datafiles/static/browse.js @@ -134,6 +134,7 @@ const replaceRows = (response) => { tr.appendChild(createTags(row.tags)); tr.appendChild(createLastUpload(row.lastUpload)); 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 a7b85a496..f9d2b58b6 100644 --- a/datafiles/templates/Html/browse.html.st +++ b/datafiles/templates/Html/browse.html.st @@ -130,6 +130,9 @@ #arrow-maintainers { width: 100px; } + #arrow-packageRank { + width: 150px; + } .lastUpload, #sliderAndOutput { white-space: nowrap; } @@ -250,6 +253,7 @@ Tags Last U/L Maintainers + Package Rank diff --git a/datafiles/templates/Html/noscript-search-form.html.st b/datafiles/templates/Html/noscript-search-form.html.st index 7c1f318e4..55c242afe 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 c32615ea9..60a6a63f7 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -27,7 +27,7 @@ copyright: 2008-2015 Duncan Coutts, license: BSD-3-Clause license-file: LICENSE -tested-with: GHC == { 9.2.2, 9.0.2, 8.10.7, 8.8.4 } +tested-with: GHC == { 9.2.4, 9.0.2, 8.10.7, 8.8.4 } data-dir: datafiles data-files: @@ -116,8 +116,11 @@ common defaults , scientific -- other dependencies shared by most components build-depends: - , aeson ^>= 2.0.3.0 + , aeson ^>= 2.0.3.0 || ^>= 2.1.0.0 , Cabal ^>= 3.6.3.0 + , Cabal-syntax ^>= 3.6.0.0 + -- Cabal-syntax needs to be bound to constrain hackage-security + -- see https://github.com/haskell/hackage-server/issues/1130 , fail ^>= 4.9.0 -- we use Control.Monad.Except, introduced in mtl-2.2.1 , network >= 3 && < 3.2 @@ -126,7 +129,7 @@ common defaults , parsec ^>= 3.1.13 , tar ^>= 0.5 , unordered-containers ^>= 0.2.10 - , vector ^>= 0.12 + , vector ^>= 0.12 || ^>= 0.13.0.0 , zlib ^>= 0.6.2 ghc-options: -Wall -fwarn-tabs -fno-warn-unused-do-bind -fno-warn-deprecated-flags -funbox-strict-fields @@ -307,6 +310,8 @@ library lib-server 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 @@ -374,7 +379,7 @@ library lib-server , async ^>= 2.2.1 -- requires bumping http-io-streams , attoparsec ^>= 0.14.4 - , attoparsec-iso8601 ^>= 1.0 + , attoparsec-iso8601 ^>= 1.0 || ^>= 1.1.0.0 , base16-bytestring ^>= 1.0 -- requires bumping http-io-streams , base64-bytestring ^>= 1.2.1.0 @@ -390,18 +395,23 @@ library lib-server , cryptohash-sha256 ^>= 0.11.100 , csv ^>= 0.1 , ed25519 ^>= 0.0.5 - , hackage-security ^>= 0.6 + , hackage-security >= 0.6 && < 0.7 + -- N.B: hackage-security-0.6.2 uses Cabal-syntax-3.8.1.0 + -- see https://github.com/haskell/hackage-server/issues/1130 + -- Thus, we need to include Cabal-syntax as dependency explicitly , hackage-security-HTTP ^>= 0.1.1 - , haddock-library > 1.7 && < 2 - , happstack-server ^>= 7.7.1 - , hashable ^>= 1.3 || ^>= 1.4 + , haddock-library ^>= 1.11.0 + -- haddock-library-1.11.0 changed type of markupOrderedList + -- see https://github.com/haskell/hackage-server/issues/1128 + , happstack-server ^>= 7.7.1 || ^>= 7.8.0 + , hashable ^>= 1.3 || ^>= 1.4 , hslogger ^>= 1.3.1 , lifted-base ^>= 0.2.1 , mime-mail ^>= 0.5 , random ^>= 1.2 , rss ^>= 3000.2.0.7 , safecopy ^>= 0.10 - , semigroups ^>= 0.19 + , semigroups ^>= 0.20 , split ^>= 0.2 , stm ^>= 2.5.0 , tagged ^>= 0.8.5 diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs index f8a8e362e..2b478d5fb 100644 --- a/src/Distribution/Server/Features.hs +++ b/src/Distribution/Server/Features.hs @@ -285,6 +285,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 ada4b622c..b50d02c67 100644 --- a/src/Distribution/Server/Features/Browse.hs +++ b/src/Distribution/Server/Features/Browse.hs @@ -9,6 +9,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 @@ -138,7 +139,7 @@ packageIndexInfoToValue :: CoreResource -> TagsResource -> UserResource -> Packa packageIndexInfoToValue coreResource tagsResource userResource PackageItem{itemName, itemDownloads, itemVotes, - itemDesc, itemTags, itemLastUpload, itemMaintainer} = + itemDesc, itemTags, itemLastUpload, itemMaintainer, itemPackageRank} = object [ Key.fromString "name" .= renderPackage itemName , Key.fromString "downloads" .= itemDownloads @@ -147,6 +148,7 @@ packageIndexInfoToValue , Key.fromString "tags" .= map renderTag (S.toAscList itemTags) , Key.fromString "lastUpload" .= iso8601Show itemLastUpload , 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 f96a3367c..d085819ba 100644 --- a/src/Distribution/Server/Features/Browse/ApplyFilter.hs +++ b/src/Distribution/Server/Features/Browse/ApplyFilter.hs @@ -64,6 +64,7 @@ sort isSearch sortColumn sortDirection = Tags -> comparing (S.toAscList . itemTags) LastUpload -> comparing itemLastUpload 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 269be66ef..942681bc3 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 | Maintainers +data NormalColumn = Name | Downloads | Rating | Description | Tags | LastUpload | Maintainers | PackageRank deriving (Show, Eq) data Column = DefaultColumn | NormalColumn NormalColumn @@ -37,6 +37,7 @@ instance FromJSON Column where "tags" -> pure $ NormalColumn Tags "lastUpload" -> pure $ NormalColumn LastUpload "maintainers" -> pure $ NormalColumn Maintainers + "packageRank" -> pure $ NormalColumn PackageRank t -> fail $ "Column invalid: " ++ T.unpack t columnToTemplateName :: Column -> String @@ -49,6 +50,7 @@ columnToTemplateName = \case NormalColumn Tags -> "tags" NormalColumn LastUpload -> "lastUpload" 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 9d0840bd8..15be3e815 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 1a719fc22..718354b13 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(..)) @@ -32,6 +36,8 @@ import Distribution.PackageDescription.Configuration import Distribution.Utils.ShortText (fromShortText) import Control.Concurrent +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty) import Data.Maybe (mapMaybe) import Data.Map (Map) import qualified Data.Map as Map @@ -39,7 +45,6 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Time.Clock (UTCTime(..)) - data ListFeature = ListFeature { listFeatureInterface :: HackageFeature, @@ -85,18 +90,20 @@ data PackageItem = PackageItem { -- How many benchmarks (>=0) this package has. itemNumBenchmarks :: !Int, -- Last upload date - itemLastUpload :: !UTCTime + itemLastUpload :: !UTCTime, -- Hotness: a more heuristic way to sort packages. presently non-existent. - --itemHotness :: Int + --itemHotness :: Int + -- 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) = memSize12 a b c d e f g h i j k l + memSize (PackageItem a b c d e f g h i j k l m) = memSize13 a b c d e f g h i j k l m emptyPackageItem :: PackageName -> PackageItem emptyPackageItem pkg = PackageItem pkg Set.empty Nothing "" [] - 0 0 False 0 0 0 (UTCTime (toEnum 0) 0) + 0 0 False 0 0 0 (UTCTime (toEnum 0) 0) 0 initListFeature :: ServerEnv @@ -108,6 +115,8 @@ initListFeature :: ServerEnv -> VersionsFeature -> UserFeature -> UploadFeature + -> DocumentationFeature + -> TarIndexCacheFeature -> IO ListFeature) initListFeature _env = do itemCache <- newMemStateWHNF Map.empty @@ -120,11 +129,12 @@ initListFeature _env = do tagsf@TagsFeature{..} versions@VersionsFeature{..} users@UserFeature{..} - uploads@UploadFeature{..} -> do + uploads@UploadFeature{..} + documentation tar -> do let (feature, modifyItem, updateDesc) = listFeature core download votesf tagsf versions users uploads - itemCache itemUpdate + itemCache itemUpdate documentation tar _env registerHookJust packageChangeHook isPackageChangeAny $ \(pkgid, _) -> updateDesc (packageName pkgid) @@ -180,6 +190,9 @@ listFeature :: CoreFeature -> UploadFeature -> MemState (Map PackageName PackageItem) -> Hook (Set PackageName) () + -> DocumentationFeature + -> TarIndexCacheFeature + -> ServerEnv -> (ListFeature, PackageName -> (PackageItem -> PackageItem) -> IO (), PackageName -> IO ()) @@ -188,10 +201,11 @@ listFeature CoreFeature{..} DownloadFeature{..} VotesFeature{..} TagsFeature{..} - VersionsFeature{..} + versions@VersionsFeature{..} UserFeature{..} UploadFeature{..} itemCache itemUpdate + documentation tar env = (ListFeature{..}, modifyItem, updateDesc) where listFeatureInterface = (emptyHackageFeature "list") { @@ -220,9 +234,9 @@ listFeature CoreFeature{..} False -> do index <- queryGetPackageIndex let pkgs = PackageIndex.lookupPackageName index pkgname - case pkgs of - [] -> return () --this shouldn't happen - _ -> modifyMemState itemCache . uncurry Map.insert =<< constructItem (last pkgs) + case NE.nonEmpty pkgs of + Nothing -> return () --this shouldn't happen + Just ne -> modifyMemState itemCache . uncurry Map.insert =<< constructItem ne updateDesc pkgname = do index <- queryGetPackageIndex @@ -243,12 +257,14 @@ listFeature CoreFeature{..} constructItemIndex :: IO (Map PackageName PackageItem) constructItemIndex = do index <- queryGetPackageIndex - items <- mapM (constructItem . last) $ PackageIndex.allPackagesByName index - return $ Map.fromList items + let byName = PackageIndex.allPackagesByNameNE index + mPkgInfos <- traverse (mapM constructItem) (NE.nonEmpty byName) + pure $ foldMap (Map.fromList . NE.toList) mPkgInfos - constructItem :: PkgInfo -> IO (PackageName, PackageItem) - constructItem pkg = do + constructItem :: NonEmpty PkgInfo -> IO (PackageName, PackageItem) + constructItem pkgs = do let pkgname = packageName pkg + pkg = NE.last pkgs -- [reverse index disabled] revCount <- query . GetReverseCount $ pkgname users <- queryGetUserDb tags <- queryTagsForPackage pkgname @@ -256,6 +272,8 @@ listFeature CoreFeature{..} votes <- pkgNumScore pkgname deprs <- queryGetDeprecatedFor pkgname maintainers <- queryUserGroup (maintainersGroup pkgname) + packageR <- rankPackage versions (cmFind pkgname downs) + (UserIdSet.size maintainers) documentation tar env pkgs return $ (,) pkgname $ (updateDescriptionItem (pkgDesc pkg) $ emptyPackageItem pkgname) { itemTags = tags @@ -265,6 +283,7 @@ listFeature CoreFeature{..} -- [reverse index disabled] , itemRevDepsCount = directReverseCount revCount , itemVotes = votes , itemLastUpload = fst (pkgOriginalUploadInfo pkg) + , 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 000000000..b9dc04936 --- /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 000000000..2263419be --- /dev/null +++ b/src/Distribution/Server/Features/PackageList/PackageRank.hs @@ -0,0 +1,336 @@ +{-# 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.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 qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty ( NonEmpty ) +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 -> IO Scorer +temporalScore p lastUploads versionList recentDownloads = do + fresh <- freshnessScore + tract <- tractionScore + -- Reverse dependencies are added + return $ tract <> fresh <> downloadScore + where + isApp = (isNothing . library) p && (not . null . executables) p + downloadScore = calcDownScore recentDownloads + calcDownScore i = fracScor + 5 + ( (logBase 2 (int2Float $ max 0 (i - 32) + 32) - 5) + / (if isApp then 6 else 8) + ) + 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 + -> NonEmpty PkgInfo + -> IO Float +rankPackage versions recentDownloads maintainers docs tarCache env pkgs + = do + t <- temporalScore pkgD uploads versionList recentDownloads + + 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 + pkgUsed = NE.last pkgs + 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) (NE.toList pkgs) + uploads = + sortBy (flip compare) + $ (fst . pkgOriginalUploadInfo <$> NE.toList pkgs) + ++ (fst . pkgLatestUploadInfo <$> NE.toList pkgs) diff --git a/src/Distribution/Server/Features/Search/ExtractDescriptionTerms.hs b/src/Distribution/Server/Features/Search/ExtractDescriptionTerms.hs index 24a8334df..d07ed63e3 100644 --- a/src/Distribution/Server/Features/Search/ExtractDescriptionTerms.hs +++ b/src/Distribution/Server/Features/Search/ExtractDescriptionTerms.hs @@ -78,7 +78,7 @@ termsMarkup = Markup { markupBold = id, markupMonospaced = \s -> if length s > 1 then [] else s, markupUnorderedList = concat, - markupOrderedList = concat, + markupOrderedList = concat . map snd, markupDefList = concatMap (\(d,t) -> d ++ t), markupCodeBlock = const [], markupTable = concat . F.toList, diff --git a/src/Distribution/Server/Features/Security/Migration.hs b/src/Distribution/Server/Features/Security/Migration.hs index 5fb09f054..b9ee61f50 100644 --- a/src/Distribution/Server/Features/Security/Migration.hs +++ b/src/Distribution/Server/Features/Security/Migration.hs @@ -206,11 +206,11 @@ data Migrated a = Migrated MigrationStats a | AlreadyMigrated a deriving (Functor) instance Applicative Migrated where - pure = return + pure = AlreadyMigrated f <*> x = do f' <- f ; x' <- x ; return $ f' x' instance Monad Migrated where - return = AlreadyMigrated + return = pure AlreadyMigrated a >>= f = f a Migrated stats a >>= f = case f a of diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs index 04b5e750a..6240e9e8c 100644 --- a/src/Distribution/Server/Features/UserDetails.hs +++ b/src/Distribution/Server/Features/UserDetails.hs @@ -330,6 +330,7 @@ userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} Up handlerGetUserNameContactHtml :: DynamicPath -> ServerPartE Response handlerGetUserNameContactHtml dpath = do (uid, uinfo) <- lookupUserNameFull =<< userNameInPath dpath + guardAuthorised_ [IsUserId uid, InGroup adminGroup] template <- getTemplate templates "user-details-form.html" udetails <- queryUserDetails uid showConfirmationOfSave <- not . null <$> queryString (lookBSs "showConfirmationOfSave") diff --git a/src/Distribution/Server/Framework/BackupRestore.hs b/src/Distribution/Server/Framework/BackupRestore.hs index 64e5c0bfa..d2158f74f 100644 --- a/src/Distribution/Server/Framework/BackupRestore.hs +++ b/src/Distribution/Server/Framework/BackupRestore.hs @@ -251,7 +251,7 @@ data Restore a = RestoreDone a | RestoreFindBlob BlobId (Bool -> Restore a) instance Monad Restore where - return = RestoreDone + return = pure RestoreDone x >>= g = g x RestoreFail err >>= _ = RestoreFail err RestoreAddBlob bs f >>= g = RestoreAddBlob bs $ \bid -> f bid >>= g @@ -270,7 +270,7 @@ instance Functor Restore where fmap = liftM instance Applicative Restore where - pure = return + pure = RestoreDone mf <*> mx = do f <- mf ; x <- mx ; return (f x) runRestore :: BlobStores -> Restore a -> IO (Either String a) diff --git a/src/Distribution/Server/Framework/HappstackUtils.hs b/src/Distribution/Server/Framework/HappstackUtils.hs index 41bce1b74..f10491f08 100644 --- a/src/Distribution/Server/Framework/HappstackUtils.hs +++ b/src/Distribution/Server/Framework/HappstackUtils.hs @@ -81,6 +81,8 @@ mime x = , ("chs", "text/plain; charset=utf-8") , ("c", " text/plain; charset=utf-8") , ("h", " text/plain; charset=utf-8") + , ("text", "text/plain; charset=utf-8") + , ("txt", "text/plain; charset=utf-8") ] diff --git a/src/Distribution/Server/Packages/PackageIndex.hs b/src/Distribution/Server/Packages/PackageIndex.hs index 4b862d649..f48750e73 100644 --- a/src/Distribution/Server/Packages/PackageIndex.hs +++ b/src/Distribution/Server/Packages/PackageIndex.hs @@ -44,7 +44,8 @@ module Distribution.Server.Packages.PackageIndex ( -- ** Bulk queries allPackageNames, allPackages, - allPackagesByName + allPackagesByName, + allPackagesByNameNE ) where import Distribution.Server.Prelude hiding (lookup) @@ -58,6 +59,8 @@ import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) import qualified Data.Foldable as Foldable import Data.List (groupBy, find, isInfixOf) +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty) import Data.SafeCopy import Distribution.Types.PackageName @@ -258,6 +261,11 @@ allPackages (PackageIndex m) = concat (Map.elems m) allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]] allPackagesByName (PackageIndex m) = Map.elems m +allPackagesByNameNE :: Package pkg => PackageIndex pkg -> [NonEmpty pkg] +allPackagesByNameNE (PackageIndex m) = + -- This is safe because there will always be at least one version of a package + NE.fromList <$> Map.elems m + allPackageNames :: PackageIndex pkg -> [PackageName] allPackageNames (PackageIndex m) = Map.keys m diff --git a/src/Distribution/Server/Pages/Package/HaddockHtml.hs b/src/Distribution/Server/Pages/Package/HaddockHtml.hs index dba250b9f..8b5b3f0d5 100644 --- a/src/Distribution/Server/Pages/Package/HaddockHtml.hs +++ b/src/Distribution/Server/Pages/Package/HaddockHtml.hs @@ -24,7 +24,7 @@ htmlMarkup modResolv = Markup { markupBold = strong, markupMonospaced = thecode, markupUnorderedList = unordList, - markupOrderedList = ordList, + markupOrderedList = ordList . map snd, markupDefList = defList, markupCodeBlock = pre, markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << maybe url showHtmlFragment mLabel, diff --git a/src/Distribution/Server/Util/Markdown.hs b/src/Distribution/Server/Util/Markdown.hs index bc8fb84a6..033ab4f00 100644 --- a/src/Distribution/Server/Util/Markdown.hs +++ b/src/Distribution/Server/Util/Markdown.hs @@ -120,6 +120,30 @@ adjustRelativeLink url --

Published to http://hackage.haskell.org/foo3/bar.

-- -- +-- >>> renderMarkdown "test" "Issue #1105:\n- pipes\n- like `a|b`\n- should be allowed in lists" +--

Issue #1105:

+-- +-- +-- +-- >>> renderMarkdown "test" "Tables should be supported:\n\nfoo|bar\n---|---\n" +--

Tables should be supported:

+-- +-- +-- +-- +-- +-- +-- +--
foobar
+-- +-- renderMarkdown :: String -- ^ Name or path of input. -> BS.ByteString -- ^ Commonmark text input. @@ -160,11 +184,33 @@ renderMarkdown' -> BS.ByteString -- ^ Commonmark text input. -> XHtml.Html -- ^ Rendered HTML. renderMarkdown' render name md = - either (const $ XHtml.pre XHtml.<< T.unpack txt) (XHtml.primHtml . T.unpack . sanitizeBalance . TL.toStrict . render) $ - runIdentity (commonmarkWith (mathSpec <> gfmExtensions <> defaultSyntaxSpec) - name - txt) - where txt = T.decodeUtf8With T.lenientDecode . BS.toStrict $ md + either (const $ fallback) mdToHTML $ + runIdentity $ commonmarkWith spec name txt + where + -- Input + txt = T.decodeUtf8With T.lenientDecode . BS.toStrict $ md + -- Fall back to HTML if there is a parse error for markdown + fallback = XHtml.pre XHtml.<< T.unpack txt + -- Conversion of parsed md to HTML + mdToHTML = XHtml.primHtml . T.unpack . sanitizeBalance . TL.toStrict . render + -- Specification of the markdown parser. + -- Andreas Abel, 2022-07-21, issue #1105. + -- Workaround for https://github.com/jgm/commonmark-hs/issues/95: + -- Put the table parser last. + spec = mconcat $ + mathSpec : + -- all the gfm extensions except for tables + emojiSpec : + strikethroughSpec : + autolinkSpec : + autoIdentifiersSpec : + taskListSpec : + footnoteSpec : + -- the default syntax + defaultSyntaxSpec : + -- the problematic table parser + pipeTableSpec : + [] -- | Does the file extension suggest that the file is in markdown syntax? supposedToBeMarkdown :: FilePath -> Bool