rss-conduit 0.4.2.0 → 0.4.2.1

raw patch · 25 files changed

+1805/−1785 lines, 25 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Text/RSS/Conduit/Parse.hs +0/−296
• Text/RSS/Conduit/Parse/Simple.hs +0/−78
• Text/RSS/Conduit/Render.hs +0/−172
• Text/RSS/Extensions.hs +0/−92
• Text/RSS/Extensions/Atom.hs +0/−41
• Text/RSS/Extensions/Content.hs +0/−80
• Text/RSS/Extensions/DublinCore.hs +0/−161
• Text/RSS/Extensions/Syndication.hs +0/−201
• Text/RSS/Lens.hs +0/−61
• Text/RSS/Types.hs +0/−318
• Text/RSS1/Conduit/Parse.hs +0/−270
• rss-conduit.cabal +20/−3
• src/Text/RSS/Conduit/Parse.hs +295/−0
• src/Text/RSS/Conduit/Parse/Simple.hs +78/−0
• src/Text/RSS/Conduit/Render.hs +172/−0
• src/Text/RSS/Extensions.hs +95/−0
• src/Text/RSS/Extensions/Atom.hs +41/−0
• src/Text/RSS/Extensions/Content.hs +80/−0
• src/Text/RSS/Extensions/DublinCore.hs +161/−0
• src/Text/RSS/Extensions/Syndication.hs +201/−0
• src/Text/RSS/Lens.hs +61/−0
• src/Text/RSS/Types.hs +318/−0
• src/Text/RSS1/Conduit/Parse.hs +270/−0
• test/HLint.hs +8/−0
• test/Main.hs +5/−12

@@ -1,296 +0,0 @@-{-# 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-    rssDocument-    -- * Elements-  , rssCategory-  , rssCloud-  , rssEnclosure-  , rssGuid-  , rssImage-  , rssItem-  , rssSkipDays-  , rssSkipHours-  , rssSource-  , rssTextInput-  ) 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.Set                     hiding (fold)-import           Data.Text                    as Text-import           Data.Text.Encoding-import           Data.Time.Clock-import           Data.Time.LocalTime-import           Data.Time.RFC822-import           Data.Version-import           Data.XML.Types-import           Lens.Simple-import           Prelude                      hiding (last, lookup)-import           Safe-import           Text.ParserCombinators.ReadP (readP_to_S)-import           Text.Read                    (readMaybe)-import           Text.XML.Stream.Parse-import           URI.ByteString--- }}}---- {{{ Util-asRssURI :: MonadThrow m => Text -> m RssURI-asRssURI t = case (parseURI' t, parseRelativeRef' t) of-  (Right u, _) -> return $ RssURI u-  (_, Right u) -> return $ RssURI u-  (_, Left e)  -> throwM $ InvalidURI e-  where parseURI' = parseURI laxURIParserOptions . encodeUtf8-        parseRelativeRef' = parseRelativeRef laxURIParserOptions . encodeUtf8--nullURI :: RssURI-nullURI = RssURI $ RelativeRef Nothing "" (Query []) Nothing--asInt :: MonadThrow m => Text -> m Int-asInt t = maybe (throwM $ InvalidInt t) return . readMaybe $ unpack t--asBool :: MonadThrow m => Text -> m Bool-asBool "true"  = return True-asBool "false" = return False-asBool t       = throwM $ InvalidBool t--asVersion :: MonadThrow m => Text -> m Version-asVersion t = maybe (throwM $ InvalidVersion t) return . fmap fst . headMay . readP_to_S parseVersion $ unpack t--asCloudProtocol :: MonadThrow m => Text -> m CloudProtocol-asCloudProtocol "xml-rpc"   = return ProtocolXmlRpc-asCloudProtocol "soap"      = return ProtocolSoap-asCloudProtocol "http-post" = return ProtocolHttpPost-asCloudProtocol t           = throwM $ InvalidProtocol t---- | Like 'tagName' but ignores the namespace.-tagName' :: (MonadThrow m) => Text -> AttrParser a -> (a -> ConduitM Event o m b) -> ConduitM Event o m (Maybe b)-tagName' t = tag' (matching $ \n -> nameLocalName n == t)---- | Tag which content is a date-time that follows RFC 3339 format.-tagDate :: (MonadThrow m) => NameMatcher a -> ConduitM Event o m (Maybe UTCTime)-tagDate name = tagIgnoreAttrs name $ fmap zonedTimeToUTC $ do-  text <- content-  maybe (throw $ InvalidTime text) return $ parseTimeRFC822 text--headRequiredC :: MonadThrow m => Text -> Consumer a m a-headRequiredC e = maybe (throw $ MissingElement e) return =<< headC--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 ()--- }}}----- | Parse a @\<skipHours\>@ element.-rssSkipHours :: MonadThrow m => ConduitM Event o m (Maybe (Set Hour))-rssSkipHours = tagIgnoreAttrs "skipHours" $-  fromList <$> (manyYield' (tagIgnoreAttrs "hour" $ content >>= asInt >>= asHour) =$= sinkList)---- | Parse a @\<skipDays\>@ element.-rssSkipDays :: MonadThrow m => ConduitM Event o m (Maybe (Set Day))-rssSkipDays = tagIgnoreAttrs "skipDays" $-  fromList <$> (manyYield' (tagIgnoreAttrs "day" $ content >>= asDay) =$= sinkList)---data TextInputPiece = TextInputTitle Text | TextInputDescription Text-                    | TextInputName Text | TextInputLink RssURI--makeTraversals ''TextInputPiece---- | Parse a @\<textInput\>@ element.-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")-    <*> ZipConduit (projectC _TextInputDescription =$= headRequiredC "Missing <description> element")-    <*> ZipConduit (projectC _TextInputName =$= headRequiredC "Missing <name> element")-    <*> ZipConduit (projectC _TextInputLink =$= headRequiredC "Missing <link> element")-  piece = [ fmap TextInputTitle <$> tagIgnoreAttrs "title" content-          , fmap TextInputDescription <$> tagIgnoreAttrs "description" content-          , fmap TextInputName <$> tagIgnoreAttrs "name" content-          , fmap TextInputLink <$> tagIgnoreAttrs "link" (content >>= asRssURI)-          ]----data ImagePiece = ImageUri RssURI | ImageTitle Text | ImageLink RssURI | ImageWidth Int-                | ImageHeight Int | ImageDescription Text--makeTraversals ''ImagePiece---- | Parse an @\<image\>@ element.-rssImage :: (MonadThrow m) => ConduitM Event o m (Maybe RssImage)-rssImage = tagIgnoreAttrs "image" $ (manyYield' (choose piece) =$= parser) <* many ignoreAnyTreeContent where-  parser = getZipConduit $ RssImage-    <$> ZipConduit (projectC _ImageUri =$= headRequiredC "Missing <url> element")-    <*> ZipConduit (projectC _ImageTitle =$= headDefC "Unnamed image")  -- Lenient-    <*> ZipConduit (projectC _ImageLink =$= headDefC nullURI)  -- Lenient-    <*> ZipConduit (projectC _ImageWidth =$= headC)-    <*> ZipConduit (projectC _ImageHeight =$= headC)-    <*> ZipConduit (projectC _ImageDescription =$= headDefC "")-  piece = [ fmap ImageUri <$> tagIgnoreAttrs "url" (content >>= asRssURI)-          , fmap ImageTitle <$> tagIgnoreAttrs "title" content-          , fmap ImageLink <$> tagIgnoreAttrs "link" (content >>= asRssURI)-          , fmap ImageWidth <$> tagIgnoreAttrs "width" (content >>= asInt)-          , fmap ImageHeight <$> tagIgnoreAttrs "height" (content >>= asInt)-          , fmap ImageDescription <$> tagIgnoreAttrs "description" content-          ]---- | Parse a @\<category\>@ element.-rssCategory :: MonadThrow m => ConduitM Event o m (Maybe RssCategory)-rssCategory = tagName' "category" (optional (requireAttr "domain") <* ignoreAttrs) $ \domain ->-  RssCategory (fromMaybe "" domain) <$> content---- | Parse a @\<cloud\>@ element.-rssCloud :: (MonadThrow m) => ConduitM Event o m (Maybe RssCloud)-rssCloud = tagName' "cloud" attributes return where-  attributes = do-    uri <- fmap RssURI $ RelativeRef-      <$> fmap Just (Authority Nothing <$> (Host . encodeUtf8 <$> requireAttr "domain") <*> (fmap Port <$> optional (requireAttr "port" >>= asInt)))-      <*> (encodeUtf8 <$> requireAttr "path")-      <*> pure (Query [])-      <*> pure Nothing-    RssCloud uri <$> requireAttr "registerProcedure" <*> (requireAttr "protocol" >>= asCloudProtocol) <* ignoreAttrs---- | Parse a @\<guid\>@ element.-rssGuid :: MonadThrow m => ConduitM Event o m (Maybe RssGuid)-rssGuid = tagName' "guid" attributes handler where-  attributes = optional (requireAttr "isPermaLink" >>= asBool) <* ignoreAttrs-  handler (Just True) = GuidUri <$> (content >>= asRssURI)-  handler _           = GuidText <$> content---- | Parse an @\<enclosure\>@ element.-rssEnclosure :: MonadThrow m => ConduitM Event o m (Maybe RssEnclosure)-rssEnclosure = tagName' "enclosure" attributes handler where-  attributes = (,,) <$> (requireAttr "url" >>= asRssURI) <*> (requireAttr "length" >>= asInt) <*> requireAttr "type" <* ignoreAttrs-  handler (uri, length_, type_) = return $ RssEnclosure uri length_ type_---- | Parse a @\<source\>@ element.-rssSource :: MonadThrow m => ConduitM Event o m (Maybe RssSource)-rssSource = tagName' "source" attributes handler where-  attributes = (requireAttr "url" >>= asRssURI) <* ignoreAttrs-  handler uri = RssSource uri <$> content---data ItemPiece = ItemTitle Text | ItemLink RssURI | ItemDescription Text-               | ItemAuthor Text | ItemCategory RssCategory | ItemComments RssURI-               | ItemEnclosure RssEnclosure | ItemGuid RssGuid | ItemPubDate UTCTime-               | ItemSource RssSource | ItemOther (NonEmpty Event)--makeTraversals ''ItemPiece---- | Parse an @\<item\>@ element.------ RSS extensions are automatically parsed based on the inferred 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 "")-    <*> ZipConduit (projectC _ItemLink =$= headC)-    <*> ZipConduit (projectC _ItemDescription =$= headDefC "")-    <*> ZipConduit (projectC _ItemAuthor =$= headDefC "")-    <*> ZipConduit (projectC _ItemCategory =$= sinkList)-    <*> ZipConduit (projectC _ItemComments =$= headC)-    <*> ZipConduit (projectC _ItemEnclosure =$= sinkList)-    <*> 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-          , fmap ItemAuthor <$> tagIgnoreAttrs "author" content-          , fmap ItemCategory <$> rssCategory-          , fmap ItemComments <$> tagIgnoreAttrs "comments" (content >>= asRssURI)-          , fmap ItemEnclosure <$> rssEnclosure-          , fmap ItemGuid <$> rssGuid-          , fmap ItemPubDate <$> tagDate "pubDate"-          , fmap ItemSource <$> rssSource-          , fmap ItemOther . nonEmpty <$> (void takeAnyTreeContent =$= sinkList)-          ]---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.------ RSS extensions are automatically parsed based on the inferred 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")-    <*> ZipConduit (projectC _ChannelLink =$= headRequiredC "Missing <link> element")-    <*> ZipConduit (projectC _ChannelDescription =$= headDefC "")  -- Lenient-    <*> ZipConduit (projectC _ChannelItem =$= sinkList)-    <*> ZipConduit (projectC _ChannelLanguage =$= headDefC "")-    <*> ZipConduit (projectC _ChannelCopyright =$= headDefC "")-    <*> ZipConduit (projectC _ChannelManagingEditor =$= headDefC "")-    <*> ZipConduit (projectC _ChannelWebmaster =$= headDefC "")-    <*> ZipConduit (projectC _ChannelPubDate =$= headC)-    <*> ZipConduit (projectC _ChannelLastBuildDate =$= headC)-    <*> ZipConduit (projectC _ChannelCategory =$= sinkList)-    <*> ZipConduit (projectC _ChannelGenerator =$= headDefC "")-    <*> ZipConduit (projectC _ChannelDocs =$= headC)-    <*> ZipConduit (projectC _ChannelCloud =$= headC)-    <*> ZipConduit (projectC _ChannelTtl =$= headC)-    <*> ZipConduit (projectC _ChannelImage =$= headC)-    <*> ZipConduit (projectC _ChannelRating =$= headDefC "")-    <*> 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-          , fmap ChannelItem <$> rssItem-          , fmap ChannelLanguage <$> tagIgnoreAttrs "language" content-          , fmap ChannelCopyright <$> tagIgnoreAttrs "copyright" content-          , fmap ChannelManagingEditor <$> tagIgnoreAttrs "managingEditor" content-          , fmap ChannelWebmaster <$> tagIgnoreAttrs "webMaster" content-          , fmap ChannelPubDate <$> tagDate "pubDate"-          , fmap ChannelLastBuildDate <$> tagDate "lastBuildDate"-          , fmap ChannelCategory <$> rssCategory-          , fmap ChannelGenerator <$> tagIgnoreAttrs "generator" content-          , fmap ChannelDocs <$> tagIgnoreAttrs "docs" (content >>= asRssURI)-          , fmap ChannelCloud <$> rssCloud-          , fmap ChannelTtl <$> tagIgnoreAttrs "ttl" (content >>= asInt)-          , fmap ChannelImage <$> rssImage-          , fmap ChannelRating <$> tagIgnoreAttrs "rating" content-          , fmap ChannelTextInput <$> rssTextInput-          , fmap ChannelSkipHours <$> rssSkipHours-          , fmap ChannelSkipDays <$> rssSkipDays-          , fmap ChannelOther . nonEmpty <$> (void takeAnyTreeContent =$= sinkList)-          ]-  attributes = (requireAttr "version" >>= asVersion) <* ignoreAttrs

@@ -1,78 +0,0 @@-{-# 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

@@ -1,172 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Streaming renderers for the RSS 2.0 standard.-module Text.RSS.Conduit.Render-  ( -- * Top-level-    renderRssDocument-    -- * Elements-  , renderRssItem-  , renderRssSource-  , renderRssEnclosure-  , renderRssGuid-  , renderRssCloud-  , renderRssCategory-  , renderRssImage-  , renderRssTextInput-  , renderRssSkipDays-  , renderRssSkipHours-  ) where---- {{{ Imports-import           Text.RSS.Extensions-import           Text.RSS.Lens-import           Text.RSS.Types--import           Control.Monad-import           Data.Conduit-import           Data.Monoid-import           Data.Set               (Set)-import qualified Data.Set               as Set-import           Data.Text              as Text hiding (map)-import           Data.Text.Encoding-import           Data.Time.Clock-import           Data.Time.LocalTime-import           Data.Time.RFC822-import           Data.Version-import           Data.XML.Types-import           Lens.Simple-import           Safe-import           Text.XML.Stream.Render-import           URI.ByteString--- }}}---- | Render the top-level @\<rss\>@ element.-renderRssDocument :: Monad m => 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-    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-    renderRssChannelExtensions $ d^.channelExtensionsL---- | Render an @\<item\>@ element.-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-  optionalTextTag "description" $ i^.itemDescriptionL-  optionalTextTag "author" $ i^.itemAuthorL-  forM_ (i^..itemCategoriesL) renderRssCategory-  forM_ (i^.itemCommentsL) $ textTag "comments" . renderRssURI-  forM_ (i^..itemEnclosureL) renderRssEnclosure-  forM_ (i^.itemGuidL) renderRssGuid-  forM_ (i^.itemPubDateL) $ dateTag "pubDate"-  forM_ (i^.itemSourceL) renderRssSource-  renderRssItemExtensions $ i^.itemExtensionsL---- | Render a @\<source\>@ element.-renderRssSource :: (Monad m) => RssSource -> Source m Event-renderRssSource s = tag "source" (attr "url" $ renderRssURI $ s^.sourceUrlL) . content $ s^.sourceNameL---- | Render an @\<enclosure\>@ element.-renderRssEnclosure :: (Monad m) => RssEnclosure -> Source m Event-renderRssEnclosure e = tag "enclosure" attributes mempty where-  attributes = attr "url" (renderRssURI $ e^.enclosureUrlL)-    <> attr "length" (tshow $ e^.enclosureLengthL)-    <> attr "type" (e^.enclosureTypeL)---- | Render a @\<guid\>@ element.-renderRssGuid :: (Monad m) => RssGuid -> Source m Event-renderRssGuid (GuidUri u) = tag "guid" (attr "isPermaLink" "true") $ content $ renderRssURI u-renderRssGuid (GuidText t) = tag "guid" mempty $ content t----- | Render a @\<cloud\>@ element.-renderRssCloud :: Monad m => RssCloud -> Source m Event-renderRssCloud c = tag "cloud" attributes $ return () where-  attributes = attr "domain" domain-    <> optionalAttr "port" port-    <> attr "path" (path <> query <> fragment)-    <> attr "registerProcedure" (c^.cloudRegisterProcedureL)-    <> attr "protocol" (describe $ c^.cloudProtocolL)--  renderUserInfo (Just (UserInfo a b)) = decodeUtf8 a <> ":" <> decodeUtf8 b <> "@"-  renderUserInfo _ = ""-  renderHost (Host h) = decodeUtf8 h-  renderQuery (Query query) = case intercalate "&" $ map (\(a,b) -> decodeUtf8 a <> "=" <> decodeUtf8 b) query of-    "" -> ""-    x  -> "?" <> x--  domain = maybe "" (\a -> renderUserInfo (authorityUserInfo a) <> renderHost (authorityHost a)) $ withRssURI (view authorityL) $ c^.cloudUriL-  port = fmap (pack . show . portNumber) $ authorityPort =<< withRssURI (view authorityL) (c^.cloudUriL)-  path = decodeUtf8 $ withRssURI (view pathL) $ c^.cloudUriL-  query = renderQuery $ withRssURI (view queryL) $ c^.cloudUriL-  fragment = maybe "" decodeUtf8 $ withRssURI (view fragmentL) $ c^.cloudUriL--  describe ProtocolXmlRpc   = "xml-rpc"-  describe ProtocolSoap     = "soap"-  describe ProtocolHttpPost = "http-post"---- | Render a @\<category\>@ element.-renderRssCategory :: (Monad m) => RssCategory -> Source m Event-renderRssCategory c = tag "category" (attr "domain" $ c^.categoryDomainL) . content $ c^.categoryNameL---- | Render an @\<image\>@ element.-renderRssImage :: (Monad m) => RssImage -> Source m Event-renderRssImage i = tag "image" mempty $ do-  textTag "url" $ renderRssURI $ i^.imageUriL-  textTag "title" $ i^.imageTitleL-  textTag "link" $ renderRssURI $ i^.imageLinkL-  forM_ (i^.imageHeightL) $ textTag "height" . tshow-  forM_ (i^.imageWidthL) $ textTag "width" . tshow-  optionalTextTag "description" $ i^.imageDescriptionL---- | Render a @\<textInput\>@ element.-renderRssTextInput :: (Monad m) => RssTextInput -> Source m Event-renderRssTextInput t = tag "textInput" mempty $ do-  textTag "title" $ t^.textInputTitleL-  textTag "description" $ t^.textInputDescriptionL-  textTag "name" $ t^.textInputNameL-  textTag "link" $ renderRssURI $ t^.textInputLinkL---- | Render a @\<skipDays\>@ element.-renderRssSkipDays :: (Monad m) => Set Day -> Source m Event-renderRssSkipDays s = unless (Set.null s) $ tag "skipDays" mempty $ forM_ s $ textTag "day" . tshow---- | Render a @\<skipHours\>@ element.-renderRssSkipHours :: (Monad m) => Set Hour -> Source m Event-renderRssSkipHours s = unless (Set.null s) $ tag "skipHour" mempty $ forM_ s $ textTag "hour" . tshow----- {{{ Utils-tshow :: Show a => a -> Text-tshow = pack . show--textTag :: (Monad m) => Name -> Text -> Source m Event-textTag name = tag name mempty . content--optionalTextTag :: Monad m => Name -> Text -> Source m Event-optionalTextTag name value = unless (Text.null value) $ textTag name value--dateTag :: (Monad m) => Name -> UTCTime -> Source m Event-dateTag name = tag name mempty . content . formatTimeRFC822 . utcToZonedTime utc--renderRssURI :: RssURI -> Text-renderRssURI = decodeUtf8 . withRssURI serializeURIRef'--- }}}

@@ -1,92 +0,0 @@-{-# 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)---- | Class of RSS extensions that can be rendered.-class RenderRssExtension e where-  -- | Render extension for the @\<channel\>@ element.-  renderRssChannelExtension :: Monad m => RssChannelExtension e -> Source m Event-  -- | Render extension for the @\<item\>@ 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 @\<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)---- | Render a set of @\<channel\>@ 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 @\<item\>@ 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)

@@ -1,41 +0,0 @@-{-# 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.Conduit.Render-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)--instance RenderRssExtension AtomModule where-  renderRssChannelExtension = mapM_ renderAtomLink . channelAtomLink-  renderRssItemExtension    = mapM_ renderAtomLink . itemAtomLink--data instance RssChannelExtension AtomModule = AtomChannel { channelAtomLink :: Maybe AtomLink }-  deriving(Eq, Generic, Show)-data instance RssItemExtension AtomModule = AtomItem { itemAtomLink :: Maybe AtomLink }-  deriving(Eq, Generic, Show)

@@ -1,80 +0,0 @@-{-# 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)-    -- * Parser-  , contentEncoded-    -- * Renderer-  , renderContentEncoded-    -- * Misc-  , namespacePrefix-  , namespaceURI-  ) where---- {{{ Imports-import           Text.RSS.Extensions-import           Text.RSS.Types--import           Conduit                hiding (throwM)-import           Control.Exception.Safe as Exception-import           Control.Monad-import           Data.Maybe-import           Data.Singletons-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--- }}}---- | __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)--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 }-  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---- | Render a @\<content:encoded\>@ element.-renderContentEncoded :: Monad m => Text -> Source m Event-renderContentEncoded = Render.tag (contentName "encoded") mempty . Render.content

@@ -1,161 +0,0 @@-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE KindSignatures    #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE RecordWildCards   #-}-{-# 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)-  , channelDcMetaData-  , RssItemExtension(DublinCoreItem)-  , itemDcMetaData-  , 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-import           Control.Monad.Fix-import           Data.Maybe-import           Data.Singletons-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           Text.XML.DublinCore.Conduit.Render-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-          ]---- | 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 :: *--data instance Sing DublinCoreModule = SDublinCoreModule--instance SingI DublinCoreModule where sing = SDublinCoreModule--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 }-  deriving(Eq, Generic, Ord, Show)-data instance RssItemExtension DublinCoreModule = DublinCoreItem { itemDcMetaData :: DcMetaData }-  deriving(Eq, Generic, Ord, Show)

@@ -1,201 +0,0 @@-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE KindSignatures    #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE RecordWildCards   #-}-{-# 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-  , syndicationInfo-  , syndicationPeriod-  , syndicationFrequency-  , syndicationBase-    -- * Renderers-  , renderSyndicationInfo-  , renderSyndicationPeriod-  , renderSyndicationFrequency-  , renderSyndicationBase-    -- * 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           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--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))--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 (Bounded, Enum, Eq, Generic, Ord, Read, 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--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, Read, Show)---- | Construct an empty 'SyndicationInfo'.-mkSyndicationInfo :: SyndicationInfo-mkSyndicationInfo = SyndicationInfo mzero mzero mzero---data ElementPiece = ElementPeriod SyndicationPeriod | ElementFrequency Int | ElementBase UTCTime--makeTraversals ''ElementPiece---- | Parse all __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)---- | 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 @\<sy:updatePeriod\>@ element.-renderSyndicationPeriod :: Monad m => SyndicationPeriod -> Source m Event-renderSyndicationPeriod = renderSyndicationTag "updatePeriod" . fromSyndicationPeriod---- | Render a @\<sy:updateFrequency\>@ element.-renderSyndicationFrequency :: Monad m => Int -> Source m Event-renderSyndicationFrequency = renderSyndicationTag "updateFrequency" . tshow---- | Render a @\<sy:updateBase\>@ element.-renderSyndicationBase :: Monad m => UTCTime -> Source m Event-renderSyndicationBase = renderSyndicationTag "updateBase" . formatTimeRFC822 . utcToZonedTime utc----- | __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--instance RenderRssExtension SyndicationModule where-  renderRssChannelExtension = renderSyndicationInfo . channelSyndicationInfo-  renderRssItemExtension    = const $ pure ()---data instance RssChannelExtension SyndicationModule = SyndicationChannel { channelSyndicationInfo :: SyndicationInfo}-  deriving (Eq, Generic, Ord, Read, Show)-data instance RssItemExtension SyndicationModule = SyndicationItem deriving (Eq, Generic, Ord, Read, Show)

@@ -1,61 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TemplateHaskell  #-}-module Text.RSS.Lens (module Text.RSS.Lens) where---- {{{ Imports-import           Text.RSS.Types--import           Data.Singletons.Prelude-import           Data.Vinyl.Lens-import           Data.Vinyl.TypeLevel-import           Lens.Simple-import           URI.ByteString--- }}}---$(makeLensesBy (\n -> Just (n ++ "L")) ''RssCategory)-$(makeLensesBy (\n -> Just (n ++ "L")) ''RssEnclosure)-$(makeLensesBy (\n -> Just (n ++ "L")) ''RssSource)--$(makeLensesBy-  (let f "itemCategories" = Nothing-       f "itemEnclosure"  = Nothing-       f n                = Just (n ++ "L")-   in f)-  ''RssItem)--itemCategoriesL :: Traversal' (RssItem e) RssCategory-itemCategoriesL inj a@RssItem { itemCategories = c } = (\x -> a { itemCategories = c }) <$> traverse inj c-{-# INLINE itemCategoriesL #-}--itemEnclosureL :: Traversal' (RssItem e) RssEnclosure-itemEnclosureL inj a@RssItem { itemEnclosure = e } = (\x -> a { itemEnclosure = e }) <$> traverse inj e-{-# INLINE itemEnclosureL #-}--itemExtensionL :: SingI a => RElem a e (RIndex a e) => Lens' (RssItem e) (RssItemExtension a)-itemExtensionL = itemExtensionsL . f . rlens sing where-  f inj (RssItemExtensions a) = RssItemExtensions <$> inj a-{-# INLINE itemExtensionL #-}--$(makeLensesBy (\n -> Just (n ++ "L")) ''RssTextInput)-$(makeLensesBy (\n -> Just (n ++ "L")) ''RssCloud)-$(makeLensesBy (\n -> Just (n ++ "L")) ''RssImage)-$(makeLensesBy-  (let f "channelItems"      = Nothing-       f "channelCategories" = Nothing-       f n                   = Just (n ++ "L")-  in f)-  ''RssDocument)--channelItemsL :: Traversal' (RssDocument e) (RssItem e)-channelItemsL inj a@RssDocument { channelItems = i } = (\x -> a { channelItems = i }) <$> traverse inj i-{-# INLINE channelItemsL #-}--channelCategoriesL :: Traversal' (RssDocument e) RssCategory-channelCategoriesL inj a@RssDocument { channelCategories = c } = (\x -> a { channelCategories = c }) <$> traverse inj c-{-# INLINE channelCategoriesL #-}--channelExtensionL :: SingI a => RElem a e (RIndex a e) => Lens' (RssDocument e) (RssChannelExtension a)-channelExtensionL = channelExtensionsL . f . rlens sing where-  f inj (RssChannelExtensions a) = RssChannelExtensions <$> inj a-{-# INLINE channelExtensionL #-}

@@ -1,318 +0,0 @@-{-# 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:------ > <?xml version="1.0"?>--- > <rss version="2.0">--- >    <channel>--- >       <title>Liftoff News</title>--- >       <link>http://liftoff.msfc.nasa.gov/</link>--- >       <description>Liftoff to Space Exploration.</description>--- >       <language>en-us</language>--- >       <pubDate>Tue, 10 Jun 2003 04:00:00 GMT</pubDate>--- >       <lastBuildDate>Tue, 10 Jun 2003 09:41:01 GMT</lastBuildDate>--- >       <docs>http://blogs.law.harvard.edu/tech/rss</docs>--- >       <generator>Weblog Editor 2.0</generator>--- >       <managingEditor>editor@example.com</managingEditor>--- >       <webMaster>webmaster@example.com</webMaster>--- >       <item>--- >          <title>Star City</title>--- >          <link>http://liftoff.msfc.nasa.gov/news/2003/news-starcity.asp</link>--- >          <description>How do Americans get ready to work with Russians aboard the International Space Station? They take a crash course in culture, language and protocol at Russia's &lt;a href="http://howe.iki.rssi.ru/GCTC/gctc_e.htm"&gt;Star City&lt;/a&gt;.</description>--- >          <pubDate>Tue, 03 Jun 2003 09:39:21 GMT</pubDate>--- >          <guid>http://liftoff.msfc.nasa.gov/2003/06/03.html#item573</guid>--- >       </item>--- >    </channel>--- > </rss>-module Text.RSS.Types where---- {{{ Imports-import           Control.Exception.Safe-import           Data.Semigroup-import           Data.Set-import           Data.Singletons.Prelude.List-import           Data.Text                    hiding (map)-import           Data.Time.Clock-import           Data.Time.LocalTime          ()-import           Data.Version-import           Data.Vinyl.Core-import           GHC.Generics                 hiding ((:+:))-import           Text.Read-import           URI.ByteString--- }}}---- * RSS core--data RssException = InvalidBool Text-                  | InvalidDay Text-                  | InvalidHour Int-                  | InvalidInt Text-                  | InvalidURI URIParseError-                  | InvalidVersion Text-                  | InvalidProtocol Text-                  | InvalidTime Text-                  | MissingElement Text--deriving instance Eq RssException-deriving instance Generic RssException-deriving instance Read RssException-deriving instance Show RssException--instance Exception RssException where-  displayException (InvalidBool t) = "Invalid bool: " ++ unpack t-  displayException (InvalidDay t) = "Invalid day: " ++ unpack t-  displayException (InvalidHour i) = "Invalid hour: " ++ show i-  displayException (InvalidInt t) = "Invalid int: " ++ unpack t-  displayException (InvalidURI t) = "Invalid URI reference: " ++ show t-  displayException (InvalidVersion t) = "Invalid version: " ++ unpack t-  displayException (InvalidProtocol t) = "Invalid Protocol: expected \"xml-rpc\", \"soap\" or \"http-post\", got \"" ++ unpack t ++ "\""-  displayException (InvalidTime t) = "Invalid time: " ++ unpack t-  displayException (MissingElement t) = "Missing element: " ++ unpack t---data RssURI = forall a . RssURI (URIRef a)--instance Eq RssURI where-  RssURI a@URI{} == RssURI b@URI{} = a == b-  RssURI a@RelativeRef{} == RssURI b@RelativeRef{} = a == b-  _ == _ = False--instance Ord RssURI where-  RssURI a@URI{} `compare` RssURI b@URI{} = a `compare` b-  RssURI a@RelativeRef{} `compare` RssURI b@RelativeRef{} = a `compare` b-  RssURI a@RelativeRef{} `compare` RssURI b@URI{} = LT-  _ `compare` _ = GT--instance Show RssURI where-  show (RssURI a@URI{})         = show a-  show (RssURI a@RelativeRef{}) = show a--withRssURI :: (forall a . URIRef a -> b) -> RssURI -> b-withRssURI f (RssURI a) = f a----- | The @\<category\>@ element.-data RssCategory = RssCategory-  { categoryDomain :: Text-  , categoryName   :: Text-  }--deriving instance Eq RssCategory-deriving instance Generic RssCategory-deriving instance Ord RssCategory-deriving instance Show RssCategory----- | The @\<enclosure\>@ element.-data RssEnclosure = RssEnclosure-  { enclosureUrl    :: RssURI-  , enclosureLength :: Int-  , enclosureType   :: Text-  }--deriving instance Eq RssEnclosure-deriving instance Generic RssEnclosure-deriving instance Ord RssEnclosure-deriving instance Show RssEnclosure----- | The @\<source\>@ element.-data RssSource = RssSource-  { sourceUrl  :: RssURI-  , sourceName :: Text-  }--deriving instance Eq RssSource-deriving instance Generic RssSource-deriving instance Ord RssSource-deriving instance Show RssSource----- | The @\<guid\>@ element.-data RssGuid = GuidText Text | GuidUri RssURI-  deriving(Eq, Generic, Ord, Show)----- | The @\<item\>@ element.------ This type is open to extensions.-data RssItem (extensions :: [*]) = RssItem-  { itemTitle       :: Text-  , itemLink        :: Maybe RssURI-  , itemDescription :: Text-  , itemAuthor      :: Text-  , itemCategories  :: [RssCategory]-  , itemComments    :: Maybe RssURI-  , itemEnclosure   :: [RssEnclosure]-  , itemGuid        :: Maybe RssGuid-  , itemPubDate     :: Maybe UTCTime-  , itemSource      :: Maybe RssSource-  , itemExtensions  :: RssItemExtensions extensions-  }--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-  { textInputTitle       :: Text-  , textInputDescription :: Text-  , textInputName        :: Text-  , textInputLink        :: RssURI-  }--deriving instance Eq RssTextInput-deriving instance Generic RssTextInput-deriving instance Ord RssTextInput-deriving instance Show RssTextInput--data CloudProtocol = ProtocolXmlRpc | ProtocolSoap | ProtocolHttpPost-  deriving(Eq, Generic, Ord, Read, Show)---- | The @\<cloud\>@ element.-data RssCloud = RssCloud-  { cloudUri               :: RssURI-  , cloudRegisterProcedure :: Text-  , cloudProtocol          :: CloudProtocol-  }--deriving instance Eq RssCloud-deriving instance Generic RssCloud-deriving instance Ord RssCloud-deriving instance Show RssCloud---- | The @\<image\>@ element.-data RssImage = RssImage-  { imageUri         :: RssURI-  , imageTitle       :: Text-  , imageLink        :: RssURI-  , imageWidth       :: Maybe Int-  , imageHeight      :: Maybe Int-  , imageDescription :: Text-  }--deriving instance Eq RssImage-deriving instance Generic RssImage-deriving instance Ord RssImage-deriving instance Show RssImage---newtype Hour = Hour Int-  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-  | i >= 0 && i < 24 = return $ Hour i-  | otherwise = throwM $ InvalidHour i--data Day = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday-  deriving(Bounded, Enum, Eq, Generic, Ord, Read, Show)---- | Basic parser for 'Day'.-asDay :: MonadThrow m => Text -> m Day-asDay t = maybe (throwM $ InvalidDay t) return . readMaybe $ unpack t---- | The @\<rss\>@ element.------ This type is open to extensions.-data RssDocument (extensions :: [*]) = RssDocument-  { documentVersion       :: Version-  , channelTitle          :: Text-  , channelLink           :: RssURI-  , channelDescription    :: Text-  , channelItems          :: [RssItem extensions]-  , channelLanguage       :: Text-  , channelCopyright      :: Text-  , channelManagingEditor :: Text-  , channelWebmaster      :: Text-  , channelPubDate        :: Maybe UTCTime-  , channelLastBuildDate  :: Maybe UTCTime-  , channelCategories     :: [RssCategory]-  , channelGenerator      :: Text-  , channelDocs           :: Maybe RssURI-  , channelCloud          :: Maybe RssCloud-  , channelTtl            :: Maybe Int-  , channelImage          :: Maybe RssImage-  , channelRating         :: Text-  , channelTextInput      :: Maybe RssTextInput-  , channelSkipHours      :: Set Hour-  , channelSkipDays       :: Set Day-  , channelExtensions     :: RssChannelExtensions extensions-  }--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 (Read (Rec RssChannelExtension a)) => Read (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 (Read (Rec RssItemExtension a)) => Read (RssItemExtensions a)-deriving instance (Show (Rec RssItemExtension a)) => Show (RssItemExtensions a)

@@ -1,270 +0,0 @@-{-# 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-    rss1Document-    -- * Elements-  , rss1ChannelItems-  , rss1Image-  , rss1Item-  , rss1TextInput-  ) where---- {{{ Imports-import           Text.RSS.Extensions-import           Text.RSS.Types--import           Conduit                 hiding (throwM)-import           Control.Exception.Safe  as Exception-import           Control.Monad-import           Control.Monad.Fix-import           Data.Conduit-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--- }}}---- {{{ Util-asDate :: (MonadThrow m) => Text -> m UTCTime-asDate text = maybe (throw $ InvalidTime text) (return . zonedTimeToUTC) $ parseTimeRFC3339 text--asRssURI :: (MonadThrow m) => Text -> m RssURI-asRssURI t = case (parseURI' t, parseRelativeRef' t) of-  (Right u, _) -> return $ RssURI u-  (_, Right u) -> return $ RssURI u-  (_, Left e)  -> throwM $ InvalidURI e-  where parseURI' = parseURI laxURIParserOptions . encodeUtf8-        parseRelativeRef' = parseRelativeRef laxURIParserOptions . encodeUtf8--nullURI :: RssURI-nullURI = RssURI $ RelativeRef Nothing "" (Query []) Nothing--headRequiredC :: MonadThrow m => Text -> Consumer a m a-headRequiredC e = maybe (throw $ MissingElement e) return =<< headC--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 ()---contentTag :: MonadThrow m => Text -> AttrParser a -> (a -> ConduitM Event o m b) -> ConduitM Event o m (Maybe b)-contentTag string = tag' (matching (== contentName string))--dcTag :: MonadThrow m => Text -> AttrParser a -> (a -> ConduitM Event o m b) -> ConduitM Event o m (Maybe b)-dcTag string = tag' (matching (== dcName string))--rdfTag :: MonadThrow m => Text -> AttrParser a -> (a -> ConduitM Event o m b) -> ConduitM Event o m (Maybe b)-rdfTag string = tag' (matching (== rdfName string))--rss1Tag :: MonadThrow m => Text -> AttrParser a -> (a -> ConduitM Event o m b) -> ConduitM Event o m (Maybe b)-rss1Tag string = tag' (matching (== rss1Name string))--contentName :: Text -> Name-contentName string = Name string (Just "http://purl.org/rss/1.0/modules/content/") (Just "content")--dcName :: Text -> Name-dcName string = Name string (Just "http://purl.org/dc/elements/1.1/") (Just "dc")--rdfName :: Text -> Name-rdfName string = Name string (Just "http://www.w3.org/1999/02/22-rdf-syntax-ns#") (Just "rdf")--rss1Name :: Text -> Name-rss1Name string = Name string (Just "http://purl.org/rss/1.0/") Nothing--- }}}---data TextInputPiece = TextInputTitle Text | TextInputDescription Text-                    | TextInputName Text | TextInputLink RssURI--makeTraversals ''TextInputPiece---- | Parse a @\<textinput\>@ element.-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")-    <*> ZipConduit (projectC _TextInputDescription =$= headRequiredC "Missing <description> element")-    <*> ZipConduit (projectC _TextInputName =$= headRequiredC "Missing <name> element")-    <*> ZipConduit (projectC _TextInputLink =$= headDefC uri)  -- Lenient-  piece = [ fmap TextInputTitle <$> rss1Tag "title" ignoreAttrs (const content)-          , fmap TextInputDescription <$> rss1Tag "description" ignoreAttrs (const content)-          , fmap TextInputName <$> rss1Tag "name" ignoreAttrs (const content)-          , fmap TextInputLink <$> rss1Tag "link" ignoreAttrs (const $ content >>= asRssURI)-          ]-  attributes = (requireAttr (rdfName "about") >>= asRssURI) <* ignoreAttrs---data ItemPiece = ItemTitle Text | ItemLink RssURI | ItemDescription Text | ItemCreator Text-               | ItemDate UTCTime | ItemContent Text | ItemOther (NonEmpty Event)--makeTraversals ''ItemPiece---- | Parse an @\<item\>@ element.------ RSS extensions are automatically parsed based on the inferred 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)-    <*> (Just <$> ZipConduit (projectC _ItemLink =$= headDefC uri))-    <*> ZipConduit (projectC _ItemDescription =$= headDefC mempty)-    <*> ZipConduit (projectC _ItemCreator =$= headDefC mempty)-    <*> pure mempty-    <*> pure mzero-    <*> pure mempty-    <*> 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---data ImagePiece = ImageUri RssURI | ImageTitle Text | ImageLink RssURI--makeTraversals ''ImagePiece---- | Parse an @\<image\>@ element.-rss1Image :: (MonadThrow m) => ConduitM Event o m (Maybe RssImage)-rss1Image = rss1Tag "image" attributes $ \uri -> (manyYield' (choose piece) =$= parser uri) <* many ignoreAnyTreeContent where-  parser uri = getZipConduit $ RssImage-    <$> ZipConduit (projectC _ImageUri =$= headDefC uri)  -- Lenient-    <*> ZipConduit (projectC _ImageTitle =$= headDefC "Unnamed image")  -- Lenient-    <*> ZipConduit (projectC _ImageLink =$= headDefC nullURI)  -- Lenient-    <*> pure mzero-    <*> pure mzero-    <*> pure mempty-  piece = [ fmap ImageUri <$> rss1Tag "url" ignoreAttrs (const $ content >>= asRssURI)-          , fmap ImageTitle <$> rss1Tag "title" ignoreAttrs (const content)-          , fmap ImageLink <$> rss1Tag "link" ignoreAttrs (const $ content >>= asRssURI)-          ]-  attributes = (requireAttr (rdfName "about") >>= asRssURI) <* ignoreAttrs----- | Parse an @\<items\>@ element.-rss1ChannelItems :: MonadThrow m => ConduitM Event o m (Maybe [Text])-rss1ChannelItems = fmap join $ rss1Tag "items" ignoreAttrs $ const $ rdfTag "Seq" ignoreAttrs $ const $ many $ rdfTag "li" attributes return where-  attributes = requireAttr (rdfName "resource") <* ignoreAttrs---data Rss1Channel (extensions :: [*]) = Rss1Channel-  { channelId'          :: RssURI-  , channelTitle'       :: Text-  , channelLink'        :: RssURI-  , channelDescription' :: Text-  , channelItems'       :: [Text]-  , channelImage'       :: Maybe RssImage-  , channelTextInput'   :: Maybe RssURI-  , channelExtensions'  :: RssChannelExtensions extensions-  }--data ChannelPiece = ChannelTitle Text-  | ChannelLink RssURI-  | ChannelDescription Text-  | ChannelImage RssImage-  | ChannelItems [Text]-  | ChannelTextInput RssURI-  | ChannelOther (NonEmpty Event)--makeTraversals ''ChannelPiece----- | Parse a @\<channel\>@ element.------ RSS extensions are automatically parsed based on the inferred 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")-    <*> ZipConduit (projectC _ChannelLink =$= headRequiredC "Missing <link> element")-    <*> ZipConduit (projectC _ChannelDescription =$= headDefC "")  -- Lenient-    <*> 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 (e :: [*]) = Rss1Document (Rss1Channel e) (Maybe RssImage) [RssItem e] (Maybe RssTextInput)--rss1ToRss2 :: Rss1Document e -> RssDocument e-rss1ToRss2 (Rss1Document channel image items textInput) = RssDocument-  (Version [1] [])-  (channelTitle' channel)-  (channelLink' channel)-  (channelDescription' channel)-  items-  mempty-  mempty-  mempty-  mempty-  mzero-  mzero-  mzero-  mempty-  mzero-  mzero-  mzero-  image-  mempty-  textInput-  mempty-  mempty-  (channelExtensions' channel)--data DocumentPiece (e :: [*]) = DocumentChannel (Rss1Channel e)-  | DocumentImage RssImage-  | DocumentItem (RssItem e)-  | DocumentTextInput RssTextInput--makeTraversals ''DocumentPiece----- | Parse an @\<RDF\>@ element.------ RSS extensions are automatically parsed based on the inferred 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")-    <*> ZipConduit (projectC _DocumentImage =$= headC)-    <*> ZipConduit (projectC _DocumentItem =$= sinkList)-    <*> ZipConduit (projectC _DocumentTextInput =$= headC)-  piece = [ fmap DocumentChannel <$> rss1Channel-          , fmap DocumentImage <$> rss1Image-          , fmap DocumentItem <$> rss1Item-          , fmap DocumentTextInput <$> rss1TextInput-          ]

@@ -1,5 +1,5 @@ name: rss-conduit-version: 0.4.2.0+version: 0.4.2.1 cabal-version: >=1.10 build-type: Simple license: PublicDomain@@ -17,8 +17,12 @@     type: git     location: git://github.com/k0ral/rss-conduit.git -library+flag enable-hlint-test+  description: Enable hlint test-suite+  manual: True+  default: False +library     if impl(ghc <8)         build-depends:             semigroups -any@@ -53,6 +57,7 @@         xml-conduit >=1.5,         xml-types -any     default-language: Haskell2010+    hs-source-dirs: src  test-suite  Tests     type: exitcode-stdio-1.0@@ -67,7 +72,6 @@         conduit-combinators -any,         data-default -any,         dublincore-xml-conduit -any,-        hlint -any,         lens-simple -any,         mono-traversable -any,         QuickCheck -any,@@ -88,3 +92,16 @@     hs-source-dirs: test     other-modules:         Arbitrary++test-suite hlint+    if flag(enable-hlint-test)+      buildable: True+    else+      buildable: False+    type: exitcode-stdio-1.0+    main-is: HLint.hs+    build-depends:+        base >=4.8,+        hlint -any+    default-language: Haskell2010+    hs-source-dirs: test

@@ -0,0 +1,295 @@+{-# 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+    rssDocument+    -- * Elements+  , rssCategory+  , rssCloud+  , rssEnclosure+  , rssGuid+  , rssImage+  , rssItem+  , rssSkipDays+  , rssSkipHours+  , rssSource+  , rssTextInput+  ) 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                (void)+import           Control.Monad.Fix+import           Data.Conduit+import           Data.List.NonEmpty           (NonEmpty (..), nonEmpty)+import           Data.Maybe+import           Data.Monoid+import           Data.Set                     (Set, fromList)+import           Data.Text                    as Text+import           Data.Text.Encoding+import           Data.Time.Clock+import           Data.Time.LocalTime+import           Data.Time.RFC822+import           Data.Version+import           Data.XML.Types+import           Lens.Simple+import           Safe+import           Text.ParserCombinators.ReadP (readP_to_S)+import           Text.Read                    (readMaybe)+import           Text.XML.Stream.Parse+import           URI.ByteString+-- }}}++-- {{{ Util+asRssURI :: MonadThrow m => Text -> m RssURI+asRssURI t = case (parseURI' t, parseRelativeRef' t) of+  (Right u, _) -> return $ RssURI u+  (_, Right u) -> return $ RssURI u+  (_, Left e)  -> throwM $ InvalidURI e+  where parseURI' = parseURI laxURIParserOptions . encodeUtf8+        parseRelativeRef' = parseRelativeRef laxURIParserOptions . encodeUtf8++nullURI :: RssURI+nullURI = RssURI $ RelativeRef Nothing "" (Query []) Nothing++asInt :: MonadThrow m => Text -> m Int+asInt t = maybe (throwM $ InvalidInt t) return . readMaybe $ unpack t++asBool :: MonadThrow m => Text -> m Bool+asBool "true"  = return True+asBool "false" = return False+asBool t       = throwM $ InvalidBool t++asVersion :: MonadThrow m => Text -> m Version+asVersion t = maybe (throwM $ InvalidVersion t) return . fmap fst . headMay . readP_to_S parseVersion $ unpack t++asCloudProtocol :: MonadThrow m => Text -> m CloudProtocol+asCloudProtocol "xml-rpc"   = return ProtocolXmlRpc+asCloudProtocol "soap"      = return ProtocolSoap+asCloudProtocol "http-post" = return ProtocolHttpPost+asCloudProtocol t           = throwM $ InvalidProtocol t++-- | Like 'tagName' but ignores the namespace.+tagName' :: (MonadThrow m) => Text -> AttrParser a -> (a -> ConduitM Event o m b) -> ConduitM Event o m (Maybe b)+tagName' t = tag' (matching $ \n -> nameLocalName n == t)++-- | Tag which content is a date-time that follows RFC 3339 format.+tagDate :: (MonadThrow m) => NameMatcher a -> ConduitM Event o m (Maybe UTCTime)+tagDate name = tagIgnoreAttrs name $ fmap zonedTimeToUTC $ do+  text <- content+  maybe (throw $ InvalidTime text) return $ parseTimeRFC822 text++headRequiredC :: MonadThrow m => Text -> Consumer a m a+headRequiredC e = maybe (throw $ MissingElement e) return =<< headC++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 ()+-- }}}+++-- | Parse a @\<skipHours\>@ element.+rssSkipHours :: MonadThrow m => ConduitM Event o m (Maybe (Set Hour))+rssSkipHours = tagIgnoreAttrs "skipHours" $+  fromList <$> (manyYield' (tagIgnoreAttrs "hour" $ content >>= asInt >>= asHour) =$= sinkList)++-- | Parse a @\<skipDays\>@ element.+rssSkipDays :: MonadThrow m => ConduitM Event o m (Maybe (Set Day))+rssSkipDays = tagIgnoreAttrs "skipDays" $+  fromList <$> (manyYield' (tagIgnoreAttrs "day" $ content >>= asDay) =$= sinkList)+++data TextInputPiece = TextInputTitle Text | TextInputDescription Text+                    | TextInputName Text | TextInputLink RssURI++makeTraversals ''TextInputPiece++-- | Parse a @\<textInput\>@ element.+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")+    <*> ZipConduit (projectC _TextInputDescription =$= headRequiredC "Missing <description> element")+    <*> ZipConduit (projectC _TextInputName =$= headRequiredC "Missing <name> element")+    <*> ZipConduit (projectC _TextInputLink =$= headRequiredC "Missing <link> element")+  piece = [ fmap TextInputTitle <$> tagIgnoreAttrs "title" content+          , fmap TextInputDescription <$> tagIgnoreAttrs "description" content+          , fmap TextInputName <$> tagIgnoreAttrs "name" content+          , fmap TextInputLink <$> tagIgnoreAttrs "link" (content >>= asRssURI)+          ]++++data ImagePiece = ImageUri RssURI | ImageTitle Text | ImageLink RssURI | ImageWidth Int+                | ImageHeight Int | ImageDescription Text++makeTraversals ''ImagePiece++-- | Parse an @\<image\>@ element.+rssImage :: (MonadThrow m) => ConduitM Event o m (Maybe RssImage)+rssImage = tagIgnoreAttrs "image" $ (manyYield' (choose piece) =$= parser) <* many ignoreAnyTreeContent where+  parser = getZipConduit $ RssImage+    <$> ZipConduit (projectC _ImageUri =$= headRequiredC "Missing <url> element")+    <*> ZipConduit (projectC _ImageTitle =$= headDefC "Unnamed image")  -- Lenient+    <*> ZipConduit (projectC _ImageLink =$= headDefC nullURI)  -- Lenient+    <*> ZipConduit (projectC _ImageWidth =$= headC)+    <*> ZipConduit (projectC _ImageHeight =$= headC)+    <*> ZipConduit (projectC _ImageDescription =$= headDefC "")+  piece = [ fmap ImageUri <$> tagIgnoreAttrs "url" (content >>= asRssURI)+          , fmap ImageTitle <$> tagIgnoreAttrs "title" content+          , fmap ImageLink <$> tagIgnoreAttrs "link" (content >>= asRssURI)+          , fmap ImageWidth <$> tagIgnoreAttrs "width" (content >>= asInt)+          , fmap ImageHeight <$> tagIgnoreAttrs "height" (content >>= asInt)+          , fmap ImageDescription <$> tagIgnoreAttrs "description" content+          ]++-- | Parse a @\<category\>@ element.+rssCategory :: MonadThrow m => ConduitM Event o m (Maybe RssCategory)+rssCategory = tagName' "category" (optional (requireAttr "domain") <* ignoreAttrs) $ \domain ->+  RssCategory (fromMaybe "" domain) <$> content++-- | Parse a @\<cloud\>@ element.+rssCloud :: (MonadThrow m) => ConduitM Event o m (Maybe RssCloud)+rssCloud = tagName' "cloud" attributes return where+  attributes = do+    uri <- fmap RssURI $ RelativeRef+      <$> fmap Just (Authority Nothing <$> (Host . encodeUtf8 <$> requireAttr "domain") <*> (fmap Port <$> optional (requireAttr "port" >>= asInt)))+      <*> (encodeUtf8 <$> requireAttr "path")+      <*> pure (Query [])+      <*> pure Nothing+    RssCloud uri <$> requireAttr "registerProcedure" <*> (requireAttr "protocol" >>= asCloudProtocol) <* ignoreAttrs++-- | Parse a @\<guid\>@ element.+rssGuid :: MonadThrow m => ConduitM Event o m (Maybe RssGuid)+rssGuid = tagName' "guid" attributes handler where+  attributes = optional (requireAttr "isPermaLink" >>= asBool) <* ignoreAttrs+  handler (Just True) = GuidUri <$> (content >>= asRssURI)+  handler _           = GuidText <$> content++-- | Parse an @\<enclosure\>@ element.+rssEnclosure :: MonadThrow m => ConduitM Event o m (Maybe RssEnclosure)+rssEnclosure = tagName' "enclosure" attributes handler where+  attributes = (,,) <$> (requireAttr "url" >>= asRssURI) <*> (requireAttr "length" >>= asInt) <*> requireAttr "type" <* ignoreAttrs+  handler (uri, length_, type_) = return $ RssEnclosure uri length_ type_++-- | Parse a @\<source\>@ element.+rssSource :: MonadThrow m => ConduitM Event o m (Maybe RssSource)+rssSource = tagName' "source" attributes handler where+  attributes = (requireAttr "url" >>= asRssURI) <* ignoreAttrs+  handler uri = RssSource uri <$> content+++data ItemPiece = ItemTitle Text | ItemLink RssURI | ItemDescription Text+               | ItemAuthor Text | ItemCategory RssCategory | ItemComments RssURI+               | ItemEnclosure RssEnclosure | ItemGuid RssGuid | ItemPubDate UTCTime+               | ItemSource RssSource | ItemOther (NonEmpty Event)++makeTraversals ''ItemPiece++-- | Parse an @\<item\>@ element.+--+-- RSS extensions are automatically parsed based on the inferred 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 "")+    <*> ZipConduit (projectC _ItemLink =$= headC)+    <*> ZipConduit (projectC _ItemDescription =$= headDefC "")+    <*> ZipConduit (projectC _ItemAuthor =$= headDefC "")+    <*> ZipConduit (projectC _ItemCategory =$= sinkList)+    <*> ZipConduit (projectC _ItemComments =$= headC)+    <*> ZipConduit (projectC _ItemEnclosure =$= sinkList)+    <*> 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+          , fmap ItemAuthor <$> tagIgnoreAttrs "author" content+          , fmap ItemCategory <$> rssCategory+          , fmap ItemComments <$> tagIgnoreAttrs "comments" (content >>= asRssURI)+          , fmap ItemEnclosure <$> rssEnclosure+          , fmap ItemGuid <$> rssGuid+          , fmap ItemPubDate <$> tagDate "pubDate"+          , fmap ItemSource <$> rssSource+          , fmap ItemOther . nonEmpty <$> (void takeAnyTreeContent =$= sinkList)+          ]+++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.+--+-- RSS extensions are automatically parsed based on the inferred 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")+    <*> ZipConduit (projectC _ChannelLink =$= headRequiredC "Missing <link> element")+    <*> ZipConduit (projectC _ChannelDescription =$= headDefC "")  -- Lenient+    <*> ZipConduit (projectC _ChannelItem =$= sinkList)+    <*> ZipConduit (projectC _ChannelLanguage =$= headDefC "")+    <*> ZipConduit (projectC _ChannelCopyright =$= headDefC "")+    <*> ZipConduit (projectC _ChannelManagingEditor =$= headDefC "")+    <*> ZipConduit (projectC _ChannelWebmaster =$= headDefC "")+    <*> ZipConduit (projectC _ChannelPubDate =$= headC)+    <*> ZipConduit (projectC _ChannelLastBuildDate =$= headC)+    <*> ZipConduit (projectC _ChannelCategory =$= sinkList)+    <*> ZipConduit (projectC _ChannelGenerator =$= headDefC "")+    <*> ZipConduit (projectC _ChannelDocs =$= headC)+    <*> ZipConduit (projectC _ChannelCloud =$= headC)+    <*> ZipConduit (projectC _ChannelTtl =$= headC)+    <*> ZipConduit (projectC _ChannelImage =$= headC)+    <*> ZipConduit (projectC _ChannelRating =$= headDefC "")+    <*> 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+          , fmap ChannelItem <$> rssItem+          , fmap ChannelLanguage <$> tagIgnoreAttrs "language" content+          , fmap ChannelCopyright <$> tagIgnoreAttrs "copyright" content+          , fmap ChannelManagingEditor <$> tagIgnoreAttrs "managingEditor" content+          , fmap ChannelWebmaster <$> tagIgnoreAttrs "webMaster" content+          , fmap ChannelPubDate <$> tagDate "pubDate"+          , fmap ChannelLastBuildDate <$> tagDate "lastBuildDate"+          , fmap ChannelCategory <$> rssCategory+          , fmap ChannelGenerator <$> tagIgnoreAttrs "generator" content+          , fmap ChannelDocs <$> tagIgnoreAttrs "docs" (content >>= asRssURI)+          , fmap ChannelCloud <$> rssCloud+          , fmap ChannelTtl <$> tagIgnoreAttrs "ttl" (content >>= asInt)+          , fmap ChannelImage <$> rssImage+          , fmap ChannelRating <$> tagIgnoreAttrs "rating" content+          , 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

@@ -0,0 +1,172 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Streaming renderers for the RSS 2.0 standard.+module Text.RSS.Conduit.Render+  ( -- * Top-level+    renderRssDocument+    -- * Elements+  , renderRssItem+  , renderRssSource+  , renderRssEnclosure+  , renderRssGuid+  , renderRssCloud+  , renderRssCategory+  , renderRssImage+  , renderRssTextInput+  , renderRssSkipDays+  , renderRssSkipHours+  ) where++-- {{{ Imports+import           Text.RSS.Extensions+import           Text.RSS.Lens+import           Text.RSS.Types++import           Control.Monad+import           Data.Conduit+import           Data.Monoid+import           Data.Set               (Set)+import qualified Data.Set               as Set+import           Data.Text              as Text hiding (map)+import           Data.Text.Encoding+import           Data.Time.Clock+import           Data.Time.LocalTime+import           Data.Time.RFC822+import           Data.Version+import           Data.XML.Types+import           Lens.Simple+import           Safe+import           Text.XML.Stream.Render+import           URI.ByteString+-- }}}++-- | Render the top-level @\<rss\>@ element.+renderRssDocument :: Monad m => 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+    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+    renderRssChannelExtensions $ d^.channelExtensionsL++-- | Render an @\<item\>@ element.+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+  optionalTextTag "description" $ i^.itemDescriptionL+  optionalTextTag "author" $ i^.itemAuthorL+  forM_ (i^..itemCategoriesL) renderRssCategory+  forM_ (i^.itemCommentsL) $ textTag "comments" . renderRssURI+  forM_ (i^..itemEnclosureL) renderRssEnclosure+  forM_ (i^.itemGuidL) renderRssGuid+  forM_ (i^.itemPubDateL) $ dateTag "pubDate"+  forM_ (i^.itemSourceL) renderRssSource+  renderRssItemExtensions $ i^.itemExtensionsL++-- | Render a @\<source\>@ element.+renderRssSource :: (Monad m) => RssSource -> Source m Event+renderRssSource s = tag "source" (attr "url" $ renderRssURI $ s^.sourceUrlL) . content $ s^.sourceNameL++-- | Render an @\<enclosure\>@ element.+renderRssEnclosure :: (Monad m) => RssEnclosure -> Source m Event+renderRssEnclosure e = tag "enclosure" attributes mempty where+  attributes = attr "url" (renderRssURI $ e^.enclosureUrlL)+    <> attr "length" (tshow $ e^.enclosureLengthL)+    <> attr "type" (e^.enclosureTypeL)++-- | Render a @\<guid\>@ element.+renderRssGuid :: (Monad m) => RssGuid -> Source m Event+renderRssGuid (GuidUri u) = tag "guid" (attr "isPermaLink" "true") $ content $ renderRssURI u+renderRssGuid (GuidText t) = tag "guid" mempty $ content t+++-- | Render a @\<cloud\>@ element.+renderRssCloud :: Monad m => RssCloud -> Source m Event+renderRssCloud c = tag "cloud" attributes $ return () where+  attributes = attr "domain" domain+    <> optionalAttr "port" port+    <> attr "path" (path <> query <> fragment)+    <> attr "registerProcedure" (c^.cloudRegisterProcedureL)+    <> attr "protocol" (describe $ c^.cloudProtocolL)++  renderUserInfo (Just (UserInfo a b)) = decodeUtf8 a <> ":" <> decodeUtf8 b <> "@"+  renderUserInfo _ = ""+  renderHost (Host h) = decodeUtf8 h+  renderQuery (Query query) = case intercalate "&" $ map (\(a,b) -> decodeUtf8 a <> "=" <> decodeUtf8 b) query of+    "" -> ""+    x  -> "?" <> x++  domain = maybe "" (\a -> renderUserInfo (authorityUserInfo a) <> renderHost (authorityHost a)) $ withRssURI (view authorityL) $ c^.cloudUriL+  port = fmap (pack . show . portNumber) $ authorityPort =<< withRssURI (view authorityL) (c^.cloudUriL)+  path = decodeUtf8 $ withRssURI (view pathL) $ c^.cloudUriL+  query = renderQuery $ withRssURI (view queryL) $ c^.cloudUriL+  fragment = maybe "" decodeUtf8 $ withRssURI (view fragmentL) $ c^.cloudUriL++  describe ProtocolXmlRpc   = "xml-rpc"+  describe ProtocolSoap     = "soap"+  describe ProtocolHttpPost = "http-post"++-- | Render a @\<category\>@ element.+renderRssCategory :: (Monad m) => RssCategory -> Source m Event+renderRssCategory c = tag "category" (attr "domain" $ c^.categoryDomainL) . content $ c^.categoryNameL++-- | Render an @\<image\>@ element.+renderRssImage :: (Monad m) => RssImage -> Source m Event+renderRssImage i = tag "image" mempty $ do+  textTag "url" $ renderRssURI $ i^.imageUriL+  textTag "title" $ i^.imageTitleL+  textTag "link" $ renderRssURI $ i^.imageLinkL+  forM_ (i^.imageHeightL) $ textTag "height" . tshow+  forM_ (i^.imageWidthL) $ textTag "width" . tshow+  optionalTextTag "description" $ i^.imageDescriptionL++-- | Render a @\<textInput\>@ element.+renderRssTextInput :: (Monad m) => RssTextInput -> Source m Event+renderRssTextInput t = tag "textInput" mempty $ do+  textTag "title" $ t^.textInputTitleL+  textTag "description" $ t^.textInputDescriptionL+  textTag "name" $ t^.textInputNameL+  textTag "link" $ renderRssURI $ t^.textInputLinkL++-- | Render a @\<skipDays\>@ element.+renderRssSkipDays :: (Monad m) => Set Day -> Source m Event+renderRssSkipDays s = unless (Set.null s) $ tag "skipDays" mempty $ forM_ s $ textTag "day" . tshow++-- | Render a @\<skipHours\>@ element.+renderRssSkipHours :: (Monad m) => Set Hour -> Source m Event+renderRssSkipHours s = unless (Set.null s) $ tag "skipHour" mempty $ forM_ s $ textTag "hour" . tshow+++-- {{{ Utils+tshow :: Show a => a -> Text+tshow = pack . show++textTag :: (Monad m) => Name -> Text -> Source m Event+textTag name = tag name mempty . content++optionalTextTag :: Monad m => Name -> Text -> Source m Event+optionalTextTag name value = unless (Text.null value) $ textTag name value++dateTag :: (Monad m) => Name -> UTCTime -> Source m Event+dateTag name = tag name mempty . content . formatTimeRFC822 . utcToZonedTime utc++renderRssURI :: RssURI -> Text+renderRssURI = decodeUtf8 . withRssURI serializeURIRef'+-- }}}

@@ -0,0 +1,95 @@+{-# 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/>.+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+-- }}}++-- * Parsing++-- | 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)+++-- * Rendering++-- | Class of RSS extensions that can be rendered.+class RenderRssExtension e where+  -- | Render extension for the @\<channel\>@ element.+  renderRssChannelExtension :: Monad m => RssChannelExtension e -> Source m Event+  -- | Render extension for the @\<item\>@ 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)++-- | Render a set of @\<channel\>@ 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 @\<item\>@ 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)

@@ -0,0 +1,41 @@+{-# 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                  (headC, (=$=))+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+-- }}}++-- | __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)++instance RenderRssExtension AtomModule where+  renderRssChannelExtension = mapM_ renderAtomLink . channelAtomLink+  renderRssItemExtension    = mapM_ renderAtomLink . itemAtomLink++data instance RssChannelExtension AtomModule = AtomChannel { channelAtomLink :: Maybe AtomLink }+  deriving(Eq, Generic, Show)+data instance RssItemExtension AtomModule = AtomItem { itemAtomLink :: Maybe AtomLink }+  deriving(Eq, Generic, Show)

@@ -0,0 +1,80 @@+{-# 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)+    -- * Parser+  , contentEncoded+    -- * Renderer+  , renderContentEncoded+    -- * Misc+  , namespacePrefix+  , namespaceURI+  ) where++-- {{{ Imports+import           Text.RSS.Extensions+import           Text.RSS.Types++import           Conduit                (ConduitM, Source, headDefC, (=$=))+import           Control.Exception.Safe as Exception+import           Control.Monad+import           Data.Maybe+import           Data.Singletons+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+-- }}}++-- | __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)++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 }+  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++-- | Render a @\<content:encoded\>@ element.+renderContentEncoded :: Monad m => Text -> Source m Event+renderContentEncoded = Render.tag (contentName "encoded") mempty . Render.content

@@ -0,0 +1,161 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE KindSignatures    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE RecordWildCards   #-}+{-# 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)+  , channelDcMetaData+  , RssItemExtension(DublinCoreItem)+  , itemDcMetaData+  , DcMetaData(..)+  , mkDcMetaData+  ) where++-- {{{ Imports+import           Text.RSS.Extensions+import           Text.RSS.Types++import           Conduit+import           Control.Exception.Safe             as Exception+import           Control.Monad+import           Control.Monad.Fix+import           Data.Maybe+import           Data.Singletons+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           Text.XML.DublinCore.Conduit.Render+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+          ]++-- | 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 :: *++data instance Sing DublinCoreModule = SDublinCoreModule++instance SingI DublinCoreModule where sing = SDublinCoreModule++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 }+  deriving(Eq, Generic, Ord, Show)+data instance RssItemExtension DublinCoreModule = DublinCoreItem { itemDcMetaData :: DcMetaData }+  deriving(Eq, Generic, Ord, Show)

@@ -0,0 +1,201 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE KindSignatures    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE RecordWildCards   #-}+{-# 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+  , syndicationInfo+  , syndicationPeriod+  , syndicationFrequency+  , syndicationBase+    -- * Renderers+  , renderSyndicationInfo+  , renderSyndicationPeriod+  , renderSyndicationFrequency+  , renderSyndicationBase+    -- * 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           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++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))++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 (Bounded, Enum, Eq, Generic, Ord, Read, 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++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, Read, Show)++-- | Construct an empty 'SyndicationInfo'.+mkSyndicationInfo :: SyndicationInfo+mkSyndicationInfo = SyndicationInfo mzero mzero mzero+++data ElementPiece = ElementPeriod SyndicationPeriod | ElementFrequency Int | ElementBase UTCTime++makeTraversals ''ElementPiece++-- | Parse all __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)++-- | 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 @\<sy:updatePeriod\>@ element.+renderSyndicationPeriod :: Monad m => SyndicationPeriod -> Source m Event+renderSyndicationPeriod = renderSyndicationTag "updatePeriod" . fromSyndicationPeriod++-- | Render a @\<sy:updateFrequency\>@ element.+renderSyndicationFrequency :: Monad m => Int -> Source m Event+renderSyndicationFrequency = renderSyndicationTag "updateFrequency" . tshow++-- | Render a @\<sy:updateBase\>@ element.+renderSyndicationBase :: Monad m => UTCTime -> Source m Event+renderSyndicationBase = renderSyndicationTag "updateBase" . formatTimeRFC822 . utcToZonedTime utc+++-- | __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++instance RenderRssExtension SyndicationModule where+  renderRssChannelExtension = renderSyndicationInfo . channelSyndicationInfo+  renderRssItemExtension    = const $ pure ()+++data instance RssChannelExtension SyndicationModule = SyndicationChannel { channelSyndicationInfo :: SyndicationInfo}+  deriving (Eq, Generic, Ord, Read, Show)+data instance RssItemExtension SyndicationModule = SyndicationItem deriving (Eq, Generic, Ord, Read, Show)

@@ -0,0 +1,61 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell  #-}+module Text.RSS.Lens (module Text.RSS.Lens) where++-- {{{ Imports+import           Text.RSS.Types++import           Data.Singletons.Prelude+import           Data.Vinyl.Lens+import           Data.Vinyl.TypeLevel+import           Lens.Simple+import           URI.ByteString+-- }}}+++$(makeLensesBy (\n -> Just (n ++ "L")) ''RssCategory)+$(makeLensesBy (\n -> Just (n ++ "L")) ''RssEnclosure)+$(makeLensesBy (\n -> Just (n ++ "L")) ''RssSource)++$(makeLensesBy+  (let f "itemCategories" = Nothing+       f "itemEnclosure"  = Nothing+       f n                = Just (n ++ "L")+   in f)+  ''RssItem)++itemCategoriesL :: Traversal' (RssItem e) RssCategory+itemCategoriesL inj a@RssItem { itemCategories = c } = (\x -> a { itemCategories = c }) <$> traverse inj c+{-# INLINE itemCategoriesL #-}++itemEnclosureL :: Traversal' (RssItem e) RssEnclosure+itemEnclosureL inj a@RssItem { itemEnclosure = e } = (\x -> a { itemEnclosure = e }) <$> traverse inj e+{-# INLINE itemEnclosureL #-}++itemExtensionL :: SingI a => RElem a e (RIndex a e) => Lens' (RssItem e) (RssItemExtension a)+itemExtensionL = itemExtensionsL . f . rlens sing where+  f inj (RssItemExtensions a) = RssItemExtensions <$> inj a+{-# INLINE itemExtensionL #-}++$(makeLensesBy (\n -> Just (n ++ "L")) ''RssTextInput)+$(makeLensesBy (\n -> Just (n ++ "L")) ''RssCloud)+$(makeLensesBy (\n -> Just (n ++ "L")) ''RssImage)+$(makeLensesBy+  (let f "channelItems"      = Nothing+       f "channelCategories" = Nothing+       f n                   = Just (n ++ "L")+  in f)+  ''RssDocument)++channelItemsL :: Traversal' (RssDocument e) (RssItem e)+channelItemsL inj a@RssDocument { channelItems = i } = (\x -> a { channelItems = i }) <$> traverse inj i+{-# INLINE channelItemsL #-}++channelCategoriesL :: Traversal' (RssDocument e) RssCategory+channelCategoriesL inj a@RssDocument { channelCategories = c } = (\x -> a { channelCategories = c }) <$> traverse inj c+{-# INLINE channelCategoriesL #-}++channelExtensionL :: SingI a => RElem a e (RIndex a e) => Lens' (RssDocument e) (RssChannelExtension a)+channelExtensionL = channelExtensionsL . f . rlens sing where+  f inj (RssChannelExtensions a) = RssChannelExtensions <$> inj a+{-# INLINE channelExtensionL #-}

@@ -0,0 +1,318 @@+{-# 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:+--+-- > <?xml version="1.0"?>+-- > <rss version="2.0">+-- >    <channel>+-- >       <title>Liftoff News</title>+-- >       <link>http://liftoff.msfc.nasa.gov/</link>+-- >       <description>Liftoff to Space Exploration.</description>+-- >       <language>en-us</language>+-- >       <pubDate>Tue, 10 Jun 2003 04:00:00 GMT</pubDate>+-- >       <lastBuildDate>Tue, 10 Jun 2003 09:41:01 GMT</lastBuildDate>+-- >       <docs>http://blogs.law.harvard.edu/tech/rss</docs>+-- >       <generator>Weblog Editor 2.0</generator>+-- >       <managingEditor>editor@example.com</managingEditor>+-- >       <webMaster>webmaster@example.com</webMaster>+-- >       <item>+-- >          <title>Star City</title>+-- >          <link>http://liftoff.msfc.nasa.gov/news/2003/news-starcity.asp</link>+-- >          <description>How do Americans get ready to work with Russians aboard the International Space Station? They take a crash course in culture, language and protocol at Russia's &lt;a href="http://howe.iki.rssi.ru/GCTC/gctc_e.htm"&gt;Star City&lt;/a&gt;.</description>+-- >          <pubDate>Tue, 03 Jun 2003 09:39:21 GMT</pubDate>+-- >          <guid>http://liftoff.msfc.nasa.gov/2003/06/03.html#item573</guid>+-- >       </item>+-- >    </channel>+-- > </rss>+module Text.RSS.Types where++-- {{{ Imports+import           Control.Exception.Safe+import           Data.Semigroup+import           Data.Set+import           Data.Singletons.Prelude.List+import           Data.Text                    (Text, unpack)+import           Data.Time.Clock+import           Data.Time.LocalTime          ()+import           Data.Version+import           Data.Vinyl.Core+import           GHC.Generics                 hiding ((:+:))+import           Text.Read+import           URI.ByteString+-- }}}++-- * RSS core++data RssException = InvalidBool Text+                  | InvalidDay Text+                  | InvalidHour Int+                  | InvalidInt Text+                  | InvalidURI URIParseError+                  | InvalidVersion Text+                  | InvalidProtocol Text+                  | InvalidTime Text+                  | MissingElement Text++deriving instance Eq RssException+deriving instance Generic RssException+deriving instance Read RssException+deriving instance Show RssException++instance Exception RssException where+  displayException (InvalidBool t) = "Invalid bool: " ++ unpack t+  displayException (InvalidDay t) = "Invalid day: " ++ unpack t+  displayException (InvalidHour i) = "Invalid hour: " ++ show i+  displayException (InvalidInt t) = "Invalid int: " ++ unpack t+  displayException (InvalidURI t) = "Invalid URI reference: " ++ show t+  displayException (InvalidVersion t) = "Invalid version: " ++ unpack t+  displayException (InvalidProtocol t) = "Invalid Protocol: expected \"xml-rpc\", \"soap\" or \"http-post\", got \"" ++ unpack t ++ "\""+  displayException (InvalidTime t) = "Invalid time: " ++ unpack t+  displayException (MissingElement t) = "Missing element: " ++ unpack t+++data RssURI = forall a . RssURI (URIRef a)++instance Eq RssURI where+  RssURI a@URI{} == RssURI b@URI{} = a == b+  RssURI a@RelativeRef{} == RssURI b@RelativeRef{} = a == b+  _ == _ = False++instance Ord RssURI where+  RssURI a@URI{} `compare` RssURI b@URI{} = a `compare` b+  RssURI a@RelativeRef{} `compare` RssURI b@RelativeRef{} = a `compare` b+  RssURI a@RelativeRef{} `compare` RssURI b@URI{} = LT+  _ `compare` _ = GT++instance Show RssURI where+  show (RssURI a@URI{})         = show a+  show (RssURI a@RelativeRef{}) = show a++withRssURI :: (forall a . URIRef a -> b) -> RssURI -> b+withRssURI f (RssURI a) = f a+++-- | The @\<category\>@ element.+data RssCategory = RssCategory+  { categoryDomain :: Text+  , categoryName   :: Text+  }++deriving instance Eq RssCategory+deriving instance Generic RssCategory+deriving instance Ord RssCategory+deriving instance Show RssCategory+++-- | The @\<enclosure\>@ element.+data RssEnclosure = RssEnclosure+  { enclosureUrl    :: RssURI+  , enclosureLength :: Int+  , enclosureType   :: Text+  }++deriving instance Eq RssEnclosure+deriving instance Generic RssEnclosure+deriving instance Ord RssEnclosure+deriving instance Show RssEnclosure+++-- | The @\<source\>@ element.+data RssSource = RssSource+  { sourceUrl  :: RssURI+  , sourceName :: Text+  }++deriving instance Eq RssSource+deriving instance Generic RssSource+deriving instance Ord RssSource+deriving instance Show RssSource+++-- | The @\<guid\>@ element.+data RssGuid = GuidText Text | GuidUri RssURI+  deriving(Eq, Generic, Ord, Show)+++-- | The @\<item\>@ element.+--+-- This type is open to extensions.+data RssItem (extensions :: [*]) = RssItem+  { itemTitle       :: Text+  , itemLink        :: Maybe RssURI+  , itemDescription :: Text+  , itemAuthor      :: Text+  , itemCategories  :: [RssCategory]+  , itemComments    :: Maybe RssURI+  , itemEnclosure   :: [RssEnclosure]+  , itemGuid        :: Maybe RssGuid+  , itemPubDate     :: Maybe UTCTime+  , itemSource      :: Maybe RssSource+  , itemExtensions  :: RssItemExtensions extensions+  }++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+  { textInputTitle       :: Text+  , textInputDescription :: Text+  , textInputName        :: Text+  , textInputLink        :: RssURI+  }++deriving instance Eq RssTextInput+deriving instance Generic RssTextInput+deriving instance Ord RssTextInput+deriving instance Show RssTextInput++data CloudProtocol = ProtocolXmlRpc | ProtocolSoap | ProtocolHttpPost+  deriving(Eq, Generic, Ord, Read, Show)++-- | The @\<cloud\>@ element.+data RssCloud = RssCloud+  { cloudUri               :: RssURI+  , cloudRegisterProcedure :: Text+  , cloudProtocol          :: CloudProtocol+  }++deriving instance Eq RssCloud+deriving instance Generic RssCloud+deriving instance Ord RssCloud+deriving instance Show RssCloud++-- | The @\<image\>@ element.+data RssImage = RssImage+  { imageUri         :: RssURI+  , imageTitle       :: Text+  , imageLink        :: RssURI+  , imageWidth       :: Maybe Int+  , imageHeight      :: Maybe Int+  , imageDescription :: Text+  }++deriving instance Eq RssImage+deriving instance Generic RssImage+deriving instance Ord RssImage+deriving instance Show RssImage+++newtype Hour = Hour Int+  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+  | i >= 0 && i < 24 = return $ Hour i+  | otherwise = throwM $ InvalidHour i++data Day = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday+  deriving(Bounded, Enum, Eq, Generic, Ord, Read, Show)++-- | Basic parser for 'Day'.+asDay :: MonadThrow m => Text -> m Day+asDay t = maybe (throwM $ InvalidDay t) return . readMaybe $ unpack t++-- | The @\<rss\>@ element.+--+-- This type is open to extensions.+data RssDocument (extensions :: [*]) = RssDocument+  { documentVersion       :: Version+  , channelTitle          :: Text+  , channelLink           :: RssURI+  , channelDescription    :: Text+  , channelItems          :: [RssItem extensions]+  , channelLanguage       :: Text+  , channelCopyright      :: Text+  , channelManagingEditor :: Text+  , channelWebmaster      :: Text+  , channelPubDate        :: Maybe UTCTime+  , channelLastBuildDate  :: Maybe UTCTime+  , channelCategories     :: [RssCategory]+  , channelGenerator      :: Text+  , channelDocs           :: Maybe RssURI+  , channelCloud          :: Maybe RssCloud+  , channelTtl            :: Maybe Int+  , channelImage          :: Maybe RssImage+  , channelRating         :: Text+  , channelTextInput      :: Maybe RssTextInput+  , channelSkipHours      :: Set Hour+  , channelSkipDays       :: Set Day+  , channelExtensions     :: RssChannelExtensions extensions+  }++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 (Read (Rec RssChannelExtension a)) => Read (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 (Read (Rec RssItemExtension a)) => Read (RssItemExtensions a)+deriving instance (Show (Rec RssItemExtension a)) => Show (RssItemExtensions a)

@@ -0,0 +1,270 @@+{-# 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+    rss1Document+    -- * Elements+  , rss1ChannelItems+  , rss1Image+  , rss1Item+  , rss1TextInput+  ) where++-- {{{ Imports+import           Text.RSS.Extensions+import           Text.RSS.Types++import           Conduit                 hiding (throwM)+import           Control.Exception.Safe  as Exception+import           Control.Monad+import           Control.Monad.Fix+import           Data.Conduit+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+-- }}}++-- {{{ Util+asDate :: (MonadThrow m) => Text -> m UTCTime+asDate text = maybe (throw $ InvalidTime text) (return . zonedTimeToUTC) $ parseTimeRFC3339 text++asRssURI :: (MonadThrow m) => Text -> m RssURI+asRssURI t = case (parseURI' t, parseRelativeRef' t) of+  (Right u, _) -> return $ RssURI u+  (_, Right u) -> return $ RssURI u+  (_, Left e)  -> throwM $ InvalidURI e+  where parseURI' = parseURI laxURIParserOptions . encodeUtf8+        parseRelativeRef' = parseRelativeRef laxURIParserOptions . encodeUtf8++nullURI :: RssURI+nullURI = RssURI $ RelativeRef Nothing "" (Query []) Nothing++headRequiredC :: MonadThrow m => Text -> Consumer a m a+headRequiredC e = maybe (throw $ MissingElement e) return =<< headC++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 ()+++contentTag :: MonadThrow m => Text -> AttrParser a -> (a -> ConduitM Event o m b) -> ConduitM Event o m (Maybe b)+contentTag string = tag' (matching (== contentName string))++dcTag :: MonadThrow m => Text -> AttrParser a -> (a -> ConduitM Event o m b) -> ConduitM Event o m (Maybe b)+dcTag string = tag' (matching (== dcName string))++rdfTag :: MonadThrow m => Text -> AttrParser a -> (a -> ConduitM Event o m b) -> ConduitM Event o m (Maybe b)+rdfTag string = tag' (matching (== rdfName string))++rss1Tag :: MonadThrow m => Text -> AttrParser a -> (a -> ConduitM Event o m b) -> ConduitM Event o m (Maybe b)+rss1Tag string = tag' (matching (== rss1Name string))++contentName :: Text -> Name+contentName string = Name string (Just "http://purl.org/rss/1.0/modules/content/") (Just "content")++dcName :: Text -> Name+dcName string = Name string (Just "http://purl.org/dc/elements/1.1/") (Just "dc")++rdfName :: Text -> Name+rdfName string = Name string (Just "http://www.w3.org/1999/02/22-rdf-syntax-ns#") (Just "rdf")++rss1Name :: Text -> Name+rss1Name string = Name string (Just "http://purl.org/rss/1.0/") Nothing+-- }}}+++data TextInputPiece = TextInputTitle Text | TextInputDescription Text+                    | TextInputName Text | TextInputLink RssURI++makeTraversals ''TextInputPiece++-- | Parse a @\<textinput\>@ element.+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")+    <*> ZipConduit (projectC _TextInputDescription =$= headRequiredC "Missing <description> element")+    <*> ZipConduit (projectC _TextInputName =$= headRequiredC "Missing <name> element")+    <*> ZipConduit (projectC _TextInputLink =$= headDefC uri)  -- Lenient+  piece = [ fmap TextInputTitle <$> rss1Tag "title" ignoreAttrs (const content)+          , fmap TextInputDescription <$> rss1Tag "description" ignoreAttrs (const content)+          , fmap TextInputName <$> rss1Tag "name" ignoreAttrs (const content)+          , fmap TextInputLink <$> rss1Tag "link" ignoreAttrs (const $ content >>= asRssURI)+          ]+  attributes = (requireAttr (rdfName "about") >>= asRssURI) <* ignoreAttrs+++data ItemPiece = ItemTitle Text | ItemLink RssURI | ItemDescription Text | ItemCreator Text+               | ItemDate UTCTime | ItemContent Text | ItemOther (NonEmpty Event)++makeTraversals ''ItemPiece++-- | Parse an @\<item\>@ element.+--+-- RSS extensions are automatically parsed based on the inferred 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)+    <*> (Just <$> ZipConduit (projectC _ItemLink =$= headDefC uri))+    <*> ZipConduit (projectC _ItemDescription =$= headDefC mempty)+    <*> ZipConduit (projectC _ItemCreator =$= headDefC mempty)+    <*> pure mempty+    <*> pure mzero+    <*> pure mempty+    <*> 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+++data ImagePiece = ImageUri RssURI | ImageTitle Text | ImageLink RssURI++makeTraversals ''ImagePiece++-- | Parse an @\<image\>@ element.+rss1Image :: (MonadThrow m) => ConduitM Event o m (Maybe RssImage)+rss1Image = rss1Tag "image" attributes $ \uri -> (manyYield' (choose piece) =$= parser uri) <* many ignoreAnyTreeContent where+  parser uri = getZipConduit $ RssImage+    <$> ZipConduit (projectC _ImageUri =$= headDefC uri)  -- Lenient+    <*> ZipConduit (projectC _ImageTitle =$= headDefC "Unnamed image")  -- Lenient+    <*> ZipConduit (projectC _ImageLink =$= headDefC nullURI)  -- Lenient+    <*> pure mzero+    <*> pure mzero+    <*> pure mempty+  piece = [ fmap ImageUri <$> rss1Tag "url" ignoreAttrs (const $ content >>= asRssURI)+          , fmap ImageTitle <$> rss1Tag "title" ignoreAttrs (const content)+          , fmap ImageLink <$> rss1Tag "link" ignoreAttrs (const $ content >>= asRssURI)+          ]+  attributes = (requireAttr (rdfName "about") >>= asRssURI) <* ignoreAttrs+++-- | Parse an @\<items\>@ element.+rss1ChannelItems :: MonadThrow m => ConduitM Event o m (Maybe [Text])+rss1ChannelItems = fmap join $ rss1Tag "items" ignoreAttrs $ const $ rdfTag "Seq" ignoreAttrs $ const $ many $ rdfTag "li" attributes return where+  attributes = requireAttr (rdfName "resource") <* ignoreAttrs+++data Rss1Channel (extensions :: [*]) = Rss1Channel+  { channelId'          :: RssURI+  , channelTitle'       :: Text+  , channelLink'        :: RssURI+  , channelDescription' :: Text+  , channelItems'       :: [Text]+  , channelImage'       :: Maybe RssImage+  , channelTextInput'   :: Maybe RssURI+  , channelExtensions'  :: RssChannelExtensions extensions+  }++data ChannelPiece = ChannelTitle Text+  | ChannelLink RssURI+  | ChannelDescription Text+  | ChannelImage RssImage+  | ChannelItems [Text]+  | ChannelTextInput RssURI+  | ChannelOther (NonEmpty Event)++makeTraversals ''ChannelPiece+++-- | Parse a @\<channel\>@ element.+--+-- RSS extensions are automatically parsed based on the inferred 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")+    <*> ZipConduit (projectC _ChannelLink =$= headRequiredC "Missing <link> element")+    <*> ZipConduit (projectC _ChannelDescription =$= headDefC "")  -- Lenient+    <*> 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 (e :: [*]) = Rss1Document (Rss1Channel e) (Maybe RssImage) [RssItem e] (Maybe RssTextInput)++rss1ToRss2 :: Rss1Document e -> RssDocument e+rss1ToRss2 (Rss1Document channel image items textInput) = RssDocument+  (Version [1] [])+  (channelTitle' channel)+  (channelLink' channel)+  (channelDescription' channel)+  items+  mempty+  mempty+  mempty+  mempty+  mzero+  mzero+  mzero+  mempty+  mzero+  mzero+  mzero+  image+  mempty+  textInput+  mempty+  mempty+  (channelExtensions' channel)++data DocumentPiece (e :: [*]) = DocumentChannel (Rss1Channel e)+  | DocumentImage RssImage+  | DocumentItem (RssItem e)+  | DocumentTextInput RssTextInput++makeTraversals ''DocumentPiece+++-- | Parse an @\<RDF\>@ element.+--+-- RSS extensions are automatically parsed based on the inferred 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")+    <*> ZipConduit (projectC _DocumentImage =$= headC)+    <*> ZipConduit (projectC _DocumentItem =$= sinkList)+    <*> ZipConduit (projectC _DocumentTextInput =$= headC)+  piece = [ fmap DocumentChannel <$> rss1Channel+          , fmap DocumentImage <$> rss1Image+          , fmap DocumentItem <$> rss1Item+          , fmap DocumentTextInput <$> rss1TextInput+          ]

@@ -0,0 +1,8 @@+import qualified Language.Haskell.HLint as HLint (hlint)+import           System.Exit+++main :: IO ()+main = do+  result <- HLint.hlint [ "test/", "src/" ]+  if null result then exitSuccess else exitFailure

@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE QuasiQuotes         #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} -- {{{ Imports import           Text.RSS.Conduit.Parse          as Parser import           Text.RSS.Conduit.Render         as Renderer@@ -35,7 +36,6 @@ import           Data.Vinyl.Core import           Data.Void import           Data.XML.Types-import qualified Language.Haskell.HLint          as HLint (hlint) import           Lens.Simple import           System.IO import           System.Timeout@@ -54,7 +54,6 @@ main = defaultMain $ testGroup "Tests"   [ unitTests   , properties-  , hlint   ]  unitTests :: TestTree@@ -95,16 +94,16 @@       (renderRssItem :: RssItem '[] -> Source Maybe Event)       rssItem   , roundtripProperty "DublinCore"-      (renderRssChannelExtension :: RssChannelExtension DublinCoreModule -> Source Maybe Event)+      (renderRssChannelExtension @DublinCoreModule)       (Just <$> parseRssChannelExtension)   , roundtripProperty "Syndication"-      (renderRssChannelExtension :: RssChannelExtension SyndicationModule -> Source Maybe Event)+      (renderRssChannelExtension @SyndicationModule)       (Just <$> parseRssChannelExtension)   , roundtripProperty "Atom"-      (renderRssChannelExtension :: RssChannelExtension AtomModule -> Source Maybe Event)+      (renderRssChannelExtension @AtomModule)       (Just <$> parseRssChannelExtension)   , roundtripProperty "Content"-      (renderRssItemExtension :: RssItemExtension ContentModule -> Source Maybe Event)+      (renderRssItemExtension @ContentModule)       (Just <$> parseRssItemExtension)   ] @@ -518,12 +517,6 @@                 ]         url = AtomURI [uri|http://dallas.example.com/rss.xml|]         link = AtomLink url "self" "application/rss+xml" mempty mempty mempty---hlint :: TestTree-hlint = testCase "HLint check" $ do-  result <- HLint.hlint [ "test/", "Text/" ]-  Prelude.null result @?= True   roundtripTextInputProperty :: TestTree