{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Text.RSS -- Copyright : Copyright 2004, Jeremy Shaw, http://www.n-heptane.com/ -- Copyright 2004-2006, Bjorn Bringert (bjorn@bringert.net) -- License : This code is released to the public domain and comes -- with no warranty. -- -- Maintainer : Bas van Dijk -- Stability : experimental -- Portability : portable -- -- A libary for generating RSS 2.0 feeds. -- -- -- Original module by Jeremy Shaw. -- -- Changes by Bjorn Bringert: -- -- * showXml just converts the RSS to a String, does not print it. -- -- * Added XML escaping. -- -- * Use RFC 2822 format for dates. -- -- * Added all elements from RSS 2.0.1-rv-6, -- -- -- * Use HaXml.Verbatim instead of HaXml.Pretty, since -- HaXml.Pretty seems to introduce spaces around entities. -- -- * Removed the use of content:encoded, since the description -- tag is the recommented way to include HTML content in RSS 2.0. -- -- Changes by Bas van Dijk: -- -- * Use @UTCTime@ from @time@ instead of @CalendarTime@ from @old-time@. -- -- * Add our own @Weekday@ type instead of using the @Day@ type from @old-time@. -- ----------------------------------------------------------------------------- module Text.RSS (RSS(..), Item, ChannelElem(..), ItemElem(..), Title,Link,Description,Width,Height, Email,Domain,MIME_Type,InputName, Weekday(..), Hour, Minutes, CloudHost, CloudPort, CloudPath, CloudProcedure, CloudProtocol(..), rssToXML, showXML ) where import Data.Ix (Ix) import Network.URI (URI) import System.Locale (defaultTimeLocale, rfc822DateFormat) import Data.Time.Clock (UTCTime) import Data.Time.Format (formatTime) import Text.XML.HaXml.Combinators (CFilter, mkElem, mkElemAttr, literal, cdata) import Text.XML.HaXml.Escape (xmlEscape, stdXmlEscaper) import Text.XML.HaXml.Types (Element,Content(..)) import Text.XML.HaXml.Verbatim (verbatim) data RSS = RSS Title Link Description [ChannelElem] [Item] deriving Show type Item = [ItemElem] type Title = String type Link = URI type Description = String type Width = Int type Height = Int type Email = String type Domain = String type MIME_Type = String type InputName = String type Hour = Int type Minutes = Int type CloudHost = String type CloudPort = Int type CloudPath = String type CloudProcedure = String data CloudProtocol = CloudProtocolXmlRpc | CloudProtocolSOAP deriving Show data ChannelElem = Language String | Copyright String | ManagingEditor Email | WebMaster Email | ChannelPubDate UTCTime | LastBuildDate UTCTime | ChannelCategory (Maybe Domain) String | Generator String -- no docs tag, we generate that automatically | Cloud CloudHost CloudPort CloudPath CloudProcedure CloudProtocol | TTL Minutes | Image URI Title Link (Maybe Width) (Maybe Height) (Maybe Description) | Rating String | TextInput Title Description InputName Link | SkipHours [Hour] | SkipDays [Weekday] deriving Show data ItemElem = Title Title | Link Link | Description Description | Author Email | Category (Maybe Domain) String | Comments URI | Enclosure URI Int MIME_Type | Guid Bool String | PubDate UTCTime | Source URI Title deriving (Show) -- | A day of the week. data Weekday = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show) -- | Converts RSS to XML. rssToXML :: RSS -> CFilter () rssToXML (RSS title link description celems items) = mkElemAttr "rss" [("version",literal "2.0")] [mkElem "channel" ([mkTitle title, mkLink link, mkDescription description, mkDocs] ++ map mkChannelElem celems ++ map mkItem items)] -- | Render XML as a string. showXML :: CFilter () -> String showXML = verbatim . cfilterToElem cfilterToElem :: CFilter () -> Element () cfilterToElem f = case f (CString False "" ()) of [CElem e _] -> xmlEscape stdXmlEscaper e [] -> error "RSS produced no output" _ -> error "RSS produced more than one output" mkSimple :: String -> String -> CFilter () mkSimple t str = mkElem t [literal str] mkTitle :: Title -> CFilter () mkTitle = mkSimple "title" mkLink :: Link -> CFilter () mkLink = mkSimple "link" . show mkDescription :: Description -> CFilter () mkDescription str = mkElem "description" [cdata str] mkDocs :: CFilter () mkDocs = mkSimple "docs" "http://www.rssboard.org/rss-specification" mkPubDate :: UTCTime -> CFilter () mkPubDate = mkSimple "pubDate" . formatDate formatDate :: UTCTime -> String formatDate = formatTime defaultTimeLocale rfc822DateFormat mkCategory :: Maybe Domain -> String -> CFilter () mkCategory md s = mkElemAttr "category" attrs [literal s] where attrs = maybe [] (\d -> [("domain", literal d)]) md maybeElem :: (a -> CFilter ()) -> Maybe a -> [CFilter ()] maybeElem = maybe [] . ((:[]) .) mkChannelElem :: ChannelElem -> CFilter () mkChannelElem (Language str) = mkSimple "language" str mkChannelElem (Copyright str) = mkSimple "copyright" str mkChannelElem (ManagingEditor str) = mkSimple "managingEditor" str mkChannelElem (WebMaster str) = mkSimple "webMaster" str mkChannelElem (ChannelPubDate date) = mkPubDate date mkChannelElem (LastBuildDate date) = mkSimple "lastBuildDate" $ formatDate date mkChannelElem (ChannelCategory md str) = mkCategory md str mkChannelElem (Generator str) = mkSimple "generator" str mkChannelElem (Cloud host port path proc proto) = mkElemAttr "cloud" [("domain", literal host), ("port", literal (show port)), ("path", literal path), ("registerProcedure", literal proc), ("protocol", literal (protocolName proto))] [] mkChannelElem (TTL minutes) = mkSimple "ttl" $ show minutes mkChannelElem (Image uri title link mw mh mdesc) = mkElem "image" ([mkElem "url" [literal (show uri)], mkTitle title, mkLink link] ++ maybeElem (mkSimple "width" . show) mw ++ maybeElem (mkSimple "height" . show) mh ++ maybeElem mkDescription mdesc) mkChannelElem (Rating str) = mkSimple "rating" str mkChannelElem (TextInput title desc name link) = mkElem "textInput" [mkTitle title, mkDescription desc, mkSimple "name" name, mkLink link] mkChannelElem (SkipHours hs) = mkElem "skipHours" (map (mkSimple "hour" . show) hs) mkChannelElem (SkipDays ds) = mkElem "skipDays" (map (mkSimple "day" . show) ds) protocolName :: CloudProtocol -> String protocolName CloudProtocolXmlRpc = "xml-rpc" protocolName CloudProtocolSOAP = "soap" mkItem :: Item -> CFilter () mkItem itemElems = mkElem "item" (map mkItemElem itemElems) mkItemElem :: ItemElem -> CFilter () mkItemElem (Title t) = mkTitle t mkItemElem (Link l) = mkLink l mkItemElem (Description d) = mkDescription d mkItemElem (Author e) = mkElem "author" [literal e] mkItemElem (Category md str) = mkCategory md str mkItemElem (Comments uri) = mkSimple "comments" $ show uri mkItemElem (Enclosure uri len mtype) = mkElemAttr "enclosure" [("url", literal (show uri)), ("length", literal (show len)), ("type", literal (mtype))] [] mkItemElem (Guid perm s) = mkElemAttr "guid" attrs [ literal s ] where attrs = if perm then [("isPermaLink", literal "true")] else [] mkItemElem (PubDate ct) = mkElem "pubDate" [ literal (formatDate ct) ] mkItemElem (Source uri t) = mkElemAttr "source" [("url", literal (show uri))] [ literal t ]