Implement new table-based browsable package index

The new index relies on jQuery DataTables to implement client-side
sorting.

This has been factored out of the HSoC work haskell#514 by @sooryan

The code has been refactored & cleaned up by Duncan, Gershom and myself.

Author: Soorya Narayan

Distribution/Server/Features/Html.hs

@@ -70,15 +70,12 @@ import Data.Array (Array, listArray)
 import qualified Data.Array as Array
 import qualified Data.Ix    as Ix
 import Data.Time.Format (formatTime)
-import Data.Time.Clock (getCurrentTime)
-import qualified Data.Time.Format.Human as HumanTime
 import Data.Time.Locale.Compat (defaultTimeLocale)
 import qualified Data.ByteString.Lazy as BS (ByteString)
 
 import Text.XHtml.Strict
 import qualified Text.XHtml.Strict as XHtml
 import Text.XHtml.Table (simpleTable)
-import Network.URI (escapeURIString, isUnreserved)
 
 
 -- TODO: move more of the below to Distribution.Server.Pages.*, it's getting
@@ -129,6 +126,7 @@ initHtmlFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode,
                    , "distro-monitor.html"
                    , "revisions.html"
                    , "package-page.html"
+                   , "table-interface.html"
                    ]
 
 
@@ -158,7 +156,7 @@ initHtmlFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode,
                             tarIndexCache
                             reportsCore
                             usersdetails
-                            (htmlUtilities core tags)
+                            (htmlUtilities core tags user)
                             mainCache namesCache
                             templates
 
@@ -268,6 +266,8 @@ htmlFeature env@ServerEnv{..}
                                       cachePackagesPage
                                       cacheNamesPage
                                       templates
+                                      list
+                                      names
     htmlUsers      = mkHtmlUsers      user usersdetails
     htmlUploads    = mkHtmlUploads    utilities upload
     htmlDocUploads = mkHtmlDocUploads utilities core docsCore templates
@@ -277,8 +277,8 @@ htmlFeature env@ServerEnv{..}
                                       docsCandidates tarIndexCache
                                       candidates templates
     htmlPreferred  = mkHtmlPreferred  utilities core versions
-    htmlTags       = mkHtmlTags       utilities core list tags
-    htmlSearch     = mkHtmlSearch     utilities core list names
+    htmlTags       = mkHtmlTags       utilities core list tags templates
+    htmlSearch     = mkHtmlSearch     utilities core list names templates
 
     htmlResources = concat [
         htmlCoreResources       htmlCore
@@ -460,11 +460,13 @@ mkHtmlCore :: ServerEnv
            -> AsyncCache Response
            -> AsyncCache Response
            -> Templates
+           -> ListFeature
+           -> SearchFeature
            -> HtmlCore
 mkHtmlCore ServerEnv{serverBaseURI}
            utilities@HtmlUtilities{..}
            UserFeature{queryGetUserDb, checkAuthenticated}
-           CoreFeature{coreResource}
+           CoreFeature{coreResource, queryGetPackageIndex}
            VersionsFeature{ versionsResource
                           , queryGetDeprecatedFor
                           , queryGetPreferredInfo
@@ -484,6 +486,8 @@ mkHtmlCore ServerEnv{serverBaseURI}
            cachePackagesPage
            cacheNamesPage
            templates
+           ListFeature{makeItemList}
+           SearchFeature{..}
   = HtmlCore{..}
   where
     cores@CoreResource{packageInPath, lookupPackageName, lookupPackageId} = coreResource
@@ -511,6 +515,10 @@ mkHtmlCore ServerEnv{serverBaseURI}
       , (resourceAt "/packages/names" ) {
             resourceGet = [("html", const $ readAsyncCache cacheNamesPage)]
           }
+      , (resourceAt "/packages/browse" ) {
+            resourceDesc = [(GET, "Show browsable list of all packages")]
+          , resourceGet  = [("html", serveBrowsePage)]
+          }
       , (extendResource $ corePackagesPage cores) {
             resourceDesc = [(GET, "Show package index")]
           , resourceGet  = [("html", const $ readAsyncCache cachePackagesPage)]
@@ -608,6 +616,21 @@ mkHtmlCore ServerEnv{serverBaseURI}
         , "versions" $= map packageId pkgs
         ]
 
+    serveBrowsePage :: DynamicPath -> ServerPartE Response
+    serveBrowsePage _ = do
+      pkgIndex <- queryGetPackageIndex
+      let packageNames = Pages.toPackageNames pkgIndex
+      pkgDetails <- liftIO $ makeItemList packageNames
+      let rowList = map makeRow pkgDetails
+          tabledata = "" +++ rowList +++ ""
+      cacheControl [Public, maxAgeHours 1]
+                   (etagFromHash (PackageIndex.indexSize pkgIndex))
+      template <- getTemplate templates "table-interface.html"
+      return $ toResponse $ template
+        [ "heading"   $= "All packages"
+        , "content"   $= "A browsable index of all the packages"
+        , "tabledata" $= tabledata ]
+
     serveDistroMonitorPage :: DynamicPath -> ServerPartE Response
     serveDistroMonitorPage dpath = do
       pkgname <- packageInPath dpath
@@ -1446,6 +1469,7 @@ mkHtmlTags :: HtmlUtilities
            -> CoreFeature
            -> ListFeature
            -> TagsFeature
+           -> Templates
            -> HtmlTags
 mkHtmlTags HtmlUtilities{..}
            CoreFeature{ coreResource = CoreResource{
@@ -1454,7 +1478,9 @@ mkHtmlTags HtmlUtilities{..}
                         }
                       }
            ListFeature{makeItemList}
-           TagsFeature{..} = HtmlTags{..}
+           TagsFeature{..}
+           templates
+           = HtmlTags{..}
   where
     tags = tagsResource
 
@@ -1500,17 +1526,21 @@ mkHtmlTags HtmlUtilities{..}
             pkgs = Set.toList pkgnames
         items <- liftIO $ makeItemList pkgs
         let (mtag, histogram) = Map.updateLookupWithKey (\_ _ -> Nothing) tg $ tagHistogram items
+            rowList = map makeRow items
             -- make a 'related tags' section, so exclude this tag from the histogram
             count = fromMaybe 0 mtag
-        return $ toResponse $ Resource.XHtml $ hackagePage tagd $
-          [ h2 << tagd
-          , case items of
+        template <- getTemplate templates "table-interface.html"
+        return $ toResponse $ template
+          [ "heading"   $= tagd
+          , "content"   $=  case items of
                 [] -> toHtml "No packages have this tag."
                 _  -> toHtml
                   [ paragraph << [if count==1 then "1 package has" else show count ++ " packages have", " this tag."]
                   , paragraph ! [theclass "toc"] << [toHtml "Related tags: ", toHtml $ showHistogram histogram]
-                  , ulist ! [theclass "packages"] << map renderItem items ]
+                  ]
+          , "tabledata" $= rowList
           ]
+
      where
       showHistogram hist = (++takeHtml) . intersperse (toHtml ", ") $
             map histogramEntry $ take takeAmount sortHist
@@ -1554,11 +1584,13 @@ mkHtmlSearch :: HtmlUtilities
              -> CoreFeature
              -> ListFeature
              -> SearchFeature
+             -> Templates
              -> HtmlSearch
 mkHtmlSearch HtmlUtilities{..}
              CoreFeature{..}
              ListFeature{makeItemList}
-             SearchFeature{..} =
+             SearchFeature{..}
+             templates =
     HtmlSearch{..}
   where
     htmlSearchResources = [
@@ -1569,10 +1601,10 @@ mkHtmlSearch HtmlUtilities{..}
 
     servePackageFind :: DynamicPath -> ServerPartE Response
     servePackageFind _ = do
-        (mtermsStr, offset, limit, mexplain) <-
-          queryString $ (,,,) <$> optional (look "terms")
-                              <*> mplus (lookRead "offset") (pure 0)
-                              <*> mplus (lookRead "limit") (pure 100)
+        (mtermsStr,  mexplain) <-
+          queryString $ (,) <$> optional (look "terms")
+                              -- <*> mplus (lookRead "offset") (pure 0)
+                              -- <*> mplus (lookRead "limit") (pure 100)
                               <*> optional (look "explain")
         let explain = isJust mexplain
         case mtermsStr of
@@ -1587,18 +1619,23 @@ mkHtmlSearch HtmlUtilities{..}
                 , toHtml $ explainResults results
                 ]
 
-          Just termsStr | terms <- words termsStr, not (null terms) -> do
-            pkgIndex <- liftIO $ queryGetPackageIndex
-            currentTime <- liftIO $ getCurrentTime
-            pkgnames <- searchPackages terms
-            let (pageResults, moreResults) = splitAt limit (drop offset pkgnames)
-            pkgDetails <- liftIO $ makeItemList pageResults
-            return $ toResponse $ Resource.XHtml $
-              hackagePage "Package search" $
-                [ toHtml $ searchForm termsStr False
-                , toHtml $ resultsArea pkgIndex currentTime pkgDetails offset limit moreResults termsStr
-                , alternativeSearchTerms termsStr
-                ]
+          Just termsStr | terms <- words termsStr -> do
+            -- pkgIndex <- liftIO $ queryGetPackageIndex
+            -- currentTime <- liftIO $ getCurrentTime
+            pkgnames <- if null terms
+                        then fmap Pages.toPackageNames queryGetPackageIndex
+                        else searchPackages terms
+            -- let (pageResults, moreResults) = splitAt limit (drop offset pkgnames)
+            pkgDetails <- liftIO $ makeItemList pkgnames
+
+            let rowList = map makeRow pkgDetails
+                tabledata = "" +++ rowList
+            template <- getTemplate templates "table-interface.html"
+            return $ toResponse $ template
+              [ "heading"   $= toHtml (searchForm termsStr False)
+              , "content"   $= "A browsable index of all the packages"
+              , "tabledata" $= tabledata
+              , "footer"    $= alternativeSearchTerms termsStr]
 
           _ ->
             return $ toResponse $ Resource.XHtml $
@@ -1607,55 +1644,6 @@ mkHtmlSearch HtmlUtilities{..}
                 , alternativeSearch
                 ]
       where
-        resultsArea pkgIndex currentTime pkgDetails offset limit moreResults termsStr =
-            [ h2 << "Results"
-            , if offset == 0
-                then noHtml
-                else paragraph << ("(" ++ show (fst range + 1) ++ " to "
-                                       ++ show (snd range) ++ ")")
-            , case pkgDetails of
-                [] | offset == 0 -> toHtml "None"
-                   | otherwise   -> toHtml "No more results"
-                _ -> toHtml
-                      [ ulist ! [theclass "searchresults"]
-                             << map renderSearchResult pkgDetails
-                      , if null moreResults
-                          then noHtml
-                          else anchor ! [href moreResultsLink]
-                                     << "More results..."
-                      ]
-            ]
-          where
-            renderSearchResult :: PackageItem -> Html
-            renderSearchResult item = li ! classes <<
-              [ packageNameLink pkgname
-              , toHtml $ " " ++ ptype
-              , br
-              , toHtml (itemDesc item)
-              , br
-              , small ! [ theclass "info" ] <<
-                [ toHtml (renderTags (itemTags item))
-                , " Last uploaded " +++ humanTime ]
-              ]
-              where
-                pkgname   = itemName item
-                timestamp = maximum
-                          $ map pkgOriginalUploadTime
-                          $ PackageIndex.lookupPackageName pkgIndex pkgname
-                -- takes current time as argument so it can say how many $X ago something was
-                humanTime = HumanTime.humanReadableTime' currentTime timestamp
-                ptype = packageType (itemHasLibrary item) (itemNumExecutables item)
-                                    (itemNumTests item) (itemNumBenchmarks item)
-                classes = case classList of [] -> []; _ -> [theclass $ unwords classList]
-                classList = (case itemDeprecated item of Nothing -> []; _ -> ["deprecated"])
-
-            range = (offset, offset + length pkgDetails)
-            moreResultsLink =
-                "/packages/search?"
-             ++ "terms="   ++ escapeURIString isUnreserved termsStr
-             ++ "&offset=" ++ show (offset + limit)
-             ++ "&limit="  ++ show limit
-
         searchForm termsStr explain =
           [ h2 << "Package search"
           , form ! [XHtml.method "GET", action "/packages/search"] <<

Distribution/Server/Features/Html/HtmlUtilities.hs

@@ -14,24 +14,42 @@ import Data.Set (Set)
 import Distribution.Server.Features.PackageList
 import Distribution.Server.Pages.Util (packageType)
 import Distribution.Package
+import Distribution.Server.Features.Users
 
 data HtmlUtilities = HtmlUtilities {
     packageLink :: PackageId -> Html
   , packageNameLink :: PackageName -> Html
   , renderItem :: PackageItem -> Html
+  , makeRow :: PackageItem -> Html
   , renderTags :: Set Tag -> [Html]
   }
 
-htmlUtilities :: CoreFeature -> TagsFeature -> HtmlUtilities
+htmlUtilities :: CoreFeature -> TagsFeature -> UserFeature -> HtmlUtilities
 htmlUtilities CoreFeature{coreResource}
-              TagsFeature{tagsResource} = HtmlUtilities{..}
+              TagsFeature{tagsResource} UserFeature{userResource} = HtmlUtilities{..}
   where
     packageLink :: PackageId -> Html
     packageLink pkgid = anchor ! [href $ corePackageIdUri cores "" pkgid] << display pkgid
 
     packageNameLink :: PackageName -> Html
     packageNameLink pkgname = anchor ! [href $ corePackageNameUri cores "" pkgname] << display pkgname
 
+    makeRow :: PackageItem -> Html
+    makeRow item = tr << [ td $ itemNameHtml
+                         , td $ toHtml $ show $ itemDownloads item
+                         , td $ toHtml $ show $ itemVotes item / 2
+                         , td $ toHtml $ "" -- FIXME/TODO: show $ itemRevDepsCount item
+                         , td $ toHtml $ itemDesc item
+                         , td $ " (" +++ renderTags (itemTags item) +++ ")"
+                         , td $ "" +++ intersperse (toHtml ", ") (map renderUser (itemMaintainer item))
+                         ]
+        where
+            renderUser user = anchor ! [href $ userPageUri userResource "" user] << display user
+            itemNameHtml = packageNameLink (itemName item) +++
+                               case itemDeprecated item of
+                                       Just pkgs -> " (deprecated in favor of " +++ intersperse (toHtml ", ") (map packageNameLink pkgs) +++ ")"
+                                       Nothing -> toHtml ""
+
     renderItem :: PackageItem -> Html
     renderItem item = li ! classes <<
           [ packageNameLink pkgname

Distribution/Server/Pages/Index.hs

@@ -1,6 +1,6 @@
 -- Generate an HTML page listing all available packages
 
-module Distribution.Server.Pages.Index (packageIndex) where
+module Distribution.Server.Pages.Index (packageIndex, toPackageNames) where
 
 import Distribution.Server.Pages.Template       ( hackagePage )
 import Distribution.Server.Pages.Util           ( packageType )
@@ -30,6 +30,15 @@ packageIndex = formatPkgGroups
                       . maximumBy (comparing packageVersion))
                  . PackageIndex.allPackagesByName
 
+toPackageNames :: PackageIndex.PackageIndex PkgInfo -> [PackageName]
+toPackageNames = map (pii_pkgName
+                      . mkPackageIndexInfo
+                      . flattenPackageDescription
+                      . pkgDesc
+                      . maximumBy (comparing packageVersion))
+                 . PackageIndex.allPackagesByName
+
+
 data PackageIndexInfo = PackageIndexInfo {
                             pii_pkgName :: !PackageName,
                             pii_categories :: ![Category],

Distribution/Server/Pages/Template.hs

@@ -60,7 +60,7 @@ stylesheetURL = "/static/hackage.css"
 
 -- URL of the package list
 pkgListURL :: URL
-pkgListURL = "/packages/"
+pkgListURL = "/packages/browse"
 
 -- URL of the upload form
 introductionURL :: URL

datafiles/static/hackage.css

@@ -65,6 +65,8 @@ h6 { font-size: 100%;   /* 13px */ }
 
 select, input, button, textarea {
 	font:99% sans-serif;
+    margin: 0.5em;
+    padding: 0.1em;
 }
 
 table {
@@ -204,7 +206,7 @@ pre {
   background: rgb(41,56,69);
   border-top: 5px solid rgb(78,98,114);
   color: #ddd;
-  padding: 0.2em;
+  padding: 0.2em 0.2em 0.5em;
   position: relative;
   text-align: left;
   font-size: 125%;
@@ -641,7 +643,7 @@ p.tip {
 
 /* Misc admin forms */
 
-form.box {
+.box {
   background: #faf9dc;
   border: 1px solid #d8d7ad;
   padding: 0.5em 1em;