Add support for Atom and RSS content feeds - this info is available through mf2 anyway so Atom and RSS are kinda redundant, but we'll include them anyway

This commit is contained in:
Danielle McLean 2017-10-09 13:32:13 +11:00
parent 1f1108a886
commit 4088735c69
Signed by: 00dani
GPG key ID: 5A5D2D1AFF12EEC5
6 changed files with 65 additions and 1 deletions

View file

@ -7,6 +7,8 @@
/sitemap.xml SitemapR GET /sitemap.xml SitemapR GET
/ HomeR GET / HomeR GET
/feed FeedR GET
!/#EntryKind/feed FeedKindR GET
!/#EntryKind EntriesR GET !/#EntryKind EntriesR GET
!/#EntryKind/#EntryId EntryNoSlugR GET !/#EntryKind/#EntryId EntryNoSlugR GET

View file

@ -53,6 +53,7 @@ dependencies:
- slug >=0.1 && <0.2 - slug >=0.1 && <0.2
- split >=0.2 && <0.3 - split >=0.2 && <0.3
- yesod-auth-hashdb >=1.6.2 && <1.7 - yesod-auth-hashdb >=1.6.2 && <1.7
- yesod-newsfeed >=1.6 && <1.7
- yesod-sitemap >=1.4 && <1.5 - yesod-sitemap >=1.4 && <1.5
# The library contains all of our application code. The executable # The library contains all of our application code. The executable

View file

@ -50,6 +50,7 @@ import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
-- Don't forget to add new modules to your cabal file! -- Don't forget to add new modules to your cabal file!
import Handler.Common import Handler.Common
import Handler.Entries import Handler.Entries
import Handler.Feed
import Handler.Home import Handler.Home
-- This line actually creates our YesodDispatch instance. It is the second half -- This line actually creates our YesodDispatch instance. It is the second half

View file

@ -5,6 +5,7 @@ module Handler.Entries where
import Import import Import
import Web.Slug ( Slug ) import Web.Slug ( Slug )
import Yesod.AtomFeed ( atomLink )
import qualified Entry.Kind as K import qualified Entry.Kind as K
import Widget.Entry ( entryR, hEntry ) import Widget.Entry ( entryR, hEntry )
@ -15,6 +16,7 @@ getEntriesR kind = do
entries <- runDB $ selectList [EntryKind ==. kind] [Desc EntryPublished] entries <- runDB $ selectList [EntryKind ==. kind] [Desc EntryPublished]
defaultLayout $ do defaultLayout $ do
setTitle . toHtml . K.pluralise $ kind setTitle . toHtml . K.pluralise $ kind
FeedKindR kind `atomLink` K.pluralise kind
$(widgetFile "entries") $(widgetFile "entries")
checkMatching :: K.EntryKind -> Slug -> Entry -> Bool checkMatching :: K.EntryKind -> Slug -> Entry -> Bool

53
src/Handler/Feed.hs Normal file
View file

@ -0,0 +1,53 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Handler.Feed where
import Import
import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
import Widget.Entry ( entryR )
import qualified Data.Text as T
import qualified Entry.Kind as K
getFeedR :: Handler TypedContent
getFeedR = do
entries <- runDB $ selectList [] [Desc EntryPublished]
newsFeed $ toFeed entries
getFeedKindR :: K.EntryKind -> Handler TypedContent
getFeedKindR kind = do
entries <- runDB $ selectList [EntryKind ==. kind] [Desc EntryPublished]
let basicFeed = toFeed entries
newsFeed $ basicFeed
{ feedTitle = T.concat [K.pluralise kind, " ~ ", feedTitle basicFeed]
, feedDescription = toHtml $ T.concat ["feed of all ", K.pluralise kind]
, feedLinkSelf = FeedKindR kind
, feedLinkHome = EntriesR kind
}
toFeed :: [Entity Entry] -> Feed (Route App)
toFeed entries@(latestEntry:_) = (toFeed [])
{ feedEntries = toFeedEntry <$> entries
, feedUpdated = entryUpdated $ entityVal latestEntry
}
toFeed [] = Feed
{ feedTitle = fromMaybe "" . appTitle $ compileTimeAppSettings
, feedLinkSelf = FeedR
, feedLinkHome = HomeR
, feedAuthor = ""
, feedDescription = "sitewide feed of all entries"
, feedLanguage = "en-au"
, feedUpdated = posixSecondsToUTCTime 0
, feedLogo = Nothing
, feedEntries = []
}
toFeedEntry :: Entity Entry -> FeedEntry (Route App)
toFeedEntry entry = FeedEntry
{ feedEntryLink = entryR entry
, feedEntryUpdated = entryUpdated $ entityVal entry
, feedEntryTitle = entryName $ entityVal entry
, feedEntryContent = toHtml . entryContent . entityVal $ entry
, feedEntryEnclosure = Nothing
}

View file

@ -6,6 +6,9 @@
module Handler.Home where module Handler.Home where
import Import import Import
import Yesod.AtomFeed ( atomLink )
import Widget.Card ( hCard ) import Widget.Card ( hCard )
import Widget.Feed ( hFeed ) import Widget.Feed ( hFeed )
@ -16,7 +19,9 @@ getHomeR = do
entries <- runDB $ selectList [EntryAuthorId ==. userId] [Desc EntryPublished] entries <- runDB $ selectList [EntryAuthorId ==. userId] [Desc EntryPublished]
defaultLayout $ do defaultLayout $ do
case maybeTitle of case maybeTitle of
Just title -> setTitle $ toHtml title Just title -> do
setTitle $ toHtml title
atomLink FeedR title
Nothing -> return () Nothing -> return ()
toWidgetHead toWidgetHead
[hamlet| [hamlet|