74 lines
2.6 KiB
Haskell
74 lines
2.6 KiB
Haskell
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
-------------------------------------------------------------------------------
|
|
--
|
|
-- Module : Yesod.RssFeed
|
|
-- Copyright : Patrick Brisbin
|
|
-- License : as-is
|
|
--
|
|
-- Maintainer : Patrick Brisbin <me@pbrisbin.com>
|
|
-- Stability : Stable
|
|
-- Portability : Portable
|
|
--
|
|
-------------------------------------------------------------------------------
|
|
module Yesod.RssFeed
|
|
( rssFeed
|
|
, rssLink
|
|
, RepRss (..)
|
|
, module Yesod.FeedTypes
|
|
) where
|
|
|
|
import Yesod.Core
|
|
import Yesod.FeedTypes
|
|
import Text.Hamlet (hamlet)
|
|
import qualified Data.ByteString.Char8 as S8
|
|
import Data.Text (Text, pack)
|
|
import Data.Text.Lazy (toStrict)
|
|
import Text.XML
|
|
import Text.Blaze.Renderer.Text (renderHtml)
|
|
|
|
newtype RepRss = RepRss Content
|
|
instance HasReps RepRss where
|
|
chooseRep (RepRss c) _ = return (typeRss, c)
|
|
|
|
-- | Generate the feed
|
|
rssFeed :: Feed (Route master) -> GHandler sub master RepRss
|
|
rssFeed feed = do
|
|
render <- getUrlRender
|
|
return $ RepRss $ toContent $ renderLBS def $ template feed render
|
|
|
|
template :: Feed url -> (url -> Text) -> Document
|
|
template Feed {..} render =
|
|
Document (Prologue [] Nothing []) root []
|
|
where
|
|
root = Element "rss" [("version", "2.0")] $ return $ NodeElement $ Element "channel" [] $ map NodeElement
|
|
$ Element "{http://www.w3.org/2005/Atom}link"
|
|
[ ("href", render feedLinkSelf)
|
|
, ("rel", "self")
|
|
, ("type", pack $ S8.unpack typeRss)
|
|
] []
|
|
: Element "title" [] [NodeContent feedTitle]
|
|
: Element "link" [] [NodeContent $ render feedLinkHome]
|
|
: Element "description" [] [NodeContent $ toStrict $ renderHtml feedDescription]
|
|
: Element "lastBuildDate" [] [NodeContent $ formatRFC822 feedUpdated]
|
|
: Element "language" [] [NodeContent feedLanguage]
|
|
: map (flip entryTemplate render) feedEntries
|
|
|
|
entryTemplate :: FeedEntry url -> (url -> Text) -> Element
|
|
entryTemplate FeedEntry {..} render = Element "item" [] $ map NodeElement
|
|
[ Element "title" [] [NodeContent feedEntryTitle]
|
|
, Element "link" [] [NodeContent $ render feedEntryLink]
|
|
, Element "guid" [] [NodeContent $ render feedEntryLink]
|
|
, Element "pubDate" [] [NodeContent $ formatRFC822 feedEntryUpdated]
|
|
, Element "description" [] [NodeContent $ toStrict $ renderHtml feedEntryContent]
|
|
]
|
|
|
|
-- | Generates a link tag in the head of a widget.
|
|
rssLink :: Route m
|
|
-> Text -- ^ title
|
|
-> GWidget s m ()
|
|
rssLink r title = toWidgetHead [hamlet|
|
|
<link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}>
|
|
|]
|