rss-conduit 0.2.0.2 → 0.3.0.0

raw patch · 6 files changed

+201/−204 lines, 6 filesdep +conduit-combinatorsdep +safe-exceptionsdep −conduit-parsedep −exceptionsdep −foldldep ~conduitdep ~xml-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: conduit-combinators, safe-exceptions

Dependencies removed: conduit-parse, exceptions, foldl, parsers, xml-conduit-parse

Dependency ranges changed: conduit, xml-conduit

API changes (from Hackage documentation)

Files

• README.md +1/−1
• Text/RSS/Conduit/Parse.hs +159/−160
• Text/RSS/Conduit/Render.hs +4/−4
• Text/RSS/Types.hs +9/−5
• rss-conduit.cabal +5/−11
• test/Main.hs +23/−23

@@ -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

@@ -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 @\<skipHours\>@ element.-rssSkipHours :: MonadCatch m => ConduitParser Event m (Set Hour)-rssSkipHours = named "Rss <skipHours> 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 @\<skipDays\>@ element.-rssSkipDays :: MonadCatch m => ConduitParser Event m (Set Day)-rssSkipDays = named "Rss <skipDays> 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 @\<textInput\>@ element.-rssTextInput :: (MonadCatch m) => ConduitParser Event m RssTextInput-rssTextInput = named "Rss <textInput> element" $ tagIgnoreAttrs "textInput" $ do-  p <- many piece-  flip foldM p $ RssTextInput-    <$> handlesM _TextInputTitle (lastRequired "Missing <title> 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

@@ -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

@@ -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

@@ -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

@@ -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</title>"+                , "<ignored>Ignored</ignored>"                 , "<link>http://link.ext</link>"                 , "<width>100</width>"                 , "<height>200</height>"                 , "<description>Description</description>"+                , "<ignored>Ignored</ignored>"                 , "</image>"                 ]  categoryCase :: TestTree categoryCase = testCase "<category> 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 = [ "<category domain=\"Domain\">"                 , "Name"@@ -140,7 +140,7 @@  cloudCase :: TestTree cloudCase = testCase "<cloud> 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 = [ "<cloud domain=\"rpc.sys.com\" port=\"80\" path=\"/RPC2\" registerProcedure=\"pingMe\" protocol=\"soap\"/>"@@ -150,7 +150,7 @@  guidCase :: TestTree guidCase = testCase "<guid> 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 isPermaLink=\"true\">//guid.ext</guid>"                 , "<guid isPermaLink=\"false\">1</guid>"@@ -160,7 +160,7 @@  enclosureCase :: TestTree enclosureCase = testCase "<enclosure> 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 = [ "<enclosure url=\"http://www.scripting.com/mp3s/weatherReportSuite.mp3\" length=\"12216320\" type=\"audio/mpeg\" />"                 ]@@ -168,7 +168,7 @@  sourceCase :: TestTree sourceCase = testCase "<source> 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 = [ "<source url=\"http://www.tomalak.org/links2.xml\">Tomalak's Realm</source>"                 ]@@ -176,7 +176,7 @@  itemCase :: TestTree itemCase = testCase "<item> 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 "<rss> 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')