103 lines
4.0 KiB
Haskell
103 lines
4.0 KiB
Haskell
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
-------------------------------------------------------------------------------
|
|
--
|
|
-- Module : Yesod.RssFeed
|
|
-- Copyright : Patrick Brisbin
|
|
-- License : as-is
|
|
--
|
|
-- Maintainer : Patrick Brisbin <me@pbrisbin.com>
|
|
-- Stability : Stable
|
|
-- Portability : Portable
|
|
--
|
|
-------------------------------------------------------------------------------
|
|
module Yesod.RssFeed
|
|
( rssFeed
|
|
, rssFeedText
|
|
, rssLink
|
|
, RepRss (..)
|
|
, module Yesod.FeedTypes
|
|
) where
|
|
|
|
import Yesod.Core
|
|
import Yesod.FeedTypes
|
|
import qualified Data.ByteString.Char8 as S8
|
|
import Data.Text (Text, pack)
|
|
import Data.Text.Lazy (toStrict)
|
|
import Text.XML
|
|
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
|
import qualified Data.Map as Map
|
|
|
|
newtype RepRss = RepRss Content
|
|
deriving ToContent
|
|
instance HasContentType RepRss where
|
|
getContentType _ = typeRss
|
|
instance ToTypedContent RepRss where
|
|
toTypedContent = TypedContent typeRss . toContent
|
|
|
|
-- | Generate the feed
|
|
rssFeed :: HasHandlerData env => Feed (Route (HandlerSite env)) -> RIO env RepRss
|
|
rssFeed feed = do
|
|
render <- getUrlRender
|
|
return $ RepRss $ toContent $ renderLBS def $ template feed render
|
|
|
|
-- | Same as @'rssFeed'@ but for @'Feed Text'@. Useful for cases where you are
|
|
-- generating a feed of external links.
|
|
rssFeedText :: HasHandlerData env => Feed Text -> RIO env RepRss
|
|
rssFeedText feed = return $ RepRss $ toContent $ renderLBS def $ template feed id
|
|
|
|
template :: Feed url -> (url -> Text) -> Document
|
|
template Feed {..} render =
|
|
Document (Prologue [] Nothing []) root []
|
|
where
|
|
root = Element "rss" (Map.singleton "version" "2.0") $ return $ NodeElement $ Element "channel" Map.empty $ map NodeElement
|
|
$ Element "{http://www.w3.org/2005/Atom}link" (Map.fromList
|
|
[ ("href", render feedLinkSelf)
|
|
, ("rel", "self")
|
|
, ("type", pack $ S8.unpack typeRss)
|
|
]) []
|
|
: Element "title" Map.empty [NodeContent feedTitle]
|
|
: Element "link" Map.empty [NodeContent $ render feedLinkHome]
|
|
: Element "description" Map.empty [NodeContent $ toStrict $ renderHtml feedDescription]
|
|
: Element "lastBuildDate" Map.empty [NodeContent $ formatRFC822 feedUpdated]
|
|
: Element "language" Map.empty [NodeContent feedLanguage]
|
|
: map (flip entryTemplate render) feedEntries
|
|
++
|
|
case feedLogo of
|
|
Nothing -> []
|
|
Just (route, desc) -> [Element "image" Map.empty
|
|
[ NodeElement $ Element "url" Map.empty [NodeContent $ render route]
|
|
, NodeElement $ Element "title" Map.empty [NodeContent desc]
|
|
, NodeElement $ Element "link" Map.empty [NodeContent $ render feedLinkHome]
|
|
]
|
|
]
|
|
|
|
entryTemplate :: FeedEntry url -> (url -> Text) -> Element
|
|
entryTemplate FeedEntry {..} render = Element "item" Map.empty $ map NodeElement $
|
|
[ Element "title" Map.empty [NodeContent feedEntryTitle]
|
|
, Element "link" Map.empty [NodeContent $ render feedEntryLink]
|
|
, Element "guid" Map.empty [NodeContent $ render feedEntryLink]
|
|
, Element "pubDate" Map.empty [NodeContent $ formatRFC822 feedEntryUpdated]
|
|
, Element "description" Map.empty [NodeContent $ toStrict $ renderHtml feedEntryContent]
|
|
]
|
|
++
|
|
case feedEntryEnclosure of
|
|
Nothing -> []
|
|
Just (EntryEnclosure{..}) -> [
|
|
Element "enclosure"
|
|
(Map.fromList [("type", enclosedMimeType)
|
|
,("length", pack $ show enclosedSize)
|
|
,("url", render enclosedUrl)]) []]
|
|
|
|
-- | Generates a link tag in the head of a widget.
|
|
rssLink :: HasWidgetData env
|
|
=> Route (HandlerSite env)
|
|
-> Text -- ^ title
|
|
-> RIO env ()
|
|
rssLink r title = toWidgetHead [hamlet|
|
|
<link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}>
|
|
|]
|