diff --git a/Text/RSS/Conduit/Parse.hs b/Text/RSS/Conduit/Parse.hs --- a/Text/RSS/Conduit/Parse.hs +++ b/Text/RSS/Conduit/Parse.hs @@ -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 diff --git a/Text/RSS/Conduit/Render.hs b/Text/RSS/Conduit/Render.hs --- a/Text/RSS/Conduit/Render.hs +++ b/Text/RSS/Conduit/Render.hs @@ -45,37 +45,38 @@ -- | Render the top-level @\@ 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 @\@ 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 @\@ 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 @\@ 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 @\@ 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 @\@ 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 @\@ 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 @\@ 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 @\@ 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' -- }}} diff --git a/Text/RSS/Types.hs b/Text/RSS/Types.hs --- a/Text/RSS/Types.hs +++ b/Text/RSS/Types.hs @@ -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 diff --git a/rss-conduit.cabal b/rss-conduit.cabal --- a/rss-conduit.cabal +++ b/rss-conduit.cabal @@ -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 diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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