Commits

Luke Plant  committed b865b65

Added 'related posts' feature

  • Participants
  • Parent commits 99479b9

Comments (0)

Files changed (4)

File src/Blog/Model.hs

                   , getRecentPosts
                   , getCategoriesForPost
                   , getCommentsForPost
+                  , getRelatedPosts
                   ) where
 
 import Database.HDBC
 import qualified Blog.Post as P
 import qualified Blog.Category as Ct
 import qualified Blog.Comment as Cm
+import qualified Data.List as List
 
 ------ Create -------
 getDbId cn =
 -- (we can then use the same 'makePost' function)
 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 = ?;"
-getRecentPostQueries    = "SELECT id, title, slug, '',       '',             '',          summary_formatted, '',        timestamp, ''            FROM posts ORDER BY timestamp DESC LIMIT 20;"
+getRecentPostsQuery     = "SELECT id, title, slug, '',       '',             '',          summary_formatted, '',        timestamp, ''            FROM posts ORDER BY timestamp DESC LIMIT 20;"
+
+
+getRelatedPostsQuery ids= "SELECT DISTINCT id, title, slug,'', '',           '',          '',                '',               '', ''            FROM posts INNER JOIN (SELECT post_id, COUNT(post_id) 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, timestamp DESC LIMIT 6;"
 
 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;"
 
 getCommentByIdQuery      = "SELECT id, post_id, timestamp, name, email, text_raw, text_formatted, format_id FROM comments WHERE id = ?;"
 getCommentsForPostQuery  = "SELECT id, '',      timestamp, name, email, '',       text_formatted, ''        FROM comments WHERE post_id = ? ORDER BY timestamp ASC;"
 
+
+-- SQL stuff
+sqlInIds :: [Int] -> String
+sqlInIds ids = "(" ++ (concat $ List.intersperse "," $ map show ids) ++ ")"
+
 ---- Constructors ----
 
 makePost row =
     (postdata:_) -> return $ Just $ makePost postdata
 
 getRecentPosts cn = do
-  res <- quickQuery' cn getRecentPostQueries []
+  res <- quickQuery' cn getRecentPostsQuery []
   return $ map makePost res
 
 getCategoriesForPost cn post = do
 getCommentsForPost cn post = do
   res <- quickQuery' cn getCommentsForPostQuery [toSql $ P.uid post]
   return $ map makeComment res
+
+getRelatedPosts cn post categories = do
+  let ids = map (Ct.uid) categories
+  res <- quickQuery' cn (getRelatedPostsQuery ids) [toSql $ P.uid post]
+  return $ map makePost res

File src/Blog/Templates.hs

 import qualified Blog.Post as P
 import qualified Blog.Category as C
 import qualified Blog.Comment as Cm
+import qualified Blog.Settings as Settings
 import System.Locale (defaultTimeLocale)
 import System.Time.Utils (epochToClockTime)
 import System.Time (toUTCTime, formatCalendarTime)
                  , ptitle = "Categories"
                  }
 
-postPage post categories comments =
+postPage post categories comments related =
     page $ defaultPageVars
-             { pcontent = formatPost post categories comments
+             { pcontent = formatPost post categories comments related
              , ptitle = P.title post
              }
 
     )
 
 
-formatPost post categories comments =
+formatPost post categories comments otherposts =
     (h1 ! [theclass "posttitle"] << P.title post
      +++
      metaInfoLine post categories "metainfo"
       << (primHtml $ P.post_formatted post)
      )
      +++
+     (if null otherposts
+      then thediv << ""
+      else (thediv ! [theclass "related"]
+            << ((h1 << "Related:")
+                +++ (unordList $ map formatRelated otherposts))
+           )
+     )
+     +++
      (thediv ! [theclass "comments"]
       << (h1 << "Comments:")
              +++ if null comments
      )
     )
 
+commentclass comment = "comment" ++
+    if (Cm.name comment == Settings.blog_author_name)
+       then " author"
+       else ""
+
 formatComment comment =
-    (thediv ! [theclass "comment"] <<
-     ((thediv ! [theclass "commentby"] << formatName (Cm.name comment))
+    (thediv ! [theclass (commentclass comment)] <<
+     (
+      (thediv ! [theclass "commentby"] <<
+       (thespan << (formatName $ Cm.name comment)
+        +++
+        (thespan ! [theclass "timestamp"] << showDate (Cm.timestamp comment))
+       )
+      )
       +++
-      (thediv ! [theclass "commenttext"]
-       << (primHtml $ Cm.text_formatted comment))
+      (thediv ! [theclass "commenttext"] <<
+       (primHtml $ Cm.text_formatted comment))
      )
     )
 
+formatRelated = postLink
+
 formatName name = if null name
                   then "Anonymous Coward"
                   else name
 postLink p = toHtml $ hotlink (postUrl p) << (P.title p)
 
 
-showDate timestamp = formatCalendarTime defaultTimeLocale  "%Y-%m-%d" (toUTCTime $ epochToClockTime timestamp)
+showDate timestamp = formatCalendarTime defaultTimeLocale  "%Y-%m-%d %H:%M" (toUTCTime $ epochToClockTime timestamp)

File src/Blog/Views.hs

 import Blog.Templates
 import Blog.Links
 import Blog.DB (connect)
-import Blog.Model (getPostBySlug, getCategoriesForPost, getRecentPosts, getCommentsForPost)
+import Blog.Model (getPostBySlug, getCategoriesForPost, getRecentPosts, getCommentsForPost, getRelatedPosts)
 
 standardResponse html = buildResponse [
                          addHtml html
     Just post -> do
             cats <- getCategoriesForPost cn post
             comments <- getCommentsForPost cn post
-            return $ Just $ standardResponse $ postPage post cats comments
+            related <- getRelatedPosts cn post cats
+            return $ Just $ standardResponse $ postPage post cats comments related
 
 aboutView = dummyView

File src/Blog/settingslocal.hs

 sqlite_path = "/home/luke/httpd/lukeplant.me.uk/web/cgi-bin/data/test1.db"
 root_url = "/blog/"
 prog_uri = "/cgi-bin/blog.cgi" -- Used for redirecting
+blog_author_name = "luke"
+
 
 -- Testing
 testdb_sqlite_path = "/home/luke/devel/haskell/blog/testsuite/test.db"