feed 0.3.9.1 → 0.3.9.2
raw patch · 24 files changed
+451/−399 lines, 24 filesdep +time
Dependencies added: time
Files
- Text/Atom/Feed.hs +5/−4
- Text/Atom/Feed/Export.hs +6/−2
- Text/Atom/Feed/Import.hs +8/−4
- Text/Atom/Feed/Link.hs +6/−5
- Text/Atom/Feed/Validate.hs +49/−48
- Text/Atom/Pub.hs +4/−3
- Text/Atom/Pub/Export.hs +6/−2
- Text/DublinCore/Types.hs +9/−6
- Text/Feed/Constructor.hs +101/−100
- Text/Feed/Export.hs +6/−5
- Text/Feed/Import.hs +22/−11
- Text/Feed/Query.hs +97/−103
- Text/Feed/Translate.hs +17/−17
- Text/Feed/Types.hs +4/−3
- Text/Feed/Util.hs +4/−3
- Text/RSS/Export.hs +3/−2
- Text/RSS/Import.hs +12/−11
- Text/RSS/Syntax.hs +24/−21
- Text/RSS1/Export.hs +32/−31
- Text/RSS1/Import.hs +4/−3
- Text/RSS1/Syntax.hs +10/−9
- Text/RSS1/Utils.hs +4/−3
- feed.cabal +9/−2
- tests/Main.hs +9/−1
Text/Atom/Feed.hs view
@@ -1,12 +1,13 @@ -------------------------------------------------------------------- -- | -- Module : Text.Atom.Feed--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Portability:+-- Portability: portable -- -------------------------------------------------------------------- @@ -253,7 +254,7 @@ , sourceUpdated = Nothing , sourceOther = [] }- + nullPerson :: Person nullPerson = Person { personName = ""
Text/Atom/Feed/Export.hs view
@@ -1,12 +1,16 @@ -------------------------------------------------------------------- -- | -- Module : Text.Atom.Feed.Export--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional+-- Portability:: portable -- Description: Convert from Atom to XML+--+-- Convert from Atom to XML -- --------------------------------------------------------------------
Text/Atom/Feed/Import.hs view
@@ -1,13 +1,17 @@ -------------------------------------------------------------------- -- | -- Module : Text.Atom.Feed.Import--- Copyright : (c) Galois, Inc. 2007-2008+-- Copyright : (c) Galois, Inc. 2007-2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional+-- Portability:: portable -- Description: Convert from XML to Atom --+-- Convert from XML to Atom+-- -------------------------------------------------------------------- module Text.Atom.Feed.Import where@@ -214,7 +218,7 @@ -- let's have them all (including xml:base and xml:lang + xmlns: stuff) known_attrs = []- + pContent :: XML.Element -> Maybe EntryContent pContent e = case pAttr "type" e of@@ -247,7 +251,7 @@ pInReplyTo es = do t <- pQNode (atomThreadName "reply-to") es case pQAttr (atomThreadName "ref") t of- Just ref -> + Just ref -> return InReplyTo { replyToRef = ref , replyToHRef = pQAttr (atomThreadName "href") t
Text/Atom/Feed/Link.hs view
@@ -1,12 +1,13 @@ -------------------------------------------------------------------- -- | -- Module : Text.Atom.Feed.Link--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Portability:+-- Portability: portable -- -------------------------------------------------------------------- @@ -25,7 +26,7 @@ -- 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: +-- registered link types (derived from: -- http:\/\/www.iana.org\/assignments\/link-relations.html -- on 2007-10-28] --@@ -51,7 +52,7 @@ deriving (Eq, Show) showLinkRelation :: LinkRelation -> String-showLinkRelation lr = +showLinkRelation lr = case lr of LinkAlternate -> "alternate" LinkCurrent -> "current"
Text/Atom/Feed/Validate.hs view
@@ -1,12 +1,13 @@ -------------------------------------------------------------------- -- | -- Module : Text.Atom.Feed.Validate--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Portability:+-- Portability: portable -- -------------------------------------------------------------------- module Text.Atom.Feed.Validate where@@ -41,7 +42,7 @@ flattenT (VNode as bs) = as ++ concatMap flattenT bs validateEntry :: Element -> ValidatorResult-validateEntry e = +validateEntry e = mkTree [] [ checkEntryAuthor e , checkCats e@@ -60,107 +61,107 @@ -- Sec 4.1.2, check #1 checkEntryAuthor :: Element -> ValidatorResult-checkEntryAuthor e = +checkEntryAuthor e = case pNodes "author" (elChildren e) of- [] -> -- required + [] -> -- required case pNode "summary" (elChildren e) of Nothing -> demand "Required 'author' element missing (no 'summary' either)"- Just e1 -> + Just e1 -> case pNode "author" (elChildren e1) of Just a -> checkAuthor a _ -> demand "Required 'author' element missing" xs -> mkTree [] $ map checkAuthor xs- + -- Sec 4.1.2, check #2 checkCats :: Element -> ValidatorResult checkCats e = mkTree [] $ map checkCat (pNodes "category" (elChildren e)) checkContents :: Element -> ValidatorResult-checkContents e = +checkContents e = case pNodes "content" (elChildren e) of [] -> valid [c] -> mkTree [] $ [checkContent c] cs -> mkTree (flattenT (demand ("at most one 'content' element expected inside 'entry', found: " ++ show (length cs)))) (map checkContent cs)- - ++ checkContributor :: Element -> ValidatorResult checkContributor _e = valid checkContentLink :: Element -> ValidatorResult-checkContentLink e = +checkContentLink e = case pNodes "content" (elChildren e) of- [] -> + [] -> case pNodes "link" (elChildren e) of [] -> demand ("An 'entry' element with no 'content' element must have at least one 'link-rel' element")- xs -> + xs -> case filter (=="alternate") $ mapMaybe (pAttr "rel") xs of [] -> demand ("An 'entry' element with no 'content' element must have at least one 'link-rel' element") _ -> valid _ -> valid checkLinks :: Element -> ValidatorResult-checkLinks e = +checkLinks e = case pNodes "link" (elChildren e) of- xs -> - case map fst $ filter (\ (_,n) -> n =="alternate") $ + xs ->+ case map fst $ filter (\ (_,n) -> n =="alternate") $ mapMaybe (\ ex -> fmap (\x -> (ex,x)) $ pAttr "rel" ex) xs of- xs1 -> - let + xs1 ->+ let jmb (Just x) (Just y) = Just (x,y) jmb _ _ = Nothing in case mapMaybe (\ ex -> pAttr "type" ex `jmb` pAttr "hreflang" ex) xs1 of- xs2 -> + xs2 -> case any (\ x -> length x > 1) (group xs2) of True -> demand ("An 'entry' element cannot have duplicate 'link-rel-alternate-type-hreflang' elements") _ -> valid checkId :: Element -> ValidatorResult-checkId e = +checkId e = case pNodes "id" (elChildren e) of [] -> demand "required field 'id' missing from 'entry' element" [_] -> valid xs -> demand ("only one 'id' field expected in 'entry' element, found: " ++ show (length xs)) checkPublished :: Element -> ValidatorResult-checkPublished e = +checkPublished e = case pNodes "published" (elChildren e) of [] -> valid [_] -> valid xs -> demand ("expected at most one 'published' field in 'entry' element, found: " ++ show (length xs)) checkRights :: Element -> ValidatorResult-checkRights e = +checkRights e = case pNodes "rights" (elChildren e) of [] -> valid [_] -> valid xs -> demand ("expected at most one 'rights' field in 'entry' element, found: " ++ show (length xs)) checkSource :: Element -> ValidatorResult-checkSource e = +checkSource e = case pNodes "source" (elChildren e) of [] -> valid [_] -> valid xs -> demand ("expected at most one 'source' field in 'entry' element, found: " ++ show (length xs)) checkSummary :: Element -> ValidatorResult-checkSummary e = +checkSummary e = case pNodes "summary" (elChildren e) of [] -> valid [_] -> valid xs -> demand ("expected at most one 'summary' field in 'entry' element, found: " ++ show (length xs)) checkTitle :: Element -> ValidatorResult-checkTitle e = +checkTitle e = case pNodes "title" (elChildren e) of [] -> demand "required field 'title' missing from 'entry' element" [_] -> valid xs -> demand ("only one 'title' field expected in 'entry' element, found: " ++ show (length xs)) checkUpdated :: Element -> ValidatorResult-checkUpdated e = +checkUpdated e = case pNodes "updated" (elChildren e) of [] -> demand "required field 'updated' missing from 'entry' element" [_] -> valid@@ -173,7 +174,7 @@ , checkLabel e ] where- checkScheme e' = + checkScheme e' = case pAttrs "scheme" e' of [] -> valid (_:xs)@@ -190,16 +191,16 @@ checkContent :: Element -> ValidatorResult checkContent e = mkTree (flattenT (mkTree [] [type_valid, src_valid])) [case ty of- "text" -> + "text" -> case onlyElems (elContent e) of [] -> valid _ -> demand ("content with type 'text' cannot have child elements, text only.")- "html" -> + "html" -> case onlyElems (elContent e) of [] -> valid _ -> demand ("content with type 'html' cannot have child elements, text only.") - "xhtml" -> + "xhtml" -> case onlyElems (elContent e) of [] -> valid [_] -> valid -- ToDo: check that it is a 'div'.@@ -208,22 +209,22 @@ {- case parseMIMEType ty of Nothing -> valid- Just mt + Just mt | isXmlType mt -> valid- | otherwise -> + | otherwise -> case onlyElems (elContent e) of- [] -> valid -- check + [] -> valid -- check _ -> demand ("content with MIME type '" ++ ty ++ "' must only contain base64 data")] -} where- types = pAttrs "type" e - (ty, type_valid) = + types = pAttrs "type" e+ (ty, type_valid) = case types of [] -> ("text", valid) [t] -> checkTypeA t (t:ts) -> (t, demand ("Expected at most one 'type' attribute, found: " ++ show (1+length ts))) - src_valid = + src_valid = case pAttrs "src" e of [] -> valid [_] ->@@ -244,7 +245,7 @@ {- case parseMIMEType v of Nothing -> ("text", demand ("Invalid/unknown type value " ++ v))- Just mt -> + Just mt -> case mimeType mt of Multipart{} -> ("text", demand "Multipart MIME types not a legal 'type'") _ -> (v, valid)@@ -253,7 +254,7 @@ std_types = [ "text", "xhtml", "html"] checkTerm :: Element -> ValidatorResult-checkTerm e = +checkTerm e = case pNodes "term" (elChildren e) of [] -> demand "required field 'term' missing from 'category' element" [_] -> valid@@ -263,32 +264,32 @@ checkAuthor e = checkPerson e checkPerson :: Element -> ValidatorResult-checkPerson e = +checkPerson e = mkTree (flattenT $ checkName e) [ checkEmail e , checkUri e ]- + checkName :: Element -> ValidatorResult-checkName e = +checkName e = case pNodes "name" (elChildren e) of [] -> demand "required field 'name' missing from 'author' element" [_] -> valid xs -> demand ("only one 'name' expected in 'author' element, found: " ++ show (length xs))- + checkEmail :: Element -> ValidatorResult-checkEmail e = +checkEmail e = case pNodes "email" (elChildren e) of [] -> valid- (_:xs) + (_:xs) | null xs -> valid | otherwise -> demand ("at most one 'email' expected in 'author' element, found: " ++ show (1+length xs))- + checkUri :: Element -> ValidatorResult-checkUri e = +checkUri e = case pNodes "email" (elChildren e) of [] -> valid- (_:xs) + (_:xs) | null xs -> valid | otherwise -> demand ("at most one 'uri' expected in 'author' element, found: " ++ show (1+length xs))
Text/Atom/Pub.hs view
@@ -1,12 +1,13 @@ -------------------------------------------------------------------- -- | -- Module : Text.Atom.Pub--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Portability:+-- Portability: portable -- -- Types for the Atom Publishing Protocol (APP) --
Text/Atom/Pub/Export.hs view
@@ -1,12 +1,16 @@ -------------------------------------------------------------------- -- | -- Module : Text.Atom.Pub.Export--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional+-- Portability:: portable -- Description: Serializing APP types (as XML.)+--+-- Serializing Atom Publishing Protocol types as XML. -- -------------------------------------------------------------------- module Text.Atom.Pub.Export where
Text/DublinCore/Types.hs view
@@ -1,17 +1,20 @@ -------------------------------------------------------------------- -- | -- Module : Text.DublinCore.Types--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Description: Representing the DublinCore metadata elements in Haskell. The Dublin--- Core Metadata Element Set. See: <http://dublincore.org/>--- +--+-- Representing the DublinCore metadata elements in Haskell.+-- For information on the Dublin Core Metadata Element Set,+-- see: <http://dublincore.org/>+-- module Text.DublinCore.Types where --- | A DCItem+-- | A DCItem pairs a specific element with its (string) value. data DCItem = DCItem { dcElt :: DCInfo
Text/Feed/Constructor.hs view
@@ -1,10 +1,11 @@ -------------------------------------------------------------------- -- | -- Module : Text.Feed.Constructor--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional -- Description: Module for an abstraction layer between different kinds of feeds. --@@ -75,22 +76,22 @@ -- the constraints are at the moment.) --- | Construct an empty feed document, intending to output it in +-- | Construct an empty feed document, intending to output it in -- the 'fk' feed format. newFeed :: FeedKind -> Feed.Types.Feed-newFeed fk = +newFeed fk = case fk of AtomKind -> AtomFeed (Atom.nullFeed "feed-id-not-filled-in" (TextString "dummy-title") "dummy-and-bogus-update-date")- RSSKind mbV -> + RSSKind mbV -> let def = (RSS.nullRSS "dummy-title" "default-channel-url") in RSSFeed $ fromMaybe def $ fmap (\ v -> def{RSS.rssVersion=v}) mbV- RDFKind 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 @@ -102,9 +103,9 @@ feedFromXML :: XML.Element -> Feed.Types.Feed feedFromXML f = XMLFeed f- + getFeedKind :: Feed.Types.Feed -> FeedKind-getFeedKind f = +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})@@ -112,32 +113,32 @@ 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 = +addItem it f = case (it,f) of- (Feed.Types.AtomItem e, Feed.Types.AtomFeed fe) -> + (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.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) -> + (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 = +withFeedItems is fe = foldr addItem (case fe of- Feed.Types.AtomFeed f -> Feed.Types.AtomFeed + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{Atom.feedEntries=[]}- Feed.Types.RSSFeed f -> Feed.Types.RSSFeed + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssItems=[]}}- Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedItems=[]}) is newItem :: FeedKind -> Feed.Types.Item-newItem fk = +newItem fk = case fk of AtomKind -> Feed.Types.AtomItem $ Atom.nullEntry "entry-id-not-filled-in"@@ -151,7 +152,7 @@ "dummy-item-link" getItemKind :: Feed.Types.Item -> FeedKind-getItemKind f = +getItemKind f = case f of Feed.Types.AtomItem{} -> AtomKind Feed.Types.RSSItem{} -> RSSKind (Just "2.0") -- good guess..@@ -161,22 +162,22 @@ type FeedSetter a = a -> Feed.Types.Feed -> Feed.Types.Feed withFeedTitle :: FeedSetter String-withFeedTitle tit fe = +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 -> + mapMaybeChildren (\ e -> if (elName e == unqual "channel")- then Just (mapMaybeChildren (\ e2 -> + 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 = +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@@ -185,82 +186,82 @@ 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 -> + mapMaybeChildren (\ e -> if (elName e == unqual "channel")- then Just (mapMaybeChildren (\ e2 -> + 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" + , linkType=Just "application/atom+xml" } -- | 'withFeedHTML' sets the URL where an HTML version of the -- feed is published. withFeedHTML :: FeedSetter URLString-withFeedHTML url fe = +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 -> + mapMaybeChildren (\ e -> if (elName e == unqual "channel")- then Just (mapMaybeChildren (\ e2 -> + 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" + , linkType=Just "text/html" } -- | 'withFeedHTML' sets the URL where an HTML version of the -- feed is published. withFeedDescription :: FeedSetter String-withFeedDescription desc fe = +withFeedDescription desc fe = case fe of- Feed.Types.AtomFeed f -> Feed.Types.AtomFeed + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedSubtitle=Just (TextString desc)}- Feed.Types.RSSFeed f -> Feed.Types.RSSFeed + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssDescription=desc}}- Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedChannel=(feedChannel f){channelDesc=desc}} Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $- mapMaybeChildren (\ e -> + mapMaybeChildren (\ e -> if (elName e == unqual "channel")- then Just (mapMaybeChildren (\ e2 -> + 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 = +withFeedPubDate dateStr fe = case fe of- Feed.Types.AtomFeed f -> Feed.Types.AtomFeed + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedUpdated=dateStr}- Feed.Types.RSSFeed f -> Feed.Types.RSSFeed + 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)) -> + (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 -> + mapMaybeChildren (\ e -> if (elName e == unqual "channel")- then Just (mapMaybeChildren (\ e2 -> + then Just (mapMaybeChildren (\ e2 -> if (elName e2 == unqual "pubDate") then Just (unode "pubDate" dateStr) else Nothing) e)@@ -269,28 +270,28 @@ isDate dc = dcElt dc == DC_Date withFeedLastUpdate :: FeedSetter DateString-withFeedLastUpdate dateStr fe = +withFeedLastUpdate dateStr fe = case fe of- Feed.Types.AtomFeed f -> Feed.Types.AtomFeed + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedUpdated=dateStr}- Feed.Types.RSSFeed f -> Feed.Types.RSSFeed + 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)) -> + (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 -> + mapMaybeChildren (\ e -> if (elName e == unqual "channel")- then Just (mapMaybeChildren (\ e2 -> + then Just (mapMaybeChildren (\ e2 -> if (elName e2 == unqual "lastUpdate") then Just (unode "lastUpdate" dateStr) else Nothing) e)@@ -299,7 +300,7 @@ isDate dc = dcElt dc == DC_Date --- | 'withFeedDate dt' is the composition of 'withFeedPubDate' +-- | '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.@@ -308,15 +309,15 @@ withFeedLogoLink :: URLString -> FeedSetter URLString-withFeedLogoLink imgURL lnk fe = +withFeedLogoLink imgURL lnk fe = case fe of- Feed.Types.AtomFeed f -> Feed.Types.AtomFeed + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{ feedLogo = Just imgURL , feedLinks = newSelf:Atom.feedLinks f }- Feed.Types.RSSFeed f -> Feed.Types.RSSFeed + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{ rssChannel=(rssChannel f)- {rssImage=Just $ + {rssImage=Just $ RSS.nullImage imgURL (rssTitle (rssChannel f)) lnk}} Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ f{ feedImage = Just $@@ -325,9 +326,9 @@ (feedChannel f){channelImageURI=Just imgURL} } Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $- mapMaybeChildren (\ e -> + mapMaybeChildren (\ e -> if (elName e == unqual "channel")- then Just (mapMaybeChildren (\ e2 -> + then Just (mapMaybeChildren (\ e2 -> if (elName e2 == unqual "image") then Just (unode "image" [ unode "url" imgURL , unode "title" title@@ -336,7 +337,7 @@ else Nothing) e) else Nothing) f where- title = + title = case fmap (findChild (unqual "title")) (findChild (unqual "channel") f) of Just (Just e1) -> strContent e1@@ -344,33 +345,33 @@ where newSelf = (nullLink lnk){ linkRel=Just (Left "self")- , linkType=Just "application/atom+xml" + , linkType=Just "application/atom+xml" } withFeedLanguage :: FeedSetter String-withFeedLanguage lang fe = +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 + 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)) -> + (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 -> + mapMaybeChildren (\ e -> if (elName e == unqual "channel")- then Just (mapMaybeChildren (\ e2 -> + then Just (mapMaybeChildren (\ e2 -> if (elName e2 == unqual "language") then Just (unode "language" lang) else Nothing) e)@@ -379,7 +380,7 @@ isLang dc = dcElt dc == DC_Language withFeedCategories :: FeedSetter [(String,Maybe String)]-withFeedCategories cats fe = +withFeedCategories cats fe = case fe of Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{ Atom.feedCategories =@@ -396,11 +397,11 @@ map (\ (t,_) -> DCItem{dcElt=DC_Subject,dcText=t}) cats ++ RSS1.channelDC (feedChannel f)}} Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $- mapMaybeChildren (\ e -> + mapMaybeChildren (\ e -> if (elName e == unqual "channel") then Just (- foldr - (\ (t,mb) acc -> + foldr+ (\ (t,mb) acc -> addChild (unode "category" (fromMaybe (\x -> [x]) (fmap (\v -> (\ x -> [Attr (unqual "domain") v,x])) mb) $@@ -412,28 +413,28 @@ withFeedGenerator :: FeedSetter (String,Maybe URLString)-withFeedGenerator (gen,mbURI) fe = +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 + 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)) -> + (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 -> + mapMaybeChildren (\ e -> if (elName e == unqual "channel")- then Just (mapMaybeChildren (\ e2 -> + then Just (mapMaybeChildren (\ e2 -> if (elName e2 == unqual "generator") then Just (unode "generator" gen) else Nothing) e)@@ -459,7 +460,7 @@ -- | 'withItemPubDate dt' associates the creation\/ publication date 'dt' -- with a feed item. withItemPubDate :: ItemSetter DateString-withItemPubDate dt fi = +withItemPubDate dt fi = case fi of Feed.Types.AtomItem e -> Feed.Types.AtomItem e{Atom.entryUpdated=dt}@@ -484,7 +485,7 @@ -- | 'withItemTitle myTitle' associates a new title, 'myTitle', -- with a feed item. withItemTitle :: ItemSetter String-withItemTitle tit fi = +withItemTitle tit fi = case fi of Feed.Types.AtomItem e -> Feed.Types.AtomItem e{Atom.entryTitle=TextString tit}@@ -501,7 +502,7 @@ -- | 'withItemAuthor auStr' associates new author info -- with a feed item. withItemAuthor :: ItemSetter String-withItemAuthor au fi = +withItemAuthor au fi = case fi of Feed.Types.AtomItem e -> Feed.Types.AtomItem e{Atom.entryAuthors=[nullPerson{personName=au,personURI=Just au}]}@@ -522,7 +523,7 @@ -- | '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 = +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)}}@@ -540,7 +541,7 @@ -- | 'withItemCommentLink url' sets the URL reference to the comment page to 'url'. withItemCommentLink :: ItemSetter String-withItemCommentLink url fi = +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}@@ -559,17 +560,17 @@ 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 = +withItemEnclosure :: String -> Maybe String -> ItemSetter (Maybe Integer)+withItemEnclosure url ty mb_len fi = case fi of- Feed.Types.AtomItem e -> Feed.Types.AtomItem + Feed.Types.AtomItem e -> Feed.Types.AtomItem e{Atom.entryLinks=((nullLink url){linkRel=Just (Left "enclosure") ,linkType=ty- ,linkLength=Just (show len)+ ,linkLength=fmap show mb_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 + Feed.Types.RSSItem i{RSS.rssItemEnclosure=Just (nullEnclosure url mb_len (fromMaybe "text/html" ty))}+ Feed.Types.RSS1Item i -> Feed.Types.RSS1Item i{RSS1.itemContent=nullContentInfo{ contentURI=Just url , contentFormat=ty }:RSS1.itemContent i}@@ -586,7 +587,7 @@ -- | '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 = +withItemId isURL idS fi = case fi of Feed.Types.AtomItem e -> Feed.Types.AtomItem e{Atom.entryId=idS}@@ -608,7 +609,7 @@ -- | 'withItemDescription desc' associates a new descriptive string (aka summary) -- with a feed item. withItemDescription :: ItemSetter String-withItemDescription desc fi = +withItemDescription desc fi = case fi of Feed.Types.AtomItem e -> Feed.Types.AtomItem e{Atom.entrySummary=Just (TextString desc)}@@ -625,7 +626,7 @@ -- | 'withItemRights rightStr' associates the rights information 'rightStr' -- with a feed item. withItemRights :: ItemSetter String-withItemRights desc fi = +withItemRights desc fi = case fi of Feed.Types.AtomItem e -> Feed.Types.AtomItem e{Atom.entryRights=Just (TextString desc)}@@ -646,7 +647,7 @@ -- | 'withItemTitle myLink' associates a new URL, 'myLink', -- with a feed item. withItemLink :: ItemSetter URLString-withItemLink url fi = +withItemLink url fi = case fi of Feed.Types.AtomItem e -> Feed.Types.AtomItem e{Atom.entryLinks=replaceAlternate url (Atom.entryLinks e)}@@ -661,31 +662,31 @@ i where replaceAlternate _ [] = []- replaceAlternate x (lr:xs) + 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 = +withItemCategories cats fi = case fi of- Feed.Types.AtomItem e -> Feed.Types.AtomItem + 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 + 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 + 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 -> + foldr (\ (t,mb) acc -> addChild (unode "category" (fromMaybe (\x -> [x]) (fmap (\v -> (\ x -> [Attr (unqual "domain") v,x])) mb) $@@ -697,12 +698,12 @@ -- helpers.. filterChildren :: (XML.Element -> Bool) -> XML.Element -> XML.Element-filterChildren pre e = +filterChildren pre e = case elContent e of [] -> e cs -> e { elContent = mapMaybe filterElt cs } where- filterElt xe@(XML.Elem el) + filterElt xe@(XML.Elem el) | pre el = Just xe | otherwise = Nothing filterElt xe = Just xe@@ -713,7 +714,7 @@ mapMaybeChildren :: (XML.Element -> Maybe XML.Element) -> XML.Element -> XML.Element-mapMaybeChildren f e = +mapMaybeChildren f e = case elContent e of [] -> e cs -> e { elContent = map procElt cs }
Text/Feed/Export.hs view
@@ -1,17 +1,19 @@ -------------------------------------------------------------------- -- | -- Module : Text.Feed.Export--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Description: Convert from Feeds to XML. --+-- Convert from Feeds to XML.+-- -------------------------------------------------------------------- -module Text.Feed.Export +module Text.Feed.Export ( Text.Feed.Export.xmlFeed -- :: Feed -> XML.Element ) where @@ -32,4 +34,3 @@ RSSFeed f -> RSS.xmlRSS f RSS1Feed f -> RSS1.xmlFeed f XMLFeed e -> e -- that was easy!-
Text/Feed/Import.hs view
@@ -1,19 +1,21 @@ -------------------------------------------------------------------- -- | -- Module : Text.Feed.Import--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Description: Convert from XML to Feeds. --+-- Convert from XML to Feeds.+-- -------------------------------------------------------------------- module Text.Feed.Import ( parseFeedFromFile -- :: FilePath -> IO Feed , parseFeedString -- :: String -> IO Feed- + -- if you know your format, use these directly: , readRSS2 -- :: XML.Element -> Maybe Feed , readRSS1 -- :: XML.Element -> Maybe Feed@@ -26,10 +28,11 @@ import Text.Feed.Types import Text.XML.Light as XML+import Text.XML.Light.Lexer ( XmlSource ) import Control.Monad -import System.IO.UTF8 as UTF8 ( readFile ) +import System.IO.UTF8 as UTF8 ( readFile ) -- | 'parseFeedFromFile fp' reads in the contents of the file at @fp@; -- the assumed encoding is UTF-8.@@ -40,19 +43,27 @@ Nothing -> fail ("parseFeedFromFile: not a well-formed XML content in: " ++ fp) Just f -> return f --- | 'parseFeedString str' tries to parse the string @str@ as --- one of the feed formats. First as Atom, then RSS2 before+-- | 'parseFeedWithParser tries to parse the string @str@+-- as one of the feed formats. First as Atom, then RSS2 before -- giving RSS1 a try. @Nothing@ is, rather unhelpfully, returned -- as an indication of error.-parseFeedString :: String -> Maybe Feed-parseFeedString str =- case parseXMLDoc str of+parseFeedWithParser :: XmlSource s => (s -> Maybe Element) -> s -> Maybe Feed+parseFeedWithParser parser str =+ case parser str of Nothing -> Nothing- Just e ->+ Just e -> readAtom e `mplus` readRSS2 e `mplus` readRSS1 e `mplus` Just (XMLFeed e)+++-- | 'parseFeedString str' tries to parse the string @str@ as+-- one of the feed formats. First as Atom, then RSS2 before+-- giving RSS1 a try. @Nothing@ is, rather unhelpfully, returned+-- as an indication of error.+parseFeedString :: String -> Maybe Feed+parseFeedString = parseFeedWithParser parseXMLDoc -- | 'readRSS2 elt' tries to derive an RSS2.x, RSS-0.9x feed document -- from the XML element @e@.
Text/Feed/Query.hs view
@@ -1,12 +1,13 @@ -------------------------------------------------------------------- -- | -- Module : Text.Feed.Query--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Portability:+-- Portability: portable -- -------------------------------------------------------------------- @@ -32,7 +33,8 @@ , ItemGetter -- type _ a = Item -> Maybe a , getItemTitle -- :: ItemGetter (String) , getItemLink -- :: ItemGetter (String)- , getItemPublishDate -- :: ItemGetter (DateString)+ , getItemPublishDate -- :: Data.Time.ParseTime t => ItemGetter (Maybe t)+ , getItemPublishDateString -- :: ItemGetter (DateString) , getItemDate -- :: ItemGetter (DateString) , getItemAuthor -- :: ItemGetter (String) , getItemCommentLink -- :: ItemGetter (URLString)@@ -55,10 +57,14 @@ import Text.DublinCore.Types +import Control.Monad ( mplus ) import Data.List import Data.Maybe---import Debug.Trace +-- for getItemPublishDate rfc822 date parsing.+import System.Locale ( rfc822DateFormat, iso8601DateFormat, defaultTimeLocale )+import Data.Time.Format ( ParseTime, parseTime )+ feedItems :: Feed.Feed -> [Feed.Item] feedItems fe = case fe of@@ -74,18 +80,15 @@ type FeedGetter a = Feed.Feed -> Maybe a -getFeedAuthor :: Feed.Feed -> (Maybe String)+getFeedAuthor :: FeedGetter String getFeedAuthor ft = case ft of- Feed.AtomFeed f -> case Atom.feedAuthors f of { [] -> Nothing; (x:_) -> Just (Atom.personName x)}+ Feed.AtomFeed f -> fmap Atom.personName $ listToMaybe $ Atom.feedAuthors f Feed.RSSFeed f -> RSS.rssEditor (RSS.rssChannel f)- Feed.RSS1Feed f -> - case filter isAuthor $ RSS1.channelDC (RSS1.feedChannel f) of- (dci:_) -> Just (dcText dci)- _ -> Nothing+ Feed.RSS1Feed f -> fmap dcText $ listToMaybe $ filter isAuthor $ RSS1.channelDC (RSS1.feedChannel f) Feed.XMLFeed f -> case findElement (unqual "channel") f of- Just e1 -> (fmap XML.strContent $ findElement (unqual "editor") e1)+ Just e1 -> fmap XML.strContent $ findElement (unqual "editor") e1 Nothing -> Nothing where isAuthor dc = dcElt dc == DC_Creator@@ -93,7 +96,7 @@ getFeedTitle :: Feed.Feed -> String getFeedTitle ft = case ft of- Feed.AtomFeed f -> (contentToStr $ Atom.feedTitle f)+ Feed.AtomFeed f -> contentToStr $ Atom.feedTitle f Feed.RSSFeed f -> RSS.rssTitle (RSS.rssChannel f) Feed.RSS1Feed f -> RSS1.channelTitle (RSS1.feedChannel f) Feed.XMLFeed f ->@@ -104,10 +107,7 @@ getFeedHome :: FeedGetter URLString getFeedHome ft = case ft of- Feed.AtomFeed f ->- case filter isSelf (Atom.feedLinks f) of- (l:_) -> Just (Atom.linkHref l)- _ -> Nothing+ Feed.AtomFeed f -> fmap Atom.linkHref $ listToMaybe $ filter isSelf (Atom.feedLinks f) Feed.RSSFeed f -> Just (RSS.rssLink (RSS.rssChannel f)) Feed.RSS1Feed f -> Just (RSS1.channelURI (RSS1.feedChannel f)) Feed.XMLFeed f ->@@ -120,17 +120,14 @@ getFeedHTML :: FeedGetter URLString getFeedHTML ft = case ft of- Feed.AtomFeed f -> - case filter isSelf (Atom.feedLinks f) of- (l:_) -> Just (Atom.linkHref l)- _ -> Nothing+ Feed.AtomFeed f -> fmap Atom.linkHref $ listToMaybe $ filter isSelf (Atom.feedLinks f) Feed.RSSFeed f -> Just (RSS.rssLink (RSS.rssChannel f)) Feed.RSS1Feed f -> Just (RSS1.channelURI (RSS1.feedChannel f))- Feed.XMLFeed f -> + Feed.XMLFeed f -> case findElement (unqual "channel") f of Just e1 -> fmap XML.strContent $ findElement (unqual "link") e1 Nothing -> Nothing- where + where isSelf lr = toStr (Atom.linkRel lr) == "alternate" && isHTMLType (linkType lr) isHTMLType (Just str) = "lmth" `isPrefixOf` (reverse str)@@ -142,7 +139,7 @@ Feed.AtomFeed f -> fmap contentToStr (Atom.feedSubtitle f) Feed.RSSFeed f -> Just $ RSS.rssDescription (RSS.rssChannel f) Feed.RSS1Feed f -> Just (RSS1.channelDesc (RSS1.feedChannel f))- Feed.XMLFeed f -> + Feed.XMLFeed f -> case findElement (unqual "channel") f of Just e1 -> fmap XML.strContent $ findElement (unqual "description") e1 Nothing -> Nothing@@ -152,11 +149,8 @@ case ft of Feed.AtomFeed f -> Just $ Atom.feedUpdated f Feed.RSSFeed f -> RSS.rssPubDate (RSS.rssChannel f)- Feed.RSS1Feed f -> - case filter isDate (RSS1.channelDC $ RSS1.feedChannel f) of- (l:_) -> Just (dcText l)- _ -> Nothing- Feed.XMLFeed f -> + Feed.RSS1Feed f -> fmap dcText $ listToMaybe $ filter isDate (RSS1.channelDC $ RSS1.feedChannel f)+ Feed.XMLFeed f -> case findElement (unqual "channel") f of Just e1 -> fmap XML.strContent $ findElement (unqual "pubDate") e1 Nothing -> Nothing@@ -168,11 +162,8 @@ case ft of Feed.AtomFeed f -> Just $ Atom.feedUpdated f Feed.RSSFeed f -> RSS.rssPubDate (RSS.rssChannel f)- Feed.RSS1Feed f -> - case filter isDate (RSS1.channelDC $ RSS1.feedChannel f) of- (l:_) -> Just (dcText l)- _ -> Nothing- Feed.XMLFeed f -> + Feed.RSS1Feed f -> fmap dcText $ listToMaybe $ filter isDate (RSS1.channelDC $ RSS1.feedChannel f)+ Feed.XMLFeed f -> case findElement (unqual "channel") f of Just e1 -> fmap XML.strContent $ findElement (unqual "pubDate") e1 Nothing -> Nothing@@ -197,13 +188,10 @@ getFeedLanguage :: FeedGetter String getFeedLanguage ft = case ft of- Feed.AtomFeed f -> + Feed.AtomFeed f -> lookupAttr (unqual "lang"){qPrefix=Just "xml"} (Atom.feedAttrs f) Feed.RSSFeed f -> RSS.rssLanguage (RSS.rssChannel f)- Feed.RSS1Feed f -> - case filter isLang (RSS1.channelDC $ RSS1.feedChannel f) of- (l:_) -> Just (dcText l)- _ -> Nothing+ Feed.RSS1Feed f -> fmap dcText $ listToMaybe $ filter isLang (RSS1.channelDC $ RSS1.feedChannel f) Feed.XMLFeed f -> do ch <- findElement (unqual "channel") f e1 <- findElement (unqual "language") ch@@ -217,10 +205,10 @@ case ft of Feed.AtomFeed f -> map (\ c -> (Atom.catTerm c, Atom.catScheme c)) (Atom.feedCategories f) Feed.RSSFeed f -> map (\ c -> (RSS.rssCategoryValue c, RSS.rssCategoryDomain c)) (RSS.rssCategories (RSS.rssChannel f))- Feed.RSS1Feed f -> + Feed.RSS1Feed f -> case filter isCat (RSS1.channelDC $ RSS1.feedChannel f) of ls -> map (\ l -> (dcText l,Nothing)) ls- Feed.XMLFeed f -> + Feed.XMLFeed f -> case fromMaybe [] $ fmap (XML.findElements (XML.unqual "category")) (findElement (unqual "channel") f) of ls -> map (\ l -> (fromMaybe "" (fmap XML.strContent $ findElement (unqual "term") l), findAttr (unqual "domain") l)) ls where@@ -233,10 +221,7 @@ gen <- Atom.feedGenerator f Atom.genURI gen Feed.RSSFeed f -> RSS.rssGenerator (RSS.rssChannel f)- Feed.RSS1Feed f -> - case filter isSource (RSS1.channelDC (RSS1.feedChannel f)) of- (l:_) -> Just (dcText l)- _ -> Nothing+ Feed.RSS1Feed f -> fmap dcText $ listToMaybe $ filter isSource (RSS1.channelDC (RSS1.feedChannel f)) Feed.XMLFeed f -> do ch <- findElement (unqual "channel") f e1 <- findElement (unqual "generator") ch@@ -247,7 +232,7 @@ type ItemGetter a = Feed.Item -> Maybe a getItemTitle :: ItemGetter String-getItemTitle it = +getItemTitle it = case it of Feed.AtomItem i -> Just (contentToStr $ Atom.entryTitle i) Feed.RSSItem i -> RSS.rssItemTitle i@@ -257,11 +242,8 @@ getItemLink :: ItemGetter String getItemLink it = case it of- Feed.AtomItem i -> -- look up the 'alternate' HTML link relation on the entry:- case filter isSelf $ Atom.entryLinks i of- (l:_) -> Just (Atom.linkHref l)- _ -> Nothing+ Feed.AtomItem i -> fmap Atom.linkHref $ listToMaybe $ filter isSelf $ Atom.entryLinks i Feed.RSSItem i -> RSS.rssItemLink i Feed.RSS1Item i -> Just (RSS1.itemLink i) Feed.XMLItem i -> fmap (\ ei -> XML.strContent ei) $ findElement (unqual "link") i@@ -272,85 +254,100 @@ isHTMLType _ = True -- if none given, assume html. -getItemPublishDate :: ItemGetter DateString-getItemPublishDate it =+-- | 'getItemPublishDate item' returns the publication date of the item,+-- but first parsed per the supported RFC 822 and RFC 3339 formats.+--+-- If the date string cannot be parsed as such, Just Nothing is+-- returned. The caller must then instead fall back to processing the+-- date string from 'getItemPublishDateString'.+--+-- The parsed date representation is one of the ParseTime instances;+-- see 'Data.Time.Format'.+getItemPublishDate :: ParseTime t => ItemGetter (Maybe t)+getItemPublishDate it = do+ ds <- getItemPublishDateString it+ let+ rfc3339DateFormat1 = iso8601DateFormat (Just "%H:%M:%S%Z")+ rfc3339DateFormat2 = iso8601DateFormat (Just "%H:%M:%S%Q%Z")++ formats = [ rfc3339DateFormat1, rfc3339DateFormat2, rfc822DateFormat ]++ date = foldl1 mplus (map (\ fmt -> parseTime defaultTimeLocale fmt ds) formats)+ return date++getItemPublishDateString :: ItemGetter DateString+getItemPublishDateString it = case it of Feed.AtomItem i -> Just $ Atom.entryUpdated i Feed.RSSItem i -> RSS.rssItemPubDate i- Feed.RSS1Item i -> - case filter isDate $ RSS1.itemDC i of- (dci:_) -> Just (dcText dci)- _ -> Nothing+ Feed.RSS1Item i -> fmap dcText $ listToMaybe $ filter isDate $ RSS1.itemDC i -- ToDo: look for it in Atom \/ RSS1 like-content as well if no 'pubDate' element. Feed.XMLItem e -> fmap XML.strContent $ findElement (unqual "pubDate") e where isDate dc = dcElt dc == DC_Date getItemDate :: ItemGetter DateString-getItemDate it = getItemPublishDate it+getItemDate it = getItemPublishDateString it +-- | 'getItemAuthor f' returns the optional author of the item. getItemAuthor :: ItemGetter String-getItemAuthor it = +getItemAuthor it = case it of- Feed.AtomItem i -> case Atom.entryAuthors i of { [] -> Nothing; (x:_) -> Just (Atom.personName x)}+ Feed.AtomItem i -> fmap Atom.personName $ listToMaybe $ Atom.entryAuthors i Feed.RSSItem i -> RSS.rssItemAuthor i- Feed.RSS1Item i -> - case filter isAuthor $ RSS1.itemDC i of- (dci:_) -> Just (dcText dci)- _ -> Nothing+ Feed.RSS1Item i -> fmap dcText $ listToMaybe $ filter isAuthor $ RSS1.itemDC i Feed.XMLItem e -> fmap XML.strContent $ findElement (unqual "author") e where isAuthor dc = dcElt dc == DC_Creator getItemCommentLink :: ItemGetter URLString-getItemCommentLink it = +getItemCommentLink it = case it of- Feed.AtomItem e -> -- look up the 'replies' HTML link relation on the entry:- case filter isReplies $ Atom.entryLinks e of- (l:_) -> Just (Atom.linkHref l)- _ -> Nothing+ Feed.AtomItem e -> fmap Atom.linkHref $ listToMaybe $ filter isReplies $ Atom.entryLinks e Feed.RSSItem i -> RSS.rssItemComments i- Feed.RSS1Item i -> - case filter isRel $ RSS1.itemDC i of- (l:_) -> Just (dcText l)- _ -> Nothing+ Feed.RSS1Item i -> fmap dcText $ listToMaybe $ filter isRel $ RSS1.itemDC i Feed.XMLItem i -> fmap (\ ei -> XML.strContent ei) $ findElement (unqual "comments") i where isReplies lr = toStr (Atom.linkRel lr) == "replies" isRel dc = dcElt dc == DC_Relation -getItemEnclosure :: ItemGetter (String, Maybe String, Integer)-getItemEnclosure it = +getItemEnclosure :: ItemGetter (String, Maybe String, Maybe Integer)+getItemEnclosure it = case it of Feed.AtomItem e -> case filter isEnc $ Atom.entryLinks e of- (l:_) -> Just (Atom.linkHref l, Atom.linkType l, - case Atom.linkLength l of - Nothing -> 0- Just x -> - case reads x of { [] -> 0; ((v,_):_) -> v })+ (l:_) -> Just (Atom.linkHref l,+ Atom.linkType l,+ readLength (Atom.linkLength l)) _ -> Nothing Feed.RSSItem i ->- fmap (\ e -> (RSS.rssEnclosureURL e, Just (RSS.rssEnclosureType e), RSS.rssEnclosureLength e)) + fmap (\ e -> (RSS.rssEnclosureURL e, Just (RSS.rssEnclosureType e), RSS.rssEnclosureLength e)) (RSS.rssItemEnclosure i)- Feed.RSS1Item i -> + Feed.RSS1Item i -> case RSS1.itemContent i of [] -> Nothing- (c:_) -> Just (fromMaybe "" (RSS1.contentURI c), RSS1.contentFormat c, 0)- Feed.XMLItem e -> fmap toV (findElement (unqual "enclosure") e)+ (c:_) -> Just (fromMaybe "" (RSS1.contentURI c), RSS1.contentFormat c, Nothing)+ Feed.XMLItem e -> fmap xmlToEnclosure (findElement (unqual "enclosure") e) where isEnc lr = toStr (Atom.linkRel lr) == "enclosure" - toV e = ( fromMaybe "" (fmap XML.strContent (findElement (unqual "url") e))- , fmap XML.strContent (findElement (unqual "type") e)- , fromMaybe 0 (fmap (read . XML.strContent) (findElement (unqual "length") e))- )+ readLength Nothing = Nothing+ readLength (Just str) =+ case reads str of+ [] -> Nothing+ ((v,_):_) -> Just v + xmlToEnclosure e =+ ( fromMaybe "" (findAttr (unqual "url") e)+ , findAttr (unqual "type") e+ , readLength $ findAttr (unqual "length") e+ )+ getItemFeedLink :: ItemGetter URLString-getItemFeedLink it = +getItemFeedLink it = case it of- Feed.AtomItem e -> + Feed.AtomItem e -> case (Atom.entrySource e) of Nothing -> Nothing Just s -> Atom.sourceId s@@ -359,30 +356,30 @@ Nothing -> Nothing Just s -> Just (RSS.rssSourceURL s) Feed.RSS1Item _ -> Nothing- Feed.XMLItem e -> + Feed.XMLItem e -> case findElement (unqual "source") e of Nothing -> Nothing Just s -> fmap XML.strContent (findElement (unqual "url") s) getItemId :: ItemGetter (Bool,String)-getItemId it = +getItemId it = case it of Feed.AtomItem e -> Just (True, Atom.entryId e)- Feed.RSSItem i -> + Feed.RSSItem i -> case RSS.rssItemGuid i of Nothing -> Nothing Just ig -> Just (fromMaybe True (RSS.rssGuidPermanentURL ig), RSS.rssGuidValue ig)- Feed.RSS1Item i -> + Feed.RSS1Item i -> case filter isId (RSS1.itemDC i) of (l:_) -> Just (True,dcText l) _ -> Nothing- Feed.XMLItem e -> + Feed.XMLItem e -> fmap (\ e1 -> (True,XML.strContent e1)) (findElement (unqual "guid") e) where isId dc = dcElt dc == DC_Identifier getItemCategories :: Feed.Item -> [String]-getItemCategories it = +getItemCategories it = case it of Feed.AtomItem i -> map Atom.catTerm $ Atom.entryCategories i Feed.RSSItem i -> map RSS.rssCategoryValue $ RSS.rssItemCategories i@@ -390,19 +387,16 @@ Feed.XMLItem i -> map XML.strContent $ XML.findElements (XML.unqual "category") i where -- get RSS1 categories; either via DublinCore's subject (or taxonomy topics...not yet.)- getCats1 i1 = + getCats1 i1 = map (words.dcText) $ filter (\ dc -> dcElt dc == DC_Subject) $ RSS1.itemDC i1 getItemRights :: ItemGetter String-getItemRights it = +getItemRights it = case it of Feed.AtomItem e -> fmap contentToStr $ Atom.entryRights e Feed.RSSItem _ -> Nothing- Feed.RSS1Item i ->- case filter isRights (RSS1.itemDC i) of- (l:_) -> Just (dcText l)- _ -> Nothing+ Feed.RSS1Item i -> fmap dcText $ listToMaybe $ filter isRights (RSS1.itemDC i) Feed.XMLItem _ -> Nothing where isRights dc = dcElt dc == DC_Rights@@ -411,7 +405,7 @@ getItemSummary it = getItemDescription it getItemDescription :: ItemGetter String-getItemDescription it = +getItemDescription it = case it of Feed.AtomItem e -> fmap contentToStr $ Atom.entrySummary e Feed.RSSItem e -> RSS.rssItemDescription e@@ -425,7 +419,7 @@ toStr (Just (Right x)) = x contentToStr :: TextContent -> String-contentToStr x = +contentToStr x = case x of Atom.TextString s -> s Atom.HTMLString s -> s
Text/Feed/Translate.hs view
@@ -1,17 +1,17 @@ -------------------------------------------------------------------- -- |--- Module : Text.Feed.Translate --- Copyright : (c) Galois, Inc. 2008+-- Module : Text.Feed.Translate+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Portability:---+-- Portability: portable -- -- Translating between RSS formats; work in progress. ---module Text.Feed.Translate +module Text.Feed.Translate ( translateItemTo -- :: FeedKind -> Item -> Item , withAtomEntry -- :: (Atom.Entry -> Atom.Entry) -> Item -> Item , withRSSItem -- :: (RSS.RSSItem -> RSS.RSSItem) -> Item -> Item@@ -30,29 +30,29 @@ -- 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 +-- format is performed; the caller is responsible -- withAtomEntry :: (Atom.Entry -> Atom.Entry) -> Item -> Item-withAtomEntry f it = +withAtomEntry f it = case it of Feed.AtomItem e -> Feed.AtomItem (f e) _ -> it withRSSItem :: (RSS.RSSItem -> RSS.RSSItem) -> Item -> Item-withRSSItem f it = +withRSSItem f it = case it of Feed.RSSItem e -> Feed.RSSItem (f e) _ -> it withRSS1Item :: (RSS1.Item -> RSS1.Item) -> Item -> Item-withRSS1Item f it = +withRSS1Item f it = case it of Feed.RSS1Item e -> Feed.RSS1Item (f e) _ -> it translateItemTo :: FeedKind -> Item -> Item-translateItemTo fk it = +translateItemTo fk it = case fk of AtomKind -> toAtomItem it RSSKind v -> toRSSItem v it@@ -65,20 +65,20 @@ toRDFItem = error "toRDFItem: unimplemented" toAtomItem :: Item -> Item-toAtomItem it = +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 = + outIt = (flip withAtomEntry) (newItem AtomKind) (\ e -> e{ Atom.entryOther = RSS.rssItemOther ri , Atom.entryAttrs = RSS.rssItemAttrs ri }) - pipeline_rss_atom = + pipeline_rss_atom = [ mb withItemTitle (rssItemTitle ri) , mb withItemLink (rssItemLink ri) , mb withItemDescription (rssItemDescription ri)@@ -89,8 +89,8 @@ , mb withItemEnclosure' (rssItemEnclosure ri) , mb withItemPubDate (rssItemPubDate ri) ]- - withItemEnclosure' e = ++ withItemEnclosure' e = withItemEnclosure (rssEnclosureURL e) (Just $ rssEnclosureType e) (rssEnclosureLength e)@@ -98,7 +98,7 @@ 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)
Text/Feed/Types.hs view
@@ -1,12 +1,13 @@ -------------------------------------------------------------------- -- | -- Module : Text.Feed.Types--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Portability:+-- Portability: portable -- --------------------------------------------------------------------
Text/Feed/Util.hs view
@@ -1,12 +1,13 @@ -------------------------------------------------------------------- -- | -- Module : Text.Feed.Util--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Portability:+-- Portability: portable -- -------------------------------------------------------------------- module Text.Feed.Util where
Text/RSS/Export.hs view
@@ -1,10 +1,11 @@ -------------------------------------------------------------------- -- | -- Module : Text.RSS.Export--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional -- Description: Convert from RSS to XML --
Text/RSS/Import.hs view
@@ -1,13 +1,15 @@ -------------------------------------------------------------------- -- | -- Module : Text.RSS.Import--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Description: Converting from XML to RSS --+-- Converting from XML to RSS+-- -------------------------------------------------------------------- module Text.RSS.Import where@@ -16,7 +18,7 @@ import Text.RSS1.Utils ( dcNS, dcPrefix ) import Text.XML.Light as XML -import Data.Maybe (listToMaybe, mapMaybe)+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Char (isSpace ) import Control.Monad (guard,mplus) @@ -59,7 +61,7 @@ let es = children e let as = elAttribs e v <- pAttr "version" e- ch <- pNode "channel" es >>= elementToChannel + ch <- pNode "channel" es >>= elementToChannel return RSS { rssVersion = v , rssAttrs = filter (\ a -> not (qName (attrKey a) `elem` known_attrs)) as@@ -75,11 +77,11 @@ let es = children e title <- pLeaf "title" es link <- pLeaf "link" es- desc <- pLeaf "description" es return RSSChannel { rssTitle = title , rssLink = link- , rssDescription = desc+ -- being liberal, <description/> is a required channel element.+ , rssDescription = fromMaybe title (pLeaf "description" es) , rssItems = pMany "item" elementToItem es , rssLanguage = pLeaf "language" es `mplus` pQLeaf (dcName "lang") es , rssCopyright = pLeaf "copyright" es@@ -205,11 +207,10 @@ let as = elAttribs e url <- pAttr "url" e ty <- pAttr "type" e- len <- pAttr "length" e >>= readInt return RSSEnclosure { rssEnclosureURL = url , rssEnclosureType = ty- , rssEnclosureLength = len+ , rssEnclosureLength = pAttr "length" e >>= readInt , rssEnclosureAttrs = filter (\ a -> not (qName (attrKey a) `elem` known_attrs)) as } where@@ -262,13 +263,13 @@ ---- readInt :: String -> Maybe Integer-readInt s = +readInt s = case reads s of ((x,_):_) -> Just x _ -> Nothing readBool :: String -> Maybe Bool-readBool s = +readBool s = case dropWhile isSpace s of 't':'r':'u':'e':_ -> Just True 'f':'a':'l':'s':'e':_ -> Just False
Text/RSS/Syntax.hs view
@@ -1,13 +1,16 @@ -------------------------------------------------------------------- -- | -- Module : Text.RSS.Syntax--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Description: The basic syntax for putting together feeds. For instance,--- to create a feed with a single item item:+--+-- The basic syntax for putting together feeds.+--+-- For instance, to create a feed with a single item item: -- (nullRSS \"rss title\" \"link\") {rssChannel=(nullChannel \"channel title\" \"link\") {rssItems=[(nullItem \"item title\")]}} --------------------------------------------------------------------@@ -32,7 +35,7 @@ type URLString = String -- | RFC 822 conforming.-type DateString = String +type DateString = String data RSSChannel = RSSChannel@@ -88,7 +91,7 @@ data RSSEnclosure = RSSEnclosure { rssEnclosureURL :: URLString- , rssEnclosureLength :: Integer+ , rssEnclosureLength :: Maybe Integer , rssEnclosureType :: String , rssEnclosureAttrs :: [XML.Attr] }@@ -150,8 +153,8 @@ nullRSS :: String -- ^channel title -> URLString -- ^channel link -> RSS-nullRSS title link = - RSS +nullRSS title link =+ RSS { rssVersion = "2.0" , rssAttrs = [] , rssChannel = nullChannel title link@@ -161,7 +164,7 @@ nullChannel :: String -- ^rssTitle -> URLString -- ^rssLink -> RSSChannel-nullChannel title link = +nullChannel title link = RSSChannel { rssTitle = title , rssLink = link@@ -188,7 +191,7 @@ nullItem :: String -- ^title -> RSSItem-nullItem title = +nullItem title = RSSItem { rssItemTitle = Just title , rssItemLink = Nothing@@ -207,28 +210,28 @@ nullSource :: URLString -- ^source URL -> String -- ^title -> RSSSource-nullSource url title = +nullSource url title = RSSSource { rssSourceURL = url , rssSourceAttrs = [] , rssSourceTitle = title } -nullEnclosure :: URLString -- ^enclosure URL- -> Integer -- ^enclosure length- -> String -- ^enclosure type+nullEnclosure :: URLString -- ^enclosure URL+ -> Maybe Integer -- ^enclosure length+ -> String -- ^enclosure type -> RSSEnclosure-nullEnclosure url len ty = +nullEnclosure url mb_len ty = RSSEnclosure { rssEnclosureURL = url- , rssEnclosureLength = len+ , rssEnclosureLength = mb_len , rssEnclosureType = ty , rssEnclosureAttrs = [] } newCategory :: String -- ^category Value -> RSSCategory-newCategory nm = +newCategory nm = RSSCategory { rssCategoryDomain = Nothing , rssCategoryAttrs = []@@ -237,7 +240,7 @@ nullGuid :: String -- ^guid value -> RSSGuid-nullGuid v = +nullGuid v = RSSGuid { rssGuidPermanentURL = Nothing , rssGuidAttrs = []@@ -252,7 +255,7 @@ -> String -- ^imageTitle -> URLString -- ^imageLink -> RSSImage-nullImage url title link = +nullImage url title link = RSSImage { rssImageURL = url , rssImageTitle = title@@ -264,7 +267,7 @@ } nullCloud :: RSSCloud-nullCloud = +nullCloud = RSSCloud { rssCloudDomain = Nothing , rssCloudPort = Nothing@@ -278,7 +281,7 @@ -> String -- ^inputName -> URLString -- ^inputLink -> RSSTextInput-nullTextInput title nm link = +nullTextInput title nm link = RSSTextInput { rssTextInputTitle = title , rssTextInputDesc = title
Text/RSS1/Export.hs view
@@ -1,12 +1,13 @@ -------------------------------------------------------------------- -- | -- Module : Text.RSS1.Export--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Portability:+-- Portability: portable -- -------------------------------------------------------------------- @@ -23,15 +24,15 @@ import Data.Maybe qualNode :: (Maybe String,Maybe String) -> String -> [XML.Content] -> XML.Element-qualNode ns n cs = - blank_element +qualNode ns n cs =+ blank_element { elName = qualName ns n , elContent = cs } --- xmlFeed :: Feed -> XML.Element-xmlFeed f = +xmlFeed f = (qualNode (rdfNS,rdfPrefix) "RDF" $ map Elem $ (concat [ [xmlChannel (feedChannel f)] , mb xmlImage (feedImage f)@@ -41,29 +42,29 @@ , feedOther f ] )) -- should we expect these to be derived by the XML pretty printer..?- { elAttribs = nub $ + { elAttribs = nub $ Attr (qualName (Nothing,Nothing) "xmlns") (fromJust rss10NS) :- Attr (qualName (Nothing,Just "xmlns") (fromJust rdfPrefix)) (fromJust rdfNS) : - Attr (qualName (Nothing,Just "xmlns") (fromJust synPrefix)) (fromJust synNS) : - Attr (qualName (Nothing,Just "xmlns") (fromJust taxPrefix)) (fromJust taxNS) : - Attr (qualName (Nothing,Just "xmlns") (fromJust conPrefix)) (fromJust conNS) : - Attr (qualName (Nothing,Just "xmlns") (fromJust dcPrefix)) (fromJust dcNS) : + Attr (qualName (Nothing,Just "xmlns") (fromJust rdfPrefix)) (fromJust rdfNS) :+ Attr (qualName (Nothing,Just "xmlns") (fromJust synPrefix)) (fromJust synNS) :+ Attr (qualName (Nothing,Just "xmlns") (fromJust taxPrefix)) (fromJust taxNS) :+ Attr (qualName (Nothing,Just "xmlns") (fromJust conPrefix)) (fromJust conNS) :+ Attr (qualName (Nothing,Just "xmlns") (fromJust dcPrefix)) (fromJust dcNS) : feedAttrs f} xmlChannel :: Channel -> XML.Element-xmlChannel ch = +xmlChannel ch = (qualNode (rss10NS,Nothing) "channel" $ map Elem $ ([ xmlLeaf (rss10NS,Nothing) "title" (channelTitle ch) , xmlLeaf (rss10NS,Nothing) "link" (channelLink ch) , xmlLeaf (rss10NS,Nothing) "description" (channelDesc ch)- ] ++ - mb xmlTextInputURI (channelTextInputURI ch) ++ - mb xmlImageURI (channelImageURI ch) ++ + ] +++ mb xmlTextInputURI (channelTextInputURI ch) +++ mb xmlImageURI (channelImageURI ch) ++ xmlItemURIs (channelItemURIs ch) ++ map xmlDC (channelDC ch) ++ concat [ mb xmlUpdatePeriod (channelUpdatePeriod ch) , mb xmlUpdateFreq (channelUpdateFreq ch) , mb (xmlLeaf (synNS,synPrefix) "updateBase") (channelUpdateBase ch)- ] ++ + ] ++ xmlContentItems (channelContent ch) ++ xmlTopics (channelTopics ch) ++ channelOther ch))@@ -74,7 +75,7 @@ xmlImageURI u = xmlEmpty (rss10NS,Nothing) "image" [Attr (rdfName "resource") u ] xmlImage :: Image -> XML.Element-xmlImage i = +xmlImage i = (qualNode (rss10NS,Nothing) "image" $ map Elem $ ([ xmlLeaf (rss10NS,Nothing) "title" (imageTitle i) , xmlLeaf (rss10NS,Nothing) "url" (imageURL i)@@ -86,8 +87,8 @@ xmlItemURIs :: [URIString] -> [XML.Element] xmlItemURIs [] = []-xmlItemURIs xs = - [qualNode (rss10NS, Nothing) "items" $ +xmlItemURIs xs =+ [qualNode (rss10NS, Nothing) "items" $ [Elem (qualNode (rdfNS,rdfPrefix) "Seq" (map toRes xs))]] where toRes u = Elem (xmlEmpty (rdfNS,rdfPrefix) "li" [Attr (rdfName "resource") u])@@ -96,7 +97,7 @@ xmlTextInputURI u = xmlEmpty (rss10NS,Nothing) "textinput" [Attr (rdfName "resource") u ] xmlTextInput :: TextInputInfo -> XML.Element-xmlTextInput ti = +xmlTextInput ti = (qualNode (rss10NS, Nothing) "textinput" $ map Elem $ [ xmlLeaf (rss10NS,Nothing) "title" (textInputTitle ti) , xmlLeaf (rss10NS,Nothing) "description" (textInputDesc ti)@@ -112,7 +113,7 @@ xmlUpdatePeriod :: UpdatePeriod -> XML.Element xmlUpdatePeriod u = xmlLeaf (synNS,synPrefix) "updatePeriod" (toStr u) where- toStr ux = + toStr ux = case ux of Update_Hourly -> "hourly" Update_Daily -> "daily"@@ -125,14 +126,14 @@ xmlContentItems :: [ContentInfo] -> [XML.Element] xmlContentItems [] = []-xmlContentItems xs = - [qualNode (conNS,conPrefix) "items" +xmlContentItems xs =+ [qualNode (conNS,conPrefix) "items" [Elem $ qualNode (rdfNS,rdfPrefix) "Bag"- (map (\ e -> Elem (qualNode (rdfNS,rdfPrefix) "li" [Elem (xmlContentInfo e)])) + (map (\ e -> Elem (qualNode (rdfNS,rdfPrefix) "li" [Elem (xmlContentInfo e)])) xs)]] xmlContentInfo :: ContentInfo -> XML.Element-xmlContentInfo ci = +xmlContentInfo ci = (qualNode (conNS,conPrefix) "item" $ map Elem $ (concat [ mb (rdfResource (conNS,conPrefix) "format") (contentFormat ci) , mb (rdfResource (conNS,conPrefix) "encoding") (contentEncoding ci)@@ -148,13 +149,13 @@ xmlTopics :: [URIString] -> [XML.Element] xmlTopics [] = []-xmlTopics xs = +xmlTopics xs = [qualNode (taxNS,taxPrefix) "topics" [Elem (qualNode (rdfNS,rdfPrefix) "Bag" $ (map (Elem . rdfResource (rdfNS,rdfPrefix) "li") xs))]] xmlTopic :: TaxonomyTopic -> XML.Element-xmlTopic tt = +xmlTopic tt = (qualNode (taxNS,taxPrefix) "topic" $ map Elem $ (xmlLeaf (rss10NS,Nothing) "link" (taxonomyLink tt): mb (xmlLeaf (rss10NS,Nothing) "title") (taxonomyTitle tt) ++@@ -165,11 +166,11 @@ {elAttribs=[Attr (rdfName "about") (taxonomyURI tt)]} xmlItem :: Item -> XML.Element-xmlItem i = +xmlItem i = (qualNode (rss10NS,Nothing) "item" $ map Elem $ ([ xmlLeaf (rss10NS,Nothing) "title" (itemTitle i) , xmlLeaf (rss10NS,Nothing) "link" (itemLink i)- ] ++ + ] ++ mb (xmlLeaf (rss10NS,Nothing) "description") (itemDesc i) ++ map xmlDC (itemDC i) ++ xmlTopics (itemTopics i) ++@@ -179,7 +180,7 @@ itemAttrs i)} xmlLeaf :: (Maybe String,Maybe String) -> String -> String -> XML.Element-xmlLeaf ns tg txt = +xmlLeaf ns tg txt = blank_element{ elName = qualName ns tg , elContent = [ Text blank_cdata { cdData = txt } ] }
Text/RSS1/Import.hs view
@@ -1,12 +1,13 @@ -------------------------------------------------------------------- -- | -- Module : Text.RSS1.Import--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Portability:+-- Portability: portable -- --------------------------------------------------------------------
Text/RSS1/Syntax.hs view
@@ -1,12 +1,13 @@ -------------------------------------------------------------------- -- | -- Module : Text.RSS1.Syntax--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Portability:+-- Portability: portable -- -------------------------------------------------------------------- @@ -106,7 +107,7 @@ deriving (Show) -data UpdatePeriod +data UpdatePeriod = Update_Hourly | Update_Daily | Update_Weekly@@ -125,7 +126,7 @@ --default constructors: nullFeed :: URIString -> TitleString -> Feed-nullFeed uri title = +nullFeed uri title = Feed { feedVersion = "1.0" , feedChannel = nullChannel uri title , feedImage = Nothing@@ -137,7 +138,7 @@ } nullChannel :: URIString -> TitleString -> Channel-nullChannel uri title = +nullChannel uri title = Channel { channelURI = uri , channelTitle = title@@ -157,7 +158,7 @@ } nullImage :: URIString -> String -> URIString -> Image-nullImage imguri title link = +nullImage imguri title link = Image { imageURI = imguri , imageTitle = title@@ -169,7 +170,7 @@ } nullItem :: URIString -> TextString -> URIString -> Item-nullItem uri title link = +nullItem uri title link = Item { itemURI = uri , itemTitle = title@@ -196,7 +197,7 @@ } nullTaxonomyTopic :: URIString -> URIString -> TaxonomyTopic-nullTaxonomyTopic uri link = +nullTaxonomyTopic uri link = TaxonomyTopic { taxonomyURI = uri , taxonomyLink = link
Text/RSS1/Utils.hs view
@@ -1,12 +1,13 @@ -------------------------------------------------------------------- -- | -- Module : Text.RSS1.Utils--- Copyright : (c) Galois, Inc. 2008+-- Copyright : (c) Galois, Inc. 2008,+-- (c) Sigbjorn Finne 2009- -- License : BSD3 ----- Maintainer: Sigbjorn Finne <sof@galois.com>+-- Maintainer: Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional--- Portability:+-- Portability: portable -- --------------------------------------------------------------------
feed.cabal view
@@ -1,10 +1,16 @@ Name: feed-Version: 0.3.9.1+Version: 0.3.9.2 License: BSD3 License-file: LICENSE Category: Text Synopsis: Interfacing with RSS (v 0.9x, 2.x, 1.0) + Atom feeds. Description: Interfacing with RSS (v 0.9x, 2.x, 1.0) + Atom feeds.+ .+ To help working with the multiple feed formats we've+ ended up with, this set of modules provides parsers,+ pretty printers and some utility code for querying+ and just generally working with a concrete representation+ of feeds in Haskell. Author: Sigbjorn Finne <sof@forkIO.com> Maintainer: Sigbjorn Finne <sof@forkIO.com> Homepage: https://github.com/sof/feed@@ -40,5 +46,6 @@ old-locale >= 1, old-time >= 1, xml >= 1.2.6,- utf8-string+ utf8-string,+ time
tests/Main.hs view
@@ -1,13 +1,21 @@ module Main where import Text.XML.Light+import Text.Feed.Types import Text.Feed.Import import Text.Feed.Export import System.Environment +pFromFile :: FilePath -> IO Feed+pFromFile fp = do+ ls <- readFile fp+ case parseFeedString ls of+ Nothing -> fail ("parseFeedFromFile: not a well-formed XML content in: " ++ fp)+ Just f -> return f+ main :: IO () main = do (x:_) <- getArgs- feed <- parseFeedFromFile x+ feed <- pFromFile x putStrLn (ppTopElement $ xmlFeed feed)