123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100 |
- {-# 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 ToContent
- instance HasContentType RepAtom where
- getContentType _ = typeAtom
- instance ToTypedContent RepAtom where
- toTypedContent = TypedContent typeAtom . toContent
- atomFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m RepAtom
- atomFeed feed = do
- render <- getUrlRender
- return $ RepAtom $ toContent $ renderLBS def $ template feed 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 = return $ RepAtom $ toContent $ renderLBS def $ template feed id
- 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.empty $ map NodeElement
- $ Element "title" Map.empty [NodeContent feedTitle]
- : Element "link" (Map.fromList [("rel", "self"), ("href", render feedLinkSelf)]) []
- : Element "link" (Map.singleton "href" $ render feedLinkHome) []
- : Element "updated" Map.empty [NodeContent $ formatW3 feedUpdated]
- : Element "id" Map.empty [NodeContent $ render feedLinkHome]
- : Element "author" Map.empty [NodeElement $ Element "name" Map.empty [NodeContent feedAuthor]]
- : map (flip entryTemplate render) feedEntries
- ++
- case feedLogo of
- Nothing -> []
- Just (route, _) -> [Element "logo" Map.empty [NodeContent $ render route]]
- entryTemplate :: FeedEntry url -> (url -> Text) -> Element
- entryTemplate FeedEntry {..} render = Element "entry" Map.empty $ map NodeElement $
- [ Element "id" Map.empty [NodeContent $ render feedEntryLink]
- , Element "link" (Map.singleton "href" $ render feedEntryLink) []
- , Element "updated" Map.empty [NodeContent $ formatW3 feedEntryUpdated]
- , Element "title" Map.empty [NodeContent feedEntryTitle]
- , Element "content" (Map.singleton "type" "html") [NodeContent $ toStrict $ renderHtml feedEntryContent]
- ]
- ++
- case feedEntryEnclosure of
- Nothing -> []
- Just (EntryEnclosure{..}) ->
- [Element "link" (Map.fromList [("rel", "enclosure")
- ,("href", render enclosedUrl)]) []]
- -- | Generates a link tag in the head of a widget.
- atomLink :: MonadWidget m
- => Route (HandlerSite m)
- -> Text -- ^ title
- -> m ()
- atomLink r title = toWidgetHead [hamlet|
- <link href=@{r} type=#{S8.unpack typeAtom} rel="alternate" title=#{title}>
- |]
|