    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    ---------------------------------------------------------
    --
    -- Module        : Yesod.AtomFeed
    -- Copyright     : Michael Snoyman
    -- License       : BSD3
    --
    -- Maintainer    : Michael Snoyman <michael@snoyman.com>
    -- Stability     : Stable
    -- Portability   : portable
    --
    -- Generating atom news feeds.
    --
    ---------------------------------------------------------

    -- | Generation of Atom newsfeeds.
    module Yesod.AtomFeed
        ( atomFeed
        , atomFeedText
        , atomLink
        , RepAtom (..)
        , module Yesod.FeedTypes
        ) where

    import Yesod.Core
    import Yesod.FeedTypes
    import qualified Data.ByteString.Char8 as S8
    import Data.Text (Text)
    import Data.Text.Lazy (toStrict)
    import Text.XML
    import Text.Blaze.Html.Renderer.Text (renderHtml)
    import qualified Data.Map as Map

    newtype RepAtom = RepAtom Content
        deriving RepAtom -> Content
    (RepAtom -> Content) -> ToContent RepAtom
    forall a. (a -> Content) -> ToContent a
    $ctoContent :: RepAtom -> Content
    toContent :: RepAtom -> Content
    ToContent
    instance HasContentType RepAtom where
        getContentType :: forall (m :: * -> *). Monad m => m RepAtom -> ContentType
    getContentType m RepAtom
    _ = ContentType
    typeAtom
    instance ToTypedContent RepAtom where
        toTypedContent :: RepAtom -> TypedContent
    toTypedContent = ContentType -> Content -> TypedContent
    TypedContent ContentType
    typeAtom (Content -> TypedContent)
    -> (RepAtom -> Content) -> RepAtom -> TypedContent
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . RepAtom -> Content
    forall a. ToContent a => a -> Content
    toContent

    atomFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m RepAtom
    atomFeed :: forall (m :: * -> *).
    MonadHandler m =>
    Feed (Route (HandlerSite m)) -> m RepAtom
    atomFeed Feed (Route (HandlerSite m))
    feed = do
        render <- m (Route (HandlerSite m) -> Text)
    forall (m :: * -> *).
    MonadHandler m =>
    m (Route (HandlerSite m) -> Text)
    getUrlRender
        return $ RepAtom $ toContent $ renderLBS def $ template feed render

    -- | Same as @'atomFeed'@ but for @'Feed Text'@. Useful for cases where you are
    --   generating a feed of external links.
    atomFeedText :: MonadHandler m => Feed Text -> m RepAtom
    atomFeedText :: forall (m :: * -> *). MonadHandler m => Feed Text -> m RepAtom
    atomFeedText Feed Text
    feed = RepAtom -> m RepAtom
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (RepAtom -> m RepAtom) -> RepAtom -> m RepAtom
    forall a b. (a -> b) -> a -> b
    $ Content -> RepAtom
    RepAtom (Content -> RepAtom) -> Content -> RepAtom
    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]
    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
    ..} url -> Text
    render =
        Prologue -> Element -> [Miscellaneous] -> Document
    Document ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
    Prologue [] Maybe Doctype
    forall a. Maybe a
    Nothing []) (Element -> Element
    addNS Element
    root) []
      where
        addNS :: Element -> Element
    addNS (Element (Name Text
    ln Maybe Text
    _ Maybe Text
    _) Map Name Text
    as [Node]
    ns) = Name -> Map Name Text -> [Node] -> Element
    Element (Text -> Maybe Text -> Maybe Text -> Name
    Name Text
    ln (Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    namespace) Maybe Text
    forall a. Maybe a
    Nothing) Map Name Text
    as ((Node -> Node) -> [Node] -> [Node]
    forall a b. (a -> b) -> [a] -> [b]
    map Node -> Node
    addNS' [Node]
    ns)
        addNS' :: Node -> Node
    addNS' (NodeElement Element
    e) = Element -> Node
    NodeElement (Element -> Node) -> Element -> Node
    forall a b. (a -> b) -> a -> b
    $ Element -> Element
    addNS Element
    e
        addNS' Node
    n = Node
    n
        namespace :: Text
    namespace = Text
    "http://www.w3.org/2005/Atom"

        root :: Element
    root = Name -> Map Name Text -> [Node] -> Element
    Element Name
    "feed" 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
    feedTitle]
            Element -> [Element] -> [Element]
    forall a. a -> [a] -> [a]
    : Name -> Map Name Text -> [Node] -> Element
    Element Name
    "link" ([(Name, Text)] -> Map Name Text
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList [(Name
    "rel", Text
    "self"), (Name
    "href", url -> Text
    render url
    feedLinkSelf)]) []
            Element -> [Element] -> [Element]
    forall a. a -> [a] -> [a]
    : Name -> Map Name Text -> [Node] -> Element
    Element Name
    "link" (Name -> Text -> Map Name Text
    forall k a. k -> a -> Map k a
    Map.singleton Name
    "href" (Text -> Map Name Text) -> Text -> Map Name Text
    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
    "updated" 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
    formatW3 UTCTime
    feedUpdated]
            Element -> [Element] -> [Element]
    forall a. a -> [a] -> [a]
    : Name -> Map Name Text -> [Node] -> Element
    Element Name
    "id" 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
    "author" 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
    "name" Map Name Text
    forall k a. Map k a
    Map.empty [Text -> Node
    NodeContent Text
    feedAuthor]]
            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
    _) -> [Name -> Map Name Text -> [Node] -> Element
    Element Name
    "logo" 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]]

    entryCategoryTemplate :: EntryCategory -> Element
    entryCategoryTemplate :: EntryCategory -> Element
    entryCategoryTemplate (EntryCategory Maybe Text
    mdomain Maybe Text
    mlabel Text
    category) =
      Name -> Map Name Text -> [Node] -> Element
    Element Name
    "category" ([(Name, Text)] -> Map Name Text
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([(Name
    "term",Text
    category)]
                                       [(Name, Text)] -> [(Name, Text)] -> [(Name, Text)]
    forall a. [a] -> [a] -> [a]
    ++ ([(Name, Text)]
    -> (Text -> [(Name, Text)]) -> Maybe Text -> [(Name, Text)]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [] (\Text
    d -> [(Name
    "scheme",Text
    d)]) Maybe Text
    mdomain)
                                       [(Name, Text)] -> [(Name, Text)] -> [(Name, Text)]
    forall a. [a] -> [a] -> [a]
    ++ ([(Name, Text)]
    -> (Text -> [(Name, Text)]) -> Maybe Text -> [(Name, Text)]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [] (\Text
    l -> [(Name
    "label",Text
    l)])  Maybe Text
    mlabel)
                                       )

                         ) []

    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]
    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
    ..} url -> Text
    render = Name -> Map Name Text -> [Node] -> Element
    Element Name
    "entry" 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
    "id" 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
    "link" (Name -> Text -> Map Name Text
    forall k a. k -> a -> Map k a
    Map.singleton Name
    "href" (Text -> Map Name Text) -> Text -> Map Name Text
    forall a b. (a -> b) -> a -> b
    $ url -> Text
    render url
    feedEntryLink) []
        , Name -> Map Name Text -> [Node] -> Element
    Element Name
    "updated" 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
    formatW3 UTCTime
    feedEntryUpdated]
        , 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
    "content" (Name -> Text -> Map Name Text
    forall k a. k -> a -> Map k a
    Map.singleton Name
    "type" Text
    "html") [Text -> Node
    NodeContent (Text -> Node) -> Text -> Node
    forall a b. (a -> b) -> a -> b
    $ LazyText -> Text
    toStrict (LazyText -> Text) -> LazyText -> Text
    forall a b. (a -> b) -> a -> b
    $ Html -> LazyText
    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
    enclosedMimeType :: forall url. EntryEnclosure url -> Text
    enclosedSize :: forall url. EntryEnclosure url -> Int
    enclosedUrl :: forall url. EntryEnclosure url -> url
    ..}) ->
                [Name -> Map Name Text -> [Node] -> Element
    Element Name
    "link" ([(Name, Text)] -> Map Name Text
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList [(Name
    "rel", Text
    "enclosure")
                                              ,(Name
    "href", url -> Text
    render url
    enclosedUrl)]) []]

    -- | Generates a link tag in the head of a widget.
    atomLink :: MonadWidget m
             => Route (HandlerSite m)
             -> Text -- ^ title
             -> m ()
    atomLink :: forall (m :: * -> *).
    MonadWidget m =>
    Route (HandlerSite m) -> Text -> m ()
    atomLink 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 typeAtom} rel="alternate" title=#{title}>
        |]