diff --git a/Text/Atom/Feed.hs b/Text/Atom/Feed.hs --- a/Text/Atom/Feed.hs +++ b/Text/Atom/Feed.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- Stability : provisional --- Portability: +-- Portability: portable -- -------------------------------------------------------------------- @@ -253,7 +254,7 @@ , sourceUpdated = Nothing , sourceOther = [] } - + nullPerson :: Person nullPerson = Person { personName = "" diff --git a/Text/Atom/Feed/Export.hs b/Text/Atom/Feed/Export.hs --- a/Text/Atom/Feed/Export.hs +++ b/Text/Atom/Feed/Export.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- Stability : provisional +-- Portability:: portable -- Description: Convert from Atom to XML +-- +-- Convert from Atom to XML -- -------------------------------------------------------------------- diff --git a/Text/Atom/Feed/Import.hs b/Text/Atom/Feed/Import.hs --- a/Text/Atom/Feed/Import.hs +++ b/Text/Atom/Feed/Import.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- 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 diff --git a/Text/Atom/Feed/Link.hs b/Text/Atom/Feed/Link.hs --- a/Text/Atom/Feed/Link.hs +++ b/Text/Atom/Feed/Link.hs @@ -1,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 +-- Maintainer: Sigbjorn Finne -- 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" diff --git a/Text/Atom/Feed/Validate.hs b/Text/Atom/Feed/Validate.hs --- a/Text/Atom/Feed/Validate.hs +++ b/Text/Atom/Feed/Validate.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- 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)) diff --git a/Text/Atom/Pub.hs b/Text/Atom/Pub.hs --- a/Text/Atom/Pub.hs +++ b/Text/Atom/Pub.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- Stability : provisional --- Portability: +-- Portability: portable -- -- Types for the Atom Publishing Protocol (APP) -- diff --git a/Text/Atom/Pub/Export.hs b/Text/Atom/Pub/Export.hs --- a/Text/Atom/Pub/Export.hs +++ b/Text/Atom/Pub/Export.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- Stability : provisional +-- Portability:: portable -- Description: Serializing APP types (as XML.) +-- +-- Serializing Atom Publishing Protocol types as XML. -- -------------------------------------------------------------------- module Text.Atom.Pub.Export where diff --git a/Text/DublinCore/Types.hs b/Text/DublinCore/Types.hs --- a/Text/DublinCore/Types.hs +++ b/Text/DublinCore/Types.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- Stability : provisional --- Description: Representing the DublinCore metadata elements in Haskell. The Dublin --- Core Metadata Element Set. See: --- +-- +-- Representing the DublinCore metadata elements in Haskell. +-- For information on the Dublin Core Metadata Element Set, +-- see: +-- module Text.DublinCore.Types where --- | A DCItem +-- | A DCItem pairs a specific element with its (string) value. data DCItem = DCItem { dcElt :: DCInfo diff --git a/Text/Feed/Constructor.hs b/Text/Feed/Constructor.hs --- a/Text/Feed/Constructor.hs +++ b/Text/Feed/Constructor.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- 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 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 } diff --git a/Text/Feed/Export.hs b/Text/Feed/Export.hs --- a/Text/Feed/Export.hs +++ b/Text/Feed/Export.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- 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! - diff --git a/Text/Feed/Import.hs b/Text/Feed/Import.hs --- a/Text/Feed/Import.hs +++ b/Text/Feed/Import.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- 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@. diff --git a/Text/Feed/Query.hs b/Text/Feed/Query.hs --- a/Text/Feed/Query.hs +++ b/Text/Feed/Query.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- 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 diff --git a/Text/Feed/Translate.hs b/Text/Feed/Translate.hs --- a/Text/Feed/Translate.hs +++ b/Text/Feed/Translate.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- 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) diff --git a/Text/Feed/Types.hs b/Text/Feed/Types.hs --- a/Text/Feed/Types.hs +++ b/Text/Feed/Types.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- Stability : provisional --- Portability: +-- Portability: portable -- -------------------------------------------------------------------- diff --git a/Text/Feed/Util.hs b/Text/Feed/Util.hs --- a/Text/Feed/Util.hs +++ b/Text/Feed/Util.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- Stability : provisional --- Portability: +-- Portability: portable -- -------------------------------------------------------------------- module Text.Feed.Util where diff --git a/Text/RSS/Export.hs b/Text/RSS/Export.hs --- a/Text/RSS/Export.hs +++ b/Text/RSS/Export.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- Stability : provisional -- Description: Convert from RSS to XML -- diff --git a/Text/RSS/Import.hs b/Text/RSS/Import.hs --- a/Text/RSS/Import.hs +++ b/Text/RSS/Import.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- 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, 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 diff --git a/Text/RSS/Syntax.hs b/Text/RSS/Syntax.hs --- a/Text/RSS/Syntax.hs +++ b/Text/RSS/Syntax.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- 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 diff --git a/Text/RSS1/Export.hs b/Text/RSS1/Export.hs --- a/Text/RSS1/Export.hs +++ b/Text/RSS1/Export.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- 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 } ] } diff --git a/Text/RSS1/Import.hs b/Text/RSS1/Import.hs --- a/Text/RSS1/Import.hs +++ b/Text/RSS1/Import.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- Stability : provisional --- Portability: +-- Portability: portable -- -------------------------------------------------------------------- diff --git a/Text/RSS1/Syntax.hs b/Text/RSS1/Syntax.hs --- a/Text/RSS1/Syntax.hs +++ b/Text/RSS1/Syntax.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- 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 diff --git a/Text/RSS1/Utils.hs b/Text/RSS1/Utils.hs --- a/Text/RSS1/Utils.hs +++ b/Text/RSS1/Utils.hs @@ -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 +-- Maintainer: Sigbjorn Finne -- Stability : provisional --- Portability: +-- Portability: portable -- -------------------------------------------------------------------- diff --git a/feed.cabal b/feed.cabal --- a/feed.cabal +++ b/feed.cabal @@ -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 Maintainer: Sigbjorn Finne 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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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)