Commits

Luke Plant committed f89ed5f

Implemented view for individual categories.

Comments (0)

Files changed (4)

src/Blog/Model.hs

                   , getCategoriesForPost
                   , getCommentsForPost
                   , getRelatedPosts
+                  , getCategoryBySlug
                   , getCategories
                   , getCategoriesBulk
+                  , getPostsForCategory
                   ) where
 
 import Database.HDBC
 import qualified Blog.Post as P
 import qualified Blog.Category as Ct
 import qualified Blog.Comment as Cm
+import qualified Blog.Settings as Settings
 import qualified Data.ByteString.Lazy.Char8 as BL
 
 ------ Create -------
 getPostByIdQuery        = "SELECT id, title, slug, post_raw, post_formatted, summary_raw, summary_formatted, format_id, timestamp, comments_open FROM posts WHERE id = ?;"
 getPostBySlugQuery      = "SELECT id, title, slug, '',       post_formatted, '',          '',                '',        timestamp, comments_open FROM posts WHERE slug = ?;"
 getRecentPostsQuery     = "SELECT id, title, slug, '',       '',             '',          summary_formatted, '',        timestamp, ''            FROM posts ORDER BY timestamp DESC $LIMITOFFSET;"
-
+getPostsForCategoryQuery= "SELECT id, title, slug, '',       '',             '',          summary_formatted, '',        timestamp, ''            FROM posts INNER JOIN post_categories ON posts.id = post_categories.post_id WHERE post_categories.category_id = ? ORDER BY timestamp DESC $LIMITOFFSET;"
 
 -- Used to get post related to a post, ordered to favour posts with
 -- more matching categories and close in time to the original post
 getRelatedPostsQuery ids = "SELECT id, title, slug, '',       '',             '',          '',                '',               '', ''            FROM posts INNER JOIN (SELECT post_id, COUNT(post_id) AS c from post_categories WHERE category_id IN " ++ sqlInIds ids ++ " GROUP BY post_id) as t2 ON posts.id = t2.post_id AND posts.id <> ? ORDER BY c DESC, abs(posts.timestamp - ?) ASC $LIMITOFFSET;"
 
+getCategoryBySlugQuery    = "SELECT categories.id, categories.name, categories.slug FROM categories WHERE slug = ?;"
 getCategoriesQuery        = "SELECT categories.id, categories.name, categories.slug FROM categories ORDER BY slug;"
 getCategoriesForPostQuery = "SELECT categories.id, categories.name, categories.slug FROM categories INNER JOIN post_categories ON categories.id = post_categories.category_id WHERE post_categories.post_id = ? ORDER BY categories.slug;"
 getCategoriesBulkQuery ids= "SELECT categories.id, categories.name, categories.slug, post_categories.post_id FROM categories INNER JOIN post_categories ON categories.id = post_categories.category_id WHERE post_categories.post_id IN " ++ sqlInIds ids ++ " ORDER BY categories.slug;"
 
 getRecentPosts :: (IConnection conn) => conn -> Int -> IO ([P.Post], Bool)
 getRecentPosts cn page = do
-  (res,more) <- pagedQuery cn getRecentPostsQuery [] page 20
+  (res,more) <- pagedQuery cn getRecentPostsQuery [] page Settings.post_page_size
   return (map makePost res, more)
 
+getPostsForCategory :: (IConnection conn) => conn -> Ct.Category -> Int -> IO ([P.Post], Bool)
+getPostsForCategory cn cat curpage = do
+  (res,more) <- pagedQuery cn getPostsForCategoryQuery [toSql $ Ct.uid cat] curpage Settings.post_page_size
+  return (map makePost res, more)
+
+getCategoryBySlug :: (IConnection conn) => conn -> String -> IO (Maybe Ct.Category)
+getCategoryBySlug cn slug = do
+  res <- quickQuery' cn getCategoryBySlugQuery [toSql slug]
+  case res of
+    [] -> return Nothing
+    (rs:_) -> return $ Just $ makeCategory rs
+
 getCategories :: (IConnection conn) => conn -> IO [Ct.Category]
 getCategories cn = do
   res <- quickQuery' cn getCategoriesQuery []

src/Blog/Templates.hs

              }
 
 formatIndex :: [(P.Post, [C.Category])] -> Int -> Bool -> Html
-formatIndex postInfo page shownext =
+formatIndex postInfo curpage shownext =
     (h1 << "Recent posts")
     +++
     (do (post, cats) <- postInfo
                  << (primHtml $ P.summary_formatted post))
                )
     ) +++ (
-           pagingLinks indexUrl page shownext
+           pagingLinks indexUrl curpage shownext
           )
 
 categoriesPage :: [C.Category] -> Html
     (thediv ! [theclass "category"]
      << categoryLink cat)
 
+categoryPage :: C.Category -> [P.Post] -> Int -> Bool -> Html
+categoryPage cat posts curpage moreposts =
+    page $ defaultPageVars
+         { pcontent = formatCategoryIndex cat posts curpage moreposts
+         , ptitle = C.name cat
+         }
+
+formatCategoryIndex cat posts curpage moreposts = 
+    (h1 << ("Category: " ++ C.name cat))
+    +++
+    (do post <- posts
+        return (
+                (thediv ! [ theclass "summarylink" ]
+                 << postLink post)
+                +++
+                (thediv ! [ theclass "summary" ]
+                 << (primHtml $ P.summary_formatted post))
+               )
+    ) +++ (
+           pagingLinks (categoryUrl cat) curpage moreposts
+          )
+
+
 postPage :: P.Post        -- ^ The Post to display
          -> [C.Category]  -- ^ Categories the post is in
          -> [Cm.Comment]  -- ^ Comments belonging to the poast

src/Blog/Views.hs

 ---- Views
 
 -- View for the main page
-mainIndex :: Request -> IO (Maybe Response)
+mainIndex :: View
 mainIndex req = do
-  let page = (getGET "p" req) `captureOrDefault` 1 :: Int
+  let curpage = getPage req
   cn <- connect
-  (posts,more) <- getRecentPosts cn page
+  (posts,more) <- getRecentPosts cn curpage
   cats <- getCategoriesBulk cn posts
-  return $ Just $ standardResponse $ mainIndexPage (zip posts cats) page more
+  return $ Just $ standardResponse $ mainIndexPage (zip posts cats) curpage more
 
 -- View to help with debugging
 debug path req = return $ Just $ buildResponse [
 postsRedirectView req = return $ Just $ redirectResponse indexUrl :: IO (Maybe Response)
 
 -- View that shows an overview of categories
+categoriesView :: View
 categoriesView req = do
   cn <- connect
   cats <- getCategories cn
 
 -- View that shows posts for an individual category
 categoryView :: String -> View
-categoryView slug = dummyView
+categoryView slug req = do
+  let curpage = getPage req
+  cn <- connect
+  mcat <- getCategoryBySlug cn slug
+  case mcat of
+    Nothing -> return $ Just $ custom404
+    Just cat -> do
+              (posts,more) <- getPostsForCategory cn cat (getPage req)
+              return $ Just $ standardResponse $ categoryPage cat posts curpage more
 
 -- View that shows individual post
 postView :: String -> View
             return $ Just $ standardResponse $ postPage post cats comments related
 
 aboutView = dummyView
+
+-- Utilities
+
+getPage req = (getGET "p" req) `captureOrDefault` 1 :: Int

src/Blog/settingslocal.hs

 prog_uri = "/cgi-bin/blog.cgi" -- Used for redirecting
 blog_author_name = "luke"
 
+post_page_size = 20 :: Int
 
 -- Testing
 testdb_sqlite_path = "/home/luke/devel/haskell/blog/testsuite/test.db"