{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-------------------------------------------------------------------------------
--
-- Module        : Yesod.RssFeed
-- Copyright     : Patrick Brisbin
-- License       : as-is
--
-- Maintainer    : Patrick Brisbin <me@pbrisbin.com>
-- Stability     : Stable
-- Portability   : Portable
--
-------------------------------------------------------------------------------
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 RepRss = RepRss Content
    deriving RepRss -> Content
(RepRss -> Content) -> ToContent RepRss
forall a. (a -> Content) -> ToContent a
toContent :: RepRss -> Content
$ctoContent :: 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

-- | Generate the feed
rssFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m RepRss
rssFeed :: forall (m :: * -> *).
MonadHandler m =>
Feed (Route (HandlerSite m)) -> m RepRss
rssFeed 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 (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

-- | Same as @'rssFeed'@ but for @'Feed Text'@. Useful for cases where you are
--   generating a feed of external links.
rssFeedText :: MonadHandler m => Feed Text -> m RepRss
rssFeedText :: forall (m :: * -> *). MonadHandler m => Feed Text -> m RepRss
rssFeedText Feed Text
feed = RepRss -> m RepRss
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
feedEntries :: forall url. Feed url -> [FeedEntry url]
feedLogo :: forall url. Feed url -> Maybe (url, Text)
feedUpdated :: forall url. Feed url -> UTCTime
feedLanguage :: forall url. Feed url -> Text
feedDescription :: forall url. Feed url -> Html
feedAuthor :: forall url. Feed url -> Text
feedLinkHome :: forall url. Feed url -> url
feedLinkSelf :: forall url. Feed url -> url
feedTitle :: forall url. Feed url -> Text
feedEntries :: [FeedEntry url]
feedLogo :: Maybe (url, Text)
feedUpdated :: UTCTime
feedLanguage :: Text
feedDescription :: Html
feedAuthor :: Text
feedLinkHome :: url
feedLinkSelf :: url
feedTitle :: Text
..} 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 (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
feedEntryCategories :: forall url. FeedEntry url -> [EntryCategory]
feedEntryEnclosure :: forall url. FeedEntry url -> Maybe (EntryEnclosure url)
feedEntryContent :: forall url. FeedEntry url -> Html
feedEntryTitle :: forall url. FeedEntry url -> Text
feedEntryUpdated :: forall url. FeedEntry url -> UTCTime
feedEntryLink :: forall url. FeedEntry url -> url
feedEntryCategories :: [EntryCategory]
feedEntryEnclosure :: Maybe (EntryEnclosure url)
feedEntryContent :: Html
feedEntryTitle :: Text
feedEntryUpdated :: UTCTime
feedEntryLink :: url
..} 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
enclosedMimeType :: forall url. EntryEnclosure url -> Text
enclosedSize :: forall url. EntryEnclosure url -> Int
enclosedUrl :: forall url. EntryEnclosure url -> url
enclosedMimeType :: Text
enclosedSize :: Int
enclosedUrl :: url
..}) -> [
            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

-- | Generates a link tag in the head of a widget.
rssLink :: MonadWidget m
        => Route (HandlerSite m)
        -> Text -- ^ title
        -> m ()
rssLink :: forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> Text -> m ()
rssLink 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 ()
toWidgetHead [hamlet|
    <link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}>
    |]