diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ This [Haskell][hsk] library implements a streaming parser/renderer for the [RSS 2.0 syndication format][rss], based on [conduit][cdt]s. -Parsers are as much lenient as possible. E.g. unexpected tags are simply ignored. +Parsers are lenient as much as possible. E.g. unexpected tags are simply ignored. [rss]: http://cyber.law.harvard.edu/rss/rss.html diff --git a/Text/RSS/Conduit/Parse.hs b/Text/RSS/Conduit/Parse.hs --- a/Text/RSS/Conduit/Parse.hs +++ b/Text/RSS/Conduit/Parse.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -- | Streaming parsers for the RSS 2.0 standard. @@ -21,19 +22,19 @@ -- {{{ Imports import Text.RSS.Types -import Control.Applicative -import Control.Foldl hiding (mconcat) +import Conduit hiding (throwM) + +import Control.Applicative hiding (many) +import Control.Exception.Safe as Exception import Control.Monad hiding (foldM) -import Control.Monad.Catch +import Control.Monad.Fix -import Data.Conduit.Parser -import Data.Conduit.Parser.XML +import Data.Conduit import Data.Maybe import Data.Monoid import Data.MonoTraversable import Data.Set hiding (fold) -import Data.Text as Text hiding (cons, last, map, - snoc) +import Data.Text as Text import Data.Text.Encoding import Data.Time.Clock import Data.Time.LocalTime @@ -45,9 +46,9 @@ import Prelude hiding (last, lookup) -import Text.Parser.Combinators import Text.ParserCombinators.ReadP (readP_to_S) import Text.Read (readMaybe) +import Text.XML.Stream.Parse import URI.ByteString -- }}} @@ -57,175 +58,176 @@ asRssURI t = case (parseURI' t, parseRelativeRef' t) of (Right u, _) -> return $ RssURI u (_, Right u) -> return $ RssURI u - (_, Left e) -> throwM $ InvalidURI e + (_, Left e) -> throwM $ InvalidURI e where parseURI' = parseURI laxURIParserOptions . encodeUtf8 parseRelativeRef' = parseRelativeRef laxURIParserOptions . encodeUtf8 +nullURI :: RssURI +nullURI = RssURI $ RelativeRef Nothing "" (Query []) Nothing + asInt :: MonadThrow m => Text -> m Int asInt t = maybe (throwM $ InvalidInt t) return . readMaybe $ unpack t asBool :: MonadThrow m => Text -> m Bool -asBool "true" = return True +asBool "true" = return True asBool "false" = return False -asBool t = throwM $ InvalidBool t +asBool t = throwM $ InvalidBool t asVersion :: MonadThrow m => Text -> m Version asVersion t = maybe (throwM $ InvalidVersion t) return . fmap fst . headMay . readP_to_S parseVersion $ unpack t asCloudProtocol :: MonadThrow m => Text -> m CloudProtocol -asCloudProtocol "xml-rpc" = return ProtocolXmlRpc -asCloudProtocol "soap" = return ProtocolSoap +asCloudProtocol "xml-rpc" = return ProtocolXmlRpc +asCloudProtocol "soap" = return ProtocolSoap asCloudProtocol "http-post" = return ProtocolHttpPost -asCloudProtocol t = throwM $ InvalidProtocol t - -unknownTag :: (MonadCatch m) => ConduitParser Event m (Endo a) -unknownTag = anyTag $ \_ _ -> many (void unknownTag <|> void textContent) >> return mempty +asCloudProtocol t = throwM $ InvalidProtocol t -- | Like 'tagName' but ignores the namespace. -tagName' :: (MonadCatch m) => Text -> AttrParser a -> (a -> ConduitParser Event m b) -> ConduitParser Event m b +tagName' :: (MonadThrow m) => Text -> AttrParser a -> (a -> ConduitM Event o m b) -> ConduitM Event o m (Maybe b) tagName' t = tagPredicate (\n -> nameLocalName n == t) -- | Tag which content is a date-time that follows RFC 3339 format. -tagDate :: (MonadCatch m) => Name -> ConduitParser Event m UTCTime -tagDate name = tagIgnoreAttrs name $ content (fmap zonedTimeToUTC . parseTimeRFC822) +tagDate :: (MonadThrow m) => Name -> ConduitM Event o m (Maybe UTCTime) +tagDate name = tagIgnoreAttrs name $ fmap zonedTimeToUTC $ do + text <- content + maybe (throw $ InvalidTime text) return $ parseTimeRFC822 text +headRequiredC :: MonadThrow m => Text -> Consumer a m a +headRequiredC e = maybe (throw $ MissingElement e) return =<< headC -lastRequired :: (Monad m, Parsing m) => String -> FoldM m a a -lastRequired e = FoldM (\_ a -> return $ Right a) (return $ Left e) (either unexpected return) +projectC :: Monad m => Fold a a' b b' -> Conduit a m b +projectC prism = fix $ \recurse -> do + item <- await + case (item, item ^? (_Just . prism)) of + (_, Just a) -> yield a >> recurse + (Just _, _) -> recurse + _ -> return () -- }}} -- | Parse a @\@ element. -rssSkipHours :: MonadCatch m => ConduitParser Event m (Set Hour) -rssSkipHours = named "Rss element" $ tagIgnoreAttrs "skipHours" $ - fromList <$> many (tagIgnoreAttrs "hour" $ content (asInt >=> asHour)) +rssSkipHours :: MonadThrow m => ConduitM Event o m (Maybe (Set Hour)) +rssSkipHours = tagIgnoreAttrs "skipHours" $ + fromList <$> (manyYield' (tagIgnoreAttrs "hour" $ content >>= asInt >>= asHour) =$= sinkList) -- | Parse a @\@ element. -rssSkipDays :: MonadCatch m => ConduitParser Event m (Set Day) -rssSkipDays = named "Rss element" $ tagIgnoreAttrs "skipDays" $ - fromList <$> many (tagIgnoreAttrs "day" $ content asDay) +rssSkipDays :: MonadThrow m => ConduitM Event o m (Maybe (Set Day)) +rssSkipDays = tagIgnoreAttrs "skipDays" $ + fromList <$> (manyYield' (tagIgnoreAttrs "day" $ content >>= asDay) =$= sinkList) data TextInputPiece = TextInputTitle Text | TextInputDescription Text | TextInputName Text | TextInputLink RssURI - | TextInputUnknown makeTraversals ''TextInputPiece -- | Parse a @\@ element. -rssTextInput :: (MonadCatch m) => ConduitParser Event m RssTextInput -rssTextInput = named "Rss element" $ tagIgnoreAttrs "textInput" $ do - p <- many piece - flip foldM p $ RssTextInput - <$> handlesM _TextInputTitle (lastRequired "Missing element.") - <*> handlesM _TextInputDescription (lastRequired "Missing <description> element.") - <*> handlesM _TextInputName (lastRequired "Missing <name> element.") - <*> handlesM _TextInputLink (lastRequired "Missing <link> element.") - where piece :: MonadCatch m => ConduitParser Event m TextInputPiece - piece = choice [ TextInputTitle <$> tagIgnoreAttrs "title" textContent - , TextInputDescription <$> tagIgnoreAttrs "description" textContent - , TextInputName <$> tagIgnoreAttrs "name" textContent - , TextInputLink <$> tagIgnoreAttrs "link" (content asRssURI) - , TextInputUnknown <$ unknownTag - ] +rssTextInput :: (MonadThrow m) => ConduitM Event o m (Maybe RssTextInput) +rssTextInput = tagIgnoreAttrs "textInput" $ (manyYield' (choose piece) =$= parser) <* many ignoreAllTreesContent where + parser = getZipConduit $ RssTextInput + <$> ZipConduit (projectC _TextInputTitle =$= headRequiredC "Missing <title> element") + <*> ZipConduit (projectC _TextInputDescription =$= headRequiredC "Missing <description> element") + <*> ZipConduit (projectC _TextInputName =$= headRequiredC "Missing <name> element") + <*> ZipConduit (projectC _TextInputLink =$= headRequiredC "Missing <link> element") + piece = [ fmap TextInputTitle <$> tagIgnoreAttrs "title" content + , fmap TextInputDescription <$> tagIgnoreAttrs "description" content + , fmap TextInputName <$> tagIgnoreAttrs "name" content + , fmap TextInputLink <$> tagIgnoreAttrs "link" (content >>= asRssURI) + ] + data ImagePiece = ImageUri RssURI | ImageTitle Text | ImageLink RssURI | ImageWidth Int - | ImageHeight Int | ImageDescription Text | ImageUnknown + | ImageHeight Int | ImageDescription Text makeTraversals ''ImagePiece -- | Parse an @\<image\>@ element. -rssImage :: (MonadCatch m) => ConduitParser Event m RssImage -rssImage = named "Rss <image> element" $ tagIgnoreAttrs "image" $ do - p <- many piece - flip foldM p $ RssImage - <$> handlesM _ImageUri (lastRequired "Missing <uri> element.") - <*> handlesM _ImageTitle (lastRequired "Missing <title> element.") - <*> handlesM _ImageLink (lastRequired "Missing <link> element.") - <*> generalize (handles _ImageWidth last) - <*> generalize (handles _ImageHeight last) - <*> generalize (handles _ImageDescription $ lastDef "") - where piece = choice [ ImageUri <$> tagIgnoreAttrs "uri" (content asRssURI) - , ImageTitle <$> tagIgnoreAttrs "title" textContent - , ImageLink <$> tagIgnoreAttrs "link" (content asRssURI) - , ImageWidth <$> tagIgnoreAttrs "width" (content asInt) - , ImageHeight <$> tagIgnoreAttrs "height" (content asInt) - , ImageDescription <$> tagIgnoreAttrs "description" textContent - , ImageUnknown <$ unknownTag - ] - +rssImage :: (MonadThrow m) => ConduitM Event o m (Maybe RssImage) +rssImage = tagIgnoreAttrs "image" $ (manyYield' (choose piece) =$= parser) <* many ignoreAllTreesContent where + parser = getZipConduit $ RssImage + <$> ZipConduit (projectC _ImageUri =$= headRequiredC "Missing <url> element") + <*> ZipConduit (projectC _ImageTitle =$= headDefC "Unnamed image") -- Lenient + <*> ZipConduit (projectC _ImageLink =$= headDefC nullURI) -- Lenient + <*> ZipConduit (projectC _ImageWidth =$= headC) + <*> ZipConduit (projectC _ImageHeight =$= headC) + <*> ZipConduit (projectC _ImageDescription =$= headDefC "") + piece = [ fmap ImageUri <$> tagIgnoreAttrs "url" (content >>= asRssURI) + , fmap ImageTitle <$> tagIgnoreAttrs "title" content + , fmap ImageLink <$> tagIgnoreAttrs "link" (content >>= asRssURI) + , fmap ImageWidth <$> tagIgnoreAttrs "width" (content >>= asInt) + , fmap ImageHeight <$> tagIgnoreAttrs "height" (content >>= asInt) + , fmap ImageDescription <$> tagIgnoreAttrs "description" content + ] -- | Parse a @\<category\>@ element. -rssCategory :: MonadCatch m => ConduitParser Event m RssCategory -rssCategory = named "Rss <category> element" $ tagName' "category" (textAttr "domain") $ \domain -> - RssCategory domain <$> textContent +rssCategory :: MonadThrow m => ConduitM Event o m (Maybe RssCategory) +rssCategory = tagName' "category" (optional (requireAttr "domain") <* ignoreAttrs) $ \domain -> + RssCategory (fromMaybe "" domain) <$> content -- | Parse a @\<cloud\>@ element. -rssCloud :: (MonadCatch m) => ConduitParser Event m RssCloud -rssCloud = named "Rss <cloud> element" $ tagName' "cloud" attributes return where +rssCloud :: (MonadThrow m) => ConduitM Event o m (Maybe RssCloud) +rssCloud = tagName' "cloud" attributes return where attributes = do uri <- fmap RssURI $ RelativeRef - <$> fmap Just (Authority Nothing <$> (Host . encodeUtf8 <$> textAttr "domain") <*> (fmap Port <$> optional (attr "port" asInt))) - <*> (encodeUtf8 <$> textAttr "path") + <$> fmap Just (Authority Nothing <$> (Host . encodeUtf8 <$> requireAttr "domain") <*> (fmap Port <$> optional (requireAttr "port" >>= asInt))) + <*> (encodeUtf8 <$> requireAttr "path") <*> pure (Query []) <*> pure Nothing - RssCloud uri <$> textAttr "registerProcedure" <*> attr "protocol" asCloudProtocol <* ignoreAttrs + RssCloud uri <$> requireAttr "registerProcedure" <*> (requireAttr "protocol" >>= asCloudProtocol) <* ignoreAttrs -- | Parse a @\<guid\>@ element. -rssGuid :: MonadCatch m => ConduitParser Event m RssGuid -rssGuid = named "RSS <guid> element" $ tagName' "guid" attributes handler where - attributes = optional (attr "isPermaLink" asBool) <* ignoreAttrs - handler (Just True) = GuidUri <$> content asRssURI - handler _ = GuidText <$> textContent +rssGuid :: MonadThrow m => ConduitM Event o m (Maybe RssGuid) +rssGuid = tagName' "guid" attributes handler where + attributes = optional (requireAttr "isPermaLink" >>= asBool) <* ignoreAttrs + handler (Just True) = GuidUri <$> (content >>= asRssURI) + handler _ = GuidText <$> content -- | Parse an @\<enclosure\>@ element. -rssEnclosure :: MonadCatch m => ConduitParser Event m RssEnclosure -rssEnclosure = named "Rss <enclosure> element" $ tagName' "enclosure" attributes handler where - attributes = (,,) <$> attr "url" asRssURI <*> attr "length" asInt <*> textAttr "type" <* ignoreAttrs +rssEnclosure :: MonadThrow m => ConduitM Event o m (Maybe RssEnclosure) +rssEnclosure = tagName' "enclosure" attributes handler where + attributes = (,,) <$> (requireAttr "url" >>= asRssURI) <*> (requireAttr "length" >>= asInt) <*> requireAttr "type" <* ignoreAttrs handler (uri, length_, type_) = return $ RssEnclosure uri length_ type_ -- | Parse a @\<source\>@ element. -rssSource :: MonadCatch m => ConduitParser Event m RssSource -rssSource = named "Rss <source> element" $ tagName' "source" attributes handler where - attributes = attr "url" asRssURI <* ignoreAttrs - handler uri = RssSource uri <$> textContent +rssSource :: MonadThrow m => ConduitM Event o m (Maybe RssSource) +rssSource = tagName' "source" attributes handler where + attributes = (requireAttr "url" >>= asRssURI) <* ignoreAttrs + handler uri = RssSource uri <$> content data ItemPiece = ItemTitle Text | ItemLink RssURI | ItemDescription Text | ItemAuthor Text | ItemCategory RssCategory | ItemComments RssURI | ItemEnclosure RssEnclosure | ItemGuid RssGuid | ItemPubDate UTCTime - | ItemSource RssSource | ItemUnknown + | ItemSource RssSource makeTraversals ''ItemPiece -- | Parse an @\<item\>@ element. -rssItem :: MonadCatch m => ConduitParser Event m RssItem -rssItem = named "Rss <item> element" $ tagIgnoreAttrs "item" $ do - p <- many piece - return . flip fold p $ RssItem - <$> handles _ItemTitle (lastDef "") - <*> handles _ItemLink last - <*> handles _ItemDescription (lastDef "") - <*> handles _ItemAuthor (lastDef "") - <*> handles _ItemCategory list - <*> handles _ItemComments last - <*> handles _ItemEnclosure list - <*> handles _ItemGuid last - <*> handles _ItemPubDate last - <*> handles _ItemSource last - where piece = choice [ ItemTitle <$> tagIgnoreAttrs "title" textContent - , ItemLink <$> tagIgnoreAttrs "link" (content asRssURI) - , ItemDescription <$> tagIgnoreAttrs "description" textContent - , ItemAuthor <$> tagIgnoreAttrs "author" textContent - , ItemCategory <$> rssCategory - , ItemComments <$> tagIgnoreAttrs "comments" (content asRssURI) - , ItemEnclosure <$> rssEnclosure - , ItemGuid <$> rssGuid - , ItemPubDate <$> tagDate "pubDate" - , ItemSource <$> rssSource - , ItemUnknown <$ unknownTag - ] +rssItem :: MonadThrow m => ConduitM Event o m (Maybe RssItem) +rssItem = tagIgnoreAttrs "item" $ (manyYield' (choose piece) =$= parser) <* many ignoreAllTreesContent where + parser = getZipConduit $ RssItem + <$> ZipConduit (projectC _ItemTitle =$= headDefC "") + <*> ZipConduit (projectC _ItemLink =$= headC) + <*> ZipConduit (projectC _ItemDescription =$= headDefC "") + <*> ZipConduit (projectC _ItemAuthor =$= headDefC "") + <*> ZipConduit (projectC _ItemCategory =$= sinkList) + <*> ZipConduit (projectC _ItemComments =$= headC) + <*> ZipConduit (projectC _ItemEnclosure =$= sinkList) + <*> ZipConduit (projectC _ItemGuid =$= headC) + <*> ZipConduit (projectC _ItemPubDate =$= headC) + <*> ZipConduit (projectC _ItemSource =$= headC) + piece = [ fmap ItemTitle <$> tagIgnoreAttrs "title" content + , fmap ItemLink <$> tagIgnoreAttrs "link" (content >>= asRssURI) + , fmap ItemDescription <$> tagIgnoreAttrs "description" content + , fmap ItemAuthor <$> tagIgnoreAttrs "author" content + , fmap ItemCategory <$> rssCategory + , fmap ItemComments <$> tagIgnoreAttrs "comments" (content >>= asRssURI) + , fmap ItemEnclosure <$> rssEnclosure + , fmap ItemGuid <$> rssGuid + , fmap ItemPubDate <$> tagDate "pubDate" + , fmap ItemSource <$> rssSource + ] data ChannelPiece = ChannelTitle Text | ChannelLink RssURI | ChannelDescription Text @@ -235,56 +237,53 @@ | ChannelGenerator Text | ChannelDocs RssURI | ChannelCloud RssCloud | ChannelTtl Int | ChannelImage RssImage | ChannelRating Text | ChannelTextInput RssTextInput | ChannelSkipHours (Set Hour) - | ChannelSkipDays (Set Day) | ChannelUnknown + | ChannelSkipDays (Set Day) makeTraversals ''ChannelPiece -- | Parse an @\<rss\>@ element. -rssDocument :: MonadCatch m => ConduitParser Event m RssDocument -rssDocument = named "RSS <rss> element" $ tagName' "rss" attributes $ \version -> tagIgnoreAttrs "channel" $ do - p <- many piece - flip foldM p $ RssDocument version - <$> handlesM _ChannelTitle (lastRequired "Missing <title> element.") - <*> handlesM _ChannelLink (lastRequired "Missing <link> element.") - <*> generalize (handles _ChannelDescription $ lastDef "") -- Lenient - <*> generalize (handles _ChannelItem list) - <*> generalize (handles _ChannelLanguage $ lastDef "") - <*> generalize (handles _ChannelCopyright $ lastDef "") - <*> generalize (handles _ChannelManagingEditor $ lastDef "") - <*> generalize (handles _ChannelWebmaster $ lastDef "") - <*> generalize (handles _ChannelPubDate last) - <*> generalize (handles _ChannelLastBuildDate last) - <*> generalize (handles _ChannelCategory list) - <*> generalize (handles _ChannelGenerator $ lastDef "") - <*> generalize (handles _ChannelDocs last) - <*> generalize (handles _ChannelCloud last) - <*> generalize (handles _ChannelTtl last) - <*> generalize (handles _ChannelImage last) - <*> generalize (handles _ChannelRating $ lastDef "") - <*> generalize (handles _ChannelTextInput last) - <*> generalize (handles _ChannelSkipHours $ lastDef mempty) - <*> generalize (handles _ChannelSkipDays $ lastDef mempty) - where piece :: MonadCatch m => ConduitParser Event m ChannelPiece - piece = choice [ ChannelTitle <$> tagIgnoreAttrs "title" textContent - , ChannelLink <$> tagIgnoreAttrs "link" (content asRssURI) - , ChannelDescription <$> tagIgnoreAttrs "description" textContent - , ChannelItem <$> rssItem - , ChannelLanguage <$> tagIgnoreAttrs "language" textContent - , ChannelCopyright <$> tagIgnoreAttrs "copyright" textContent - , ChannelManagingEditor <$> tagIgnoreAttrs "managingEditor" textContent - , ChannelWebmaster <$> tagIgnoreAttrs "webMaster" textContent - , ChannelPubDate <$> tagDate "pubDate" - , ChannelLastBuildDate <$> tagDate "lastBuildDate" - , ChannelCategory <$> rssCategory - , ChannelGenerator <$> tagIgnoreAttrs "generator" textContent - , ChannelDocs <$> tagIgnoreAttrs "docs" (content asRssURI) - , ChannelCloud <$> rssCloud - , ChannelTtl <$> tagIgnoreAttrs "ttl" (content asInt) - , ChannelImage <$> rssImage - , ChannelRating <$> tagIgnoreAttrs "rating" textContent - , ChannelTextInput <$> rssTextInput - , ChannelSkipHours <$> rssSkipHours - , ChannelSkipDays <$> rssSkipDays - , ChannelUnknown <$ unknownTag - ] - attributes = attr "version" asVersion <* ignoreAttrs +rssDocument :: MonadThrow m => ConduitM Event o m (Maybe RssDocument) +rssDocument = tagName' "rss" attributes $ \version -> force "Missing <channel>" $ tagIgnoreAttrs "channel" (manyYield' (choose piece) =$= parser version) <* many ignoreAllTreesContent where + parser version = getZipConduit $ RssDocument version + <$> ZipConduit (projectC _ChannelTitle =$= headRequiredC "Missing <title> element") + <*> ZipConduit (projectC _ChannelLink =$= headRequiredC "Missing <link> element") + <*> ZipConduit (projectC _ChannelDescription =$= headDefC "") -- Lenient + <*> ZipConduit (projectC _ChannelItem =$= sinkList) + <*> ZipConduit (projectC _ChannelLanguage =$= headDefC "") + <*> ZipConduit (projectC _ChannelCopyright =$= headDefC "") + <*> ZipConduit (projectC _ChannelManagingEditor =$= headDefC "") + <*> ZipConduit (projectC _ChannelWebmaster =$= headDefC "") + <*> ZipConduit (projectC _ChannelPubDate =$= headC) + <*> ZipConduit (projectC _ChannelLastBuildDate =$= headC) + <*> ZipConduit (projectC _ChannelCategory =$= sinkList) + <*> ZipConduit (projectC _ChannelGenerator =$= headDefC "") + <*> ZipConduit (projectC _ChannelDocs =$= headC) + <*> ZipConduit (projectC _ChannelCloud =$= headC) + <*> ZipConduit (projectC _ChannelTtl =$= headC) + <*> ZipConduit (projectC _ChannelImage =$= headC) + <*> ZipConduit (projectC _ChannelRating =$= headDefC "") + <*> ZipConduit (projectC _ChannelTextInput =$= headC) + <*> ZipConduit (projectC _ChannelSkipHours =$= headDefC mempty) + <*> ZipConduit (projectC _ChannelSkipDays =$= headDefC mempty) + piece = [ fmap ChannelTitle <$> tagIgnoreAttrs "title" content + , fmap ChannelLink <$> tagIgnoreAttrs "link" (content >>= asRssURI) + , fmap ChannelDescription <$> tagIgnoreAttrs "description" content + , fmap ChannelItem <$> rssItem + , fmap ChannelLanguage <$> tagIgnoreAttrs "language" content + , fmap ChannelCopyright <$> tagIgnoreAttrs "copyright" content + , fmap ChannelManagingEditor <$> tagIgnoreAttrs "managingEditor" content + , fmap ChannelWebmaster <$> tagIgnoreAttrs "webMaster" content + , fmap ChannelPubDate <$> tagDate "pubDate" + , fmap ChannelLastBuildDate <$> tagDate "lastBuildDate" + , fmap ChannelCategory <$> rssCategory + , fmap ChannelGenerator <$> tagIgnoreAttrs "generator" content + , fmap ChannelDocs <$> tagIgnoreAttrs "docs" (content >>= asRssURI) + , fmap ChannelCloud <$> rssCloud + , fmap ChannelTtl <$> tagIgnoreAttrs "ttl" (content >>= asInt) + , fmap ChannelImage <$> rssImage + , fmap ChannelRating <$> tagIgnoreAttrs "rating" content + , fmap ChannelTextInput <$> rssTextInput + , fmap ChannelSkipHours <$> rssSkipHours + , fmap ChannelSkipDays <$> rssSkipDays + ] + attributes = (requireAttr "version" >>= asVersion) <* ignoreAttrs diff --git a/Text/RSS/Conduit/Render.hs b/Text/RSS/Conduit/Render.hs --- a/Text/RSS/Conduit/Render.hs +++ b/Text/RSS/Conduit/Render.hs @@ -111,7 +111,7 @@ renderHost (Host h) = decodeUtf8 h renderQuery (Query query) = case intercalate "&" $ map (\(a,b) -> decodeUtf8 a <> "=" <> decodeUtf8 b) query of "" -> "" - x -> "?" <> x + x -> "?" <> x domain = maybe "" (\a -> renderUserInfo (authorityUserInfo a) <> renderHost (authorityHost a)) $ withRssURI (view authorityL) $ c^.cloudUriL port = fmap (pack . show . portNumber) $ authorityPort =<< withRssURI (view authorityL) (c^.cloudUriL) @@ -119,8 +119,8 @@ query = renderQuery $ withRssURI (view queryL) $ c^.cloudUriL fragment = maybe "" decodeUtf8 $ withRssURI (view fragmentL) $ c^.cloudUriL - describe ProtocolXmlRpc = "xml-rpc" - describe ProtocolSoap = "soap" + describe ProtocolXmlRpc = "xml-rpc" + describe ProtocolSoap = "soap" describe ProtocolHttpPost = "http-post" -- | Render a @\<category\>@ element. @@ -130,7 +130,7 @@ -- | Render an @\<image\>@ element. renderRssImage :: (Monad m) => RssImage -> Source m Event renderRssImage i = tag "image" mempty $ do - textTag "uri" $ decodeUtf8 $ withRssURI serializeURIRef' $ i^.imageUriL + textTag "url" $ decodeUtf8 $ withRssURI serializeURIRef' $ i^.imageUriL textTag "title" $ i^.imageTitleL textTag "link" $ decodeUtf8 $ withRssURI serializeURIRef' $ i^.imageLinkL forM_ (i^.imageHeightL) $ textTag "height" . tshow diff --git a/Text/RSS/Types.hs b/Text/RSS/Types.hs --- a/Text/RSS/Types.hs +++ b/Text/RSS/Types.hs @@ -35,15 +35,15 @@ module Text.RSS.Types where -- {{{ Imports -import Control.Monad.Catch +import Control.Exception.Safe import Data.Set -import Data.Text hiding (map) +import Data.Text hiding (map) import Data.Time.Clock -import Data.Time.LocalTime () +import Data.Time.LocalTime () import Data.Version -import GHC.Generics hiding ((:+:)) +import GHC.Generics hiding ((:+:)) import Text.Read @@ -58,6 +58,8 @@ | InvalidURI URIParseError | InvalidVersion Text | InvalidProtocol Text + | InvalidTime Text + | MissingElement Text deriving instance Eq RssException deriving instance Show RssException @@ -70,6 +72,8 @@ displayException (InvalidURI t) = "Invalid URI reference: " ++ show t displayException (InvalidVersion t) = "Invalid version: " ++ unpack t displayException (InvalidProtocol t) = "Invalid Protocol: expected \"xml-rpc\", \"soap\" or \"http-post\", got \"" ++ unpack t ++ "\"" + displayException (InvalidTime t) = "Invalid time: " ++ unpack t + displayException (MissingElement t) = "Missing element: " ++ unpack t data RssURI = forall a . RssURI (URIRef a) @@ -86,7 +90,7 @@ _ `compare` _ = GT instance Show RssURI where - show (RssURI a@URI{}) = show a + show (RssURI a@URI{}) = show a show (RssURI a@RelativeRef{}) = show a withRssURI :: (forall a . URIRef a -> b) -> RssURI -> b diff --git a/rss-conduit.cabal b/rss-conduit.cabal --- a/rss-conduit.cabal +++ b/rss-conduit.cabal @@ -1,8 +1,8 @@ name: rss-conduit -version: 0.2.0.2 +version: 0.3.0.0 synopsis: Streaming parser/renderer for the RSS 2.0 standard. description: Cf README file. -license: OtherLicense +license: PublicDomain license-file: LICENSE author: koral maintainer: koral att mailoo dott org @@ -25,20 +25,17 @@ build-depends: base >= 4.8 && < 5 , conduit - , conduit-parse + , conduit-combinators , containers - , exceptions - , foldl + , safe-exceptions , lens-simple , mono-traversable - , parsers , safe , text , time >= 1.5 , timerep >= 2.0 , uri-bytestring >= 0.2 , xml-conduit >= 1.3 - , xml-conduit-parse >= 0.3 , xml-types default-language: Haskell2010 @@ -53,13 +50,11 @@ , bytestring , conduit , conduit-extra - , conduit-parse , data-default - , exceptions + , safe-exceptions , hlint , lens-simple , mono-traversable - , parsers , QuickCheck , quickcheck-instances , resourcet @@ -70,6 +65,5 @@ , text , uri-bytestring >= 0.2 , xml-conduit >= 1.3 - , xml-conduit-parse >= 0.3 , xml-types default-language: Haskell2010 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,15 +4,13 @@ -- {{{ Imports import Arbitrary -import Control.Monad.Catch.Pure +import Control.Exception.Safe as Exception import Control.Monad.Trans.Resource import Data.Char import Data.Conduit import Data.Conduit.Binary import Data.Conduit.List -import Data.Conduit.Parser -import Data.Conduit.Parser.XML as XML import Data.Default import Data.Version @@ -24,11 +22,11 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck -import Text.Parser.Combinators import Text.RSS.Conduit.Parse as Parser import Text.RSS.Conduit.Render as Renderer import Text.RSS.Lens import Text.RSS.Types +import Text.XML.Stream.Parse as XML hiding (choose) import Text.XML.Stream.Render import URI.ByteString @@ -72,7 +70,7 @@ skipHoursCase :: TestTree skipHoursCase = testCase "<skipHours> element" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssSkipHours + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssSkipHours result @?= [Hour 0, Hour 9, Hour 18, Hour 21] where input = [ "<skipHours>" , "<hour>21</hour>" @@ -85,7 +83,7 @@ skipDaysCase :: TestTree skipDaysCase = testCase "<skipDays> element" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssSkipDays + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssSkipDays result @?= [Monday, Saturday, Friday] where input = [ "<skipDays>" , "<day>Monday</day>" @@ -97,7 +95,7 @@ textInputCase :: TestTree textInputCase = testCase "<textInput> element" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssTextInput + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssTextInput result^.textInputTitleL @?= "Title" result^.textInputDescriptionL @?= "Description" result^.textInputNameL @?= "Name" @@ -112,7 +110,7 @@ imageCase :: TestTree imageCase = testCase "<image> element" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssImage + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssImage result^.imageUriL @?= RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "image.ext") Nothing)) "" (Query []) Nothing) result^.imageTitleL @?= "Title" result^.imageLinkL @?= RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "link.ext") Nothing)) "" (Query []) Nothing) @@ -120,18 +118,20 @@ result^.imageHeightL @?= Just 200 result^.imageDescriptionL @?= "Description" where input = [ "<image>" - , "<uri>http://image.ext</uri>" + , "<url>http://image.ext</url>" , "<title>Title" + , "Ignored" , "http://link.ext" , "100" , "200" , "Description" + , "Ignored" , "" ] categoryCase :: TestTree categoryCase = testCase " element" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssCategory + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssCategory result @?= RssCategory "Domain" "Name" where input = [ "" , "Name" @@ -140,7 +140,7 @@ cloudCase :: TestTree cloudCase = testCase " element" $ do - (result1, result2) <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser ((,) <$> rssCloud <*> rssCloud) + result1:result2:_ <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= XML.many rssCloud result1 @?= RssCloud uri "pingMe" ProtocolSoap result2 @?= RssCloud uri "myCloud.rssPleaseNotify" ProtocolXmlRpc where input = [ "" @@ -150,7 +150,7 @@ guidCase :: TestTree guidCase = testCase " element" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser (some rssGuid) + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= XML.many rssGuid result @?= [GuidUri uri, GuidText "1", GuidText "2"] where input = [ "//guid.ext" , "1" @@ -160,7 +160,7 @@ enclosureCase :: TestTree enclosureCase = testCase " element" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssEnclosure + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssEnclosure result @?= RssEnclosure uri 12216320 "audio/mpeg" where input = [ "" ] @@ -168,7 +168,7 @@ sourceCase :: TestTree sourceCase = testCase " element" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssSource + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssSource result @?= RssSource uri "Tomalak's Realm" where input = [ "Tomalak's Realm" ] @@ -176,7 +176,7 @@ itemCase :: TestTree itemCase = testCase " element" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssItem + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssItem result^.itemTitleL @?= "Example entry" result^.itemLinkL @?= Just link result^.itemDescriptionL @?= "Here is some text containing an interesting description." @@ -195,7 +195,7 @@ documentCase :: TestTree documentCase = testCase " element" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssDocument + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssDocument result^.documentVersionL @?= Version [2] [] result^.channelTitleL @?= "RSS Title" result^.channelDescriptionL @?= "This is an example of an RSS feed" @@ -231,25 +231,25 @@ roundtripTextInputProperty :: TestTree -roundtripTextInputProperty = testProperty "parse . render = id (RssTextInput)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssTextInput t =$= runConduitParser rssTextInput) +roundtripTextInputProperty = testProperty "parse . render = id (RssTextInput)" $ \t -> either (const False) (t ==) (runConduit $ renderRssTextInput t =$= force "ERROR" rssTextInput) roundtripImageProperty :: TestTree -roundtripImageProperty = testProperty "parse . render = id (RssImage)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssImage t =$= runConduitParser rssImage) +roundtripImageProperty = testProperty "parse . render = id (RssImage)" $ \t -> either (const False) (t ==) (runConduit $ renderRssImage t =$= force "ERROR" rssImage) roundtripCategoryProperty :: TestTree -roundtripCategoryProperty = testProperty "parse . render = id (RssCategory)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssCategory t =$= runConduitParser rssCategory) +roundtripCategoryProperty = testProperty "parse . render = id (RssCategory)" $ \t -> either (const False) (t ==) (runConduit $ renderRssCategory t =$= force "ERROR" rssCategory) roundtripEnclosureProperty :: TestTree -roundtripEnclosureProperty = testProperty "parse . render = id (RssEnclosure)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssEnclosure t =$= runConduitParser rssEnclosure) +roundtripEnclosureProperty = testProperty "parse . render = id (RssEnclosure)" $ \t -> either (const False) (t ==) (runConduit $ renderRssEnclosure t =$= force "ERROR" rssEnclosure) roundtripSourceProperty :: TestTree -roundtripSourceProperty = testProperty "parse . render = id (RssSource)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssSource t =$= runConduitParser rssSource) +roundtripSourceProperty = testProperty "parse . render = id (RssSource)" $ \t -> either (const False) (t ==) (runConduit $ renderRssSource t =$= force "ERROR" rssSource) roundtripGuidProperty :: TestTree -roundtripGuidProperty = testProperty "parse . render = id (RssGuid)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssGuid t =$= runConduitParser rssGuid) +roundtripGuidProperty = testProperty "parse . render = id (RssGuid)" $ \t -> either (const False) (t ==) (runConduit $ renderRssGuid t =$= force "ERROR" rssGuid) roundtripItemProperty :: TestTree -roundtripItemProperty = testProperty "parse . render = id (RssItem)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssItem t =$= runConduitParser rssItem) +roundtripItemProperty = testProperty "parse . render = id (RssItem)" $ \t -> either (const False) (t ==) (runConduit $ renderRssItem t =$= force "ERROR" rssItem) letter = choose ('a', 'z')