lambdaFeed-0.3.1: RSS.hs

-- |A simple feed generator: RSS 2.0 generator
--
--  Copyright (c) 2006 Manuel M T Chakravarty
--
--  License: <http://www.gnu.org/licenses/gpl.html>
--
--- Description ---------------------------------------------------------------
--
--  Language: Haskell 98
--

module RSS (
  channelToRSS
) where

-- standard libraries
--
import Data.Char (
  toLower)
import Data.Maybe (
  maybe, catMaybes, maybeToList)
import Text.PrettyPrint

-- lambdaFeed
import Config (Config(..))
import Feed (
  URL, Channel(..), Image(..), Category(..), Item(..), Enclosure(..),
  GUID(..), Source(..))

infixr 0 $?
infix  4 =!


-- Render a channel to RSS.
--
channelToRSS :: Config -> Channel [Item] -> String
channelToRSS config chan = renderXML $
  RecXML "rss" ["version" =! "2.0"]
    [ RecXML "channel" [] $
        [ TextXML "title"          []        $ titleChan chan
	, TextXML "link"           []        $ linkChan chan
	, TextXML "description"    []        $ descriptionChan chan
        ] ++ catMaybes
	[ TextXML "language"       []        $? languageChan chan
	, TextXML "copyright"      []        $? copyrightChan chan
	, TextXML "managingEditor" []        $? managingEditorChan chan
	, TextXML "webMaster"	   []        $? webMasterChan chan
	, TextXML "pubDate"        [] . show $? pubDateChan chan
	, TextXML "lastBuildDate"  [] . show $? lastBuildDateChan chan
        ] ++ 
        categoryToRSS                        $* categoryChan chan
        ++ catMaybes
	[ TextXML "generator"	   []        $? generatorChan chan
	, TextXML "docs"	   []        $? docsChan chan
	, TextXML "ttl"	           [] . show $? ttlChan chan
	, imageToRSS                         $? imageChan chan
	] ++
	map itemToRSS (itemsChan chan)
    ]

-- Render a category to RSS.
--
categoryToRSS :: Category -> XML
categoryToRSS category =
  TextXML "category" (maybeToList ("domain" =? domainCategory category)) $
    categoryCategory category

-- Render an image to RSS.
--
imageToRSS :: Image -> XML
imageToRSS image =
  EmptyXML "image" $
    [ "url"   =! urlImage image
    , "title" =! titleImage image
    , "link"  =! linkImage image
    ] ++ catMaybes
    [ "width"       =? (show $? widthImage  image)
    , "height"      =? (show $? heightImage image)
    , "description" =? descriptionImage image
    ]

-- Render an item to RSS.
--
itemToRSS :: Item -> XML
itemToRSS item =
  RecXML "item" [] $ catMaybes
    [ TextXML "title"        []        $? titleItem item
    , TextXML "link"         []        $? linkItem item
    , TextXML "description"  []        $? descriptionItem item
    , TextXML "author"       []        $? authorItem item
    ] ++
    categoryToRSS		       $* categoryItem item
    ++ catMaybes
    [ TextXML "comments"     []        $? commentsItem item
    , enclosureToRSS		       $? enclosureItem item
    , guidToRSS			       $? guidItem item
    , TextXML "pubDate"      [] . show $? pubDateItem item
    , sourceToRSS		       $? sourceItem item
    ]

-- Render an enclosure to RSS.
--
enclosureToRSS :: Enclosure -> XML
enclosureToRSS enclosure =
  EmptyXML "enclosure"
    [ "url"    =! urlEnclosure enclosure
    , "length" =! (show . lengthEnclosure $ enclosure)
    , "type"   =! typeEnclosure enclosure
    ]

-- Render a GUID to RSS.
--
guidToRSS :: GUID -> XML
guidToRSS guid =
  TextXML "guid" 
    (maybeToList ("isPermaLink" =? (showBool $? isPermaLinkGUID guid))) $
      guidGUID guid
  where
    showBool = map toLower . show

-- Render a source specification to RSS.
--
sourceToRSS :: Source -> XML
sourceToRSS source =
  TextXML "source" ["url" =! urlSource source ] $
      sourceSource source

-- Attribute construction.
--
(=!) :: String -> String -> AttrXML
name =! value = (name, value)

-- Optional attribute construction.
--
(=?) :: String -> Maybe String -> Maybe AttrXML
name =? value = (name =!) $? value

-- Map
--
($*) :: (a -> b) -> [a] -> [b]
($*) = fmap

-- Optional application.
--
($?) :: (a -> b) -> Maybe a -> Maybe b
($?) = fmap


-- Poor Man's XML Rendering
-- ------------------------

-- An XML tree consisting of empty and non-empty tags.
--
data XML = EmptyXML String [AttrXML]
	 | TextXML  String [AttrXML] String
	 | RecXML   String [AttrXML] [XML]

-- XML attributes are associations.
--
type AttrXML = (String, String)

-- Render an XML tree.
--
renderXML :: XML -> String
renderXML xml = render $
  text "<?xml version=\"1.0\"?>"
  $+$
  renderTag xml
  where
    renderTag (EmptyXML name attrs     ) = 
      renderStartTag name attrs (text "/>")
    renderTag (TextXML  name attrs txt ) = cat
      [ renderStartTag name attrs (char '>')
      , nest 4 (text txt)
      , renderEndTag name
      ]
    renderTag (RecXML   name attrs xmls) =
      renderStartTag name attrs (char '>')
      $+$
      nest 4 (vcat . map renderTag $ xmls)
      $+$
      renderEndTag name
    --
    renderStartTag name attrs terminator = cat
      [ sep 
          [ char '<' <> text name
          , nest 2 (sep $ map renderAttr attrs)
	  ]
      , terminator
      ]
    --
    renderEndTag name = text "</" <> text name <> char '>'
    --
    renderAttr (name, value) = 
      text name <> char '=' <> doubleQuotes (text value)