rss-conduit 0.3.1.2 → 0.3.2.0

raw patch · 6 files changed

+86/−36 lines, 6 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Text/RSS/Conduit/Parse.hs +1/−1
• Text/RSS/Conduit/Render.hs +36/−32
• Text/RSS/Types.hs +12/−2
• rss-conduit.cabal +1/−1
• test/Arbitrary.hs +30/−0
• test/Main.hs +6/−0

@@ -54,7 +54,7 @@ -- }}}  -- {{{ Util-asRssURI :: (MonadThrow m) => Text -> m RssURI+asRssURI :: MonadThrow m => Text -> m RssURI asRssURI t = case (parseURI' t, parseRelativeRef' t) of   (Right u, _) -> return $ RssURI u   (_, Right u) -> return $ RssURI u

@@ -45,37 +45,38 @@  -- | 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-  forM_ (d^..channelItemsL) renderRssItem+renderRssDocument d = tag "rss" (attr "version" . pack . showVersion $ d^.documentVersionL) $+  tag "channel" mempty $ do+    textTag "title" $ d^.channelTitleL+    textTag "link" $ renderRssURI $ 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" . renderRssURI+    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+    forM_ (d^..channelItemsL) renderRssItem  -- | 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'+  forM_ (i^.itemLinkL) $ textTag "link" . renderRssURI   optionalTextTag "description" $ i^.itemDescriptionL   optionalTextTag "author" $ i^.itemAuthorL   forM_ (i^..itemCategoriesL) renderRssCategory-  forM_ (i^.itemCommentsL) $ textTag "comments" . decodeUtf8 . withRssURI serializeURIRef'+  forM_ (i^.itemCommentsL) $ textTag "comments" . renderRssURI   forM_ (i^..itemEnclosureL) renderRssEnclosure   forM_ (i^.itemGuidL) renderRssGuid   forM_ (i^.itemPubDateL) $ dateTag "pubDate"@@ -83,23 +84,23 @@  -- | 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+renderRssSource s = tag "source" (attr "url" $ renderRssURI $ 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)+  attributes = attr "url" (renderRssURI $ 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 (GuidUri u) = tag "guid" (attr "isPermaLink" "true") $ content $ renderRssURI u renderRssGuid (GuidText t) = tag "guid" mempty $ content t   -- | Render a @\<cloud\>@ element.-renderRssCloud :: (Monad m) => RssCloud -> Source m Event+renderRssCloud :: Monad m => RssCloud -> Source m Event renderRssCloud c = tag "cloud" attributes $ return () where   attributes = attr "domain" domain     <> optionalAttr "port" port@@ -131,9 +132,9 @@ -- | Render an @\<image\>@ element. renderRssImage :: (Monad m) => RssImage -> Source m Event renderRssImage i = tag "image" mempty $ do-  textTag "url" $ decodeUtf8 $ withRssURI serializeURIRef' $ i^.imageUriL+  textTag "url" $ renderRssURI $ i^.imageUriL   textTag "title" $ i^.imageTitleL-  textTag "link" $ decodeUtf8 $ withRssURI serializeURIRef' $ i^.imageLinkL+  textTag "link" $ renderRssURI $ i^.imageLinkL   forM_ (i^.imageHeightL) $ textTag "height" . tshow   forM_ (i^.imageWidthL) $ textTag "width" . tshow   optionalTextTag "description" $ i^.imageDescriptionL@@ -144,15 +145,15 @@   textTag "title" $ t^.textInputTitleL   textTag "description" $ t^.textInputDescriptionL   textTag "name" $ t^.textInputNameL-  textTag "link" $ decodeUtf8 $ withRssURI serializeURIRef' $ t^.textInputLinkL+  textTag "link" $ renderRssURI $ t^.textInputLinkL  -- | Render a @\<skipDays\>@ element. renderRssSkipDays :: (Monad m) => Set Day -> Source m Event-renderRssSkipDays s = tag "skipDays" mempty $ forM_ s $ textTag "day" . tshow+renderRssSkipDays s = unless (onull 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+renderRssSkipHours s = unless (onull s) $ tag "skipHour" mempty $ forM_ s $ textTag "hour" . tshow   -- {{{ Utils@@ -167,4 +168,7 @@  dateTag :: (Monad m) => Name -> UTCTime -> Source m Event dateTag name = tag name mempty . content . formatTimeRFC822 . utcToZonedTime utc++renderRssURI :: RssURI -> Text+renderRssURI = decodeUtf8 . withRssURI serializeURIRef' -- }}}

@@ -37,6 +37,7 @@ -- {{{ Imports import           Control.Exception.Safe +import           Data.Semigroup import           Data.Set import           Data.Text              hiding (map) import           Data.Time.Clock@@ -204,8 +205,17 @@   newtype Hour = Hour Int-  deriving(Eq, Generic, Ord, Show)+  deriving(Eq, Generic, Ord, Read, Show) +instance Bounded Hour where+  minBound = Hour 0+  maxBound = Hour 23++instance Enum Hour where+  fromEnum (Hour h) = fromEnum h+  toEnum i = if i >= 0 && i < 24 then Hour i else error $ "Invalid hour: " <> show i++ -- | Smart constructor for 'Hour' asHour :: MonadThrow m => Int -> m Hour asHour i@@ -213,7 +223,7 @@   | otherwise = throwM $ InvalidHour i  data Day = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday-  deriving(Enum, Eq, Generic, Ord, Read, Show)+  deriving(Bounded, Enum, Eq, Generic, Ord, Read, Show)  -- | Basic parser for 'Day'. asDay :: MonadThrow m => Text -> m Day

@@ -1,5 +1,5 @@ name:                rss-conduit-version:             0.3.1.2+version:             0.3.2.0 synopsis:            Streaming parser/renderer for the RSS standard. description:         Cf README file. license:             PublicDomain

@@ -114,6 +114,36 @@ instance Arbitrary RssTextInput where   arbitrary = RssTextInput <$> (pack <$> listOf genAlphaNum) <*> (pack <$> listOf genAlphaNum) <*> (pack <$> listOf genAlphaNum) <*> arbitrary +instance Arbitrary RssDocument where+  arbitrary = RssDocument+    <$> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> vectorOf 1 arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> oneof [Just <$> genTime, pure Nothing]+    <*> oneof [Just <$> genTime, pure Nothing]+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary++instance Arbitrary Day where+  arbitrary = arbitraryBoundedEnum+  shrink = genericShrink++instance Arbitrary Hour where+  arbitrary = Hour <$> suchThat arbitrary (\x -> x >= 0 && x < 24)  -- | Alpha-numeric generator. genAlphaNum :: Gen Char

@@ -14,6 +14,7 @@ import           Data.Conduit.List import           Data.Default import           Data.Version+import           Data.XML.Types  import qualified Language.Haskell.HLint       as HLint (hlint) @@ -72,6 +73,7 @@   , roundtripSourceProperty   , roundtripGuidProperty   , roundtripItemProperty+  , roundtripDocumentProperty   ]  @@ -379,6 +381,10 @@ roundtripItemProperty :: TestTree roundtripItemProperty = testProperty "parse . render = id (RssItem)" $ \t -> either (const False) (t ==) (runConduit $ renderRssItem t =$= force "ERROR" rssItem) +roundtripDocumentProperty :: TestTree+roundtripDocumentProperty = testProperty "parse . render = id (RssDocument)" $ \t ->+  counterexample (show (runConduit (renderRssDocument t =$= consume) :: Maybe ([Event]))) $+    Just (Just t) === runConduit (renderRssDocument t =$= rssDocument)  letter = choose ('a', 'z') digit = arbitrary `suchThat` isDigit