-- eidolon -- A simple gallery in Haskell and Yesod
-- Copyright (C) 2015 Amedeo Molnár
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published
-- by the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
module Handler.RootFeed where
import Import
import qualified Data.Text as T
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
image <- return $ 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}
<summary>#{mediumDescription medium}
<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
<description>#{mediumDescription medium}
<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
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)
getUserFeedAtomR :: UserId -> Handler RepAtom
getUserFeedAtomR = getUserFeedR
getUserFeedRssR :: UserId -> Handler RepRss
getUserFeedRssR = getUserFeedR
getNameFeedAtomR :: Text -> Handler RepAtom
getNameFeedAtomR name = do
muser <- runDB $ getBy $ UniqueUser name
case muser of
Just (Entity uId _) ->
getUserFeedR uId
Nothing ->
notFound
getNameFeedRssR :: Text -> Handler RepRss
getNameFeedRssR name = do
muser <- runDB $ getBy $ UniqueUser name
case muser of
Just (Entity uId _) ->
getUserFeedR uId
Nothing ->
notFound
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)