{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
-- | Streaming renderers for the Atom 1.0 standard.
module Text.Atom.Conduit.Render
  ( -- * Top-level
    renderAtomFeed
    -- * Elements
  , renderAtomEntry
  , renderAtomContent
  , renderAtomSource
  , renderAtomGenerator
  , renderAtomLink
  , renderAtomCategory
    -- * Constructs
  , renderAtomPerson
  , renderAtomText
  ) where

-- {{{ Imports
import           Text.Atom.Lens
import           Text.Atom.Types

import           Control.Monad
import           Data.Conduit
import           Data.Monoid
import           Data.Text              as Text
import           Data.Text.Encoding
import           Data.Time.Clock
import           Data.Time.LocalTime
import           Data.Time.RFC3339
import           Data.XML.Types
import           Lens.Simple
import           Refined
import           Text.XML.Stream.Render
import           URI.ByteString
-- }}}

-- | Render the top-level @atom:feed@ element.
renderAtomFeed :: (Monad m) => AtomFeed -> ConduitT () Event m ()
renderAtomFeed f = atomTag "feed" (attr "xmlns" "http://www.w3.org/2005/Atom") $ do
  forM_ (f^.feedAuthorsL) $ renderAtomPerson "author"
  forM_ (f^.feedCategoriesL) renderAtomCategory
  forM_ (f^.feedContributorsL) $ renderAtomPerson "contributor"
  forM_ (f^.feedEntriesL) renderAtomEntry
  forM_ (f^.feedGeneratorL) renderAtomGenerator
  forM_ (feedIcon f) $ atomTag "icon" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'
  atomTag "id" mempty . content $ f^.feedIdL
  forM_ (f^.feedLinksL) renderAtomLink
  forM_ (feedLogo f) $ atomTag "logo" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'
  forM_ (f^.feedRightsL) $ renderAtomText "rights"
  forM_ (f^.feedSubtitleL) $ renderAtomText "subtitle"
  renderAtomText "title" $ f^.feedTitleL
  dateTag "updated" $ f^.feedUpdatedL

-- | Render an @atom:entry@ element.
renderAtomEntry :: (Monad m) => AtomEntry -> ConduitT () Event m ()
renderAtomEntry e = atomTag "entry" mempty $ do
  forM_ (e^.entryAuthorsL) $ renderAtomPerson "author"
  forM_ (e^.entryCategoriesL) renderAtomCategory
  forM_ (e^.entryContentL) renderAtomContent
  forM_ (e^.entryContributorsL) $ renderAtomPerson "contributor"
  atomTag "id" mempty . content $ e^.entryIdL
  forM_ (e^.entryLinksL) renderAtomLink
  forM_ (e^.entryPublishedL) $ dateTag "published"
  forM_ (e^.entryRightsL) $ renderAtomText "rights"
  forM_ (e^.entrySourceL) renderAtomSource
  forM_ (e^.entrySummaryL) $ renderAtomText "summary"
  renderAtomText "title" (e^.entryTitleL)
  dateTag "updated" (e^.entryUpdatedL)

-- | Render an @atom:content@ element.
renderAtomContent :: (Monad m) => AtomContent -> ConduitT () Event m ()
renderAtomContent (AtomContentInlineXHTML t) = atomTag "content" (attr "type" "xhtml")
  . tag "{http://www.w3.org/1999/xhtml}div" mempty $ content t
renderAtomContent (AtomContentOutOfLine ctype uri) = atomTag "content" (nonEmptyAttr "type" ctype <> attr "src" (decodeUtf8 $ withAtomURI serializeURIRef' uri)) $ return ()
renderAtomContent (AtomContentInlineText TypeHTML t) = atomTag "content" (attr "type" "html") $ content t
renderAtomContent (AtomContentInlineText TypeText t) = atomTag "content" mempty $ content t
renderAtomContent (AtomContentInlineOther ctype t) = atomTag "content" (attr "type" ctype) $ content t

-- | Render an @atom:source@ element.
renderAtomSource :: (Monad m) => AtomSource -> ConduitT () Event m ()
renderAtomSource s = atomTag "source" mempty $ do
  forM_ (s^.sourceAuthorsL) $ renderAtomPerson "author"
  forM_ (s^.sourceCategoriesL) renderAtomCategory
  forM_ (s^.sourceContributorsL) $ renderAtomPerson "contributor"
  forM_ (s^.sourceGeneratorL) renderAtomGenerator
  forM_ (sourceIcon s) $ atomTag "icon" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'
  unless (Text.null $ s^.sourceIdL) . atomTag "id" mempty . content $ s^.sourceIdL
  forM_ (s^.sourceLinksL) renderAtomLink
  forM_ (sourceLogo s) $ atomTag "logo" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'
  forM_ (s^.sourceRightsL) $ renderAtomText "rights"
  forM_ (s^.sourceSubtitleL) $ renderAtomText "subtitle"
  forM_ (s^.sourceTitleL) $ renderAtomText "title"
  forM_ (s^.sourceUpdatedL) $ dateTag "updated"

-- | Render an @atom:generator@ element.
renderAtomGenerator :: (Monad m) => AtomGenerator -> ConduitT () Event m ()
renderAtomGenerator g = atomTag "generator" attributes . content . unrefine $ g^.generatorContentL
  where attributes = optionalAttr "uri" (decodeUtf8 . withAtomURI serializeURIRef' <$> generatorUri g)
                     <> nonEmptyAttr "version" (g^.generatorVersionL)

-- | Render an @atom:link@ element.
renderAtomLink :: (Monad m) => AtomLink -> ConduitT () Event m ()
renderAtomLink l = atomTag "link" linkAttrs $ return ()
  where linkAttrs = attr "href" (decodeUtf8 . withAtomURI serializeURIRef' $ linkHref l)
                    <> nonEmptyAttr "rel" (l^.linkRelL)
                    <> nonEmptyAttr "type" (l^.linkTypeL)
                    <> nonEmptyAttr "hreflang" (l^.linkLangL)
                    <> nonEmptyAttr "title" (l^.linkTitleL)
                    <> nonEmptyAttr "length" (l^.linkLengthL)

-- | Render an @atom:category@ element.
renderAtomCategory :: (Monad m) => AtomCategory -> ConduitT () Event m ()
renderAtomCategory c = atomTag "category" attributes $ return ()
  where attributes = attr "term" (unrefine $ c^.categoryTermL)
                     <> nonEmptyAttr "scheme" (c^.categorySchemeL)
                     <> nonEmptyAttr "label" (c^.categoryLabelL)

-- | Render an atom person construct.
renderAtomPerson :: (Monad m) => Text -> AtomPerson -> ConduitT () Event m ()
renderAtomPerson name p = atomTag name mempty $ do
  atomTag "name" mempty . content . unrefine $ p^.personNameL
  unless (Text.null $ p^.personEmailL) $ atomTag "email" mempty . content $ p^.personEmailL
  forM_ (personUri p) $ atomTag "uri" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'

-- | Render an atom text construct.
renderAtomText :: (Monad m) => Text -> AtomText -> ConduitT () Event m ()
renderAtomText name (AtomXHTMLText t) = atomTag name (attr "type" "xhtml")
  . tag "{http://www.w3.org/1999/xhtml}div" mempty $ content t
renderAtomText name (AtomPlainText TypeHTML t) = atomTag name (attr "type" "html") $ content t
renderAtomText name (AtomPlainText TypeText t) = atomTag name mempty $ content t

atomTag :: Monad m => Text -> Attributes -> ConduitT () Event m () -> ConduitT () Event m ()
atomTag name = tag (Name name (Just "http://www.w3.org/2005/Atom") (Just "atom"))

dateTag :: (Monad m) => Text -> UTCTime -> ConduitT () Event m ()
dateTag name = atomTag name mempty . content . formatTimeRFC3339 . utcToZonedTime utc

nonEmptyAttr :: Name -> Text -> Attributes
nonEmptyAttr name value
  | value == mempty = mempty
  | otherwise = attr name value