Enable filtering packages by distro

Author: ysangkok

datafiles/templates/Html/new-browse.html.st

@@ -221,6 +221,8 @@
         <dd>Only show deprecated packages.</dd>
         <dt>(deprecated:false)</dt>
         <dd>Only show packages that are not deprecated. If no other deprecation filter is given, this filter is automatically added.</dd>
+        <dt>(distro:Debian)</dt>
+        <dd>Only show packages that are available in the Debian distribution. See the <a href="/distros">full list of available distributions</a>.</dd>
       </dl>
       </div>
       <table id=newBrowse class=fancy>

src/Distribution/Server/Features.hs

@@ -333,6 +333,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                        tagsFeature
                        listFeature
                        searchFeature
+                       distroFeature
 
 #endif
 

src/Distribution/Server/Features/Browse.hs

@@ -15,6 +15,7 @@ import qualified Data.Vector as V
 import Distribution.Server.Features.Browse.ApplyFilter (applyFilter)
 import Distribution.Server.Features.Browse.Options (BrowseOptions(..), IsSearch(..))
 import Distribution.Server.Features.Core (CoreFeature(CoreFeature), queryGetPackageIndex, coreResource)
+import Distribution.Server.Features.Distro (DistroFeature)
 import Distribution.Server.Features.PackageList (ListFeature(ListFeature), makeItemList)
 import Distribution.Server.Features.Search (SearchFeature(SearchFeature), searchPackages)
 import Distribution.Server.Features.Tags (TagsFeature(TagsFeature), tagsResource)
@@ -36,11 +37,12 @@ type BrowseFeature =
     -> TagsFeature
     -> ListFeature
     -> SearchFeature
+    -> DistroFeature
     -> IO HackageFeature
 
 initNewBrowseFeature :: ServerEnv -> IO BrowseFeature
 initNewBrowseFeature _env =
-  pure \coreFeature userFeature tagsFeature listFeature searchFeature ->
+  pure \coreFeature userFeature tagsFeature listFeature searchFeature distroFeature ->
     pure $
       (emptyHackageFeature "json")
         { featureResources =
@@ -50,7 +52,7 @@ initNewBrowseFeature _env =
               ]
             , resourcePost =
               [ ("json"
-                , \_ -> getNewPkgList coreFeature userFeature tagsFeature listFeature searchFeature
+                , \_ -> getNewPkgList coreFeature userFeature tagsFeature listFeature searchFeature distroFeature
                 )
               ]
             }
@@ -89,8 +91,8 @@ paginate PaginationConfig{totalNumberOfElements, pageNumber} = do
          else pageSize
    )
 
-getNewPkgList :: CoreFeature -> UserFeature -> TagsFeature -> ListFeature -> SearchFeature -> ServerPartT (ExceptT ErrorResponse IO) Response
-getNewPkgList CoreFeature{queryGetPackageIndex, coreResource} UserFeature{userResource} TagsFeature{tagsResource} ListFeature{makeItemList} SearchFeature{searchPackages} = do
+getNewPkgList :: CoreFeature -> UserFeature -> TagsFeature -> ListFeature -> SearchFeature -> DistroFeature -> ServerPartT (ExceptT ErrorResponse IO) Response
+getNewPkgList CoreFeature{queryGetPackageIndex, coreResource} UserFeature{userResource} TagsFeature{tagsResource} ListFeature{makeItemList} SearchFeature{searchPackages} distroFeature = do
   browseOptionsBS <- lookBS "browseOptions"
   browseOptions <- lift (parseBrowseOptions browseOptionsBS)
   (isSearch, packageNames) <-
@@ -99,8 +101,8 @@ getNewPkgList CoreFeature{queryGetPackageIndex, coreResource} UserFeature{userRe
       terms -> (IsSearch,)    <$> liftIO (searchPackages terms)
   pkgDetails <- liftIO (makeItemList packageNames)
   now <- liftIO getCurrentTime
-  let listOfPkgs = applyFilter now isSearch coreResource userResource tagsResource browseOptions pkgDetails
-      config =
+  listOfPkgs <- liftIO $ applyFilter now isSearch coreResource userResource tagsResource distroFeature browseOptions pkgDetails
+  let config =
         PaginationConfig
           { totalNumberOfElements = length listOfPkgs
           , pageNumber = fromIntegral $ boPage browseOptions

src/Distribution/Server/Features/Browse/ApplyFilter.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE RecordWildCards, NamedFieldPuns, TypeApplications #-}
 module Distribution.Server.Features.Browse.ApplyFilter (applyFilter) where
 
+import Control.Monad (filterM)
 import Data.List (sortBy)
 import Data.Ord (comparing)
 import Data.Time.Clock (UTCTime(utctDay), diffUTCTime)
@@ -13,18 +14,21 @@ import qualified Data.Set as S
 import Distribution.Server.Features.Browse.Options (BrowseOptions(..), Direction(..), Column(..), Sort(..), NormalColumn(..), IsSearch(..))
 import Distribution.Server.Features.Browse.Parsers (DeprecatedOption(..), Filter(..), operatorToFunction)
 import Distribution.Server.Features.Core (CoreResource, corePackageNameUri)
+import Distribution.Server.Features.Distro (DistroFeature(DistroFeature, queryPackageStatus))
+import Distribution.Server.Features.Distro.Types (DistroName(..))
 import Distribution.Server.Features.PackageList(PackageItem(..))
 import Distribution.Server.Features.Tags (Tag(..), TagsResource, tagUri)
 import Distribution.Server.Features.Users (UserResource, userPageUri)
 import Distribution.Server.Users.Types (UserName)
 import Distribution.Text (display)
 
-applyFilter :: UTCTime -> IsSearch -> CoreResource -> UserResource -> TagsResource -> BrowseOptions -> [PackageItem] -> [Value]
-applyFilter now isSearch coreResource userResource tagsResource browseOptions items =
- map packageIndexInfoToValue $
- sort isSearch (boSort browseOptions) $
- filterPackages now (boFilters browseOptions) $
- items
+applyFilter :: UTCTime -> IsSearch -> CoreResource -> UserResource -> TagsResource -> DistroFeature -> BrowseOptions -> [PackageItem] -> IO [Value]
+applyFilter now isSearch coreResource userResource tagsResource DistroFeature{queryPackageStatus} browseOptions items = do
+ packages <- filterM filterForItem items
+ pure $
+   map packageIndexInfoToValue $
+   sort isSearch (boSort browseOptions) $
+   packages
  where
   packageIndexInfoToValue :: PackageItem -> Value
   packageIndexInfoToValue PackageItem{..} =
@@ -55,6 +59,33 @@ applyFilter now isSearch coreResource userResource tagsResource browseOptions it
       , T.pack "display" .= display pkg
       ]
 
+  includeItem :: PackageItem -> Filter -> IO Bool
+  includeItem PackageItem{ itemDownloads }  (DownloadsFilter ( op, sndParam))    = pure $ operatorToFunction op (fromIntegral @Int @Word itemDownloads) sndParam
+  includeItem PackageItem{ itemVotes }      (RatingFilter (op, sndParam) )       = pure $ operatorToFunction op itemVotes sndParam
+  includeItem PackageItem{ itemLastUpload } (LastUploadFilter (op, sndParam))    = pure $ operatorToFunction op (utctDay itemLastUpload) sndParam
+  includeItem PackageItem{ itemTags }       (TagFilter tagStr)                   = pure $ any (\tag -> display tag == tagStr) itemTags
+  includeItem PackageItem{ itemMaintainer } (MaintainerFilter maintainerStr)     = pure $ any (\user -> display user == maintainerStr) itemMaintainer
+  includeItem PackageItem{ itemLastUpload } (AgeLastULFilter (op, sndParam))     = pure $ operatorToFunction op (diffUTCTime now itemLastUpload) sndParam
+  includeItem PackageItem{ itemDeprecated } (DeprecatedFilter OnlyDeprecated)    = pure $ not (null itemDeprecated)
+  includeItem PackageItem{ itemDeprecated } (DeprecatedFilter ExcludeDeprecated) = pure $ null itemDeprecated
+  includeItem _                             (DeprecatedFilter Don'tCareAboutDeprecated) = pure True
+  includeItem PackageItem{ itemName }       (DistroFilter distroStr)             = elem (DistroName distroStr) . map fst <$> queryPackageStatus itemName
+  includeItem packageItem (Not filt) = not <$> includeItem packageItem filt
+
+  filtersWithoutDefaults = boFilters browseOptions
+
+  filtersWithDefaults =
+    -- The lack of other filters means we don't care.
+    -- But deprecated packages are excluded by default.
+    -- So we check if the user has overriden the default filter.
+    case [ x | DeprecatedFilter x <- filtersWithoutDefaults ] of
+      [] -> DeprecatedFilter ExcludeDeprecated : filtersWithoutDefaults
+      _  -> filtersWithoutDefaults
+
+  filterForItem :: PackageItem -> IO Bool
+  filterForItem item =
+    all id <$> traverse (includeItem item) filtersWithDefaults
+
 sort :: IsSearch -> Sort -> [PackageItem] -> [PackageItem]
 sort isSearch Sort {sortColumn, sortDirection} =
   case sortColumn of
@@ -79,28 +110,3 @@ sort isSearch Sort {sortColumn, sortDirection} =
       case sortDirection of
         Ascending -> id
         Descending -> flip
-
-includeItem :: UTCTime -> PackageItem -> Filter -> Bool
-includeItem _   PackageItem{ itemDownloads }  (DownloadsFilter ( op, sndParam))    = operatorToFunction op (fromIntegral @Int @Word itemDownloads) sndParam
-includeItem _   PackageItem{ itemVotes }      (RatingFilter (op, sndParam) )       = operatorToFunction op itemVotes sndParam
-includeItem _   PackageItem{ itemLastUpload } (LastUploadFilter (op, sndParam))    = operatorToFunction op (utctDay itemLastUpload) sndParam
-includeItem _   PackageItem{ itemTags }       (TagFilter tagStr)                   = any (\tag -> display tag == tagStr) itemTags
-includeItem _   PackageItem{ itemMaintainer } (MaintainerFilter maintainerStr)     = any (\user -> display user == maintainerStr) itemMaintainer
-includeItem now PackageItem{ itemLastUpload } (AgeLastULFilter (op, sndParam))     = operatorToFunction op (diffUTCTime now itemLastUpload) sndParam
-includeItem _   PackageItem{ itemDeprecated } (DeprecatedFilter OnlyDeprecated)    = not (null itemDeprecated)
-includeItem _   PackageItem{ itemDeprecated } (DeprecatedFilter ExcludeDeprecated) = null itemDeprecated
-includeItem _   _                             (DeprecatedFilter Don'tCareAboutDeprecated) = True
-includeItem now packageItem (Not filt) = not (includeItem now packageItem filt)
-
-filterPackages :: UTCTime -> [Filter] -> [PackageItem] -> [PackageItem]
-filterPackages now filtersWithoutDefaults = filter filterForItem
-  where
-    filterForItem :: PackageItem -> Bool
-    filterForItem item = all (includeItem now item) filtersWithDefaults
-    filtersWithDefaults =
-      -- The lack of other filters means we don't care.
-      -- But deprecated packages are excluded by default.
-      -- So we check if the user has overriden the default filter.
-      case [ x | DeprecatedFilter x <- filtersWithoutDefaults ] of
-        [] -> DeprecatedFilter ExcludeDeprecated : filtersWithoutDefaults
-        _  -> filtersWithoutDefaults

src/Distribution/Server/Features/Browse/Parsers.hs

@@ -36,6 +36,7 @@ data Filter
   | TagFilter String
   | MaintainerFilter String
   | DeprecatedFilter DeprecatedOption
+  | DistroFilter String
   | Not Filter
   deriving (Show, Eq)
 
@@ -84,7 +85,7 @@ allowedAfterOpeningBrace AllowNot = "not " <|> allowedAfterOpeningBrace Disallow
 allowedAfterOpeningBrace _ =
   asum
     [ "downloads", "rating", "lastUpload" , "ageOfLastUpload"
-    , "tag:", "maintainer:", "deprecated:"
+    , "tag:", "maintainer:", "deprecated:", "distro:"
     ]
 
 -- Whether the 'not' operator can be used.
@@ -111,6 +112,7 @@ filterWith allowNot = do
         "tag:" -> TagFilter <$> wordWoSpaceOrParens
         "maintainer:" -> MaintainerFilter <$> wordWoSpaceOrParens
         "deprecated:" -> DeprecatedFilter <$> deprecatedOption
+        "distro:" -> DistroFilter <$> wordWoSpaceOrParens
         _ -> fail "Impossible since fieldName possibilities are known at compile time"
       pure filt