haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Feeds use xml-conduit (#301)

Browse Source
This commit is contained in:
Michael Snoyman 2012-04-03 09:51:04 +03:00
parent ddde7e1676
commit 6461edf00b
3 changed files with 69 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
yesod-newsfeed/Yesod/AtomFeed.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------- ---------------------------------------------------------
-- --
-- Module : Yesod.AtomFeed -- Module : Yesod.AtomFeed
@ -23,43 +25,47 @@ module Yesod.AtomFeed
import Yesod.Core import Yesod.Core
import Yesod.FeedTypes import Yesod.FeedTypes
import Text.Hamlet (HtmlUrl, xhamlet, hamlet) import Text.Hamlet (hamlet)
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import Control.Monad (liftM)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Lazy (toStrict)
import Text.XML
import Text.Blaze.Renderer.Text (renderHtml)
newtype RepAtom = RepAtom Content newtype RepAtom = RepAtom Content
instance HasReps RepAtom where instance HasReps RepAtom where
chooseRep (RepAtom c) _ = return (typeAtom, c) chooseRep (RepAtom c) _ = return (typeAtom, c)
atomFeed :: Feed (Route master) -> GHandler sub master RepAtom 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 :: Feed url -> (url -> Text) -> Document
template arg = [xhamlet| template Feed {..} render =
\<?xml version="1.0" encoding="utf-8"?> Document (Prologue [] Nothing []) (addNS root) []
<feed xmlns="http://www.w3.org/2005/Atom"> where
<title>#{feedTitle arg} addNS (Element (Name ln _ _) as ns) = Element (Name ln (Just namespace) Nothing) as (map addNS' ns)
<link rel=self href=@{feedLinkSelf arg}> addNS' (NodeElement e) = NodeElement $ addNS e
<link href=@{feedLinkHome arg}> addNS' n = n
<updated>#{formatW3 $ feedUpdated arg} namespace = "http://www.w3.org/2005/Atom"
<id>@{feedLinkHome arg}
$forall entry <- feedEntries arg
^{entryTemplate entry}
|]
entryTemplate :: FeedEntry url -> HtmlUrl url root = Element "feed" [] $ map NodeElement
entryTemplate arg = [xhamlet| $ Element "title" [] [NodeContent feedTitle]
<entry> : Element "link" [("rel", "self"), ("href", render feedLinkSelf)] []
<id>@{feedEntryLink arg} : Element "link" [("href", render feedLinkHome)] []
<link href=@{feedEntryLink arg}> : Element "updated" [] [NodeContent $ formatW3 feedUpdated]
<updated>#{formatW3 $ feedEntryUpdated arg} : Element "id" [] [NodeContent $ render feedLinkHome]
<title>#{feedEntryTitle arg} : map (flip entryTemplate render) feedEntries
<content type=html>
\<![CDATA[ entryTemplate :: FeedEntry url -> (url -> Text) -> Element
\#{feedEntryContent arg} 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. -- | Generates a link tag in the head of a widget.
atomLink :: Route m atomLink :: Route m

62
yesod-newsfeed/Yesod/RssFeed.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- --
-- Module : Yesod.RssFeed -- Module : Yesod.RssFeed
@ -19,10 +21,12 @@ module Yesod.RssFeed
import Yesod.Core import Yesod.Core
import Yesod.FeedTypes import Yesod.FeedTypes
import Text.Hamlet (HtmlUrl, xhamlet, hamlet) import Text.Hamlet (hamlet)
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import Control.Monad (liftM) import Data.Text (Text, pack)
import Data.Text (Text) import Data.Text.Lazy (toStrict)
import Text.XML
import Text.Blaze.Renderer.Text (renderHtml)
newtype RepRss = RepRss Content newtype RepRss = RepRss Content
instance HasReps RepRss where instance HasReps RepRss where
@ -30,33 +34,35 @@ instance HasReps RepRss where
-- | Generate the feed -- | Generate the feed
rssFeed :: Feed (Route master) -> GHandler sub master RepRss 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 :: Feed url -> (url -> Text) -> Document
template arg = [xhamlet| template Feed {..} render =
\<?xml version="1.0" encoding="utf-8"?> Document (Prologue [] Nothing []) root []
<rss version="2.0" xmlns:atom="http://www.w3.org/2005/Atom"> where
<channel> root = Element "rss" [("version", "2.0")] $ return $ NodeElement $ Element "channel" [] $ map NodeElement
<atom:link href=@{feedLinkSelf arg} rel="self" type=#{S8.unpack typeRss}> $ Element "{http://www.w3.org/2005/Atom}link"
<title> #{feedTitle arg} [ ("href", render feedLinkSelf)
<link> @{feedLinkHome arg} , ("rel", "self")
<description> #{feedDescription arg} , ("type", pack $ S8.unpack typeRss)
<lastBuildDate>#{formatRFC822 $ feedUpdated arg} ] []
<language> #{feedLanguage arg} : 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 :: FeedEntry url -> (url -> Text) -> Element
^{entryTemplate entry} entryTemplate FeedEntry {..} render = Element "item" [] $ map NodeElement
|] [ Element "title" [] [NodeContent feedEntryTitle]
, Element "link" [] [NodeContent $ render feedEntryLink]
entryTemplate :: FeedEntry url -> HtmlUrl url , Element "guid" [] [NodeContent $ render feedEntryLink]
entryTemplate arg = [xhamlet| , Element "pubDate" [] [NodeContent $ formatRFC822 feedEntryUpdated]
<item> , Element "description" [] [NodeContent $ toStrict $ renderHtml feedEntryContent]
<title> #{feedEntryTitle arg} ]
<link> @{feedEntryLink arg}
<guid> @{feedEntryLink arg}
<pubDate> #{formatRFC822 $ feedEntryUpdated arg}
<description>#{feedEntryContent arg}
|]
-- | Generates a link tag in the head of a widget. -- | Generates a link tag in the head of a widget.
rssLink :: Route m rssLink :: Route m

2
yesod-newsfeed/yesod-newsfeed.cabal
View File

@ -19,6 +19,8 @@ library
, hamlet >= 1.0 && < 1.1 , hamlet >= 1.0 && < 1.1
, bytestring >= 0.9.1.4 && < 0.10 , bytestring >= 0.9.1.4 && < 0.10
, text >= 0.9 && < 0.12 , text >= 0.9 && < 0.12
, xml-conduit >= 0.7 && < 0.8
, blaze-html >= 0.4 && < 0.5
exposed-modules: Yesod.AtomFeed exposed-modules: Yesod.AtomFeed
, Yesod.RssFeed , Yesod.RssFeed
, Yesod.Feed , Yesod.Feed