nek0/eidolon
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Reworked newsfeeds now with yesod-newsfeed

Browse source
This commit is contained in:
nek0 2015-09-26 11:15:20 +02:00
parent 3aad76bfcf
commit 9feff0896c
7 changed files with 172 additions and 236 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Handler/Album.hs
View file

@ -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"

6
Handler/Home.hs
View file

@ -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")

4
Handler/Medium.hs
View file

@ -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"

4
Handler/Profile.hs
View file

@ -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"

367
Handler/RootFeed.hs
View file

@ -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 "<?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
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)
}

2
eidolon.cabal
View file

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

21
templates/default-layout.hamlet
View file

@ -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
|