rss-conduit (empty) → 0.2.0.0
raw patch · 10 files changed
+1224/−0 lines, 10 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, conduit, conduit-extra, conduit-parse, containers, data-default, exceptions, foldl, hlint, lens-simple, mono-traversable, parsers, quickcheck-instances, resourcet, rss-conduit, safe, tasty, tasty-hunit, tasty-quickcheck, text, time, timerep, uri-bytestring, xml-conduit, xml-conduit-parse, xml-types
Files
- LICENSE +13/−0
- README.md +10/−0
- Setup.hs +2/−0
- Text/RSS/Conduit/Parse.hs +289/−0
- Text/RSS/Conduit/Render.hs +169/−0
- Text/RSS/Lens.hs +48/−0
- Text/RSS/Types.hs +231/−0
- rss-conduit.cabal +75/−0
- test/Arbitrary.hs +131/−0
- test/Main.hs +256/−0
+ LICENSE view
@@ -0,0 +1,13 @@+DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+Version 2, December 2004++Copyright (C) 2015 koral <koral at mailoo dot org>++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.
+ README.md view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/RSS/Conduit/Parse.hs view
@@ -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 @\<skipHours\>@ element.+rssSkipHours :: MonadCatch m => ConduitParser Event m (Set Hour)+rssSkipHours = named "Rss <skipHours> element" $ tagIgnoreAttrs "skipHours" $+ fromList <$> many (tagIgnoreAttrs "hour" $ content (asInt >=> asHour))++-- | 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)+++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+ ]+++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
+ Text/RSS/Conduit/Render.hs view
@@ -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+-- }}}
+ Text/RSS/Lens.hs view
@@ -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 #-}
+ Text/RSS/Types.hs view
@@ -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</title>+-- > <link>http://liftoff.msfc.nasa.gov/</link>+-- > <description>Liftoff to Space Exploration.</description>+-- > <language>en-us</language>+-- > <pubDate>Tue, 10 Jun 2003 04:00:00 GMT</pubDate>+-- > <lastBuildDate>Tue, 10 Jun 2003 09:41:01 GMT</lastBuildDate>+-- > <docs>http://blogs.law.harvard.edu/tech/rss</docs>+-- > <generator>Weblog Editor 2.0</generator>+-- > <managingEditor>editor@example.com</managingEditor>+-- > <webMaster>webmaster@example.com</webMaster>+-- > <item>+-- > <title>Star City</title>+-- > <link>http://liftoff.msfc.nasa.gov/news/2003/news-starcity.asp</link>+-- > <description>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>.</description>+-- > <pubDate>Tue, 03 Jun 2003 09:39:21 GMT</pubDate>+-- > <guid>http://liftoff.msfc.nasa.gov/2003/06/03.html#item573</guid>+-- > </item>+-- > </channel>+-- > </rss>+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 @\<category\>@ element.+data RssCategory = RssCategory+ { categoryDomain :: Text+ , categoryName :: Text+ }++deriving instance Eq RssCategory+deriving instance Generic RssCategory+deriving instance Show RssCategory+++-- | The @\<enclosure\>@ element.+data RssEnclosure = RssEnclosure+ { enclosureUrl :: RssURI+ , enclosureLength :: Int+ , enclosureType :: Text+ }++deriving instance Eq RssEnclosure+deriving instance Generic RssEnclosure+deriving instance Show RssEnclosure+++-- | The @\<source\>@ element.+data RssSource = RssSource+ { sourceUrl :: RssURI+ , sourceName :: Text+ }++deriving instance Eq RssSource+deriving instance Generic RssSource+deriving instance Show RssSource+++-- | The @\<guid\>@ element.+data RssGuid = GuidText Text | GuidUri RssURI+ deriving(Eq, Generic, Show)+++-- | The @\<item\>@ 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 @\<textInput\>@ 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 @\<cloud\>@ element.+data RssCloud = RssCloud+ { cloudUri :: RssURI+ , cloudRegisterProcedure :: Text+ , cloudProtocol :: CloudProtocol+ }++deriving instance Eq RssCloud+deriving instance Generic RssCloud+deriving instance Show RssCloud++-- | The @\<image\>@ 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 @\<rss\>@ 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
+ rss-conduit.cabal view
@@ -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
+ test/Arbitrary.hs view
@@ -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
+ test/Main.hs view
@@ -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 "<skipHours> element" $ do+ result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssSkipHours+ result @?= [Hour 0, Hour 9, Hour 18, Hour 21]+ where input = [ "<skipHours>"+ , "<hour>21</hour>"+ , "<hour>9</hour>"+ , "<hour>0</hour>"+ , "<hour>18</hour>"+ , "<hour>9</hour>"+ , "</skipHours>"+ ]++skipDaysCase :: TestTree+skipDaysCase = testCase "<skipDays> element" $ do+ result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssSkipDays+ result @?= [Monday, Saturday, Friday]+ where input = [ "<skipDays>"+ , "<day>Monday</day>"+ , "<day>Monday</day>"+ , "<day>Friday</day>"+ , "<day>Saturday</day>"+ , "</skipDays>"+ ]++textInputCase :: TestTree+textInputCase = testCase "<textInput> 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 = [ "<textInput>"+ , "<title>Title</title>"+ , "<description>Description</description>"+ , "<name>Name</name>"+ , "<link>http://link.ext</link>"+ , "</textInput>"+ ]++imageCase :: TestTree+imageCase = testCase "<image> 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 = [ "<image>"+ , "<uri>http://image.ext</uri>"+ , "<title>Title</title>"+ , "<link>http://link.ext</link>"+ , "<width>100</width>"+ , "<height>200</height>"+ , "<description>Description</description>"+ , "</image>"+ ]++categoryCase :: TestTree+categoryCase = testCase "<category> element" $ do+ result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssCategory+ result @?= RssCategory "Domain" "Name"+ where input = [ "<category domain=\"Domain\">"+ , "Name"+ , "</category>"+ ]++cloudCase :: TestTree+cloudCase = testCase "<cloud> 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 = [ "<cloud domain=\"rpc.sys.com\" port=\"80\" path=\"/RPC2\" registerProcedure=\"pingMe\" protocol=\"soap\"/>"+ , "<cloud domain=\"rpc.sys.com\" port=\"80\" path=\"/RPC2\" registerProcedure=\"myCloud.rssPleaseNotify\" protocol=\"xml-rpc\" />"+ ]+ uri = RssURI (RelativeRef (Just (Authority Nothing (Host "rpc.sys.com") (Just $ Port 80))) "/RPC2" (Query []) Nothing)++guidCase :: TestTree+guidCase = testCase "<guid> element" $ do+ result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser (some rssGuid)+ result @?= [GuidUri uri, GuidText "1", GuidText "2"]+ where input = [ "<guid isPermaLink=\"true\">//guid.ext</guid>"+ , "<guid isPermaLink=\"false\">1</guid>"+ , "<guid>2</guid>"+ ]+ uri = RssURI (RelativeRef (Just (Authority Nothing (Host "guid.ext") Nothing)) "" (Query []) Nothing)++enclosureCase :: TestTree+enclosureCase = testCase "<enclosure> element" $ do+ result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssEnclosure+ result @?= RssEnclosure uri 12216320 "audio/mpeg"+ where input = [ "<enclosure url=\"http://www.scripting.com/mp3s/weatherReportSuite.mp3\" length=\"12216320\" type=\"audio/mpeg\" />"+ ]+ uri = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.scripting.com") Nothing)) "/mp3s/weatherReportSuite.mp3" (Query []) Nothing)++sourceCase :: TestTree+sourceCase = testCase "<source> element" $ do+ result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser rssSource+ result @?= RssSource uri "Tomalak's Realm"+ where input = [ "<source url=\"http://www.tomalak.org/links2.xml\">Tomalak's Realm</source>"+ ]+ uri = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.tomalak.org") Nothing)) "/links2.xml" (Query []) Nothing)++itemCase :: TestTree+itemCase = testCase "<item> 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 = [ "<item>"+ , "<title>Example entry</title>"+ , "<description>Here is some text containing an interesting description.</description>"+ , "<link>http://www.example.com/blog/post/1</link>"+ , "<guid isPermaLink=\"false\">7bd204c6-1655-4c27-aeee-53f933c5395f</guid>"+ , "<pubDate>Sun, 06 Sep 2009 16:20:00 +0000</pubDate>"+ , "</item>"+ ]+ link = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.example.com") Nothing)) "/blog/post/1" (Query []) Nothing)++documentCase :: TestTree+documentCase = testCase "<rss> 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 = [ "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"+ , "<rss version=\"2.0\">"+ , "<channel>"+ , "<title>RSS Title</title>"+ , "<description>This is an example of an RSS feed</description>"+ , "<link>http://www.example.com/main.html</link>"+ , "<lastBuildDate>Mon, 06 Sep 2010 00:01:00 +0000 </lastBuildDate>"+ , "<pubDate>Sun, 06 Sep 2009 16:20:00 +0000</pubDate>"+ , "<ttl>1800</ttl>"+ , "<item>"+ , "<title>Example entry</title>"+ , "<description>Here is some text containing an interesting description.</description>"+ , "<link>http://www.example.com/blog/post/1</link>"+ , "<guid isPermaLink=\"true\">7bd204c6-1655-4c27-aeee-53f933c5395f</guid>"+ , "<pubDate>Sun, 06 Sep 2009 16:20:00 +0000</pubDate>"+ , "</item>"+ , "</channel>"+ , "</rss>"+ ]+ 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]