Commits

Luke Plant committed 7a2bb47

Implemented feeds

Comments (0)

Files changed (7)

         SHA >= 1.0.2,
         HStringTemplate >= 0.6.1,
         text >= 0.3,
+        feed >= 0.3.7,
+        time >= 1.1.3,
+        xml >= 1.3.4,
         ella >= 0.1.2
   Main-is: BlogCgi.hs
   hs-source-dirs: src

src/Blog/Feeds.hs

+module Blog.Feeds ( allPostsFeed
+                  , allCommentsFeed
+                  , categoryPostsFeed
+                  , postCommentFeed
+                  )
+
+where
+
+import Blog.Links
+import Data.Time (UTCTime)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
+import Data.Time.Format (formatTime)
+import System.Locale (defaultTimeLocale)
+import Text.Atom.Feed
+import qualified Blog.Category as C
+import qualified Blog.Comment as Cm
+import qualified Blog.Post as P
+import qualified Blog.Settings as Settings
+
+rfc3339 :: UTCTime -> String
+rfc3339 d = formatTime defaultTimeLocale "%FT%TZ" d
+
+formatTimestamp :: Int -> String
+formatTimestamp = rfc3339 . posixSecondsToUTCTime . realToFrac
+
+fullUrl url = Settings.absolute_root ++ url
+
+selfLink url = Link { linkHref = fullUrl url
+                    , linkRel = Just $ Left "self"
+                    , linkType = Nothing
+                    , linkHrefLang = Nothing
+                    , linkTitle = Nothing
+                    , linkLength = Nothing
+                    , linkAttrs = []
+                    , linkOther = []
+                    }
+
+htmlLink url = Link { linkHref = fullUrl url
+                    , linkRel = Just $ Left "alternate"
+                    , linkType = Just "text/html"
+                    , linkHrefLang = Nothing
+                    , linkTitle = Nothing
+                    , linkLength = Nothing
+                    , linkAttrs = []
+                    , linkOther = []
+                    }
+
+authors = [ Person { personName = "Luke Plant"
+                   , personURI = Just "http://lukeplant.me.uk/"
+                   , personEmail = Nothing
+                   , personOther = []
+                   }
+          ]
+
+commentAuthor name = Person { personName = name
+                            , personURI = Nothing
+                            , personEmail = Nothing
+                            , personOther = []
+                            }
+
+mkPostEntry post =
+    Entry { entryId = fullUrl $ postUrl post
+          , entryTitle = TextString $ P.title post
+          , entryUpdated = formatTimestamp $ P.timestamp post
+          , entryAuthors = authors
+          , entryCategories = []
+          , entryContent = Just $ HTMLContent $ P.post_formatted post
+          , entryContributor = []
+          , entryLinks = [ htmlLink $ postUrl post
+                         ]
+          , entryPublished = Just $ formatTimestamp $ P.timestamp post
+          , entryRights = Nothing
+          , entrySource = Nothing
+          , entrySummary = Just $ HTMLString $ P.summary_formatted post
+          , entryInReplyTo = Nothing
+          , entryInReplyTotal = Nothing
+          , entryAttrs = []
+          , entryOther = []
+          }
+
+-- | creates a Feed for a list of posts, which must already be in descending
+-- order by timestamp (newest first)
+allPostsFeed :: [P.Post] -> Feed
+allPostsFeed posts =
+    Feed { feedId = fullUrl $ allPostsFeedUrl
+         , feedTitle = TextString "All Unkept"
+         , feedUpdated = if null posts
+                         then "" -- the best we can do
+                         else formatTimestamp $ P.timestamp $ head $ posts
+         , feedAuthors = authors
+         , feedCategories = [] -- Possible TODO
+         , feedContributors = []
+         , feedGenerator = Nothing
+         , feedIcon = Just "http://lukeplant.me.uk/favicon.ico"
+         , feedLinks = [ selfLink allPostsFeedUrl
+                       , htmlLink indexUrl
+                       ]
+         , feedLogo = Nothing -- TODO
+         , feedRights = Just $ TextString "© Luke Plant"
+         , feedSubtitle = Nothing
+         , feedEntries = map mkPostEntry posts
+         , feedAttrs = []
+         , feedOther = []
+         }
+
+categoryPostsFeed cat posts =
+    let basefeed = allPostsFeed posts
+        url = categoryPostsFeedUrl cat
+    in basefeed { feedId = fullUrl $ url
+                , feedTitle = TextString $ "All Unkept - " ++ C.name cat
+                , feedLinks = [ selfLink url
+                              , htmlLink $ categoryUrl cat
+                              ]
+                }
+
+--mkCommentEntry :: (Cm.Comment, P.Post) -> Entry
+mkCommentEntry (comment, post) =
+    Entry { entryId = fullUrl $ commentUrl comment post
+          , entryTitle = TextString ("Comment #" ++ (show $ Cm.uid comment) ++ " on post " ++ (P.title post))
+          , entryUpdated = formatTimestamp $ Cm.timestamp comment
+          , entryAuthors = [commentAuthor $ Cm.name comment]
+          , entryCategories = []
+          , entryContent = Just $ HTMLContent $ Cm.text_formatted comment
+          , entryContributor = []
+          , entryLinks = [ htmlLink $ commentUrl comment post
+                         ]
+          , entryPublished = Just $ formatTimestamp $ Cm.timestamp comment
+          , entryRights = Nothing
+          , entrySource = Nothing
+          , entrySummary = Nothing
+          , entryInReplyTo = Nothing
+          , entryInReplyTotal = Nothing
+          , entryAttrs = []
+          , entryOther = []
+          }
+
+allCommentsFeed :: [(Cm.Comment, P.Post)] -> Feed
+allCommentsFeed commentsAndPosts =
+    Feed { feedId = fullUrl $ allCommentsFeedUrl
+         , feedTitle = TextString "All Unkept - Comments"
+         , feedUpdated = if null commentsAndPosts
+                         then "" -- the best we can do
+                         else formatTimestamp $ Cm.timestamp $ fst $ head $ commentsAndPosts
+         , feedAuthors = []
+         , feedCategories = [] -- Possible TODO
+         , feedContributors = []
+         , feedGenerator = Nothing
+         , feedIcon = Just "http://lukeplant.me.uk/favicon.ico"
+         , feedLinks = [ selfLink allCommentsFeedUrl
+                       ]
+         , feedLogo = Nothing -- TODO
+         , feedRights = Just $ TextString "© Luke Plant"
+         , feedSubtitle = Nothing
+         , feedEntries = map mkCommentEntry commentsAndPosts
+         , feedAttrs = []
+         , feedOther = []
+         }
+
+
+postCommentFeed comments post =
+    let basefeed = allCommentsFeed $ zip comments (repeat post)
+        url = postCommentFeedUrl post
+    in basefeed { feedId = fullUrl url
+                , feedTitle = TextString $ "All Unkept - Comments on " ++ P.title post
+                , feedLinks = [ selfLink url
+                              , htmlLink (url ++ "#comments")
+                              ]
+                }
+

src/Blog/Links.hs

 module Blog.Links where
 
 import qualified Blog.Category as C
+import qualified Blog.Comment as Cm
 import qualified Blog.Post as P
 import qualified Blog.Settings as Settings
 
 allPostsFeedUrl        = Settings.root_url ++ "atom/"
 postCommentFeedUrl   p = Settings.root_url ++ "posts/" ++ (P.slug p) ++ "/atom/"
 categoryPostsFeedUrl c = Settings.root_url ++ "categories/" ++ (C.slug c) ++ "/atom/"
-allCommentsUrl         = Settings.root_url ++ "comments/atom/"
+allCommentsFeedUrl     = Settings.root_url ++ "comments/atom/"
+
+commentUrl cm p        = postUrl p ++ "#comment" ++ (show $ Cm.uid cm)

src/Blog/Model.hs

                   , getPostBySlug
                   , getPostById
                   , getRecentPosts
+                  , getRecentComments
                   , getCategoriesForPost
                   , getCommentsForPost
                   , getRelatedPosts
 getCommentByIdQuery      = "SELECT id, post_id, timestamp, name, email, text_raw, text_formatted, format_id, hidden, response FROM comments WHERE id = ?;"
 getCommentsForPostQuery  = "SELECT id, '',      timestamp, name, email, '',       text_formatted, '',        hidden, response FROM comments WHERE post_id = ? ORDER BY timestamp ASC;"
 
+getRecentCommentsQuery   = "SELECT c.id, c.post_id, c.timestamp, c.name, c.email, '',       c.text_formatted, '',        c.hidden, c.response, p.slug as post_slug, p.title as post_title FROM comments as c INNER JOIN posts as p ON c.post_id = p.id ORDER BY c.timestamp DESC;"
+
 getPasswordForUsernameQuery = "SELECT password FROM users WHERE username = ?;"
 setPasswordForUsernameQuery = "UPDATE users SET password = ? WHERE username = ?;"
 
                , Cm.response = fromSql (row !! 9)
                }
 
+minimalPost slug title =
+    P.Post { P.uid = undefined
+           , P.title = title
+           , P.slug = slug
+           , P.post_raw = undefined
+           , P.post_formatted = undefined
+           , P.summary_raw = undefined
+           , P.summary_formatted = undefined
+           , P.format = undefined
+           , P.timestamp = undefined
+           , P.comments_open = undefined
+           }
+
+
 ---- Public API for queries ----
 
 getPostBySlug :: (IConnection conn) => conn -> String -> IO (Maybe P.Post)
   (res,more) <- pagedQuery cn getPostsForCategoryQuery [toSql $ Ct.uid cat] curpage Settings.post_page_size
   return (map makePost res, more)
 
+-- | Returns all recent comments, paired with the Post they are from
+-- Contains only enough information to generate the feed.
+getRecentComments :: (IConnection conn) => conn -> Int -> Int -> IO [(Cm.Comment, P.Post)]
+getRecentComments cn page pagesize = do
+  (res, more) <- pagedQuery cn getRecentCommentsQuery [] page pagesize
+  let comments = map makeComment res
+  let posts = map (\row -> minimalPost (fromSql $ row !! 10) (fromSql $ row !! 11)) res
+  return $ zip comments posts
+
 getCategoryBySlug :: (IConnection conn) => conn -> String -> IO (Maybe Ct.Category)
 getCategoryBySlug cn slug = do
   res <- quickQuery' cn getCategoryBySlugQuery [toSql slug]

src/Blog/Routes.hs

 views  = [ addSlashRedirectView
          , canonicalUri
          , empty                                      //-> mainIndex              $ []
+         , "atom/" <+/> empty                         //-> allPostsFeedView       $ []
          , "posts/" <+/> anyParam                     //-> postView               $ []
+         , "posts/" <+/> stringParam </+> "atom/"     //-> postCommentFeedView    $ []
          , "posts/" <+/> empty                        //-> postsRedirectView      $ []
          , "categories/" <+/> empty                   //-> categoriesView         $ []
          , "categories/" <+/> anyParam                //-> categoryView           $ []
+         , "categories/" <+/> stringParam</+>"atom/"  //-> categoryPostsFeedView  $ []
+         , "comments/atom/" <+/> empty                //-> allCommentsFeedView    $ []
          , "login/" <+/> empty                        //-> loginView              $ []
          , "logout/" <+/> empty                       //-> logoutView             $ []
          , "admin/" <+/> empty                        //-> adminMenu              $ [adminRequired]

src/Blog/Views.hs

 -- which has pure functions that generally return Html.
 
 import Blog.DB (connect)
+import Blog.Feeds
 import Blog.Formats (Format(..), getFormatter)
 import Blog.Forms
 import Blog.Globals (mkCsrfField)
 import Ella.Utils (addHtml)
 import Maybe (fromMaybe, isJust, fromJust, catMaybes)
 import System.Time (ClockTime(..), toUTCTime)
+import Text.Atom.Feed (Feed)
+import Text.Atom.Feed.Export (xmlFeed)
 import Text.StringTemplate
 import Text.StringTemplate.GenericStandard
+import Text.XML.Light (showTopElement)
 import qualified Blog.Category as Ct
 import qualified Blog.Links as Links
 import qualified Blog.Post as P
                 ]
 
 
+-- Feed utilities
+
+feedResponse :: Feed -> IO (Maybe Response)
+feedResponse feed = return $ Just $
+                    with (textBasedResponse "application/atom+xml" "UTF-8")
+                             [ addContent $ utf8 $ showTopElement $ xmlFeed feed
+                             ]
+
 ---- Views
 
 -- View for the main page
               ("atomfeedurl", allPostsFeedUrl)
              )
 
+-- Feed for all posts
+allPostsFeedView req = do
+  cn <- connect
+  (posts, more) <- getRecentPosts cn 1 Settings.feed_post_page_size
+  feedResponse $ allPostsFeed posts
+
+
+allCommentsFeedView req = do
+  cn <- connect
+  comments <- getRecentComments cn 1 Settings.feed_comment_page_size
+  feedResponse $ allCommentsFeed comments
+
 -- | View to help with debugging
 debug :: String -> View
 debug path req = return $ Just $ buildResponse [
                           ("atomfeedurl", categoryPostsFeedUrl cat)
                          )
 
+categoryPostsFeedView slug req = do
+  cn <- connect
+  mcat <- getCategoryBySlug cn slug
+  case mcat of
+    Nothing -> return404 req
+    Just cat -> do
+              (posts,more) <- getPostsForCategory cn cat 1
+              feedResponse $ categoryPostsFeed cat posts
+
 -- | View that shows individual post
 postView :: String -> View
 postView slug req = do
           _ -> do commentExtra <- initialCommentExtra req
                   return (NoComment, emptyComment, [], commentExtra)
 
+postCommentFeedView slug req = do
+  cn <- connect
+  mp <- getPostBySlug cn slug
+  case mp of
+    Nothing -> return404 req
+    Just post -> do
+            comments <- getCommentsForPost cn post
+            feedResponse $ postCommentFeed comments post
+
+
 -- | View that displays a login form and handles logging in
 loginView :: View
 loginView req = do
        return $ Just success
 
 
+-- Authentication
 createLoginCookies loginData timestamp =
   let username = fromJust $ Map.lookup "username" loginData
       password = fromJust $ Map.lookup "password" loginData

src/Blog/settingslocal.hs

 
 post_page_size = 20 :: Int
 admin_post_page_size = 100 :: Int
+feed_post_page_size = 20 :: Int
+feed_comment_page_size = 20 :: Int
 domain = "lukeplant_local"
+absolute_root = "http://" ++ domain
 
 secret = "123"