module Text.Atom.Feed.Export where
import Text.XML.Light as XML
import Text.Atom.Feed
atom_prefix :: Maybe String
atom_prefix = Nothing
atom_thr_prefix :: Maybe String
atom_thr_prefix = Just "thr"
atomNS :: String
atomNS = "http://www.w3.org/2005/Atom"
atomThreadNS :: String
atomThreadNS = "http://purl.org/syndication/thread/1.0"
xmlns_atom :: Attr
xmlns_atom = Attr qn atomNS
where
qn = case atom_prefix of
Nothing -> QName { qName = "xmlns"
, qURI = Nothing
, qPrefix = Nothing
}
Just s -> QName { qName = s
, qURI = Nothing
, qPrefix = Just "xmlns"
}
xmlns_atom_thread :: Attr
xmlns_atom_thread = Attr qn atomThreadNS
where
qn = case atom_prefix of
Nothing -> QName { qName = "xmlns"
, qURI = Nothing
, qPrefix = Nothing
}
Just s -> QName { qName = s
, qURI = Nothing
, qPrefix = Just "xmlns"
}
atomName :: String -> QName
atomName nc = QName { qName = nc
, qURI = Just atomNS
, qPrefix = atom_prefix
}
atomAttr :: String -> String -> Attr
atomAttr x y = Attr (atomName x) y
atomNode :: String -> [XML.Content] -> XML.Element
atomNode x xs = blank_element { elName = atomName x, elContent = xs }
atomLeaf :: String -> String -> XML.Element
atomLeaf tag txt = blank_element
{ elName = atomName tag
, elContent = [ Text blank_cdata { cdData = txt } ]
}
atomThreadName :: String -> QName
atomThreadName nc =
QName { qName = nc
, qURI = Just atomThreadNS
, qPrefix = atom_thr_prefix
}
atomThreadAttr :: String -> String -> Attr
atomThreadAttr x y = Attr (atomThreadName x) y
atomThreadNode :: String -> [XML.Content] -> XML.Element
atomThreadNode x xs =
blank_element { elName = atomThreadName x, elContent = xs }
atomThreadLeaf :: String -> String -> XML.Element
atomThreadLeaf tag txt =
blank_element { elName = atomThreadName tag
, elContent = [ Text blank_cdata { cdData = txt } ]
}
xmlFeed :: Feed -> XML.Element
xmlFeed f = ( atomNode "feed"
$ map Elem
$ [ xmlTitle (feedTitle f) ]
++ [ xmlId (feedId f) ]
++ [ xmlUpdated (feedUpdated f) ]
++ map xmlLink (feedLinks f)
++ map xmlAuthor (feedAuthors f)
++ map xmlCategory (feedCategories f)
++ map xmlContributor (feedContributors f)
++ mb xmlGenerator (feedGenerator f)
++ mb xmlIcon (feedIcon f)
++ mb xmlLogo (feedLogo f)
++ mb xmlRights (feedRights f)
++ mb xmlSubtitle (feedSubtitle f)
++ map xmlEntry (feedEntries f)
++ feedOther f )
{ elAttribs = [xmlns_atom] }
xmlEntry :: Entry -> XML.Element
xmlEntry e = ( atomNode "entry"
$ map Elem
$ [ xmlId (entryId e) ]
++ [ xmlTitle (entryTitle e) ]
++ [ xmlUpdated (entryUpdated e) ]
++ map xmlAuthor (entryAuthors e)
++ map xmlCategory (entryCategories e)
++ mb xmlContent (entryContent e)
++ map xmlContributor (entryContributor e)
++ map xmlLink (entryLinks e)
++ mb xmlPublished (entryPublished e)
++ mb xmlRights (entryRights e)
++ mb xmlSource (entrySource e)
++ mb xmlSummary (entrySummary e)
++ mb xmlInReplyTo (entryInReplyTo e)
++ mb xmlInReplyTotal (entryInReplyTotal e)
++ entryOther e )
{ elAttribs = entryAttrs e }
xmlContent :: EntryContent -> XML.Element
xmlContent cont = case cont of
TextContent t -> (atomLeaf "content" t)
{ elAttribs = [ atomAttr "type" "text" ] }
HTMLContent t -> (atomLeaf "content" t)
{ elAttribs = [ atomAttr "type" "html" ] }
XHTMLContent x -> (atomNode "content" [ Elem x ])
{ elAttribs = [ atomAttr "type" "xhtml" ] }
MixedContent mbTy cs -> (atomNode "content" cs)
{ elAttribs = mb (atomAttr "type") mbTy }
ExternalContent mbTy src -> (atomNode "content" [])
{ elAttribs = [ atomAttr "src" src ]
++ mb (atomAttr "type") mbTy }
xmlCategory :: Category -> XML.Element
xmlCategory c = (atomNode "category" (map Elem (catOther c)))
{ elAttribs = [ atomAttr "term" (catTerm c) ]
++ mb (atomAttr "scheme") (catScheme c)
++ mb (atomAttr "label") (catLabel c)
}
xmlLink :: Link -> XML.Element
xmlLink l = (atomNode "link" (map Elem (linkOther l)))
{ elAttribs = [ atomAttr "href" (linkHref l) ]
++ mb (atomAttr "rel" . either id id) (linkRel l)
++ mb (atomAttr "type") (linkType l)
++ mb (atomAttr "hreflang") (linkHrefLang l)
++ mb (atomAttr "title") (linkTitle l)
++ mb (atomAttr "length") (linkLength l)
++ linkAttrs l
}
xmlSource :: Source -> Element
xmlSource s = atomNode "source"
$ map Elem
$ sourceOther s
++ map xmlAuthor (sourceAuthors s)
++ map xmlCategory (sourceCategories s)
++ mb xmlGenerator (sourceGenerator s)
++ mb xmlIcon (sourceIcon s)
++ mb xmlId (sourceId s)
++ map xmlLink (sourceLinks s)
++ mb xmlLogo (sourceLogo s)
++ mb xmlRights (sourceRights s)
++ mb xmlSubtitle (sourceSubtitle s)
++ mb xmlTitle (sourceTitle s)
++ mb xmlUpdated (sourceUpdated s)
xmlGenerator :: Generator -> Element
xmlGenerator g = (atomLeaf "generator" (genText g))
{ elAttribs = mb (atomAttr "uri") (genURI g)
++ mb (atomAttr "version") (genVersion g)
}
xmlAuthor :: Person -> XML.Element
xmlAuthor p = atomNode "author" (xmlPerson p)
xmlContributor :: Person -> XML.Element
xmlContributor c = atomNode "contributor" (xmlPerson c)
xmlPerson :: Person -> [XML.Content]
xmlPerson p = map Elem $
[ atomLeaf "name" (personName p) ]
++ mb (atomLeaf "uri") (personURI p)
++ mb (atomLeaf "email") (personEmail p)
++ personOther p
xmlInReplyTo :: InReplyTo -> XML.Element
xmlInReplyTo irt =
(atomThreadNode "in-reply-to" (replyToContent irt))
{ elAttribs =
mb (atomThreadAttr "ref") (Just $ replyToRef irt)
++ mb (atomThreadAttr "href") (replyToHRef irt)
++ mb (atomThreadAttr "type") (replyToType irt)
++ mb (atomThreadAttr "source") (replyToSource irt)
++ replyToOther irt
}
xmlInReplyTotal :: InReplyTotal -> XML.Element
xmlInReplyTotal irt =
(atomThreadLeaf "total" (show $ replyToTotal irt))
{ elAttribs = replyToTotalOther irt }
xmlId :: String -> XML.Element
xmlId i = atomLeaf "id" i
xmlIcon :: URI -> XML.Element
xmlIcon i = atomLeaf "icon" i
xmlLogo :: URI -> XML.Element
xmlLogo l = atomLeaf "logo" l
xmlUpdated :: Date -> XML.Element
xmlUpdated u = atomLeaf "updated" u
xmlPublished :: Date -> XML.Element
xmlPublished p = atomLeaf "published" p
xmlRights :: TextContent -> XML.Element
xmlRights r = xmlTextContent "rights" r
xmlTitle :: TextContent -> XML.Element
xmlTitle r = xmlTextContent "title" r
xmlSubtitle :: TextContent -> XML.Element
xmlSubtitle s = xmlTextContent "subtitle" s
xmlSummary :: TextContent -> XML.Element
xmlSummary s = xmlTextContent "summary" s
xmlTextContent :: String -> TextContent -> XML.Element
xmlTextContent tg t =
case t of
TextString s -> (atomLeaf tg s) { elAttribs = [atomAttr "type" "text"] }
HTMLString s -> (atomLeaf tg s) { elAttribs = [atomAttr "type" "html"] }
XHTMLString e -> (atomNode tg [XML.Elem e])
{ elAttribs = [atomAttr "type" "xhtml"] }
mb :: (a -> b) -> Maybe a -> [b]
mb _ Nothing = []
mb f (Just x) = [f x]