77 lines
2.6 KiB
Haskell
77 lines
2.6 KiB
Haskell
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
---------------------------------------------------------
|
|
--
|
|
-- 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
|
|
, atomLink
|
|
, RepAtom (..)
|
|
, module Yesod.FeedTypes
|
|
) where
|
|
|
|
import Yesod.Core
|
|
import Yesod.FeedTypes
|
|
import Text.Hamlet (hamlet)
|
|
import qualified Data.ByteString.Char8 as S8
|
|
import Data.Text (Text)
|
|
import Data.Text.Lazy (toStrict)
|
|
import Text.XML
|
|
import Text.Blaze.Renderer.Text (renderHtml)
|
|
|
|
newtype RepAtom = RepAtom Content
|
|
instance HasReps RepAtom where
|
|
chooseRep (RepAtom c) _ = return (typeAtom, c)
|
|
|
|
atomFeed :: Feed (Route master) -> GHandler sub master RepAtom
|
|
atomFeed feed = do
|
|
render <- getUrlRender
|
|
return $ RepAtom $ toContent $ renderLBS def $ template feed render
|
|
|
|
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 NodeElement
|
|
$ Element "title" [] [NodeContent feedTitle]
|
|
: Element "link" [("rel", "self"), ("href", render feedLinkSelf)] []
|
|
: Element "link" [("href", render feedLinkHome)] []
|
|
: Element "updated" [] [NodeContent $ formatW3 feedUpdated]
|
|
: Element "id" [] [NodeContent $ render feedLinkHome]
|
|
: map (flip entryTemplate render) feedEntries
|
|
|
|
entryTemplate :: FeedEntry url -> (url -> Text) -> Element
|
|
entryTemplate FeedEntry {..} render = Element "entry" [] $ map NodeElement
|
|
[ Element "id" [] [NodeContent $ render feedEntryLink]
|
|
, Element "link" [("href", render feedEntryLink)] []
|
|
, Element "updated" [] [NodeContent $ formatW3 feedEntryUpdated]
|
|
, Element "title" [] [NodeContent feedEntryTitle]
|
|
, Element "content" [("type", "html")] [NodeContent $ toStrict $ renderHtml feedEntryContent]
|
|
]
|
|
|
|
-- | Generates a link tag in the head of a widget.
|
|
atomLink :: Route m
|
|
-> Text -- ^ title
|
|
-> GWidget s m ()
|
|
atomLink r title = toWidgetHead [hamlet|
|
|
<link href=@{r} type=#{S8.unpack typeAtom} rel="alternate" title=#{title}>
|
|
|]
|