Commits

Luke Plant committed 55aa573

Implemented 'categories' view

Comments (0)

Files changed (3)

src/Blog/Model.hs

                   , getCategoriesForPost
                   , getCommentsForPost
                   , getRelatedPosts
+                  , getCategories
                   , getCategoriesBulk
                   ) where
 
 -- 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;"
 
+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;"
 
   (res,more) <- pagedQuery cn getRecentPostsQuery [] page 20
   return (map makePost res, more)
 
+getCategories :: (IConnection conn) => conn -> IO [Ct.Category]
+getCategories cn = do
+  res <- quickQuery' cn getCategoriesQuery []
+  return $ map makeCategory res
+
 getCategoriesForPost :: (IConnection conn) => conn -> P.Post -> IO [Ct.Category]
 getCategoriesForPost cn post = do
   res <- quickQuery' cn getCategoriesForPostQuery [toSql $ P.uid post]

src/Blog/Templates.hs

      )
     where makeLink url page text = toHtml (hotlink (url ++ "?p=" ++ (show page)) << text)
 
-categoriesPage = page $ defaultPageVars
-                 { pcontent = h1 << "Categories"
-                              +++
-                              p << "TODO"
-                 , ptitle = "Categories"
-                 }
+categoriesPage :: [C.Category] -> Html
+categoriesPage cats =
+    page $ defaultPageVars
+             { pcontent = h1 << "Categories"
+                          +++
+                          (map formatCategoryLink cats)
+             , ptitle = "Categories"
+             }
+
+formatCategoryLink cat =
+    (thediv ! [theclass "category"]
+     << categoryLink cat)
 
 postPage :: P.Post        -- ^ The Post to display
          -> [C.Category]  -- ^ Categories the post is in

src/Blog/Views.hs

 postsRedirectView req = return $ Just $ redirectResponse indexUrl :: IO (Maybe Response)
 
 -- View that shows an overview of categories
-categoriesView req = return $ Just $ standardResponse categoriesPage :: IO (Maybe Response)
+categoriesView req = do
+  cn <- connect
+  cats <- getCategories cn
+  return $ Just $ standardResponse $ categoriesPage cats
 
 -- View that shows posts for an individual category
 categoryView :: String -> View