diff --git a/Text/RSS/Conduit/Parse.hs b/Text/RSS/Conduit/Parse.hs deleted file mode 100644 --- a/Text/RSS/Conduit/Parse.hs +++ /dev/null @@ -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 @\@ element. -rssSkipHours :: MonadThrow m => ConduitM Event o m (Maybe (Set Hour)) -rssSkipHours = tagIgnoreAttrs "skipHours" $ - fromList <$> (manyYield' (tagIgnoreAttrs "hour" $ content >>= asInt >>= asHour) =$= sinkList) - --- | Parse a @\@ 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 @\@ 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 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 diff --git a/Text/RSS/Conduit/Parse/Simple.hs b/Text/RSS/Conduit/Parse/Simple.hs deleted file mode 100644 --- a/Text/RSS/Conduit/Parse/Simple.hs +++ /dev/null @@ -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 diff --git a/Text/RSS/Conduit/Render.hs b/Text/RSS/Conduit/Render.hs deleted file mode 100644 --- a/Text/RSS/Conduit/Render.hs +++ /dev/null @@ -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' --- }}} diff --git a/Text/RSS/Extensions.hs b/Text/RSS/Extensions.hs deleted file mode 100644 --- a/Text/RSS/Extensions.hs +++ /dev/null @@ -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) diff --git a/Text/RSS/Extensions/Atom.hs b/Text/RSS/Extensions/Atom.hs deleted file mode 100644 --- a/Text/RSS/Extensions/Atom.hs +++ /dev/null @@ -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) diff --git a/Text/RSS/Extensions/Content.hs b/Text/RSS/Extensions/Content.hs deleted file mode 100644 --- a/Text/RSS/Extensions/Content.hs +++ /dev/null @@ -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 diff --git a/Text/RSS/Extensions/DublinCore.hs b/Text/RSS/Extensions/DublinCore.hs deleted file mode 100644 --- a/Text/RSS/Extensions/DublinCore.hs +++ /dev/null @@ -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) diff --git a/Text/RSS/Extensions/Syndication.hs b/Text/RSS/Extensions/Syndication.hs deleted file mode 100644 --- a/Text/RSS/Extensions/Syndication.hs +++ /dev/null @@ -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) diff --git a/Text/RSS/Lens.hs b/Text/RSS/Lens.hs deleted file mode 100644 --- a/Text/RSS/Lens.hs +++ /dev/null @@ -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 #-} diff --git a/Text/RSS/Types.hs b/Text/RSS/Types.hs deleted file mode 100644 --- a/Text/RSS/Types.hs +++ /dev/null @@ -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 --- > http://liftoff.msfc.nasa.gov/ --- > Liftoff to Space Exploration. --- > en-us --- > Tue, 10 Jun 2003 04:00:00 GMT --- > Tue, 10 Jun 2003 09:41:01 GMT --- > http://blogs.law.harvard.edu/tech/rss --- > Weblog Editor 2.0 --- > editor@example.com --- > webmaster@example.com --- > --- > Star City --- > http://liftoff.msfc.nasa.gov/news/2003/news-starcity.asp --- > 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 <a href="http://howe.iki.rssi.ru/GCTC/gctc_e.htm">Star City</a>. --- > Tue, 03 Jun 2003 09:39:21 GMT --- > http://liftoff.msfc.nasa.gov/2003/06/03.html#item573 --- > --- > --- > -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 @\@ 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 @\@ 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 @\@ 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 @\@ element. -data RssGuid = GuidText Text | GuidUri RssURI - deriving(Eq, Generic, Ord, Show) - - --- | The @\@ 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 @\@ 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 @\@ 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 @\@ 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 @\@ 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 @\@ and @\@ elements: --- --- > data instance RssChannelExtension MyExtension = MyExtensionChannel { {- ... fields -} } --- > data instance RssItemExtension MyExtension = MyExtensionItem { {- ... fields -} } --- --- - Implement corresponding parsers (cf "Text.RSS.Extensions"). - --- | @\@ extension type. -data family RssChannelExtension extensionTag :: * - --- | @\@ extension type. -data family RssItemExtension extensionTag :: * - --- | Combination of multiple @\@ 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 @\@ 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) diff --git a/Text/RSS1/Conduit/Parse.hs b/Text/RSS1/Conduit/Parse.hs deleted file mode 100644 --- a/Text/RSS1/Conduit/Parse.hs +++ /dev/null @@ -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 @\@ 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 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 - ] diff --git a/rss-conduit.cabal b/rss-conduit.cabal --- a/rss-conduit.cabal +++ b/rss-conduit.cabal @@ -1,5 +1,5 @@ name: rss-conduit -version: 0.4.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 diff --git a/src/Text/RSS/Conduit/Parse.hs b/src/Text/RSS/Conduit/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Text/RSS/Conduit/Parse.hs @@ -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 diff --git a/src/Text/RSS/Conduit/Parse/Simple.hs b/src/Text/RSS/Conduit/Parse/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Text/RSS/Conduit/Parse/Simple.hs @@ -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 diff --git a/src/Text/RSS/Conduit/Render.hs b/src/Text/RSS/Conduit/Render.hs new file mode 100644 --- /dev/null +++ b/src/Text/RSS/Conduit/Render.hs @@ -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' +-- }}} diff --git a/src/Text/RSS/Extensions.hs b/src/Text/RSS/Extensions.hs new file mode 100644 --- /dev/null +++ b/src/Text/RSS/Extensions.hs @@ -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) diff --git a/src/Text/RSS/Extensions/Atom.hs b/src/Text/RSS/Extensions/Atom.hs new file mode 100644 --- /dev/null +++ b/src/Text/RSS/Extensions/Atom.hs @@ -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) diff --git a/src/Text/RSS/Extensions/Content.hs b/src/Text/RSS/Extensions/Content.hs new file mode 100644 --- /dev/null +++ b/src/Text/RSS/Extensions/Content.hs @@ -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 diff --git a/src/Text/RSS/Extensions/DublinCore.hs b/src/Text/RSS/Extensions/DublinCore.hs new file mode 100644 --- /dev/null +++ b/src/Text/RSS/Extensions/DublinCore.hs @@ -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) diff --git a/src/Text/RSS/Extensions/Syndication.hs b/src/Text/RSS/Extensions/Syndication.hs new file mode 100644 --- /dev/null +++ b/src/Text/RSS/Extensions/Syndication.hs @@ -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) diff --git a/src/Text/RSS/Lens.hs b/src/Text/RSS/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Text/RSS/Lens.hs @@ -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 #-} diff --git a/src/Text/RSS/Types.hs b/src/Text/RSS/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/RSS/Types.hs @@ -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 +-- > http://liftoff.msfc.nasa.gov/ +-- > Liftoff to Space Exploration. +-- > en-us +-- > Tue, 10 Jun 2003 04:00:00 GMT +-- > Tue, 10 Jun 2003 09:41:01 GMT +-- > http://blogs.law.harvard.edu/tech/rss +-- > Weblog Editor 2.0 +-- > editor@example.com +-- > webmaster@example.com +-- > +-- > Star City +-- > http://liftoff.msfc.nasa.gov/news/2003/news-starcity.asp +-- > 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 <a href="http://howe.iki.rssi.ru/GCTC/gctc_e.htm">Star City</a>. +-- > Tue, 03 Jun 2003 09:39:21 GMT +-- > http://liftoff.msfc.nasa.gov/2003/06/03.html#item573 +-- > +-- > +-- > +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 @\@ 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 @\@ 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 @\@ 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 @\@ element. +data RssGuid = GuidText Text | GuidUri RssURI + deriving(Eq, Generic, Ord, Show) + + +-- | The @\@ 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 @\@ 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 @\@ 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 @\@ 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 @\@ 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 @\@ and @\@ elements: +-- +-- > data instance RssChannelExtension MyExtension = MyExtensionChannel { {- ... fields -} } +-- > data instance RssItemExtension MyExtension = MyExtensionItem { {- ... fields -} } +-- +-- - Implement corresponding parsers (cf "Text.RSS.Extensions"). + +-- | @\@ extension type. +data family RssChannelExtension extensionTag :: * + +-- | @\@ extension type. +data family RssItemExtension extensionTag :: * + +-- | Combination of multiple @\@ 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 @\@ 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) diff --git a/src/Text/RSS1/Conduit/Parse.hs b/src/Text/RSS1/Conduit/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Text/RSS1/Conduit/Parse.hs @@ -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 @\@ 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 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 + ] diff --git a/test/HLint.hs b/test/HLint.hs new file mode 100644 --- /dev/null +++ b/test/HLint.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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