{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Yesod.RssFeed
( rssFeed
, rssFeedText
, rssLink
, RepRss (..)
, module Yesod.FeedTypes
) where
import Yesod.Core
import Yesod.FeedTypes
import qualified Data.ByteString.Char8 as S8
import Data.Text (Text, pack)
import Data.Text.Lazy (toStrict)
import Text.XML
import Text.Blaze.Html.Renderer.Text (renderHtml)
import qualified Data.Map as Map
newtype = Content
deriving RepRss -> Content
(RepRss -> Content) -> ToContent RepRss
forall a. (a -> Content) -> ToContent a
$ctoContent :: RepRss -> Content
toContent :: RepRss -> Content
ToContent
instance HasContentType RepRss where
getContentType :: forall (m :: * -> *). Monad m => m RepRss -> ContentType
getContentType m RepRss
_ = ContentType
typeRss
instance ToTypedContent RepRss where
toTypedContent :: RepRss -> TypedContent
toTypedContent = ContentType -> Content -> TypedContent
TypedContent ContentType
typeRss (Content -> TypedContent)
-> (RepRss -> Content) -> RepRss -> TypedContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepRss -> Content
forall a. ToContent a => a -> Content
toContent
rssFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m RepRss
Feed (Route (HandlerSite m))
feed = do
Route (HandlerSite m) -> Text
render <- m (Route (HandlerSite m) -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
RepRss -> m RepRss
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (RepRss -> m RepRss) -> RepRss -> m RepRss
forall a b. (a -> b) -> a -> b
$ Content -> RepRss
RepRss (Content -> RepRss) -> Content -> RepRss
forall a b. (a -> b) -> a -> b
$ ByteString -> Content
forall a. ToContent a => a -> Content
toContent (ByteString -> Content) -> ByteString -> Content
forall a b. (a -> b) -> a -> b
$ RenderSettings -> Document -> ByteString
renderLBS RenderSettings
forall a. Default a => a
def (Document -> ByteString) -> Document -> ByteString
forall a b. (a -> b) -> a -> b
$ Feed (Route (HandlerSite m))
-> (Route (HandlerSite m) -> Text) -> Document
forall url. Feed url -> (url -> Text) -> Document
template Feed (Route (HandlerSite m))
feed Route (HandlerSite m) -> Text
render
rssFeedText :: MonadHandler m => Feed Text -> m RepRss
Feed Text
feed = RepRss -> m RepRss
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (RepRss -> m RepRss) -> RepRss -> m RepRss
forall a b. (a -> b) -> a -> b
$ Content -> RepRss
RepRss (Content -> RepRss) -> Content -> RepRss
forall a b. (a -> b) -> a -> b
$ ByteString -> Content
forall a. ToContent a => a -> Content
toContent (ByteString -> Content) -> ByteString -> Content
forall a b. (a -> b) -> a -> b
$ RenderSettings -> Document -> ByteString
renderLBS RenderSettings
forall a. Default a => a
def (Document -> ByteString) -> Document -> ByteString
forall a b. (a -> b) -> a -> b
$ Feed Text -> (Text -> Text) -> Document
forall url. Feed url -> (url -> Text) -> Document
template Feed Text
feed Text -> Text
forall a. a -> a
id
template :: Feed url -> (url -> Text) -> Document
template :: forall url. Feed url -> (url -> Text) -> Document
template Feed {url
[FeedEntry url]
Maybe (url, Text)
Html
Text
UTCTime
feedTitle :: Text
feedLinkSelf :: url
feedLinkHome :: url
feedAuthor :: Text
feedDescription :: Html
feedLanguage :: Text
feedUpdated :: UTCTime
feedLogo :: Maybe (url, Text)
feedEntries :: [FeedEntry url]
feedTitle :: forall url. Feed url -> Text
feedLinkSelf :: forall url. Feed url -> url
feedLinkHome :: forall url. Feed url -> url
feedAuthor :: forall url. Feed url -> Text
feedDescription :: forall url. Feed url -> Html
feedLanguage :: forall url. Feed url -> Text
feedUpdated :: forall url. Feed url -> UTCTime
feedLogo :: forall url. Feed url -> Maybe (url, Text)
feedEntries :: forall url. Feed url -> [FeedEntry url]
..} url -> Text
render =
Prologue -> Element -> [Miscellaneous] -> Document
Document ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
Prologue [] Maybe Doctype
forall a. Maybe a
Nothing []) Element
root []
where
root :: Element
root = Name -> Map Name Text -> [Node] -> Element
Element Name
"rss" (Name -> Text -> Map Name Text
forall k a. k -> a -> Map k a
Map.singleton Name
"version" Text
"2.0") ([Node] -> Element) -> [Node] -> Element
forall a b. (a -> b) -> a -> b
$ Node -> [Node]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Node -> [Node]) -> Node -> [Node]
forall a b. (a -> b) -> a -> b
$ Element -> Node
NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
Element Name
"channel" Map Name Text
forall k a. Map k a
Map.empty ([Node] -> Element) -> [Node] -> Element
forall a b. (a -> b) -> a -> b
$ (Element -> Node) -> [Element] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Node
NodeElement
([Element] -> [Node]) -> [Element] -> [Node]
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
Element Name
"{http://www.w3.org/2005/Atom}link" ([(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (Name
"href", url -> Text
render url
feedLinkSelf)
, (Name
"rel", Text
"self")
, (Name
"type", String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ContentType -> String
S8.unpack ContentType
typeRss)
]) []
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Name -> Map Name Text -> [Node] -> Element
Element Name
"title" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent Text
feedTitle]
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Name -> Map Name Text -> [Node] -> Element
Element Name
"link" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ url -> Text
render url
feedLinkHome]
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Name -> Map Name Text -> [Node] -> Element
Element Name
"description" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ Text -> Text
toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Html -> Text
renderHtml Html
feedDescription]
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Name -> Map Name Text -> [Node] -> Element
Element Name
"lastBuildDate" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ UTCTime -> Text
formatRFC822 UTCTime
feedUpdated]
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Name -> Map Name Text -> [Node] -> Element
Element Name
"language" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent Text
feedLanguage]
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: (FeedEntry url -> Element) -> [FeedEntry url] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map ((FeedEntry url -> (url -> Text) -> Element)
-> (url -> Text) -> FeedEntry url -> Element
forall a b c. (a -> b -> c) -> b -> a -> c
flip FeedEntry url -> (url -> Text) -> Element
forall url. FeedEntry url -> (url -> Text) -> Element
entryTemplate url -> Text
render) [FeedEntry url]
feedEntries
[Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
case Maybe (url, Text)
feedLogo of
Maybe (url, Text)
Nothing -> []
Just (url
route, Text
desc) -> [Name -> Map Name Text -> [Node] -> Element
Element Name
"image" Map Name Text
forall k a. Map k a
Map.empty
[ Element -> Node
NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
Element Name
"url" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ url -> Text
render url
route]
, Element -> Node
NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
Element Name
"title" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent Text
desc]
, Element -> Node
NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
Element Name
"link" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ url -> Text
render url
feedLinkHome]
]
]
entryTemplate :: FeedEntry url -> (url -> Text) -> Element
entryTemplate :: forall url. FeedEntry url -> (url -> Text) -> Element
entryTemplate FeedEntry {url
[EntryCategory]
Maybe (EntryEnclosure url)
Html
Text
UTCTime
feedEntryLink :: url
feedEntryUpdated :: UTCTime
feedEntryTitle :: Text
feedEntryContent :: Html
feedEntryEnclosure :: Maybe (EntryEnclosure url)
feedEntryCategories :: [EntryCategory]
feedEntryLink :: forall url. FeedEntry url -> url
feedEntryUpdated :: forall url. FeedEntry url -> UTCTime
feedEntryTitle :: forall url. FeedEntry url -> Text
feedEntryContent :: forall url. FeedEntry url -> Html
feedEntryEnclosure :: forall url. FeedEntry url -> Maybe (EntryEnclosure url)
feedEntryCategories :: forall url. FeedEntry url -> [EntryCategory]
..} url -> Text
render = Name -> Map Name Text -> [Node] -> Element
Element Name
"item" Map Name Text
forall k a. Map k a
Map.empty ([Node] -> Element) -> [Node] -> Element
forall a b. (a -> b) -> a -> b
$ (Element -> Node) -> [Element] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Node
NodeElement ([Element] -> [Node]) -> [Element] -> [Node]
forall a b. (a -> b) -> a -> b
$
[ Name -> Map Name Text -> [Node] -> Element
Element Name
"title" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent Text
feedEntryTitle]
, Name -> Map Name Text -> [Node] -> Element
Element Name
"link" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ url -> Text
render url
feedEntryLink]
, Name -> Map Name Text -> [Node] -> Element
Element Name
"guid" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ url -> Text
render url
feedEntryLink]
, Name -> Map Name Text -> [Node] -> Element
Element Name
"pubDate" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ UTCTime -> Text
formatRFC822 UTCTime
feedEntryUpdated]
, Name -> Map Name Text -> [Node] -> Element
Element Name
"description" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ Text -> Text
toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Html -> Text
renderHtml Html
feedEntryContent]
]
[Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ (EntryCategory -> Element) -> [EntryCategory] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map EntryCategory -> Element
entryCategoryTemplate [EntryCategory]
feedEntryCategories
[Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
case Maybe (EntryEnclosure url)
feedEntryEnclosure of
Maybe (EntryEnclosure url)
Nothing -> []
Just (EntryEnclosure{url
Int
Text
enclosedUrl :: url
enclosedSize :: Int
enclosedMimeType :: Text
enclosedUrl :: forall url. EntryEnclosure url -> url
enclosedSize :: forall url. EntryEnclosure url -> Int
enclosedMimeType :: forall url. EntryEnclosure url -> Text
..}) -> [
Name -> Map Name Text -> [Node] -> Element
Element Name
"enclosure"
([(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name
"type", Text
enclosedMimeType)
,(Name
"length", String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
enclosedSize)
,(Name
"url", url -> Text
render url
enclosedUrl)]) []]
entryCategoryTemplate :: EntryCategory -> Element
entryCategoryTemplate :: EntryCategory -> Element
entryCategoryTemplate (EntryCategory Maybe Text
mdomain Maybe Text
_ Text
category) =
Name -> Map Name Text -> [Node] -> Element
Element Name
"category" Map Name Text
prop [Text -> Node
NodeContent Text
category]
where prop :: Map Name Text
prop = Map Name Text
-> (Text -> Map Name Text) -> Maybe Text -> Map Name Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Name Text
forall k a. Map k a
Map.empty (\Text
domain -> [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name
"domain",Text
domain)]) Maybe Text
mdomain
rssLink :: MonadWidget m
=> Route (HandlerSite m)
-> Text
-> m ()
Route (HandlerSite m)
r Text
title = ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> Html) -> m ()
forall site a (m :: * -> *).
(ToWidgetHead site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
forall (m :: * -> *).
(MonadWidget m, HandlerSite m ~ HandlerSite m) =>
((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> Html) -> m ()
toWidgetHead (Route (HandlerSite m) -> [(Text, Text)] -> Text) -> Html
[hamlet|
<link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}>
|]