Commits

Luke Plant committed b28e49c

Added paging to index page

Comments (0)

Files changed (3)

src/Blog/Model.hs

 addLimitOffset sql limitOffset =
     BL.unpack $ regexReplace (" \\$LIMITOFFSET") (BL.pack $ " " ++ limitOffset) (BL.pack sql)
 
--- return 'LIMIT/OFFSET' for a page (1 indexed)
+-- return 'LIMIT/OFFSET' for a page (1 indexed), with an extra row
+-- which allows us to tell if there are more records
 makePagingLimitOffset page size =
-    let limit = size
+    let limit = size + 1
         offset = (page - 1) * size
     in "LIMIT " ++ (show limit) ++ " OFFSET " ++ (show offset)
 
+-- | Get a page of results, and a boolean which is True if there are more rows
+--
+-- The query must contain "$LIMITOFFSET" in an appropriate place to be replaced
+-- with the actual limit/offset clause
+pagedQuery cn sql params page pagesize =
+    let limitOffset = makePagingLimitOffset page pagesize
+        q = addLimitOffset sql limitOffset
+    in do
+      res <- quickQuery' cn q params
+      let (recs,rest) = splitAt pagesize res
+      return (recs, not $ null rest)
+
 ---- Constructors ----
 
 makePost row =
     [] -> return Nothing
     (postdata:_) -> return $ Just $ makePost postdata
 
-getRecentPosts cn p = do
-  let q = addLimitOffset getRecentPostsQuery (makePagingLimitOffset p 20)
-  res <- quickQuery' cn q []
-  return $ map makePost res
+getRecentPosts cn page = do
+  (res,more) <- pagedQuery cn getRecentPostsQuery [] page 20
+  return (map makePost res, more)
 
 getCategoriesForPost cn post = do
   res <- quickQuery' cn getCategoriesForPostQuery [toSql $ P.uid post]
 
 getRelatedPosts cn post categories = do
   let ids = map (Ct.uid) categories
-  let q = addLimitOffset (getRelatedPostsQuery ids) (makePagingLimitOffset 1 7)
-  res <- quickQuery' cn q [ toSql $ P.uid post
-                          , toSql $ P.timestamp post ]
+  (res,_) <- pagedQuery cn (getRelatedPostsQuery ids) [ toSql $ P.uid post
+                                                      , toSql $ P.timestamp post ] 1 7
   return $ map makePost res

src/Blog/Templates.hs

 
 -- Page specific templates
 
-mainIndexPage posts =
+mainIndexPage posts curpage moreposts =
     page $ defaultPageVars
-             { pcontent = h1 << "Recent posts"
-                          +++
-                          do post <- posts
-                             return (
-                                     (thediv ! [ theclass "summarylink" ]
-                                      << postLink post)
-                                     +++
-                                     (thediv ! [ theclass "summary" ]
-                                      << (primHtml $ P.summary_formatted post))
-                                    )
+             { pcontent = formatIndex posts curpage moreposts
              , ptitle = ""
              }
 
+formatIndex :: [P.Post] -> Int -> Bool -> Html
+formatIndex posts page shownext =
+    (h1 << "Recent posts")
+    +++
+    (do post <- posts
+        return (
+                (thediv ! [ theclass "summarylink" ]
+                 << postLink post)
+                +++
+                (thediv ! [ theclass "summary" ]
+                 << (primHtml $ P.summary_formatted post))
+               )
+    ) +++ (
+           pagingLinks indexUrl page shownext
+          )
+
+-- TODO - fix this to be able to work with URLs that have query
+-- strings already.
+pagingLinks :: String -> Int -> Bool -> Html
+pagingLinks url page shownext =
+    (thediv ! [theclass "paginglinks"]
+     << ((if page > 1
+          then makeLink url (page - 1) "<< Back"
+          else thespan << "<< Back")
+         +++
+         (toHtml " | ")
+         +++
+         (if shownext
+          then makeLink url (page + 1) "Next >>"
+          else thespan << "Next >>")
+        )
+     )
+    where makeLink url page text = toHtml (hotlink (url ++ "?p=" ++ (show page)) << text)
+
 categoriesPage = page $ defaultPageVars
                  { pcontent = h1 << "Categories"
                               +++

src/Blog/Views.hs

 module Blog.Views where
 
 import Ella.Framework (default404, View)
+import Ella.Param (captureOrDefault)
 import Ella.Request
 import Ella.Response
 import Ella.Utils (addHtml)
 
 ---- Views
 
--- | parse a value (packed in a Just) or return a default
---
--- This is useful in dealing with 'Maybe' vals returned from
--- getGET, getPOST etc.
-parseOrDefault v d = fromMaybe d (v >>= exactParse)
-
 -- View for the main page
 mainIndex :: Request -> IO (Maybe Response)
 mainIndex req = do
-  let page = (getGET "p" req) `parseOrDefault` 1 :: Int
+  let page = (getGET "p" req) `captureOrDefault` 1 :: Int
   cn <- connect
-  posts <- getRecentPosts cn page
-  return $ Just $ standardResponse $ mainIndexPage posts
+  (posts,more) <- getRecentPosts cn page
+  return $ Just $ standardResponse $ mainIndexPage posts page more
 
 -- View to help with debugging
 debug path req = return $ Just $ buildResponse [