    {-# 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
    $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

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

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

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