Initial implementation of paging on recent packages

datafiles/static/hackage.css

@@ -1040,3 +1040,50 @@ a.deprecated[href]:visited {
 .versions a.normal[href]:visited {
     color: #61B01E;
 }
+
+/* Paginator */
+/* Maybe should remove this from browse.html.st */
+#paginatorContainer {
+  display: flex;
+  align-items: center;
+  flex-wrap: wrap;
+}
+
+.paginator {
+  margin-left: auto;
+}
+
+.paginator a {
+  box-sizing: border-box;
+  display: inline-block;
+  min-width: 1.5em;
+  padding: 0.5em 1em;
+  margin-left: 2px;
+  text-align: center;
+  text-decoration: none !important;
+  color: #333 !important;
+  border: 1px solid transparent;
+  border-radius: 2px;
+}
+
+.paginator .current,
+.paginator .current:hover {
+  color: #333 !important;
+  border: 1px solid #979797;
+  background: linear-gradient(to bottom, #fff 0%, #dcdcdc 100%);
+}
+
+.paginator a:hover {
+  color: white !important;
+  border: 1px solid #111;
+  background: linear-gradient(to bottom, #585858 0%, #111 100%);
+}
+
+.paginator span {
+  padding: 0 1em;
+  cursor: default;
+}
+
+.paginator .disabled {
+  color: #666;
+}

hackage-server.cabal

@@ -255,6 +255,7 @@ library lib-server
     Distribution.Server.Util.Merge
     Distribution.Server.Util.ParseSpecVer
     Distribution.Server.Util.Markdown
+    Distribution.Server.Util.Paging
 
     Distribution.Server.Features
     Distribution.Server.Features.Browse

src/Distribution/Server/Features/Html.hs

@@ -75,6 +75,8 @@ import qualified Text.XHtml.Strict as XHtml
 import Text.XHtml.Table (simpleTable)
 import Distribution.PackageDescription (hasLibs)
 import Distribution.PackageDescription.Configuration (flattenPackageDescription)
+import qualified Distribution.Server.Pages.Recent as Pages
+import qualified Distribution.Server.Util.Paging as Paging
 
 
 -- TODO: move more of the below to Distribution.Server.Pages.*, it's getting
@@ -491,7 +493,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
   = HtmlCore{..}
   where
     candidatesCore = candidatesCoreResource
-    cores@CoreResource{packageInPath, lookupPackageName, lookupPackageId} = coreResource
+    cores@CoreResource {packageInPath, lookupPackageName, lookupPackageId} = coreResource
     versions = versionsResource
     docs     = documentationResource
 
@@ -535,8 +537,51 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
       , (resourceAt "/package/:package/revisions/.:format") {
             resourceGet  = [("html", serveCabalRevisionsPage)]
           }
+      , (resourceAt "/packages/recent.:format") {
+            resourceGet = [("html", serveRecentPage)]
+          }
+      , (resourceAt "/packages/recent/revisions.:format") {
+            resourceGet = [("html", serveRevisionPage)]
+          }
       ]
 
+    serveRecentPage :: DynamicPath -> ServerPartE Response
+    serveRecentPage _ = do
+      -- TODO
+      -- [x] Change paginate to use custom object to prohibit messing things up
+      -- [x] Extract out revision to HTML feature
+      -- [x] Show different pagination options in HTML
+      -- [-] Remove old HTML from RecentPackages Feature
+      -- [] Convert over RSS to use pagination with query params
+      -- [] Convert paginator HTML to look and act like search paginator
+      pkgIndex <- queryGetPackageIndex
+      users <- queryGetUserDb
+      page <- readWithDefault 1 <$> optional (look "page")
+      pageSize <- readWithDefault 25 <$> optional (look "pageSize")
+      let recentChanges = sortBy (flip $ comparing pkgOriginalUploadTime)
+                          (PackageIndex.allPackages pkgIndex)
+      let conf = Paging.createConf page pageSize recentChanges
+
+
+
+      return . toResponse $ Pages.recentPaging conf users recentChanges
+        where 
+          readWithDefault n = fromMaybe n . fmap (read :: String -> Int)
+
+    serveRevisionPage :: DynamicPath -> ServerPartE Response
+    serveRevisionPage _ = do
+      pkgIndex <- queryGetPackageIndex
+      users <- queryGetUserDb
+      page <- readWithDefault 1 <$> optional (look "page")
+      pageSize <- readWithDefault 50 <$> optional (look "pageSize")
+      let recentChanges = sortBy (flip $ comparing pkgOriginalUploadTime)
+                          (PackageIndex.allPackages pkgIndex)
+      let conf = Paging.createConf page pageSize recentChanges
+
+
+      return . toResponse $ Pages.revisionsPaging conf users recentChanges
+        where readWithDefault n = fromMaybe n . fmap (read :: String -> Int)
+
     serveBrowsePage :: DynamicPath -> ServerPartE Response
     serveBrowsePage _dpath = do
       template <- getTemplate templates "browse.html"

src/Distribution/Server/Features/RecentPackages.hs

@@ -92,14 +92,12 @@ recentPackagesFeature env
     recentPackagesResource = RecentPackagesResource {
         recentPackages = (extendResourcePath "/recent.:format" (corePackagesPage coreResource)) {
             resourceGet = [
-                ("html", const $ liftM (\(x,_,_,_) -> x) $ readAsyncCache cacheRecent)
-              , ("rss",  const $ addAllowOriginHeader >> (liftM (\(_,x,_,_) -> x) $ readAsyncCache cacheRecent))
+                ("rss",  const $ addAllowOriginHeader >> (liftM (\(_,x,_,_) -> x) $ readAsyncCache cacheRecent))
               ]
           },
         recentRevisions = (extendResourcePath "/recent/revisions.:format" (corePackagesPage coreResource)) {
             resourceGet = [
-                ("html", const $ liftM (\(_,_,x,_) -> x) $ readAsyncCache cacheRecent)
-              , ("rss",  const $ addAllowOriginHeader >> (liftM (\(_,_,_,x) -> x) $ readAsyncCache cacheRecent))
+                ("rss",  const $ addAllowOriginHeader >> (liftM (\(_,_,_,x) -> x) $ readAsyncCache cacheRecent))
               ]
           }
       }

src/Distribution/Server/Pages/Recent.hs

@@ -4,7 +4,9 @@ module Distribution.Server.Pages.Recent (
     recentPage,
     recentFeed,
     revisionsPage,
-    recentRevisionsFeed
+    recentRevisionsFeed,
+    recentPaging,
+    revisionsPaging,
   ) where
 
 import Distribution.Server.Packages.Types
@@ -36,32 +38,73 @@ import Data.Time.Format
          ( defaultTimeLocale, formatTime )
 import Data.Maybe
          ( listToMaybe)
+import Distribution.Server.Util.Paging (PaginatedConf (PaginatedConf), paginate, totalPages)
 
 -- | Takes a list of package info, in reverse order by timestamp.
---
-recentPage :: Users -> [PkgInfo] -> Html
-recentPage users pkgs =
-  let log_rows = map (makeRow users) (take 25 pkgs)
-      docBody = [XHtml.h2 << "Recent additions",
-                 XHtml.table ! [XHtml.align "center"] << log_rows,
-                 XHtml.anchor ! [XHtml.href recentRevisionsURL] << XHtml.toHtml "Recent revisions"]
-      rss_link = XHtml.thelink ! [XHtml.rel "alternate",
-                                  XHtml.thetype "application/rss+xml",
-                                  XHtml.title "Hackage RSS Feed",
-                                  XHtml.href rssFeedURL] << XHtml.noHtml
+
+recentPaging :: PaginatedConf -> Users -> [PkgInfo] -> Html
+recentPaging conf users pkgs =
+  let log_rows = makeRow users <$> paginate conf pkgs
+      docBody =
+        [ XHtml.h2 << "Recent additions",
+          XHtml.table ! [XHtml.align "center"] << log_rows,
+          paginator conf recentURL,
+          XHtml.anchor ! [XHtml.href recentRevisionsURL] << XHtml.toHtml "Recent revisions"
+        ]
+      rss_link =
+        XHtml.thelink
+          ! [ XHtml.rel "alternate",
+              XHtml.thetype "application/rss+xml",
+              XHtml.title "Hackage RSS Feed",
+              XHtml.href rssFeedURL
+            ]
+          << XHtml.noHtml
    in hackagePageWithHead [rss_link] "recent additions" docBody
 
-revisionsPage :: Users -> [PkgInfo] -> Html
-revisionsPage users pkgs =
-  let log_rows = map (makeRevisionRow users) (take 40 pkgs)
-      docBody = [XHtml.h2 << "Recent cabal metadata revisions",
-          XHtml.table ! [XHtml.align "center"] << log_rows]
-      rss_link = XHtml.thelink ! [XHtml.rel "alternate",
-                                  XHtml.thetype "application/rss+xml",
-                                  XHtml.title "Hackage Revisions RSS Feed",
-                                  XHtml.href revisionsRssFeedURL] << XHtml.noHtml
+
+recentPage :: Users -> [PkgInfo] -> Html
+recentPage = recentPaging (PaginatedConf 1 25 1000)
+
+
+paginator :: PaginatedConf -> URL -> Html 
+paginator pc@(PaginatedConf currPage _ totalAmount) baseUrl = 
+  let 
+    total = totalPages pc
+    infoText = "Showing " ++ show currPage ++ " to " ++ show total ++ " of " ++ show totalAmount ++ " entries"
+    info = XHtml.thediv << infoText
+    next = XHtml.anchor ! [XHtml.href (paginateURLNext pc baseUrl)] << "Next"
+    prev = XHtml.anchor ! [XHtml.href (paginateURLPrev pc baseUrl)] << "Previous"
+    wrapper = XHtml.thediv ! [XHtml.theclass "paginator"] << (prev <> next)
+  in XHtml.thediv ! [XHtml.identifier "paginatorContainer"] << mconcat [info, wrapper]
+
+
+-- Should actually check if next exists
+paginateURLNext,paginateURLPrev :: PaginatedConf -> URL -> URL
+paginateURLNext (PaginatedConf cp _ _) url = url <> "?page=" ++ (show . succ) cp
+paginateURLPrev (PaginatedConf cp _ _) url = url <> "?page=" ++ (show . pred) cp
+
+revisionsPaging :: PaginatedConf -> Users -> [PkgInfo] -> Html
+revisionsPaging conf users pkgs =
+  let log_rows = map (makeRevisionRow users) (paginate conf pkgs)
+      docBody =
+        [ XHtml.h2 << "Recent cabal metadata revisions",
+          XHtml.table ! [XHtml.align "center"] << log_rows,
+          paginator conf recentRevisionsURL
+        ]
+      rss_link =
+        XHtml.thelink
+          ! [ XHtml.rel "alternate",
+              XHtml.thetype "application/rss+xml",
+              XHtml.title "Hackage Revisions RSS Feed",
+              XHtml.href revisionsRssFeedURL
+            ]
+          << XHtml.noHtml
    in hackagePageWithHead [rss_link] "recent revisions" docBody
 
+-- Remove Later
+revisionsPage :: Users -> [PkgInfo] -> Html
+revisionsPage = revisionsPaging (PaginatedConf 1 50 1000)
+
 makeRow :: Users -> PkgInfo -> Html
 makeRow users pkginfo =
   XHtml.tr <<
@@ -110,6 +153,9 @@ packageURL pkgid = "/package/" ++ display pkgid
 rssFeedURL :: URL
 rssFeedURL = "/recent.rss"
 
+recentURL :: URL
+recentURL = "/packages/recent.html"
+
 recentAdditionsURL :: URL
 recentAdditionsURL = "/recent.html"
 

src/Distribution/Server/Util/Paging.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Distribution.Server.Util.Paging where
+import Text.XHtml (URL)
+
+-- Could design this way better
+-- Need to check that paging math comes out right
+data PaginatedConf = PaginatedConf
+  { currPage :: Int,
+    pageSize :: Int,
+    totalAmount :: Int
+  }
+
+totalPages :: PaginatedConf -> Int
+totalPages PaginatedConf {pageSize, totalAmount} = totalAmount `div` pageSize
+
+createConf :: Int -> Int -> [a] -> PaginatedConf
+createConf page pageSize xs = PaginatedConf page pageSize (length xs)
+
+paginate :: PaginatedConf -> [a] -> [a]
+paginate PaginatedConf {currPage, pageSize} = take pageSize . drop toDrop
+  where
+    toDrop = pageSize * pred currPage
+
+hasNext,hasPrev :: PaginatedConf -> Bool
+hasNext pc@PaginatedConf{currPage} = currPage < totalPages pc
+hasPrev PaginatedConf {currPage} = currPage >= 1
+
+
+allPagedURLS :: URL -> PaginatedConf -> [URL]
+allPagedURLS base pc = (\p -> base ++ "?page=" ++ show p ++ "&pageSize=" ++ (show . pageSize) pc) 
+    <$> [1..totalPages pc]