rss-conduit 0.3.2.0 → 0.4.0.0

raw patch · 14 files changed

+863/−96 lines, 14 filesdep +atom-conduitdep +dublincore-xml-conduitdep +semigroupsdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: atom-conduit, dublincore-xml-conduit, semigroups, singletons, vinyl

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Text/RSS/Conduit/Parse.hs +25/−18
• Text/RSS/Conduit/Parse/Simple.hs +78/−0
• Text/RSS/Conduit/Render.hs +6/−2
• Text/RSS/Extensions.hs +68/−0
• Text/RSS/Extensions/Atom.hs +34/−0
• Text/RSS/Extensions/Content.hs +67/−0
• Text/RSS/Extensions/DublinCore.hs +130/−0
• Text/RSS/Extensions/Syndication.hs +154/−0
• Text/RSS/Lens.hs +4/−4
• Text/RSS/Types.hs +73/−18
• Text/RSS1/Conduit/Parse.hs +34/−18
• rss-conduit.cabal +19/−3
• test/Arbitrary.hs +6/−2
• test/Main.hs +165/−31

@@ -1,7 +1,10 @@+{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE FlexibleContexts   #-} {-# LANGUAGE OverloadedStrings  #-} {-# LANGUAGE RankNTypes         #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TypeOperators      #-} -- | Streaming parsers for the RSS 2.0 standard. module Text.RSS.Conduit.Parse   ( -- * Top-level@@ -20,16 +23,16 @@   ) where  -- {{{ Imports+import           Text.RSS.Extensions import           Text.RSS.Types  import           Conduit                      hiding (throwM)- import           Control.Applicative          hiding (many) import           Control.Exception.Safe       as Exception import           Control.Monad                hiding (foldM) import           Control.Monad.Fix- import           Data.Conduit+import           Data.List.NonEmpty           (NonEmpty (..), nonEmpty) import           Data.Maybe import           Data.Monoid import           Data.MonoTraversable@@ -41,15 +44,11 @@ import           Data.Time.RFC822 import           Data.Version import           Data.XML.Types- import           Lens.Simple- import           Prelude                      hiding (last, lookup)- import           Text.ParserCombinators.ReadP (readP_to_S) import           Text.Read                    (readMaybe) import           Text.XML.Stream.Parse- import           URI.ByteString -- }}} @@ -122,7 +121,7 @@ makeTraversals ''TextInputPiece  -- | Parse a @\<textInput\>@ element.-rssTextInput :: (MonadThrow m) => ConduitM Event o m (Maybe RssTextInput)+rssTextInput :: MonadThrow m => ConduitM Event o m (Maybe RssTextInput) rssTextInput = tagIgnoreAttrs "textInput" $ (manyYield' (choose piece) =$= parser) <* many ignoreAnyTreeContent where   parser = getZipConduit $ RssTextInput     <$> ZipConduit (projectC _TextInputTitle =$= headRequiredC "Missing <title> element")@@ -199,12 +198,14 @@ data ItemPiece = ItemTitle Text | ItemLink RssURI | ItemDescription Text                | ItemAuthor Text | ItemCategory RssCategory | ItemComments RssURI                | ItemEnclosure RssEnclosure | ItemGuid RssGuid | ItemPubDate UTCTime-               | ItemSource RssSource+               | ItemSource RssSource | ItemOther (NonEmpty Event)  makeTraversals ''ItemPiece  -- | Parse an @\<item\>@ element.-rssItem :: MonadThrow m => ConduitM Event o m (Maybe RssItem)+--+-- RSS extensions are automatically parsed based on the expected result type.+rssItem :: ParseRssExtensions e => MonadThrow m => ConduitM Event o m (Maybe (RssItem e)) rssItem = tagIgnoreAttrs "item" $ (manyYield' (choose piece) =$= parser) <* many ignoreAnyTreeContent where   parser = getZipConduit $ RssItem     <$> ZipConduit (projectC _ItemTitle =$= headDefC "")@@ -217,6 +218,7 @@     <*> ZipConduit (projectC _ItemGuid =$= headC)     <*> ZipConduit (projectC _ItemPubDate =$= headC)     <*> ZipConduit (projectC _ItemSource =$= headC)+    <*> ZipConduit (projectC _ItemOther =$= concatC =$= parseRssItemExtensions)   piece = [ fmap ItemTitle <$> tagIgnoreAttrs "title" content           , fmap ItemLink <$> tagIgnoreAttrs "link" (content >>= asRssURI)           , fmap ItemDescription <$> tagIgnoreAttrs "description" content@@ -227,22 +229,25 @@           , fmap ItemGuid <$> rssGuid           , fmap ItemPubDate <$> tagDate "pubDate"           , fmap ItemSource <$> rssSource+          , fmap ItemOther . nonEmpty <$> (void takeAnyTreeContent =$= sinkList)           ]  -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)+data ChannelPiece e = ChannelTitle Text | ChannelLink RssURI | ChannelDescription Text+                    | ChannelItem (RssItem e) | 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) | ChannelOther (NonEmpty Event)  makeTraversals ''ChannelPiece  -- | Parse an @\<rss\>@ element.-rssDocument :: MonadThrow m => ConduitM Event o m (Maybe RssDocument)+--+-- RSS extensions are automatically parsed based on the expected result type.+rssDocument :: ParseRssExtensions e => MonadThrow m => ConduitM Event o m (Maybe (RssDocument e)) rssDocument = tagName' "rss" attributes $ \version -> force "Missing <channel>" $ tagIgnoreAttrs "channel" (manyYield' (choose piece) =$= parser version) <* many ignoreAnyTreeContent where   parser version = getZipConduit $ RssDocument version     <$> ZipConduit (projectC _ChannelTitle =$= headRequiredC "Missing <title> element")@@ -265,6 +270,7 @@     <*> ZipConduit (projectC _ChannelTextInput =$= headC)     <*> ZipConduit (projectC _ChannelSkipHours =$= headDefC mempty)     <*> ZipConduit (projectC _ChannelSkipDays =$= headDefC mempty)+    <*> ZipConduit (projectC _ChannelOther =$= concatC =$= parseRssChannelExtensions)   piece = [ fmap ChannelTitle <$> tagIgnoreAttrs "title" content           , fmap ChannelLink <$> tagIgnoreAttrs "link" (content >>= asRssURI)           , fmap ChannelDescription <$> tagIgnoreAttrs "description" content@@ -285,5 +291,6 @@           , fmap ChannelTextInput <$> rssTextInput           , fmap ChannelSkipHours <$> rssSkipHours           , fmap ChannelSkipDays <$> rssSkipDays+          , fmap ChannelOther . nonEmpty <$> (void takeAnyTreeContent =$= sinkList)           ]   attributes = (requireAttr "version" >>= asVersion) <* ignoreAttrs

@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes       #-}+-- | Streaming parsers for the RSS 2.0 standard.+--+-- This module re-exports a monomorphic version of the parsers from 'Text.RSS.Conduit.Parse' that ignores RSS extensions.+module Text.RSS.Conduit.Parse.Simple+  ( -- * Top-level+    rssDocument+    -- * Elements+  , rssCategory+  , rssCloud+  , rssEnclosure+  , rssGuid+  , rssImage+  , rssItem+  , rssSkipDays+  , rssSkipHours+  , rssSource+  , rssTextInput+  ) where++-- {{{ Imports+import qualified Text.RSS.Conduit.Parse as P+import           Text.RSS.Types++import           Control.Exception.Safe as Exception+import           Data.Conduit+import           Data.Set+import           Data.XML.Types+-- }}}++-- | Parse a @\<skipHours\>@ element.+rssSkipHours :: MonadThrow m => ConduitM Event o m (Maybe (Set Hour))+rssSkipHours = P.rssSkipHours++-- | Parse a @\<skipDays\>@ element.+rssSkipDays :: MonadThrow m => ConduitM Event o m (Maybe (Set Day))+rssSkipDays = P.rssSkipDays++-- | Parse a @\<textInput\>@ element.+rssTextInput :: MonadThrow m => ConduitM Event o m (Maybe RssTextInput)+rssTextInput = P.rssTextInput++-- | Parse an @\<image\>@ element.+rssImage :: MonadThrow m => ConduitM Event o m (Maybe RssImage)+rssImage = P.rssImage++-- | Parse a @\<category\>@ element.+rssCategory :: MonadThrow m => ConduitM Event o m (Maybe RssCategory)+rssCategory = P.rssCategory++-- | Parse a @\<cloud\>@ element.+rssCloud :: MonadThrow m => ConduitM Event o m (Maybe RssCloud)+rssCloud = P.rssCloud++-- | Parse a @\<guid\>@ element.+rssGuid :: MonadThrow m => ConduitM Event o m (Maybe RssGuid)+rssGuid = P.rssGuid++-- | Parse an @\<enclosure\>@ element.+rssEnclosure :: MonadThrow m => ConduitM Event o m (Maybe RssEnclosure)+rssEnclosure = P.rssEnclosure++-- | Parse a @\<source\>@ element.+rssSource :: MonadThrow m => ConduitM Event o m (Maybe RssSource)+rssSource = P.rssSource++-- | Parse an @\<item\>@ element.+--+-- RSS extensions are ignored.+rssItem :: MonadThrow m => ConduitM Event o m (Maybe RssItem')+rssItem = P.rssItem++-- | Parse an @\<rss\>@ element.+--+-- RSS extensions are ignored.+rssDocument :: MonadThrow m => ConduitM Event o m (Maybe RssDocument')+rssDocument = P.rssDocument

@@ -44,7 +44,9 @@ -- }}}  -- | Render the top-level @\<rss\>@ element.-renderRssDocument :: (Monad m) => RssDocument -> Source m Event+--+-- __Note__: RSS extensions are NOT rendered.+renderRssDocument :: Monad m => RssDocument a -> Source m Event renderRssDocument d = tag "rss" (attr "version" . pack . showVersion $ d^.documentVersionL) $   tag "channel" mempty $ do     textTag "title" $ d^.channelTitleL@@ -69,7 +71,9 @@     forM_ (d^..channelItemsL) renderRssItem  -- | Render an @\<item\>@ element.-renderRssItem :: (Monad m) => RssItem -> Source m Event+--+-- __Note__: RSS extensions are NOT rendered.+renderRssItem :: Monad m => RssItem e -> Source m Event renderRssItem i = tag "item" mempty $ do   optionalTextTag "title" $ i^.itemTitleL   forM_ (i^.itemLinkL) $ textTag "link" . renderRssURI

@@ -0,0 +1,68 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}+-- | Support for RSS extensions.+-- Cf specification at <http://web.resource.org/rss/1.0/modules/>.+--+-- For now, only parsing is implemented. Rendering will be implemented later.+module Text.RSS.Extensions where++-- {{{ Imports+import           Control.Exception.Safe       as Exception+import           Data.Conduit+import           Data.Maybe+import           Data.Proxy+import           Data.Singletons+import           Data.Singletons.Prelude.Bool+import           Data.Singletons.Prelude.Eq+import           Data.Singletons.Prelude.List+import           Data.Text+import           Data.Vinyl.Core+import           Data.Vinyl.TypeLevel+import           Data.XML.Types+import           Debug.Trace+import           GHC.Generics+import           Text.Atom.Conduit.Parse+import           Text.Atom.Types+import           Text.Read                    (readMaybe)+import           Text.RSS.Types+import           Text.XML.Stream.Parse+import           URI.ByteString+-- }}}++-- | Class of RSS extensions that can be parsed.+class ParseRssExtension a where+  -- | This parser will be fed with all 'Event's within the @\<channel\>@ element.+  -- Therefore, it is expected to ignore 'Event's unrelated to the RSS extension.+  parseRssChannelExtension :: MonadThrow m => ConduitM Event o m (RssChannelExtension a)+  -- | This parser will be fed with all 'Event's within the @\<item\>@ element.+  -- Therefore, it is expected to ignore 'Event's unrelated to the RSS extension.+  parseRssItemExtension :: MonadThrow m => ConduitM Event o m (RssItemExtension a)++-- | Requirement on a list of extension tags to be able to parse and combine them.+type ParseRssExtensions (e :: [*]) = (AllConstrained ParseRssExtension e, SingI e)++-- | Parse a combination of RSS extensions at @\<channel\>@ level.+parseRssChannelExtensions :: ParseRssExtensions e => MonadThrow m => ConduitM Event o m (RssChannelExtensions e)+parseRssChannelExtensions = f sing where+  f :: AllConstrained ParseRssExtension e => MonadThrow m+    => Sing e -> ConduitM Event o m (RssChannelExtensions e)+  f SNil = return $ RssChannelExtensions RNil+  f (SCons _ es) = fmap RssChannelExtensions $ getZipConduit $ (:&)+    <$> ZipConduit parseRssChannelExtension+    <*> ZipConduit (rssChannelExtension <$> f es)++-- | Parse a combination of RSS extensions at @\<item\>@ level.+parseRssItemExtensions :: ParseRssExtensions e => MonadThrow m => ConduitM Event o m (RssItemExtensions e)+parseRssItemExtensions = f sing where+  f :: AllConstrained ParseRssExtension e => MonadThrow m+    => Sing e -> ConduitM Event o m (RssItemExtensions e)+  f SNil = return $ RssItemExtensions RNil+  f (SCons _ es) = fmap RssItemExtensions $ getZipConduit $ (:&)+    <$> ZipConduit parseRssItemExtension+    <*> ZipConduit (rssItemExtension <$> f es)

@@ -0,0 +1,34 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE DeriveGeneric  #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes     #-}+{-# LANGUAGE TypeFamilies   #-}+-- | __Atom__ extension for RSS.+-- Cf specification at <http://www.rssboard.org/rss-profile#namespace-elements-atom>.+module Text.RSS.Extensions.Atom where++-- {{{ Imports+import           Text.RSS.Extensions+import           Text.RSS.Types++import           Conduit                 hiding (throwM)+import           Data.Singletons+import           GHC.Generics+import           Text.Atom.Conduit.Parse+import           Text.Atom.Types+import           Text.XML.Stream.Parse+-- }}}++-- | __Atom__ tag type.+data AtomModule :: *++data instance Sing AtomModule = SAtomModule++instance SingI AtomModule where sing = SAtomModule++instance ParseRssExtension AtomModule where+  parseRssChannelExtension = AtomChannel <$> (manyYield' atomLink =$= headC)+  parseRssItemExtension    = AtomItem <$> (manyYield' atomLink =$= headC)++data instance RssChannelExtension AtomModule = AtomChannel (Maybe AtomLink) deriving(Eq, Generic, Show)+data instance RssItemExtension AtomModule = AtomItem (Maybe AtomLink) deriving(Eq, Generic, Show)

@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE KindSignatures    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE TypeFamilies      #-}+-- | __Content__ extension for RSS.+-- Cf specification at <http://web.resource.org/rss/1.0/modules/content/>.+--+-- This implementation corresponds to the /updated syntax/ from the specification.+module Text.RSS.Extensions.Content+  ( -- * Types+    ContentModule(..)+  , RssChannelExtension(ContentChannel)+  , RssItemExtension(ContentItem)+    -- * Parsers+  , contentEncoded+    -- * Misc+  , namespacePrefix+  , namespaceURI+  ) where++-- {{{ Imports+import           Text.RSS.Extensions+import           Text.RSS.Types++import           Conduit                hiding (throwM)+import           Control.Exception.Safe as Exception+import           Data.Maybe+import           Data.Singletons+import           Data.Text+import           Data.XML.Types+import           GHC.Generics+import           Text.XML.Stream.Parse+import           URI.ByteString+-- }}}++-- | __Content__ tag type.+data ContentModule :: *++data instance Sing ContentModule = SContentModule++instance SingI ContentModule where sing = SContentModule++instance ParseRssExtension ContentModule where+  parseRssChannelExtension = pure ContentChannel+  parseRssItemExtension    = ContentItem <$> (manyYield' contentEncoded =$= headDefC mempty)+++data instance RssChannelExtension ContentModule = ContentChannel deriving(Eq, Generic, Ord, Show)+data instance RssItemExtension ContentModule = ContentItem Text deriving(Eq, Generic, Ord, Show)+++-- | XML prefix is @content@.+namespacePrefix :: Text+namespacePrefix = "content"++-- | XML namespace is @http://purl.org/rss/1.0/modules/content/@+namespaceURI :: URIRef Absolute+namespaceURI = uri where Right uri = parseURI laxURIParserOptions "http://purl.org/rss/1.0/modules/content/"++contentName :: Text -> Name+contentName string = Name string (Just "http://purl.org/rss/1.0/modules/content/") (Just namespacePrefix)++-- | Parse a @\<content:encoded\>@ element.+contentEncoded :: MonadThrow m => ConduitM Event o m (Maybe Text)+contentEncoded = tagIgnoreAttrs (matching (== contentName "encoded")) content

@@ -0,0 +1,130 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE KindSignatures    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TypeFamilies      #-}+-- | __Dublin Core__ extension for RSS.+--  Cf specification at <http://web.resource.org/rss/1.0/modules/dc/>.+module Text.RSS.Extensions.DublinCore+  ( DublinCoreModule(..)+  , RssChannelExtension(DublinCoreChannel)+  , RssItemExtension(DublinCoreItem)+  , DcMetaData(..)+  , mkDcMetaData+  ) where++-- {{{ Imports+import           Text.RSS.Extensions+import           Text.RSS.Types++import           Conduit                           hiding (throwM)+import           Control.Exception.Safe            as Exception+import           Control.Monad.Fix+import           Data.Maybe+import           Data.Singletons+import           Data.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           Text.XML.Stream.Parse+import           URI.ByteString+-- }}}++-- {{{ Utils+projectC :: Monad m => Fold a a' b b' -> Conduit a m b+projectC prism = fix $ \recurse -> do+  item <- await+  case (item, item ^? (_Just . prism)) of+    (_, Just a) -> yield a >> recurse+    (Just _, _) -> recurse+    _           -> return ()+-- }}}++-- | __Dublin Core__ extension model.+data DcMetaData = DcMetaData+  { elementContributor :: Text+  , elementCoverage    :: Text+  , elementCreator     :: Text+  , elementDate        :: Maybe UTCTime+  , elementDescription :: Text+  , elementFormat      :: Text+  , elementIdentifier  :: Text+  , elementLanguage    :: Text+  , elementPublisher   :: Text+  , elementRelation    :: Text+  , elementRights      :: Text+  , elementSource      :: Text+  , elementSubject     :: Text+  , elementTitle       :: Text+  , elementType        :: Text+  } deriving(Eq, Generic, Ord, Show)++-- | Construct an empty 'DcMetaData'.+mkDcMetaData = DcMetaData mempty mempty mempty Nothing mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty+++data ElementPiece = ElementContributor Text | ElementCoverage Text | ElementCreator Text+                  | ElementDate UTCTime | ElementDescription Text | ElementFormat Text+                  | ElementIdentifier Text | ElementLanguage Text | ElementPublisher Text+                  | ElementRelation Text | ElementRights Text | ElementSource Text+                  | ElementSubject Text | ElementTitle Text | ElementType Text++makeTraversals ''ElementPiece++-- | Parse a set of Dublin Core metadata elements.+dcMetadata :: MonadThrow m => ConduitM Event o m DcMetaData+dcMetadata = manyYield' (choose piece) =$= parser where+  parser = getZipConduit $ DcMetaData+    <$> ZipConduit (projectC _ElementContributor =$= headDefC "")+    <*> ZipConduit (projectC _ElementCoverage =$= headDefC "")+    <*> ZipConduit (projectC _ElementCreator =$= headDefC "")+    <*> ZipConduit (projectC _ElementDate =$= headC)+    <*> ZipConduit (projectC _ElementDescription =$= headDefC "")+    <*> ZipConduit (projectC _ElementFormat =$= headDefC "")+    <*> ZipConduit (projectC _ElementIdentifier =$= headDefC "")+    <*> ZipConduit (projectC _ElementLanguage =$= headDefC "")+    <*> ZipConduit (projectC _ElementPublisher =$= headDefC "")+    <*> ZipConduit (projectC _ElementRelation =$= headDefC "")+    <*> ZipConduit (projectC _ElementRights =$= headDefC "")+    <*> ZipConduit (projectC _ElementSource =$= headDefC "")+    <*> ZipConduit (projectC _ElementSubject =$= headDefC "")+    <*> ZipConduit (projectC _ElementTitle =$= headDefC "")+    <*> ZipConduit (projectC _ElementType =$= headDefC "")+  piece = [ fmap ElementContributor <$> DC.elementContributor+          , fmap ElementCoverage <$> DC.elementCoverage+          , fmap ElementCreator <$> DC.elementCreator+          , fmap ElementDate <$> DC.elementDate+          , fmap ElementDescription <$> DC.elementDescription+          , fmap ElementFormat <$> DC.elementFormat+          , fmap ElementIdentifier <$> DC.elementIdentifier+          , fmap ElementLanguage <$> DC.elementLanguage+          , fmap ElementPublisher <$> DC.elementPublisher+          , fmap ElementRelation <$> DC.elementRelation+          , fmap ElementRights <$> DC.elementRights+          , fmap ElementSource <$> DC.elementSource+          , fmap ElementSubject <$> DC.elementSubject+          , fmap ElementTitle <$> DC.elementTitle+          , fmap ElementType <$> DC.elementType+          ]+++-- | __Dublin Core__ tag type.+data DublinCoreModule :: *++data instance Sing DublinCoreModule = SDublinCoreModule++instance SingI DublinCoreModule where sing = SDublinCoreModule++instance ParseRssExtension DublinCoreModule where+  parseRssChannelExtension = DublinCoreChannel <$> dcMetadata+  parseRssItemExtension    = DublinCoreItem <$> dcMetadata+++data instance RssChannelExtension DublinCoreModule = DublinCoreChannel DcMetaData deriving(Eq, Generic, Ord, Show)+data instance RssItemExtension DublinCoreModule = DublinCoreItem DcMetaData deriving(Eq, Generic, Ord, Show)

@@ -0,0 +1,154 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE KindSignatures    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TypeFamilies      #-}+-- | __Syndication__ module for RSS.+-- Cf specification at <http://web.resource.org/rss/1.0/modules/syndication/>.+module Text.RSS.Extensions.Syndication+  ( -- * Types+    SyndicationModule(..)+  , RssChannelExtension(SyndicationChannel)+  , RssItemExtension(SyndicationItem)+  , SyndicationInfo(..)+  , mkSyndicationInfo+  , SyndicationPeriod(..)+  , asSyndicationPeriod+    -- * Parsers+  , syndicationPeriod+  , syndicationFrequency+  , syndicationBase+    -- * Misc+  , namespacePrefix+  , namespaceURI+  ) where++-- {{{ Imports+import           Text.RSS.Extensions+import           Text.RSS.Types++import           Conduit                           hiding (throwM)+import           Control.Applicative+import           Control.Exception.Safe            as Exception+import           Control.Monad+import           Control.Monad.Fix+import           Data.Maybe+import           Data.Singletons+import           Data.Text+import           Data.Time.Clock+import           Data.Time.LocalTime+import           Data.Time.RFC2822+import           Data.Time.RFC3339+import           Data.Time.RFC822+import           Data.XML.Types+import           GHC.Generics+import           Lens.Simple+import           Text.Read+import qualified Text.XML.DublinCore.Conduit.Parse as DC+import           Text.XML.Stream.Parse+import           URI.ByteString+-- }}}++-- {{{ Utils+asDate :: MonadThrow m => Text -> m UTCTime+asDate text = maybe (throw $ InvalidTime text) (return . zonedTimeToUTC) $+  parseTimeRFC3339 text <|> parseTimeRFC2822 text <|> parseTimeRFC822 text++asInt :: MonadThrow m => Text -> m Int+asInt t = maybe (throwM $ InvalidInt t) return . readMaybe $ unpack t++projectC :: Monad m => Fold a a' b b' -> Conduit a m b+projectC prism = fix $ \recurse -> do+  item <- await+  case (item, item ^? (_Just . prism)) of+    (_, Just a) -> yield a >> recurse+    (Just _, _) -> recurse+    _           -> return ()+-- }}}++newtype SyndicationException = InvalidSyndicationPeriod Text deriving(Eq, Generic, Ord, Show)++instance Exception SyndicationException where+  displayException (InvalidSyndicationPeriod t) = "Invalid syndication period: " ++ unpack t++-- | XML prefix is @sy@.+namespacePrefix :: Text+namespacePrefix = "sy"++-- | XML namespace is <http://purl.org/rss/1.0/modules/syndication/>.+namespaceURI :: URIRef Absolute+namespaceURI = uri where Right uri = parseURI laxURIParserOptions "http://purl.org/rss/1.0/modules/syndication/"++syndicationName :: Text -> Name+syndicationName string = Name string (Just "http://purl.org/rss/1.0/modules/syndication/") (Just namespacePrefix)++syndicationTag :: MonadThrow m => Text -> ConduitM Event o m a -> ConduitM Event o m (Maybe a)+syndicationTag name = tagIgnoreAttrs (matching (== syndicationName name))+++data SyndicationPeriod = Hourly | Daily | Weekly | Monthly | Yearly deriving(Eq, Generic, Ord, Show)++asSyndicationPeriod :: MonadThrow m => Text -> m SyndicationPeriod+asSyndicationPeriod "hourly"  = pure Hourly+asSyndicationPeriod "daily"   = pure Daily+asSyndicationPeriod "weekly"  = pure Weekly+asSyndicationPeriod "monthly" = pure Monthly+asSyndicationPeriod "yearly"  = pure Yearly+asSyndicationPeriod t         = throw $ InvalidSyndicationPeriod t++-- | __Syndication__ extension model.+data SyndicationInfo = SyndicationInfo+  { updatePeriod    :: Maybe SyndicationPeriod+  , updateFrequency :: Maybe Int+  , updateBase      :: Maybe UTCTime+  } deriving(Eq, Generic, Ord, Show)++-- | Construct an empty 'SyndicationInfo'.+mkSyndicationInfo :: SyndicationInfo+mkSyndicationInfo = SyndicationInfo mzero mzero mzero+++data ElementPiece = ElementPeriod SyndicationPeriod | ElementFrequency Int | ElementBase UTCTime++makeTraversals ''ElementPiece++-- | Parse __Syndication__ elements.+syndicationInfo :: MonadThrow m => ConduitM Event o m SyndicationInfo+syndicationInfo = manyYield' (choose piece) =$= parser where+  parser = getZipConduit $ SyndicationInfo+    <$> ZipConduit (projectC _ElementPeriod =$= headC)+    <*> ZipConduit (projectC _ElementFrequency =$= headC)+    <*> ZipConduit (projectC _ElementBase =$= headC)+  piece = [ fmap ElementPeriod <$> syndicationPeriod+          , fmap ElementFrequency <$> syndicationFrequency+          , fmap ElementBase <$> syndicationBase+          ]++-- | Parse a @\<sy:updatePeriod\>@ element.+syndicationPeriod :: MonadThrow m => ConduitM Event o m (Maybe SyndicationPeriod)+syndicationPeriod = syndicationTag "updatePeriod" (content >>= asSyndicationPeriod)++-- | Parse a @\<sy:updateFrequency\>@ element.+syndicationFrequency :: MonadThrow m => ConduitM Event o m (Maybe Int)+syndicationFrequency = syndicationTag "updateFrequency" (content >>= asInt)++-- | Parse a @\<sy:updateBase\>@ element.+syndicationBase :: MonadThrow m => ConduitM Event o m (Maybe UTCTime)+syndicationBase = syndicationTag "updateBase" (content >>= asDate)++-- | __Syndication__ tag type.+data SyndicationModule :: *++data instance Sing SyndicationModule = SSyndicationModule++instance SingI SyndicationModule where sing = SSyndicationModule++instance ParseRssExtension SyndicationModule where+  parseRssChannelExtension = SyndicationChannel <$> syndicationInfo+  parseRssItemExtension    = pure SyndicationItem+++data instance RssChannelExtension SyndicationModule = SyndicationChannel SyndicationInfo deriving(Eq, Generic, Ord, Show)+data instance RssItemExtension SyndicationModule = SyndicationItem deriving(Eq, Generic, Ord, Show)

@@ -21,11 +21,11 @@    in f)   ''RssItem) -itemCategoriesL :: Traversal' RssItem RssCategory+itemCategoriesL :: Traversal' (RssItem e) RssCategory itemCategoriesL inj a@RssItem { itemCategories = c } = (\x -> a { itemCategories = c }) <$> traverse inj c {-# INLINE itemCategoriesL #-} -itemEnclosureL :: Traversal' RssItem RssEnclosure+itemEnclosureL :: Traversal' (RssItem e) RssEnclosure itemEnclosureL inj a@RssItem { itemEnclosure = e } = (\x -> a { itemEnclosure = e }) <$> traverse inj e {-# INLINE itemEnclosureL #-} @@ -39,10 +39,10 @@   in f)   ''RssDocument) -channelItemsL :: Traversal' RssDocument RssItem+channelItemsL :: Traversal' (RssDocument e) (RssItem e) channelItemsL inj a@RssDocument { channelItems = i } = (\x -> a { channelItems = i }) <$> traverse inj i {-# INLINE channelItemsL #-} -channelCategoriesL :: Traversal' RssDocument RssCategory+channelCategoriesL :: Traversal' (RssDocument e) RssCategory channelCategoriesL inj a@RssDocument { channelCategories = c } = (\x -> a { channelCategories = c }) <$> traverse inj c {-# INLINE channelCategoriesL #-}

@@ -1,11 +1,15 @@+{-# LANGUAGE DataKinds                 #-} {-# LANGUAGE DeriveGeneric             #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE GADTs                     #-} {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE RankNTypes                #-} {-# LANGUAGE StandaloneDeriving        #-}+{-# LANGUAGE TypeFamilies              #-} {-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE UndecidableInstances      #-} -- | RSS is an XML dialect for Web content syndication. -- -- Example:@@ -36,21 +40,20 @@  -- {{{ Imports import           Control.Exception.Safe- import           Data.Semigroup import           Data.Set-import           Data.Text              hiding (map)+import           Data.Singletons.Prelude.List+import           Data.Text                    hiding (map) import           Data.Time.Clock-import           Data.Time.LocalTime    ()+import           Data.Time.LocalTime          () import           Data.Version--import           GHC.Generics           hiding ((:+:))-+import           Data.Vinyl.Core+import           GHC.Generics                 hiding ((:+:)) import           Text.Read- import           URI.ByteString -- }}} +-- * RSS core  data RssException = InvalidBool Text                   | InvalidDay Text@@ -63,6 +66,7 @@                   | MissingElement Text  deriving instance Eq RssException+deriving instance Generic RssException deriving instance Show RssException  instance Exception RssException where@@ -141,7 +145,9 @@   -- | The @\<item\>@ element.-data RssItem = RssItem+--+-- This type is open to extensions.+data RssItem (extensions :: [*]) = RssItem   { itemTitle       :: Text   , itemLink        :: Maybe RssURI   , itemDescription :: Text@@ -152,13 +158,16 @@   , itemGuid        :: Maybe RssGuid   , itemPubDate     :: Maybe UTCTime   , itemSource      :: Maybe RssSource+  , itemExtensions  :: RssItemExtensions extensions   } -deriving instance Eq RssItem-deriving instance Generic RssItem-deriving instance Ord RssItem-deriving instance Show RssItem+deriving instance (Eq (RssItemExtensions e)) => Eq (RssItem e)+deriving instance (Generic (RssItemExtensions e)) => Generic (RssItem e)+deriving instance (Ord (RssItemExtensions e)) => Ord (RssItem e)+deriving instance (Show (RssItemExtensions e)) => Show (RssItem e) +-- | Alias for 'RssItem' with no RSS extensions.+type RssItem' = RssItem '[]  -- | The @\<textInput\>@ element. data RssTextInput = RssTextInput@@ -230,12 +239,14 @@ asDay t = maybe (throwM $ InvalidDay t) return . readMaybe $ unpack t  -- | The @\<rss\>@ element.-data RssDocument = RssDocument+--+-- This type is open to extensions.+data RssDocument (extensions :: [*]) = RssDocument   { documentVersion       :: Version   , channelTitle          :: Text   , channelLink           :: RssURI   , channelDescription    :: Text-  , channelItems          :: [RssItem]+  , channelItems          :: [RssItem extensions]   , channelLanguage       :: Text   , channelCopyright      :: Text   , channelManagingEditor :: Text@@ -252,9 +263,53 @@   , channelTextInput      :: Maybe RssTextInput   , channelSkipHours      :: Set Hour   , channelSkipDays       :: Set Day+  , channelExtensions     :: RssChannelExtensions extensions   } -deriving instance Eq RssDocument-deriving instance Generic RssDocument-deriving instance Ord RssDocument-deriving instance Show RssDocument+deriving instance (Eq (RssChannelExtensions e), Eq (RssItemExtensions e)) => Eq (RssDocument e)+deriving instance (Generic (RssChannelExtensions e), Generic (RssItemExtensions e)) => Generic (RssDocument e)+deriving instance (Ord (RssChannelExtensions e), Ord (RssItemExtensions e)) => Ord (RssDocument e)+deriving instance (Show (RssChannelExtensions e), Show (RssItemExtensions e)) => Show (RssDocument e)++-- | Alias for 'RssDocument' with no RSS extensions.+type RssDocument' = RssDocument '[]++-- * RSS extensions+--+-- $doc+-- To implement an RSS extension:+--+-- - Create a void data-type, that will be used as a tag to identify the extension:+--+--   > data MyExtension :: *+--+-- - Implement extension types for @\<channel\>@ and @\<item\>@ elements:+--+--   > data instance RssChannelExtension MyExtension = MyExtensionChannel { {- ... fields -} }+--   > data instance RssItemExtension MyExtension = MyExtensionItem { {- ... fields -} }+--+-- - Implement corresponding parsers (cf 'Text.RSS.Extensions').++-- | @\<channel\>@ extension type.+data family RssChannelExtension extensionTag :: *++-- | @\<item\>@ extension type.+data family RssItemExtension extensionTag :: *++-- | Combination of multiple @\<channel\>@ extensions.+data family RssChannelExtensions (extensionTags :: [*]) :: *+data instance RssChannelExtensions a = RssChannelExtensions { rssChannelExtension :: Rec RssChannelExtension a }++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 (Show (Rec RssChannelExtension a)) => Show (RssChannelExtensions a)++-- | Combination of multiple @\<item\>@ extensions.+data family RssItemExtensions (extensionTags :: [*]) :: *+data instance RssItemExtensions (a :: [*]) = RssItemExtensions { rssItemExtension :: Rec RssItemExtension a }++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 (Show (Rec RssItemExtension a)) => Show (RssItemExtensions a)

@@ -1,6 +1,9 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes        #-} {-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TypeFamilies      #-} -- | Streaming parsers for the RSS 1.0 standard. module Text.RSS1.Conduit.Parse   ( -- * Top-level@@ -13,27 +16,26 @@   ) where  -- {{{ Imports+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.Conduit-import           Data.Text              as Text+import           Data.List.NonEmpty+import           Data.Singletons.Prelude+import           Data.Text               as Text import           Data.Text.Encoding import           Data.Time.Clock import           Data.Time.LocalTime import           Data.Time.RFC3339 import           Data.Version+import           Data.Vinyl.Core import           Data.XML.Types- import           Lens.Simple- import           Text.XML.Stream.Parse- import           URI.ByteString -- }}} @@ -96,7 +98,7 @@ makeTraversals ''TextInputPiece  -- | Parse a @\<textinput\>@ element.-rss1TextInput :: (MonadThrow m) => ConduitM Event o m (Maybe RssTextInput)+rss1TextInput :: MonadThrow m => ConduitM Event o m (Maybe RssTextInput) rss1TextInput = rss1Tag "textinput" attributes $ \uri -> (manyYield' (choose piece) =$= parser uri) <* many ignoreAnyTreeContent where   parser uri = getZipConduit $ RssTextInput     <$> ZipConduit (projectC _TextInputTitle =$= headRequiredC "Missing <title> element")@@ -111,12 +113,15 @@   attributes = (requireAttr (rdfName "about") >>= asRssURI) <* ignoreAttrs  -data ItemPiece = ItemTitle Text | ItemLink RssURI | ItemDescription Text | ItemCreator Text | ItemDate UTCTime | ItemContent Text+data ItemPiece = ItemTitle Text | ItemLink RssURI | ItemDescription Text | ItemCreator Text+               | ItemDate UTCTime | ItemContent Text | ItemOther (NonEmpty Event)  makeTraversals ''ItemPiece  -- | Parse an @\<item\>@ element.-rss1Item :: MonadThrow m => ConduitM Event o m (Maybe RssItem)+--+-- RSS extensions are automatically parsed based on the expected result type.+rss1Item :: ParseRssExtensions e => MonadCatch m => ConduitM Event o m (Maybe (RssItem e)) rss1Item = rss1Tag "item" attributes $ \uri -> (manyYield' (choose piece) =$= parser uri) <* many ignoreAnyTreeContent where   parser uri = getZipConduit $ RssItem     <$> ZipConduit (projectC _ItemTitle =$= headDefC mempty)@@ -129,11 +134,13 @@     <*> pure mzero     <*> ZipConduit (projectC _ItemDate =$= headC)     <*> pure mzero+    <*> ZipConduit (projectC _ItemOther =$= concatC =$= parseRssItemExtensions)   piece = [ fmap ItemTitle <$> rss1Tag "title" ignoreAttrs (const content)           , fmap ItemLink <$> rss1Tag "link" ignoreAttrs (const $ content >>= asRssURI)           , fmap ItemDescription <$> (rss1Tag "description" ignoreAttrs (const content) `orE` contentTag "encoded" ignoreAttrs (const content))           , fmap ItemCreator <$> dcTag "creator" ignoreAttrs (const content)           , fmap ItemDate <$> dcTag "date" ignoreAttrs (const $ content >>= asDate)+          , fmap ItemOther . nonEmpty <$> (void takeAnyTreeContent =$= sinkList)           ]   attributes = (requireAttr (rdfName "about") >>= asRssURI) <* ignoreAttrs @@ -165,7 +172,7 @@   attributes = requireAttr (rdfName "resource") <* ignoreAttrs  -data Rss1Channel = Rss1Channel+data Rss1Channel (extensions :: [*]) = Rss1Channel   { channelId'          :: RssURI   , channelTitle'       :: Text   , channelLink'        :: RssURI@@ -173,6 +180,7 @@   , channelItems'       :: [Text]   , channelImage'       :: Maybe RssImage   , channelTextInput'   :: Maybe RssURI+  , channelExtensions'  :: RssChannelExtensions extensions   }  data ChannelPiece = ChannelTitle Text@@ -181,12 +189,15 @@   | ChannelImage RssImage   | ChannelItems [Text]   | ChannelTextInput RssURI+  | ChannelOther (NonEmpty Event)  makeTraversals ''ChannelPiece   -- | Parse a @\<channel\>@ element.-rss1Channel :: MonadThrow m => ConduitM Event o m (Maybe Rss1Channel)+--+-- RSS extensions are automatically parsed based on the expected result type.+rss1Channel :: ParseRssExtensions e => MonadThrow m => ConduitM Event o m (Maybe (Rss1Channel e)) rss1Channel = rss1Tag "channel" attributes $ \channelId -> (manyYield' (choose piece) =$= parser channelId) <* many ignoreAnyTreeContent where   parser channelId = getZipConduit $ Rss1Channel channelId     <$> ZipConduit (projectC _ChannelTitle =$= headRequiredC "Missing <title> element")@@ -195,19 +206,21 @@     <*> ZipConduit (projectC _ChannelItems =$= concatC =$= sinkList)     <*> ZipConduit (projectC _ChannelImage =$= headC)     <*> ZipConduit (projectC _ChannelTextInput =$= headC)+    <*> ZipConduit (projectC _ChannelOther =$= concatC =$= parseRssChannelExtensions)   piece = [ fmap ChannelTitle <$> rss1Tag "title" ignoreAttrs (const content)           , fmap ChannelLink <$> rss1Tag "link" ignoreAttrs (const $ content >>= asRssURI)           , fmap ChannelDescription <$> rss1Tag "description" ignoreAttrs (const content)           , fmap ChannelItems <$> rss1ChannelItems           , fmap ChannelImage <$> rss1Image           , fmap ChannelTextInput <$> rss1Tag "textinput" (requireAttr (rdfName "resource") >>= asRssURI) return+          , fmap ChannelOther . nonEmpty <$> (void takeAnyTreeContent =$= sinkList)           ]   attributes = (requireAttr (rdfName "about") >>= asRssURI) <* ignoreAttrs  -data Rss1Document = Rss1Document Rss1Channel (Maybe RssImage) [RssItem] (Maybe RssTextInput)+data Rss1Document (e :: [*]) = Rss1Document (Rss1Channel e) (Maybe RssImage) [RssItem e] (Maybe RssTextInput) -rss1ToRss2 :: Rss1Document -> RssDocument+rss1ToRss2 :: Rss1Document e -> RssDocument e rss1ToRss2 (Rss1Document channel image items textInput) = RssDocument   (Version [1] [])   (channelTitle' channel)@@ -230,17 +243,20 @@   textInput   mempty   mempty+  (channelExtensions' channel) -data DocumentPiece = DocumentChannel Rss1Channel+data DocumentPiece (e :: [*]) = DocumentChannel (Rss1Channel e)   | DocumentImage RssImage-  | DocumentItem RssItem+  | DocumentItem (RssItem e)   | DocumentTextInput RssTextInput  makeTraversals ''DocumentPiece   -- | Parse an @\<RDF\>@ element.-rss1Document :: MonadThrow m => ConduitM Event o m (Maybe RssDocument)+--+-- RSS extensions are automatically parsed based on the expected result type.+rss1Document :: ParseRssExtensions e => MonadCatch m => ConduitM Event o m (Maybe (RssDocument e)) rss1Document = fmap (fmap rss1ToRss2) $ rdfTag "RDF" ignoreAttrs $ const $ (manyYield' (choose piece) =$= parser) <* many ignoreAnyTreeContent where   parser = getZipConduit $ Rss1Document     <$> ZipConduit (projectC _DocumentChannel =$= headRequiredC "Missing <channel> element")

@@ -1,5 +1,5 @@ name:                rss-conduit-version:             0.3.2.0+version:             0.4.0.0 synopsis:            Streaming parser/renderer for the RSS standard. description:         Cf README file. license:             PublicDomain@@ -19,25 +19,37 @@   exposed-modules:     Text.RSS1.Conduit.Parse     Text.RSS.Conduit.Parse+    Text.RSS.Conduit.Parse.Simple     Text.RSS.Conduit.Render+    Text.RSS.Extensions+    Text.RSS.Extensions.Atom+    Text.RSS.Extensions.Content+    Text.RSS.Extensions.DublinCore+    Text.RSS.Extensions.Syndication     Text.RSS.Lens     Text.RSS.Types   -- other-modules:   build-depends:-      base >= 4.8 && < 5+      atom-conduit+    , base >= 4.8 && < 5     , conduit     , conduit-combinators     , containers+    , dublincore-xml-conduit     , safe-exceptions     , lens-simple     , mono-traversable     , safe+    , singletons     , text     , time >= 1.5     , timerep >= 2.0     , uri-bytestring >= 0.2+    , vinyl     , xml-conduit >= 1.5     , xml-types+  if impl(ghc < 8)+    build-depends: semigroups   default-language: Haskell2010  test-suite Tests@@ -47,24 +59,28 @@   other-modules: Arbitrary   build-depends:       rss-conduit+    , atom-conduit     , base >= 4.8 && < 5     , bytestring     , conduit     , conduit-combinators     , data-default-    , safe-exceptions+    , dublincore-xml-conduit     , hlint     , lens-simple     , mono-traversable     , QuickCheck     , quickcheck-instances     , resourcet+    , safe-exceptions+    , singletons     , tasty     , tasty-hunit     , tasty-quickcheck     , time >= 1.5     , text     , uri-bytestring >= 0.2+    , vinyl     , xml-conduit >= 1.3     , xml-types   default-language: Haskell2010

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds         #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs             #-} -- | 'Arbitrary' instances used by RSS types.@@ -14,6 +15,7 @@ import           Data.Text.Encoding import           Data.Time.Clock import           Data.Version+import           Data.Vinyl.Core  import           GHC.Generics @@ -95,7 +97,7 @@ 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+instance Arbitrary (RssItem '[]) where   arbitrary = RssItem     <$> (pack <$> listOf genAlphaNum)     <*> arbitrary@@ -107,6 +109,7 @@     <*> arbitrary     <*> oneof [Just <$> genTime, pure Nothing]     <*> arbitrary+    <*> pure (RssItemExtensions RNil)  instance Arbitrary RssSource where   arbitrary = RssSource <$> arbitrary <*> (pack <$> listOf genAlphaNum)@@ -114,7 +117,7 @@ instance Arbitrary RssTextInput where   arbitrary = RssTextInput <$> (pack <$> listOf genAlphaNum) <*> (pack <$> listOf genAlphaNum) <*> (pack <$> listOf genAlphaNum) <*> arbitrary -instance Arbitrary RssDocument where+instance Arbitrary (RssDocument '[]) where   arbitrary = RssDocument     <$> arbitrary     <*> arbitrary@@ -137,6 +140,7 @@     <*> arbitrary     <*> arbitrary     <*> arbitrary+    <*> pure (RssChannelExtensions RNil)  instance Arbitrary Day where   arbitrary = arbitraryBoundedEnum

@@ -1,40 +1,48 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedLists   #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-} -- {{{ Imports-import           Arbitrary+import           Text.RSS.Conduit.Parse          as Parser+import           Text.RSS.Conduit.Render         as Renderer+import           Text.RSS.Extensions+import           Text.RSS.Extensions.Atom+import           Text.RSS.Extensions.Content+import           Text.RSS.Extensions.DublinCore+import           Text.RSS.Extensions.Syndication+import           Text.RSS.Lens+import           Text.RSS.Types+import           Text.RSS1.Conduit.Parse         as Parser +import           Arbitrary import           Conduit--import           Control.Exception.Safe       as Exception+import           Control.Exception.Safe          as Exception+import           Control.Monad import           Control.Monad.Trans.Resource- import           Data.Char import           Data.Conduit import           Data.Conduit.List import           Data.Default+import           Data.Singletons.Prelude.List+import           Data.Text                       (Text)+import           Data.Time.Calendar+import           Data.Time.LocalTime import           Data.Version+import           Data.Vinyl.Core import           Data.XML.Types--import qualified Language.Haskell.HLint       as HLint (hlint)-+import qualified Language.Haskell.HLint          as HLint (hlint) import           Lens.Simple-+import           System.IO+import           System.Timeout import           Test.Tasty import           Test.Tasty.HUnit import           Test.Tasty.QuickCheck--import           Text.RSS.Conduit.Parse       as Parser-import           Text.RSS.Conduit.Render      as Renderer-import           Text.RSS.Lens-import           Text.RSS.Types-import           Text.RSS1.Conduit.Parse      as Parser-import           Text.XML.Stream.Parse        as XML hiding (choose)+import           Text.Atom.Conduit.Parse+import           Text.Atom.Types+import           Text.XML.Stream.Parse           as XML hiding (choose) import           Text.XML.Stream.Render- import           URI.ByteString--import           System.IO -- }}}  main :: IO ()@@ -62,6 +70,12 @@   , rss1ChannelItemsCase   , rss1DocumentCase   , rss2DocumentCase+  , dublinCoreChannelCase+  , dublinCoreItemCase+  , contentItemCase+  , syndicationChannelCase+  , atomChannelCase+  , multipleExtensionsCase   ]  properties :: TestTree@@ -73,7 +87,6 @@   , roundtripSourceProperty   , roundtripGuidProperty   , roundtripItemProperty-  , roundtripDocumentProperty   ]  @@ -215,11 +228,15 @@  rss1ItemCase :: TestTree rss1ItemCase = testCase "RSS1 <item> element" $ do-  result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rss1Item+  Just result <- runResourceT $ runConduit $ sourceList input =$= XML.parseText' def =$= rss1Item   result^.itemTitleL @?= "Processing Inclusions with XSLT"   result^.itemLinkL @?= Just link   result^.itemDescriptionL @?= "Processing document inclusions with general XML tools can be problematic. This article proposes a way of preserving inclusion information through SAX-based processing."-  where input = [ "<item xmlns=\"http://purl.org/rss/1.0/\" xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\" rdf:about=\"http://xml.com/pub/2000/08/09/xslt/xslt.html\">"+  result^.itemExtensionsL @?= RssItemExtensions RNil+  where input = [ "<item xmlns=\"http://purl.org/rss/1.0/\""+                , "xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\""+                , "xmlns:dc=\"http://purl.org/dc/elements/1.1/\""+                , "rdf:about=\"http://xml.com/pub/2000/08/09/xslt/xslt.html\" >"                 , "<title>Processing Inclusions with XSLT</title>"                 , "<description>Processing document inclusions with general XML tools can be"                 , " problematic. This article proposes a way of preserving inclusion"@@ -238,6 +255,7 @@   result^.itemLinkL @?= Just link   result^.itemDescriptionL @?= "Here is some text containing an interesting description."   result^.itemGuidL @?= Just (GuidText "7bd204c6-1655-4c27-aeee-53f933c5395f")+  result^.itemExtensionsL @?= RssItemExtensions RNil   -- isJust (result^.itemPubDate_) @?= True   where input = [ "<item>"                 , "<title>Example entry</title>"@@ -267,7 +285,7 @@  rss1DocumentCase :: TestTree rss1DocumentCase = testCase "<rdf> element" $ do-  result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rss1Document+  Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rss1Document   result^.documentVersionL @?= Version [1] []   result^.channelTitleL @?= "XML.com"   result^.channelDescriptionL @?= "XML.com features a rich mix of information and services for the XML community."@@ -280,6 +298,7 @@   result^?channelTextInputL._Just.textInputDescriptionL @?= Just "Search XML.com's XML collection"   result^?channelTextInputL._Just.textInputNameL @?= Just "s"   result^?channelTextInputL._Just.textInputLinkL @?= Just textInputLink+  result^.channelExtensionsL @?= RssChannelExtensions RNil   where input = [ "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"                 , "<rdf:RDF xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\" xmlns=\"http://purl.org/rss/1.0/\">"                 , "<channel rdf:about=\"http://www.xml.com/xml/news.rss\">"@@ -325,12 +344,13 @@  rss2DocumentCase :: TestTree rss2DocumentCase = testCase "<rss> element" $ do-  result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssDocument+  Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= 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+  result^.channelExtensionsL @?= RssChannelExtensions RNil   length (result^..channelItemsL) @?= 1   where input = [ "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"                 , "<rss version=\"2.0\">"@@ -354,6 +374,124 @@         link = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.example.com") Nothing)) "/main.html" (Query []) Nothing)  +dublinCoreChannelCase :: TestTree+dublinCoreChannelCase = testCase "Dublin Core <channel> extension" $ do+  Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rssDocument+  result^.channelExtensionsL @?= RssChannelExtensions (DublinCoreChannel dublinCoreElement :& RNil)+  where input = [ "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"+                , "<rss xmlns:dc=\"http://purl.org/dc/elements/1.1/\" version=\"2.0\">"+                , "<channel>"+                , "<title>RSS Title</title>"+                , "<link>http://xml.com/pub/2000/08/09/xslt/xslt.html</link>"+                , "<dc:publisher>The O'Reilly Network</dc:publisher>"+                , "<dc:creator>Rael Dornfest (mailto:rael@oreilly.com)</dc:creator>"+                , "<dc:date>2000-01-01T12:00:00+00:00</dc:date>"+                , "<dc:language>EN</dc:language>"+                , "<dc:rights>Copyright © 2000 O'Reilly &amp; Associates, Inc.</dc:rights>"+                , "<dc:subject>XML</dc:subject>"+                , "</channel>"+                , "</rss>"+                ]+        dublinCoreElement = mkDcMetaData+          { elementCreator = "Rael Dornfest (mailto:rael@oreilly.com)"+          , elementDate = Just date+          , elementLanguage = "EN"+          , elementPublisher = "The O'Reilly Network"+          , elementRights = "Copyright © 2000 O'Reilly & Associates, Inc."+          , elementSubject = "XML"+          }+        date = localTimeToUTC utc $ LocalTime (fromGregorian 2000 1 1) (TimeOfDay 12 0 0)++dublinCoreItemCase :: TestTree+dublinCoreItemCase = testCase "Dublin Core <item> extension" $ do+  Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rssItem+  result^.itemExtensionsL @?= RssItemExtensions (DublinCoreItem dublinCoreElement :& RNil)+  where input = [ "<item xmlns:dc=\"http://purl.org/dc/elements/1.1/\">"+                , "<title>Example entry</title>"+                , "<dc:description>XML is placing increasingly heavy loads on the existing technical "+                , "infrastructure of the Internet.</dc:description>"+                , "<dc:language>EN</dc:language>"+                , "<dc:publisher>The O'Reilly Network</dc:publisher>"+                , "<dc:creator>Simon St.Laurent (mailto:simonstl@simonstl.com)</dc:creator>"+                , "<dc:date>2000-01-01T12:00:00+00:00</dc:date>"+                , "<dc:rights>Copyright © 2000 O'Reilly &amp; Associates, Inc.</dc:rights>"+                , "<dc:subject>XML</dc:subject>"+                , "</item>"+                ]+        dublinCoreElement = mkDcMetaData+          { elementCreator = "Simon St.Laurent (mailto:simonstl@simonstl.com)"+          , elementDate = Just date+          , elementLanguage = "EN"+          , elementDescription = "XML is placing increasingly heavy loads on the existing technical infrastructure of the Internet."+          , elementPublisher = "The O'Reilly Network"+          , elementRights = "Copyright © 2000 O'Reilly & Associates, Inc."+          , elementSubject = "XML"+          }+        date = localTimeToUTC utc $ LocalTime (fromGregorian 2000 1 1) (TimeOfDay 12 0 0)++contentItemCase :: TestTree+contentItemCase = testCase "Content <item> extension" $ do+  Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rssItem+  result^.itemExtensionsL @?= RssItemExtensions (ContentItem "<p>What a <em>beautiful</em> day!</p>" :& RNil)+  where input = [ "<item xmlns:content=\"http://purl.org/rss/1.0/modules/content/\">"+                , "<title>Example entry</title>"+                , "<content:encoded><![CDATA[<p>What a <em>beautiful</em> day!</p>]]></content:encoded>"+                , "</item>"+                ]++syndicationChannelCase :: TestTree+syndicationChannelCase = testCase "Syndication <channel> extension" $ do+  Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rssDocument+  result^.channelExtensionsL @?= RssChannelExtensions (SyndicationChannel syndicationInfo :& RNil)+  where input = [ "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"+                , "<rss xmlns:sy=\"http://purl.org/rss/1.0/modules/syndication/\" version=\"2.0\">"+                , "<channel>"+                , "<title>RSS Title</title>"+                , "<link>http://xml.com/pub/2000/08/09/xslt/xslt.html</link>"+                , "<sy:updatePeriod>hourly</sy:updatePeriod>"+                , "<sy:updateFrequency>2</sy:updateFrequency>"+                , "<sy:updateBase>2000-01-01T12:00:00+00:00</sy:updateBase>"+                , "</channel>"+                , "</rss>"+                ]+        syndicationInfo = mkSyndicationInfo+          { updatePeriod = Just Hourly+          , updateFrequency = Just 2+          , updateBase = Just date+          }+        date = localTimeToUTC utc $ LocalTime (fromGregorian 2000 1 1) (TimeOfDay 12 0 0)++atomChannelCase :: TestTree+atomChannelCase = testCase "Atom <channel> extension" $ do+  Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rssDocument+  result^.channelExtensionsL @?= RssChannelExtensions (AtomChannel (Just link) :& RNil)+  where input = [ "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"+                , "<rss xmlns:atom=\"http://www.w3.org/2005/Atom\" version=\"2.0\">"+                , "<channel>"+                , "<title>RSS Title</title>"+                , "<link>http://xml.com/pub/2000/08/09/xslt/xslt.html</link>"+                , "<atom:link href=\"http://dallas.example.com/rss.xml\" rel=\"self\" type=\"application/rss+xml\" />"+                , "</channel>"+                , "</rss>"+                ]+        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++multipleExtensionsCase :: TestTree+multipleExtensionsCase = testCase "Multiple extensions" $ do+  Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rssItem+  result^.itemExtensionsL @?= RssItemExtensions (ContentItem "<p>What a <em>beautiful</em> day!</p>" :& AtomItem (Just link) :& RNil)+  where input = [ "<item xmlns:content=\"http://purl.org/rss/1.0/modules/content/\""+                , " xmlns:atom=\"http://www.w3.org/2005/Atom\">"+                , "<title>Example entry</title>"+                , "<atom:link href=\"http://dallas.example.com/rss.xml\" rel=\"self\" type=\"application/rss+xml\" />"+                , "<content:encoded><![CDATA[<p>What a <em>beautiful</em> day!</p>]]></content:encoded>"+                , "</item>"+                ]+        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++ hlint :: TestTree hlint = testCase "HLint check" $ do   result <- HLint.hlint [ "test/", "Text/" ]@@ -379,12 +517,8 @@ roundtripGuidProperty = testProperty "parse . render = id (RssGuid)" $ \t -> either (const False) (t ==) (runConduit $ renderRssGuid t =$= force "ERROR" rssGuid)  roundtripItemProperty :: TestTree-roundtripItemProperty = testProperty "parse . render = id (RssItem)" $ \t -> either (const False) (t ==) (runConduit $ renderRssItem t =$= force "ERROR" rssItem)+roundtripItemProperty = testProperty "parse . render = id (RssItem)" $ \(t :: RssItem '[]) -> 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