eidolon/Handler/RootFeed.hs

--  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 <http://www.gnu.org/licenses/>.

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 Text.Shakespeare.Text (stext)
import Yesod.Feed
import Yesod.RssFeed
import Yesod.AtomFeed

getCommentFeedRssR :: MediumId -> Handler RepRss
getCommentFeedRssR mId = do
  feed <- commentFeedBuilder mId
  rssFeed feed

getCommentFeedAtomR :: MediumId -> Handler RepAtom
getCommentFeedAtomR mId = do
  feed <- commentFeedBuilder mId
  atomFeed feed

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
    }

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}|]
    }

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
  Entity uId _ <- runDB $ getBy404 $ UniqueUser name
  getUserFeedRssR uId

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