diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,12 @@ +Version 0.3.9: + + * tidy up compilation with ghc-7.6(.3), bumped version + (but no functional changes.) + +Version 0.3.8: + + * cabal build fixes. + Version 0.3.7: * parsing: made be optional. diff --git a/Text/Atom/Feed/Export.hs b/Text/Atom/Feed/Export.hs --- a/Text/Atom/Feed/Export.hs +++ b/Text/Atom/Feed/Export.hs @@ -16,9 +16,6 @@ import Text.XML.Light as XML import Text.Atom.Feed -import Data.List -import Data.Maybe - atom_prefix :: Maybe String atom_prefix = Nothing -- Just "atom" @@ -178,7 +175,7 @@ } xmlSource :: Source -> Element -xmlSource s = atomNode "source" +xmlSource s = atomNode "source" $ map Elem $ sourceOther s ++ map xmlAuthor (sourceAuthors s) @@ -215,9 +212,9 @@ ++ personOther p xmlInReplyTo :: InReplyTo -> XML.Element -xmlInReplyTo irt = +xmlInReplyTo irt = (atomThreadNode "in-reply-to" (replyToContent irt)) - { elAttribs = + { elAttribs = mb (atomThreadAttr "ref") (Just $ replyToRef irt) ++ mb (atomThreadAttr "href") (replyToHRef irt) ++ mb (atomThreadAttr "type") (replyToType irt) @@ -226,7 +223,7 @@ } xmlInReplyTotal :: InReplyTotal -> XML.Element -xmlInReplyTotal irt = +xmlInReplyTotal irt = (atomThreadLeaf "total" (show $ replyToTotal irt)) { elAttribs = replyToTotalOther irt } @@ -269,4 +266,3 @@ mb :: (a -> b) -> Maybe a -> [b] mb _ Nothing = [] mb f (Just x) = [f x] - diff --git a/Text/Atom/Feed/Link.hs b/Text/Atom/Feed/Link.hs --- a/Text/Atom/Feed/Link.hs +++ b/Text/Atom/Feed/Link.hs @@ -1,80 +1,80 @@ --------------------------------------------------------------------- --- | --- Module : Text.Atom.Feed.Link --- Copyright : (c) Galois, Inc. 2008 --- License : BSD3 --- --- Maintainer: Sigbjorn Finne <sof@galois.com> --- Stability : provisional --- Portability: --- --------------------------------------------------------------------- - -module Text.Atom.Feed.Link - ( LinkRelation(..) - , showLinkRelation - , showLinkAttr - ) where - --- | Atom feeds uses typed IRI links to represent --- information \/ metadata that is of interest to the --- consumers (software, in the main) of feeds. For instance, --- the edit link relation attached to an atom:entry element --- points to the IRI to use to update\/edit it. --- --- The Atom standard encourages that such typed links to --- be registered with IANA if they have wider applicability, --- and the 'LinkRelation' data type encodes the currently --- registered link types (derived from: --- http:\/\/www.iana.org\/assignments\/link-relations.html --- on 2007-10-28] --- -data LinkRelation -- relevant RFC: - = LinkAlternate -- http://www.rfc-editor.org/rfc/rfc4287.txt - | LinkCurrent -- http://www.rfc-editor.org/rfc/rfc5005.txt - | LinkEnclosure -- http://www.rfc-editor.org/rfc/rfc4287.txt - | LinkEdit -- http://www.rfc-editor.org/rfc/rfc5023.txt - | LinkEditMedia -- http://www.rfc-editor.org/rfc/rfc5023.txt - | LinkFirst -- http://www.iana.org/assignments/link-relations/first - | LinkLast -- http://www.iana.org/assignments/link-relations/last - | LinkLicense -- http://www.rfc-editor.org/rfc/rfc4946.txt - | LinkNext -- http://www.rfc-editor.org/rfc/rfc5005.txt - | LinkNextArchive -- http://www.rfc-editor.org/rfc/rfc5005.txt - | LinkPayment -- http://www.iana.org/assignments/link-relations/payment - | LinkPrevArchive -- http://www.rfc-editor.org/rfc/rfc5005.txt - | LinkPrevious -- http://www.rfc-editor.org/rfc/rfc5005.txt - | LinkRelated -- http://www.rfc-editor.org/rfc/rfc4287.txt - | LinkReplies -- http://www.rfc-editor.org/rfc/rfc4685.txt - | LinkSelf -- http://www.rfc-editor.org/rfc/rfc4287.txt - | LinkVia -- http://www.rfc-editor.org/rfc/rfc4287.txt - | LinkOther String - deriving (Eq, Show) - -showLinkRelation :: LinkRelation -> String -showLinkRelation lr = - case lr of - LinkAlternate -> "alternate" - LinkCurrent -> "current" - LinkEnclosure -> "enclosure" - LinkEdit -> "edit" - LinkEditMedia -> "edit-media" - LinkFirst -> "first" - LinkLast -> "last" - LinkLicense -> "license" - LinkNext -> "next" - LinkNextArchive -> "next-archive" - LinkPayment -> "payment" - LinkPrevArchive -> "prev-archive" - LinkPrevious -> "previous" - LinkRelated -> "related" - LinkReplies -> "replies" - LinkSelf -> "self" - LinkVia -> "via" - LinkOther s -> s - -showLinkAttr :: LinkRelation -> String{-URI-} -> String -showLinkAttr lr s = showLinkRelation lr ++ '=':'"':concatMap escQ s ++ "\"" - where - escQ '"' = "&dquot;" - escQ x = [x] - +-------------------------------------------------------------------- +-- | +-- Module : Text.Atom.Feed.Link +-- Copyright : (c) Galois, Inc. 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@galois.com> +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +module Text.Atom.Feed.Link + ( LinkRelation(..) + , showLinkRelation + , showLinkAttr + ) where + +-- | Atom feeds uses typed IRI links to represent +-- information \/ metadata that is of interest to the +-- consumers (software, in the main) of feeds. For instance, +-- the edit link relation attached to an atom:entry element +-- points to the IRI to use to update\/edit it. +-- +-- The Atom standard encourages that such typed links to +-- be registered with IANA if they have wider applicability, +-- and the 'LinkRelation' data type encodes the currently +-- registered link types (derived from: +-- http:\/\/www.iana.org\/assignments\/link-relations.html +-- on 2007-10-28] +-- +data LinkRelation -- relevant RFC: + = LinkAlternate -- http://www.rfc-editor.org/rfc/rfc4287.txt + | LinkCurrent -- http://www.rfc-editor.org/rfc/rfc5005.txt + | LinkEnclosure -- http://www.rfc-editor.org/rfc/rfc4287.txt + | LinkEdit -- http://www.rfc-editor.org/rfc/rfc5023.txt + | LinkEditMedia -- http://www.rfc-editor.org/rfc/rfc5023.txt + | LinkFirst -- http://www.iana.org/assignments/link-relations/first + | LinkLast -- http://www.iana.org/assignments/link-relations/last + | LinkLicense -- http://www.rfc-editor.org/rfc/rfc4946.txt + | LinkNext -- http://www.rfc-editor.org/rfc/rfc5005.txt + | LinkNextArchive -- http://www.rfc-editor.org/rfc/rfc5005.txt + | LinkPayment -- http://www.iana.org/assignments/link-relations/payment + | LinkPrevArchive -- http://www.rfc-editor.org/rfc/rfc5005.txt + | LinkPrevious -- http://www.rfc-editor.org/rfc/rfc5005.txt + | LinkRelated -- http://www.rfc-editor.org/rfc/rfc4287.txt + | LinkReplies -- http://www.rfc-editor.org/rfc/rfc4685.txt + | LinkSelf -- http://www.rfc-editor.org/rfc/rfc4287.txt + | LinkVia -- http://www.rfc-editor.org/rfc/rfc4287.txt + | LinkOther String + deriving (Eq, Show) + +showLinkRelation :: LinkRelation -> String +showLinkRelation lr = + case lr of + LinkAlternate -> "alternate" + LinkCurrent -> "current" + LinkEnclosure -> "enclosure" + LinkEdit -> "edit" + LinkEditMedia -> "edit-media" + LinkFirst -> "first" + LinkLast -> "last" + LinkLicense -> "license" + LinkNext -> "next" + LinkNextArchive -> "next-archive" + LinkPayment -> "payment" + LinkPrevArchive -> "prev-archive" + LinkPrevious -> "previous" + LinkRelated -> "related" + LinkReplies -> "replies" + LinkSelf -> "self" + LinkVia -> "via" + LinkOther s -> s + +showLinkAttr :: LinkRelation -> String{-URI-} -> String +showLinkAttr lr s = showLinkRelation lr ++ '=':'"':concatMap escQ s ++ "\"" + where + escQ '"' = "&dquot;" + escQ x = [x] + diff --git a/Text/Atom/Pub/Export.hs b/Text/Atom/Pub/Export.hs --- a/Text/Atom/Pub/Export.hs +++ b/Text/Atom/Pub/Export.hs @@ -13,13 +13,11 @@ import Text.XML.Light import Text.Atom.Pub -import Text.Atom.Feed.Export +import Text.Atom.Feed.Export ( mb, xmlCategory, xmlTitle , xmlns_atom ) -import Data.Maybe - showServiceDoc :: Service -> String showServiceDoc s = showElement (xmlService s) @@ -47,15 +45,15 @@ appName nc = (mkQName (Just "app") nc){qURI=Just appNS} xmlService :: Service -> Element -xmlService s = +xmlService s = mkElem (appName "service") [xmlns_app,xmlns_atom] (concat [ map xmlWorkspace (serviceWorkspaces s) , serviceOther s ]) xmlWorkspace :: Workspace -> Element -xmlWorkspace w = - mkElem (appName "workspace") +xmlWorkspace w = + mkElem (appName "workspace") [mkAttr "xml:lang" "en"] (concat [ [xmlTitle (workspaceTitle w)] , map xmlCollection (workspaceCols w) @@ -71,11 +69,11 @@ , map xmlCategories (collectionCats c) , collectionOther c ]) - + xmlCategories :: Categories -> Element -xmlCategories (CategoriesExternal u) = +xmlCategories (CategoriesExternal u) = mkElem (appName "categories") [mkAttr "href" u] [] -xmlCategories (Categories mbFixed mbScheme cs) = +xmlCategories (Categories mbFixed mbScheme cs) = mkElem (appName "categories") (concat [ mb (\ f -> mkAttr "fixed" (if f then "yes" else "no")) mbFixed , mb (mkAttr "scheme") mbScheme diff --git a/Text/Feed/Constructor.hs b/Text/Feed/Constructor.hs --- a/Text/Feed/Constructor.hs +++ b/Text/Feed/Constructor.hs @@ -1,725 +1,725 @@ --------------------------------------------------------------------- --- | --- Module : Text.Feed.Constructor --- Copyright : (c) Galois, Inc. 2008 --- License : BSD3 --- --- Maintainer: Sigbjorn Finne <sof@galois.com> --- Stability : provisional --- Description: Module for an abstraction layer between different kinds of feeds. --- --------------------------------------------------------------------- - -module Text.Feed.Constructor - ( FeedKind(..) - , newFeed -- :: FeedKind -> Feed - , feedFromRSS -- :: RSS -> Feed - , feedFromAtom -- :: Atom.Feed -> Feed - , feedFromRDF -- :: RSS1.Feed -> Feed - , feedFromXML -- :: Element -> Feed - , getFeedKind -- :: Feed -> FeedKind - - , FeedSetter -- type _ a = a -> Feed -> Feed - , addItem -- :: FeedSetter Item - - , withFeedTitle -- :: FeedSetter String - , withFeedHome -- :: FeedSetter URLString - , withFeedHTML -- :: FeedSetter URLString - , withFeedDescription -- :: FeedSetter String - , withFeedPubDate -- :: FeedSetter DateString - , withFeedLastUpdate -- :: FeedSetter DateString - , withFeedDate -- :: FeedSetter DateString - , withFeedLogoLink -- :: FeedSetter URLString - , withFeedLanguage -- :: FeedSetter String - , withFeedCategories -- :: FeedSetter [(String,Maybe String)] - , withFeedGenerator -- :: FeedSetter String - , withFeedItems -- :: FeedSetter [Item] - - , newItem -- :: FeedKind -> Item - , getItemKind -- :: Item -> FeedKind - , atomEntryToItem -- :: Atom.Entry -> Item - , rssItemToItem -- :: RSS.Item -> Item - , rdfItemToItem -- :: RSS1.Item -> Item - - , ItemSetter -- type _ a = a -> Item -> Item - , withItemTitle -- :: ItemSetter String - , withItemLink -- :: ItemSetter URLString - , withItemPubDate -- :: ItemSetter DateString - , withItemDate -- :: ItemSetter DateString - , withItemAuthor -- :: ItemSetter String - , withItemCommentLink -- :: ItemSetter String - , withItemEnclosure -- :: String -> Maybe String -> ItemSetter Integer - , withItemFeedLink -- :: String -> ItemSetter String - , withItemId -- :: Bool -> ItemSetter String - , withItemCategories -- :: ItemSetter [(String, Maybe String)] - , withItemDescription -- :: ItemSetter String - , withItemRights -- :: ItemSetter String - ) where - -import Text.Feed.Types as Feed.Types - -import Text.Atom.Feed as Atom -import Text.RSS.Syntax as RSS -import Text.RSS1.Syntax as RSS1 -import Text.DublinCore.Types -import Text.XML.Light as XML hiding ( filterChildren ) - -import Data.Maybe ( fromMaybe, mapMaybe ) -import Data.Char ( toLower ) - --- ToDo: --- --- - complete set of constructors over feeds --- - provide a unified treatment of date string reps. --- (i.e., I know they differ across formats, but ignorant what --- the constraints are at the moment.) - - --- | Construct an empty feed document, intending to output it in --- the 'fk' feed format. -newFeed :: FeedKind -> Feed.Types.Feed -newFeed fk = - case fk of - AtomKind -> AtomFeed (Atom.nullFeed "feed-id-not-filled-in" - (TextString "dummy-title") - "dummy-and-bogus-update-date") - RSSKind mbV -> - let def = (RSS.nullRSS "dummy-title" "default-channel-url") in - RSSFeed $ fromMaybe def $ fmap (\ v -> def{RSS.rssVersion=v}) mbV - RDFKind mbV -> - let def = (RSS1.nullFeed "default-channel-url" "dummy-title") in - RSS1Feed $ fromMaybe def $ fmap (\ v -> def{RSS1.feedVersion=v}) mbV - - -feedFromRSS :: RSS.RSS -> Feed.Types.Feed -feedFromRSS r = RSSFeed r - -feedFromAtom :: Atom.Feed -> Feed.Types.Feed -feedFromAtom f = AtomFeed f - -feedFromRDF :: RSS1.Feed -> Feed.Types.Feed -feedFromRDF f = RSS1Feed f - -feedFromXML :: XML.Element -> Feed.Types.Feed -feedFromXML f = XMLFeed f - -getFeedKind :: Feed.Types.Feed -> FeedKind -getFeedKind f = - case f of - Feed.Types.AtomFeed{} -> AtomKind - Feed.Types.RSSFeed r -> RSSKind (case RSS.rssVersion r of { "2.0" -> Nothing; v -> Just v}) - Feed.Types.RSS1Feed r -> RDFKind (case RSS1.feedVersion r of { "1.0" -> Nothing; v -> Just v}) - Feed.Types.XMLFeed{} -> RSSKind (Just "2.0") -- for now, just a hunch.. - -addItem :: Feed.Types.Item -> Feed.Types.Feed -> Feed.Types.Feed -addItem it f = - case (it,f) of - (Feed.Types.AtomItem e, Feed.Types.AtomFeed fe) -> - Feed.Types.AtomFeed fe{Atom.feedEntries=e:Atom.feedEntries fe} - (Feed.Types.RSSItem e, Feed.Types.RSSFeed r) -> - Feed.Types.RSSFeed r{RSS.rssChannel=(RSS.rssChannel r){RSS.rssItems=e:RSS.rssItems (RSS.rssChannel r)}} - (Feed.Types.RSS1Item e, Feed.Types.RSS1Feed r) -> - -- note: do not update the channel item URIs at this point; - -- will delay doing so until serialization. - Feed.Types.RSS1Feed r{RSS1.feedItems=e:RSS1.feedItems r} - _ -> error "addItem: currently unable to automatically convert items from one feed type to another" - -withFeedItems :: FeedSetter [Feed.Types.Item] -withFeedItems is fe = - foldr addItem - (case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed - f{Atom.feedEntries=[]} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){rssItems=[]}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed - f{feedItems=[]}) - is - -newItem :: FeedKind -> Feed.Types.Item -newItem fk = - case fk of - AtomKind -> Feed.Types.AtomItem $ - Atom.nullEntry "entry-id-not-filled-in" - (TextString "dummy-entry-title") - "dummy-and-bogus-entry-update-date" - RSSKind{} -> Feed.Types.RSSItem $ - RSS.nullItem "dummy-rss-item-title" - RDFKind{} -> Feed.Types.RSS1Item $ - RSS1.nullItem "dummy-item-uri" - "dummy-item-title" - "dummy-item-link" - -getItemKind :: Feed.Types.Item -> FeedKind -getItemKind f = - case f of - Feed.Types.AtomItem{} -> AtomKind - Feed.Types.RSSItem{} -> RSSKind (Just "2.0") -- good guess.. - Feed.Types.RSS1Item{} -> RDFKind (Just "1.0") - Feed.Types.XMLItem{} -> RSSKind (Just "2.0") - -type FeedSetter a = a -> Feed.Types.Feed -> Feed.Types.Feed - -withFeedTitle :: FeedSetter String -withFeedTitle tit fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedTitle=TextString tit} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssTitle=tit}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedChannel=(feedChannel f){channelTitle=tit}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "title") - then Just (unode "title" tit) - else Nothing) e) - else Nothing) f - -withFeedHome :: FeedSetter URLString -withFeedHome url fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedLinks=newSelf:Atom.feedLinks f} - -- ToDo: fix, the <link> element is for the HTML home of the channel, not the - -- location of the feed itself. Struggling to find if there is a common way - -- to represent this outside of RSS 2.0 standard elements.. - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssLink=url}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedChannel=(feedChannel f){channelURI=url}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "link") - then Just (unode "link" url) - else Nothing) e) - else Nothing) f - where - newSelf = (nullLink url){ linkRel=Just (Left "self") - , linkType=Just "application/atom+xml" - } - --- | 'withFeedHTML' sets the URL where an HTML version of the --- feed is published. -withFeedHTML :: FeedSetter URLString -withFeedHTML url fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedLinks=newAlt:Atom.feedLinks f} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssLink=url}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedChannel=(feedChannel f){channelLink=url}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "link") - then Just (unode "link" url) - else Nothing) e) - else Nothing) f - where - newAlt = (nullLink url){ linkRel=Just (Left "alternate") - , linkType=Just "text/html" - } - --- | 'withFeedHTML' sets the URL where an HTML version of the --- feed is published. -withFeedDescription :: FeedSetter String -withFeedDescription desc fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed - f{feedSubtitle=Just (TextString desc)} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){rssDescription=desc}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed - f{feedChannel=(feedChannel f){channelDesc=desc}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "description") - then Just (unode "description" desc) - else Nothing) e) - else Nothing) f - -withFeedPubDate :: FeedSetter String -withFeedPubDate dateStr fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed - f{feedUpdated=dateStr} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){rssPubDate=Just dateStr}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ - case break isDate $ RSS1.channelDC (RSS1.feedChannel f) of - (as,(dci:bs)) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC=as++dci{dcText=dateStr}:bs}} - (_,[]) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC= - DCItem{dcElt=DC_Date,dcText=dateStr}: - RSS1.channelDC (RSS1.feedChannel f)}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "pubDate") - then Just (unode "pubDate" dateStr) - else Nothing) e) - else Nothing) f - where - isDate dc = dcElt dc == DC_Date - -withFeedLastUpdate :: FeedSetter DateString -withFeedLastUpdate dateStr fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed - f{feedUpdated=dateStr} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){rssLastUpdate=Just dateStr}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ - case break isDate $ RSS1.channelDC (RSS1.feedChannel f) of - (as,(dci:bs)) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC=as++dci{dcText=dateStr}:bs}} - (_,[]) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC= - DCItem{dcElt=DC_Date,dcText=dateStr}: - RSS1.channelDC (RSS1.feedChannel f)}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "lastUpdate") - then Just (unode "lastUpdate" dateStr) - else Nothing) e) - else Nothing) f - where - isDate dc = dcElt dc == DC_Date - - --- | 'withFeedDate dt' is the composition of 'withFeedPubDate' --- and 'withFeedLastUpdate', setting both publication date and --- last update date to 'dt'. Notice that RSS2.0 is the only format --- supporting both pub and last-update. -withFeedDate :: FeedSetter DateString -withFeedDate dt f = withFeedPubDate dt(withFeedLastUpdate dt f) - - -withFeedLogoLink :: URLString -> FeedSetter URLString -withFeedLogoLink imgURL lnk fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed - f{ feedLogo = Just imgURL - , feedLinks = newSelf:Atom.feedLinks f - } - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{ rssChannel=(rssChannel f) - {rssImage=Just $ - RSS.nullImage imgURL (rssTitle (rssChannel f)) lnk}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ - f{ feedImage = Just $ - RSS1.nullImage imgURL (RSS1.channelTitle (RSS1.feedChannel f)) lnk - , feedChannel = - (feedChannel f){channelImageURI=Just imgURL} - } - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "image") - then Just (unode "image" [ unode "url" imgURL - , unode "title" title - , unode "link" lnk - ]) - else Nothing) e) - else Nothing) f - where - title = - case fmap (findChild (unqual "title")) - (findChild (unqual "channel") f) of - Just (Just e1) -> strContent e1 - _ -> "feed_title" -- shouldn't happen.. - - where - newSelf = (nullLink lnk){ linkRel=Just (Left "self") - , linkType=Just "application/atom+xml" - } - - -withFeedLanguage :: FeedSetter String -withFeedLanguage lang fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed $ - f{Atom.feedAttrs=(XML.Attr (unqual "lang"){qPrefix=Just "xml"} lang):Atom.feedAttrs f} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){rssLanguage=Just lang}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ - case break isLang $ RSS1.channelDC (RSS1.feedChannel f) of - (as,(dci:bs)) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC=as++dci{dcText=lang}:bs}} - (_,[]) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC= - DCItem{dcElt=DC_Language,dcText=lang}: - RSS1.channelDC (RSS1.feedChannel f)}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "language") - then Just (unode "language" lang) - else Nothing) e) - else Nothing) f - where - isLang dc = dcElt dc == DC_Language - -withFeedCategories :: FeedSetter [(String,Maybe String)] -withFeedCategories cats fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed - f{ Atom.feedCategories = - map ( \ (t,mb) -> (Atom.newCategory t){Atom.catScheme=mb}) - cats ++ feedCategories f} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){ - RSS.rssCategories= - map (\ (t,mb) -> (RSS.newCategory t){RSS.rssCategoryDomain=mb}) - cats ++ RSS.rssCategories (rssChannel f)}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed - f{feedChannel=(feedChannel f){ - RSS1.channelDC= - map (\ (t,_) -> DCItem{dcElt=DC_Subject,dcText=t}) - cats ++ RSS1.channelDC (feedChannel f)}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just ( - foldr - (\ (t,mb) acc -> - addChild (unode "category" - (fromMaybe (\x -> [x]) - (fmap (\v -> (\ x -> [Attr (unqual "domain") v,x])) mb) $ - (Attr (unqual "term") t)) - ) acc) - e - cats) - else Nothing) f - - -withFeedGenerator :: FeedSetter (String,Maybe URLString) -withFeedGenerator (gen,mbURI) fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed $ - f{Atom.feedGenerator=Just ((Atom.nullGenerator gen){Atom.genURI=mbURI})} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){rssGenerator=Just gen}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ - case break isSource $ RSS1.channelDC (RSS1.feedChannel f) of - (as,(dci:bs)) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC=as++dci{dcText=gen}:bs}} - (_,[]) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC= - DCItem{dcElt=DC_Source,dcText=gen}: - RSS1.channelDC (RSS1.feedChannel f)}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "generator") - then Just (unode "generator" gen) - else Nothing) e) - else Nothing) f - where - isSource dc = dcElt dc == DC_Source - - - --- Item constructors (all the way to the end): - -atomEntryToItem :: Atom.Entry -> Feed.Types.Item -atomEntryToItem e = Feed.Types.AtomItem e - -rssItemToItem :: RSS.RSSItem -> Feed.Types.Item -rssItemToItem i = Feed.Types.RSSItem i - -rdfItemToItem :: RSS1.Item -> Feed.Types.Item -rdfItemToItem i = Feed.Types.RSS1Item i - -type ItemSetter a = a -> Feed.Types.Item -> Feed.Types.Item - --- | 'withItemPubDate dt' associates the creation\/ publication date 'dt' --- with a feed item. -withItemPubDate :: ItemSetter DateString -withItemPubDate dt fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryUpdated=dt} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemPubDate=Just dt} - Feed.Types.RSS1Item i -> - case break isDate $ RSS1.itemDC i of - (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=dt}:bs} - (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Date,dcText=dt}:RSS1.itemDC i} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "pubDate" dt) $ - filterChildren (\ e -> elName e /= unqual "pubDate") - i - where - isDate dc = dcElt dc == DC_Date - --- | 'withItemDate' is a synonym for 'withItemPubDate'. -withItemDate :: ItemSetter DateString -withItemDate dt fi = withItemPubDate dt fi - --- | 'withItemTitle myTitle' associates a new title, 'myTitle', --- with a feed item. -withItemTitle :: ItemSetter String -withItemTitle tit fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryTitle=TextString tit} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemTitle=Just tit} - Feed.Types.RSS1Item i -> - Feed.Types.RSS1Item i{RSS1.itemTitle=tit} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "title" tit) $ - filterChildren (\ e -> elName e /= unqual "title") - i - --- | 'withItemAuthor auStr' associates new author info --- with a feed item. -withItemAuthor :: ItemSetter String -withItemAuthor au fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryAuthors=[nullPerson{personName=au,personURI=Just au}]} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemAuthor=Just au} - Feed.Types.RSS1Item i -> - case break isAuthor $ RSS1.itemDC i of - (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=au}:bs} - (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Creator,dcText=au}:RSS1.itemDC i} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "author" au) $ - filterChildren (\ e -> elName e /= unqual "author") - i - where - isAuthor dc = dcElt dc == DC_Creator - --- | 'withItemFeedLink name myFeed' associates the parent feed URL 'myFeed' --- with a feed item. It is labelled as 'name'. -withItemFeedLink :: String -> ItemSetter String -withItemFeedLink tit url fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entrySource=Just Atom.nullSource{sourceId=Just url,sourceTitle=Just (TextString tit)}} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemSource=Just (RSS.nullSource url tit)} - Feed.Types.RSS1Item i -> - Feed.Types.RSS1Item i{RSS1.itemTitle=tit} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "source" (Attr (unqual "url") url,tit)) $ - filterChildren (\ e -> elName e /= unqual "source") - i - - - --- | 'withItemCommentLink url' sets the URL reference to the comment page to 'url'. -withItemCommentLink :: ItemSetter String -withItemCommentLink url fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryLinks=((nullLink url){linkRel=Just (Left "replies")}):Atom.entryLinks e} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemComments=Just url} - Feed.Types.RSS1Item i -> - case break isRel $ RSS1.itemDC i of - (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=url}:bs} - (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Relation,dcText=url}:RSS1.itemDC i} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "comments" url) $ - filterChildren (\ e -> elName e /= unqual "comments") - i - where - isRel dc = dcElt dc == DC_Relation - --- | 'withItemEnclosure url mbTy len' sets the URL reference to the comment page to 'url'. -withItemEnclosure :: String -> Maybe String -> ItemSetter Integer -withItemEnclosure url ty len fi = - case fi of - Feed.Types.AtomItem e -> Feed.Types.AtomItem - e{Atom.entryLinks=((nullLink url){linkRel=Just (Left "enclosure") - ,linkType=ty - ,linkLength=Just (show len) - }):Atom.entryLinks e} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemEnclosure=Just (nullEnclosure url len (fromMaybe "text/html" ty))} - Feed.Types.RSS1Item i -> Feed.Types.RSS1Item - i{RSS1.itemContent=nullContentInfo{ contentURI=Just url - , contentFormat=ty - }:RSS1.itemContent i} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild ((unode "enclosure" url) - {elAttribs= [ Attr (unqual "length") "0" - , Attr (unqual "type") (fromMaybe "text/html" ty) - ]}) $ - filterChildren (\ e -> elName e /= unqual "enclosure") - i - - --- | 'withItemId isURL id' associates new unique identifier with a feed item. --- If 'isURL' is 'True', then the id is assumed to point to a valid web resource. -withItemId :: Bool -> ItemSetter String -withItemId isURL idS fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryId=idS} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemGuid=Just (nullGuid idS){rssGuidPermanentURL=Just isURL}} - Feed.Types.RSS1Item i -> - case break isId $ RSS1.itemDC i of - (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=idS}:bs} - (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Identifier,dcText=idS}:RSS1.itemDC i} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "guid" (Attr (unqual "isPermaLink") (showBool isURL),idS)) $ - filterChildren (\ e -> elName e /= unqual "guid") - i - where - showBool x = map toLower (show x) - isId dc = dcElt dc == DC_Identifier - --- | 'withItemDescription desc' associates a new descriptive string (aka summary) --- with a feed item. -withItemDescription :: ItemSetter String -withItemDescription desc fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entrySummary=Just (TextString desc)} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemDescription=Just desc} - Feed.Types.RSS1Item i -> - Feed.Types.RSS1Item i{RSS1.itemDesc=Just desc} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "description" desc) $ - filterChildren (\ e -> elName e /= unqual "description") - i - --- | 'withItemRights rightStr' associates the rights information 'rightStr' --- with a feed item. -withItemRights :: ItemSetter String -withItemRights desc fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryRights=Just (TextString desc)} - -- Note: per-item copyright information isn't supported by RSS2.0 (and earlier editions), - -- you can only attach this at the feed/channel level. So, there's not much we can do - -- except dropping the information on the floor here. (Rolling our own attribute or - -- extension element is an option, but would prefer if someone else had started that - -- effort already. - Feed.Types.RSSItem{} -> fi - Feed.Types.RSS1Item i -> - case break ((==DC_Rights).dcElt) $ RSS1.itemDC i of - (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=desc}:bs} - (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Rights,dcText=desc}:RSS1.itemDC i} - -- Since we're so far assuming that a shallow XML rep. of an item - -- is of RSS2.0 ilk, pinning on the rights info is hard (see above.) - Feed.Types.XMLItem{} -> fi - --- | 'withItemTitle myLink' associates a new URL, 'myLink', --- with a feed item. -withItemLink :: ItemSetter URLString -withItemLink url fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryLinks=replaceAlternate url (Atom.entryLinks e)} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemLink=Just url} - Feed.Types.RSS1Item i -> - Feed.Types.RSS1Item i{RSS1.itemLink=url} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "link" url) $ - filterChildren (\ e -> elName e /= unqual "link") - i - where - replaceAlternate _ [] = [] - replaceAlternate x (lr:xs) - | toStr (Atom.linkRel lr) == "alternate" = lr{Atom.linkHref=x} : xs - | otherwise = lr : replaceAlternate x xs - - toStr Nothing = "" - toStr (Just (Left x)) = x - toStr (Just (Right x)) = x - -withItemCategories :: ItemSetter [(String,Maybe String)] -withItemCategories cats fi = - case fi of - Feed.Types.AtomItem e -> Feed.Types.AtomItem - e{ Atom.entryCategories = - map ( \ (t,mb) -> (Atom.newCategory t){Atom.catScheme=mb}) - cats ++ entryCategories e} - Feed.Types.RSSItem i -> Feed.Types.RSSItem - i{RSS.rssItemCategories= - map (\ (t,mb) -> (RSS.newCategory t){RSS.rssCategoryDomain=mb}) - cats ++ rssItemCategories i} - Feed.Types.RSS1Item i -> Feed.Types.RSS1Item - i{RSS1.itemDC= - map (\ (t,_) -> DCItem{dcElt=DC_Subject,dcText=t}) - cats ++ RSS1.itemDC i} - Feed.Types.XMLItem i -> Feed.Types.XMLItem $ - foldr (\ (t,mb) acc -> - addChild (unode "category" - (fromMaybe (\x -> [x]) - (fmap (\v -> (\ x -> [Attr (unqual "domain") v,x])) mb) $ - (Attr (unqual "term") t)) - ) acc) - i - cats - --- helpers.. - -filterChildren :: (XML.Element -> Bool) -> XML.Element -> XML.Element -filterChildren pre e = - case elContent e of - [] -> e - cs -> e { elContent = mapMaybe filterElt cs } - where - filterElt xe@(XML.Elem el) - | pre el = Just xe - | otherwise = Nothing - filterElt xe = Just xe - -addChild :: XML.Element -> XML.Element -> XML.Element -addChild a b = b { elContent = XML.Elem a : elContent b } - -mapMaybeChildren :: (XML.Element -> Maybe XML.Element) - -> XML.Element - -> XML.Element -mapMaybeChildren f e = - case elContent e of - [] -> e - cs -> e { elContent = map procElt cs } - where - procElt xe@(XML.Elem el) = - case f el of - Nothing -> xe - Just el1 -> XML.Elem el1 - procElt xe = xe +-------------------------------------------------------------------- +-- | +-- Module : Text.Feed.Constructor +-- Copyright : (c) Galois, Inc. 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@galois.com> +-- Stability : provisional +-- Description: Module for an abstraction layer between different kinds of feeds. +-- +-------------------------------------------------------------------- + +module Text.Feed.Constructor + ( FeedKind(..) + , newFeed -- :: FeedKind -> Feed + , feedFromRSS -- :: RSS -> Feed + , feedFromAtom -- :: Atom.Feed -> Feed + , feedFromRDF -- :: RSS1.Feed -> Feed + , feedFromXML -- :: Element -> Feed + , getFeedKind -- :: Feed -> FeedKind + + , FeedSetter -- type _ a = a -> Feed -> Feed + , addItem -- :: FeedSetter Item + + , withFeedTitle -- :: FeedSetter String + , withFeedHome -- :: FeedSetter URLString + , withFeedHTML -- :: FeedSetter URLString + , withFeedDescription -- :: FeedSetter String + , withFeedPubDate -- :: FeedSetter DateString + , withFeedLastUpdate -- :: FeedSetter DateString + , withFeedDate -- :: FeedSetter DateString + , withFeedLogoLink -- :: FeedSetter URLString + , withFeedLanguage -- :: FeedSetter String + , withFeedCategories -- :: FeedSetter [(String,Maybe String)] + , withFeedGenerator -- :: FeedSetter String + , withFeedItems -- :: FeedSetter [Item] + + , newItem -- :: FeedKind -> Item + , getItemKind -- :: Item -> FeedKind + , atomEntryToItem -- :: Atom.Entry -> Item + , rssItemToItem -- :: RSS.Item -> Item + , rdfItemToItem -- :: RSS1.Item -> Item + + , ItemSetter -- type _ a = a -> Item -> Item + , withItemTitle -- :: ItemSetter String + , withItemLink -- :: ItemSetter URLString + , withItemPubDate -- :: ItemSetter DateString + , withItemDate -- :: ItemSetter DateString + , withItemAuthor -- :: ItemSetter String + , withItemCommentLink -- :: ItemSetter String + , withItemEnclosure -- :: String -> Maybe String -> ItemSetter Integer + , withItemFeedLink -- :: String -> ItemSetter String + , withItemId -- :: Bool -> ItemSetter String + , withItemCategories -- :: ItemSetter [(String, Maybe String)] + , withItemDescription -- :: ItemSetter String + , withItemRights -- :: ItemSetter String + ) where + +import Text.Feed.Types as Feed.Types + +import Text.Atom.Feed as Atom +import Text.RSS.Syntax as RSS +import Text.RSS1.Syntax as RSS1 +import Text.DublinCore.Types +import Text.XML.Light as XML hiding ( filterChildren ) + +import Data.Maybe ( fromMaybe, mapMaybe ) +import Data.Char ( toLower ) + +-- ToDo: +-- +-- - complete set of constructors over feeds +-- - provide a unified treatment of date string reps. +-- (i.e., I know they differ across formats, but ignorant what +-- the constraints are at the moment.) + + +-- | Construct an empty feed document, intending to output it in +-- the 'fk' feed format. +newFeed :: FeedKind -> Feed.Types.Feed +newFeed fk = + case fk of + AtomKind -> AtomFeed (Atom.nullFeed "feed-id-not-filled-in" + (TextString "dummy-title") + "dummy-and-bogus-update-date") + RSSKind mbV -> + let def = (RSS.nullRSS "dummy-title" "default-channel-url") in + RSSFeed $ fromMaybe def $ fmap (\ v -> def{RSS.rssVersion=v}) mbV + RDFKind mbV -> + let def = (RSS1.nullFeed "default-channel-url" "dummy-title") in + RSS1Feed $ fromMaybe def $ fmap (\ v -> def{RSS1.feedVersion=v}) mbV + + +feedFromRSS :: RSS.RSS -> Feed.Types.Feed +feedFromRSS r = RSSFeed r + +feedFromAtom :: Atom.Feed -> Feed.Types.Feed +feedFromAtom f = AtomFeed f + +feedFromRDF :: RSS1.Feed -> Feed.Types.Feed +feedFromRDF f = RSS1Feed f + +feedFromXML :: XML.Element -> Feed.Types.Feed +feedFromXML f = XMLFeed f + +getFeedKind :: Feed.Types.Feed -> FeedKind +getFeedKind f = + case f of + Feed.Types.AtomFeed{} -> AtomKind + Feed.Types.RSSFeed r -> RSSKind (case RSS.rssVersion r of { "2.0" -> Nothing; v -> Just v}) + Feed.Types.RSS1Feed r -> RDFKind (case RSS1.feedVersion r of { "1.0" -> Nothing; v -> Just v}) + Feed.Types.XMLFeed{} -> RSSKind (Just "2.0") -- for now, just a hunch.. + +addItem :: Feed.Types.Item -> Feed.Types.Feed -> Feed.Types.Feed +addItem it f = + case (it,f) of + (Feed.Types.AtomItem e, Feed.Types.AtomFeed fe) -> + Feed.Types.AtomFeed fe{Atom.feedEntries=e:Atom.feedEntries fe} + (Feed.Types.RSSItem e, Feed.Types.RSSFeed r) -> + Feed.Types.RSSFeed r{RSS.rssChannel=(RSS.rssChannel r){RSS.rssItems=e:RSS.rssItems (RSS.rssChannel r)}} + (Feed.Types.RSS1Item e, Feed.Types.RSS1Feed r) -> + -- note: do not update the channel item URIs at this point; + -- will delay doing so until serialization. + Feed.Types.RSS1Feed r{RSS1.feedItems=e:RSS1.feedItems r} + _ -> error "addItem: currently unable to automatically convert items from one feed type to another" + +withFeedItems :: FeedSetter [Feed.Types.Item] +withFeedItems is fe = + foldr addItem + (case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed + f{Atom.feedEntries=[]} + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed + f{rssChannel=(rssChannel f){rssItems=[]}} + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed + f{feedItems=[]}) + is + +newItem :: FeedKind -> Feed.Types.Item +newItem fk = + case fk of + AtomKind -> Feed.Types.AtomItem $ + Atom.nullEntry "entry-id-not-filled-in" + (TextString "dummy-entry-title") + "dummy-and-bogus-entry-update-date" + RSSKind{} -> Feed.Types.RSSItem $ + RSS.nullItem "dummy-rss-item-title" + RDFKind{} -> Feed.Types.RSS1Item $ + RSS1.nullItem "dummy-item-uri" + "dummy-item-title" + "dummy-item-link" + +getItemKind :: Feed.Types.Item -> FeedKind +getItemKind f = + case f of + Feed.Types.AtomItem{} -> AtomKind + Feed.Types.RSSItem{} -> RSSKind (Just "2.0") -- good guess.. + Feed.Types.RSS1Item{} -> RDFKind (Just "1.0") + Feed.Types.XMLItem{} -> RSSKind (Just "2.0") + +type FeedSetter a = a -> Feed.Types.Feed -> Feed.Types.Feed + +withFeedTitle :: FeedSetter String +withFeedTitle tit fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedTitle=TextString tit} + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssTitle=tit}} + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedChannel=(feedChannel f){channelTitle=tit}} + Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ + mapMaybeChildren (\ e -> + if (elName e == unqual "channel") + then Just (mapMaybeChildren (\ e2 -> + if (elName e2 == unqual "title") + then Just (unode "title" tit) + else Nothing) e) + else Nothing) f + +withFeedHome :: FeedSetter URLString +withFeedHome url fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedLinks=newSelf:Atom.feedLinks f} + -- ToDo: fix, the <link> element is for the HTML home of the channel, not the + -- location of the feed itself. Struggling to find if there is a common way + -- to represent this outside of RSS 2.0 standard elements.. + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssLink=url}} + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedChannel=(feedChannel f){channelURI=url}} + Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ + mapMaybeChildren (\ e -> + if (elName e == unqual "channel") + then Just (mapMaybeChildren (\ e2 -> + if (elName e2 == unqual "link") + then Just (unode "link" url) + else Nothing) e) + else Nothing) f + where + newSelf = (nullLink url){ linkRel=Just (Left "self") + , linkType=Just "application/atom+xml" + } + +-- | 'withFeedHTML' sets the URL where an HTML version of the +-- feed is published. +withFeedHTML :: FeedSetter URLString +withFeedHTML url fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedLinks=newAlt:Atom.feedLinks f} + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssLink=url}} + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedChannel=(feedChannel f){channelLink=url}} + Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ + mapMaybeChildren (\ e -> + if (elName e == unqual "channel") + then Just (mapMaybeChildren (\ e2 -> + if (elName e2 == unqual "link") + then Just (unode "link" url) + else Nothing) e) + else Nothing) f + where + newAlt = (nullLink url){ linkRel=Just (Left "alternate") + , linkType=Just "text/html" + } + +-- | 'withFeedHTML' sets the URL where an HTML version of the +-- feed is published. +withFeedDescription :: FeedSetter String +withFeedDescription desc fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed + f{feedSubtitle=Just (TextString desc)} + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed + f{rssChannel=(rssChannel f){rssDescription=desc}} + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed + f{feedChannel=(feedChannel f){channelDesc=desc}} + Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ + mapMaybeChildren (\ e -> + if (elName e == unqual "channel") + then Just (mapMaybeChildren (\ e2 -> + if (elName e2 == unqual "description") + then Just (unode "description" desc) + else Nothing) e) + else Nothing) f + +withFeedPubDate :: FeedSetter String +withFeedPubDate dateStr fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed + f{feedUpdated=dateStr} + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed + f{rssChannel=(rssChannel f){rssPubDate=Just dateStr}} + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ + case break isDate $ RSS1.channelDC (RSS1.feedChannel f) of + (as,(dci:bs)) -> + f{RSS1.feedChannel= + (RSS1.feedChannel f) + {RSS1.channelDC=as++dci{dcText=dateStr}:bs}} + (_,[]) -> + f{RSS1.feedChannel= + (RSS1.feedChannel f) + {RSS1.channelDC= + DCItem{dcElt=DC_Date,dcText=dateStr}: + RSS1.channelDC (RSS1.feedChannel f)}} + Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ + mapMaybeChildren (\ e -> + if (elName e == unqual "channel") + then Just (mapMaybeChildren (\ e2 -> + if (elName e2 == unqual "pubDate") + then Just (unode "pubDate" dateStr) + else Nothing) e) + else Nothing) f + where + isDate dc = dcElt dc == DC_Date + +withFeedLastUpdate :: FeedSetter DateString +withFeedLastUpdate dateStr fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed + f{feedUpdated=dateStr} + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed + f{rssChannel=(rssChannel f){rssLastUpdate=Just dateStr}} + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ + case break isDate $ RSS1.channelDC (RSS1.feedChannel f) of + (as,(dci:bs)) -> + f{RSS1.feedChannel= + (RSS1.feedChannel f) + {RSS1.channelDC=as++dci{dcText=dateStr}:bs}} + (_,[]) -> + f{RSS1.feedChannel= + (RSS1.feedChannel f) + {RSS1.channelDC= + DCItem{dcElt=DC_Date,dcText=dateStr}: + RSS1.channelDC (RSS1.feedChannel f)}} + Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ + mapMaybeChildren (\ e -> + if (elName e == unqual "channel") + then Just (mapMaybeChildren (\ e2 -> + if (elName e2 == unqual "lastUpdate") + then Just (unode "lastUpdate" dateStr) + else Nothing) e) + else Nothing) f + where + isDate dc = dcElt dc == DC_Date + + +-- | 'withFeedDate dt' is the composition of 'withFeedPubDate' +-- and 'withFeedLastUpdate', setting both publication date and +-- last update date to 'dt'. Notice that RSS2.0 is the only format +-- supporting both pub and last-update. +withFeedDate :: FeedSetter DateString +withFeedDate dt f = withFeedPubDate dt(withFeedLastUpdate dt f) + + +withFeedLogoLink :: URLString -> FeedSetter URLString +withFeedLogoLink imgURL lnk fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed + f{ feedLogo = Just imgURL + , feedLinks = newSelf:Atom.feedLinks f + } + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed + f{ rssChannel=(rssChannel f) + {rssImage=Just $ + RSS.nullImage imgURL (rssTitle (rssChannel f)) lnk}} + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ + f{ feedImage = Just $ + RSS1.nullImage imgURL (RSS1.channelTitle (RSS1.feedChannel f)) lnk + , feedChannel = + (feedChannel f){channelImageURI=Just imgURL} + } + Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ + mapMaybeChildren (\ e -> + if (elName e == unqual "channel") + then Just (mapMaybeChildren (\ e2 -> + if (elName e2 == unqual "image") + then Just (unode "image" [ unode "url" imgURL + , unode "title" title + , unode "link" lnk + ]) + else Nothing) e) + else Nothing) f + where + title = + case fmap (findChild (unqual "title")) + (findChild (unqual "channel") f) of + Just (Just e1) -> strContent e1 + _ -> "feed_title" -- shouldn't happen.. + + where + newSelf = (nullLink lnk){ linkRel=Just (Left "self") + , linkType=Just "application/atom+xml" + } + + +withFeedLanguage :: FeedSetter String +withFeedLanguage lang fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed $ + f{Atom.feedAttrs=(XML.Attr (unqual "lang"){qPrefix=Just "xml"} lang):Atom.feedAttrs f} + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed + f{rssChannel=(rssChannel f){rssLanguage=Just lang}} + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ + case break isLang $ RSS1.channelDC (RSS1.feedChannel f) of + (as,(dci:bs)) -> + f{RSS1.feedChannel= + (RSS1.feedChannel f) + {RSS1.channelDC=as++dci{dcText=lang}:bs}} + (_,[]) -> + f{RSS1.feedChannel= + (RSS1.feedChannel f) + {RSS1.channelDC= + DCItem{dcElt=DC_Language,dcText=lang}: + RSS1.channelDC (RSS1.feedChannel f)}} + Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ + mapMaybeChildren (\ e -> + if (elName e == unqual "channel") + then Just (mapMaybeChildren (\ e2 -> + if (elName e2 == unqual "language") + then Just (unode "language" lang) + else Nothing) e) + else Nothing) f + where + isLang dc = dcElt dc == DC_Language + +withFeedCategories :: FeedSetter [(String,Maybe String)] +withFeedCategories cats fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed + f{ Atom.feedCategories = + map ( \ (t,mb) -> (Atom.newCategory t){Atom.catScheme=mb}) + cats ++ feedCategories f} + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed + f{rssChannel=(rssChannel f){ + RSS.rssCategories= + map (\ (t,mb) -> (RSS.newCategory t){RSS.rssCategoryDomain=mb}) + cats ++ RSS.rssCategories (rssChannel f)}} + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed + f{feedChannel=(feedChannel f){ + RSS1.channelDC= + map (\ (t,_) -> DCItem{dcElt=DC_Subject,dcText=t}) + cats ++ RSS1.channelDC (feedChannel f)}} + Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ + mapMaybeChildren (\ e -> + if (elName e == unqual "channel") + then Just ( + foldr + (\ (t,mb) acc -> + addChild (unode "category" + (fromMaybe (\x -> [x]) + (fmap (\v -> (\ x -> [Attr (unqual "domain") v,x])) mb) $ + (Attr (unqual "term") t)) + ) acc) + e + cats) + else Nothing) f + + +withFeedGenerator :: FeedSetter (String,Maybe URLString) +withFeedGenerator (gen,mbURI) fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed $ + f{Atom.feedGenerator=Just ((Atom.nullGenerator gen){Atom.genURI=mbURI})} + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed + f{rssChannel=(rssChannel f){rssGenerator=Just gen}} + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ + case break isSource $ RSS1.channelDC (RSS1.feedChannel f) of + (as,(dci:bs)) -> + f{RSS1.feedChannel= + (RSS1.feedChannel f) + {RSS1.channelDC=as++dci{dcText=gen}:bs}} + (_,[]) -> + f{RSS1.feedChannel= + (RSS1.feedChannel f) + {RSS1.channelDC= + DCItem{dcElt=DC_Source,dcText=gen}: + RSS1.channelDC (RSS1.feedChannel f)}} + Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ + mapMaybeChildren (\ e -> + if (elName e == unqual "channel") + then Just (mapMaybeChildren (\ e2 -> + if (elName e2 == unqual "generator") + then Just (unode "generator" gen) + else Nothing) e) + else Nothing) f + where + isSource dc = dcElt dc == DC_Source + + + +-- Item constructors (all the way to the end): + +atomEntryToItem :: Atom.Entry -> Feed.Types.Item +atomEntryToItem e = Feed.Types.AtomItem e + +rssItemToItem :: RSS.RSSItem -> Feed.Types.Item +rssItemToItem i = Feed.Types.RSSItem i + +rdfItemToItem :: RSS1.Item -> Feed.Types.Item +rdfItemToItem i = Feed.Types.RSS1Item i + +type ItemSetter a = a -> Feed.Types.Item -> Feed.Types.Item + +-- | 'withItemPubDate dt' associates the creation\/ publication date 'dt' +-- with a feed item. +withItemPubDate :: ItemSetter DateString +withItemPubDate dt fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem e{Atom.entryUpdated=dt} + Feed.Types.RSSItem i -> + Feed.Types.RSSItem i{RSS.rssItemPubDate=Just dt} + Feed.Types.RSS1Item i -> + case break isDate $ RSS1.itemDC i of + (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=dt}:bs} + (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Date,dcText=dt}:RSS1.itemDC i} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "pubDate" dt) $ + filterChildren (\ e -> elName e /= unqual "pubDate") + i + where + isDate dc = dcElt dc == DC_Date + +-- | 'withItemDate' is a synonym for 'withItemPubDate'. +withItemDate :: ItemSetter DateString +withItemDate dt fi = withItemPubDate dt fi + +-- | 'withItemTitle myTitle' associates a new title, 'myTitle', +-- with a feed item. +withItemTitle :: ItemSetter String +withItemTitle tit fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem e{Atom.entryTitle=TextString tit} + Feed.Types.RSSItem i -> + Feed.Types.RSSItem i{RSS.rssItemTitle=Just tit} + Feed.Types.RSS1Item i -> + Feed.Types.RSS1Item i{RSS1.itemTitle=tit} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "title" tit) $ + filterChildren (\ e -> elName e /= unqual "title") + i + +-- | 'withItemAuthor auStr' associates new author info +-- with a feed item. +withItemAuthor :: ItemSetter String +withItemAuthor au fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem e{Atom.entryAuthors=[nullPerson{personName=au,personURI=Just au}]} + Feed.Types.RSSItem i -> + Feed.Types.RSSItem i{RSS.rssItemAuthor=Just au} + Feed.Types.RSS1Item i -> + case break isAuthor $ RSS1.itemDC i of + (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=au}:bs} + (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Creator,dcText=au}:RSS1.itemDC i} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "author" au) $ + filterChildren (\ e -> elName e /= unqual "author") + i + where + isAuthor dc = dcElt dc == DC_Creator + +-- | 'withItemFeedLink name myFeed' associates the parent feed URL 'myFeed' +-- with a feed item. It is labelled as 'name'. +withItemFeedLink :: String -> ItemSetter String +withItemFeedLink tit url fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem e{Atom.entrySource=Just Atom.nullSource{sourceId=Just url,sourceTitle=Just (TextString tit)}} + Feed.Types.RSSItem i -> + Feed.Types.RSSItem i{RSS.rssItemSource=Just (RSS.nullSource url tit)} + Feed.Types.RSS1Item i -> + Feed.Types.RSS1Item i{RSS1.itemTitle=tit} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "source" (Attr (unqual "url") url,tit)) $ + filterChildren (\ e -> elName e /= unqual "source") + i + + + +-- | 'withItemCommentLink url' sets the URL reference to the comment page to 'url'. +withItemCommentLink :: ItemSetter String +withItemCommentLink url fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem e{Atom.entryLinks=((nullLink url){linkRel=Just (Left "replies")}):Atom.entryLinks e} + Feed.Types.RSSItem i -> + Feed.Types.RSSItem i{RSS.rssItemComments=Just url} + Feed.Types.RSS1Item i -> + case break isRel $ RSS1.itemDC i of + (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=url}:bs} + (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Relation,dcText=url}:RSS1.itemDC i} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "comments" url) $ + filterChildren (\ e -> elName e /= unqual "comments") + i + where + isRel dc = dcElt dc == DC_Relation + +-- | 'withItemEnclosure url mbTy len' sets the URL reference to the comment page to 'url'. +withItemEnclosure :: String -> Maybe String -> ItemSetter Integer +withItemEnclosure url ty len fi = + case fi of + Feed.Types.AtomItem e -> Feed.Types.AtomItem + e{Atom.entryLinks=((nullLink url){linkRel=Just (Left "enclosure") + ,linkType=ty + ,linkLength=Just (show len) + }):Atom.entryLinks e} + Feed.Types.RSSItem i -> + Feed.Types.RSSItem i{RSS.rssItemEnclosure=Just (nullEnclosure url len (fromMaybe "text/html" ty))} + Feed.Types.RSS1Item i -> Feed.Types.RSS1Item + i{RSS1.itemContent=nullContentInfo{ contentURI=Just url + , contentFormat=ty + }:RSS1.itemContent i} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild ((unode "enclosure" url) + {elAttribs= [ Attr (unqual "length") "0" + , Attr (unqual "type") (fromMaybe "text/html" ty) + ]}) $ + filterChildren (\ e -> elName e /= unqual "enclosure") + i + + +-- | 'withItemId isURL id' associates new unique identifier with a feed item. +-- If 'isURL' is 'True', then the id is assumed to point to a valid web resource. +withItemId :: Bool -> ItemSetter String +withItemId isURL idS fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem e{Atom.entryId=idS} + Feed.Types.RSSItem i -> + Feed.Types.RSSItem i{RSS.rssItemGuid=Just (nullGuid idS){rssGuidPermanentURL=Just isURL}} + Feed.Types.RSS1Item i -> + case break isId $ RSS1.itemDC i of + (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=idS}:bs} + (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Identifier,dcText=idS}:RSS1.itemDC i} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "guid" (Attr (unqual "isPermaLink") (showBool isURL),idS)) $ + filterChildren (\ e -> elName e /= unqual "guid") + i + where + showBool x = map toLower (show x) + isId dc = dcElt dc == DC_Identifier + +-- | 'withItemDescription desc' associates a new descriptive string (aka summary) +-- with a feed item. +withItemDescription :: ItemSetter String +withItemDescription desc fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem e{Atom.entrySummary=Just (TextString desc)} + Feed.Types.RSSItem i -> + Feed.Types.RSSItem i{RSS.rssItemDescription=Just desc} + Feed.Types.RSS1Item i -> + Feed.Types.RSS1Item i{RSS1.itemDesc=Just desc} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "description" desc) $ + filterChildren (\ e -> elName e /= unqual "description") + i + +-- | 'withItemRights rightStr' associates the rights information 'rightStr' +-- with a feed item. +withItemRights :: ItemSetter String +withItemRights desc fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem e{Atom.entryRights=Just (TextString desc)} + -- Note: per-item copyright information isn't supported by RSS2.0 (and earlier editions), + -- you can only attach this at the feed/channel level. So, there's not much we can do + -- except dropping the information on the floor here. (Rolling our own attribute or + -- extension element is an option, but would prefer if someone else had started that + -- effort already. + Feed.Types.RSSItem{} -> fi + Feed.Types.RSS1Item i -> + case break ((==DC_Rights).dcElt) $ RSS1.itemDC i of + (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=desc}:bs} + (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Rights,dcText=desc}:RSS1.itemDC i} + -- Since we're so far assuming that a shallow XML rep. of an item + -- is of RSS2.0 ilk, pinning on the rights info is hard (see above.) + Feed.Types.XMLItem{} -> fi + +-- | 'withItemTitle myLink' associates a new URL, 'myLink', +-- with a feed item. +withItemLink :: ItemSetter URLString +withItemLink url fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem e{Atom.entryLinks=replaceAlternate url (Atom.entryLinks e)} + Feed.Types.RSSItem i -> + Feed.Types.RSSItem i{RSS.rssItemLink=Just url} + Feed.Types.RSS1Item i -> + Feed.Types.RSS1Item i{RSS1.itemLink=url} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "link" url) $ + filterChildren (\ e -> elName e /= unqual "link") + i + where + replaceAlternate _ [] = [] + replaceAlternate x (lr:xs) + | toStr (Atom.linkRel lr) == "alternate" = lr{Atom.linkHref=x} : xs + | otherwise = lr : replaceAlternate x xs + + toStr Nothing = "" + toStr (Just (Left x)) = x + toStr (Just (Right x)) = x + +withItemCategories :: ItemSetter [(String,Maybe String)] +withItemCategories cats fi = + case fi of + Feed.Types.AtomItem e -> Feed.Types.AtomItem + e{ Atom.entryCategories = + map ( \ (t,mb) -> (Atom.newCategory t){Atom.catScheme=mb}) + cats ++ entryCategories e} + Feed.Types.RSSItem i -> Feed.Types.RSSItem + i{RSS.rssItemCategories= + map (\ (t,mb) -> (RSS.newCategory t){RSS.rssCategoryDomain=mb}) + cats ++ rssItemCategories i} + Feed.Types.RSS1Item i -> Feed.Types.RSS1Item + i{RSS1.itemDC= + map (\ (t,_) -> DCItem{dcElt=DC_Subject,dcText=t}) + cats ++ RSS1.itemDC i} + Feed.Types.XMLItem i -> Feed.Types.XMLItem $ + foldr (\ (t,mb) acc -> + addChild (unode "category" + (fromMaybe (\x -> [x]) + (fmap (\v -> (\ x -> [Attr (unqual "domain") v,x])) mb) $ + (Attr (unqual "term") t)) + ) acc) + i + cats + +-- helpers.. + +filterChildren :: (XML.Element -> Bool) -> XML.Element -> XML.Element +filterChildren pre e = + case elContent e of + [] -> e + cs -> e { elContent = mapMaybe filterElt cs } + where + filterElt xe@(XML.Elem el) + | pre el = Just xe + | otherwise = Nothing + filterElt xe = Just xe + +addChild :: XML.Element -> XML.Element -> XML.Element +addChild a b = b { elContent = XML.Elem a : elContent b } + +mapMaybeChildren :: (XML.Element -> Maybe XML.Element) + -> XML.Element + -> XML.Element +mapMaybeChildren f e = + case elContent e of + [] -> e + cs -> e { elContent = map procElt cs } + where + procElt xe@(XML.Elem el) = + case f el of + Nothing -> xe + Just el1 -> XML.Elem el1 + procElt xe = xe diff --git a/Text/Feed/Translate.hs b/Text/Feed/Translate.hs --- a/Text/Feed/Translate.hs +++ b/Text/Feed/Translate.hs @@ -1,134 +1,134 @@ --------------------------------------------------------------------- --- | --- Module : Text.Feed.Translate --- Copyright : (c) Galois, Inc. 2008 --- License : BSD3 --- --- Maintainer: Sigbjorn Finne <sof@galois.com> --- Stability : provisional --- Portability: --- --- --- Translating between RSS formats; work in progress. --- -module Text.Feed.Translate - ( translateItemTo -- :: FeedKind -> Item -> Item - , withAtomEntry -- :: (Atom.Entry -> Atom.Entry) -> Item -> Item - , withRSSItem -- :: (RSS.RSSItem -> RSS.RSSItem) -> Item -> Item - , withRSS1Item -- :: (RSS1.Item -> RSS1.Item) -> Item -> Item - ) where - -import Text.Feed.Types as Feed -import Text.Feed.Constructor - -import Text.RSS.Syntax as RSS -import qualified Text.RSS1.Syntax as RSS1 -import Text.Atom.Feed as Atom - -import Data.Maybe ( fromMaybe ) - --- functions for performing format-specific transformations. --- If the item isn't in the of-interest format, no transformation --- is performed (i.e., no on-the-fly translation into the requested --- format is performed; the caller is responsible --- - -withAtomEntry :: (Atom.Entry -> Atom.Entry) -> Item -> Item -withAtomEntry f it = - case it of - Feed.AtomItem e -> Feed.AtomItem (f e) - _ -> it - -withRSSItem :: (RSS.RSSItem -> RSS.RSSItem) -> Item -> Item -withRSSItem f it = - case it of - Feed.RSSItem e -> Feed.RSSItem (f e) - _ -> it - -withRSS1Item :: (RSS1.Item -> RSS1.Item) -> Item -> Item -withRSS1Item f it = - case it of - Feed.RSS1Item e -> Feed.RSS1Item (f e) - _ -> it - -translateItemTo :: FeedKind -> Item -> Item -translateItemTo fk it = - case fk of - AtomKind -> toAtomItem it - RSSKind v -> toRSSItem v it - RDFKind v -> toRDFItem v it - -toRSSItem :: Maybe String -> Item -> Item -toRSSItem = error "toRSSItem: unimplemented" - -toRDFItem :: Maybe String -> Item -> Item -toRDFItem = error "toRDFItem: unimplemented" - -toAtomItem :: Item -> Item -toAtomItem it = - case it of - AtomItem{} -> it - RSS1Item{} -> error "toAtomItem: unimplemented (from RSS1 item rep.)" - XMLItem{} -> error "toAtomItem: unimplemented (from shallow XML rep.)" - Feed.RSSItem ri -> foldl (\ oi f -> f oi) outIt pipeline_rss_atom - where - outIt = - (flip withAtomEntry) (newItem AtomKind) - (\ e -> e{ Atom.entryOther = RSS.rssItemOther ri - , Atom.entryAttrs = RSS.rssItemAttrs ri - }) - - pipeline_rss_atom = - [ mb withItemTitle (rssItemTitle ri) - , mb withItemLink (rssItemLink ri) - , mb withItemDescription (rssItemDescription ri) - , mb withItemAuthor (rssItemAuthor ri) - , ls withItemCategories (rssItemCategories ri) - , mb withItemId' (rssItemGuid ri) - , mb withItemCommentLink (rssItemComments ri) - , mb withItemEnclosure' (rssItemEnclosure ri) - , mb withItemPubDate (rssItemPubDate ri) - ] - - withItemEnclosure' e = - withItemEnclosure (rssEnclosureURL e) - (Just $ rssEnclosureType e) - (rssEnclosureLength e) - withItemId' g = withItemId (fromMaybe True (rssGuidPermanentURL g)) (rssGuidValue g) - - mb _ Nothing = id - mb f (Just v) = f v - - ls _ [] = id - -- hack, only used for cats, so specialize: - ls f xs = f (map (\ c -> (rssCategoryValue c, rssCategoryDomain c)) xs) - -{- - pipeline_rss_atom = - [ withItemTitle (rssItemTitle ri) - , withItemLink (rssLink ri) - , withDescription (rssDescription ri) - , \ inp -> mb (\ la -> inp{feedLanguage=...}) (rssLanguage ri) - , \ inp -> mb (\ ed -> inp{feedAuthors=[nullPerson{personName=ed}]}) - (rssEditor ri) - , \ inp -> mb (\ ed -> inp{feedAuthors=[nullPerson{personName=ed}]}) - (rssWebMaster ri) - , \ inp -> mb (\ pu -> withPubDate) - (rssPubDate ri) - , \ inp -> mb withLastUpdate - (rssLastUpdate ri) - , \ inp -> withCategories (map (\c -> (RSS.rssCategoryValue c, RSS.rssCategoryDomain c)) - (rssCategories ri)) inp - , \ inp -> mb withGenerator - (rssGenerator ri) - , rssDocs - , rssCloud - , rssTTL - , rssImage - , rssRating - , rssTextInput - , rssSkipHours - , rssSkipDays - } - in --} +-------------------------------------------------------------------- +-- | +-- Module : Text.Feed.Translate +-- Copyright : (c) Galois, Inc. 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@galois.com> +-- Stability : provisional +-- Portability: +-- +-- +-- Translating between RSS formats; work in progress. +-- +module Text.Feed.Translate + ( translateItemTo -- :: FeedKind -> Item -> Item + , withAtomEntry -- :: (Atom.Entry -> Atom.Entry) -> Item -> Item + , withRSSItem -- :: (RSS.RSSItem -> RSS.RSSItem) -> Item -> Item + , withRSS1Item -- :: (RSS1.Item -> RSS1.Item) -> Item -> Item + ) where + +import Text.Feed.Types as Feed +import Text.Feed.Constructor + +import Text.RSS.Syntax as RSS +import qualified Text.RSS1.Syntax as RSS1 +import Text.Atom.Feed as Atom + +import Data.Maybe ( fromMaybe ) + +-- functions for performing format-specific transformations. +-- If the item isn't in the of-interest format, no transformation +-- is performed (i.e., no on-the-fly translation into the requested +-- format is performed; the caller is responsible +-- + +withAtomEntry :: (Atom.Entry -> Atom.Entry) -> Item -> Item +withAtomEntry f it = + case it of + Feed.AtomItem e -> Feed.AtomItem (f e) + _ -> it + +withRSSItem :: (RSS.RSSItem -> RSS.RSSItem) -> Item -> Item +withRSSItem f it = + case it of + Feed.RSSItem e -> Feed.RSSItem (f e) + _ -> it + +withRSS1Item :: (RSS1.Item -> RSS1.Item) -> Item -> Item +withRSS1Item f it = + case it of + Feed.RSS1Item e -> Feed.RSS1Item (f e) + _ -> it + +translateItemTo :: FeedKind -> Item -> Item +translateItemTo fk it = + case fk of + AtomKind -> toAtomItem it + RSSKind v -> toRSSItem v it + RDFKind v -> toRDFItem v it + +toRSSItem :: Maybe String -> Item -> Item +toRSSItem = error "toRSSItem: unimplemented" + +toRDFItem :: Maybe String -> Item -> Item +toRDFItem = error "toRDFItem: unimplemented" + +toAtomItem :: Item -> Item +toAtomItem it = + case it of + AtomItem{} -> it + RSS1Item{} -> error "toAtomItem: unimplemented (from RSS1 item rep.)" + XMLItem{} -> error "toAtomItem: unimplemented (from shallow XML rep.)" + Feed.RSSItem ri -> foldl (\ oi f -> f oi) outIt pipeline_rss_atom + where + outIt = + (flip withAtomEntry) (newItem AtomKind) + (\ e -> e{ Atom.entryOther = RSS.rssItemOther ri + , Atom.entryAttrs = RSS.rssItemAttrs ri + }) + + pipeline_rss_atom = + [ mb withItemTitle (rssItemTitle ri) + , mb withItemLink (rssItemLink ri) + , mb withItemDescription (rssItemDescription ri) + , mb withItemAuthor (rssItemAuthor ri) + , ls withItemCategories (rssItemCategories ri) + , mb withItemId' (rssItemGuid ri) + , mb withItemCommentLink (rssItemComments ri) + , mb withItemEnclosure' (rssItemEnclosure ri) + , mb withItemPubDate (rssItemPubDate ri) + ] + + withItemEnclosure' e = + withItemEnclosure (rssEnclosureURL e) + (Just $ rssEnclosureType e) + (rssEnclosureLength e) + withItemId' g = withItemId (fromMaybe True (rssGuidPermanentURL g)) (rssGuidValue g) + + mb _ Nothing = id + mb f (Just v) = f v + + ls _ [] = id + -- hack, only used for cats, so specialize: + ls f xs = f (map (\ c -> (rssCategoryValue c, rssCategoryDomain c)) xs) + +{- + pipeline_rss_atom = + [ withItemTitle (rssItemTitle ri) + , withItemLink (rssLink ri) + , withDescription (rssDescription ri) + , \ inp -> mb (\ la -> inp{feedLanguage=...}) (rssLanguage ri) + , \ inp -> mb (\ ed -> inp{feedAuthors=[nullPerson{personName=ed}]}) + (rssEditor ri) + , \ inp -> mb (\ ed -> inp{feedAuthors=[nullPerson{personName=ed}]}) + (rssWebMaster ri) + , \ inp -> mb (\ pu -> withPubDate) + (rssPubDate ri) + , \ inp -> mb withLastUpdate + (rssLastUpdate ri) + , \ inp -> withCategories (map (\c -> (RSS.rssCategoryValue c, RSS.rssCategoryDomain c)) + (rssCategories ri)) inp + , \ inp -> mb withGenerator + (rssGenerator ri) + , rssDocs + , rssCloud + , rssTTL + , rssImage + , rssRating + , rssTextInput + , rssSkipHours + , rssSkipDays + } + in +-} diff --git a/Text/RSS/Export.hs b/Text/RSS/Export.hs --- a/Text/RSS/Export.hs +++ b/Text/RSS/Export.hs @@ -16,12 +16,11 @@ import Text.XML.Light as XML import Text.RSS.Syntax -import Data.List import Data.Maybe qualNode :: String -> [XML.Content] -> XML.Element -qualNode n cs = - blank_element +qualNode n cs = + blank_element { elName = qualName n , elContent = cs } @@ -31,16 +30,16 @@ --- xmlRSS :: RSS -> XML.Element -xmlRSS r = +xmlRSS r = (qualNode "rss" $ map Elem $ - ( [ xmlChannel (rssChannel r) ] + ( [ xmlChannel (rssChannel r) ] ++ rssOther r)) { elAttribs = (Attr (qualName "version") (rssVersion r)):rssAttrs r } xmlChannel :: RSSChannel -> XML.Element -xmlChannel ch = +xmlChannel ch = (qualNode "channel" $ map Elem $ - ( [ xmlLeaf "title" (rssTitle ch) + ( [ xmlLeaf "title" (rssTitle ch) , xmlLeaf "link" (rssLink ch) , xmlLeaf "description" (rssDescription ch) ] @@ -62,11 +61,11 @@ ++ mb xmlSkipHours (rssSkipHours ch) ++ mb xmlSkipDays (rssSkipDays ch) ++ rssChannelOther ch)) - + xmlItem :: RSSItem -> XML.Element -xmlItem it = +xmlItem it = (qualNode "item" $ map Elem $ - ( mb (xmlLeaf "title") (rssItemTitle it) + ( mb (xmlLeaf "title") (rssItemTitle it) ++ mb (xmlLeaf "link") (rssItemLink it) ++ mb (xmlLeaf "description") (rssItemDescription it) ++ mb (xmlLeaf "author") (rssItemAuthor it) @@ -80,22 +79,22 @@ { elAttribs = rssItemAttrs it } xmlSource :: RSSSource -> XML.Element -xmlSource s = +xmlSource s = (xmlLeaf "source" (rssSourceTitle s)) - { elAttribs = (Attr (qualName "url") (rssSourceURL s)) : + { elAttribs = (Attr (qualName "url") (rssSourceURL s)) : rssSourceAttrs s } xmlEnclosure :: RSSEnclosure -> XML.Element -xmlEnclosure e = +xmlEnclosure e = (xmlLeaf "enclosure" "") { elAttribs = - (Attr (qualName "url") (rssEnclosureURL e)) : - (Attr (qualName "length") (show $ rssEnclosureLength e)) : - (Attr (qualName "type") (rssEnclosureType e)) : + (Attr (qualName "url") (rssEnclosureURL e)) : + (Attr (qualName "length") (show $ rssEnclosureLength e)) : + (Attr (qualName "type") (rssEnclosureType e)) : rssEnclosureAttrs e } xmlCategory :: RSSCategory -> XML.Element -xmlCategory c = +xmlCategory c = (xmlLeaf "category" (rssCategoryValue c)) { elAttribs = (fromMaybe id (fmap (\ n -> ((Attr (qualName "domain") n):)) @@ -103,7 +102,7 @@ (rssCategoryAttrs c) } xmlGuid :: RSSGuid -> XML.Element -xmlGuid g = +xmlGuid g = (xmlLeaf "guid" (rssGuidValue g)) { elAttribs = (fromMaybe id (fmap (\ n -> ((Attr (qualName "isPermaLink") (toBool n)):)) @@ -114,19 +113,19 @@ toBool _ = "true" xmlImage :: RSSImage -> XML.Element -xmlImage im = +xmlImage im = (qualNode "image" $ map Elem $ ( [ xmlLeaf "url" (rssImageURL im) , xmlLeaf "title" (rssImageTitle im) , xmlLeaf "link" (rssImageLink im) - ] + ] ++ mb ((xmlLeaf "width") . show) (rssImageWidth im) ++ mb ((xmlLeaf "height") . show) (rssImageHeight im) ++ mb (xmlLeaf "description") (rssImageDesc im) ++ rssImageOther im)) xmlCloud :: RSSCloud -> XML.Element -xmlCloud cl = +xmlCloud cl = (xmlLeaf "cloud" "") { elAttribs = ( mb (Attr (qualName "domain")) (rssCloudDomain cl) @@ -147,12 +146,12 @@ { elAttribs = rssTextInputAttrs ti } xmlSkipHours :: [Integer] -> XML.Element -xmlSkipHours hs = +xmlSkipHours hs = (qualNode "skipHours" $ map Elem $ (map (\ n -> xmlLeaf "hour" (show n)) hs)) xmlSkipDays :: [String] -> XML.Element -xmlSkipDays hs = +xmlSkipDays hs = (qualNode "skipDayss" $ map Elem $ (map (\ n -> xmlLeaf "day" n) hs)) @@ -162,7 +161,7 @@ xmlAttr k v = Attr (qualName k) v xmlLeaf :: String -> String -> XML.Element -xmlLeaf tg txt = +xmlLeaf tg txt = blank_element{ elName = qualName tg , elContent = [ Text blank_cdata { cdData = txt } ] } @@ -171,4 +170,3 @@ mb :: (a -> b) -> Maybe a -> [b] mb _ Nothing = [] mb f (Just x) = [f x] - diff --git a/Text/RSS1/Import.hs b/Text/RSS1/Import.hs --- a/Text/RSS1/Import.hs +++ b/Text/RSS1/Import.hs @@ -1,6 +1,6 @@ -------------------------------------------------------------------- -- | --- Module : Text.RSS1.Import +-- Module : Text.RSS1.Import -- Copyright : (c) Galois, Inc. 2008 -- License : BSD3 -- @@ -10,14 +10,13 @@ -- -------------------------------------------------------------------- -module Text.RSS1.Import +module Text.RSS1.Import ( elementToFeed ) where import Text.RSS1.Syntax import Text.RSS1.Utils import Text.XML.Light as XML -import Text.XML.Light.Proc as XML import Text.DublinCore.Types import Data.Maybe (mapMaybe, fromMaybe) @@ -123,7 +122,7 @@ li <- pLeaf "link" e de <- pLeaf "description" e let mbImg = pLeaf "image" e - let is = + let is = case fmap seqLeaves $ pNode "items" e of Nothing -> [] Just ss -> ss @@ -133,7 +132,7 @@ let cs = mapMaybe elementToContent es let es_other = removeKnownElts e let as_other = removeKnownAttrs e - let def_chan = + let def_chan = Channel { channelURI = uri , channelTitle = ti @@ -154,13 +153,13 @@ return (addSyndication e def_chan) addSyndication :: XML.Element -> Channel -> Channel -addSyndication e ch = +addSyndication e ch = ch{ channelUpdatePeriod = fmap toUpdatePeriod $ pQLeaf (synNS,synPrefix) "updatePeriod" e , channelUpdateFreq = fmap read $ pQLeaf (synNS,synPrefix) "updateFrequency" e , channelUpdateBase = pQLeaf (synNS,synPrefix) "updateBase" e } where - toUpdatePeriod x = + toUpdatePeriod x = case x of "hourly" -> Update_Hourly "daily" -> Update_Daily @@ -169,7 +168,7 @@ "yearly" -> Update_Yearly _ -> Update_Hourly -- ToDo: whine - + elementToDC :: XML.Element -> Maybe DCItem elementToDC e = do guard (qURI (elName e) == dcNS) @@ -220,18 +219,18 @@ } bagLeaves :: XML.Element -> [URIString] -bagLeaves be = - mapMaybe +bagLeaves be = + mapMaybe (\ e -> do guard (elName e == qualName (rdfNS,rdfPrefix) "li") - pAttr (rdfNS,rdfPrefix) "resource" e `mplus` + pAttr (rdfNS,rdfPrefix) "resource" e `mplus` fmap strContent (pQNode (qualName (rdfNS,rdfPrefix) "li") e)) (fromMaybe [] $ fmap children $ pQNode (qualName (rdfNS,rdfPrefix) "Bag") be) {- bagElements :: XML.Element -> [XML.Element] -bagElements be = - mapMaybe +bagElements be = + mapMaybe (\ e -> do guard (elName e == rdfName "li") return e) @@ -239,8 +238,8 @@ -} seqLeaves :: XML.Element -> [URIString] -seqLeaves se = - mapMaybe +seqLeaves se = + mapMaybe (\ e -> do guard (elName e == rdfName "li") return (strContent e)) diff --git a/Text/RSS1/Utils.hs b/Text/RSS1/Utils.hs --- a/Text/RSS1/Utils.hs +++ b/Text/RSS1/Utils.hs @@ -13,7 +13,6 @@ module Text.RSS1.Utils where import Text.XML.Light as XML -import Text.XML.Light.Proc as XML import Text.DublinCore.Types import Data.Maybe (listToMaybe, mapMaybe) @@ -94,11 +93,11 @@ known_con_elts = map (qualName (conNS,conPrefix)) [ "items", "item", "format", "encoding" ] removeKnownElts :: XML.Element -> [XML.Element] -removeKnownElts e = +removeKnownElts e = filter (\ e1 -> not (elName e1 `elem` known_elts)) (children e) where - known_elts = - concat [ known_rss_elts + known_elts = + concat [ known_rss_elts , known_syn_elts , known_dc_elts , known_con_elts @@ -106,9 +105,8 @@ ] removeKnownAttrs :: XML.Element -> [XML.Attr] -removeKnownAttrs e = +removeKnownAttrs e = filter (\ a -> not (attrKey a `elem` known_attrs)) (elAttribs e) where - known_attrs = + known_attrs = map rdfName [ "about" ] - diff --git a/feed.cabal b/feed.cabal --- a/feed.cabal +++ b/feed.cabal @@ -1,5 +1,5 @@ Name: feed -Version: 0.3.8 +Version: 0.3.9 License: BSD3 License-file: LICENSE Category: Text