{-# 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
toContent :: RepAtom -> Content
$ctoContent :: RepAtom -> Content
ToContent
instance HasContentType RepAtom where
    getContentType :: m RepAtom -> ContentType
getContentType _ = 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 :: Feed (Route (HandlerSite m)) -> m RepAtom
atomFeed feed :: 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
    RepAtom -> m RepAtom
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 (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 @'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 Text -> m RepAtom
atomFeedText feed :: Feed Text
feed = RepAtom -> m RepAtom
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 :: Feed url -> (url -> Text) -> Document
template Feed {..} render :: 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 ln :: Text
ln _ _) as :: Map Name Text
as ns :: [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 e :: Element
e) = Element -> Node
NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Element -> Element
addNS Element
e
    addNS' n :: Node
n = Node
n
    namespace :: Text
namespace = "http://www.w3.org/2005/Atom"

    root :: Element
root = Name -> Map Name Text -> [Node] -> Element
Element "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 "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 "link" ([(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [("rel", "self"), ("href", url -> Text
render url
feedLinkSelf)]) []
        Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Name -> Map Name Text -> [Node] -> Element
Element "link" (Name -> Text -> Map Name Text
forall k a. k -> a -> Map k a
Map.singleton "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 "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 "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 "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" 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
            Nothing -> []
            Just (route :: url
route, _) -> [Name -> Map Name Text -> [Node] -> Element
Element "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 mdomain :: Maybe Text
mdomain mlabel :: Maybe Text
mlabel category :: Text
category) =
  Name -> Map Name Text -> [Node] -> Element
Element "category" ([(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([("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 [] (\d :: Text
d -> [("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 [] (\l :: Text
l -> [("label",Text
l)])  Maybe Text
mlabel)
                                   )

                     ) []

entryTemplate :: FeedEntry url -> (url -> Text) -> Element
entryTemplate :: FeedEntry url -> (url -> Text) -> Element
entryTemplate FeedEntry {..} render :: url -> Text
render = Name -> Map Name Text -> [Node] -> Element
Element "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 "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 "link" (Name -> Text -> Map Name Text
forall k a. k -> a -> Map k a
Map.singleton "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 "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 "title" Map Name Text
forall k a. Map k a
Map.empty [Text -> Node
NodeContent Text
feedEntryTitle]
    , Name -> Map Name Text -> [Node] -> Element
Element "content" (Name -> Text -> Map Name Text
forall k a. k -> a -> Map k a
Map.singleton "type" "html") [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
        Nothing -> []
        Just (EntryEnclosure{..}) ->
            [Name -> Map Name Text -> [Node] -> Element
Element "link" ([(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [("rel", "enclosure")
                                          ,("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 :: Route (HandlerSite m) -> Text -> m ()
atomLink r :: Route (HandlerSite m)
r title :: 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 typeAtom} rel="alternate" title=#{title}>
    |]