-------------------------------------------------------------------- -- | -- Module : Text.Atom.Feed.Export -- Copyright : (c) Galois, Inc. 2008, -- (c) Sigbjorn Finne 2009- -- License : BSD3 -- -- Maintainer: Sigbjorn Finne -- Stability : provisional -- Portability:: portable -- Description: Convert from Atom to XML -- -- Convert from Atom to XML -- -------------------------------------------------------------------- module Text.Atom.Feed.Export ( atom_prefix , atom_thr_prefix , atomNS , atomThreadNS , xmlns_atom , xmlns_atom_thread , atomName , atomAttr , atomNode , atomLeaf , atomThreadName , atomThreadAttr , atomThreadNode , atomThreadLeaf , xmlFeed , textFeed , xmlEntry , xmlContent , xmlCategory , xmlLink , xmlSource , xmlGenerator , xmlAuthor , xmlContributor , xmlPerson , xmlInReplyTo , xmlInReplyTotal , xmlId , xmlIcon , xmlLogo , xmlUpdated , xmlPublished , xmlRights , xmlTitle , xmlSubtitle , xmlSummary , xmlTextContent , mb ) where import Prelude.Compat import Data.Text (Text, pack) import Data.XML.Types as XML import Text.Atom.Feed import qualified Data.Text.Lazy as TL import qualified Data.Text.Util as U atom_prefix :: Maybe Text atom_prefix = Nothing -- Just "atom" atom_thr_prefix :: Maybe Text atom_thr_prefix = Just "thr" atomNS :: Text atomNS = "http://www.w3.org/2005/Atom" atomThreadNS :: Text atomThreadNS = "http://purl.org/syndication/thread/1.0" blank_element :: Name -> [Node] -> XML.Element blank_element name = XML.Element name [] xmlns_atom :: Attr xmlns_atom = (qn, [ContentText atomNS]) where qn = case atom_prefix of Nothing -> Name {nameLocalName = "xmlns", nameNamespace = Nothing, namePrefix = Nothing} Just s -> Name { nameLocalName = s , nameNamespace = Nothing -- XXX: is this ok? , namePrefix = Just "xmlns" } xmlns_atom_thread :: Attr xmlns_atom_thread = (qn, [ContentText atomThreadNS]) where qn = case atom_prefix of Nothing -> Name {nameLocalName = "xmlns", nameNamespace = Nothing, namePrefix = Nothing} Just s -> Name { nameLocalName = s , nameNamespace = Nothing -- XXX: is this ok? , namePrefix = Just "xmlns" } atomName :: Text -> Name atomName nc = Name {nameLocalName = nc, nameNamespace = Just atomNS, namePrefix = atom_prefix} atomAttr :: Text -> Text -> Attr atomAttr x y = (atomName x, [ContentText y]) atomNode :: Text -> [Node] -> XML.Element atomNode x = blank_element (atomName x) atomLeaf :: Text -> Text -> XML.Element atomLeaf tag txt = blank_element (atomName tag) [NodeContent $ ContentText txt] atomThreadName :: Text -> Name atomThreadName nc = Name {nameLocalName = nc, nameNamespace = Just atomThreadNS, namePrefix = atom_thr_prefix} atomThreadAttr :: Text -> Text -> Attr atomThreadAttr x y = (atomThreadName x, [ContentText y]) atomThreadNode :: Text -> [Node] -> XML.Element atomThreadNode x = blank_element (atomThreadName x) atomThreadLeaf :: Text -> Text -> XML.Element atomThreadLeaf tag txt = blank_element (atomThreadName tag) [NodeContent $ ContentText txt] -------------------------------------------------------------------------------- xmlFeed :: Feed -> XML.Element xmlFeed f = (atomNode "feed" $ map NodeElement $ [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) {elementAttributes = [xmlns_atom]} textFeed :: Feed -> Maybe TL.Text textFeed = U.renderFeed xmlFeed xmlEntry :: Entry -> XML.Element xmlEntry e = (atomNode "entry" $ map NodeElement $ [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) {elementAttributes = entryAttrs e} xmlContent :: EntryContent -> XML.Element xmlContent cont = case cont of TextContent t -> (atomLeaf "content" t) {elementAttributes = [atomAttr "type" "text"]} HTMLContent x -> (atomNode "content" [NodeElement x]) {elementAttributes = [atomAttr "type" "html"]} XHTMLContent x -> (atomNode "content" [NodeElement x]) {elementAttributes = [atomAttr "type" "xhtml"]} MixedContent mbTy cs -> (atomNode "content" cs) {elementAttributes = mb (atomAttr "type") mbTy} ExternalContent mbTy src -> (atomNode "content" []) {elementAttributes = atomAttr "src" src : mb (atomAttr "type") mbTy} xmlCategory :: Category -> XML.Element xmlCategory c = (atomNode "category" (map NodeElement (catOther c))) { elementAttributes = [atomAttr "term" (catTerm c)] ++ mb (atomAttr "scheme") (catScheme c) ++ mb (atomAttr "label") (catLabel c) } xmlLink :: Link -> XML.Element xmlLink l = (atomNode "link" (map NodeElement (linkOther l))) { elementAttributes = [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 NodeElement $ 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)) {elementAttributes = 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.Node] xmlPerson p = map NodeElement $ [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)) { elementAttributes = 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" (pack $ show $ replyToTotal irt)) {elementAttributes = replyToTotalOther irt} xmlId :: Text -> XML.Element xmlId = atomLeaf "id" xmlIcon :: URI -> XML.Element xmlIcon = atomLeaf "icon" xmlLogo :: URI -> XML.Element xmlLogo = atomLeaf "logo" xmlUpdated :: Date -> XML.Element xmlUpdated = atomLeaf "updated" xmlPublished :: Date -> XML.Element xmlPublished = atomLeaf "published" xmlRights :: TextContent -> XML.Element xmlRights = xmlTextContent "rights" xmlTitle :: TextContent -> XML.Element xmlTitle = xmlTextContent "title" xmlSubtitle :: TextContent -> XML.Element xmlSubtitle = xmlTextContent "subtitle" xmlSummary :: TextContent -> XML.Element xmlSummary = xmlTextContent "summary" xmlTextContent :: Text -> TextContent -> XML.Element xmlTextContent tg t = case t of TextString s -> (atomLeaf tg s) {elementAttributes = [atomAttr "type" "text"]} HTMLString s -> (atomLeaf tg s) {elementAttributes = [atomAttr "type" "html"]} XHTMLString e -> (atomNode tg [XML.NodeElement e]) {elementAttributes = [atomAttr "type" "xhtml"]} -------------------------------------------------------------------------------- mb :: (a -> b) -> Maybe a -> [b] mb _ Nothing = [] mb f (Just x) = [f x]