{-# 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 <v.dijk.bas@gmail.com>
-- 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,
--   <http://www.rssboard.org/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)

#if MIN_VERSION_time(1,5,0)
import Data.Time.Format(defaultTimeLocale, rfc822DateFormat)
#else
import System.Locale (defaultTimeLocale, rfc822DateFormat)
#endif

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 ]