diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE +Version 2, December 2004 + +Copyright (C) 2015 koral + +Everyone is permitted to copy and distribute verbatim or modified +copies of this license document, and changing it is allowed as long +as the name is changed. + +DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE +TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + +0. You just DO WHAT THE FUCK YOU WANT TO. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +# atom-conduit + +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. + + +[rss]: http://cyber.law.harvard.edu/rss/rss.html +[cdt]: https://hackage.haskell.org/package/conduit +[hsk]: https://haskell.org diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/RSS/Conduit/Parse.hs b/Text/RSS/Conduit/Parse.hs new file mode 100644 --- /dev/null +++ b/Text/RSS/Conduit/Parse.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Streaming parsers for the RSS 2.0 standard. +module Text.RSS.Conduit.Parse + ( -- * Top-level + rssDocument + -- * Elements + , rssCategory + , rssCloud + , rssEnclosure + , rssGuid + , rssImage + , rssItem + , rssSkipDays + , rssSkipHours + , rssSource + , rssTextInput + ) where + +-- {{{ Imports +import Text.RSS.Types + +import Control.Applicative +import Control.Foldl hiding (mconcat) +import Control.Monad hiding (foldM) +import Control.Monad.Catch + +import Data.Conduit.Parser +import Data.Conduit.Parser.XML +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.Encoding +import Data.Time.Clock +import Data.Time.LocalTime +import Data.Time.RFC822 +import Data.Version +import Data.XML.Types + +import Lens.Simple + +import Prelude hiding (last, lookup) + +import Text.Parser.Combinators +import Text.ParserCombinators.ReadP (readP_to_S) +import Text.Read (readMaybe) + +import URI.ByteString +-- }}} + +-- {{{ Util +asRssURI :: (MonadThrow m) => Text -> m RssURI +asRssURI t = case (parseURI' t, parseRelativeRef' t) of + (Right u, _) -> return $ RssURI u + (_, Right u) -> return $ RssURI u + (_, Left e) -> throwM $ InvalidURI e + where parseURI' = parseURI laxURIParserOptions . encodeUtf8 + parseRelativeRef' = parseRelativeRef laxURIParserOptions . encodeUtf8 + +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 "false" = return False +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 "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 + +-- | Like 'tagName' but ignores the namespace. +tagName' :: (MonadCatch m) => Text -> AttrParser a -> (a -> ConduitParser Event m b) -> ConduitParser Event m 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) + + +lastRequired :: (Monad m, Parsing m) => String -> FoldM m a a +lastRequired e = FoldM (\_ a -> return $ Right a) (return $ Left e) (either unexpected 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)) + +-- | Parse a @\@ element. +rssSkipDays :: MonadCatch m => ConduitParser Event m (Set Day) +rssSkipDays = named "Rss element" $ tagIgnoreAttrs "skipDays" $ + fromList <$> many (tagIgnoreAttrs "day" $ content asDay) + + +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 + ] + + +data ImagePiece = ImageUri RssURI | ImageTitle Text | ImageLink RssURI | ImageWidth Int + | ImageHeight Int | ImageDescription Text | ImageUnknown + +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 + ] + + +-- | Parse a @\<category\>@ element. +rssCategory :: MonadCatch m => ConduitParser Event m RssCategory +rssCategory = named "Rss <category> element" $ tagName' "category" (textAttr "domain") $ \domain -> + RssCategory domain <$> textContent + +-- | Parse a @\<cloud\>@ element. +rssCloud :: (MonadCatch m) => ConduitParser Event m RssCloud +rssCloud = named "Rss <cloud> element" $ 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") + <*> pure (Query []) + <*> pure Nothing + RssCloud uri <$> textAttr "registerProcedure" <*> attr "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 + +-- | 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 + 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 + + +data ItemPiece = ItemTitle Text | ItemLink RssURI | ItemDescription Text + | ItemAuthor Text | ItemCategory RssCategory | ItemComments RssURI + | ItemEnclosure RssEnclosure | ItemGuid RssGuid | ItemPubDate UTCTime + | ItemSource RssSource | ItemUnknown + +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 + ] + + +data ChannelPiece = ChannelTitle Text | ChannelLink RssURI | ChannelDescription Text + | ChannelItem RssItem | ChannelLanguage Text | ChannelCopyright Text + | ChannelManagingEditor Text | ChannelWebmaster Text | ChannelPubDate UTCTime + | ChannelLastBuildDate UTCTime | ChannelCategory RssCategory + | ChannelGenerator Text | ChannelDocs RssURI | ChannelCloud RssCloud + | ChannelTtl Int | ChannelImage RssImage | ChannelRating Text + | ChannelTextInput RssTextInput | ChannelSkipHours (Set Hour) + | ChannelSkipDays (Set Day) | ChannelUnknown + +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.") + <*> handlesM _ChannelDescription (lastRequired "Missing <description> element.") + <*> 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 diff --git a/Text/RSS/Conduit/Render.hs b/Text/RSS/Conduit/Render.hs new file mode 100644 --- /dev/null +++ b/Text/RSS/Conduit/Render.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Streaming renderers for the RSS 2.0 standard. +module Text.RSS.Conduit.Render + ( -- * Top-level + renderRssDocument + -- * Elements + , renderRssItem + , renderRssSource + , renderRssEnclosure + , renderRssGuid + , renderRssCloud + , renderRssCategory + , renderRssImage + , renderRssTextInput + , renderRssSkipDays + , renderRssSkipHours + ) where + +-- {{{ Imports +import Text.RSS.Lens +import Text.RSS.Types + +import Control.Monad + +import Data.Conduit +import Data.Monoid +import Data.MonoTraversable +import Data.Set (Set) +import Data.Text as Text hiding (map) +import Data.Text.Encoding +import Data.Time.Clock +import Data.Time.LocalTime +import Data.Time.RFC822 +import Data.Version +import Data.XML.Types + +import Lens.Simple + +import Safe + +import Text.XML.Stream.Render + +import URI.ByteString +-- }}} + +-- | Render the top-level @\<rss\>@ element. +renderRssDocument :: (Monad m) => RssDocument -> Source m Event +renderRssDocument d = tag "rss" (attr "version" . pack . showVersion $ d^.documentVersionL) $ do + textTag "title" $ d^.channelTitleL + textTag "link" $ decodeUtf8 $ withRssURI serializeURIRef' $ d^.channelLinkL + textTag "description" $ d^.channelDescriptionL + optionalTextTag "copyright" $ d^.channelCopyrightL + optionalTextTag "language" $ d^.channelLanguageL + optionalTextTag "managingEditor" $ d^.channelManagingEditorL + optionalTextTag "webMaster" $ d^.channelWebmasterL + forM_ (d^.channelPubDateL) $ dateTag "pubDate" + forM_ (d^.channelLastBuildDateL) $ dateTag "lastBuildDate" + forM_ (d^..channelCategoriesL) renderRssCategory + optionalTextTag "generator" $ d^.channelGeneratorL + forM_ (d^.channelDocsL) $ textTag "docs" . decodeUtf8 . withRssURI serializeURIRef' + forM_ (d^.channelCloudL) renderRssCloud + forM_ (d^.channelTtlL) $ textTag "ttl" . tshow + forM_ (d^.channelImageL) renderRssImage + optionalTextTag "rating" $ d^.channelRatingL + forM_ (d^.channelTextInputL) renderRssTextInput + renderRssSkipHours $ d^.channelSkipHoursL + renderRssSkipDays $ d^.channelSkipDaysL + +-- | Render an @\<item\>@ element. +renderRssItem :: (Monad m) => RssItem -> Source m Event +renderRssItem i = tag "item" mempty $ do + optionalTextTag "title" $ i^.itemTitleL + forM_ (i^.itemLinkL) $ textTag "link" . decodeUtf8 . withRssURI serializeURIRef' + optionalTextTag "description" $ i^.itemDescriptionL + optionalTextTag "author" $ i^.itemAuthorL + forM_ (i^..itemCategoriesL) renderRssCategory + forM_ (i^.itemCommentsL) $ textTag "comments" . decodeUtf8 . withRssURI serializeURIRef' + forM_ (i^..itemEnclosureL) renderRssEnclosure + forM_ (i^.itemGuidL) renderRssGuid + forM_ (i^.itemPubDateL) $ dateTag "pubDate" + forM_ (i^.itemSourceL) renderRssSource + +-- | Render a @\<source\>@ element. +renderRssSource :: (Monad m) => RssSource -> Source m Event +renderRssSource s = tag "source" (attr "url" $ decodeUtf8 $ withRssURI serializeURIRef' $ s^.sourceUrlL) . content $ s^.sourceNameL + +-- | Render an @\<enclosure\>@ element. +renderRssEnclosure :: (Monad m) => RssEnclosure -> Source m Event +renderRssEnclosure e = tag "enclosure" attributes mempty where + attributes = attr "url" (decodeUtf8 $ withRssURI serializeURIRef' $ e^.enclosureUrlL) + <> attr "length" (tshow $ e^.enclosureLengthL) + <> attr "type" (e^.enclosureTypeL) + +-- | Render a @\<guid\>@ element. +renderRssGuid :: (Monad m) => RssGuid -> Source m Event +renderRssGuid (GuidUri u) = tag "guid" (attr "isPermaLink" "true") $ content $ decodeUtf8 $ withRssURI serializeURIRef' u +renderRssGuid (GuidText t) = tag "guid" mempty $ content t + + +-- | Render a @\<cloud\>@ element. +renderRssCloud :: (Monad m) => RssCloud -> Source m Event +renderRssCloud c = tag "cloud" attributes $ return () where + attributes = attr "domain" domain + <> optionalAttr "port" port + <> attr "path" (path <> query <> fragment) + <> attr "registerProcedure" (c^.cloudRegisterProcedureL) + <> attr "protocol" (describe $ c^.cloudProtocolL) + + renderUserInfo (Just (UserInfo a b)) = decodeUtf8 a <> ":" <> decodeUtf8 b <> "@" + renderUserInfo _ = "" + renderHost (Host h) = decodeUtf8 h + renderQuery (Query query) = case intercalate "&" $ map (\(a,b) -> decodeUtf8 a <> "=" <> decodeUtf8 b) query of + "" -> "" + 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) + path = decodeUtf8 $ withRssURI (view pathL) $ c^.cloudUriL + query = renderQuery $ withRssURI (view queryL) $ c^.cloudUriL + fragment = maybe "" decodeUtf8 $ withRssURI (view fragmentL) $ c^.cloudUriL + + describe ProtocolXmlRpc = "xml-rpc" + describe ProtocolSoap = "soap" + describe ProtocolHttpPost = "http-post" + +-- | Render a @\<category\>@ element. +renderRssCategory :: (Monad m) => RssCategory -> Source m Event +renderRssCategory c = tag "category" (attr "domain" $ c^.categoryDomainL) . content $ c^.categoryNameL + +-- | 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 "title" $ i^.imageTitleL + textTag "link" $ decodeUtf8 $ withRssURI serializeURIRef' $ i^.imageLinkL + forM_ (i^.imageHeightL) $ textTag "height" . tshow + forM_ (i^.imageWidthL) $ textTag "width" . tshow + optionalTextTag "description" $ i^.imageDescriptionL + +-- | Render a @\<textInput\>@ element. +renderRssTextInput :: (Monad m) => RssTextInput -> Source m Event +renderRssTextInput t = tag "textInput" mempty $ do + textTag "title" $ t^.textInputTitleL + textTag "description" $ t^.textInputDescriptionL + textTag "name" $ t^.textInputNameL + textTag "link" $ decodeUtf8 $ withRssURI serializeURIRef' $ t^.textInputLinkL + +-- | Render a @\<skipDays\>@ element. +renderRssSkipDays :: (Monad m) => Set Day -> Source m Event +renderRssSkipDays s = tag "skipDays" mempty $ forM_ s $ textTag "day" . tshow + +-- | Render a @\<skipHours\>@ element. +renderRssSkipHours :: (Monad m) => Set Hour -> Source m Event +renderRssSkipHours s = tag "skipHour" mempty $ forM_ s $ textTag "hour" . tshow + + +-- {{{ Utils +tshow :: (Show a) => a -> Text +tshow = pack . show + +textTag :: (Monad m) => Name -> Text -> Source m Event +textTag name = tag name mempty . content + +optionalTextTag :: (Monad m) => Name -> Text -> Source m Event +optionalTextTag name value = unless (onull value) $ textTag name value + +dateTag :: (Monad m) => Name -> UTCTime -> Source m Event +dateTag name = tag name mempty . content . formatTimeRFC822 . utcToZonedTime utc +-- }}} diff --git a/Text/RSS/Lens.hs b/Text/RSS/Lens.hs new file mode 100644 --- /dev/null +++ b/Text/RSS/Lens.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TemplateHaskell #-} +module Text.RSS.Lens where + +-- {{{ Imports +import Lens.Simple + +import Text.RSS.Types + +import URI.ByteString +-- }}} + + +$(makeLensesBy (\n -> Just (n ++ "L")) ''RssCategory) +$(makeLensesBy (\n -> Just (n ++ "L")) ''RssEnclosure) +$(makeLensesBy (\n -> Just (n ++ "L")) ''RssSource) + +$(makeLensesBy + (let f "itemCategories" = Nothing + f "itemEnclosure" = Nothing + f n = Just (n ++ "L") + in f) + ''RssItem) + +itemCategoriesL :: Traversal' RssItem RssCategory +itemCategoriesL inj a@RssItem { itemCategories = c } = (\x -> a { itemCategories = c }) <$> sequenceA (map inj c) +{-# INLINE itemCategoriesL #-} + +itemEnclosureL :: Traversal' RssItem RssEnclosure +itemEnclosureL inj a@RssItem { itemEnclosure = e } = (\x -> a { itemEnclosure = e }) <$> sequenceA (map inj e) +{-# INLINE itemEnclosureL #-} + +$(makeLensesBy (\n -> Just (n ++ "L")) ''RssTextInput) +$(makeLensesBy (\n -> Just (n ++ "L")) ''RssCloud) +$(makeLensesBy (\n -> Just (n ++ "L")) ''RssImage) +$(makeLensesBy + (let f "channelItems" = Nothing + f "channelCategories" = Nothing + f n = Just (n ++ "L") + in f) + ''RssDocument) + +channelItemsL :: Traversal' RssDocument RssItem +channelItemsL inj a@RssDocument { channelItems = i } = (\x -> a { channelItems = i }) <$> sequenceA (map inj i) +{-# INLINE channelItemsL #-} + +channelCategoriesL :: Traversal' RssDocument RssCategory +channelCategoriesL inj a@RssDocument { channelCategories = c } = (\x -> a { channelCategories = c }) <$> sequenceA (map inj c) +{-# INLINE channelCategoriesL #-} diff --git a/Text/RSS/Types.hs b/Text/RSS/Types.hs new file mode 100644 --- /dev/null +++ b/Text/RSS/Types.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +-- | RSS is an XML dialect for Web content syndication. +-- +-- Example: +-- +-- > <?xml version="1.0"?> +-- > <rss version="2.0"> +-- > <channel> +-- > <title>Liftoff News +-- > http://liftoff.msfc.nasa.gov/ +-- > Liftoff to Space Exploration. +-- > en-us +-- > Tue, 10 Jun 2003 04:00:00 GMT +-- > Tue, 10 Jun 2003 09:41:01 GMT +-- > http://blogs.law.harvard.edu/tech/rss +-- > Weblog Editor 2.0 +-- > editor@example.com +-- > webmaster@example.com +-- > +-- > Star City +-- > http://liftoff.msfc.nasa.gov/news/2003/news-starcity.asp +-- > How do Americans get ready to work with Russians aboard the International Space Station? They take a crash course in culture, language and protocol at Russia's <a href="http://howe.iki.rssi.ru/GCTC/gctc_e.htm">Star City</a>. +-- > Tue, 03 Jun 2003 09:39:21 GMT +-- > http://liftoff.msfc.nasa.gov/2003/06/03.html#item573 +-- > +-- > +-- > +module Text.RSS.Types where + +-- {{{ Imports +import Control.Monad.Catch + +import Data.Set +import Data.Text hiding (map) +import Data.Time.Clock +import Data.Time.LocalTime () +import Data.Version + +import GHC.Generics hiding ((:+:)) + +import Text.Read + +import URI.ByteString +-- }}} + + +data RssException = InvalidBool Text + | InvalidDay Text + | InvalidHour Int + | InvalidInt Text + | InvalidURI URIParseError + | InvalidVersion Text + | InvalidProtocol Text + +deriving instance Eq RssException +deriving instance Show RssException + +instance Exception RssException where + displayException (InvalidBool t) = "Invalid bool: " ++ unpack t + displayException (InvalidDay t) = "Invalid day: " ++ unpack t + displayException (InvalidHour i) = "Invalid hour: " ++ show i + displayException (InvalidInt t) = "Invalid int: " ++ unpack t + 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 ++ "\"" + + +data RssURI = forall a . RssURI (URIRef a) + +instance Eq RssURI where + RssURI a@URI{} == RssURI b@URI{} = a == b + RssURI a@RelativeRef{} == RssURI b@RelativeRef{} = a == b + _ == _ = False +instance Show RssURI where + show (RssURI a@URI{}) = show a + show (RssURI a@RelativeRef{}) = show a + +withRssURI :: (forall a . URIRef a -> b) -> RssURI -> b +withRssURI f (RssURI a) = f a + + +-- | The @\@ element. +data RssCategory = RssCategory + { categoryDomain :: Text + , categoryName :: Text + } + +deriving instance Eq RssCategory +deriving instance Generic RssCategory +deriving instance Show RssCategory + + +-- | The @\@ element. +data RssEnclosure = RssEnclosure + { enclosureUrl :: RssURI + , enclosureLength :: Int + , enclosureType :: Text + } + +deriving instance Eq RssEnclosure +deriving instance Generic RssEnclosure +deriving instance Show RssEnclosure + + +-- | The @\@ element. +data RssSource = RssSource + { sourceUrl :: RssURI + , sourceName :: Text + } + +deriving instance Eq RssSource +deriving instance Generic RssSource +deriving instance Show RssSource + + +-- | The @\@ element. +data RssGuid = GuidText Text | GuidUri RssURI + deriving(Eq, Generic, Show) + + +-- | The @\@ element. +data RssItem = RssItem + { itemTitle :: Text + , itemLink :: Maybe RssURI + , itemDescription :: Text + , itemAuthor :: Text + , itemCategories :: [RssCategory] + , itemComments :: Maybe RssURI + , itemEnclosure :: [RssEnclosure] + , itemGuid :: Maybe RssGuid + , itemPubDate :: Maybe UTCTime + , itemSource :: Maybe RssSource + } + +deriving instance Eq RssItem +deriving instance Generic RssItem +deriving instance Show RssItem + + +-- | The @\@ element. +data RssTextInput = RssTextInput + { textInputTitle :: Text + , textInputDescription :: Text + , textInputName :: Text + , textInputLink :: RssURI + } + +deriving instance Eq RssTextInput +deriving instance Generic RssTextInput +deriving instance Show RssTextInput + +data CloudProtocol = ProtocolXmlRpc | ProtocolSoap | ProtocolHttpPost + deriving(Eq, Generic, Show) + +-- | The @\@ element. +data RssCloud = RssCloud + { cloudUri :: RssURI + , cloudRegisterProcedure :: Text + , cloudProtocol :: CloudProtocol + } + +deriving instance Eq RssCloud +deriving instance Generic RssCloud +deriving instance Show RssCloud + +-- | The @\@ element. +data RssImage = RssImage + { imageUri :: RssURI + , imageTitle :: Text + , imageLink :: RssURI + , imageWidth :: Maybe Int + , imageHeight :: Maybe Int + , imageDescription :: Text + } + +deriving instance Eq RssImage +deriving instance Generic RssImage +deriving instance Show RssImage + + +newtype Hour = Hour Int + deriving(Eq, Generic, Ord, Show) + +-- | Smart constructor for 'Hour' +asHour :: MonadThrow m => Int -> m Hour +asHour i + | i >= 0 && i < 24 = return $ Hour i + | otherwise = throwM $ InvalidHour i + +data Day = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday + deriving(Enum, Eq, Generic, Ord, Read, Show) + +-- | Basic parser for 'Day'. +asDay :: MonadThrow m => Text -> m Day +asDay t = maybe (throwM $ InvalidDay t) return . readMaybe $ unpack t + +-- | The @\@ element. +data RssDocument = RssDocument + { documentVersion :: Version + , channelTitle :: Text + , channelLink :: RssURI + , channelDescription :: Text + , channelItems :: [RssItem] + , channelLanguage :: Text + , channelCopyright :: Text + , channelManagingEditor :: Text + , channelWebmaster :: Text + , channelPubDate :: Maybe UTCTime + , channelLastBuildDate :: Maybe UTCTime + , channelCategories :: [RssCategory] + , channelGenerator :: Text + , channelDocs :: Maybe RssURI + , channelCloud :: Maybe RssCloud + , channelTtl :: Maybe Int + , channelImage :: Maybe RssImage + , channelRating :: Text + , channelTextInput :: Maybe RssTextInput + , channelSkipHours :: Set Hour + , channelSkipDays :: Set Day + } + +deriving instance Eq RssDocument +deriving instance Generic RssDocument +deriving instance Show RssDocument diff --git a/rss-conduit.cabal b/rss-conduit.cabal new file mode 100644 --- /dev/null +++ b/rss-conduit.cabal @@ -0,0 +1,75 @@ +name: rss-conduit +version: 0.2.0.0 +synopsis: Streaming parser/renderer for the RSS 2.0 standard. +description: Cf README file. +license: OtherLicense +license-file: LICENSE +author: koral +maintainer: koral att mailoo dott org +category: XML, Conduit +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/k0ral/rss-conduit.git + +library + exposed-modules: + Text.RSS.Conduit.Parse + Text.RSS.Conduit.Render + Text.RSS.Lens + Text.RSS.Types + -- other-modules: + build-depends: + base >= 4.8 && < 5 + , conduit + , conduit-parse + , containers + , exceptions + , foldl + , 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 + +test-suite Tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: Arbitrary + build-depends: + rss-conduit + , base >= 4.8 && < 5 + , bytestring + , conduit + , conduit-extra + , conduit-parse + , data-default + , exceptions + , hlint + , lens-simple + , mono-traversable + , parsers + , QuickCheck + , quickcheck-instances + , resourcet + , tasty + , tasty-hunit + , tasty-quickcheck + , time >= 1.5 + , text + , uri-bytestring >= 0.2 + , xml-conduit >= 1.3 + , xml-conduit-parse >= 0.3 + , xml-types + default-language: Haskell2010 diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Arbitrary.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +-- | 'Arbitrary' instances used by RSS types. +module Arbitrary where + +-- {{{ Imports +import Data.ByteString (ByteString) +import Data.Char +import Data.Maybe +import Data.MonoTraversable (Element) +import Data.NonNull +import Data.Sequences (SemiSequence) +import Data.Text (Text, find, pack) +import Data.Text.Encoding +import Data.Time.Clock +import Data.Version + +import GHC.Generics + +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import Text.RSS.Types + +import URI.ByteString +-- }}} + + +-- | Reasonable enough 'URI' generator. +instance Arbitrary (URIRef Absolute) where + arbitrary = URI <$> arbitrary <*> arbitrary <*> genPath <*> arbitrary <*> (Just <$> genFragment) + shrink (URI a b c d e) = URI <$> shrink a <*> shrink b <*> shrink c <*> shrink d <*> shrink e + +-- | Reasonable enough 'RelativeRef' generator. +instance Arbitrary (URIRef Relative) where + arbitrary = RelativeRef <$> arbitrary <*> genPath <*> arbitrary <*> (Just <$> genFragment) + shrink (RelativeRef a b c d) = RelativeRef <$> shrink a <*> shrink b <*> shrink c <*> shrink d + +-- | Reasonable enough 'Authority' generator. +instance Arbitrary Authority where + arbitrary = Authority <$> arbitrary <*> arbitrary <*> arbitrary + shrink = genericShrink + +genFragment :: Gen ByteString +genFragment = encodeUtf8 . pack <$> listOf1 genAlphaNum + +instance Arbitrary Host where + arbitrary = Host . encodeUtf8 . pack <$> listOf1 genAlphaNum + shrink = genericShrink + +genPath :: Gen ByteString +genPath = encodeUtf8 . pack . ("/" ++) <$> listOf1 genAlphaNum + +instance Arbitrary Port where + arbitrary = do + Positive port <- arbitrary + return $ Port port + +instance Arbitrary Query where + arbitrary = do + a <- listOf1 (encodeUtf8 . pack <$> listOf1 genAlphaNum) + b <- listOf1 (encodeUtf8 . pack <$> listOf1 genAlphaNum) + return $ Query $ Prelude.zip a b + shrink = genericShrink + +instance Arbitrary Scheme where + arbitrary = Scheme . encodeUtf8 . pack <$> listOf1 (choose('a', 'z')) + shrink = genericShrink + +instance Arbitrary UserInfo where + arbitrary = do + a <- encodeUtf8 . pack <$> listOf1 genAlphaNum + b <- encodeUtf8 . pack <$> listOf1 genAlphaNum + return $ UserInfo a b + shrink = genericShrink + + +instance Arbitrary RssCategory where + arbitrary = RssCategory <$> (pack <$> listOf genAlphaNum) <*> (pack <$> listOf genAlphaNum) + +instance Arbitrary CloudProtocol where + arbitrary = oneof $ map pure [ProtocolXmlRpc, ProtocolSoap, ProtocolHttpPost] + +instance Arbitrary RssCloud where + arbitrary = RssCloud <$> arbitrary <*> (pack <$> listOf genAlphaNum) <*> arbitrary + +instance Arbitrary RssEnclosure where + arbitrary = do + Positive l <- arbitrary + RssEnclosure <$> arbitrary <*> pure l <*> (pack <$> listOf genAlphaNum) + +instance Arbitrary RssGuid where + arbitrary = oneof [GuidText <$> (pack <$> listOf genAlphaNum), GuidUri <$> arbitrary] + +instance Arbitrary RssImage where + arbitrary = RssImage <$> arbitrary <*> (pack <$> listOf genAlphaNum) <*> arbitrary <*> fmap (fmap abs) arbitrary <*> fmap (fmap abs) arbitrary <*> (pack <$> listOf genAlphaNum) + +instance Arbitrary RssItem where + arbitrary = RssItem + <$> (pack <$> listOf genAlphaNum) + <*> arbitrary + <*> (pack <$> listOf genAlphaNum) + <*> (pack <$> listOf genAlphaNum) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> oneof [Just <$> genTime, pure Nothing] + <*> arbitrary + +instance Arbitrary RssSource where + arbitrary = RssSource <$> arbitrary <*> (pack <$> listOf genAlphaNum) + +instance Arbitrary RssTextInput where + arbitrary = RssTextInput <$> (pack <$> listOf genAlphaNum) <*> (pack <$> listOf genAlphaNum) <*> (pack <$> listOf genAlphaNum) <*> arbitrary + + +-- | Alpha-numeric generator. +genAlphaNum :: Gen Char +genAlphaNum = oneof [choose('a', 'z'), arbitrary `suchThat` isDigit] + +-- | Generates 'UTCTime' with rounded seconds. +genTime :: Gen UTCTime +genTime = do + (UTCTime d s) <- arbitrary + return $ UTCTime d $ fromIntegral (round s :: Int) + +instance Arbitrary RssURI where + arbitrary = oneof [RssURI <$> (arbitrary :: Gen (URIRef Absolute)), RssURI <$> (arbitrary :: Gen (URIRef Relative))] + shrink (RssURI a@URI{}) = RssURI <$> shrink a + shrink (RssURI a@RelativeRef{}) = RssURI <$> shrink a diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +-- {{{ Imports +import Arbitrary + +import Control.Monad.Catch.Pure +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 + +import qualified Language.Haskell.HLint as HLint (hlint) + +import Lens.Simple + +import Test.Tasty +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.Render + +import URI.ByteString + +import System.IO +-- }}} + +main :: IO () +main = defaultMain $ testGroup "Tests" + [ unitTests + , properties + , hlint + ] + +unitTests :: TestTree +unitTests = testGroup "Unit tests" + [ skipHoursCase + , skipDaysCase + , textInputCase + , imageCase + , categoryCase + , cloudCase + , guidCase + , enclosureCase + , sourceCase + , itemCase + , documentCase + ] + +properties :: TestTree +properties = testGroup "Properties" + [ roundtripTextInputProperty + , roundtripImageProperty + , roundtripCategoryProperty + , roundtripEnclosureProperty + , roundtripSourceProperty + , roundtripGuidProperty + , roundtripItemProperty + ] + + +skipHoursCase :: TestTree +skipHoursCase = testCase " element" $ do + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssSkipHours + result @?= [Hour 0, Hour 9, Hour 18, Hour 21] + where input = [ "" + , "21" + , "9" + , "0" + , "18" + , "9" + , "" + ] + +skipDaysCase :: TestTree +skipDaysCase = testCase " element" $ do + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssSkipDays + result @?= [Monday, Saturday, Friday] + where input = [ "" + , "Monday" + , "Monday" + , "Friday" + , "Saturday" + , "" + ] + +textInputCase :: TestTree +textInputCase = testCase " element" $ do + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssTextInput + result^.textInputTitleL @?= "Title" + result^.textInputDescriptionL @?= "Description" + result^.textInputNameL @?= "Name" + result^.textInputLinkL @=? RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "link.ext") Nothing)) "" (Query []) Nothing) + where input = [ "" + , "Title" + , "Description" + , "Name" + , "http://link.ext" + , "" + ] + +imageCase :: TestTree +imageCase = testCase " element" $ do + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser 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) + result^.imageWidthL @?= Just 100 + result^.imageHeightL @?= Just 200 + result^.imageDescriptionL @?= "Description" + where input = [ "" + , "http://image.ext" + , "Title" + , "http://link.ext" + , "100" + , "200" + , "Description" + , "" + ] + +categoryCase :: TestTree +categoryCase = testCase " element" $ do + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssCategory + result @?= RssCategory "Domain" "Name" + where input = [ "" + , "Name" + , "" + ] + +cloudCase :: TestTree +cloudCase = testCase " element" $ do + (result1, result2) <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser ((,) <$> rssCloud <*> rssCloud) + result1 @?= RssCloud uri "pingMe" ProtocolSoap + result2 @?= RssCloud uri "myCloud.rssPleaseNotify" ProtocolXmlRpc + where input = [ "" + , "" + ] + uri = RssURI (RelativeRef (Just (Authority Nothing (Host "rpc.sys.com") (Just $ Port 80))) "/RPC2" (Query []) Nothing) + +guidCase :: TestTree +guidCase = testCase " element" $ do + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser (some rssGuid) + result @?= [GuidUri uri, GuidText "1", GuidText "2"] + where input = [ "//guid.ext" + , "1" + , "2" + ] + uri = RssURI (RelativeRef (Just (Authority Nothing (Host "guid.ext") Nothing)) "" (Query []) Nothing) + +enclosureCase :: TestTree +enclosureCase = testCase " element" $ do + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssEnclosure + result @?= RssEnclosure uri 12216320 "audio/mpeg" + where input = [ "" + ] + uri = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.scripting.com") Nothing)) "/mp3s/weatherReportSuite.mp3" (Query []) Nothing) + +sourceCase :: TestTree +sourceCase = testCase " element" $ do + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssSource + result @?= RssSource uri "Tomalak's Realm" + where input = [ "Tomalak's Realm" + ] + uri = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.tomalak.org") Nothing)) "/links2.xml" (Query []) Nothing) + +itemCase :: TestTree +itemCase = testCase " element" $ do + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssItem + result^.itemTitleL @?= "Example entry" + result^.itemLinkL @?= Just link + result^.itemDescriptionL @?= "Here is some text containing an interesting description." + result^.itemGuidL @?= Just (GuidText "7bd204c6-1655-4c27-aeee-53f933c5395f") + -- isJust (result^.itemPubDate_) @?= True + where input = [ "" + , "Example entry" + , "Here is some text containing an interesting description." + , "http://www.example.com/blog/post/1" + , "7bd204c6-1655-4c27-aeee-53f933c5395f" + , "Sun, 06 Sep 2009 16:20:00 +0000" + , "" + ] + link = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.example.com") Nothing)) "/blog/post/1" (Query []) Nothing) + +documentCase :: TestTree +documentCase = testCase " element" $ do + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssDocument + result^.documentVersionL @?= Version [2] [] + result^.channelTitleL @?= "RSS Title" + result^.channelDescriptionL @?= "This is an example of an RSS feed" + result^.channelLinkL @?= link + result^.channelTtlL @?= Just 1800 + length (result^..channelItemsL) @?= 1 + where input = [ "" + , "" + , "" + , "RSS Title" + , "This is an example of an RSS feed" + , "http://www.example.com/main.html" + , "Mon, 06 Sep 2010 00:01:00 +0000 " + , "Sun, 06 Sep 2009 16:20:00 +0000" + , "1800" + , "" + , "Example entry" + , "Here is some text containing an interesting description." + , "http://www.example.com/blog/post/1" + , "7bd204c6-1655-4c27-aeee-53f933c5395f" + , "Sun, 06 Sep 2009 16:20:00 +0000" + , "" + , "" + , "" + ] + link = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.example.com") Nothing)) "/main.html" (Query []) Nothing) + + +hlint :: TestTree +hlint = testCase "HLint check" $ do + result <- HLint.hlint [ "test/", "Text/" ] + Prelude.null result @?= True + + +roundtripTextInputProperty :: TestTree +roundtripTextInputProperty = testProperty "parse . render = id (RssTextInput)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssTextInput t =$= runConduitParser rssTextInput) + +roundtripImageProperty :: TestTree +roundtripImageProperty = testProperty "parse . render = id (RssImage)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssImage t =$= runConduitParser rssImage) + +roundtripCategoryProperty :: TestTree +roundtripCategoryProperty = testProperty "parse . render = id (RssCategory)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssCategory t =$= runConduitParser rssCategory) + +roundtripEnclosureProperty :: TestTree +roundtripEnclosureProperty = testProperty "parse . render = id (RssEnclosure)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssEnclosure t =$= runConduitParser rssEnclosure) + +roundtripSourceProperty :: TestTree +roundtripSourceProperty = testProperty "parse . render = id (RssSource)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssSource t =$= runConduitParser rssSource) + +roundtripGuidProperty :: TestTree +roundtripGuidProperty = testProperty "parse . render = id (RssGuid)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssGuid t =$= runConduitParser rssGuid) + +roundtripItemProperty :: TestTree +roundtripItemProperty = testProperty "parse . render = id (RssItem)" $ \t -> either (const False) (t ==) (runIdentity . runCatchT . runConduit $ renderRssItem t =$= runConduitParser rssItem) + + +letter = choose ('a', 'z') +digit = arbitrary `suchThat` isDigit +alphaNum = oneof [letter, digit]