diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +#### 0.3.10.3 + +* RSS Export: avoid attribute (thanks to Roman Cheplyaka) + #### 0.3.10.2 * The Atom RFC says that when a link element doesn't specify the "rel" diff --git a/feed.cabal b/feed.cabal --- a/feed.cabal +++ b/feed.cabal @@ -1,5 +1,5 @@ name: feed -version: 0.3.10.2 +version: 0.3.10.3 license: BSD3 license-file: LICENSE category: Text diff --git a/src/Text/Atom/Feed/Export.hs b/src/Text/Atom/Feed/Export.hs --- a/src/Text/Atom/Feed/Export.hs +++ b/src/Text/Atom/Feed/Export.hs @@ -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 diff --git a/src/Text/Atom/Feed/Import.hs b/src/Text/Atom/Feed/Import.hs --- a/src/Text/Atom/Feed/Import.hs +++ b/src/Text/Atom/Feed/Import.hs @@ -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 = [] diff --git a/src/Text/Atom/Feed/Validate.hs b/src/Text/Atom/Feed/Validate.hs --- a/src/Text/Atom/Feed/Validate.hs +++ b/src/Text/Atom/Feed/Validate.hs @@ -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)) - diff --git a/src/Text/Atom/Pub/Export.hs b/src/Text/Atom/Pub/Export.hs --- a/src/Text/Atom/Pub/Export.hs +++ b/src/Text/Atom/Pub/Export.hs @@ -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) diff --git a/src/Text/Feed/Query.hs b/src/Text/Feed/Query.hs --- a/src/Text/Feed/Query.hs +++ b/src/Text/Feed/Query.hs @@ -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)) diff --git a/src/Text/RSS/Export.hs b/src/Text/RSS/Export.hs --- a/src/Text/RSS/Export.hs +++ b/src/Text/RSS/Export.hs @@ -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] diff --git a/src/Text/RSS1/Import.hs b/src/Text/RSS1/Import.hs --- a/src/Text/RSS1/Import.hs +++ b/src/Text/RSS1/Import.hs @@ -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 diff --git a/src/Text/RSS1/Utils.hs b/src/Text/RSS1/Utils.hs --- a/src/Text/RSS1/Utils.hs +++ b/src/Text/RSS1/Utils.hs @@ -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 = diff --git a/tests/Text/RSS/Export/Tests.hs b/tests/Text/RSS/Export/Tests.hs --- a/tests/Text/RSS/Export/Tests.hs +++ b/tests/Text/RSS/Export/Tests.hs @@ -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