Feeds use xml-conduit (#301)
This commit is contained in:
Michael Snoyman
parent
ddde7e1676
commit
6461edf00b
@ -1,4 +1,6 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Yesod.AtomFeed
|
||||
@ -23,43 +25,47 @@ module Yesod.AtomFeed
|
||||
|
||||
import Yesod.Core
|
||||
import Yesod.FeedTypes
|
||||
import Text.Hamlet (HtmlUrl, xhamlet, hamlet)
|
||||
import Text.Hamlet (hamlet)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Control.Monad (liftM)
|
||||
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 = liftM RepAtom . hamletToContent . template
|
||||
atomFeed feed = do
|
||||
render <- getUrlRender
|
||||
return $ RepAtom $ toContent $ renderLBS def $ template feed render
|
||||
|
||||
template :: Feed url -> HtmlUrl url
|
||||
template arg = [xhamlet|
|
||||
\<?xml version="1.0" encoding="utf-8"?>
|
||||
<feed xmlns="http://www.w3.org/2005/Atom">
|
||||
<title>#{feedTitle arg}
|
||||
<link rel=self href=@{feedLinkSelf arg}>
|
||||
<link href=@{feedLinkHome arg}>
|
||||
<updated>#{formatW3 $ feedUpdated arg}
|
||||
<id>@{feedLinkHome arg}
|
||||
$forall entry <- feedEntries arg
|
||||
^{entryTemplate entry}
|
||||
|]
|
||||
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"
|
||||
|
||||
entryTemplate :: FeedEntry url -> HtmlUrl url
|
||||
entryTemplate arg = [xhamlet|
|
||||
<entry>
|
||||
<id>@{feedEntryLink arg}
|
||||
<link href=@{feedEntryLink arg}>
|
||||
<updated>#{formatW3 $ feedEntryUpdated arg}
|
||||
<title>#{feedEntryTitle arg}
|
||||
<content type=html>
|
||||
\<![CDATA[
|
||||
\#{feedEntryContent arg}
|
||||
]]>
|
||||
|]
|
||||
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
|
||||
|
||||
@ -1,4 +1,6 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-------------------------------------------------------------------------------
|
||||
--
|
||||
-- Module : Yesod.RssFeed
|
||||
@ -19,10 +21,12 @@ module Yesod.RssFeed
|
||||
|
||||
import Yesod.Core
|
||||
import Yesod.FeedTypes
|
||||
import Text.Hamlet (HtmlUrl, xhamlet, hamlet)
|
||||
import Text.Hamlet (hamlet)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Control.Monad (liftM)
|
||||
import Data.Text (Text)
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Text.Lazy (toStrict)
|
||||
import Text.XML
|
||||
import Text.Blaze.Renderer.Text (renderHtml)
|
||||
|
||||
newtype RepRss = RepRss Content
|
||||
instance HasReps RepRss where
|
||||
@ -30,33 +34,35 @@ instance HasReps RepRss where
|
||||
|
||||
-- | Generate the feed
|
||||
rssFeed :: Feed (Route master) -> GHandler sub master RepRss
|
||||
rssFeed = liftM RepRss . hamletToContent . template
|
||||
rssFeed feed = do
|
||||
render <- getUrlRender
|
||||
return $ RepRss $ toContent $ renderLBS def $ template feed render
|
||||
|
||||
template :: Feed url -> HtmlUrl url
|
||||
template arg = [xhamlet|
|
||||
\<?xml version="1.0" encoding="utf-8"?>
|
||||
<rss version="2.0" xmlns:atom="http://www.w3.org/2005/Atom">
|
||||
<channel>
|
||||
<atom:link href=@{feedLinkSelf arg} rel="self" type=#{S8.unpack typeRss}>
|
||||
<title> #{feedTitle arg}
|
||||
<link> @{feedLinkHome arg}
|
||||
<description> #{feedDescription arg}
|
||||
<lastBuildDate>#{formatRFC822 $ feedUpdated arg}
|
||||
<language> #{feedLanguage arg}
|
||||
template :: Feed url -> (url -> Text) -> Document
|
||||
template Feed {..} render =
|
||||
Document (Prologue [] Nothing []) root []
|
||||
where
|
||||
root = Element "rss" [("version", "2.0")] $ return $ NodeElement $ Element "channel" [] $ map NodeElement
|
||||
$ Element "{http://www.w3.org/2005/Atom}link"
|
||||
[ ("href", render feedLinkSelf)
|
||||
, ("rel", "self")
|
||||
, ("type", pack $ S8.unpack typeRss)
|
||||
] []
|
||||
: Element "title" [] [NodeContent feedTitle]
|
||||
: Element "link" [] [NodeContent $ render feedLinkHome]
|
||||
: Element "description" [] [NodeContent $ toStrict $ renderHtml feedDescription]
|
||||
: Element "lastBuildDate" [] [NodeContent $ formatRFC822 feedUpdated]
|
||||
: Element "language" [] [NodeContent feedLanguage]
|
||||
: map (flip entryTemplate render) feedEntries
|
||||
|
||||
$forall entry <- feedEntries arg
|
||||
^{entryTemplate entry}
|
||||
|]
|
||||
|
||||
entryTemplate :: FeedEntry url -> HtmlUrl url
|
||||
entryTemplate arg = [xhamlet|
|
||||
<item>
|
||||
<title> #{feedEntryTitle arg}
|
||||
<link> @{feedEntryLink arg}
|
||||
<guid> @{feedEntryLink arg}
|
||||
<pubDate> #{formatRFC822 $ feedEntryUpdated arg}
|
||||
<description>#{feedEntryContent arg}
|
||||
|]
|
||||
entryTemplate :: FeedEntry url -> (url -> Text) -> Element
|
||||
entryTemplate FeedEntry {..} render = Element "item" [] $ map NodeElement
|
||||
[ Element "title" [] [NodeContent feedEntryTitle]
|
||||
, Element "link" [] [NodeContent $ render feedEntryLink]
|
||||
, Element "guid" [] [NodeContent $ render feedEntryLink]
|
||||
, Element "pubDate" [] [NodeContent $ formatRFC822 feedEntryUpdated]
|
||||
, Element "description" [] [NodeContent $ toStrict $ renderHtml feedEntryContent]
|
||||
]
|
||||
|
||||
-- | Generates a link tag in the head of a widget.
|
||||
rssLink :: Route m
|
||||
|
||||
@ -19,6 +19,8 @@ library
|
||||
, hamlet >= 1.0 && < 1.1
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
, text >= 0.9 && < 0.12
|
||||
, xml-conduit >= 0.7 && < 0.8
|
||||
, blaze-html >= 0.4 && < 0.5
|
||||
exposed-modules: Yesod.AtomFeed
|
||||
, Yesod.RssFeed
|
||||
, Yesod.Feed
|
||||
|
||||
Loading…
Reference in New Issue
Block a user