-------------------------------------------------------------------- -- | -- 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 where import Text.XML.Light as XML import Text.Atom.Feed atom_prefix :: Maybe String atom_prefix = Nothing -- Just "atom" 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 -- XXX: is this ok? , 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 -- XXX: is this ok? , 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]