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 @@ -17,6 +17,7 @@ ) where -- {{{ Imports +import Text.RSS.Extensions import Text.RSS.Lens import Text.RSS.Types @@ -39,9 +40,7 @@ -- }}} -- | Render the top-level @\@ element. --- --- __Note__: RSS extensions are NOT rendered. -renderRssDocument :: Monad m => RssDocument a -> Source m Event +renderRssDocument :: Monad m => RenderRssExtensions e => RssDocument e -> Source m Event renderRssDocument d = tag "rss" (attr "version" . pack . showVersion $ d^.documentVersionL) $ tag "channel" mempty $ do textTag "title" $ d^.channelTitleL @@ -64,11 +63,10 @@ renderRssSkipHours $ d^.channelSkipHoursL renderRssSkipDays $ d^.channelSkipDaysL forM_ (d^..channelItemsL) renderRssItem + renderRssChannelExtensions $ d^.channelExtensionsL -- | Render an @\@ element. --- --- __Note__: RSS extensions are NOT rendered. -renderRssItem :: Monad m => RssItem e -> Source m Event +renderRssItem :: Monad m => RenderRssExtensions e => RssItem e -> Source m Event renderRssItem i = tag "item" mempty $ do optionalTextTag "title" $ i^.itemTitleL forM_ (i^.itemLinkL) $ textTag "link" . renderRssURI @@ -80,6 +78,7 @@ forM_ (i^.itemGuidL) renderRssGuid forM_ (i^.itemPubDateL) $ dateTag "pubDate" forM_ (i^.itemSourceL) renderRssSource + renderRssItemExtensions $ i^.itemExtensionsL -- | Render a @\@ element. renderRssSource :: (Monad m) => RssSource -> Source m Event @@ -156,7 +155,7 @@ -- {{{ Utils -tshow :: (Show a) => a -> Text +tshow :: Show a => a -> Text tshow = pack . show textTag :: (Monad m) => Name -> Text -> Source m Event diff --git a/Text/RSS/Extensions.hs b/Text/RSS/Extensions.hs --- a/Text/RSS/Extensions.hs +++ b/Text/RSS/Extensions.hs @@ -47,6 +47,16 @@ -- | Requirement on a list of extension tags to be able to parse and combine them. type ParseRssExtensions (e :: [*]) = (AllConstrained ParseRssExtension e, SingI e) +-- | Class of RSS extensions that can be rendered. +class RenderRssExtension e where + -- | Render extension for the @\@ element. + renderRssChannelExtension :: Monad m => RssChannelExtension e -> Source m Event + -- | Render extension for the @\@ element. + renderRssItemExtension :: Monad m => RssItemExtension e -> Source m Event + +-- | Requirement on a list of extension tags to be able to render them. +type RenderRssExtensions (e :: [*]) = (AllConstrained RenderRssExtension e) + -- | Parse a combination of RSS extensions at @\@ level. parseRssChannelExtensions :: ParseRssExtensions e => MonadThrow m => ConduitM Event o m (RssChannelExtensions e) parseRssChannelExtensions = f sing where @@ -66,3 +76,17 @@ f (SCons _ es) = fmap RssItemExtensions $ getZipConduit $ (:&) <$> ZipConduit parseRssItemExtension <*> ZipConduit (rssItemExtension <$> f es) + +-- | Render a set of @\@ extensions. +renderRssChannelExtensions :: Monad m => RenderRssExtensions e => RssChannelExtensions e -> Source m Event +renderRssChannelExtensions (RssChannelExtensions RNil) = pure () +renderRssChannelExtensions (RssChannelExtensions (a :& t)) = do + renderRssChannelExtension a + renderRssChannelExtensions (RssChannelExtensions t) + +-- | Render a set of @\@ extensions. +renderRssItemExtensions :: Monad m => RenderRssExtensions e => RssItemExtensions e -> Source m Event +renderRssItemExtensions (RssItemExtensions RNil) = pure () +renderRssItemExtensions (RssItemExtensions (a :& t)) = do + renderRssItemExtension a + renderRssItemExtensions (RssItemExtensions t) diff --git a/Text/RSS/Extensions/Atom.hs b/Text/RSS/Extensions/Atom.hs --- a/Text/RSS/Extensions/Atom.hs +++ b/Text/RSS/Extensions/Atom.hs @@ -11,10 +11,11 @@ import Text.RSS.Extensions import Text.RSS.Types -import Conduit hiding (throwM) +import Conduit hiding (throwM) import Data.Singletons import GHC.Generics import Text.Atom.Conduit.Parse +import Text.Atom.Conduit.Render import Text.Atom.Types import Text.XML.Stream.Parse -- }}} @@ -29,6 +30,10 @@ instance ParseRssExtension AtomModule where parseRssChannelExtension = AtomChannel <$> (manyYield' atomLink =$= headC) parseRssItemExtension = AtomItem <$> (manyYield' atomLink =$= headC) + +instance RenderRssExtension AtomModule where + renderRssChannelExtension = mapM_ renderAtomLink . channelAtomLink + renderRssItemExtension = mapM_ renderAtomLink . itemAtomLink data instance RssChannelExtension AtomModule = AtomChannel { channelAtomLink :: Maybe AtomLink } deriving(Eq, Generic, Show) diff --git a/Text/RSS/Extensions/Content.hs b/Text/RSS/Extensions/Content.hs --- a/Text/RSS/Extensions/Content.hs +++ b/Text/RSS/Extensions/Content.hs @@ -13,8 +13,10 @@ ContentModule(..) , RssChannelExtension(ContentChannel) , RssItemExtension(ContentItem) - -- * Parsers + -- * Parser , contentEncoded + -- * Renderer + , renderContentEncoded -- * Misc , namespacePrefix , namespaceURI @@ -26,12 +28,15 @@ import Conduit hiding (throwM) import Control.Exception.Safe as Exception +import Control.Monad import Data.Maybe import Data.Singletons -import Data.Text +import Data.Text (Text) +import qualified Data.Text as Text import Data.XML.Types import GHC.Generics import Text.XML.Stream.Parse +import qualified Text.XML.Stream.Render as Render import URI.ByteString -- }}} @@ -46,6 +51,9 @@ parseRssChannelExtension = pure ContentChannel parseRssItemExtension = ContentItem <$> (manyYield' contentEncoded =$= headDefC mempty) +instance RenderRssExtension ContentModule where + renderRssChannelExtension = const $ pure () + renderRssItemExtension (ContentItem e) = unless (Text.null e) $ renderContentEncoded e data instance RssChannelExtension ContentModule = ContentChannel deriving(Eq, Generic, Ord, Show) data instance RssItemExtension ContentModule = ContentItem { itemContent :: Text } @@ -66,3 +74,7 @@ -- | Parse a @\@ element. contentEncoded :: MonadThrow m => ConduitM Event o m (Maybe Text) contentEncoded = tagIgnoreAttrs (matching (== contentName "encoded")) content + +-- | Render a @\@ element. +renderContentEncoded :: Monad m => Text -> Source m Event +renderContentEncoded = Render.tag (contentName "encoded") mempty . Render.content diff --git a/Text/RSS/Extensions/DublinCore.hs b/Text/RSS/Extensions/DublinCore.hs --- a/Text/RSS/Extensions/DublinCore.hs +++ b/Text/RSS/Extensions/DublinCore.hs @@ -3,6 +3,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | __Dublin Core__ extension for RSS. @@ -21,19 +22,22 @@ import Text.RSS.Extensions import Text.RSS.Types -import Conduit hiding (throwM) -import Control.Exception.Safe as Exception +import Conduit hiding (throwM) +import Control.Exception.Safe as Exception +import Control.Monad import Control.Monad.Fix import Data.Maybe import Data.Singletons -import Data.Text +import Data.Text (Text) +import qualified Data.Text as Text import Data.Time.Clock import Data.Time.LocalTime import Data.Time.RFC3339 import Data.XML.Types import GHC.Generics import Lens.Simple -import qualified Text.XML.DublinCore.Conduit.Parse as DC +import qualified Text.XML.DublinCore.Conduit.Parse as DC +import Text.XML.DublinCore.Conduit.Render import Text.XML.Stream.Parse import URI.ByteString -- }}} @@ -115,7 +119,26 @@ , fmap ElementType <$> DC.elementType ] +-- | Render a set of Dublin Core metadata elements. +renderDcMetadata :: Monad m => DcMetaData -> Source m Event +renderDcMetadata DcMetaData{..} = do + unless (Text.null elementContributor) $ renderElementContributor elementContributor + unless (Text.null elementCoverage) $ renderElementCoverage elementCoverage + unless (Text.null elementCreator) $ renderElementCreator elementCreator + forM_ elementDate renderElementDate + unless (Text.null elementDescription) $ renderElementDescription elementDescription + unless (Text.null elementFormat) $ renderElementFormat elementFormat + unless (Text.null elementIdentifier) $ renderElementIdentifier elementIdentifier + unless (Text.null elementLanguage) $ renderElementLanguage elementLanguage + unless (Text.null elementPublisher) $ renderElementPublisher elementPublisher + unless (Text.null elementRelation) $ renderElementRelation elementRelation + unless (Text.null elementRights) $ renderElementRights elementRights + unless (Text.null elementSource) $ renderElementSource elementSource + unless (Text.null elementSubject) $ renderElementSubject elementSubject + unless (Text.null elementTitle) $ renderElementTitle elementTitle + unless (Text.null elementType) $ renderElementType elementType + -- | __Dublin Core__ tag type. data DublinCoreModule :: * @@ -126,6 +149,10 @@ instance ParseRssExtension DublinCoreModule where parseRssChannelExtension = DublinCoreChannel <$> dcMetadata parseRssItemExtension = DublinCoreItem <$> dcMetadata + +instance RenderRssExtension DublinCoreModule where + renderRssChannelExtension = renderDcMetadata . channelDcMetaData + renderRssItemExtension = renderDcMetadata . itemDcMetaData data instance RssChannelExtension DublinCoreModule = DublinCoreChannel { channelDcMetaData :: DcMetaData } diff --git a/Text/RSS/Extensions/Syndication.hs b/Text/RSS/Extensions/Syndication.hs --- a/Text/RSS/Extensions/Syndication.hs +++ b/Text/RSS/Extensions/Syndication.hs @@ -3,6 +3,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | __Syndication__ module for RSS. @@ -17,9 +18,15 @@ , SyndicationPeriod(..) , asSyndicationPeriod -- * Parsers + , syndicationInfo , syndicationPeriod , syndicationFrequency , syndicationBase + -- * Renderers + , renderSyndicationInfo + , renderSyndicationPeriod + , renderSyndicationFrequency + , renderSyndicationBase -- * Misc , namespacePrefix , namespaceURI @@ -29,9 +36,9 @@ import Text.RSS.Extensions import Text.RSS.Types -import Conduit hiding (throwM) +import Conduit hiding (throwM) import Control.Applicative -import Control.Exception.Safe as Exception +import Control.Exception.Safe as Exception import Control.Monad import Control.Monad.Fix import Data.Maybe @@ -46,12 +53,15 @@ import GHC.Generics import Lens.Simple import Text.Read -import qualified Text.XML.DublinCore.Conduit.Parse as DC import Text.XML.Stream.Parse +import qualified Text.XML.Stream.Render as Render import URI.ByteString -- }}} -- {{{ Utils +tshow :: Show a => a -> Text +tshow = pack . show + asDate :: MonadThrow m => Text -> m UTCTime asDate text = maybe (throw $ InvalidTime text) (return . zonedTimeToUTC) $ parseTimeRFC3339 text <|> parseTimeRFC2822 text <|> parseTimeRFC822 text @@ -87,9 +97,13 @@ syndicationTag :: MonadThrow m => Text -> ConduitM Event o m a -> ConduitM Event o m (Maybe a) syndicationTag name = tagIgnoreAttrs (matching (== syndicationName name)) +renderSyndicationTag :: Monad m => Text -> Text -> Source m Event +renderSyndicationTag name = Render.tag (syndicationName name) mempty . Render.content -data SyndicationPeriod = Hourly | Daily | Weekly | Monthly | Yearly deriving(Eq, Generic, Ord, Show) +data SyndicationPeriod = Hourly | Daily | Weekly | Monthly | Yearly + deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show) + asSyndicationPeriod :: MonadThrow m => Text -> m SyndicationPeriod asSyndicationPeriod "hourly" = pure Hourly asSyndicationPeriod "daily" = pure Daily @@ -98,12 +112,20 @@ asSyndicationPeriod "yearly" = pure Yearly asSyndicationPeriod t = throw $ InvalidSyndicationPeriod t +fromSyndicationPeriod :: SyndicationPeriod -> Text +fromSyndicationPeriod Hourly = "hourly" +fromSyndicationPeriod Daily = "daily" +fromSyndicationPeriod Weekly = "weekly" +fromSyndicationPeriod Monthly = "monthly" +fromSyndicationPeriod Yearly = "yearly" + + -- | __Syndication__ extension model. data SyndicationInfo = SyndicationInfo { updatePeriod :: Maybe SyndicationPeriod , updateFrequency :: Maybe Int , updateBase :: Maybe UTCTime - } deriving(Eq, Generic, Ord, Show) + } deriving (Eq, Generic, Ord, Read, Show) -- | Construct an empty 'SyndicationInfo'. mkSyndicationInfo :: SyndicationInfo @@ -114,7 +136,7 @@ makeTraversals ''ElementPiece --- | Parse __Syndication__ elements. +-- | Parse all __Syndication__ elements. syndicationInfo :: MonadThrow m => ConduitM Event o m SyndicationInfo syndicationInfo = manyYield' (choose piece) =$= parser where parser = getZipConduit $ SyndicationInfo @@ -138,6 +160,26 @@ syndicationBase :: MonadThrow m => ConduitM Event o m (Maybe UTCTime) syndicationBase = syndicationTag "updateBase" (content >>= asDate) +-- | Render all __Syndication__ elements. +renderSyndicationInfo :: Monad m => SyndicationInfo -> Source m Event +renderSyndicationInfo SyndicationInfo{..} = do + forM_ updatePeriod renderSyndicationPeriod + forM_ updateFrequency renderSyndicationFrequency + forM_ updateBase renderSyndicationBase + +-- | Render a @\@ element. +renderSyndicationPeriod :: Monad m => SyndicationPeriod -> Source m Event +renderSyndicationPeriod = renderSyndicationTag "updatePeriod" . fromSyndicationPeriod + +-- | Render a @\@ element. +renderSyndicationFrequency :: Monad m => Int -> Source m Event +renderSyndicationFrequency = renderSyndicationTag "updateFrequency" . tshow + +-- | Render a @\@ element. +renderSyndicationBase :: Monad m => UTCTime -> Source m Event +renderSyndicationBase = renderSyndicationTag "updateBase" . formatTimeRFC822 . utcToZonedTime utc + + -- | __Syndication__ tag type. data SyndicationModule :: * @@ -149,7 +191,11 @@ parseRssChannelExtension = SyndicationChannel <$> syndicationInfo parseRssItemExtension = pure SyndicationItem +instance RenderRssExtension SyndicationModule where + renderRssChannelExtension = renderSyndicationInfo . channelSyndicationInfo + renderRssItemExtension = const $ pure () + data instance RssChannelExtension SyndicationModule = SyndicationChannel { channelSyndicationInfo :: SyndicationInfo} - deriving(Eq, Generic, Ord, Show) -data instance RssItemExtension SyndicationModule = SyndicationItem deriving(Eq, Generic, Ord, Show) + deriving (Eq, Generic, Ord, Read, Show) +data instance RssItemExtension SyndicationModule = SyndicationItem deriving (Eq, Generic, Ord, Read, Show) diff --git a/Text/RSS/Types.hs b/Text/RSS/Types.hs --- a/Text/RSS/Types.hs +++ b/Text/RSS/Types.hs @@ -67,6 +67,7 @@ deriving instance Eq RssException deriving instance Generic RssException +deriving instance Read RssException deriving instance Show RssException instance Exception RssException where @@ -183,7 +184,7 @@ deriving instance Show RssTextInput data CloudProtocol = ProtocolXmlRpc | ProtocolSoap | ProtocolHttpPost - deriving(Eq, Generic, Ord, Show) + deriving(Eq, Generic, Ord, Read, Show) -- | The @\@ element. data RssCloud = RssCloud @@ -303,6 +304,7 @@ deriving instance (Eq (Rec RssChannelExtension a)) => Eq (RssChannelExtensions a) deriving instance (Generic (Rec RssChannelExtension a)) => Generic (RssChannelExtensions a) deriving instance (Ord (Rec RssChannelExtension a)) => Ord (RssChannelExtensions a) +deriving instance (Read (Rec RssChannelExtension a)) => Read (RssChannelExtensions a) deriving instance (Show (Rec RssChannelExtension a)) => Show (RssChannelExtensions a) -- | Combination of multiple @\@ extensions. @@ -312,4 +314,5 @@ deriving instance (Eq (Rec RssItemExtension a)) => Eq (RssItemExtensions a) deriving instance (Generic (Rec RssItemExtension a)) => Generic (RssItemExtensions a) deriving instance (Ord (Rec RssItemExtension a)) => Ord (RssItemExtensions a) +deriving instance (Read (Rec RssItemExtension a)) => Read (RssItemExtensions a) deriving instance (Show (Rec RssItemExtension a)) => Show (RssItemExtensions a) 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.4.1.0 +version: 0.4.2.0 cabal-version: >=1.10 build-type: Simple license: PublicDomain @@ -35,7 +35,7 @@ Text.RSS.Lens Text.RSS.Types build-depends: - atom-conduit -any, + atom-conduit >=0.5, base >=4.8 && <5, conduit -any, conduit-combinators -any, @@ -59,8 +59,9 @@ main-is: Main.hs build-depends: rss-conduit -any, - atom-conduit -any, + atom-conduit >=0.5, base >=4.8 && <5, + blaze-builder -any, bytestring -any, conduit -any, conduit-combinators -any, diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -5,25 +5,27 @@ module Arbitrary (module Arbitrary) where -- {{{ Imports -import Data.ByteString (ByteString) +import Text.RSS.Extensions.Atom +import Text.RSS.Extensions.Content +import Text.RSS.Extensions.DublinCore +import Text.RSS.Extensions.Syndication +import Text.RSS.Types + +import Data.ByteString (ByteString) import Data.Char import Data.Maybe -import Data.MonoTraversable (Element) +import Data.MonoTraversable (Element) import Data.NonNull -import Data.Sequences (SemiSequence) -import Data.Text (Text, find, pack) +import Data.Sequences (SemiSequence) +import Data.Text (Text, find, pack) import Data.Text.Encoding import Data.Time.Clock import Data.Version import Data.Vinyl.Core - import GHC.Generics - import Test.QuickCheck -import Test.QuickCheck.Instances () - -import Text.RSS.Types - +import Test.QuickCheck.Instances () +import Text.Atom.Types import URI.ByteString -- }}} @@ -163,3 +165,49 @@ 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 + +instance Arbitrary DcMetaData where + arbitrary = DcMetaData + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> oneof [Just <$> genTime, pure Nothing] + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary (RssChannelExtension DublinCoreModule) where + arbitrary = DublinCoreChannel <$> arbitrary + +instance Arbitrary SyndicationPeriod where + arbitrary = arbitraryBoundedEnum + shrink = genericShrink + +instance Arbitrary SyndicationInfo where + arbitrary = SyndicationInfo + <$> arbitrary + <*> arbitrary + <*> oneof [Just <$> genTime, pure Nothing] + +instance Arbitrary (RssChannelExtension SyndicationModule) where + arbitrary = SyndicationChannel <$> arbitrary + +instance Arbitrary AtomURI where + arbitrary = oneof [AtomURI <$> (arbitrary :: Gen (URIRef Absolute)), AtomURI <$> (arbitrary :: Gen (URIRef Relative))] + +instance Arbitrary AtomLink where + arbitrary = AtomLink <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary (RssChannelExtension AtomModule) where + arbitrary = AtomChannel <$> arbitrary + +instance Arbitrary (RssItemExtension ContentModule) where + arbitrary = ContentItem <$> arbitrary diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -- {{{ Imports import Text.RSS.Conduit.Parse as Parser @@ -16,6 +17,7 @@ import Text.RSS1.Conduit.Parse as Parser import Arbitrary +import Blaze.ByteString.Builder (toByteString) import Conduit import Control.Exception.Safe as Exception import Control.Monad @@ -26,10 +28,12 @@ import Data.Default import Data.Singletons.Prelude.List import Data.Text (Text) +import Data.Text.Encoding import Data.Time.Calendar import Data.Time.LocalTime import Data.Version import Data.Vinyl.Core +import Data.Void import Data.XML.Types import qualified Language.Haskell.HLint as HLint (hlint) import Lens.Simple @@ -43,6 +47,7 @@ import Text.XML.Stream.Parse as XML hiding (choose) import Text.XML.Stream.Render import URI.ByteString +import URI.ByteString.QQ -- }}} main :: IO () @@ -80,16 +85,39 @@ properties :: TestTree properties = testGroup "Properties" - [ roundtripTextInputProperty - , roundtripImageProperty - , roundtripCategoryProperty - , roundtripEnclosureProperty - , roundtripSourceProperty - , roundtripGuidProperty - , roundtripItemProperty + [ roundtripProperty "RssTextInput" renderRssTextInput rssTextInput + , roundtripProperty "RssImage" renderRssImage rssImage + , roundtripProperty "RssCategory" renderRssCategory rssCategory + , roundtripProperty "RssEnclosure" renderRssEnclosure rssEnclosure + , roundtripProperty "RssSource" renderRssSource rssSource + , roundtripProperty "RssGuid" renderRssGuid rssGuid + , roundtripProperty "RssItem" + (renderRssItem :: RssItem '[] -> Source Maybe Event) + rssItem + , roundtripProperty "DublinCore" + (renderRssChannelExtension :: RssChannelExtension DublinCoreModule -> Source Maybe Event) + (Just <$> parseRssChannelExtension) + , roundtripProperty "Syndication" + (renderRssChannelExtension :: RssChannelExtension SyndicationModule -> Source Maybe Event) + (Just <$> parseRssChannelExtension) + , roundtripProperty "Atom" + (renderRssChannelExtension :: RssChannelExtension AtomModule -> Source Maybe Event) + (Just <$> parseRssChannelExtension) + , roundtripProperty "Content" + (renderRssItemExtension :: RssItemExtension ContentModule -> Source Maybe Event) + (Just <$> parseRssItemExtension) ] +roundtripProperty :: Eq a => Arbitrary a => Show a + => TestName -> (a -> Source Maybe Event) -> ConduitM Event Void Maybe (Maybe a) -> TestTree +roundtripProperty name render parse = testProperty ("parse . render = id (" <> name <> ")") $ do + input <- arbitrary + let intermediate = fmap (decodeUtf8 . toByteString) $ runConduit $ render input =$= renderBuilder def =$= foldC + output = join $ runConduit $ render input =$= parse + return $ counterexample (show input <> " | " <> show intermediate <> " | " <> show output) $ Just input == output + + skipHoursCase :: TestTree skipHoursCase = testCase " element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssSkipHours @@ -121,7 +149,7 @@ result^.textInputTitleL @?= "Search XML.com" result^.textInputDescriptionL @?= "Search XML.com's XML collection" result^.textInputNameL @?= "s" - result^.textInputLinkL @=? RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "search.xml.com") Nothing)) "" (Query []) Nothing) + result^.textInputLinkL @=? RssURI [uri|http://search.xml.com|] where input = [ "" , "Search XML.com" , "Search XML.com's XML collection" @@ -136,7 +164,7 @@ result^.textInputTitleL @?= "Title" result^.textInputDescriptionL @?= "Description" result^.textInputNameL @?= "Name" - result^.textInputLinkL @=? RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "link.ext") Nothing)) "" (Query []) Nothing) + result^.textInputLinkL @=? RssURI [uri|http://link.ext|] where input = [ "" , "Title" , "Description" @@ -148,9 +176,9 @@ rss1ImageCase :: TestTree rss1ImageCase = testCase "RSS1 element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rss1Image - result^.imageUriL @?= RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "xml.com") Nothing)) "/universal/images/xml_tiny.gif" (Query []) Nothing) + result^.imageUriL @?= RssURI [uri|http://xml.com/universal/images/xml_tiny.gif|] result^.imageTitleL @?= "XML.com" - result^.imageLinkL @?= RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.xml.com") Nothing)) "" (Query []) Nothing) + result^.imageLinkL @?= RssURI [uri|http://www.xml.com|] where input = [ "" , "http://xml.com/universal/images/xml_tiny.gif" , "XML.com" @@ -163,9 +191,9 @@ rss2ImageCase :: TestTree rss2ImageCase = testCase "RSS2 element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssImage - result^.imageUriL @?= RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "image.ext") Nothing)) "" (Query []) Nothing) + result^.imageUriL @?= RssURI [uri|http://image.ext|] result^.imageTitleL @?= "Title" - result^.imageLinkL @?= RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "link.ext") Nothing)) "" (Query []) Nothing) + result^.imageLinkL @?= RssURI [uri|http://link.ext|] result^.imageWidthL @?= Just 100 result^.imageHeightL @?= Just 200 result^.imageDescriptionL @?= "Description" @@ -198,7 +226,7 @@ where input = [ "" , "" ] - uri = RssURI (RelativeRef (Just (Authority Nothing (Host "rpc.sys.com") (Just $ Port 80))) "/RPC2" (Query []) Nothing) + uri = RssURI [relativeRef|//rpc.sys.com:80/RPC2|] guidCase :: TestTree guidCase = testCase " element" $ do @@ -208,23 +236,23 @@ , "1" , "2" ] - uri = RssURI (RelativeRef (Just (Authority Nothing (Host "guid.ext") Nothing)) "" (Query []) Nothing) + uri = RssURI [relativeRef|//guid.ext|] enclosureCase :: TestTree enclosureCase = testCase " element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssEnclosure - result @?= RssEnclosure uri 12216320 "audio/mpeg" + result @?= RssEnclosure url 12216320 "audio/mpeg" where input = [ "" ] - uri = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.scripting.com") Nothing)) "/mp3s/weatherReportSuite.mp3" (Query []) Nothing) + url = RssURI [uri|http://www.scripting.com/mp3s/weatherReportSuite.mp3|] sourceCase :: TestTree sourceCase = testCase " element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssSource - result @?= RssSource uri "Tomalak's Realm" + result @?= RssSource url "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) + url = RssURI [uri|http://www.tomalak.org/links2.xml|] rss1ItemCase :: TestTree rss1ItemCase = testCase "RSS1 element" $ do @@ -246,7 +274,7 @@ , "Some content in unknown tag, should be ignored." , "" ] - link = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "xml.com") Nothing)) "/pub/2000/08/09/xslt/xslt.html" (Query []) Nothing) + link = RssURI [uri|http://xml.com/pub/2000/08/09/xslt/xslt.html|] rss2ItemCase :: TestTree rss2ItemCase = testCase "RSS2 element" $ do @@ -266,7 +294,7 @@ , "Some content in unknown tag, should be ignored." , "" ] - link = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.example.com") Nothing)) "/blog/post/1" (Query []) Nothing) + link = RssURI [uri|http://www.example.com/blog/post/1|] rss1ChannelItemsCase :: TestTree @@ -336,10 +364,10 @@ , "" , "" ] - link = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "xml.com") Nothing)) "/pub" (Query []) Nothing) - imageLink = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.xml.com") Nothing)) "" (Query []) Nothing) - imageUri = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "xml.com") Nothing)) "/universal/images/xml_tiny.gif" (Query []) Nothing) - textInputLink = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "search.xml.com") Nothing)) "" (Query []) Nothing) + link = RssURI [uri|http://xml.com/pub|] + imageLink = RssURI [uri|http://www.xml.com|] + imageUri = RssURI [uri|http://xml.com/universal/images/xml_tiny.gif|] + textInputLink = RssURI [uri|http://search.xml.com|] rss2DocumentCase :: TestTree @@ -371,7 +399,7 @@ , "" , "" ] - link = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.example.com") Nothing)) "/main.html" (Query []) Nothing) + link = RssURI [uri|http://www.example.com/main.html|] dublinCoreChannelCase :: TestTree @@ -474,8 +502,8 @@ , "" , "" ] - uri = AtomURI (URI (Scheme "http") (Just (Authority Nothing (Host "dallas.example.com") Nothing)) "/rss.xml" (Query []) Nothing) - link = AtomLink uri "self" "application/rss+xml" mempty mempty mempty + url = AtomURI [uri|http://dallas.example.com/rss.xml|] + link = AtomLink url "self" "application/rss+xml" mempty mempty mempty multipleExtensionsCase :: TestTree multipleExtensionsCase = testCase "Multiple extensions" $ do @@ -488,8 +516,8 @@ , "What a beautiful day!

]]>" , "" ] - uri = AtomURI (URI (Scheme "http") (Just (Authority Nothing (Host "dallas.example.com") Nothing)) "/rss.xml" (Query []) Nothing) - link = AtomLink uri "self" "application/rss+xml" mempty mempty mempty + url = AtomURI [uri|http://dallas.example.com/rss.xml|] + link = AtomLink url "self" "application/rss+xml" mempty mempty mempty hlint :: TestTree