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