Reworked newsfeeds now with yesod-newsfeed

Handler/Album.hs

@@ -19,6 +19,8 @@ module Handler.Album where
 import Import
 import qualified Data.Text as T
 import System.FilePath
+import Yesod.RssFeed
+import Yesod.AtomFeed
 
 getAlbumR :: AlbumId -> Handler Html
 getAlbumR albumId = do
@@ -40,6 +42,8 @@ getAlbumR albumId = do
       media <- runDB $ selectList [MediumAlbum ==. albumId] [Desc MediumTime]
       defaultLayout $ do
         setTitle $ toHtml ("Eidolon :: Album " `T.append` albumTitle album)
+        rssLink (AlbumFeedRssR albumId) $ "Album feed of album " `T.append` albumTitle album
+        atomLink (AlbumFeedAtomR albumId) $ "Album feed of album " `T.append` albumTitle album
         $(widgetFile "album")
     Nothing -> do
       setMessage "This album does not exist"

Handler/Home.hs

@@ -21,6 +21,8 @@ import Import
 import qualified Data.Text as T
 import Data.List as L
 import System.FilePath
+import Yesod.RssFeed
+import Yesod.AtomFeed
 
 getHomeR :: Handler Html
 getHomeR = do
@@ -28,6 +30,8 @@ getHomeR = do
   nextMediaQuery <- runDB $ selectList [] [Desc MediumTime, LimitTo 1, OffsetBy 30]
   let nextMedia = not $ L.null nextMediaQuery
   defaultLayout $ do
+    rssLink RootFeedRssR "Root Feed"
+    atomLink RootFeedAtomR "Root Feed"
     setTitle "Eidolon :: Home"
     $(widgetFile "home")
 
@@ -37,5 +41,7 @@ getPageR page = do
   nextMediaQuery <- runDB $ selectList [] [Desc MediumTime, LimitTo 1, OffsetBy ((page + 1) * 30)]
   let nextMedia = not $ L.null nextMediaQuery
   defaultLayout $ do
+    rssLink RootFeedRssR "Root Feed"
+    atomLink RootFeedAtomR "Root Feed"
     setTitle $ toHtml ("Eidolon :: Page " `T.append` T.pack (show page))
     $(widgetFile "page")

Handler/Medium.hs

@@ -23,6 +23,8 @@ import qualified Data.Text as T
 -- import System.Locale
 import System.FilePath
 import Yesod.Markdown
+import Yesod.RssFeed
+import Yesod.AtomFeed
 
 getMediumR :: MediumId -> Handler Html
 getMediumR mediumId = do
@@ -61,6 +63,8 @@ getMediumR mediumId = do
       let pr = StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumPath medium) []
       formLayout $ do
         setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium))
+        rssLink (CommentFeedRssR mediumId) $ "Comment feed of medium " `T.append` mediumTitle medium
+        atomLink (CommentFeedAtomR mediumId) $ "Comment feed of medium " `T.append` mediumTitle medium
         $(widgetFile "medium")
     Nothing -> do
       setMessage "This image does not exist"

Handler/Profile.hs

@@ -20,6 +20,8 @@ import Import
 import Data.Maybe
 import qualified Data.Text as T
 import System.FilePath
+import Yesod.RssFeed
+import Yesod.AtomFeed
 
 getProfileR :: UserId -> Handler Html
 getProfileR ownerId = do
@@ -46,6 +48,8 @@ getProfileR ownerId = do
           return False
       defaultLayout $ do
         setTitle $ toHtml ("Eidolon :: " `T.append` userSlug owner `T.append` "'s profile")
+        rssLink (UserFeedRssR ownerId) $ userSlug owner `T.append` "'s feed"
+        atomLink (UserFeedAtomR ownerId) $ userSlug owner `T.append` "'s feed"
         $(widgetFile "profile")
     Nothing -> do
       setMessage "This profile does not exist"

Handler/RootFeed.hs

@@ -18,230 +18,167 @@ module Handler.RootFeed where
 
 import Import
 import qualified Data.Text as T
+import qualified Data.Text.Lazy as L
 import Data.Maybe
 import Data.Time
-import Data.Either.Combinators
+import Text.Shakespeare.Text (stext)
-import Blaze.ByteString.Builder
+import Yesod.Feed
-
+import Yesod.RssFeed
-data FeedParameters = Parameters
+import Yesod.AtomFeed
-  { pTitle :: T.Text
-  , pImage :: T.Text
-  , pLink :: Route App
-  }
-
-nsAtom :: T.Text
-nsAtom = "http://www.w3.org/2005/Atom"
-
-class RepFeed c where
-  renderFeed :: FeedParameters -> Either [Entity Comment] [Entity Medium] -> Handler c
-
-newtype RepAtom = RepAtom Content
-  deriving (ToContent)
-
-instance ToTypedContent RepAtom where
-  toTypedContent =
-    TypedContent typeAtom . withXmlDecl . toContent
-
-withXmlDecl :: Content -> Content
-withXmlDecl (ContentBuilder b _) =
-  flip ContentBuilder Nothing $
-  fromByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\r\n" `mappend`
-  b
-withXmlDecl c = c
-
-instance RepFeed RepAtom where
-  renderFeed params items = do
-    let image = pImage params
-    url <- getUrlRender
-    tz <- liftIO getCurrentTimeZone
-    links <- case items of
-      Left commEnts ->
-        return $ Left $ map (\ent -> (entityKey ent, url $ MediumR $ commentOrigin $ entityVal ent)) commEnts
-      Right mediaEnts ->
-        return $ Right $ map (\ent -> (entityKey ent, url $ MediumR $ entityKey ent)) mediaEnts
-    return $ RepAtom $ toContent $ 
-               [xhamlet|$newline always
-                 <feed version="1.0"
-                       xmlns=#{nsAtom}>
-                     <title>#{pTitle params}
-                     <link rel="alternate"
-                           type="text/html"
-                           href=#{url $ pLink params}
-                           >
-                     <id>#{url $ pLink params}
-                     $if not (T.null image)
-                         <link rel="icon"
-                               href=#{image}
-                               >
-                     $case items
-                       $of Right media
-                         $forall (Entity mediumId medium) <- media
-                           <entry xml:lang="en">
-                             <title>#{mediumTitle medium}
-                             <link rel="alternate"
-                               type="text/html"
-                               href=#{fromJust $ lookup mediumId $ fromRight [] links}
-                               >
-                             <id>#{fromJust $ lookup mediumId $ fromRight [] links}
-                             <published>#{iso8601 $ utcToZonedTime tz $ mediumTime medium}
-                             $maybe d <- mediumDescription medium
-                               <summary>#{d}
-                             $nothing
-                               <summary>No description given
-                             <link rel="icon"
-                               href=#{url $ StaticR $ mediumStaticThumbRoute medium}
-                               >
-                             <link rel="enclosure"
-                               type=#{mediumMime medium}
-                               href=#{url $ StaticR $ mediumStaticImageRoute medium}
-                               >
-                       $of Left comments
-                         $forall (Entity commentId comment) <- comments
-                           <entry xml:lang="en">
-                             <title>#{fromJust $ commentAuthorSlug comment} commented
-                             <link rel="alternate"
-                               type="text/html"
-                               href=#{fromJust $ lookup commentId $ fromLeft [] links}
-                               >
-                             <id>#{fromJust $ lookup commentId $ fromLeft [] links}
-                             <published>#{iso8601 $ utcToZonedTime tz $ commentTime comment}
-                             <summary>#{commentContent comment}
-                    |] url
-
-newtype RepRss = RepRss Content
-    deriving (ToContent)
-
-instance ToTypedContent RepRss where
-    toTypedContent =
-        TypedContent typeRss .
-        withXmlDecl . toContent
-      
-instance RepFeed RepRss where
-  renderFeed params items = do
-    url <- getUrlRender
-    let image = pImage params
-    links <- case items of
-      Left commEnts ->
-        return $ Left $ map (\ent -> (entityKey ent, url $ MediumR $ commentOrigin $ entityVal ent)) commEnts
-      Right mediaEnts ->
-        return $ Right $ map (\ent -> (entityKey ent, url $ MediumR $ entityKey ent)) mediaEnts
-    return $ RepRss $ toContent $ 
-               [xhamlet|$newline always
-                 <rss version="2.0"
-                      xmlns:atom=#{nsAtom}>
-                   <channel>
-                     <title>#{pTitle params}
-                     <link>#{url $ pLink params}
-                     $if not (T.null image)
-                       <image>
-                         <url>#{image}
-                     $case items
-                       $of Right media
-                         $forall (Entity mediumId medium) <- media
-                           <item>
-                             <title>#{mediumTitle medium}
-                             <link>#{fromJust $ lookup mediumId $ fromRight [] links}
-                             <language>en
-                             $maybe d <- mediumDescription medium
-                               <description>#{d}
-                             $nothing
-                               <description>No description given
-                             <guid isPermaLink="true">#{fromJust $ lookup mediumId $ fromRight [] links}
-                             <pubDate>#{rfc822 $ mediumTime medium}
-                             <image>
-                               <url>#{fromJust $ lookup mediumId $ fromRight [] links}
-                             <enclosure type=#{mediumMime medium}
-                                        url=#{url $ StaticR $ mediumStaticImageRoute medium}>
-                       $of Left comments
-                         $forall (Entity commentId comment) <- comments
-                           <item>
-                             <title>#{fromJust $ commentAuthorSlug comment} commented
-                             <link>#{fromJust $ lookup commentId $ fromLeft [] links}
-                             <language>en
-                             <description>#{commentContent comment}
-                             <pubdate>#{rfc822 $ commentTime comment}
-                     |] url
-
-getRootFeedAtomR :: Handler RepAtom
-getRootFeedAtomR = getRootFeedR
-
-getRootFeedRssR :: Handler RepRss
-getRootFeedRssR = getRootFeedR
-
-getRootFeedR :: RepFeed a => Handler a
-getRootFeedR = do
-  recentMedia <- runDB $ selectList [] [Desc MediumTime, LimitTo 100]
-  renderFeed Parameters
-    { pTitle = "Eidolon :: Latest media"
-    , pLink  = HomeR
-    , pImage = ""
-    } (Right recentMedia)
-
-getAlbumFeedAtomR :: AlbumId -> Handler RepAtom
-getAlbumFeedAtomR = getAlbumFeedR
-
-getAlbumFeedRssR :: AlbumId -> Handler RepRss
-getAlbumFeedRssR = getAlbumFeedR
-
-getAlbumFeedR :: RepFeed a => AlbumId -> Handler a
-getAlbumFeedR albumId = do
-  album <- runDB $ get404 albumId
-  url <- getUrlRender
-  recentMedia <- runDB $ selectList [MediumAlbum ==. albumId] [Desc MediumTime, LimitTo 100]
-  renderFeed Parameters
-    { pTitle = "Eidolon :: Latest media in album " `T.append` (albumTitle album)
-    , pLink  = AlbumR albumId
-    , pImage = url $ StaticR $ StaticRoute
-        (drop 2 $ T.splitOn "/" $ T.pack $ fromMaybe "/static/img/album.jpg" $ albumSamplePic album) []
-    } (Right recentMedia)
-
-getCommentFeedAtomR :: MediumId -> Handler RepAtom
-getCommentFeedAtomR = getCommentFeedR
 
 getCommentFeedRssR :: MediumId -> Handler RepRss
-getCommentFeedRssR = getCommentFeedR
+getCommentFeedRssR mId = do
+  feed <- commentFeedBuilder mId
+  rssFeed feed
 
-getCommentFeedR :: RepFeed a => MediumId -> Handler a
+getCommentFeedAtomR :: MediumId -> Handler RepAtom
-getCommentFeedR mediumId = do
+getCommentFeedAtomR mId = do
-  medium <- runDB $ get404 mediumId
+  feed <- commentFeedBuilder mId
-  url <- getUrlRender
+  atomFeed feed
-  recentComments <- runDB $ selectList [CommentOrigin ==. mediumId] [Desc CommentTime, LimitTo 100]
-  renderFeed Parameters
-    { pTitle = "Eidolon :: Newest comments on " `T.append` (mediumTitle medium)
-    , pLink  = MediumR mediumId
-    , pImage = url $ StaticR $ mediumStaticThumbRoute medium
-    } (Left recentComments)
 
-getUserFeedAtomR :: UserId -> Handler RepAtom
+commentFeedBuilder :: MediumId -> Handler (Feed (Route App))
-getUserFeedAtomR = getUserFeedR
+commentFeedBuilder mId = do
+  medium <- runDB $ get404 mId
+  owner <- runDB $ getJust $ mediumOwner medium
+  cs <- runDB $ selectList [CommentOrigin ==. mId] [Desc CommentTime, LimitTo 100]
+  time <- case cs of
+    x:_ -> return $ commentTime $ entityVal x
+    [] -> liftIO getCurrentTime
+  es <- mapM commentToEntry cs
+  route <- fromJust <$> getCurrentRoute
+  return $ Feed
+    { feedTitle = "Eidolon :: Newest Comments on " `T.append` (mediumTitle medium)
+    , feedLinkSelf = route
+    , feedLinkHome = MediumR mId
+    , feedAuthor = userSlug owner
+    , feedDescription = [shamlet|
+        These are the latest comments on the medium #{mediumTitle medium} by #{userSlug owner}
+      |]
+    , feedLanguage = "en"
+    , feedUpdated = time
+    , feedEntries = es
+    }
 
-getUserFeedRssR :: UserId -> Handler RepRss
+commentToEntry :: Monad m => Entity Comment -> m (FeedEntry (Route App))
-getUserFeedRssR = getUserFeedR
+commentToEntry c =
+  return FeedEntry
+    { feedEntryLink = MediumR (commentOrigin $ entityVal c)
+    , feedEntryUpdated = (commentTime $ entityVal c)
+    , feedEntryTitle = L.toStrict $ [stext|#{commentAuthorSlug $ entityVal c} wrote:|]
+    , feedEntryContent = [shamlet|#{commentContent $ entityVal c}|]
+    }
 
-getNameFeedAtomR :: Text -> Handler RepAtom
+getAlbumFeedRssR :: AlbumId -> Handler RepRss
-getNameFeedAtomR name = do
+getAlbumFeedRssR aId = do
-  muser <- runDB $ getBy $ UniqueUser name
+  feed <- albumFeedBuilder aId
-  case muser of
+  rssFeed feed
-    Just (Entity uId _) ->
+
-      getUserFeedR uId
+getAlbumFeedAtomR :: AlbumId -> Handler RepAtom
-    Nothing ->
+getAlbumFeedAtomR aId = do
-      notFound
+  feed <- albumFeedBuilder aId
+  atomFeed feed
+
+albumFeedBuilder :: AlbumId -> Handler (Feed (Route App))
+albumFeedBuilder aId = do
+  album <- runDB $ get404 aId
+  owner <- runDB $ getJust $ albumOwner album
+  ms <- runDB $ selectList [MediumAlbum ==. aId] [Desc MediumTime, LimitTo 100]
+  time <- case ms of
+    x:_ -> return $ mediumTime $ entityVal x
+    [] -> liftIO getCurrentTime
+  es <- mapM mediumToEntry ms
+  route <- fromJust <$> getCurrentRoute
+  return Feed
+    { feedTitle = "Eidolon :: Newest media in " `T.append` (albumTitle album)
+    , feedLinkSelf = route
+    , feedLinkHome = AlbumR aId
+    , feedAuthor = userSlug owner
+    , feedDescription = [shamlet|
+        These are the latest media uploaded in #{userSlug owner}'s album #{albumTitle album}
+      |]
+    , feedLanguage = "en"
+    , feedUpdated = time
+    , feedEntries = es
+    }
 
 getNameFeedRssR :: Text -> Handler RepRss
 getNameFeedRssR name = do
-  muser <- runDB $ getBy $ UniqueUser name
+  Entity uId _ <- runDB $ getBy404 $ UniqueUser name
-  case muser of
+  getUserFeedRssR uId
-    Just (Entity uId _) ->
-      getUserFeedR uId
-    Nothing ->
-      notFound
 
-getUserFeedR :: RepFeed a => UserId -> Handler a
+getNameFeedAtomR :: Text -> Handler RepAtom
-getUserFeedR userId = do
+getNameFeedAtomR name = do
-  user <- runDB $ get404 userId
+  Entity uId _ <- runDB $ getBy404 $ UniqueUser name
-  recentMedia <- runDB $ selectList [MediumOwner ==. userId] [Desc MediumTime, LimitTo 100]
+  getUserFeedAtomR uId
-  renderFeed Parameters
+
-    { pTitle = "Eidolon :: Newest media of " `T.append` (userSlug user)
+getUserFeedRssR :: UserId -> Handler RepRss
-    , pLink  = ProfileR userId
+getUserFeedRssR uId = do
-    , pImage = ""
+  feed <- userFeedBuilder uId
-    } (Right recentMedia)
+  rssFeed feed
+
+getUserFeedAtomR :: UserId -> Handler RepAtom
+getUserFeedAtomR uId = do
+  feed <- userFeedBuilder uId
+  atomFeed feed
+
+userFeedBuilder :: UserId -> Handler (Feed (Route App))
+userFeedBuilder uId = do
+  user <- runDB $ get404 uId
+  ms <- runDB $ selectList [MediumOwner ==. uId] [Desc MediumTime, LimitTo 100]
+  time <- case ms of
+    x:_ -> return $ mediumTime $ entityVal x
+    [] -> liftIO getCurrentTime
+  es <- mapM mediumToEntry ms
+  route <- fromJust <$> getCurrentRoute
+  return Feed
+    { feedTitle = "Eidolon :: Newest media of " `T.append` (userSlug user)
+    , feedLinkSelf = route
+    , feedLinkHome = ProfileR uId
+    , feedAuthor = userSlug user
+    , feedDescription = [shamlet|
+        These are the latest media uploaded by #{userSlug user} to Eidolon.
+      |]
+    , feedLanguage = "en"
+    , feedUpdated = time
+    , feedEntries = es
+    }
+
+getRootFeedRssR :: Handler RepRss
+getRootFeedRssR = do
+  feed <- rootFeedBuilder
+  rssFeed feed
+
+getRootFeedAtomR :: Handler RepAtom
+getRootFeedAtomR = do
+  feed <- rootFeedBuilder
+  atomFeed feed
+
+rootFeedBuilder :: Handler (Feed (Route App))
+rootFeedBuilder = do
+  ms <- runDB $ selectList [] [Desc MediumTime, LimitTo 100]
+  time <- case ms of
+    x:_ -> return $ mediumTime $ entityVal x
+    [] -> liftIO getCurrentTime
+  es <- mapM mediumToEntry ms
+  route <- fromJust <$> getCurrentRoute
+  return Feed
+    { feedTitle = "Eidolon :: Latest media"
+    , feedLinkSelf = route
+    , feedLinkHome = HomeR
+    , feedAuthor = "Everyone"
+    , feedDescription = [shamlet|
+        These are the latest media uploaded to the Eidolon gallery service.
+      |]
+    , feedLanguage = "en"
+    , feedUpdated = time
+    , feedEntries = es
+    }
+
+mediumToEntry :: Monad m => Entity Medium -> m (FeedEntry (Route App))
+mediumToEntry ent =
+  return FeedEntry
+    { feedEntryLink = MediumR (entityKey ent)
+    , feedEntryUpdated = mediumTime (entityVal ent)
+    , feedEntryTitle = mediumTitle (entityVal ent)
+    , feedEntryContent = toHtml (fromMaybe (Textarea "") $ mediumDescription $ entityVal ent)
+    }

eidolon.cabal

@@ -116,6 +116,8 @@ library
                  , blaze-markup
                  , either
                  , wai
+                 -- experiment
+                 , yesod-newsfeed
 
 executable         eidolon
     if flag(library-only)

templates/default-layout.hamlet

@@ -1,6 +1,3 @@
-<head>
-  ^{pageHead wc}
-
 <nav id="header">
   <div id="top-nav">
   <ul id="user-nav">
@@ -32,49 +29,31 @@ $maybe msg <- mmsg
   <div class="right">
     $case route
       $of Just HomeR
-        <head>
-          <link rel="alternate" type="application/atom+xml" title="Root Feed" href=@{RootFeedAtomR}>
-          <link rel="alternate" type="application/rss+xml" title="Root Feed" href=@{RootFeedRssR}>
         get a Feed from This:
         <a href="@{RootFeedAtomR}">Atom
         |
         <a href="@{RootFeedRssR}">RSS
       $of Just (PageR _)
-        <head>
-          <link rel="alternate" type="application/atom+xml" title="Root Feed" href=@{RootFeedAtomR}>
-          <link rel="alternate" type="application/rss+xml" title="Root Feed" href=@{RootFeedRssR}>
         get a Feed from This:
         <a href="@{RootFeedAtomR}">Atom
         |
         <a href="@{RootFeedRssR}">RSS
       $of Just (ProfileR uId)
-        <head>
-          <link rel="alternate" type="application/atom+xml" title="User Feed" href=@{UserFeedAtomR uId}>
-          <link rel="alternate" type="application/rss+xml" title="User Feed" href=@{UserFeedRssR uId}>
         get a Feed from This:
         <a href="@{UserFeedAtomR uId}">Atom
         |
         <a href="@{UserFeedRssR uId}">RSS
       $of Just (UserR name)
-        <head>
-          <link rel="alternate" type="application/atom+xml" title="User Feed" href=@{NameFeedAtomR name}>
-          <link rel="alternate" type="application/rss+xml" title="User Feed" href=@{NameFeedRssR name}>
         get a Feed from This:
         <a href="@{NameFeedAtomR name}">Atom
         |
         <a href="@{NameFeedRssR name}">RSS
       $of Just (AlbumR aId)
-        <head>
-          <link rel="alternate" type="application/atom+xml" title="Album Feed" href=@{AlbumFeedAtomR aId}>
-          <link rel="alternate" type="application/rss+xml" title="Album Feed" href=@{AlbumFeedRssR aId}>
         get a Feed from This:
         <a href="@{AlbumFeedAtomR aId}">Atom
         |
         <a href="@{AlbumFeedRssR aId}">RSS
       $of Just (MediumR mId)
-        <head>
-          <link rel="alternate" type="application/atom+xml" title="Comment Feed" href=@{CommentFeedAtomR mId}>
-          <link rel="alternate" type="application/rss+xml" title="Comment Feed" href=@{CommentFeedRssR mId}>
         get a Feed from This:
         <a href="@{CommentFeedAtomR mId}">Atom
         |