feed 0.3.10.2 → 0.3.10.3
raw patch · 11 files changed
+175/−90 lines, 11 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- feed.cabal +1/−1
- src/Text/Atom/Feed/Export.hs +11/−11
- src/Text/Atom/Feed/Import.hs +4/−4
- src/Text/Atom/Feed/Validate.hs +34/−35
- src/Text/Atom/Pub/Export.hs +14/−14
- src/Text/Feed/Query.hs +11/−4
- src/Text/RSS/Export.hs +13/−13
- src/Text/RSS1/Import.hs +3/−3
- src/Text/RSS1/Utils.hs +4/−4
- tests/Text/RSS/Export/Tests.hs +76/−1
CHANGELOG.md view
@@ -1,3 +1,7 @@+#### 0.3.10.3++* RSS Export: avoid <enclosure length="Nothing"> attribute (thanks to Roman Cheplyaka)+ #### 0.3.10.2 * The Atom RFC says that when a link element doesn't specify the "rel"
feed.cabal view
@@ -1,5 +1,5 @@ name: feed-version: 0.3.10.2+version: 0.3.10.3 license: BSD3 license-file: LICENSE category: Text
src/Text/Atom/Feed/Export.hs view
@@ -134,8 +134,8 @@ ++ mb xmlRights (entryRights e) ++ mb xmlSource (entrySource e) ++ mb xmlSummary (entrySummary e)- ++ mb xmlInReplyTo (entryInReplyTo e)- ++ mb xmlInReplyTotal (entryInReplyTotal e)+ ++ mb xmlInReplyTo (entryInReplyTo e)+ ++ mb xmlInReplyTotal (entryInReplyTotal e) ++ entryOther e ) { elAttribs = entryAttrs e }@@ -175,7 +175,7 @@ ++ mb (atomAttr "hreflang") (linkHrefLang l) ++ mb (atomAttr "title") (linkTitle l) ++ mb (atomAttr "length") (linkLength l)- ++ linkAttrs l+ ++ linkAttrs l } xmlSource :: Source -> Element@@ -218,18 +218,18 @@ xmlInReplyTo :: InReplyTo -> XML.Element xmlInReplyTo irt = (atomThreadNode "in-reply-to" (replyToContent irt))- { elAttribs =- mb (atomThreadAttr "ref") (Just $ replyToRef irt)- ++ mb (atomThreadAttr "href") (replyToHRef irt)- ++ mb (atomThreadAttr "type") (replyToType irt)- ++ mb (atomThreadAttr "source") (replyToSource irt)- ++ replyToOther irt- }+ { elAttribs =+ mb (atomThreadAttr "ref") (Just $ replyToRef irt)+ ++ mb (atomThreadAttr "href") (replyToHRef irt)+ ++ mb (atomThreadAttr "type") (replyToType irt)+ ++ mb (atomThreadAttr "source") (replyToSource irt)+ ++ replyToOther irt+ } xmlInReplyTotal :: InReplyTotal -> XML.Element xmlInReplyTotal irt = (atomThreadLeaf "total" (show $ replyToTotal irt))- { elAttribs = replyToTotalOther irt }+ { elAttribs = replyToTotalOther irt } xmlId :: String -> XML.Element xmlId i = atomLeaf "id" i
src/Text/Atom/Feed/Import.hs view
@@ -86,10 +86,10 @@ } where other_es es = filter (\ el -> not (elName el `elem` known_elts))- es+ es other_as as = filter (\ a -> not (attrKey a `elem` known_attrs))- as+ as -- let's have them all (including xml:base and xml:lang + xmlns: stuff) known_attrs = []@@ -182,7 +182,7 @@ } where other_as as = filter (\ a -> not (attrKey a `elem` known_attrs))- as+ as known_attrs = map atomName [ "href", "rel", "type", "hreflang", "title", "length"]@@ -214,7 +214,7 @@ } where other_as as = filter (\ a -> not (attrKey a `elem` known_attrs))- as+ as -- let's have them all (including xml:base and xml:lang + xmlns: stuff) known_attrs = []
src/Text/Atom/Feed/Validate.hs view
@@ -66,10 +66,10 @@ [] -> -- required case pNode "summary" (elChildren e) of Nothing -> demand "Required 'author' element missing (no 'summary' either)"- Just e1 ->- case pNode "author" (elChildren e1) of- Just a -> checkAuthor a- _ -> demand "Required 'author' element missing"+ Just e1 ->+ case pNode "author" (elChildren e1) of+ Just a -> checkAuthor a+ _ -> demand "Required 'author' element missing" xs -> mkTree [] $ map checkAuthor xs @@ -95,10 +95,10 @@ [] -> case pNodes "link" (elChildren e) of [] -> demand ("An 'entry' element with no 'content' element must have at least one 'link-rel' element")- 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+ 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@@ -109,14 +109,14 @@ mapMaybe (\ ex -> fmap (\x -> (ex,x)) $ pAttr "rel" ex) xs of xs1 -> let- jmb (Just x) (Just y) = Just (x,y)- jmb _ _ = Nothing- in+ jmb (Just x) (Just y) = Just (x,y)+ jmb _ _ = Nothing+ in case mapMaybe (\ ex -> pAttr "type" ex `jmb` pAttr "hreflang" ex) xs1 of- 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+ 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 =@@ -179,14 +179,14 @@ [] -> valid (_:xs) | null xs -> valid- | otherwise -> demand ("Expected at most one 'scheme' attribute, found: " ++ show (1+length xs))+ | otherwise -> demand ("Expected at most one 'scheme' attribute, found: " ++ show (1+length xs)) checkLabel e' = case pAttrs "label" e' of [] -> valid (_:xs) | null xs -> valid- | otherwise -> demand ("Expected at most one 'label' attribute, found: " ++ show (1+length xs))+ | otherwise -> demand ("Expected at most one 'label' attribute, found: " ++ show (1+length xs)) checkContent :: Element -> ValidatorResult checkContent e = mkTree (flattenT (mkTree [] [type_valid, src_valid]))@@ -194,27 +194,27 @@ "text" -> case onlyElems (elContent e) of [] -> valid- _ -> demand ("content with type 'text' cannot have child elements, text only.")+ _ -> demand ("content with type 'text' cannot have child elements, text only.") "html" -> case onlyElems (elContent e) of [] -> valid- _ -> demand ("content with type 'html' cannot have child elements, text only.")+ _ -> demand ("content with type 'html' cannot have child elements, text only.") "xhtml" -> case onlyElems (elContent e) of [] -> valid- [_] -> valid -- ToDo: check that it is a 'div'.- _ds -> demand ("content with type 'xhtml' should only contain one 'div' child.")+ [_] -> valid -- ToDo: check that it is a 'div'.+ _ds -> demand ("content with type 'xhtml' should only contain one 'div' child.") _ -> valid] {- case parseMIMEType ty of Nothing -> valid- Just mt- | isXmlType mt -> valid+ Just mt+ | isXmlType mt -> valid | otherwise -> case onlyElems (elContent e) of [] -> valid -- check- _ -> demand ("content with MIME type '" ++ ty ++ "' must only contain base64 data")]+ _ -> demand ("content with MIME type '" ++ ty ++ "' must only contain base64 data")] -} where types = pAttrs "type" e@@ -229,12 +229,12 @@ [] -> valid [_] -> case types of- [] -> advice "It is advisable to provide a 'type' along with a 'src' attribute"- (_:_) -> valid+ [] -> advice "It is advisable to provide a 'type' along with a 'src' attribute"+ (_:_) -> valid {-- case parseMIMEType t of- Just{} -> valid- _ -> demand "The 'type' attribute must be a valid MIME type"+ case parseMIMEType t of+ Just{} -> valid+ _ -> demand "The 'type' attribute must be a valid MIME type" -} ss -> demand ("Expected at most one 'src' attribute, found: " ++ show (length ss)) @@ -244,11 +244,11 @@ | otherwise = (v,valid) {- case parseMIMEType v of- Nothing -> ("text", demand ("Invalid/unknown type value " ++ v))- Just mt ->- case mimeType mt of- Multipart{} -> ("text", demand "Multipart MIME types not a legal 'type'")- _ -> (v, valid)+ Nothing -> ("text", demand ("Invalid/unknown type value " ++ v))+ Just mt ->+ case mimeType mt of+ Multipart{} -> ("text", demand "Multipart MIME types not a legal 'type'")+ _ -> (v, valid) -} where std_types = [ "text", "xhtml", "html"]@@ -292,4 +292,3 @@ (_:xs) | null xs -> valid | otherwise -> demand ("at most one 'uri' expected in 'author' element, found: " ++ show (1+length xs))-
src/Text/Atom/Pub/Export.hs view
@@ -52,27 +52,27 @@ xmlService s = mkElem (appName "service") [xmlns_app,xmlns_atom] (concat [ map xmlWorkspace (serviceWorkspaces s)- , serviceOther s- ])+ , serviceOther s+ ]) xmlWorkspace :: Workspace -> Element xmlWorkspace w = mkElem (appName "workspace") [mkAttr "xml:lang" "en"]- (concat [ [xmlTitle (workspaceTitle w)]- , map xmlCollection (workspaceCols w)- , workspaceOther w- ])+ (concat [ [xmlTitle (workspaceTitle w)]+ , map xmlCollection (workspaceCols w)+ , workspaceOther w+ ]) xmlCollection :: Collection -> Element xmlCollection c = mkElem (appName "collection") [mkAttr "href" (collectionURI c)]- (concat [ [xmlTitle (collectionTitle c)]- , map xmlAccept (collectionAccept c)- , map xmlCategories (collectionCats c)- , collectionOther c- ])+ (concat [ [xmlTitle (collectionTitle c)]+ , map xmlAccept (collectionAccept c)+ , map xmlCategories (collectionCats c)+ , collectionOther c+ ]) xmlCategories :: Categories -> Element xmlCategories (CategoriesExternal u) =@@ -80,9 +80,9 @@ xmlCategories (Categories mbFixed mbScheme cs) = mkElem (appName "categories") (concat [ mb (\ f -> mkAttr "fixed" (if f then "yes" else "no")) mbFixed- , mb (mkAttr "scheme") mbScheme- ])- (map xmlCategory cs)+ , mb (mkAttr "scheme") mbScheme+ ])+ (map xmlCategory cs) xmlAccept :: Accept -> Element xmlAccept a = mkLeaf (appName "accept") [] (acceptType a)
src/Text/Feed/Query.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -------------------------------------------------------------------- -- | -- Module : Text.Feed.Query@@ -62,9 +63,9 @@ import Data.Maybe -- for getItemPublishDate rfc822 date parsing.-import System.Locale ( rfc822DateFormat, iso8601DateFormat )-import Data.Time.Locale.Compat ( defaultTimeLocale )-import Data.Time.Format ( ParseTime, parseTime )+import Data.Time.Locale.Compat ( defaultTimeLocale, rfc822DateFormat, iso8601DateFormat )+import Data.Time.Format ( ParseTime )+import qualified Data.Time.Format as F feedItems :: Feed.Feed -> [Feed.Item] feedItems fe =@@ -280,6 +281,12 @@ date = foldl1 mplus (map (\ fmt -> parseTime defaultTimeLocale fmt ds) formats) return date+ where+#if MIN_VERSION_time(1,5,0)+ parseTime = F.parseTimeM True+#else+ parseTime = F.parseTime+#endif getItemPublishDateString :: ItemGetter DateString getItemPublishDateString it =@@ -325,7 +332,7 @@ case filter isEnc $ Atom.entryLinks e of (l:_) -> Just (Atom.linkHref l, Atom.linkType l,- readLength (Atom.linkLength l))+ readLength (Atom.linkLength l)) _ -> Nothing Feed.RSSItem i -> fmap (\ e -> (RSS.rssEnclosureURL e, Just (RSS.rssEnclosureType e), RSS.rssEnclosureLength e))
src/Text/RSS/Export.hs view
@@ -90,25 +90,25 @@ (xmlLeaf "enclosure" "") { elAttribs = (Attr (qualName "url") (rssEnclosureURL e)) :- (Attr (qualName "length") (show $ rssEnclosureLength e)) : (Attr (qualName "type") (rssEnclosureType e)) :- rssEnclosureAttrs e }+ mb (Attr (qualName "length") . show) (rssEnclosureLength e) +++ rssEnclosureAttrs e } xmlCategory :: RSSCategory -> XML.Element xmlCategory c = (xmlLeaf "category" (rssCategoryValue c)) { elAttribs = (fromMaybe id (fmap (\ n -> ((Attr (qualName "domain") n):))- (rssCategoryDomain c))) $- (rssCategoryAttrs c) }+ (rssCategoryDomain c))) $+ (rssCategoryAttrs c) } xmlGuid :: RSSGuid -> XML.Element xmlGuid g = (xmlLeaf "guid" (rssGuidValue g)) { elAttribs = (fromMaybe id (fmap (\ n -> ((Attr (qualName "isPermaLink") (toBool n)):))- (rssGuidPermanentURL g))) $- (rssGuidAttrs g) }+ (rssGuidPermanentURL g))) $+ (rssGuidAttrs g) } where toBool False = "false" toBool _ = "true"@@ -130,11 +130,11 @@ (xmlLeaf "cloud" "") { elAttribs = ( mb (Attr (qualName "domain")) (rssCloudDomain cl)- ++ mb (Attr (qualName "port")) (rssCloudPort cl)- ++ mb (Attr (qualName "path")) (rssCloudPath cl)- ++ mb (Attr (qualName "registerProcedure")) (rssCloudRegisterProcedure cl)- ++ mb (Attr (qualName "protocol")) (rssCloudProtocol cl)- ++ rssCloudAttrs cl) }+ ++ mb (Attr (qualName "port")) (rssCloudPort cl)+ ++ mb (Attr (qualName "path")) (rssCloudPath cl)+ ++ mb (Attr (qualName "registerProcedure")) (rssCloudRegisterProcedure cl)+ ++ mb (Attr (qualName "protocol")) (rssCloudProtocol cl)+ ++ rssCloudAttrs cl) } xmlTextInput :: RSSTextInput -> XML.Element xmlTextInput ti =@@ -164,8 +164,8 @@ xmlLeaf :: String -> String -> XML.Element xmlLeaf tg txt = blank_element{ elName = qualName tg- , elContent = [ Text blank_cdata { cdData = txt } ]- }+ , elContent = [ Text blank_cdata { cdData = txt } ]+ } --- mb :: (a -> b) -> Maybe a -> [b]
src/Text/RSS1/Import.hs view
@@ -126,7 +126,7 @@ let is = case fmap seqLeaves $ pNode "items" e of Nothing -> []- Just ss -> ss+ Just ss -> ss let tinp = pLeaf "textinput" e let dcs = mapMaybe elementToDC es let tos = fromMaybe [] (fmap bagLeaves $ pQNode (qualName (taxNS,taxPrefix) "topics") e)@@ -135,7 +135,7 @@ let as_other = removeKnownAttrs e let def_chan = Channel- { channelURI = uri+ { channelURI = uri , channelTitle = ti , channelLink = li , channelDesc = de@@ -146,7 +146,7 @@ , channelUpdatePeriod = Nothing , channelUpdateFreq = Nothing , channelUpdateBase = Nothing- , channelContent = cs+ , channelContent = cs , channelTopics = tos , channelOther = es_other , channelAttrs = as_other
src/Text/RSS1/Utils.hs view
@@ -100,10 +100,10 @@ known_elts = concat [ known_rss_elts , known_syn_elts- , known_dc_elts- , known_con_elts- , known_tax_elts- ]+ , known_dc_elts+ , known_con_elts+ , known_tax_elts+ ] removeKnownAttrs :: XML.Element -> [XML.Attr] removeKnownAttrs e =
tests/Text/RSS/Export/Tests.hs view
@@ -13,7 +13,8 @@ rssExportTests :: Test rssExportTests = testGroup "Text.RSS.Export" [ mutuallyExclusive $ testGroup "RSS export"- [ testCreateXMLCloud+ [ testCreateXMLImage+ , testCreateXMLCloud , testCreateXMLTextInput , testCreateEmptyXMLSkipHours , testCreateXMLSkipHours@@ -25,6 +26,80 @@ ] type String = [Char]++testCreateXMLImage :: Test+testCreateXMLImage = testCase "should create image as xml" testImage+ where+ testImage :: Assertion+ testImage = do+ let other = XML.Element {+ elName = createQName "other"+ , elAttribs = [] :: [ Attr ]+ , elContent = [ createContent "image other" ] :: [ Content ]+ , elLine = Nothing+ }++ let image = RSSImage {+ rssImageURL = "image url"+ , rssImageTitle = "image title"+ , rssImageLink = "image link"+ , rssImageWidth = Just 100+ , rssImageHeight = Just 200+ , rssImageDesc = Just "image desc"+ , rssImageOther = [ other ]+ }++ let expected = XML.Element {+ elName = createQName "image"+ , elAttribs = [] :: [ Attr ]+ , elContent = [+ Elem(XML.Element {+ elName = createQName "url"+ , elAttribs = [] :: [ Attr ]+ , elContent = [ createContent "image url" ] :: [ Content ]+ , elLine = Nothing+ })+ , Elem(XML.Element {+ elName = createQName "title"+ , elAttribs = [] :: [ Attr ]+ , elContent = [ createContent "image title" ] :: [ Content ]+ , elLine = Nothing+ })+ , Elem(XML.Element {+ elName = createQName "link"+ , elAttribs = [] :: [ Attr ]+ , elContent = [ createContent "image link" ] :: [ Content ]+ , elLine = Nothing+ })+ , Elem(XML.Element {+ elName = createQName "width"+ , elAttribs = [] :: [ Attr ]+ , elContent = [ createContent "100" ] :: [ Content ]+ , elLine = Nothing+ })+ , Elem(XML.Element {+ elName = createQName "height"+ , elAttribs = [] :: [ Attr ]+ , elContent = [ createContent "200" ] :: [ Content ]+ , elLine = Nothing+ })+ , Elem(XML.Element {+ elName = createQName "description"+ , elAttribs = [] :: [ Attr ]+ , elContent = [ createContent "image desc" ] :: [ Content ]+ , elLine = Nothing+ })+ , Elem(XML.Element {+ elName = createQName "other"+ , elAttribs = [] :: [ Attr ]+ , elContent = [ createContent "image other" ] :: [ Content ]+ , elLine = Nothing+ })+ ] :: [ Content ]+ , elLine = Nothing+ }++ assertEqual "image" expected (xmlImage image) testCreateXMLCloud :: Test testCreateXMLCloud = testCase "should create cloud as xml" testCloud