yesod/yesod-newsfeed/Yesod/AtomFeed.hs

{-# 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 ToContent
instance HasContentType RepAtom where
    getContentType _ = typeAtom
instance ToTypedContent RepAtom where
    toTypedContent = TypedContent typeAtom . toContent

atomFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m RepAtom
atomFeed feed = do
    render <- 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 feed = return $ RepAtom $ toContent $ renderLBS def $ template feed id

template :: Feed url -> (url -> Text) -> Document
template Feed {..} render =
    Document (Prologue [] Nothing []) (addNS root) []
  where
    addNS (Element (Name ln _ _) as ns) = Element (Name ln (Just namespace) Nothing) as (map addNS' ns)
    addNS' (NodeElement e) = NodeElement $ addNS e
    addNS' n = n
    namespace = "http://www.w3.org/2005/Atom"

    root = Element "feed" Map.empty $ map NodeElement
        $ Element "title" Map.empty [NodeContent feedTitle]
        : Element "link" (Map.fromList [("rel", "self"), ("href", render feedLinkSelf)]) []
        : Element "link" (Map.singleton "href" $ render feedLinkHome) []
        : Element "updated" Map.empty [NodeContent $ formatW3 feedUpdated]
        : Element "id" Map.empty [NodeContent $ render feedLinkHome]
        : Element "author" Map.empty [NodeElement $ Element "name" Map.empty [NodeContent feedAuthor]]
        : map (flip entryTemplate render) feedEntries
        ++
        case feedLogo of
            Nothing -> []
            Just (route, _) -> [Element "logo" Map.empty [NodeContent $ render route]]

entryTemplate :: FeedEntry url -> (url -> Text) -> Element
entryTemplate FeedEntry {..} render = Element "entry" Map.empty $ map NodeElement $
    [ Element "id" Map.empty [NodeContent $ render feedEntryLink]
    , Element "link" (Map.singleton "href" $ render feedEntryLink) []
    , Element "updated" Map.empty [NodeContent $ formatW3 feedEntryUpdated]
    , Element "title" Map.empty [NodeContent feedEntryTitle]
    , Element "content" (Map.singleton "type" "html") [NodeContent $ toStrict $ renderHtml feedEntryContent]
    ]
    ++
    case feedEntryEnclosure of
        Nothing -> []
        Just (EntryEnclosure{..}) ->
            [Element "link" (Map.fromList [("rel", "enclosure")
                                          ,("href", render enclosedUrl)]) []]

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