module Text.RSS.Conduit.Render
(
renderRssDocument
, renderRssItem
, renderRssSource
, renderRssEnclosure
, renderRssGuid
, renderRssCloud
, renderRssCategory
, renderRssImage
, renderRssTextInput
, renderRssSkipDays
, renderRssSkipHours
) where
import Text.RSS.Lens
import Text.RSS.Types
import Control.Monad
import Data.Conduit
import Data.Monoid
import Data.MonoTraversable
import Data.Set (Set)
import Data.Text as Text hiding (map)
import Data.Text.Encoding
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Time.RFC822
import Data.Version
import Data.XML.Types
import Lens.Simple
import Safe
import Text.XML.Stream.Render
import URI.ByteString
renderRssDocument :: (Monad m) => RssDocument -> Source m Event
renderRssDocument d = tag "rss" (attr "version" . pack . showVersion $ d^.documentVersionL) $ do
textTag "title" $ d^.channelTitleL
textTag "link" $ decodeUtf8 $ withRssURI serializeURIRef' $ d^.channelLinkL
textTag "description" $ d^.channelDescriptionL
optionalTextTag "copyright" $ d^.channelCopyrightL
optionalTextTag "language" $ d^.channelLanguageL
optionalTextTag "managingEditor" $ d^.channelManagingEditorL
optionalTextTag "webMaster" $ d^.channelWebmasterL
forM_ (d^.channelPubDateL) $ dateTag "pubDate"
forM_ (d^.channelLastBuildDateL) $ dateTag "lastBuildDate"
forM_ (d^..channelCategoriesL) renderRssCategory
optionalTextTag "generator" $ d^.channelGeneratorL
forM_ (d^.channelDocsL) $ textTag "docs" . decodeUtf8 . withRssURI serializeURIRef'
forM_ (d^.channelCloudL) renderRssCloud
forM_ (d^.channelTtlL) $ textTag "ttl" . tshow
forM_ (d^.channelImageL) renderRssImage
optionalTextTag "rating" $ d^.channelRatingL
forM_ (d^.channelTextInputL) renderRssTextInput
renderRssSkipHours $ d^.channelSkipHoursL
renderRssSkipDays $ d^.channelSkipDaysL
forM_ (d^..channelItemsL) renderRssItem
renderRssItem :: (Monad m) => RssItem -> Source m Event
renderRssItem i = tag "item" mempty $ do
optionalTextTag "title" $ i^.itemTitleL
forM_ (i^.itemLinkL) $ textTag "link" . decodeUtf8 . withRssURI serializeURIRef'
optionalTextTag "description" $ i^.itemDescriptionL
optionalTextTag "author" $ i^.itemAuthorL
forM_ (i^..itemCategoriesL) renderRssCategory
forM_ (i^.itemCommentsL) $ textTag "comments" . decodeUtf8 . withRssURI serializeURIRef'
forM_ (i^..itemEnclosureL) renderRssEnclosure
forM_ (i^.itemGuidL) renderRssGuid
forM_ (i^.itemPubDateL) $ dateTag "pubDate"
forM_ (i^.itemSourceL) renderRssSource
renderRssSource :: (Monad m) => RssSource -> Source m Event
renderRssSource s = tag "source" (attr "url" $ decodeUtf8 $ withRssURI serializeURIRef' $ s^.sourceUrlL) . content $ s^.sourceNameL
renderRssEnclosure :: (Monad m) => RssEnclosure -> Source m Event
renderRssEnclosure e = tag "enclosure" attributes mempty where
attributes = attr "url" (decodeUtf8 $ withRssURI serializeURIRef' $ e^.enclosureUrlL)
<> attr "length" (tshow $ e^.enclosureLengthL)
<> attr "type" (e^.enclosureTypeL)
renderRssGuid :: (Monad m) => RssGuid -> Source m Event
renderRssGuid (GuidUri u) = tag "guid" (attr "isPermaLink" "true") $ content $ decodeUtf8 $ withRssURI serializeURIRef' u
renderRssGuid (GuidText t) = tag "guid" mempty $ content t
renderRssCloud :: (Monad m) => RssCloud -> Source m Event
renderRssCloud c = tag "cloud" attributes $ return () where
attributes = attr "domain" domain
<> optionalAttr "port" port
<> attr "path" (path <> query <> fragment)
<> attr "registerProcedure" (c^.cloudRegisterProcedureL)
<> attr "protocol" (describe $ c^.cloudProtocolL)
renderUserInfo (Just (UserInfo a b)) = decodeUtf8 a <> ":" <> decodeUtf8 b <> "@"
renderUserInfo _ = ""
renderHost (Host h) = decodeUtf8 h
renderQuery (Query query) = case intercalate "&" $ map (\(a,b) -> decodeUtf8 a <> "=" <> decodeUtf8 b) query of
"" -> ""
x -> "?" <> x
domain = maybe "" (\a -> renderUserInfo (authorityUserInfo a) <> renderHost (authorityHost a)) $ withRssURI (view authorityL) $ c^.cloudUriL
port = fmap (pack . show . portNumber) $ authorityPort =<< withRssURI (view authorityL) (c^.cloudUriL)
path = decodeUtf8 $ withRssURI (view pathL) $ c^.cloudUriL
query = renderQuery $ withRssURI (view queryL) $ c^.cloudUriL
fragment = maybe "" decodeUtf8 $ withRssURI (view fragmentL) $ c^.cloudUriL
describe ProtocolXmlRpc = "xml-rpc"
describe ProtocolSoap = "soap"
describe ProtocolHttpPost = "http-post"
renderRssCategory :: (Monad m) => RssCategory -> Source m Event
renderRssCategory c = tag "category" (attr "domain" $ c^.categoryDomainL) . content $ c^.categoryNameL
renderRssImage :: (Monad m) => RssImage -> Source m Event
renderRssImage i = tag "image" mempty $ do
textTag "url" $ decodeUtf8 $ withRssURI serializeURIRef' $ i^.imageUriL
textTag "title" $ i^.imageTitleL
textTag "link" $ decodeUtf8 $ withRssURI serializeURIRef' $ i^.imageLinkL
forM_ (i^.imageHeightL) $ textTag "height" . tshow
forM_ (i^.imageWidthL) $ textTag "width" . tshow
optionalTextTag "description" $ i^.imageDescriptionL
renderRssTextInput :: (Monad m) => RssTextInput -> Source m Event
renderRssTextInput t = tag "textInput" mempty $ do
textTag "title" $ t^.textInputTitleL
textTag "description" $ t^.textInputDescriptionL
textTag "name" $ t^.textInputNameL
textTag "link" $ decodeUtf8 $ withRssURI serializeURIRef' $ t^.textInputLinkL
renderRssSkipDays :: (Monad m) => Set Day -> Source m Event
renderRssSkipDays s = tag "skipDays" mempty $ forM_ s $ textTag "day" . tshow
renderRssSkipHours :: (Monad m) => Set Hour -> Source m Event
renderRssSkipHours s = tag "skipHour" mempty $ forM_ s $ textTag "hour" . tshow
tshow :: (Show a) => a -> Text
tshow = pack . show
textTag :: (Monad m) => Name -> Text -> Source m Event
textTag name = tag name mempty . content
optionalTextTag :: (Monad m) => Name -> Text -> Source m Event
optionalTextTag name value = unless (onull value) $ textTag name value
dateTag :: (Monad m) => Name -> UTCTime -> Source m Event
dateTag name = tag name mempty . content . formatTimeRFC822 . utcToZonedTime utc