From 9feff0896c84878ffba96a2c4920464af4310a38 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 26 Sep 2015 11:15:20 +0200 Subject: [PATCH] Reworked newsfeeds now with yesod-newsfeed --- Handler/Album.hs | 4 + Handler/Home.hs | 6 + Handler/Medium.hs | 4 + Handler/Profile.hs | 4 + Handler/RootFeed.hs | 367 +++++++++++++------------------- eidolon.cabal | 2 + templates/default-layout.hamlet | 21 -- 7 files changed, 172 insertions(+), 236 deletions(-) diff --git a/Handler/Album.hs b/Handler/Album.hs index 3069d16..f42e099 100644 --- a/Handler/Album.hs +++ b/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" diff --git a/Handler/Home.hs b/Handler/Home.hs index bba7e7e..b7ec6b9 100644 --- a/Handler/Home.hs +++ b/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") diff --git a/Handler/Medium.hs b/Handler/Medium.hs index 43eafac..6f90711 100644 --- a/Handler/Medium.hs +++ b/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" diff --git a/Handler/Profile.hs b/Handler/Profile.hs index 17eb27a..fdf6021 100644 --- a/Handler/Profile.hs +++ b/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" diff --git a/Handler/RootFeed.hs b/Handler/RootFeed.hs index e7ca048..6ada3b0 100644 --- a/Handler/RootFeed.hs +++ b/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 Blaze.ByteString.Builder - -data FeedParameters = Parameters - { 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 "\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 - - #{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 +import Text.Shakespeare.Text (stext) +import Yesod.Feed +import Yesod.RssFeed +import Yesod.AtomFeed getCommentFeedRssR :: MediumId -> Handler RepRss -getCommentFeedRssR = getCommentFeedR +getCommentFeedRssR mId = do + feed <- commentFeedBuilder mId + rssFeed feed -getCommentFeedR :: RepFeed a => MediumId -> Handler a -getCommentFeedR mediumId = do - medium <- runDB $ get404 mediumId - url <- getUrlRender - 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) +getCommentFeedAtomR :: MediumId -> Handler RepAtom +getCommentFeedAtomR mId = do + feed <- commentFeedBuilder mId + atomFeed feed -getUserFeedAtomR :: UserId -> Handler RepAtom -getUserFeedAtomR = getUserFeedR +commentFeedBuilder :: MediumId -> Handler (Feed (Route App)) +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 -getUserFeedRssR = getUserFeedR +commentToEntry :: Monad m => Entity Comment -> m (FeedEntry (Route App)) +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 -getNameFeedAtomR name = do - muser <- runDB $ getBy $ UniqueUser name - case muser of - Just (Entity uId _) -> - getUserFeedR uId - Nothing -> - notFound +getAlbumFeedRssR :: AlbumId -> Handler RepRss +getAlbumFeedRssR aId = do + feed <- albumFeedBuilder aId + rssFeed feed + +getAlbumFeedAtomR :: AlbumId -> Handler RepAtom +getAlbumFeedAtomR aId = do + 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 - case muser of - Just (Entity uId _) -> - getUserFeedR uId - Nothing -> - notFound + Entity uId _ <- runDB $ getBy404 $ UniqueUser name + getUserFeedRssR uId -getUserFeedR :: RepFeed a => UserId -> Handler a -getUserFeedR userId = do - user <- runDB $ get404 userId - recentMedia <- runDB $ selectList [MediumOwner ==. userId] [Desc MediumTime, LimitTo 100] - renderFeed Parameters - { pTitle = "Eidolon :: Newest media of " `T.append` (userSlug user) - , pLink = ProfileR userId - , pImage = "" - } (Right recentMedia) +getNameFeedAtomR :: Text -> Handler RepAtom +getNameFeedAtomR name = do + Entity uId _ <- runDB $ getBy404 $ UniqueUser name + getUserFeedAtomR uId + +getUserFeedRssR :: UserId -> Handler RepRss +getUserFeedRssR uId = do + feed <- userFeedBuilder uId + 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) + } diff --git a/eidolon.cabal b/eidolon.cabal index 740cec7..457c9cb 100644 --- a/eidolon.cabal +++ b/eidolon.cabal @@ -116,6 +116,8 @@ library , blaze-markup , either , wai + -- experiment + , yesod-newsfeed executable eidolon if flag(library-only) diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 7fecf8d..7f97e9d 100644 --- a/templates/default-layout.hamlet +++ b/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 |