feed 0.3.8 → 0.3.9
raw patch · 10 files changed
+1002/−1004 lines, 10 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Text.RSS1.Utils: conPrefix, conNS :: Maybe String
- Text.RSS1.Utils: dcPrefix, dcNS :: Maybe String
- Text.RSS1.Utils: rdfPrefix, rdfNS :: Maybe String
- Text.RSS1.Utils: rssPrefix, rss10NS :: Maybe String
- Text.RSS1.Utils: synPrefix, synNS :: Maybe String
- Text.RSS1.Utils: taxPrefix, taxNS :: Maybe String
+ Text.RSS1.Utils: conNS :: Maybe String
+ Text.RSS1.Utils: conPrefix :: Maybe String
+ Text.RSS1.Utils: dcNS :: Maybe String
+ Text.RSS1.Utils: dcPrefix :: Maybe String
+ Text.RSS1.Utils: rdfNS :: Maybe String
+ Text.RSS1.Utils: rdfPrefix :: Maybe String
+ Text.RSS1.Utils: rss10NS :: Maybe String
+ Text.RSS1.Utils: rssPrefix :: Maybe String
+ Text.RSS1.Utils: synNS :: Maybe String
+ Text.RSS1.Utils: synPrefix :: Maybe String
+ Text.RSS1.Utils: taxNS :: Maybe String
+ Text.RSS1.Utils: taxPrefix :: Maybe String
Files
- CHANGES +9/−0
- Text/Atom/Feed/Export.hs +4/−8
- Text/Atom/Feed/Link.hs +80/−80
- Text/Atom/Pub/Export.hs +7/−9
- Text/Feed/Constructor.hs +725/−725
- Text/Feed/Translate.hs +134/−134
- Text/RSS/Export.hs +23/−25
- Text/RSS1/Import.hs +14/−15
- Text/RSS1/Utils.hs +5/−7
- feed.cabal +1/−1
CHANGES view
@@ -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: * <feed> parsing: made <title> be optional.
Text/Atom/Feed/Export.hs view
@@ -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]-
Text/Atom/Feed/Link.hs view
@@ -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]+
Text/Atom/Pub/Export.hs view
@@ -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
Text/Feed/Constructor.hs view
@@ -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
Text/Feed/Translate.hs view
@@ -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+-}
Text/RSS/Export.hs view
@@ -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]-
Text/RSS1/Import.hs view
@@ -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))
Text/RSS1/Utils.hs view
@@ -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" ]-
feed.cabal view
@@ -1,5 +1,5 @@ Name: feed-Version: 0.3.8+Version: 0.3.9 License: BSD3 License-file: LICENSE Category: Text