diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,13 +1,121 @@ -DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE -Version 2, December 2004 +Creative Commons Legal Code -Copyright (C) 2015 koral +CC0 1.0 Universal -Everyone is permitted to copy and distribute verbatim or modified -copies of this license document, and changing it is allowed as long -as the name is changed. + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE + LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN + ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS + INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES + REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS + PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM + THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED + HEREUNDER. -DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE -TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION +Statement of Purpose -0. You just DO WHAT THE FUCK YOU WANT TO. +The laws of most jurisdictions throughout the world automatically confer +exclusive Copyright and Related Rights (defined below) upon the creator +and subsequent owner(s) (each and all, an "owner") of an original work of +authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work for +the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without fear +of later claims of infringement build upon, modify, incorporate in other +works, reuse and redistribute as freely as possible in any form whatsoever +and for any purposes, including without limitation commercial purposes. +These owners may contribute to the Commons to promote the ideal of a free +culture and the further production of creative, cultural and scientific +works, or to gain reputation or greater distribution for their Work in +part through the use and efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or she +is an owner of Copyright and Related Rights in the Work, voluntarily +elects to apply CC0 to the Work and publicly distribute the Work under its +terms, with knowledge of his or her Copyright and Related Rights in the +Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be +protected by copyright and related or neighboring rights ("Copyright and +Related Rights"). Copyright and Related Rights include, but are not +limited to, the following: + + i. the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; + ii. moral rights retained by the original author(s) and/or performer(s); +iii. publicity and privacy rights pertaining to a person's image or + likeness depicted in a Work; + iv. rights protecting against unfair competition in regards to a Work, + subject to the limitations in paragraph 4(a), below; + v. rights protecting the extraction, dissemination, use and reuse of data + in a Work; + vi. database rights (such as those arising under Directive 96/9/EC of the + European Parliament and of the Council of 11 March 1996 on the legal + protection of databases, and under any national implementation + thereof, including any amended or successor version of such + directive); and +vii. other similar, equivalent or corresponding rights throughout the + world based on applicable law or treaty, and any national + implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in contravention +of, applicable law, Affirmer hereby overtly, fully, permanently, +irrevocably and unconditionally waives, abandons, and surrenders all of +Affirmer's Copyright and Related Rights and associated claims and causes +of action, whether now known or unknown (including existing as well as +future claims and causes of action), in the Work (i) in all territories +worldwide, (ii) for the maximum duration provided by applicable law or +treaty (including future time extensions), (iii) in any current or future +medium and for any number of copies, and (iv) for any purpose whatsoever, +including without limitation commercial, advertising or promotional +purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each +member of the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal or +equitable action to disrupt the quiet enjoyment of the Work by the public +as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any reason +be judged legally invalid or ineffective under applicable law, then the +Waiver shall be preserved to the maximum extent permitted taking into +account Affirmer's express Statement of Purpose. In addition, to the +extent the Waiver is so judged Affirmer hereby grants to each affected +person a royalty-free, non transferable, non sublicensable, non exclusive, +irrevocable and unconditional license to exercise Affirmer's Copyright and +Related Rights in the Work (i) in all territories worldwide, (ii) for the +maximum duration provided by applicable law or treaty (including future +time extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"License"). The License shall be deemed effective as of the date CC0 was +applied by Affirmer to the Work. Should any part of the License for any +reason be judged legally invalid or ineffective under applicable law, such +partial invalidity or ineffectiveness shall not invalidate the remainder +of the License, and in such case Affirmer hereby affirms that he or she +will not (i) exercise any of his or her remaining Copyright and Related +Rights in the Work or (ii) assert any associated claims and causes of +action with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + a. No trademark or patent rights held by Affirmer are waived, abandoned, + surrendered, licensed or otherwise affected by this document. + b. Affirmer offers the Work as-is and makes no representations or + warranties of any kind concerning the Work, express, implied, + statutory or otherwise, including without limitation warranties of + title, merchantability, fitness for a particular purpose, non + infringement, or the absence of latent or other defects, accuracy, or + the present or absence of errors, whether or not discoverable, all to + the greatest extent permissible under applicable law. + c. Affirmer disclaims responsibility for clearing rights of other persons + that may apply to the Work or any use thereof, including without + limitation any person's Copyright and Related Rights in the Work. + Further, Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. + d. Affirmer understands and acknowledges that Creative Commons is not a + party to this document and has no duty or obligation with respect to + this CC0 or use of the Work. diff --git a/rss-conduit.cabal b/rss-conduit.cabal --- a/rss-conduit.cabal +++ b/rss-conduit.cabal @@ -1,15 +1,16 @@ +cabal-version: 2.2 name: rss-conduit -version: 0.4.3.1 -cabal-version: >=1.10 +version: 0.5.0.0 build-type: Simple -license: PublicDomain +license: CC0-1.0 license-file: LICENSE -maintainer: chahine.moreau@gmail.com +author: koral +maintainer: mail@cmoreau.info +bug-reports: https://github.com/k0ral/rss-conduit/issues synopsis: Streaming parser/renderer for the RSS standard. -description: - Cf README file. +description: Cf README file. category: XML, Conduit -author: chahine.moreau@gmail.com +tested-with: GHC <8.9 && >=8.4.2 extra-source-files: README.md @@ -22,10 +23,13 @@ manual: True default: False +common common + build-depends: base >=4.7 && <5, base-compat-batteries + default-language: Haskell2010 + + library - if impl(ghc <8) - build-depends: - semigroups -any + import: common exposed-modules: Text.RSS1.Conduit.Parse Text.RSS.Conduit.Parse @@ -40,7 +44,6 @@ Text.RSS.Types build-depends: atom-conduit >=0.5, - base >=4.8 && <5, conduit >= 1.3, conduit-combinators -any, containers -any, @@ -48,24 +51,21 @@ safe-exceptions -any, lens-simple -any, safe -any, - singletons -any, text -any, time >=1.5, timerep >=2.0, uri-bytestring >=0.2, - vinyl >= 0.9, xml-conduit >=1.5, xml-types -any - default-language: Haskell2010 hs-source-dirs: src -test-suite Tests +test-suite tests + import: common type: exitcode-stdio-1.0 main-is: Main.hs build-depends: - rss-conduit -any, + rss-conduit, atom-conduit >=0.5, - base >=4.8 && <5, blaze-builder -any, bytestring -any, conduit -any, @@ -75,35 +75,50 @@ filepath -any, lens-simple -any, mono-traversable -any, - QuickCheck -any, - quickcheck-instances -any, resourcet -any, safe-exceptions -any, - singletons -any, tasty -any, tasty-golden -any, tasty-hunit -any, + time >=1.5, + text -any, + uri-bytestring >=0.2, + xml-conduit >=1.3, + xml-types -any + hs-source-dirs: test + +test-suite quickcheck-tests + import: common + type: exitcode-stdio-1.0 + main-is: QuickCheck.hs + build-depends: + rss-conduit, + atom-conduit >=0.5, + blaze-builder -any, + bytestring -any, + conduit -any, + dublincore-xml-conduit -any, + filepath -any, + QuickCheck -any, + quickcheck-instances -any, + tasty -any, tasty-quickcheck -any, time >=1.5, text -any, uri-bytestring >=0.2, - vinyl -any, xml-conduit >=1.3, xml-types -any - default-language: Haskell2010 hs-source-dirs: test other-modules: Arbitrary test-suite hlint + import: common 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 + build-depends: hlint -any hs-source-dirs: test diff --git a/src/Text/RSS/Conduit/Parse.hs b/src/Text/RSS/Conduit/Parse.hs --- a/src/Text/RSS/Conduit/Parse.hs +++ b/src/Text/RSS/Conduit/Parse.hs @@ -205,7 +205,7 @@ -- | Parse an @\@ 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 :: ParseRssExtension 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 "") @@ -218,7 +218,7 @@ <*> ZipConduit (projectC _ItemGuid .| headC) <*> ZipConduit (projectC _ItemPubDate .| headC) <*> ZipConduit (projectC _ItemSource .| headC) - <*> ZipConduit (projectC _ItemOther .| concatC .| parseRssItemExtensions) + <*> ZipConduit (projectC _ItemOther .| concatC .| parseRssItemExtension) piece = [ fmap ItemTitle <$> tagIgnoreAttrs "title" content , fmap ItemLink <$> tagIgnoreAttrs "link" (content >>= asRssURI) , fmap ItemDescription <$> tagIgnoreAttrs "description" content @@ -247,7 +247,7 @@ -- | Parse an @\@ 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 :: ParseRssExtension e => MonadThrow m => ConduitM Event o m (Maybe (RssDocument e)) rssDocument = tagName' "rss" attributes $ \version -> force "Missing " $ tagIgnoreAttrs "channel" (manyYield' (choose piece) .| parser version) <* many ignoreAnyTreeContent where parser version = getZipConduit $ RssDocument version <$> ZipConduit (projectC _ChannelTitle .| headRequiredC "Missing element") @@ -270,7 +270,7 @@ <*> ZipConduit (projectC _ChannelTextInput .| headC) <*> ZipConduit (projectC _ChannelSkipHours .| headDefC mempty) <*> ZipConduit (projectC _ChannelSkipDays .| headDefC mempty) - <*> ZipConduit (projectC _ChannelOther .| concatC .| parseRssChannelExtensions) + <*> ZipConduit (projectC _ChannelOther .| concatC .| parseRssChannelExtension) piece = [ fmap ChannelTitle <$> tagIgnoreAttrs "title" content , fmap ChannelLink <$> tagIgnoreAttrs "link" (content >>= asRssURI) , fmap ChannelDescription <$> tagIgnoreAttrs "description" content diff --git a/src/Text/RSS/Conduit/Render.hs b/src/Text/RSS/Conduit/Render.hs --- a/src/Text/RSS/Conduit/Render.hs +++ b/src/Text/RSS/Conduit/Render.hs @@ -40,7 +40,7 @@ -- }}} -- | Render the top-level @\<rss\>@ element. -renderRssDocument :: Monad m => RenderRssExtensions e => RssDocument e -> ConduitT () Event m () +renderRssDocument :: Monad m => RenderRssExtension e => RssDocument e -> ConduitT () Event m () renderRssDocument d = tag "rss" (attr "version" . pack . showVersion $ d^.documentVersionL) $ tag "channel" mempty $ do textTag "title" $ d^.channelTitleL @@ -63,10 +63,10 @@ renderRssSkipHours $ d^.channelSkipHoursL renderRssSkipDays $ d^.channelSkipDaysL forM_ (d^..channelItemsL) renderRssItem - renderRssChannelExtensions $ d^.channelExtensionsL + renderRssChannelExtension $ d^.channelExtensionsL -- | Render an @\<item\>@ element. -renderRssItem :: Monad m => RenderRssExtensions e => RssItem e -> ConduitT () Event m () +renderRssItem :: Monad m => RenderRssExtension e => RssItem e -> ConduitT () Event m () renderRssItem i = tag "item" mempty $ do optionalTextTag "title" $ i^.itemTitleL forM_ (i^.itemLinkL) $ textTag "link" . renderRssURI @@ -78,7 +78,7 @@ forM_ (i^.itemGuidL) renderRssGuid forM_ (i^.itemPubDateL) $ dateTag "pubDate" forM_ (i^.itemSourceL) renderRssSource - renderRssItemExtensions $ i^.itemExtensionsL + renderRssItemExtension $ i^.itemExtensionsL -- | Render a @\<source\>@ element. renderRssSource :: (Monad m) => RssSource -> ConduitT () Event m () diff --git a/src/Text/RSS/Extensions.hs b/src/Text/RSS/Extensions.hs --- a/src/Text/RSS/Extensions.hs +++ b/src/Text/RSS/Extensions.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} @@ -8,25 +6,53 @@ {-# LANGUAGE TypeOperators #-} -- | Support for RSS extensions. -- Cf specification at <http://web.resource.org/rss/1.0/modules/>. +-- +-- To implement an RSS extension: +-- +-- - Create a data-type, that will be used as a tag to identify the extension. +-- To allow stacking multiple extensions, your data-type should have kind * -> * +-- +-- > data MyExtension otherExtensions = MyExtension otherExtensions +-- +-- - Implement extension types for @\<channel\>@ and @\<item\>@ elements: +-- +-- > data instance RssChannelExtension (MyExtension e) = MyExtensionChannel +-- > { -- ... add your fields ... +-- > , otherChannelExtensions :: RssChannelExtension e +-- > } +-- > +-- > data instance RssItemExtension (MyExtension e) = MyExtensionItem +-- > { -- ... add your fields ... +-- > , otherItemExtensions :: RssItemExtension e +-- > } +-- +-- - Implement 'ParseRssExtension' and 'RenderRssExtension' type classes: +-- +-- > -- Parser should rely on ZipConduit to be order-insensitive +-- > instance ParseRssExtension e => ParseRssExtension (MyExtension e) where +-- > parseRssChannelExtension = getZipConduit $ MyExtensionChannel +-- > <$> ZipConduit -- ... parse fields +-- > <*> ZipConduit parseRssChannelExtension +-- > parseRssItemExtension = -- ... similarly +-- > +-- > instance RenderRssExtension e => RenderRssExtension (MyExtension e) where +-- > renderRssChannelExtension (MyExtensionChannel {- fields -} otherChannelExtensions) = do +-- > -- ... render fields +-- > renderRssChannelExtension otherChannelExtensions +-- > renderRssItemExtension (MyExtensionItem {- fields -} otherItemExtensions) = -- ... similarly module Text.RSS.Extensions where -- {{{ Imports -import Control.Exception.Safe as Exception +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 GHC.Generics import Text.Atom.Conduit.Parse import Text.Atom.Types -import Text.Read (readMaybe) +import Text.Read (readMaybe) import Text.RSS.Types import Text.XML.Stream.Parse import URI.ByteString @@ -43,28 +69,9 @@ -- Therefore, it is expected to ignore 'Event's unrelated to the RSS extension. parseRssItemExtension :: MonadThrow m => ConduitT 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 => ConduitT Event o m (RssChannelExtensions e) -parseRssChannelExtensions = f sing where - f :: AllConstrained ParseRssExtension e => MonadThrow m - => Sing e -> ConduitT 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 => ConduitT Event o m (RssItemExtensions e) -parseRssItemExtensions = f sing where - f :: AllConstrained ParseRssExtension e => MonadThrow m - => Sing e -> ConduitT Event o m (RssItemExtensions e) - f SNil = return $ RssItemExtensions RNil - f (SCons _ es) = fmap RssItemExtensions $ getZipConduit $ (:&) - <$> ZipConduit parseRssItemExtension - <*> ZipConduit (rssItemExtension <$> f es) +instance ParseRssExtension NoExtensions where + parseRssChannelExtension = pure NoChannelExtensions + parseRssItemExtension = pure NoItemExtensions -- * Rendering @@ -76,19 +83,6 @@ -- | Render extension for the @\<item\>@ element. renderRssItemExtension :: Monad m => RssItemExtension e -> ConduitT () Event m () --- | 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 -> ConduitT () Event m () -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 -> ConduitT () Event m () -renderRssItemExtensions (RssItemExtensions RNil) = pure () -renderRssItemExtensions (RssItemExtensions (a :& t)) = do - renderRssItemExtension a - renderRssItemExtensions (RssItemExtensions t) +instance RenderRssExtension NoExtensions where + renderRssChannelExtension = const $ pure () + renderRssItemExtension = const $ pure () diff --git a/src/Text/RSS/Extensions/Atom.hs b/src/Text/RSS/Extensions/Atom.hs --- a/src/Text/RSS/Extensions/Atom.hs +++ b/src/Text/RSS/Extensions/Atom.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} -- | __Atom__ extension for RSS. -- Cf specification at <http://www.rssboard.org/rss-profile#namespace-elements-atom>. module Text.RSS.Extensions.Atom where @@ -11,8 +13,7 @@ import Text.RSS.Extensions import Text.RSS.Types -import Conduit (headC, (.|)) -import Data.Singletons +import Conduit (ZipConduit (..), headC, (.|)) import GHC.Generics import Text.Atom.Conduit.Parse import Text.Atom.Conduit.Render @@ -21,21 +22,44 @@ -- }}} -- | __Atom__ tag type. -data AtomModule :: * +newtype AtomModule a = AtomModule a -data instance Sing AtomModule = SAtomModule +instance ParseRssExtension a => ParseRssExtension (AtomModule a) where + parseRssChannelExtension = getZipConduit $ AtomChannel + <$> ZipConduit (manyYield' atomLink .| headC) + <*> ZipConduit parseRssChannelExtension + parseRssItemExtension = getZipConduit $ AtomItem + <$> ZipConduit (manyYield' atomLink .| headC) + <*> ZipConduit parseRssItemExtension -instance SingI AtomModule where sing = SAtomModule +instance RenderRssExtension a => RenderRssExtension (AtomModule a) where + renderRssChannelExtension AtomChannel{..} = do + mapM_ renderAtomLink channelAtomLink + renderRssChannelExtension channelAtomOther + renderRssItemExtension AtomItem{..} = do + mapM_ renderAtomLink itemAtomLink + renderRssItemExtension itemAtomOther -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 a) = AtomChannel + { channelAtomLink :: Maybe AtomLink + , channelAtomOther :: RssChannelExtension a + } -data instance RssChannelExtension AtomModule = AtomChannel { channelAtomLink :: Maybe AtomLink } - deriving(Eq, Generic, Show) -data instance RssItemExtension AtomModule = AtomItem { itemAtomLink :: Maybe AtomLink } - deriving(Eq, Generic, Show) +deriving instance Eq (RssChannelExtension a) => Eq (RssChannelExtension (AtomModule a)) +deriving instance Ord (RssChannelExtension a) => Ord (RssChannelExtension (AtomModule a)) +--deriving instance Read (RssChannelExtension a) => Read (RssChannelExtension (AtomModule a)) +deriving instance Show (RssChannelExtension a) => Show (RssChannelExtension (AtomModule a)) +deriving instance Generic (RssChannelExtension a) => Generic (RssChannelExtension (AtomModule a)) + + +data instance RssItemExtension (AtomModule a) = AtomItem + { itemAtomLink :: Maybe AtomLink + , itemAtomOther :: RssItemExtension a + } + +deriving instance Eq (RssItemExtension a) => Eq (RssItemExtension (AtomModule a)) +deriving instance Ord (RssItemExtension a) => Ord (RssItemExtension (AtomModule a)) +--deriving instance Read (RssItemExtension a) => Read (RssItemExtension (AtomModule a)) +deriving instance Show (RssItemExtension a) => Show (RssItemExtension (AtomModule a)) +deriving instance Generic (RssItemExtension a) => Generic (RssItemExtension (AtomModule a)) diff --git a/src/Text/RSS/Extensions/Content.hs b/src/Text/RSS/Extensions/Content.hs --- a/src/Text/RSS/Extensions/Content.hs +++ b/src/Text/RSS/Extensions/Content.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} -- | __Content__ extension for RSS. -- Cf specification at <http://web.resource.org/rss/1.0/modules/content/>. -- @@ -26,11 +27,10 @@ import Text.RSS.Extensions import Text.RSS.Types -import Conduit (ConduitT, Source, headDefC, (.|)) +import Conduit (ConduitT, Source, ZipConduit (..), 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 @@ -41,23 +41,39 @@ -- }}} -- | __Content__ tag type. -data ContentModule :: * +newtype ContentModule a = ContentModule a -data instance Sing ContentModule = SContentModule +instance ParseRssExtension a => ParseRssExtension (ContentModule a) where + parseRssChannelExtension = parseRssChannelExtension + parseRssItemExtension = getZipConduit $ ContentItem + <$> ZipConduit (manyYield' contentEncoded .| headDefC mempty) + <*> ZipConduit parseRssItemExtension -instance SingI ContentModule where sing = SContentModule +instance RenderRssExtension a => RenderRssExtension (ContentModule a) where + renderRssChannelExtension = renderRssChannelExtension + renderRssItemExtension (ContentItem e a) = do + unless (Text.null e) $ renderContentEncoded e + renderRssItemExtension a -instance ParseRssExtension ContentModule where - parseRssChannelExtension = pure ContentChannel - parseRssItemExtension = ContentItem <$> (manyYield' contentEncoded .| headDefC mempty) +data instance RssChannelExtension (ContentModule a) = ContentChannel (RssChannelExtension a) -instance RenderRssExtension ContentModule where - renderRssChannelExtension = const $ pure () - renderRssItemExtension (ContentItem e) = unless (Text.null e) $ renderContentEncoded e +deriving instance Eq (RssChannelExtension a) => Eq (RssChannelExtension (ContentModule a)) +deriving instance Ord (RssChannelExtension a) => Ord (RssChannelExtension (ContentModule a)) +deriving instance Read (RssChannelExtension a) => Read (RssChannelExtension (ContentModule a)) +deriving instance Show (RssChannelExtension a) => Show (RssChannelExtension (ContentModule a)) +deriving instance Generic (RssChannelExtension a) => Generic (RssChannelExtension (ContentModule a)) -data instance RssChannelExtension ContentModule = ContentChannel deriving(Eq, Generic, Ord, Show) -data instance RssItemExtension ContentModule = ContentItem { itemContent :: Text } - deriving(Eq, Generic, Ord, Show) +data instance RssItemExtension (ContentModule a) = ContentItem + { itemContent :: Text + , itemOther :: RssItemExtension a + } + +deriving instance Eq (RssItemExtension a) => Eq (RssItemExtension (ContentModule a)) +deriving instance Ord (RssItemExtension a) => Ord (RssItemExtension (ContentModule a)) +deriving instance Read (RssItemExtension a) => Read (RssItemExtension (ContentModule a)) +deriving instance Show (RssItemExtension a) => Show (RssItemExtension (ContentModule a)) +deriving instance Generic (RssItemExtension a) => Generic (RssItemExtension (ContentModule a)) + -- | XML prefix is @content@. diff --git a/src/Text/RSS/Extensions/DublinCore.hs b/src/Text/RSS/Extensions/DublinCore.hs --- a/src/Text/RSS/Extensions/DublinCore.hs +++ b/src/Text/RSS/Extensions/DublinCore.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# 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 @@ -27,7 +28,6 @@ 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 @@ -69,7 +69,7 @@ , elementSubject :: Text , elementTitle :: Text , elementType :: Text - } deriving(Eq, Generic, Ord, Show) + } deriving(Eq, Generic, Ord, Read, Show) -- | Construct an empty 'DcMetaData'. mkDcMetaData = DcMetaData mempty mempty mempty Nothing mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty @@ -140,22 +140,43 @@ -- | __Dublin Core__ tag type. -data DublinCoreModule :: * +newtype DublinCoreModule a = DublinCoreModule a -data instance Sing DublinCoreModule = SDublinCoreModule +instance ParseRssExtension a => ParseRssExtension (DublinCoreModule a) where + parseRssChannelExtension = getZipConduit $ DublinCoreChannel + <$> ZipConduit dcMetadata + <*> ZipConduit parseRssChannelExtension + parseRssItemExtension = getZipConduit $ DublinCoreItem + <$> ZipConduit dcMetadata + <*> ZipConduit parseRssItemExtension -instance SingI DublinCoreModule where sing = SDublinCoreModule +instance RenderRssExtension a => RenderRssExtension (DublinCoreModule a) where + renderRssChannelExtension DublinCoreChannel{..} = do + renderDcMetadata channelDcMetaData + renderRssChannelExtension channelDcOther + renderRssItemExtension DublinCoreItem{..} = do + renderDcMetadata itemDcMetaData + renderRssItemExtension itemDcOther -instance ParseRssExtension DublinCoreModule where - parseRssChannelExtension = DublinCoreChannel <$> dcMetadata - parseRssItemExtension = DublinCoreItem <$> dcMetadata -instance RenderRssExtension DublinCoreModule where - renderRssChannelExtension = renderDcMetadata . channelDcMetaData - renderRssItemExtension = renderDcMetadata . itemDcMetaData +data instance RssChannelExtension (DublinCoreModule a) = DublinCoreChannel + { channelDcMetaData :: DcMetaData + , channelDcOther :: RssChannelExtension a + } +deriving instance Eq (RssChannelExtension a) => Eq (RssChannelExtension (DublinCoreModule a)) +deriving instance Ord (RssChannelExtension a) => Ord (RssChannelExtension (DublinCoreModule a)) +deriving instance Read (RssChannelExtension a) => Read (RssChannelExtension (DublinCoreModule a)) +deriving instance Show (RssChannelExtension a) => Show (RssChannelExtension (DublinCoreModule a)) +deriving instance Generic (RssChannelExtension a) => Generic (RssChannelExtension (DublinCoreModule a)) -data instance RssChannelExtension DublinCoreModule = DublinCoreChannel { channelDcMetaData :: DcMetaData } - deriving(Eq, Generic, Ord, Show) -data instance RssItemExtension DublinCoreModule = DublinCoreItem { itemDcMetaData :: DcMetaData } - deriving(Eq, Generic, Ord, Show) +data instance RssItemExtension (DublinCoreModule a) = DublinCoreItem + { itemDcMetaData :: DcMetaData + , itemDcOther :: RssItemExtension a + } + +deriving instance Eq (RssItemExtension a) => Eq (RssItemExtension (DublinCoreModule a)) +deriving instance Ord (RssItemExtension a) => Ord (RssItemExtension (DublinCoreModule a)) +deriving instance Read (RssItemExtension a) => Read (RssItemExtension (DublinCoreModule a)) +deriving instance Show (RssItemExtension a) => Show (RssItemExtension (DublinCoreModule a)) +deriving instance Generic (RssItemExtension a) => Generic (RssItemExtension (DublinCoreModule a)) diff --git a/src/Text/RSS/Extensions/Syndication.hs b/src/Text/RSS/Extensions/Syndication.hs --- a/src/Text/RSS/Extensions/Syndication.hs +++ b/src/Text/RSS/Extensions/Syndication.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# 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 @@ -42,7 +43,6 @@ import Control.Monad import Control.Monad.Fix import Data.Maybe -import Data.Singletons import Data.Text import Data.Time.Clock import Data.Time.LocalTime @@ -181,21 +181,36 @@ -- | __Syndication__ tag type. -data SyndicationModule :: * +newtype SyndicationModule a = SyndicationModule a -data instance Sing SyndicationModule = SSyndicationModule +instance ParseRssExtension a => ParseRssExtension (SyndicationModule a) where + parseRssChannelExtension = getZipConduit $ SyndicationChannel + <$> ZipConduit syndicationInfo + <*> ZipConduit parseRssChannelExtension + parseRssItemExtension = SyndicationItem <$> parseRssItemExtension -instance SingI SyndicationModule where sing = SSyndicationModule +instance RenderRssExtension a => RenderRssExtension (SyndicationModule a) where + renderRssChannelExtension SyndicationChannel{..} = do + renderSyndicationInfo channelSyndicationInfo + renderRssChannelExtension channelSyndicationOther + renderRssItemExtension (SyndicationItem a) = renderRssItemExtension a -instance ParseRssExtension SyndicationModule where - parseRssChannelExtension = SyndicationChannel <$> syndicationInfo - parseRssItemExtension = pure SyndicationItem -instance RenderRssExtension SyndicationModule where - renderRssChannelExtension = renderSyndicationInfo . channelSyndicationInfo - renderRssItemExtension = const $ pure () +data instance RssChannelExtension (SyndicationModule a) = SyndicationChannel + { channelSyndicationInfo :: SyndicationInfo + , channelSyndicationOther :: RssChannelExtension a + } +deriving instance Eq (RssChannelExtension a) => Eq (RssChannelExtension (SyndicationModule a)) +deriving instance Ord (RssChannelExtension a) => Ord (RssChannelExtension (SyndicationModule a)) +deriving instance Read (RssChannelExtension a) => Read (RssChannelExtension (SyndicationModule a)) +deriving instance Show (RssChannelExtension a) => Show (RssChannelExtension (SyndicationModule a)) +deriving instance Generic (RssChannelExtension a) => Generic (RssChannelExtension (SyndicationModule a)) -data instance RssChannelExtension SyndicationModule = SyndicationChannel { channelSyndicationInfo :: SyndicationInfo} - deriving (Eq, Generic, Ord, Read, Show) -data instance RssItemExtension SyndicationModule = SyndicationItem deriving (Eq, Generic, Ord, Read, Show) +data instance RssItemExtension (SyndicationModule a) = SyndicationItem (RssItemExtension a) + +deriving instance Eq (RssItemExtension a) => Eq (RssItemExtension (SyndicationModule a)) +deriving instance Ord (RssItemExtension a) => Ord (RssItemExtension (SyndicationModule a)) +deriving instance Read (RssItemExtension a) => Read (RssItemExtension (SyndicationModule a)) +deriving instance Show (RssItemExtension a) => Show (RssItemExtension (SyndicationModule a)) +deriving instance Generic (RssItemExtension a) => Generic (RssItemExtension (SyndicationModule a)) diff --git a/src/Text/RSS/Lens.hs b/src/Text/RSS/Lens.hs --- a/src/Text/RSS/Lens.hs +++ b/src/Text/RSS/Lens.hs @@ -5,8 +5,6 @@ -- {{{ Imports import Text.RSS.Types -import Data.Vinyl.Lens -import Data.Vinyl.TypeLevel import Lens.Simple import URI.ByteString -- }}} @@ -31,10 +29,6 @@ itemEnclosureL inj a@RssItem { itemEnclosure = e } = (\x -> a { itemEnclosure = e }) <$> traverse inj e {-# INLINE itemEnclosureL #-} -itemExtensionL :: RElem a e (RIndex a e) => Lens' (RssItem e) (RssItemExtension a) -itemExtensionL = itemExtensionsL . f . rlens where - f inj (RssItemExtensions a) = RssItemExtensions <$> inj a -{-# INLINE itemExtensionL #-} $(makeLensesBy (\n -> Just (n ++ "L")) ''RssTextInput) $(makeLensesBy (\n -> Just (n ++ "L")) ''RssCloud) @@ -53,8 +47,3 @@ channelCategoriesL :: Traversal' (RssDocument e) RssCategory channelCategoriesL inj a@RssDocument { channelCategories = c } = (\x -> a { channelCategories = c }) <$> traverse inj c {-# INLINE channelCategoriesL #-} - -channelExtensionL :: RElem a e (RIndex a e) => Lens' (RssDocument e) (RssChannelExtension a) -channelExtensionL = channelExtensionsL . f . rlens where - f inj (RssChannelExtensions a) = RssChannelExtensions <$> inj a -{-# INLINE channelExtensionL #-} diff --git a/src/Text/RSS/Types.hs b/src/Text/RSS/Types.hs --- a/src/Text/RSS/Types.hs +++ b/src/Text/RSS/Types.hs @@ -42,13 +42,11 @@ import Control.Exception.Safe import Data.Semigroup import Data.Set -import Data.Singletons.Prelude.List -import Data.Text (Text, unpack) +import Data.Text (Text, unpack) import Data.Time.Clock -import Data.Time.LocalTime () +import Data.Time.LocalTime () import Data.Version -import Data.Vinyl.Core -import GHC.Generics hiding ((:+:)) +import GHC.Generics hiding ((:+:)) import Text.Read import URI.ByteString -- }}} @@ -148,7 +146,7 @@ -- | The @\<item\>@ element. -- -- This type is open to extensions. -data RssItem (extensions :: [*]) = RssItem +data RssItem extensions = RssItem { itemTitle :: Text , itemLink :: Maybe RssURI , itemDescription :: Text @@ -159,16 +157,16 @@ , itemGuid :: Maybe RssGuid , itemPubDate :: Maybe UTCTime , itemSource :: Maybe RssSource - , itemExtensions :: RssItemExtensions extensions + , itemExtensions :: RssItemExtension 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) +deriving instance (Eq (RssItemExtension e)) => Eq (RssItem e) +deriving instance (Generic (RssItemExtension e)) => Generic (RssItem e) +deriving instance (Ord (RssItemExtension e)) => Ord (RssItem e) +deriving instance (Show (RssItemExtension e)) => Show (RssItem e) -- | Alias for 'RssItem' with no RSS extensions. -type RssItem' = RssItem '[] +type RssItem' = RssItem NoExtensions -- | The @\<textInput\>@ element. data RssTextInput = RssTextInput @@ -242,7 +240,7 @@ -- | The @\<rss\>@ element. -- -- This type is open to extensions. -data RssDocument (extensions :: [*]) = RssDocument +data RssDocument extensions = RssDocument { documentVersion :: Version , channelTitle :: Text , channelLink :: RssURI @@ -264,32 +262,18 @@ , channelTextInput :: Maybe RssTextInput , channelSkipHours :: Set Hour , channelSkipDays :: Set Day - , channelExtensions :: RssChannelExtensions extensions + , channelExtensions :: RssChannelExtension 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) +deriving instance (Eq (RssChannelExtension e), Eq (RssItemExtension e)) => Eq (RssDocument e) +deriving instance (Generic (RssChannelExtension e), Generic (RssItemExtension e)) => Generic (RssDocument e) +deriving instance (Ord (RssChannelExtension e), Ord (RssItemExtension e)) => Ord (RssDocument e) +deriving instance (Show (RssChannelExtension e), Show (RssItemExtension e)) => Show (RssDocument e) -- | Alias for 'RssDocument' with no RSS extensions. -type RssDocument' = RssDocument '[] +type RssDocument' = RssDocument NoExtensions -- * RSS extensions --- --- $doc --- To implement an RSS extension: --- --- - Create a void data-type, that will be used as a tag to identify the extension: --- --- > data MyExtension :: * --- --- - Implement extension types for @\<channel\>@ and @\<item\>@ elements: --- --- > data instance RssChannelExtension MyExtension = MyExtensionChannel { {- ... fields -} } --- > data instance RssItemExtension MyExtension = MyExtensionItem { {- ... fields -} } --- --- - Implement corresponding parsers (cf "Text.RSS.Extensions"). -- | @\<channel\>@ extension type. data family RssChannelExtension extensionTag :: * @@ -297,22 +281,11 @@ -- | @\<item\>@ extension type. data family RssItemExtension extensionTag :: * --- | Combination of multiple @\<channel\>@ extensions. -data family RssChannelExtensions (extensionTags :: [*]) :: * -data instance RssChannelExtensions a = RssChannelExtensions { rssChannelExtension :: Rec RssChannelExtension a } - -deriving instance (Eq (Rec RssChannelExtension a)) => Eq (RssChannelExtensions a) -deriving instance (Generic (Rec RssChannelExtension a)) => Generic (RssChannelExtensions a) -deriving instance (Ord (Rec RssChannelExtension a)) => Ord (RssChannelExtensions a) -deriving instance (Read (Rec RssChannelExtension a)) => Read (RssChannelExtensions a) -deriving instance (Show (Rec RssChannelExtension a)) => Show (RssChannelExtensions a) - --- | Combination of multiple @\<item\>@ extensions. -data family RssItemExtensions (extensionTags :: [*]) :: * -data instance RssItemExtensions (a :: [*]) = RssItemExtensions { rssItemExtension :: Rec RssItemExtension a } +-- | Trivial extension type that parses/renders nothing. +data NoExtensions = NoExtensions + deriving(Eq, Generic, Ord, Read, Show) -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) +data instance RssChannelExtension NoExtensions = NoChannelExtensions + deriving(Eq, Generic, Ord, Read, Show) +data instance RssItemExtension NoExtensions = NoItemExtensions + deriving(Eq, Generic, Ord, Read, Show) diff --git a/src/Text/RSS1/Conduit/Parse.hs b/src/Text/RSS1/Conduit/Parse.hs --- a/src/Text/RSS1/Conduit/Parse.hs +++ b/src/Text/RSS1/Conduit/Parse.hs @@ -19,20 +19,18 @@ import Text.RSS.Extensions import Text.RSS.Types -import Conduit hiding (throwM) -import Control.Exception.Safe as Exception +import Conduit hiding (throwM) +import Control.Exception.Safe as Exception import Control.Monad import Control.Monad.Fix import Data.Conduit import Data.List.NonEmpty -import Data.Singletons.Prelude -import Data.Text as Text +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 @@ -121,7 +119,7 @@ -- | 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 :: ParseRssExtension 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) @@ -134,7 +132,7 @@ <*> pure mzero <*> ZipConduit (projectC _ItemDate .| headC) <*> pure mzero - <*> ZipConduit (projectC _ItemOther .| concatC .| parseRssItemExtensions) + <*> ZipConduit (projectC _ItemOther .| concatC .| parseRssItemExtension) 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)) @@ -172,7 +170,7 @@ attributes = requireAttr (rdfName "resource") <* ignoreAttrs -data Rss1Channel (extensions :: [*]) = Rss1Channel +data Rss1Channel extensions = Rss1Channel { channelId' :: RssURI , channelTitle' :: Text , channelLink' :: RssURI @@ -180,7 +178,7 @@ , channelItems' :: [Text] , channelImage' :: Maybe RssImage , channelTextInput' :: Maybe RssURI - , channelExtensions' :: RssChannelExtensions extensions + , channelExtensions' :: RssChannelExtension extensions } data ChannelPiece = ChannelTitle Text @@ -197,7 +195,7 @@ -- | 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 :: ParseRssExtension 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") @@ -206,7 +204,7 @@ <*> ZipConduit (projectC _ChannelItems .| concatC .| sinkList) <*> ZipConduit (projectC _ChannelImage .| headC) <*> ZipConduit (projectC _ChannelTextInput .| headC) - <*> ZipConduit (projectC _ChannelOther .| concatC .| parseRssChannelExtensions) + <*> ZipConduit (projectC _ChannelOther .| concatC .| parseRssChannelExtension) piece = [ fmap ChannelTitle <$> rss1Tag "title" ignoreAttrs (const content) , fmap ChannelLink <$> rss1Tag "link" ignoreAttrs (const $ content >>= asRssURI) , fmap ChannelDescription <$> rss1Tag "description" ignoreAttrs (const content) @@ -218,7 +216,7 @@ attributes = (requireAttr (rdfName "about") >>= asRssURI) <* ignoreAttrs -data Rss1Document (e :: [*]) = Rss1Document (Rss1Channel e) (Maybe RssImage) [RssItem e] (Maybe RssTextInput) +data Rss1Document e = Rss1Document (Rss1Channel e) (Maybe RssImage) [RssItem e] (Maybe RssTextInput) rss1ToRss2 :: Rss1Document e -> RssDocument e rss1ToRss2 (Rss1Document channel image items textInput) = RssDocument @@ -245,7 +243,7 @@ mempty (channelExtensions' channel) -data DocumentPiece (e :: [*]) = DocumentChannel (Rss1Channel e) +data DocumentPiece e = DocumentChannel (Rss1Channel e) | DocumentImage RssImage | DocumentItem (RssItem e) | DocumentTextInput RssTextInput @@ -256,7 +254,7 @@ -- | 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 :: ParseRssExtension 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") diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -- | 'Arbitrary' instances used by RSS types. @@ -14,14 +15,10 @@ import Data.ByteString (ByteString) import Data.Char import Data.Maybe -import Data.MonoTraversable (Element) -import Data.NonNull -import Data.Sequences (SemiSequence) import Data.Text (Text, find, pack) import Data.Text.Encoding import Data.Time.Clock import Data.Version -import Data.Vinyl.Core import GHC.Generics import Test.QuickCheck import Test.QuickCheck.Instances () @@ -99,7 +96,7 @@ instance Arbitrary RssImage where arbitrary = RssImage <$> arbitrary <*> (pack <$> listOf genAlphaNum) <*> arbitrary <*> fmap (fmap abs) arbitrary <*> fmap (fmap abs) arbitrary <*> (pack <$> listOf genAlphaNum) -instance Arbitrary (RssItem '[]) where +instance Arbitrary (RssItem NoExtensions) where arbitrary = RssItem <$> (pack <$> listOf genAlphaNum) <*> arbitrary @@ -111,7 +108,7 @@ <*> arbitrary <*> oneof [Just <$> genTime, pure Nothing] <*> arbitrary - <*> pure (RssItemExtensions RNil) + <*> pure NoItemExtensions instance Arbitrary RssSource where arbitrary = RssSource <$> arbitrary <*> (pack <$> listOf genAlphaNum) @@ -119,7 +116,7 @@ instance Arbitrary RssTextInput where arbitrary = RssTextInput <$> (pack <$> listOf genAlphaNum) <*> (pack <$> listOf genAlphaNum) <*> (pack <$> listOf genAlphaNum) <*> arbitrary -instance Arbitrary (RssDocument '[]) where +instance Arbitrary (RssDocument NoExtensions) where arbitrary = RssDocument <$> arbitrary <*> arbitrary @@ -142,7 +139,7 @@ <*> arbitrary <*> arbitrary <*> arbitrary - <*> pure (RssChannelExtensions RNil) + <*> pure NoChannelExtensions instance Arbitrary Day where arbitrary = arbitraryBoundedEnum @@ -166,6 +163,12 @@ shrink (RssURI a@URI{}) = RssURI <$> shrink a shrink (RssURI a@RelativeRef{}) = RssURI <$> shrink a +instance Arbitrary (RssChannelExtension NoExtensions) where + arbitrary = pure NoChannelExtensions + +instance Arbitrary (RssItemExtension NoExtensions) where + arbitrary = pure NoItemExtensions + instance Arbitrary DcMetaData where arbitrary = DcMetaData <$> arbitrary @@ -184,8 +187,8 @@ <*> arbitrary <*> arbitrary -instance Arbitrary (RssChannelExtension DublinCoreModule) where - arbitrary = DublinCoreChannel <$> arbitrary +instance Arbitrary (RssChannelExtension a) => Arbitrary (RssChannelExtension (DublinCoreModule a)) where + arbitrary = DublinCoreChannel <$> arbitrary <*> arbitrary instance Arbitrary SyndicationPeriod where arbitrary = arbitraryBoundedEnum @@ -197,8 +200,8 @@ <*> arbitrary <*> oneof [Just <$> genTime, pure Nothing] -instance Arbitrary (RssChannelExtension SyndicationModule) where - arbitrary = SyndicationChannel <$> arbitrary +instance Arbitrary (RssChannelExtension a) => Arbitrary (RssChannelExtension (SyndicationModule a)) where + arbitrary = SyndicationChannel <$> arbitrary <*> arbitrary instance Arbitrary AtomURI where arbitrary = oneof [AtomURI <$> (arbitrary :: Gen (URIRef Absolute)), AtomURI <$> (arbitrary :: Gen (URIRef Relative))] @@ -206,8 +209,8 @@ instance Arbitrary AtomLink where arbitrary = AtomLink <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -instance Arbitrary (RssChannelExtension AtomModule) where - arbitrary = AtomChannel <$> arbitrary +instance Arbitrary (RssChannelExtension a) => Arbitrary (RssChannelExtension (AtomModule a)) where + arbitrary = AtomChannel <$> arbitrary <*> arbitrary -instance Arbitrary (RssItemExtension ContentModule) where - arbitrary = ContentItem <$> arbitrary +instance Arbitrary (RssItemExtension a) => Arbitrary (RssItemExtension (ContentModule a)) where + arbitrary = ContentItem <$> arbitrary <*> arbitrary diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,7 +4,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -- {{{ Imports import Text.RSS.Conduit.Parse as Parser import Text.RSS.Conduit.Render as Renderer @@ -17,8 +16,6 @@ import Text.RSS.Types import Text.RSS1.Conduit.Parse as Parser -import Arbitrary -import Blaze.ByteString.Builder (toByteString) import Conduit import Control.Exception.Safe as Exception import Control.Monad @@ -28,15 +25,11 @@ import Data.Conduit.List import Data.Default import Data.Maybe -import Data.Singletons.Prelude.List import Data.String -import Data.Text (Text) -import Data.Text.Encoding -import qualified Data.Text.Lazy.Encoding as Lazy -import Data.Time.Calendar +import qualified Data.Text.Lazy.Encoding as Lazy +import Data.Time.Calendar hiding (DayOfWeek (..)) import Data.Time.LocalTime import Data.Version -import Data.Vinyl.Core import Data.Void import Data.XML.Types import Lens.Simple @@ -44,9 +37,8 @@ import System.IO import System.Timeout import Test.Tasty -import Test.Tasty.Golden (findByExtension, goldenVsString) +import Test.Tasty.Golden (findByExtension, goldenVsString) import Test.Tasty.HUnit -import Test.Tasty.QuickCheck import Text.Atom.Conduit.Parse import Text.Atom.Types import Text.XML.Stream.Parse as XML hiding (choose) @@ -61,7 +53,6 @@ defaultMain $ testGroup "Tests" [ unitTests , goldenTests - , properties ] unitTests :: TestTree @@ -98,45 +89,11 @@ xmlFile <- xmlFiles let goldenFile = addExtension xmlFile ".golden" f file = fmap (Lazy.encodeUtf8 . fromString . show) $ runResourceT $ runConduit $ sourceFile file .| Conduit.decodeUtf8C .| XML.parseText' def .| parser - parser = rssDocument :: MonadThrow m => ConduitM Event o m (Maybe (RssDocument '[])) + parser = rssDocument :: MonadThrow m => ConduitM Event o m (Maybe (RssDocument NoExtensions)) return $ goldenVsString xmlFile goldenFile $ f xmlFile -properties :: TestTree -properties = testGroup "Properties" - [ roundtripProperty "RssTextInput" renderRssTextInput rssTextInput - , roundtripProperty "RssImage" renderRssImage rssImage - , roundtripProperty "RssCategory" renderRssCategory rssCategory - , roundtripProperty "RssEnclosure" renderRssEnclosure rssEnclosure - , roundtripProperty "RssSource" renderRssSource rssSource - , roundtripProperty "RssGuid" renderRssGuid rssGuid - , roundtripProperty "RssItem" - (renderRssItem :: RssItem '[] -> ConduitT () Event Maybe ()) - rssItem - , roundtripProperty "DublinCore" - (renderRssChannelExtension @DublinCoreModule) - (Just <$> parseRssChannelExtension) - , roundtripProperty "Syndication" - (renderRssChannelExtension @SyndicationModule) - (Just <$> parseRssChannelExtension) - , roundtripProperty "Atom" - (renderRssChannelExtension @AtomModule) - (Just <$> parseRssChannelExtension) - , roundtripProperty "Content" - (renderRssItemExtension @ContentModule) - (Just <$> parseRssItemExtension) - ] - -roundtripProperty :: Eq a => Arbitrary a => Show a - => TestName -> (a -> ConduitT () Event Maybe ()) -> ConduitT Event Void Maybe (Maybe a) -> TestTree -roundtripProperty name render parse = testProperty ("parse . render = id (" <> name <> ")") $ do - input <- arbitrary - let intermediate = fmap (decodeUtf8 . toByteString) $ runConduit $ render input .| renderBuilder def .| foldC - output = join $ runConduit $ render input .| parse - return $ counterexample (show input <> " | " <> show intermediate <> " | " <> show output) $ Just input == output - - skipHoursCase :: TestTree skipHoursCase = testCase "<skipHours> element" $ do result <- runResourceT . runConduit $ sourceList input .| XML.parseText' def .| force "ERROR" rssSkipHours @@ -279,7 +236,7 @@ result^.itemTitleL @?= "Processing Inclusions with XSLT" result^.itemLinkL @?= Just link result^.itemDescriptionL @?= "Processing document inclusions with general XML tools can be problematic. This article proposes a way of preserving inclusion information through SAX-based processing." - result^.itemExtensionsL @?= RssItemExtensions RNil + result^.itemExtensionsL @?= NoItemExtensions where input = [ "<item xmlns=\"http://purl.org/rss/1.0/\"" , "xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"" , "xmlns:dc=\"http://purl.org/dc/elements/1.1/\"" @@ -302,7 +259,7 @@ result^.itemLinkL @?= Just link result^.itemDescriptionL @?= "Here is some text containing an interesting description." result^.itemGuidL @?= Just (GuidText "7bd204c6-1655-4c27-aeee-53f933c5395f") - result^.itemExtensionsL @?= RssItemExtensions RNil + result^.itemExtensionsL @?= NoItemExtensions isJust (result^.itemPubDateL) @?= True where input = [ "<item>" , "<title>Example entry" @@ -324,7 +281,7 @@ result^.itemDescriptionL @?= "" result^.itemAuthorL @?= "author@w3schools.com" result^.itemGuidL @?= Nothing - result^.itemExtensionsL @?= RssItemExtensions RNil + result^.itemExtensionsL @?= NoItemExtensions isJust (result^.itemPubDateL) @?= True where input = [ "" , "Plop" @@ -364,7 +321,7 @@ result^?channelTextInputL._Just.textInputDescriptionL @?= Just "Search XML.com's XML collection" result^?channelTextInputL._Just.textInputNameL @?= Just "s" result^?channelTextInputL._Just.textInputLinkL @?= Just textInputLink - result^.channelExtensionsL @?= RssChannelExtensions RNil + result^.channelExtensionsL @?= NoChannelExtensions where input = [ "" , "" , "" @@ -411,7 +368,7 @@ dublinCoreChannelCase :: TestTree dublinCoreChannelCase = testCase "Dublin Core extension" $ do Just result <- runResourceT . runConduit $ sourceList input .| XML.parseText' def .| rssDocument - result^.channelExtensionsL @?= RssChannelExtensions (DublinCoreChannel dublinCoreElement :& RNil) + result^.channelExtensionsL @?= DublinCoreChannel dublinCoreElement NoChannelExtensions where input = [ "" , "" , "" @@ -439,7 +396,7 @@ dublinCoreItemCase :: TestTree dublinCoreItemCase = testCase "Dublin Core extension" $ do Just result <- runResourceT . runConduit $ sourceList input .| XML.parseText' def .| rssItem - result^.itemExtensionsL @?= RssItemExtensions (DublinCoreItem dublinCoreElement :& RNil) + result^.itemExtensionsL @?= DublinCoreItem dublinCoreElement NoItemExtensions where input = [ "" , "Example entry" , "XML is placing increasingly heavy loads on the existing technical " @@ -466,7 +423,7 @@ contentItemCase :: TestTree contentItemCase = testCase "Content extension" $ do Just result <- runResourceT . runConduit $ sourceList input .| XML.parseText' def .| rssItem - result^.itemExtensionsL @?= RssItemExtensions (ContentItem "

What a beautiful day!

" :& RNil) + result^.itemExtensionsL @?= ContentItem "

What a beautiful day!

" NoItemExtensions where input = [ "" , "Example entry" , "What a beautiful day!

]]>" @@ -476,7 +433,7 @@ syndicationChannelCase :: TestTree syndicationChannelCase = testCase "Syndication extension" $ do Just result <- runResourceT . runConduit $ sourceList input .| XML.parseText' def .| rssDocument - result^.channelExtensionsL @?= RssChannelExtensions (SyndicationChannel syndicationInfo :& RNil) + result^.channelExtensionsL @?= SyndicationChannel syndicationInfo NoChannelExtensions where input = [ "" , "" , "" @@ -498,7 +455,7 @@ atomChannelCase :: TestTree atomChannelCase = testCase "Atom extension" $ do Just result <- runResourceT . runConduit $ sourceList input .| XML.parseText' def .| rssDocument - result^.channelExtensionsL @?= RssChannelExtensions (AtomChannel (Just link) :& RNil) + result^.channelExtensionsL @?= AtomChannel (Just link) NoChannelExtensions where input = [ "" , "" , "" @@ -514,7 +471,7 @@ multipleExtensionsCase :: TestTree multipleExtensionsCase = testCase "Multiple extensions" $ do Just result <- runResourceT . runConduit $ sourceList input .| XML.parseText' def .| rssItem - result^.itemExtensionsL @?= RssItemExtensions (ContentItem "

What a beautiful day!

" :& AtomItem (Just link) :& RNil) + result^.itemExtensionsL @?= ContentItem "

What a beautiful day!

" (AtomItem (Just link) NoItemExtensions) where input = [ "" , "Example entry" @@ -524,30 +481,3 @@ ] url = AtomURI [uri|http://dallas.example.com/rss.xml|] link = AtomLink url "self" "application/rss+xml" mempty mempty mempty - - -roundtripTextInputProperty :: TestTree -roundtripTextInputProperty = testProperty "parse . render = id (RssTextInput)" $ \t -> either (const False) (t ==) (runConduit $ renderRssTextInput t .| force "ERROR" rssTextInput) - -roundtripImageProperty :: TestTree -roundtripImageProperty = testProperty "parse . render = id (RssImage)" $ \t -> either (const False) (t ==) (runConduit $ renderRssImage t .| force "ERROR" rssImage) - -roundtripCategoryProperty :: TestTree -roundtripCategoryProperty = testProperty "parse . render = id (RssCategory)" $ \t -> either (const False) (t ==) (runConduit $ renderRssCategory t .| force "ERROR" rssCategory) - -roundtripEnclosureProperty :: TestTree -roundtripEnclosureProperty = testProperty "parse . render = id (RssEnclosure)" $ \t -> either (const False) (t ==) (runConduit $ renderRssEnclosure t .| force "ERROR" rssEnclosure) - -roundtripSourceProperty :: TestTree -roundtripSourceProperty = testProperty "parse . render = id (RssSource)" $ \t -> either (const False) (t ==) (runConduit $ renderRssSource t .| force "ERROR" rssSource) - -roundtripGuidProperty :: TestTree -roundtripGuidProperty = testProperty "parse . render = id (RssGuid)" $ \t -> either (const False) (t ==) (runConduit $ renderRssGuid t .| force "ERROR" rssGuid) - -roundtripItemProperty :: TestTree -roundtripItemProperty = testProperty "parse . render = id (RssItem)" $ \(t :: RssItem '[]) -> either (const False) (t ==) (runConduit $ renderRssItem t .| force "ERROR" rssItem) - - -letter = choose ('a', 'z') -digit = arbitrary `suchThat` isDigit -alphaNum = oneof [letter, digit] diff --git a/test/QuickCheck.hs b/test/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/test/QuickCheck.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- {{{ Imports +import Text.RSS.Conduit.Parse as Parser +import Text.RSS.Conduit.Render as Renderer +import Text.RSS.Extensions +import Text.RSS.Extensions.Atom +import Text.RSS.Extensions.Content +import Text.RSS.Extensions.DublinCore +import Text.RSS.Extensions.Syndication +import Text.RSS.Lens +import Text.RSS.Types +import Text.RSS1.Conduit.Parse as Parser + +import Arbitrary +import Blaze.ByteString.Builder (toByteString) +import Conduit +import Control.Monad +import Data.Char +import Data.Conduit +import Data.Conduit.List +import Data.Maybe +import Data.String +import Data.Text (Text) +import Data.Text.Encoding +import qualified Data.Text.Lazy.Encoding as Lazy +import Data.Time.Calendar +import Data.Time.LocalTime +import Data.Version +import Data.Void +import Data.XML.Types +import Prelude () +import Prelude.Compat +import System.FilePath +import System.IO +import System.Timeout +import Test.Tasty +import Test.Tasty.QuickCheck +import Text.Atom.Conduit.Parse +import Text.Atom.Types +import Text.XML.Stream.Parse as XML hiding (choose) +import Text.XML.Stream.Render +import URI.ByteString +import URI.ByteString.QQ +-- }}} + +main :: IO () +main = defaultMain $ testGroup "Property tests" + [ roundtripProperty "RssTextInput" renderRssTextInput rssTextInput + , roundtripProperty "RssImage" renderRssImage rssImage + , roundtripProperty "RssCategory" renderRssCategory rssCategory + , roundtripProperty "RssEnclosure" renderRssEnclosure rssEnclosure + , roundtripProperty "RssSource" renderRssSource rssSource + , roundtripProperty "RssGuid" renderRssGuid rssGuid +-- , roundtripProperty "RssItem" +-- (renderRssItem :: RssItem '[] -> ConduitT () Event Maybe ()) +-- rssItem + , roundtripProperty "DublinCore" + (renderRssChannelExtension @(DublinCoreModule NoExtensions)) + (Just <$> parseRssChannelExtension) + , roundtripProperty "Syndication" + (renderRssChannelExtension @(SyndicationModule NoExtensions)) + (Just <$> parseRssChannelExtension) + , roundtripProperty "Atom" + (renderRssChannelExtension @(AtomModule NoExtensions)) + (Just <$> parseRssChannelExtension) + , roundtripProperty "Content" + (renderRssItemExtension @(ContentModule NoExtensions)) + (Just <$> parseRssItemExtension) + ] + + +roundtripProperty :: Eq a => Arbitrary a => Show a + => TestName -> (a -> ConduitT () Event Maybe ()) -> ConduitT Event Void Maybe (Maybe a) -> TestTree +roundtripProperty name render parse = testProperty ("parse . render = id (" <> name <> ")") $ do + input <- arbitrary + let intermediate = fmap (decodeUtf8 . toByteString) $ runConduit $ render input .| renderBuilder def .| foldC + output = join $ runConduit $ render input .| parse + return $ counterexample (show input <> " | " <> show intermediate <> " | " <> show output) $ Just input == output + +roundtripTextInputProperty :: TestTree +roundtripTextInputProperty = testProperty "parse . render = id (RssTextInput)" $ \t -> either (const False) (t ==) (runConduit $ renderRssTextInput t .| force "ERROR" rssTextInput) + +roundtripImageProperty :: TestTree +roundtripImageProperty = testProperty "parse . render = id (RssImage)" $ \t -> either (const False) (t ==) (runConduit $ renderRssImage t .| force "ERROR" rssImage) + +roundtripCategoryProperty :: TestTree +roundtripCategoryProperty = testProperty "parse . render = id (RssCategory)" $ \t -> either (const False) (t ==) (runConduit $ renderRssCategory t .| force "ERROR" rssCategory) + +roundtripEnclosureProperty :: TestTree +roundtripEnclosureProperty = testProperty "parse . render = id (RssEnclosure)" $ \t -> either (const False) (t ==) (runConduit $ renderRssEnclosure t .| force "ERROR" rssEnclosure) + +roundtripSourceProperty :: TestTree +roundtripSourceProperty = testProperty "parse . render = id (RssSource)" $ \t -> either (const False) (t ==) (runConduit $ renderRssSource t .| force "ERROR" rssSource) + +roundtripGuidProperty :: TestTree +roundtripGuidProperty = testProperty "parse . render = id (RssGuid)" $ \t -> either (const False) (t ==) (runConduit $ renderRssGuid t .| force "ERROR" rssGuid) + +roundtripItemProperty :: TestTree +roundtripItemProperty = testProperty "parse . render = id (RssItem)" $ \(t :: RssItem NoExtensions) -> either (const False) (t ==) (runConduit $ renderRssItem t .| force "ERROR" rssItem)