Remove divison by zero in query params

Author: LeviButcher

datafiles/static/hackage.css

@@ -1066,8 +1066,10 @@ a.deprecated[href]:visited {
   border-radius: 2px;
 }
 
+/* Targeting of href for a tags higher up makes it more cumbersome to override */
 .paginator a[href]:link, .paginator a[href]:visited {
   color: #333;
+  text-decoration: none;
 }
 
 .paginator .current,
@@ -1077,7 +1079,7 @@ a.deprecated[href]:visited {
   background: linear-gradient(to bottom, #fff 0%, #dcdcdc 100%);
 }
 
-.paginator a:hover {
+.paginator a[href]:hover {
   color: white;
   border: 1px solid #111;
   background: linear-gradient(to bottom, #585858 0%, #111 100%);

src/Distribution/Server/Features/Html.hs

@@ -79,6 +79,7 @@ import qualified Distribution.Server.Pages.Recent as Pages
 import qualified Distribution.Server.Util.Paging as Paging
 import Distribution.Server.Features.RecentPackages (RecentPackagesFeature (RecentPackagesFeature, getRecentRevisions, getRecentPackages))
 import Data.Time (getCurrentTime)
+import Text.Read (readMaybe)
 
 
 -- TODO: move more of the below to Distribution.Server.Pages.*, it's getting
@@ -555,72 +556,60 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
           }
       ]
 
+    readParamWithDefaultAnyValid :: (Read a, HasRqData m, Monad m, Functor m, Alternative m) => 
+      a -> (a -> Bool) -> String -> m a
+    readParamWithDefaultAnyValid n f queryParam = do
+        m <- optional (look queryParam)
+        let parsed = m >>= readMaybe >>= (\x -> if f x then Just x else Nothing)
+
+        return $ fromMaybe n parsed
+
+
     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
-      -- [x] Remove old HTML from RecentPackages Feature
-      -- [/] Convert over RSS to use pagination with query params
-      --    Blocked due to not being able to query for query params
-      --    Maybe change RecentPackages to only return back cached packages then inject to HTML Feature
-      -- [/] Convert paginator HTML to look and act like search paginator
-      --    [] Check that Paging is done correctly
-      --    [] Make disabled state work on buttons
-      --    [] Add in Form to set pageSize
-
       recentPackages <- getRecentPackages
       users <- queryGetUserDb
-      page <- readWithDefault 1 <$> optional (look "page")
-      pageSize <- readWithDefault 25 <$> optional (look "pageSize")
-      
+      page <-  readParamWithDefaultAnyValid 1 (>= 1) "page"
+      pageSize <- readParamWithDefaultAnyValid 20 (>= 1) "pageSize"
+
       let conf = Paging.createConf page pageSize recentPackages
 
       return . toResponse $ Pages.recentPage conf users recentPackages
-        where 
-          readWithDefault n = fromMaybe n . fmap (read :: String -> Int)
 
     serveRecentRSS :: DynamicPath -> ServerPartE Response
     serveRecentRSS _ = do
       recentPackages <- getRecentPackages
       users <- queryGetUserDb
-      page <- readWithDefault 1 <$> optional (look "page")
-      pageSize <- readWithDefault 25 <$> optional (look "pageSize")
+      page <-  readParamWithDefaultAnyValid 1 (>= 1) "page"
+      pageSize <- readParamWithDefaultAnyValid 20 (>= 1) "pageSize"
       now   <- liftIO getCurrentTime
 
       let conf = Paging.createConf page pageSize recentPackages
 
       return . toResponse $ Pages.recentFeed conf users serverBaseURI now recentPackages
-        where 
-          readWithDefault n = fromMaybe n . fmap (read :: String -> Int)
 
     serveRevisionPage :: DynamicPath -> ServerPartE Response
     serveRevisionPage _ = do
       revisions <- getRecentRevisions
       users <- queryGetUserDb
-      page <- readWithDefault 1 <$> optional (look "page")
-      pageSize <- readWithDefault 50 <$> optional (look "pageSize")
+      page <-  readParamWithDefaultAnyValid 1 (>= 1) "page"
+      pageSize <- readParamWithDefaultAnyValid 40 (>= 1) "pageSize"
 
       let conf = Paging.createConf page pageSize revisions
 
-
       return . toResponse $ Pages.revisionsPage conf users revisions
-        where readWithDefault n = fromMaybe n . fmap (read :: String -> Int)
 
     serveRevisionRSS :: DynamicPath -> ServerPartE Response
     serveRevisionRSS _ = do
       revisions <- getRecentRevisions
       users <- queryGetUserDb
-      page <- readWithDefault 1 <$> optional (look "page")
-      pageSize <- readWithDefault 40 <$> optional (look "pageSize")
+      page <-  readParamWithDefaultAnyValid 1 (>= 1) "page"
+      pageSize <- readParamWithDefaultAnyValid 40 (>= 1) "pageSize"
       now   <- liftIO getCurrentTime
 
       let conf = Paging.createConf page pageSize revisions
 
-
       return . toResponse $ Pages.recentRevisionsFeed conf users serverBaseURI now revisions
-        where readWithDefault n = fromMaybe n . fmap (read :: String -> Int)
 
     serveBrowsePage :: DynamicPath -> ServerPartE Response
     serveBrowsePage _dpath = do

src/Distribution/Server/Pages/Recent.hs

@@ -24,24 +24,24 @@ import Distribution.Text
 import Distribution.Utils.ShortText (fromShortText)
 
 import qualified Text.XHtml.Strict as XHtml
-import Text.XHtml
-         ( Html, URL, (<<), (!) )
+import Text.XHtml ( Html, URL, (<<), (!) )
 import qualified Text.RSS as RSS
 import Text.RSS ( RSS(RSS) )
 import Network.URI ( URI(..), uriToString )
 import Data.Time.Clock ( UTCTime )
 import Data.Time.Format ( defaultTimeLocale, formatTime )
-import Data.Maybe ( listToMaybe)
-import Distribution.Server.Util.Paging (PaginatedConf (..), paginate, allPagedURLS, hasNext, hasPrev, pageIndexRange)
-import qualified Text.XHtml as Xhtml
+import Data.Maybe ( listToMaybe, fromMaybe)
+import Distribution.Server.Util.Paging (PaginatedConfiguration(..), hasNext,
+  hasPrev, nextURL, pageIndexRange, paginate, prevURL, toURL, allPagedURLs)
 
 -- | Takes a list of package info, in reverse order by timestamp.
 
-recentPage :: PaginatedConf -> Users -> [PkgInfo] -> Html
+recentPage :: PaginatedConfiguration -> Users -> [PkgInfo] -> Html
 recentPage conf users pkgs =
   let log_rows = makeRow users <$> paginate conf pkgs
       docBody =
         [ XHtml.h2 << "Recent additions",
+          pageSizeForm recentURL,
           XHtml.table ! [XHtml.align "center"] << log_rows,
           paginator conf recentURL,
           XHtml.anchor ! [XHtml.href recentRevisionsURL] << XHtml.toHtml "Recent revisions"
@@ -51,26 +51,36 @@ recentPage conf users pkgs =
           ! [ XHtml.rel "alternate",
               XHtml.thetype "application/rss+xml",
               XHtml.title "Hackage RSS Feed",
-              XHtml.href rssFeedURL
+              XHtml.href $ toURL rssFeedURL conf
             ]
           << XHtml.noHtml
    in hackagePageWithHead [rss_link] "recent additions" docBody
 
-paginator :: PaginatedConf -> URL -> Html 
-paginator pc@(PaginatedConf currPage _ totalAmount) baseUrl = 
+
+pageSizeForm :: URL -> Html
+pageSizeForm base = 
+  let pageSizeLabel = XHtml.label ! [XHtml.thefor "pageSize"] << "Page Size: "
+      pageSizeInput = XHtml.input ! [XHtml.thetype "number", XHtml.name "pageSize", XHtml.strAttr "min" "0"]
+      submitButton = XHtml.button ! [XHtml.thetype "submit"] << "Submit"
+      theForm = XHtml.form ! [XHtml.action base, XHtml.method "GET"]
+  in theForm << (pageSizeLabel <> pageSizeInput <> submitButton)
+
+
+paginator :: PaginatedConfiguration -> URL -> Html 
+paginator pc@PaginatedConfiguration{currPage,totalAmount} baseUrl = 
   let 
     (start, end) = pageIndexRange pc
     infoText = "Showing " ++ show start ++ " to " ++ show end ++ " of " ++ show totalAmount ++ " entries"
     info = XHtml.thediv << infoText
 
     next = if hasNext pc 
-      then XHtml.anchor ! [XHtml.href (paginateURLNext pc baseUrl)] << "Next" 
-      else Xhtml.noHtml
+      then XHtml.anchor ! [XHtml.href (fromMaybe "" (nextURL baseUrl pc))] << "Next" 
+      else XHtml.noHtml
     prev = if hasPrev pc 
-      then XHtml.anchor ! [XHtml.href (paginateURLPrev pc baseUrl) ] << "Previous" 
+      then XHtml.anchor ! [XHtml.href (fromMaybe "" (prevURL baseUrl pc)) ] << "Previous" 
       else XHtml.noHtml 
 
-    pagedURLS = zip [1..] (allPagedURLS baseUrl pc)
+    pagedURLS = zip [1..] (allPagedURLs baseUrl pc)
     pagedLinks = (\(x,y) -> XHtml.anchor ! [XHtml.href y, 
       if currPage == x then XHtml.theclass "current" else noAttr ] << show x) <$> pagedURLS
 
@@ -84,14 +94,14 @@ paginator pc@(PaginatedConf currPage _ totalAmount) baseUrl =
 noAttr :: XHtml.HtmlAttr
 noAttr = XHtml.theclass ""
 
--- Worst code I've written so far
-reducePagedLinks :: PaginatedConf -> [Html] -> Html
-reducePagedLinks PaginatedConf{currPage} xs
+-- | Generates a list of links of the current possible paging links, recreates the functionality of the paging links on the search page
+reducePagedLinks :: PaginatedConfiguration -> [Html] -> Html
+reducePagedLinks PaginatedConfiguration{currPage} xs
   | currPage >= (length xs - 3) = mconcat  . keepLastPages .fillFirst $ xs -- Beginning ellipses
   | length xs > 5 && currPage < 5 = mconcat . keepFirstPages . fillLast $ xs -- Ending ellipses
   | length xs <= 5 = mconcat xs -- Do Nothing
   | otherwise = mconcat . keepMiddlePages . fillLast . fillFirst $ xs -- Begin and End ellipses
-  where filler = XHtml.anchor << "..."
+  where filler = XHtml.thespan << "..."
         fillFirst x = insertAt 1 filler x
         fillLast x = insertAt (pred . length $ x) filler x
         keepFirstPages x = case splitAt (length x - 2) x of (hts, hts') -> take 5 hts ++ hts'
@@ -106,16 +116,12 @@ insertAt n a x = case splitAt n x of (hts, hts') -> hts ++ [a] ++ hts'
 takeLast :: Int -> [a] -> [a]
 takeLast n = reverse . take n . reverse
 
--- 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
-
-revisionsPage :: PaginatedConf -> Users -> [PkgInfo] -> Html
+revisionsPage :: PaginatedConfiguration -> Users -> [PkgInfo] -> Html
 revisionsPage conf users pkgs =
   let log_rows = map (makeRevisionRow users) (paginate conf pkgs)
       docBody =
         [ XHtml.h2 << "Recent cabal metadata revisions",
+          pageSizeForm recentRevisionsURL,
           XHtml.table ! [XHtml.align "center"] << log_rows,
           paginator conf recentRevisionsURL
         ]
@@ -124,7 +130,7 @@ revisionsPage conf users pkgs =
           ! [ XHtml.rel "alternate",
               XHtml.thetype "application/rss+xml",
               XHtml.title "Hackage Revisions RSS Feed",
-              XHtml.href revisionsRssFeedURL
+              XHtml.href $ toURL revisionsRssFeedURL conf
             ]
           << XHtml.noHtml
    in hackagePageWithHead [rss_link] "recent revisions" docBody
@@ -190,7 +196,7 @@ recentRevisionsURL :: URL
 recentRevisionsURL = "/packages/recent/revisions.html"
 
 
-recentFeed :: PaginatedConf -> Users -> URI -> UTCTime -> [PkgInfo] -> RSS
+recentFeed :: PaginatedConfiguration -> Users -> URI -> UTCTime -> [PkgInfo] -> RSS
 recentFeed conf users hostURI now pkgs = RSS
   "Recent additions"
   (hostURI { uriPath = recentAdditionsURL})
@@ -203,7 +209,7 @@ recentFeed conf users hostURI now pkgs = RSS
     pkgList = paginate conf pkgs
     updated = maybe now (fst . pkgOriginalUploadInfo) (listToMaybe pkgList)
 
-recentRevisionsFeed :: PaginatedConf -> Users -> URI -> UTCTime -> [PkgInfo] -> RSS
+recentRevisionsFeed :: PaginatedConfiguration -> Users -> URI -> UTCTime -> [PkgInfo] -> RSS
 recentRevisionsFeed conf users hostURI now pkgs = RSS
   "Recent revisions"
   (hostURI { uriPath = recentRevisionsURL})

src/Distribution/Server/Util/Paging.hs

@@ -1,45 +1,80 @@
 {-# LANGUAGE NamedFieldPuns #-}
-module Distribution.Server.Util.Paging where
+
+module Distribution.Server.Util.Paging 
+(
+  totalPages,
+  createConf,
+  hasNext,
+  hasPrev,
+  paginate,
+  pageIndexStart,
+  pageIndexRange,
+  pageIndexEnd,
+  allPagedURLs,
+  nextURL,
+  prevURL,
+  toURL,
+  PaginatedConfiguration(..),
+)
+where
 import Text.XHtml (URL)
+import Data.List (genericTake, genericDrop, genericLength)
 
--- This could be designed better, perhaps turning PaginatedConf into a function that returns the paging info 
+-- This could be better designed, perhaps turning PaginatedConfiguration into a function that returns the paging info 
 --  and the paged data
-data PaginatedConf = PaginatedConf
+data PaginatedConfiguration = PaginatedConfiguration
   { currPage :: Int,
     pageSize :: Int,
     totalAmount :: Int
   }
 
-totalPages :: PaginatedConf -> Int
-totalPages PaginatedConf {pageSize, totalAmount} = 
+-- Assumes pageSize isn't 0, not the best design
+totalPages :: PaginatedConfiguration -> Int
+totalPages PaginatedConfiguration {pageSize, totalAmount} = 
     case totalAmount `quotRem` pageSize of
       (x,r)
         | r == 0 -> x
         | otherwise -> succ x
 
-createConf :: Int -> Int -> [a] -> PaginatedConf
-createConf page pageSize xs = PaginatedConf page pageSize (length xs)
+createConf :: Int -> Int -> [a] -> PaginatedConfiguration
+createConf page pageSize xs = PaginatedConfiguration page pageSize (genericLength xs)
 
-paginate :: PaginatedConf -> [a] -> [a]
-paginate PaginatedConf {currPage, pageSize} = take pageSize . drop toDrop
+paginate :: PaginatedConfiguration -> [a] -> [a]
+paginate PaginatedConfiguration {currPage, pageSize} = genericTake pageSize . genericDrop  toDrop
   where
-    toDrop = pageSize * pred currPage
+    toDrop =  pageSize * pred currPage
 
-hasNext,hasPrev :: PaginatedConf -> Bool
-hasNext pc@PaginatedConf{currPage} = currPage < totalPages pc
-hasPrev PaginatedConf {currPage} = currPage > 1
+hasNext,hasPrev :: PaginatedConfiguration -> Bool
+hasNext pc@PaginatedConfiguration{currPage} =  currPage < totalPages pc
+hasPrev PaginatedConfiguration {currPage} =  currPage > 1
 
 -- | Returns the index positions that the current PaginatedConfiguration would show (Starts at 1)
-pageIndexRange :: PaginatedConf -> (Int, Int)
-pageIndexRange conf@PaginatedConf{currPage, pageSize, totalAmount} = (start, end)
-  where start = succ $ (currPage * pageSize) - pageSize
-        end = if currPage == totalPages conf then totalAmount else currPage * pageSize
+pageIndexRange :: PaginatedConfiguration -> (Int, Int)
+pageIndexRange conf@PaginatedConfiguration{currPage, pageSize, totalAmount} = (start, end)
+  where start = succ $  currPage *  pageSize -  pageSize
+        end = if  currPage == totalPages conf then totalAmount else  currPage *  pageSize
 
-pageIndexStart, pageIndexEnd ::  PaginatedConf -> Int
+pageIndexStart, pageIndexEnd ::  PaginatedConfiguration -> Int
 pageIndexStart = fst . pageIndexRange
 pageIndexEnd = snd . pageIndexRange
 
 
-allPagedURLS :: URL -> PaginatedConf -> [URL]
-allPagedURLS base pc = (\p -> base ++ "?page=" ++ show p ++ "&pageSize=" ++ (show . pageSize) pc) 
-    <$> [1..totalPages pc]
+allPagedURLs :: URL -> PaginatedConfiguration -> [URL]
+allPagedURLs base pc = toURL base . (\x -> pc{currPage=x}) <$> [1..totalPages pc]
+
+
+-- | Converts the PaginatedConfiguration to a URL, Assumes no query params in url
+toURL :: URL -> PaginatedConfiguration -> URL
+toURL base PaginatedConfiguration{currPage, pageSize} = base ++ "?page=" ++ show currPage ++ "&pageSize=" ++ show pageSize
+
+nextURL :: URL -> PaginatedConfiguration -> Maybe URL
+nextURL base conf@PaginatedConfiguration {currPage}
+  |  page > totalPages conf = Nothing
+  | otherwise = Just $ toURL base conf{currPage = page}
+  where page = succ currPage 
+
+prevURL :: URL -> PaginatedConfiguration -> Maybe URL
+prevURL base conf@PaginatedConfiguration {currPage}
+  | page < 1 = Nothing
+  | otherwise = Just $ toURL base conf{currPage=page}
+  where page = pred currPage