atom-conduit 0.6.0.0 → 0.7.0.0
raw patch · 17 files changed
+1359/−1100 lines, 17 filesdep +QuickCheckdep +base-nopreludedep +generic-randomdep −basedep ~refineddep ~xml-conduitPVP ok
version bump matches the API change (PVP)
Dependencies added: QuickCheck, base-noprelude, generic-random, prettyprinter, relude
Dependencies removed: base
Dependency ranges changed: refined, xml-conduit
API changes (from Hackage documentation)
- Text.Atom.Types: type Type = Text
+ Text.Atom.Types: type ContentType = Text
- Text.Atom.Lens: _AtomXHTMLText :: Applicative f => (Text -> f Text) -> AtomText -> f AtomText
+ Text.Atom.Lens: _AtomXHTMLText :: Applicative f => (Element -> f Element) -> AtomText -> f AtomText
- Text.Atom.Types: AtomContentInlineOther :: Type -> Text -> AtomContent
+ Text.Atom.Types: AtomContentInlineOther :: ContentType -> Text -> AtomContent
- Text.Atom.Types: AtomContentInlineXHTML :: Text -> AtomContent
+ Text.Atom.Types: AtomContentInlineXHTML :: Element -> AtomContent
- Text.Atom.Types: AtomContentOutOfLine :: Type -> AtomURI -> AtomContent
+ Text.Atom.Types: AtomContentOutOfLine :: ContentType -> AtomURI -> AtomContent
- Text.Atom.Types: AtomXHTMLText :: Text -> AtomText
+ Text.Atom.Types: AtomXHTMLText :: Element -> AtomText
Files
- LICENSE +118/−8
- Text/Atom/Conduit/Parse.hs +0/−359
- Text/Atom/Conduit/Render.hs +0/−142
- Text/Atom/Lens.hs +0/−90
- Text/Atom/Types.hs +0/−210
- atom-conduit.cabal +78/−41
- src/Prelude.hs +4/−0
- src/Text/Atom/Conduit/Parse.hs +356/−0
- src/Text/Atom/Conduit/Render.hs +141/−0
- src/Text/Atom/Lens.hs +90/−0
- src/Text/Atom/Types.hs +213/−0
- test/GoldenTests.hs +26/−0
- test/HLint.hs +1/−2
- test/Main.hs +0/−248
- test/Prelude.hs +4/−0
- test/QuickCheck.hs +230/−0
- test/UnitTests.hs +98/−0
LICENSE view
@@ -1,11 +1,121 @@-DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE-Version 2, December 2004+Creative Commons Legal Code -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.+CC0 1.0 Universal -DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE-TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION+ 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. -0. You just DO WHAT THE FUCK YOU WANT TO.+Statement of Purpose++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.
− Text/Atom/Conduit/Parse.hs
@@ -1,359 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}--- | Streaming parsers for the Atom 1.0 standard.-module Text.Atom.Conduit.Parse- ( -- * Top-level- atomFeed- -- * Elements- , atomEntry- , atomContent- , atomCategory- , atomLink- , atomGenerator- , atomSource- -- * Constructs- , atomPerson- , atomText- ) where---- {{{ Imports-import Blaze.ByteString.Builder (toByteString)-import Conduit (foldC, headC, headDefC, sinkList)-import Control.Applicative hiding (many)-import Control.Exception.Safe as Exception-import Control.Monad-import Control.Monad.Fix-import Data.Conduit-import Data.Maybe-import Data.Monoid-import Data.Text as Text (Text, unpack)-import Data.Text.Encoding-import Data.Time.Clock-import Data.Time.LocalTime-import Data.Time.RFC3339-import Data.XML.Types-import Lens.Simple-import Prelude-import Refined-import Text.Atom.Types-import Text.XML.Stream.Parse-import qualified Text.XML.Stream.Render as Render--import URI.ByteString--- }}}---- {{{ Util-data AtomException = InvalidDate Text- | InvalidURI URIParseError Text- | MissingElement Text- | NullElement--deriving instance Eq AtomException-deriving instance Show AtomException--instance Exception AtomException where- displayException (InvalidDate t) = "Invalid date: " <> unpack t- displayException (InvalidURI e t) = "Invalid URI reference: " <> show e <> " in " <> unpack t- displayException (MissingElement t) = "Missing element: " <> unpack t- displayException NullElement = "Null element"--asURIReference :: MonadThrow m => Text -> m AtomURI-asURIReference t = case (parseURI' t, parseRelativeRef' t) of- (Right u, _) -> return $ AtomURI u- (_, Right u) -> return $ AtomURI u- (Left _, Left e) -> throwM $ InvalidURI e t- where parseURI' = parseURI laxURIParserOptions . encodeUtf8- parseRelativeRef' = parseRelativeRef laxURIParserOptions . encodeUtf8--liftMaybe :: (MonadThrow m, Exception e) => e -> Maybe a -> m a-liftMaybe e = maybe (throw e) return---- | 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 && nameNamespace n == Just "http://www.w3.org/2005/Atom")---- | Tag which content is a date-time that follows RFC 3339 format.-tagDate :: MonadThrow m => Text -> ConduitM Event o m (Maybe UTCTime)-tagDate name = tagIgnoreAttrs' name $ do- text <- content- zonedTimeToUTC <$> liftMaybe (InvalidDate text) (parseTimeRFC3339 text)---- | Like 'tagName'' but ignores all attributes.-tagIgnoreAttrs' :: MonadThrow m => Text -> ConduitM Event o m a -> ConduitM Event o m (Maybe a)-tagIgnoreAttrs' name handler = tagName' name ignoreAttrs $ const handler--xhtmlContent :: MonadThrow m => ConduitM Event o m Text-xhtmlContent = fmap (decodeUtf8 . toByteString) $ many_ takeAnyTreeContent .| Render.renderBuilder def .| foldC---projectC :: Monad m => Fold a a' b b' -> ConduitT a b m ()-projectC prism = fix $ \recurse -> do- item <- await- case (item, item ^? (_Just . prism)) of- (_, Just a) -> yield a >> recurse- (Just _, _) -> recurse- _ -> return ()--headRequiredC :: MonadThrow m => Text -> ConduitT a o m a-headRequiredC e = liftMaybe (MissingElement e) =<< headC--atomId :: MonadThrow m => ConduitM Event o m (Maybe Text)-atomId = tagIgnoreAttrs' "id" content--atomIcon, atomLogo :: MonadThrow m => ConduitM Event o m (Maybe AtomURI)-atomIcon = tagIgnoreAttrs' "icon" $ content >>= asURIReference-atomLogo = tagIgnoreAttrs' "logo" $ content >>= asURIReference--- }}}---data PersonPiece = PersonName (Refined (Not Null) Text)- | PersonEmail Text- | PersonUri AtomURI--makeTraversals ''PersonPiece---- | Parse an Atom person construct.--- Example:------ > <author>--- > <name>John Doe</name>--- > <email>JohnDoe@example.com</email>--- > <uri>http://example.com/~johndoe</uri>--- > </author>-atomPerson :: MonadThrow m => Text -> ConduitM Event o m (Maybe AtomPerson)-atomPerson name = tagIgnoreAttrs' name $ (manyYield' (choose piece) .| parser) <* many ignoreAnyTreeContent where- parser = getZipConduit $ AtomPerson- <$> ZipConduit (projectC _PersonName .| headRequiredC "Missing or invalid <name> element")- <*> ZipConduit (projectC _PersonEmail .| headDefC "")- <*> ZipConduit (projectC _PersonUri .| headC)- piece = [ fmap PersonName <$> tagIgnoreAttrs' "name" (content >>= refineThrow)- , fmap PersonEmail <$> tagIgnoreAttrs' "email" content- , fmap PersonUri <$> tagIgnoreAttrs' "uri" (content >>= asURIReference)- ]----- | Parse an @atom:category@ element.--- Example:------ > <category term="sports"/>-atomCategory :: MonadThrow m => ConduitM Event o m (Maybe AtomCategory)-atomCategory = tagName' "category" categoryAttrs $ \(t, s, l) -> do- term <- refineThrow t- return $ AtomCategory term s l- where categoryAttrs = (,,) <$> requireAttr "term"- <*> (requireAttr "scheme" <|> pure mempty)- <*> (requireAttr "label" <|> pure mempty)- <* ignoreAttrs---- | Parse an @atom:content@ element.-atomContent :: MonadThrow m => ConduitM Event o m (Maybe AtomContent)-atomContent = tagName' "content" contentAttrs handler where- contentAttrs = (,) <$> optional (requireAttr "type") <*> optional (requireAttr "src" >>= asURIReference) <* ignoreAttrs- handler (Just "xhtml", _) = AtomContentInlineXHTML <$> force "<div>" (tagIgnoreAttrs "{http://www.w3.org/1999/xhtml}div" xhtmlContent)- handler (ctype, Just uri) = return $ AtomContentOutOfLine (fromMaybe mempty ctype) uri- handler (Just "html", _) = AtomContentInlineText TypeHTML <$> content- handler (Nothing, _) = AtomContentInlineText TypeText <$> content- handler (Just ctype, _) = AtomContentInlineOther ctype <$> content---- | Parse an @atom:link@ element.--- Examples:------ > <link rel="self" href="/feed" />------ > <link rel="alternate" href="/blog/1234"/>-atomLink :: MonadThrow m => ConduitM Event o m (Maybe AtomLink)-atomLink = tagName' "link" linkAttrs $ \(href, rel, ltype, lang, title, length') ->- return $ AtomLink href rel ltype lang title length'- where linkAttrs = (,,,,,) <$> (requireAttr "href" >>= asURIReference)- <*> (requireAttr "rel" <|> pure mempty)- <*> (requireAttr "type" <|> pure mempty)- <*> (requireAttr "hreflang" <|> pure mempty)- <*> (requireAttr "title" <|> pure mempty)- <*> (requireAttr "length" <|> pure mempty)- <* ignoreAttrs---- | Parse an Atom text construct.--- Examples:------ > <title type="text">AT&T bought by SBC!</title>------ > <title type="html">--- > AT&amp;T bought <b>by SBC</b>!--- > </title>------ > <title type="xhtml">--- > <div xmlns="http://www.w3.org/1999/xhtml">--- > AT&T bought <b>by SBC</b>!--- > </div>--- > </title>-atomText :: MonadThrow m => Text -> ConduitM Event o m (Maybe AtomText)-atomText name = tagName' name (optional (requireAttr "type") <* ignoreAttrs) handler- where handler (Just "xhtml") = AtomXHTMLText <$> force "<div>" (tagIgnoreAttrs "{http://www.w3.org/1999/xhtml}div" xhtmlContent)- handler (Just "html") = AtomPlainText TypeHTML <$> content- handler _ = AtomPlainText TypeText <$> content---- | Parse an @atom:generator@ element.--- Example:------ > <generator uri="/myblog.php" version="1.0">--- > Example Toolkit--- > </generator>-atomGenerator :: MonadThrow m => ConduitM Event o m (Maybe AtomGenerator)-atomGenerator = tagName' "generator" generatorAttrs $ \(uri, version) -> AtomGenerator uri version <$> (refineThrow =<< content)- where generatorAttrs = (,) <$> optional (requireAttr "uri" >>= asURIReference) <*> (requireAttr "version" <|> pure mempty) <* ignoreAttrs---data SourcePiece = SourceAuthor AtomPerson- | SourceCategory AtomCategory- | SourceContributor AtomPerson- | SourceGenerator AtomGenerator- | SourceIcon AtomURI- | SourceId Text- | SourceLink AtomLink- | SourceLogo AtomURI- | SourceRights AtomText- | SourceSubtitle AtomText- | SourceTitle AtomText- | SourceUpdated UTCTime--makeTraversals ''SourcePiece---- | Parse an @atom:source@ element.--- Example:------ > <source>--- > <id>http://example.org/</id>--- > <title>Fourty-Two</title>--- > <updated>2003-12-13T18:30:02Z</updated>--- > <rights>© 2005 Example, Inc.</rights>--- > </source>-atomSource :: MonadThrow m => ConduitM Event o m (Maybe AtomSource)-atomSource = tagIgnoreAttrs' "source" $ manyYield' (choose piece) .| zipConduit where- zipConduit = getZipConduit $ AtomSource- <$> ZipConduit (projectC _SourceAuthor .| sinkList)- <*> ZipConduit (projectC _SourceCategory .| sinkList)- <*> ZipConduit (projectC _SourceContributor .| sinkList)- <*> ZipConduit (projectC _SourceGenerator .| headC)- <*> ZipConduit (projectC _SourceIcon .| headC)- <*> ZipConduit (projectC _SourceId .| headDefC "")- <*> ZipConduit (projectC _SourceLink .| sinkList)- <*> ZipConduit (projectC _SourceLogo .| headC)- <*> ZipConduit (projectC _SourceRights .| headC)- <*> ZipConduit (projectC _SourceSubtitle .| headC)- <*> ZipConduit (projectC _SourceTitle .| headC)- <*> ZipConduit (projectC _SourceUpdated .| headC)- piece = [ fmap SourceAuthor <$> atomPerson "author"- , fmap SourceCategory <$> atomCategory- , fmap SourceContributor <$> atomPerson "contributor"- , fmap SourceGenerator <$> atomGenerator- , fmap SourceIcon <$> atomIcon- , fmap SourceId <$> atomId- , fmap SourceLink <$> atomLink- , fmap SourceLogo <$> atomLogo- , fmap SourceRights <$> atomText "rights"- , fmap SourceSubtitle <$> atomText "subtitle"- , fmap SourceTitle <$> atomText "title"- , fmap SourceUpdated <$> tagDate "updated"- ]---data EntryPiece = EntryAuthor AtomPerson- | EntryCategory AtomCategory- | EntryContent AtomContent- | EntryContributor AtomPerson- | EntryId Text- | EntryLink AtomLink- | EntryPublished UTCTime- | EntryRights AtomText- | EntrySource AtomSource- | EntrySummary AtomText- | EntryTitle AtomText- | EntryUpdated UTCTime--makeTraversals ''EntryPiece---- | Parse an @atom:entry@ element.-atomEntry :: MonadThrow m => ConduitM Event o m (Maybe AtomEntry)-atomEntry = tagIgnoreAttrs' "entry" $ manyYield' (choose piece) .| zipConduit where- zipConduit = getZipConduit $ AtomEntry- <$> ZipConduit (projectC _EntryAuthor .| sinkList)- <*> ZipConduit (projectC _EntryCategory .| sinkList)- <*> ZipConduit (projectC _EntryContent .| headC)- <*> ZipConduit (projectC _EntryContributor .| sinkList)- <*> ZipConduit (projectC _EntryId .| headRequiredC "Missing <id> element")- <*> ZipConduit (projectC _EntryLink .| sinkList)- <*> ZipConduit (projectC _EntryPublished .| headC)- <*> ZipConduit (projectC _EntryRights .| headC)- <*> ZipConduit (projectC _EntrySource .| headC)- <*> ZipConduit (projectC _EntrySummary .| headC)- <*> ZipConduit (projectC _EntryTitle .| headRequiredC "Missing or invalid <title> element.")- <*> ZipConduit (projectC _EntryUpdated .| headRequiredC "Missing or invalid <updated> element.")- piece = [ fmap EntryAuthor <$> atomPerson "author"- , fmap EntryCategory <$> atomCategory- , fmap EntryContent <$> atomContent- , fmap EntryContributor <$> atomPerson "contributor"- , fmap EntryId <$> atomId- , fmap EntryLink <$> atomLink- , fmap EntryPublished <$> tagDate "published"- , fmap EntryRights <$> atomText "rights"- , fmap EntrySource <$> atomSource- , fmap EntrySummary <$> atomText "summary"- , fmap EntryTitle <$> atomText "title"- , fmap EntryUpdated <$> tagDate "updated"- ]---data FeedPiece = FeedAuthor AtomPerson- | FeedCategory AtomCategory- | FeedContributor AtomPerson- | FeedEntry AtomEntry- | FeedGenerator AtomGenerator- | FeedIcon AtomURI- | FeedId Text- | FeedLink AtomLink- | FeedLogo AtomURI- | FeedRights AtomText- | FeedSubtitle AtomText- | FeedTitle AtomText- | FeedUpdated UTCTime--makeTraversals ''FeedPiece---- | Parse an @atom:feed@ element.-atomFeed :: MonadThrow m => ConduitM Event o m (Maybe AtomFeed)-atomFeed = tagIgnoreAttrs' "feed" $ manyYield' (choose piece) .| zipConduit where- zipConduit = getZipConduit $ AtomFeed- <$> ZipConduit (projectC _FeedAuthor .| sinkList)- <*> ZipConduit (projectC _FeedCategory .| sinkList)- <*> ZipConduit (projectC _FeedContributor .| sinkList)- <*> ZipConduit (projectC _FeedEntry .| sinkList)- <*> ZipConduit (projectC _FeedGenerator .| headC)- <*> ZipConduit (projectC _FeedIcon .| headC)- <*> ZipConduit (projectC _FeedId .| headRequiredC "Missing <id> element")- <*> ZipConduit (projectC _FeedLink .| sinkList)- <*> ZipConduit (projectC _FeedLogo .| headC)- <*> ZipConduit (projectC _FeedRights .| headC)- <*> ZipConduit (projectC _FeedSubtitle .| headC)- <*> ZipConduit (projectC _FeedTitle .| headRequiredC "Missing <title> element.")- <*> ZipConduit (projectC _FeedUpdated .| headRequiredC "Missing <updated> element.")- piece = [ fmap FeedAuthor <$> atomPerson "author"- , fmap FeedCategory <$> atomCategory- , fmap FeedContributor <$> atomPerson "contributor"- , fmap FeedEntry <$> atomEntry- , fmap FeedGenerator <$> atomGenerator- , fmap FeedIcon <$> atomIcon- , fmap FeedId <$> atomId- , fmap FeedLink <$> atomLink- , fmap FeedLogo <$> atomLogo- , fmap FeedRights <$> atomText "rights"- , fmap FeedSubtitle <$> atomText "subtitle"- , fmap FeedTitle <$> atomText "title"- , fmap FeedUpdated <$> tagDate "updated"- ]
− Text/Atom/Conduit/Render.hs
@@ -1,142 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}--- | Streaming renderers for the Atom 1.0 standard.-module Text.Atom.Conduit.Render- ( -- * Top-level- renderAtomFeed- -- * Elements- , renderAtomEntry- , renderAtomContent- , renderAtomSource- , renderAtomGenerator- , renderAtomLink- , renderAtomCategory- -- * Constructs- , renderAtomPerson- , renderAtomText- ) where---- {{{ Imports-import Text.Atom.Lens-import Text.Atom.Types--import Control.Monad-import Data.Conduit-import Data.Monoid-import Data.Text as Text-import Data.Text.Encoding-import Data.Time.Clock-import Data.Time.LocalTime-import Data.Time.RFC3339-import Data.XML.Types-import Lens.Simple-import Refined-import Text.XML.Stream.Render-import URI.ByteString--- }}}---- | Render the top-level @atom:feed@ element.-renderAtomFeed :: (Monad m) => AtomFeed -> ConduitT () Event m ()-renderAtomFeed f = atomTag "feed" (attr "xmlns" "http://www.w3.org/2005/Atom") $ do- forM_ (f^.feedAuthorsL) $ renderAtomPerson "author"- forM_ (f^.feedCategoriesL) renderAtomCategory- forM_ (f^.feedContributorsL) $ renderAtomPerson "contributor"- forM_ (f^.feedEntriesL) renderAtomEntry- forM_ (f^.feedGeneratorL) renderAtomGenerator- forM_ (feedIcon f) $ atomTag "icon" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'- atomTag "id" mempty . content $ f^.feedIdL- forM_ (f^.feedLinksL) renderAtomLink- forM_ (feedLogo f) $ atomTag "logo" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'- forM_ (f^.feedRightsL) $ renderAtomText "rights"- forM_ (f^.feedSubtitleL) $ renderAtomText "subtitle"- renderAtomText "title" $ f^.feedTitleL- dateTag "updated" $ f^.feedUpdatedL---- | Render an @atom:entry@ element.-renderAtomEntry :: (Monad m) => AtomEntry -> ConduitT () Event m ()-renderAtomEntry e = atomTag "entry" mempty $ do- forM_ (e^.entryAuthorsL) $ renderAtomPerson "author"- forM_ (e^.entryCategoriesL) renderAtomCategory- forM_ (e^.entryContentL) renderAtomContent- forM_ (e^.entryContributorsL) $ renderAtomPerson "contributor"- atomTag "id" mempty . content $ e^.entryIdL- forM_ (e^.entryLinksL) renderAtomLink- forM_ (e^.entryPublishedL) $ dateTag "published"- forM_ (e^.entryRightsL) $ renderAtomText "rights"- forM_ (e^.entrySourceL) renderAtomSource- forM_ (e^.entrySummaryL) $ renderAtomText "summary"- renderAtomText "title" (e^.entryTitleL)- dateTag "updated" (e^.entryUpdatedL)---- | Render an @atom:content@ element.-renderAtomContent :: (Monad m) => AtomContent -> ConduitT () Event m ()-renderAtomContent (AtomContentInlineXHTML t) = atomTag "content" (attr "type" "xhtml")- . tag "{http://www.w3.org/1999/xhtml}div" mempty $ content t-renderAtomContent (AtomContentOutOfLine ctype uri) = atomTag "content" (nonEmptyAttr "type" ctype <> attr "src" (decodeUtf8 $ withAtomURI serializeURIRef' uri)) $ return ()-renderAtomContent (AtomContentInlineText TypeHTML t) = atomTag "content" (attr "type" "html") $ content t-renderAtomContent (AtomContentInlineText TypeText t) = atomTag "content" mempty $ content t-renderAtomContent (AtomContentInlineOther ctype t) = atomTag "content" (attr "type" ctype) $ content t---- | Render an @atom:source@ element.-renderAtomSource :: (Monad m) => AtomSource -> ConduitT () Event m ()-renderAtomSource s = atomTag "source" mempty $ do- forM_ (s^.sourceAuthorsL) $ renderAtomPerson "author"- forM_ (s^.sourceCategoriesL) renderAtomCategory- forM_ (s^.sourceContributorsL) $ renderAtomPerson "contributor"- forM_ (s^.sourceGeneratorL) renderAtomGenerator- forM_ (sourceIcon s) $ atomTag "icon" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'- unless (Text.null $ s^.sourceIdL) . atomTag "id" mempty . content $ s^.sourceIdL- forM_ (s^.sourceLinksL) renderAtomLink- forM_ (sourceLogo s) $ atomTag "logo" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'- forM_ (s^.sourceRightsL) $ renderAtomText "rights"- forM_ (s^.sourceSubtitleL) $ renderAtomText "subtitle"- forM_ (s^.sourceTitleL) $ renderAtomText "title"- forM_ (s^.sourceUpdatedL) $ dateTag "updated"---- | Render an @atom:generator@ element.-renderAtomGenerator :: (Monad m) => AtomGenerator -> ConduitT () Event m ()-renderAtomGenerator g = atomTag "generator" attributes . content . unrefine $ g^.generatorContentL- where attributes = optionalAttr "uri" (decodeUtf8 . withAtomURI serializeURIRef' <$> generatorUri g)- <> nonEmptyAttr "version" (g^.generatorVersionL)---- | Render an @atom:link@ element.-renderAtomLink :: (Monad m) => AtomLink -> ConduitT () Event m ()-renderAtomLink l = atomTag "link" linkAttrs $ return ()- where linkAttrs = attr "href" (decodeUtf8 . withAtomURI serializeURIRef' $ linkHref l)- <> nonEmptyAttr "rel" (l^.linkRelL)- <> nonEmptyAttr "type" (l^.linkTypeL)- <> nonEmptyAttr "hreflang" (l^.linkLangL)- <> nonEmptyAttr "title" (l^.linkTitleL)- <> nonEmptyAttr "length" (l^.linkLengthL)---- | Render an @atom:category@ element.-renderAtomCategory :: (Monad m) => AtomCategory -> ConduitT () Event m ()-renderAtomCategory c = atomTag "category" attributes $ return ()- where attributes = attr "term" (unrefine $ c^.categoryTermL)- <> nonEmptyAttr "scheme" (c^.categorySchemeL)- <> nonEmptyAttr "label" (c^.categoryLabelL)---- | Render an atom person construct.-renderAtomPerson :: (Monad m) => Text -> AtomPerson -> ConduitT () Event m ()-renderAtomPerson name p = atomTag name mempty $ do- atomTag "name" mempty . content . unrefine $ p^.personNameL- unless (Text.null $ p^.personEmailL) $ atomTag "email" mempty . content $ p^.personEmailL- forM_ (personUri p) $ atomTag "uri" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'---- | Render an atom text construct.-renderAtomText :: (Monad m) => Text -> AtomText -> ConduitT () Event m ()-renderAtomText name (AtomXHTMLText t) = atomTag name (attr "type" "xhtml")- . tag "{http://www.w3.org/1999/xhtml}div" mempty $ content t-renderAtomText name (AtomPlainText TypeHTML t) = atomTag name (attr "type" "html") $ content t-renderAtomText name (AtomPlainText TypeText t) = atomTag name mempty $ content t--atomTag :: Monad m => Text -> Attributes -> ConduitT () Event m () -> ConduitT () Event m ()-atomTag name = tag (Name name (Just "http://www.w3.org/2005/Atom") (Just "atom"))--dateTag :: (Monad m) => Text -> UTCTime -> ConduitT () Event m ()-dateTag name = atomTag name mempty . content . formatTimeRFC3339 . utcToZonedTime utc--nonEmptyAttr :: Name -> Text -> Attributes-nonEmptyAttr name value- | value == mempty = mempty- | otherwise = attr name value
− Text/Atom/Lens.hs
@@ -1,90 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-module Text.Atom.Lens (module Text.Atom.Lens) where---- {{{ Imports-import Lens.Simple--import Text.Atom.Types--import URI.ByteString--- }}}--makeLensesFor- [ ("categoryTerm", "categoryTermL")- , ("categoryScheme", "categorySchemeL")- , ("categoryLabel", "categoryLabelL")- ] ''AtomCategory--makeLensesFor- [ ("entryAuthors", "entryAuthorsL")- , ("entryCategories", "entryCategoriesL")- , ("entryContent", "entryContentL")- , ("entryContributors", "entryContributorsL")- , ("entryId", "entryIdL")- , ("entryLinks", "entryLinksL")- , ("entryPublished", "entryPublishedL")- , ("entryRights", "entryRightsL")- , ("entrySource", "entrySourceL")- , ("entrySummary", "entrySummaryL")- , ("entryTitle", "entryTitleL")- , ("entryUpdated", "entryUpdatedL")- ] ''AtomEntry---makeLensesFor- [ ("feedAuthors", "feedAuthorsL")- , ("feedCategories", "feedCategoriesL")- , ("feedContributors", "feedContributorsL")- , ("feedEntries", "feedEntriesL")- , ("feedGenerator", "feedGeneratorL")- , ("feedIcon", "feedIconL")- , ("feedId", "feedIdL")- , ("feedLinks", "feedLinksL")- , ("feedLogo", "feedLogoL")- , ("feedRights", "feedRightsL")- , ("feedSubtitle", "feedSubtitleL")- , ("feedTitle", "feedTitleL")- , ("feedUpdated", "feedUpdatedL")- ] ''AtomFeed--makeLensesFor- [ ("generatorVersion", "generatorVersionL")- , ("generatorContent", "generatorContentL")- , ("generatorUri", "generatorUriL")- ] ''AtomGenerator--makeLensesFor- [ ("linkHref", "linkHrefL")- , ("linkType", "linkTypeL")- , ("linkRel", "linkRelL")- , ("linkLang", "linkLangL")- , ("linkTitle", "linkTitleL")- , ("linkLength", "linkLengthL")- ] ''AtomLink--makeLensesFor- [ ("personName", "personNameL")- , ("personEmail", "personEmailL")- , ("personUri", "personUriL")- ] ''AtomPerson----personUriL :: Traversal' AtomPerson (URIRef a)---personUriL inj a@AtomPerson { personUri = u } = (\x -> a { personUri = x }) <$> traverse inj u--makeLensesFor- [ ("sourceAuthors", "sourceAuthorsL")- , ("sourceCategories", "sourceCategoriesL")- , ("sourceContributors", "sourceContributorsL")- , ("sourceGenerator", "sourceGeneratorL")- -- , ("sourceIcon"- , ("sourceId", "sourceIdL")- , ("sourceLinks", "sourceLinksL")- , ("sourceLogo", "sourceLogoL")- , ("sourceRights", "sourceRightsL")- , ("sourceSubtitle", "sourceSubtitleL")- , ("sourceTitle", "sourceTitleL")- , ("sourceUpdated", "sourceUpdatedL")- ] ''AtomSource--makeTraversals ''AtomText
− Text/Atom/Types.hs
@@ -1,210 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}--- | Atom is an XML-based Web content and metadata syndication format.------ Example:------ > <?xml version="1.0" encoding="utf-8"?>--- > <feed xmlns="http://www.w3.org/2005/Atom">--- >--- > <title>Example Feed</title>--- > <link href="http://example.org/"/>--- > <updated>2003-12-13T18:30:02Z</updated>--- > <author>--- > <name>John Doe</name>--- > </author>--- > <id>urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6</id>--- >--- > <entry>--- > <title>Atom-Powered Robots Run Amok</title>--- > <link href="http://example.org/2003/12/13/atom03"/>--- > <id>urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a</id>--- > <updated>2003-12-13T18:30:02Z</updated>--- > <summary>Some text.</summary>--- > </entry>--- >--- > </feed>-module Text.Atom.Types (module Text.Atom.Types) where---- {{{ Imports-import Control.Monad-import Data.Text as Text-import Data.Time.Clock-import Data.Time.LocalTime ()-import Data.Typeable-import GHC.Generics-import Refined-import URI.ByteString--- }}}---- | 'Predicate' on 'Text', true iff text is null.-data Null deriving(Typeable)--instance Predicate Null Text where- validate p value = unless (Text.null value) $ throwRefine $ RefineOtherException (typeOf p) "Text is not null"--data AtomURI = forall a . AtomURI (URIRef a)--withAtomURI :: (forall a . URIRef a -> b) -> AtomURI -> b-withAtomURI f (AtomURI a) = f a---instance Eq AtomURI where- AtomURI a@URI{} == AtomURI b@URI{} = a == b- AtomURI a@RelativeRef{} == AtomURI b@RelativeRef{} = a == b- _ == _ = False-instance Ord AtomURI where- AtomURI a@URI{} `compare` AtomURI b@URI{} = a `compare` b- AtomURI a@RelativeRef{} `compare` AtomURI b@RelativeRef{} = a `compare` b- AtomURI a@URI{} `compare` _ = LT- AtomURI a@RelativeRef{} `compare` b = b `compare` AtomURI a-instance Show AtomURI where- show (AtomURI a@URI{}) = show a- show (AtomURI a@RelativeRef{}) = show a---data TextType = TypeText | TypeHTML- deriving(Eq, Ord, Generic, Show)---- | An atom text construct.-data AtomText = AtomPlainText TextType Text- | AtomXHTMLText Text -- ^ XHTML special characters will be in encoded form--deriving instance Eq AtomText-deriving instance Ord AtomText-deriving instance Generic AtomText-deriving instance Show AtomText---- | An atom person construct.-data AtomPerson = AtomPerson- { personName :: Refined (Not Null) Text- , personEmail :: Text- , personUri :: Maybe AtomURI- }--deriving instance Eq AtomPerson-deriving instance Ord AtomPerson-deriving instance Generic AtomPerson--- deriving instance Read AtomPerson-deriving instance Show AtomPerson---- | The @atom:category@ element.-data AtomCategory = AtomCategory- { categoryTerm :: Refined (Not Null) Text- , categoryScheme :: Text- , categoryLabel :: Text- }--deriving instance Eq AtomCategory-deriving instance Ord AtomCategory-deriving instance Generic AtomCategory-deriving instance Show AtomCategory---- | The @atom:link@ element.-data AtomLink = AtomLink- { linkHref :: AtomURI- , linkRel :: Text- , linkType :: Text- , linkLang :: Text- , linkTitle :: Text- , linkLength :: Text- }--deriving instance Eq AtomLink-deriving instance Ord AtomLink-deriving instance Generic AtomLink-deriving instance Show AtomLink---- | The @atom:generator@ element.-data AtomGenerator = AtomGenerator- { generatorUri :: Maybe AtomURI- , generatorVersion :: Text- , generatorContent :: Refined (Not Null) Text- }--deriving instance Eq AtomGenerator-deriving instance Ord AtomGenerator-deriving instance Generic AtomGenerator-deriving instance Show AtomGenerator---- | The @atom:source@ element.-data AtomSource = AtomSource- { sourceAuthors :: [AtomPerson]- , sourceCategories :: [AtomCategory]- , sourceContributors :: [AtomPerson]- , sourceGenerator :: Maybe AtomGenerator- , sourceIcon :: Maybe AtomURI- , sourceId :: Text- , sourceLinks :: [AtomLink]- , sourceLogo :: Maybe AtomURI- , sourceRights :: Maybe AtomText- , sourceSubtitle :: Maybe AtomText- , sourceTitle :: Maybe AtomText- , sourceUpdated :: Maybe UTCTime- }--deriving instance Eq AtomSource-deriving instance Ord AtomSource-deriving instance Generic AtomSource-deriving instance Show AtomSource--type Type = Text---- | The @atom:content@ element.-data AtomContent = AtomContentInlineText TextType Text- | AtomContentInlineXHTML Text- | AtomContentInlineOther Type Text- | AtomContentOutOfLine Type AtomURI--deriving instance Eq AtomContent-deriving instance Ord AtomContent-deriving instance Generic AtomContent-deriving instance Show AtomContent---- | The @atom:entry@ element.-data AtomEntry = AtomEntry- { entryAuthors :: [AtomPerson]- , entryCategories :: [AtomCategory]- , entryContent :: Maybe AtomContent- , entryContributors :: [AtomPerson]- , entryId :: Text- , entryLinks :: [AtomLink]- , entryPublished :: Maybe UTCTime- , entryRights :: Maybe AtomText- , entrySource :: Maybe AtomSource- , entrySummary :: Maybe AtomText- , entryTitle :: AtomText- , entryUpdated :: UTCTime- }--deriving instance Eq AtomEntry-deriving instance Ord AtomEntry-deriving instance Generic AtomEntry-deriving instance Show AtomEntry---- | The @atom:feed@ element.-data AtomFeed = AtomFeed- { feedAuthors :: [AtomPerson]- , feedCategories :: [AtomCategory]- , feedContributors :: [AtomPerson]- , feedEntries :: [AtomEntry]- , feedGenerator :: Maybe AtomGenerator- , feedIcon :: Maybe AtomURI- , feedId :: Text- , feedLinks :: [AtomLink]- , feedLogo :: Maybe AtomURI- , feedRights :: Maybe AtomText- , feedSubtitle :: Maybe AtomText- , feedTitle :: AtomText- , feedUpdated :: UTCTime- }--deriving instance Eq AtomFeed-deriving instance Ord AtomFeed-deriving instance Generic AtomFeed-deriving instance Show AtomFeed
atom-conduit.cabal view
@@ -1,14 +1,16 @@+cabal-version: 2.2 name: atom-conduit-version: 0.6.0.0-cabal-version: >=1.10+version: 0.7.0.0 build-type: Simple-license: PublicDomain+license: CC0-1.0 license-file: LICENSE-maintainer: koral+author: koral+maintainer: chahine.moreau@gmail.com+bug-reports: https://github.com/k0ral/atom-conduit/issues synopsis: Streaming parser/renderer for the Atom 1.0 standard (RFC 4287). description: Cf README. category: XML, Conduit-author: koral+tested-with: GHC <8.8 && >=8.4 extra-source-files: README.md @@ -21,66 +23,101 @@ manual: True default: False +common common+ build-depends:+ base-noprelude >=4.7 && <5,+ relude+ default-language: Haskell2010+ other-modules:+ Prelude++ library+ import: common exposed-modules: Text.Atom.Conduit.Parse Text.Atom.Conduit.Render Text.Atom.Lens Text.Atom.Types build-depends:- base >=4.9 && <5,- blaze-builder -any,+ blaze-builder, conduit >=1.3,- safe-exceptions -any,- lens-simple -any,- parsers -any,- refined -any,- text -any,+ safe-exceptions,+ lens-simple,+ parsers,+ prettyprinter,+ refined >=0.2,+ text, time >=1.5, timerep >=2.0, uri-bytestring >=0.2,- xml-conduit >=1.5,- xml-types -any- default-language: Haskell2010+ xml-conduit >=1.9,+ xml-types+ hs-source-dirs: src -test-suite Tests+test-suite quickcheck+ import: common type: exitcode-stdio-1.0- main-is: Main.hs+ main-is: QuickCheck.hs build-depends:- atom-conduit -any,- base >=4.9,- blaze-builder -any,+ atom-conduit, conduit >=1.3,- data-default -any,- filepath -any,- lens-simple -any,- parsers -any,- pretty-simple -any,- quickcheck-instances -any,- refined -any,- resourcet -any,- safe-exceptions -any,- tasty -any,- tasty-golden -any,- tasty-hunit -any,- tasty-quickcheck -any,+ generic-random,+ QuickCheck,+ quickcheck-instances,+ refined >=0.2,+ tasty,+ tasty-quickcheck, time >=1.5,- text -any,+ text, uri-bytestring >=0.2,- xml-conduit >=1.4,- xml-types -any- default-language: Haskell2010+ xml-conduit >=1.9,+ xml-types hs-source-dirs: test +test-suite golden+ import: common+ type: exitcode-stdio-1.0+ main-is: GoldenTests.hs+ build-depends:+ atom-conduit,+ conduit >=1.3,+ data-default,+ filepath,+ pretty-simple,+ resourcet,+ tasty,+ tasty-golden,+ text,+ xml-conduit >=1.9+ hs-source-dirs: test++test-suite unit+ import: common+ type: exitcode-stdio-1.0+ main-is: UnitTests.hs+ build-depends:+ atom-conduit,+ conduit >=1.3,+ data-default,+ lens-simple,+ refined >=0.2,+ resourcet,+ tasty,+ tasty-hunit,+ time >=1.5,+ uri-bytestring >=0.2,+ xml-conduit >=1.9,+ xml-types+ hs-source-dirs: test+ 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 hs-source-dirs: test
+ src/Prelude.hs view
@@ -0,0 +1,4 @@+module Prelude (module Relude, module Relude.Extra.Map) where++import Relude hiding (Predicate, force, many)+import Relude.Extra.Map (lookup)
+ src/Text/Atom/Conduit/Parse.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+-- | Streaming parsers for the Atom 1.0 standard.+module Text.Atom.Conduit.Parse+ ( -- * Top-level+ atomFeed+ -- * Elements+ , atomEntry+ , atomContent+ , atomCategory+ , atomLink+ , atomGenerator+ , atomSource+ -- * Constructs+ , atomPerson+ , atomText+ ) where++-- {{{ Imports+import Blaze.ByteString.Builder (toByteString)+import Conduit+import Control.Applicative hiding (many)+import Control.Exception.Safe as Exception+import Control.Monad+import Control.Monad.Fix+import Data.Maybe+import Data.Monoid+import Data.Text as Text (Text, unpack)+import Data.Time.Clock+import Data.Time.LocalTime+import Data.Time.RFC3339+import Data.XML.Types as XML+import Lens.Simple+import Refined+import Text.Atom.Types+import Text.XML.Stream.Parse+import qualified Text.XML.Stream.Render as Render+import qualified Text.XML.Unresolved as Unresolved++import URI.ByteString+-- }}}++-- {{{ Util+data AtomException = InvalidDate Text+ | InvalidURI URIParseError Text+ | MissingElement Text++deriving instance Eq AtomException+deriving instance Show AtomException++instance Exception AtomException where+ displayException (InvalidDate t) = "Invalid date: " <> unpack t+ displayException (InvalidURI e t) = "Invalid URI reference: " <> show e <> " in " <> unpack t+ displayException (MissingElement t) = "Missing element: " <> unpack t++asURIReference :: MonadThrow m => Text -> m AtomURI+asURIReference t = case (parseURI' t, parseRelativeRef' t) of+ (Right u, _) -> return $ AtomURI u+ (_, Right u) -> return $ AtomURI u+ (Left _, Left e) -> throw $ InvalidURI e t+ where parseURI' = parseURI laxURIParserOptions . encodeUtf8+ parseRelativeRef' = parseRelativeRef laxURIParserOptions . encodeUtf8++liftMaybe :: (MonadThrow m, Exception e) => e -> Maybe a -> m a+liftMaybe e = maybe (throw e) return++-- | 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 && nameNamespace n == Just "http://www.w3.org/2005/Atom")++-- | Tag which content is a date-time that follows RFC 3339 format.+tagDate :: MonadThrow m => Text -> ConduitM Event o m (Maybe UTCTime)+tagDate name = tagIgnoreAttrs' name $ do+ text <- content+ zonedTimeToUTC <$> liftMaybe (InvalidDate text) (parseTimeRFC3339 text)++-- | Like 'tagName'' but ignores all attributes.+tagIgnoreAttrs' :: MonadThrow m => Text -> ConduitM Event o m a -> ConduitM Event o m (Maybe a)+tagIgnoreAttrs' name handler = tagName' name ignoreAttrs $ const handler++xhtmlContent :: MonadThrow m => ConduitM Event o m XML.Element+xhtmlContent = force "element" $ many_ takeAnyTreeContent .| mapC (Nothing, ) .| Unresolved.elementFromEvents+++projectC :: Monad m => Fold a a' b b' -> ConduitT a b m ()+projectC prism = fix $ \recurse -> do+ item <- await+ case (item, item ^? (_Just . prism)) of+ (_, Just a) -> yield a >> recurse+ (Just _, _) -> recurse+ _ -> return ()++headRequiredC :: MonadThrow m => Text -> ConduitT a o m a+headRequiredC e = liftMaybe (MissingElement e) =<< headC++atomId :: MonadThrow m => ConduitM Event o m (Maybe Text)+atomId = tagIgnoreAttrs' "id" content++atomIcon, atomLogo :: MonadThrow m => ConduitM Event o m (Maybe AtomURI)+atomIcon = tagIgnoreAttrs' "icon" $ content >>= asURIReference+atomLogo = tagIgnoreAttrs' "logo" $ content >>= asURIReference+-- }}}+++data PersonPiece = PersonName (Refined (Not Null) Text)+ | PersonEmail Text+ | PersonUri AtomURI++makeTraversals ''PersonPiece++-- | Parse an Atom person construct.+-- Example:+--+-- > <author>+-- > <name>John Doe</name>+-- > <email>JohnDoe@example.com</email>+-- > <uri>http://example.com/~johndoe</uri>+-- > </author>+atomPerson :: MonadThrow m => Text -> ConduitM Event o m (Maybe AtomPerson)+atomPerson name = tagIgnoreAttrs' name $ (manyYield' (choose piece) .| parser) <* many ignoreAnyTreeContent where+ parser = getZipConduit $ AtomPerson+ <$> ZipConduit (projectC _PersonName .| headRequiredC "Missing or invalid <name> element")+ <*> ZipConduit (projectC _PersonEmail .| headDefC "")+ <*> ZipConduit (projectC _PersonUri .| headC)+ piece = [ fmap PersonName <$> tagIgnoreAttrs' "name" (content >>= refineThrow)+ , fmap PersonEmail <$> tagIgnoreAttrs' "email" content+ , fmap PersonUri <$> tagIgnoreAttrs' "uri" (content >>= asURIReference)+ ]+++-- | Parse an @atom:category@ element.+-- Example:+--+-- > <category term="sports"/>+atomCategory :: MonadThrow m => ConduitM Event o m (Maybe AtomCategory)+atomCategory = tagName' "category" categoryAttrs $ \(t, s, l) -> do+ term <- refineThrow t+ return $ AtomCategory term s l+ where categoryAttrs = (,,) <$> requireAttr "term"+ <*> (requireAttr "scheme" <|> pure mempty)+ <*> (requireAttr "label" <|> pure mempty)+ <* ignoreAttrs++-- | Parse an @atom:content@ element.+atomContent :: MonadThrow m => ConduitM Event o m (Maybe AtomContent)+atomContent = tagName' "content" contentAttrs handler where+ contentAttrs = (,) <$> optional (requireAttr "type") <*> optional (requireAttr "src" >>= asURIReference) <* ignoreAttrs+ handler (Just "xhtml", _) = AtomContentInlineXHTML <$> xhtmlContent+ handler (ctype, Just uri) = return $ AtomContentOutOfLine (fromMaybe mempty ctype) uri+ handler (Just "html", _) = AtomContentInlineText TypeHTML <$> content+ handler (Nothing, _) = AtomContentInlineText TypeText <$> content+ handler (Just ctype, _) = AtomContentInlineOther ctype <$> content++-- | Parse an @atom:link@ element.+-- Examples:+--+-- > <link rel="self" href="/feed" />+--+-- > <link rel="alternate" href="/blog/1234"/>+atomLink :: MonadThrow m => ConduitM Event o m (Maybe AtomLink)+atomLink = tagName' "link" linkAttrs $ \(href, rel, ltype, lang, title, length') ->+ return $ AtomLink href rel ltype lang title length'+ where linkAttrs = (,,,,,) <$> (requireAttr "href" >>= asURIReference)+ <*> (requireAttr "rel" <|> pure mempty)+ <*> (requireAttr "type" <|> pure mempty)+ <*> (requireAttr "hreflang" <|> pure mempty)+ <*> (requireAttr "title" <|> pure mempty)+ <*> (requireAttr "length" <|> pure mempty)+ <* ignoreAttrs++-- | Parse an Atom text construct.+-- Examples:+--+-- > <title type="text">AT&T bought by SBC!</title>+--+-- > <title type="html">+-- > AT&amp;T bought <b>by SBC</b>!+-- > </title>+--+-- > <title type="xhtml">+-- > <div xmlns="http://www.w3.org/1999/xhtml">+-- > AT&T bought <b>by SBC</b>!+-- > </div>+-- > </title>+atomText :: MonadThrow m => Text -> ConduitM Event o m (Maybe AtomText)+atomText name = tagName' name (optional (requireAttr "type") <* ignoreAttrs) handler+ where handler (Just "xhtml") = AtomXHTMLText <$> xhtmlContent+ handler (Just "html") = AtomPlainText TypeHTML <$> content+ handler _ = AtomPlainText TypeText <$> content++-- | Parse an @atom:generator@ element.+-- Example:+--+-- > <generator uri="/myblog.php" version="1.0">+-- > Example Toolkit+-- > </generator>+atomGenerator :: MonadThrow m => ConduitM Event o m (Maybe AtomGenerator)+atomGenerator = tagName' "generator" generatorAttrs $ \(uri, version) -> AtomGenerator uri version <$> (refineThrow =<< content)+ where generatorAttrs = (,) <$> optional (requireAttr "uri" >>= asURIReference) <*> (requireAttr "version" <|> pure mempty) <* ignoreAttrs+++data SourcePiece = SourceAuthor AtomPerson+ | SourceCategory AtomCategory+ | SourceContributor AtomPerson+ | SourceGenerator AtomGenerator+ | SourceIcon AtomURI+ | SourceId Text+ | SourceLink AtomLink+ | SourceLogo AtomURI+ | SourceRights AtomText+ | SourceSubtitle AtomText+ | SourceTitle AtomText+ | SourceUpdated UTCTime++makeTraversals ''SourcePiece++-- | Parse an @atom:source@ element.+-- Example:+--+-- > <source>+-- > <id>http://example.org/</id>+-- > <title>Fourty-Two</title>+-- > <updated>2003-12-13T18:30:02Z</updated>+-- > <rights>© 2005 Example, Inc.</rights>+-- > </source>+atomSource :: MonadThrow m => ConduitM Event o m (Maybe AtomSource)+atomSource = tagIgnoreAttrs' "source" $ manyYield' (choose piece) .| zipConduit where+ zipConduit = getZipConduit $ AtomSource+ <$> ZipConduit (projectC _SourceAuthor .| sinkList)+ <*> ZipConduit (projectC _SourceCategory .| sinkList)+ <*> ZipConduit (projectC _SourceContributor .| sinkList)+ <*> ZipConduit (projectC _SourceGenerator .| headC)+ <*> ZipConduit (projectC _SourceIcon .| headC)+ <*> ZipConduit (projectC _SourceId .| headDefC "")+ <*> ZipConduit (projectC _SourceLink .| sinkList)+ <*> ZipConduit (projectC _SourceLogo .| headC)+ <*> ZipConduit (projectC _SourceRights .| headC)+ <*> ZipConduit (projectC _SourceSubtitle .| headC)+ <*> ZipConduit (projectC _SourceTitle .| headC)+ <*> ZipConduit (projectC _SourceUpdated .| headC)+ piece = [ fmap SourceAuthor <$> atomPerson "author"+ , fmap SourceCategory <$> atomCategory+ , fmap SourceContributor <$> atomPerson "contributor"+ , fmap SourceGenerator <$> atomGenerator+ , fmap SourceIcon <$> atomIcon+ , fmap SourceId <$> atomId+ , fmap SourceLink <$> atomLink+ , fmap SourceLogo <$> atomLogo+ , fmap SourceRights <$> atomText "rights"+ , fmap SourceSubtitle <$> atomText "subtitle"+ , fmap SourceTitle <$> atomText "title"+ , fmap SourceUpdated <$> tagDate "updated"+ ]+++data EntryPiece = EntryAuthor AtomPerson+ | EntryCategory AtomCategory+ | EntryContent AtomContent+ | EntryContributor AtomPerson+ | EntryId Text+ | EntryLink AtomLink+ | EntryPublished UTCTime+ | EntryRights AtomText+ | EntrySource AtomSource+ | EntrySummary AtomText+ | EntryTitle AtomText+ | EntryUpdated UTCTime++makeTraversals ''EntryPiece++-- | Parse an @atom:entry@ element.+atomEntry :: MonadThrow m => ConduitM Event o m (Maybe AtomEntry)+atomEntry = tagIgnoreAttrs' "entry" $ manyYield' (choose piece) .| zipConduit where+ zipConduit = getZipConduit $ AtomEntry+ <$> ZipConduit (projectC _EntryAuthor .| sinkList)+ <*> ZipConduit (projectC _EntryCategory .| sinkList)+ <*> ZipConduit (projectC _EntryContent .| headC)+ <*> ZipConduit (projectC _EntryContributor .| sinkList)+ <*> ZipConduit (projectC _EntryId .| headRequiredC "Missing <id> element")+ <*> ZipConduit (projectC _EntryLink .| sinkList)+ <*> ZipConduit (projectC _EntryPublished .| headC)+ <*> ZipConduit (projectC _EntryRights .| headC)+ <*> ZipConduit (projectC _EntrySource .| headC)+ <*> ZipConduit (projectC _EntrySummary .| headC)+ <*> ZipConduit (projectC _EntryTitle .| headRequiredC "Missing or invalid <title> element.")+ <*> ZipConduit (projectC _EntryUpdated .| headRequiredC "Missing or invalid <updated> element.")+ piece = [ fmap EntryAuthor <$> atomPerson "author"+ , fmap EntryCategory <$> atomCategory+ , fmap EntryContent <$> atomContent+ , fmap EntryContributor <$> atomPerson "contributor"+ , fmap EntryId <$> atomId+ , fmap EntryLink <$> atomLink+ , fmap EntryPublished <$> tagDate "published"+ , fmap EntryRights <$> atomText "rights"+ , fmap EntrySource <$> atomSource+ , fmap EntrySummary <$> atomText "summary"+ , fmap EntryTitle <$> atomText "title"+ , fmap EntryUpdated <$> tagDate "updated"+ ]+++data FeedPiece = FeedAuthor AtomPerson+ | FeedCategory AtomCategory+ | FeedContributor AtomPerson+ | FeedEntry AtomEntry+ | FeedGenerator AtomGenerator+ | FeedIcon AtomURI+ | FeedId Text+ | FeedLink AtomLink+ | FeedLogo AtomURI+ | FeedRights AtomText+ | FeedSubtitle AtomText+ | FeedTitle AtomText+ | FeedUpdated UTCTime++makeTraversals ''FeedPiece++-- | Parse an @atom:feed@ element.+atomFeed :: MonadThrow m => ConduitM Event o m (Maybe AtomFeed)+atomFeed = tagIgnoreAttrs' "feed" $ manyYield' (choose piece) .| zipConduit where+ zipConduit = getZipConduit $ AtomFeed+ <$> ZipConduit (projectC _FeedAuthor .| sinkList)+ <*> ZipConduit (projectC _FeedCategory .| sinkList)+ <*> ZipConduit (projectC _FeedContributor .| sinkList)+ <*> ZipConduit (projectC _FeedEntry .| sinkList)+ <*> ZipConduit (projectC _FeedGenerator .| headC)+ <*> ZipConduit (projectC _FeedIcon .| headC)+ <*> ZipConduit (projectC _FeedId .| headRequiredC "Missing <id> element")+ <*> ZipConduit (projectC _FeedLink .| sinkList)+ <*> ZipConduit (projectC _FeedLogo .| headC)+ <*> ZipConduit (projectC _FeedRights .| headC)+ <*> ZipConduit (projectC _FeedSubtitle .| headC)+ <*> ZipConduit (projectC _FeedTitle .| headRequiredC "Missing <title> element.")+ <*> ZipConduit (projectC _FeedUpdated .| headRequiredC "Missing <updated> element.")+ piece = [ fmap FeedAuthor <$> atomPerson "author"+ , fmap FeedCategory <$> atomCategory+ , fmap FeedContributor <$> atomPerson "contributor"+ , fmap FeedEntry <$> atomEntry+ , fmap FeedGenerator <$> atomGenerator+ , fmap FeedIcon <$> atomIcon+ , fmap FeedId <$> atomId+ , fmap FeedLink <$> atomLink+ , fmap FeedLogo <$> atomLogo+ , fmap FeedRights <$> atomText "rights"+ , fmap FeedSubtitle <$> atomText "subtitle"+ , fmap FeedTitle <$> atomText "title"+ , fmap FeedUpdated <$> tagDate "updated"+ ]
+ src/Text/Atom/Conduit/Render.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+-- | Streaming renderers for the Atom 1.0 standard.+module Text.Atom.Conduit.Render+ ( -- * Top-level+ renderAtomFeed+ -- * Elements+ , renderAtomEntry+ , renderAtomContent+ , renderAtomSource+ , renderAtomGenerator+ , renderAtomLink+ , renderAtomCategory+ -- * Constructs+ , renderAtomPerson+ , renderAtomText+ ) where++-- {{{ Imports+import Text.Atom.Lens+import Text.Atom.Types++import Conduit+import Control.Monad+import Data.Monoid+import Data.Text as Text+import Data.Time.Clock+import Data.Time.LocalTime+import Data.Time.RFC3339+import Data.XML.Types+import Lens.Simple+import Refined+import Text.XML as XML+import Text.XML.Stream.Render+import qualified Text.XML.Unresolved as Unresolved+import URI.ByteString+-- }}}++-- | Render the top-level @atom:feed@ element.+renderAtomFeed :: (Monad m) => AtomFeed -> ConduitT () Event m ()+renderAtomFeed f = atomTag "feed" (attr "xmlns" "http://www.w3.org/2005/Atom") $ do+ forM_ (f^.feedAuthorsL) $ renderAtomPerson "author"+ forM_ (f^.feedCategoriesL) renderAtomCategory+ forM_ (f^.feedContributorsL) $ renderAtomPerson "contributor"+ forM_ (f^.feedEntriesL) renderAtomEntry+ forM_ (f^.feedGeneratorL) renderAtomGenerator+ forM_ (feedIcon f) $ atomTag "icon" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'+ atomTag "id" mempty . content $ f^.feedIdL+ forM_ (f^.feedLinksL) renderAtomLink+ forM_ (feedLogo f) $ atomTag "logo" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'+ forM_ (f^.feedRightsL) $ renderAtomText "rights"+ forM_ (f^.feedSubtitleL) $ renderAtomText "subtitle"+ renderAtomText "title" $ f^.feedTitleL+ dateTag "updated" $ f^.feedUpdatedL++-- | Render an @atom:entry@ element.+renderAtomEntry :: (Monad m) => AtomEntry -> ConduitT () Event m ()+renderAtomEntry e = atomTag "entry" mempty $ do+ forM_ (e^.entryAuthorsL) $ renderAtomPerson "author"+ forM_ (e^.entryCategoriesL) renderAtomCategory+ forM_ (e^.entryContentL) renderAtomContent+ forM_ (e^.entryContributorsL) $ renderAtomPerson "contributor"+ atomTag "id" mempty . content $ e^.entryIdL+ forM_ (e^.entryLinksL) renderAtomLink+ forM_ (e^.entryPublishedL) $ dateTag "published"+ forM_ (e^.entryRightsL) $ renderAtomText "rights"+ forM_ (e^.entrySourceL) renderAtomSource+ forM_ (e^.entrySummaryL) $ renderAtomText "summary"+ renderAtomText "title" (e^.entryTitleL)+ dateTag "updated" (e^.entryUpdatedL)++-- | Render an @atom:content@ element.+renderAtomContent :: (Monad m) => AtomContent -> ConduitT () Event m ()+renderAtomContent (AtomContentInlineXHTML element) = atomTag "content" (attr "type" "xhtml") $ yieldMany $ Unresolved.elementToEvents element+renderAtomContent (AtomContentOutOfLine ctype uri) = atomTag "content" (nonEmptyAttr "type" ctype <> attr "src" (decodeUtf8 $ withAtomURI serializeURIRef' uri)) $ return ()+renderAtomContent (AtomContentInlineText TypeHTML t) = atomTag "content" (attr "type" "html") $ content t+renderAtomContent (AtomContentInlineText TypeText t) = atomTag "content" mempty $ content t+renderAtomContent (AtomContentInlineOther ctype t) = atomTag "content" (attr "type" ctype) $ content t++-- | Render an @atom:source@ element.+renderAtomSource :: (Monad m) => AtomSource -> ConduitT () Event m ()+renderAtomSource s = atomTag "source" mempty $ do+ forM_ (s^.sourceAuthorsL) $ renderAtomPerson "author"+ forM_ (s^.sourceCategoriesL) renderAtomCategory+ forM_ (s^.sourceContributorsL) $ renderAtomPerson "contributor"+ forM_ (s^.sourceGeneratorL) renderAtomGenerator+ forM_ (sourceIcon s) $ atomTag "icon" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'+ unless (Text.null $ s^.sourceIdL) . atomTag "id" mempty . content $ s^.sourceIdL+ forM_ (s^.sourceLinksL) renderAtomLink+ forM_ (sourceLogo s) $ atomTag "logo" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'+ forM_ (s^.sourceRightsL) $ renderAtomText "rights"+ forM_ (s^.sourceSubtitleL) $ renderAtomText "subtitle"+ forM_ (s^.sourceTitleL) $ renderAtomText "title"+ forM_ (s^.sourceUpdatedL) $ dateTag "updated"++-- | Render an @atom:generator@ element.+renderAtomGenerator :: (Monad m) => AtomGenerator -> ConduitT () Event m ()+renderAtomGenerator g = atomTag "generator" attributes . content . unrefine $ g^.generatorContentL+ where attributes = optionalAttr "uri" (decodeUtf8 . withAtomURI serializeURIRef' <$> generatorUri g)+ <> nonEmptyAttr "version" (g^.generatorVersionL)++-- | Render an @atom:link@ element.+renderAtomLink :: (Monad m) => AtomLink -> ConduitT () Event m ()+renderAtomLink l = atomTag "link" linkAttrs $ return ()+ where linkAttrs = attr "href" (decodeUtf8 . withAtomURI serializeURIRef' $ linkHref l)+ <> nonEmptyAttr "rel" (l^.linkRelL)+ <> nonEmptyAttr "type" (l^.linkTypeL)+ <> nonEmptyAttr "hreflang" (l^.linkLangL)+ <> nonEmptyAttr "title" (l^.linkTitleL)+ <> nonEmptyAttr "length" (l^.linkLengthL)++-- | Render an @atom:category@ element.+renderAtomCategory :: (Monad m) => AtomCategory -> ConduitT () Event m ()+renderAtomCategory c = atomTag "category" attributes $ return ()+ where attributes = attr "term" (unrefine $ c^.categoryTermL)+ <> nonEmptyAttr "scheme" (c^.categorySchemeL)+ <> nonEmptyAttr "label" (c^.categoryLabelL)++-- | Render an atom person construct.+renderAtomPerson :: (Monad m) => Text -> AtomPerson -> ConduitT () Event m ()+renderAtomPerson name p = atomTag name mempty $ do+ atomTag "name" mempty . content . unrefine $ p^.personNameL+ unless (Text.null $ p^.personEmailL) $ atomTag "email" mempty . content $ p^.personEmailL+ forM_ (personUri p) $ atomTag "uri" mempty . content . decodeUtf8 . withAtomURI serializeURIRef'++-- | Render an atom text construct.+renderAtomText :: Monad m => Text -> AtomText -> ConduitT () Event m ()+renderAtomText name (AtomXHTMLText element) = atomTag name (attr "type" "xhtml") $ yieldMany $ Unresolved.elementToEvents element+renderAtomText name (AtomPlainText TypeHTML t) = atomTag name (attr "type" "html") $ content t+renderAtomText name (AtomPlainText TypeText t) = atomTag name mempty $ content t++atomTag :: Monad m => Text -> Attributes -> ConduitT () Event m () -> ConduitT () Event m ()+atomTag name = tag (Name name (Just "http://www.w3.org/2005/Atom") (Just "atom"))++dateTag :: (Monad m) => Text -> UTCTime -> ConduitT () Event m ()+dateTag name = atomTag name mempty . content . formatTimeRFC3339 . utcToZonedTime utc++nonEmptyAttr :: Name -> Text -> Attributes+nonEmptyAttr name value+ | value == mempty = mempty+ | otherwise = attr name value
+ src/Text/Atom/Lens.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+module Text.Atom.Lens (module Text.Atom.Lens) where++-- {{{ Imports+import Lens.Simple++import Text.Atom.Types++import URI.ByteString+-- }}}++makeLensesFor+ [ ("categoryTerm", "categoryTermL")+ , ("categoryScheme", "categorySchemeL")+ , ("categoryLabel", "categoryLabelL")+ ] ''AtomCategory++makeLensesFor+ [ ("entryAuthors", "entryAuthorsL")+ , ("entryCategories", "entryCategoriesL")+ , ("entryContent", "entryContentL")+ , ("entryContributors", "entryContributorsL")+ , ("entryId", "entryIdL")+ , ("entryLinks", "entryLinksL")+ , ("entryPublished", "entryPublishedL")+ , ("entryRights", "entryRightsL")+ , ("entrySource", "entrySourceL")+ , ("entrySummary", "entrySummaryL")+ , ("entryTitle", "entryTitleL")+ , ("entryUpdated", "entryUpdatedL")+ ] ''AtomEntry+++makeLensesFor+ [ ("feedAuthors", "feedAuthorsL")+ , ("feedCategories", "feedCategoriesL")+ , ("feedContributors", "feedContributorsL")+ , ("feedEntries", "feedEntriesL")+ , ("feedGenerator", "feedGeneratorL")+ , ("feedIcon", "feedIconL")+ , ("feedId", "feedIdL")+ , ("feedLinks", "feedLinksL")+ , ("feedLogo", "feedLogoL")+ , ("feedRights", "feedRightsL")+ , ("feedSubtitle", "feedSubtitleL")+ , ("feedTitle", "feedTitleL")+ , ("feedUpdated", "feedUpdatedL")+ ] ''AtomFeed++makeLensesFor+ [ ("generatorVersion", "generatorVersionL")+ , ("generatorContent", "generatorContentL")+ , ("generatorUri", "generatorUriL")+ ] ''AtomGenerator++makeLensesFor+ [ ("linkHref", "linkHrefL")+ , ("linkType", "linkTypeL")+ , ("linkRel", "linkRelL")+ , ("linkLang", "linkLangL")+ , ("linkTitle", "linkTitleL")+ , ("linkLength", "linkLengthL")+ ] ''AtomLink++makeLensesFor+ [ ("personName", "personNameL")+ , ("personEmail", "personEmailL")+ , ("personUri", "personUriL")+ ] ''AtomPerson++--personUriL :: Traversal' AtomPerson (URIRef a)+--personUriL inj a@AtomPerson { personUri = u } = (\x -> a { personUri = x }) <$> traverse inj u++makeLensesFor+ [ ("sourceAuthors", "sourceAuthorsL")+ , ("sourceCategories", "sourceCategoriesL")+ , ("sourceContributors", "sourceContributorsL")+ , ("sourceGenerator", "sourceGeneratorL")+ -- , ("sourceIcon"+ , ("sourceId", "sourceIdL")+ , ("sourceLinks", "sourceLinksL")+ , ("sourceLogo", "sourceLogoL")+ , ("sourceRights", "sourceRightsL")+ , ("sourceSubtitle", "sourceSubtitleL")+ , ("sourceTitle", "sourceTitleL")+ , ("sourceUpdated", "sourceUpdatedL")+ ] ''AtomSource++makeTraversals ''AtomText
+ src/Text/Atom/Types.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+-- | Atom is an XML-based Web content and metadata syndication format.+--+-- Example:+--+-- > <?xml version="1.0" encoding="utf-8"?>+-- > <feed xmlns="http://www.w3.org/2005/Atom">+-- >+-- > <title>Example Feed</title>+-- > <link href="http://example.org/"/>+-- > <updated>2003-12-13T18:30:02Z</updated>+-- > <author>+-- > <name>John Doe</name>+-- > </author>+-- > <id>urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6</id>+-- >+-- > <entry>+-- > <title>Atom-Powered Robots Run Amok</title>+-- > <link href="http://example.org/2003/12/13/atom03"/>+-- > <id>urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a</id>+-- > <updated>2003-12-13T18:30:02Z</updated>+-- > <summary>Some text.</summary>+-- > </entry>+-- >+-- > </feed>+module Text.Atom.Types (module Text.Atom.Types) where++-- {{{ Imports+import Control.Monad+import Data.Text as Text+import Data.Text.Prettyprint.Doc+import Data.Time.Clock+import Data.Time.LocalTime ()+import Data.Typeable+import Data.XML.Types as XML+import GHC.Generics+import Refined+import URI.ByteString+import qualified Text.Show as Text+-- }}}++-- | 'Predicate' on 'Text', true iff text is null.+data Null deriving(Typeable)++instance Predicate Null Text where+ validate p value = unless (Text.null value) $ throwRefine $ RefineOtherException (typeOf p) $ "Text is not null: " <> pretty value++data AtomURI = forall a . AtomURI (URIRef a)++withAtomURI :: (forall a . URIRef a -> b) -> AtomURI -> b+withAtomURI f (AtomURI a) = f a+++instance Eq AtomURI where+ AtomURI a@URI{} == AtomURI b@URI{} = a == b+ AtomURI a@RelativeRef{} == AtomURI b@RelativeRef{} = a == b+ _ == _ = False+instance Ord AtomURI where+ AtomURI a@URI{} `compare` AtomURI b@URI{} = a `compare` b+ AtomURI a@RelativeRef{} `compare` AtomURI b@RelativeRef{} = a `compare` b+ AtomURI a@URI{} `compare` _ = LT+ AtomURI a@RelativeRef{} `compare` b = b `compare` AtomURI a+instance Text.Show AtomURI where+ show (AtomURI a@URI{}) = show a+ show (AtomURI a@RelativeRef{}) = show a+++data TextType = TypeText | TypeHTML+ deriving(Eq, Ord, Generic, Show)++-- | An atom text construct.+data AtomText = AtomPlainText TextType Text+ | AtomXHTMLText XML.Element++deriving instance Eq AtomText+deriving instance Ord AtomText+deriving instance Generic AtomText+deriving instance Show AtomText++-- | An atom person construct.+data AtomPerson = AtomPerson+ { personName :: Refined (Not Null) Text+ , personEmail :: Text+ , personUri :: Maybe AtomURI+ }++deriving instance Eq AtomPerson+deriving instance Ord AtomPerson+deriving instance Generic AtomPerson+-- deriving instance Read AtomPerson+deriving instance Show AtomPerson++-- | The @atom:category@ element.+data AtomCategory = AtomCategory+ { categoryTerm :: Refined (Not Null) Text+ , categoryScheme :: Text+ , categoryLabel :: Text+ }++deriving instance Eq AtomCategory+deriving instance Ord AtomCategory+deriving instance Generic AtomCategory+deriving instance Show AtomCategory++-- | The @atom:link@ element.+data AtomLink = AtomLink+ { linkHref :: AtomURI+ , linkRel :: Text+ , linkType :: Text+ , linkLang :: Text+ , linkTitle :: Text+ , linkLength :: Text+ }++deriving instance Eq AtomLink+deriving instance Ord AtomLink+deriving instance Generic AtomLink+deriving instance Show AtomLink++-- | The @atom:generator@ element.+data AtomGenerator = AtomGenerator+ { generatorUri :: Maybe AtomURI+ , generatorVersion :: Text+ , generatorContent :: Refined (Not Null) Text+ }++deriving instance Eq AtomGenerator+deriving instance Ord AtomGenerator+deriving instance Generic AtomGenerator+deriving instance Show AtomGenerator++-- | The @atom:source@ element.+data AtomSource = AtomSource+ { sourceAuthors :: [AtomPerson]+ , sourceCategories :: [AtomCategory]+ , sourceContributors :: [AtomPerson]+ , sourceGenerator :: Maybe AtomGenerator+ , sourceIcon :: Maybe AtomURI+ , sourceId :: Text+ , sourceLinks :: [AtomLink]+ , sourceLogo :: Maybe AtomURI+ , sourceRights :: Maybe AtomText+ , sourceSubtitle :: Maybe AtomText+ , sourceTitle :: Maybe AtomText+ , sourceUpdated :: Maybe UTCTime+ }++deriving instance Eq AtomSource+deriving instance Ord AtomSource+deriving instance Generic AtomSource+deriving instance Show AtomSource++type ContentType = Text++-- | The @atom:content@ element.+data AtomContent = AtomContentInlineText TextType Text+ | AtomContentInlineXHTML XML.Element+ | AtomContentInlineOther ContentType Text+ | AtomContentOutOfLine ContentType AtomURI++deriving instance Eq AtomContent+deriving instance Ord AtomContent+deriving instance Generic AtomContent+deriving instance Show AtomContent++-- | The @atom:entry@ element.+data AtomEntry = AtomEntry+ { entryAuthors :: [AtomPerson]+ , entryCategories :: [AtomCategory]+ , entryContent :: Maybe AtomContent+ , entryContributors :: [AtomPerson]+ , entryId :: Text+ , entryLinks :: [AtomLink]+ , entryPublished :: Maybe UTCTime+ , entryRights :: Maybe AtomText+ , entrySource :: Maybe AtomSource+ , entrySummary :: Maybe AtomText+ , entryTitle :: AtomText+ , entryUpdated :: UTCTime+ }++deriving instance Eq AtomEntry+deriving instance Ord AtomEntry+deriving instance Generic AtomEntry+deriving instance Show AtomEntry++-- | The @atom:feed@ element.+data AtomFeed = AtomFeed+ { feedAuthors :: [AtomPerson]+ , feedCategories :: [AtomCategory]+ , feedContributors :: [AtomPerson]+ , feedEntries :: [AtomEntry]+ , feedGenerator :: Maybe AtomGenerator+ , feedIcon :: Maybe AtomURI+ , feedId :: Text+ , feedLinks :: [AtomLink]+ , feedLogo :: Maybe AtomURI+ , feedRights :: Maybe AtomText+ , feedSubtitle :: Maybe AtomText+ , feedTitle :: AtomText+ , feedUpdated :: UTCTime+ }++deriving instance Eq AtomFeed+deriving instance Ord AtomFeed+deriving instance Generic AtomFeed+deriving instance Show AtomFeed
+ test/GoldenTests.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+import Control.Monad.Trans.Resource+import Data.Conduit+import Data.Conduit.Combinators as Conduit (decodeUtf8,+ sourceFile)+import Data.Default+import qualified Data.Text.Lazy.Encoding as Lazy+import System.FilePath+import Test.Tasty+import Test.Tasty.Golden (findByExtension, goldenVsString)+import Text.Atom.Conduit.Parse as Parser+import Text.Atom.Conduit.Render as Renderer+import Text.Atom.Types+import Text.Pretty.Simple+import qualified Text.XML.Stream.Parse as XML++main :: IO ()+main = defaultMain =<< do+ xmlFiles <- findByExtension [".xml"] "."++ return $ testGroup "Atom golden tests" $ do+ xmlFile <- xmlFiles+ let goldenFile = addExtension xmlFile ".golden"+ f file = fmap (Lazy.encodeUtf8 . pShowNoColor) $ runResourceT $ runConduit $ sourceFile file .| Conduit.decodeUtf8 .| XML.parseText def .| XML.force "Invalid <feed>" atomFeed+ return $ goldenVsString xmlFile goldenFile $ f xmlFile
test/HLint.hs view
@@ -1,8 +1,7 @@ import qualified Language.Haskell.HLint as HLint (hlint)-import System.Exit main :: IO () main = do- result <- HLint.hlint [ "test/", "Text/" ]+ result <- HLint.hlint [ "test/", "src/" ] if null result then exitSuccess else exitFailure
− test/Main.hs
@@ -1,248 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-import Blaze.ByteString.Builder (toByteString)-import Control.Monad-import Control.Monad.Trans.Resource-import Data.Char-import Data.Conduit-import Data.Conduit.Combinators as Conduit (decodeUtf8, fold,- sourceFile, yieldMany)-import Data.Default-import Data.Functor.Identity-import Data.Monoid-import Data.String-import Data.Text as Text-import Data.Text.Encoding as Text-import qualified Data.Text.Lazy.Encoding as Lazy-import Data.Time.Clock-import Data.Void-import Data.XML.Types-import Lens.Simple-import Refined-import System.FilePath-import Test.QuickCheck.Instances-import Test.Tasty-import Test.Tasty.Golden (findByExtension, goldenVsString)-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck-import Text.Atom.Conduit.Parse as Parser-import Text.Atom.Conduit.Render as Renderer-import Text.Atom.Lens-import Text.Atom.Types-import Text.Parser.Combinators-import Text.Pretty.Simple-import qualified Text.XML.Stream.Parse as XML-import URI.ByteString--main :: IO ()-main = do- goldenTests <- genGoldenTests- defaultMain $ testGroup "Tests" [ unitTests, properties, goldenTests ]--unitTests :: TestTree-unitTests = testGroup "Unit tests"- [ linkCase- , personCase- , generatorCase- , sourceCase- , textConstructCase- ]--genGoldenTests :: IO TestTree-genGoldenTests = do- xmlFiles <- findByExtension [".xml"] "."-- return $ testGroup "Atom golden tests" $ do- xmlFile <- xmlFiles- let goldenFile = addExtension xmlFile ".golden"- f file = fmap (Lazy.encodeUtf8 . pShowNoColor) $ runResourceT $ runConduit $ sourceFile file .| Conduit.decodeUtf8 .| XML.parseText' def .| XML.force "Invalid <feed>" atomFeed- return $ goldenVsString xmlFile goldenFile $ f xmlFile--properties :: TestTree-properties = testGroup "Properties"- [ roundtripProperty "AtomText" (renderAtomText "test") (atomText "test")- , roundtripProperty "AtomPerson" (renderAtomPerson "test") (atomPerson "test")- , roundtripProperty "AtomCategory" renderAtomCategory atomCategory- , roundtripProperty "AtomLink" renderAtomLink atomLink- , roundtripProperty "AtomGenerator" renderAtomGenerator atomGenerator- , roundtripProperty "AtomSource" renderAtomSource atomSource- , roundtripProperty "AtomContent" renderAtomContent atomContent- -- , roundtripProperty "AtomEntry" renderAtomEntry atomEntry- -- , roundtripProperty "AtomFeed" renderAtomFeed atomFeed- ]--linkCase :: TestTree-linkCase = testCase "Link element" $ do- result <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.force "Invalid <link>" atomLink- result ^. linkHrefL @?= AtomURI (RelativeRef Nothing "/feed" (Query []) Nothing)- (result ^. linkRelL) @?= "self"- where input = ["<link xmlns=\"http://www.w3.org/2005/Atom\" rel=\"self\" href=\"/feed\" />"]--personCase :: TestTree-personCase = testCase "Person construct" $ do- result <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.force "Invalid <author>" (atomPerson "author")- unrefine (result ^. personNameL) @?= "John Doe"- result ^. personEmailL @?= "JohnDoe@example.com"- result ^. personUriL @?= Just (AtomURI $ URI (Scheme "http") (Just $ Authority Nothing (Host "example.com") Nothing) "/~johndoe" (Query []) Nothing)- where input =- [ "<author xmlns=\"http://www.w3.org/2005/Atom\">"- , "<name>John Doe</name>"- , "<email>JohnDoe@example.com</email>"- , "<uri>http://example.com/~johndoe</uri>"- , "</author>"- ]--generatorCase :: TestTree-generatorCase = testCase "Generator element" $ do- result <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.force "Invalid <generator>" atomGenerator- result ^. generatorUriL @?= Just (AtomURI $ RelativeRef Nothing "/myblog.php" (Query []) Nothing)- (result ^. generatorVersionL) @?= "1.0"- unrefine (result ^. generatorContentL) @?= "Example Toolkit"- where input =- [ "<generator xmlns=\"http://www.w3.org/2005/Atom\" uri=\"/myblog.php\" version=\"1.0\">"- , "Example Toolkit"- , "</generator>"- ]--sourceCase :: TestTree-sourceCase = testCase "Source element" $ do- result <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.force "Invalid <source>" atomSource- (result ^. sourceIdL) @?= "http://example.org/"- (result ^. sourceTitleL) @?= Just (AtomPlainText TypeText "Fourty-Two")- show <$> (result ^. sourceUpdatedL) @?= Just "2003-12-13 18:30:02 UTC"- (result ^. sourceRightsL) @?= Just (AtomPlainText TypeText "© 2005 Example, Inc.")- where input =- [ "<source xmlns=\"http://www.w3.org/2005/Atom\">"- , "<id>http://example.org/</id>"- , "<title>Fourty-Two</title>"- , "<updated>2003-12-13T18:30:02Z</updated>"- , "<rights>© 2005 Example, Inc.</rights>"- , "</source>"- ]--textConstructCase :: TestTree-textConstructCase = testCase "Text construct" $ do- a:b:c:_ <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.many (atomText "title")- a @?= AtomPlainText TypeText "AT&T bought by SBC!"- b @?= AtomPlainText TypeHTML "AT&T bought <b>by SBC</b>!"- c @?= AtomXHTMLText "AT&T bought <b xmlns=\"http://www.w3.org/1999/xhtml\"><em>by SBC</em></b><!"- where input =- [ "<title xmlns=\"http://www.w3.org/2005/Atom\" type=\"text\">AT&T bought by SBC!</title>"- , "<title xmlns=\"http://www.w3.org/2005/Atom\" type=\"html\">"- , "AT&amp;T bought <b>by SBC</b>!"- , "</title>"- , "<title xmlns=\"http://www.w3.org/2005/Atom\" type=\"xhtml\">"- , "<div xmlns=\"http://www.w3.org/1999/xhtml\">"- , "AT&T bought <b><em>by SBC</em></b><!"- , "</div>"- , "</title>"- ]---roundtripProperty :: Eq a => Arbitrary a => Show a- => TestName -> (a -> ConduitT () Event Maybe ()) -> ConduitM Event Void Maybe (Maybe a) -> TestTree-roundtripProperty name render parse = testProperty ("parse . render = id (" <> name <> ")") $ do- input <- arbitrary- let output = join $ runConduit $ render input .| parse- return $ Just input == output---letter = choose ('a', 'z')-digit = arbitrary `suchThat` isDigit-alphaNum = oneof [letter, digit]--instance Arbitrary (Refined (Not Null) Text) where- arbitrary = do- ~(Right text) <- refine <$> arbitrary `suchThat` (not . Text.null)- return text--instance Arbitrary Scheme where- arbitrary = do- a <- letter- b <- listOf $ oneof [letter, digit, pure '+', pure '-', pure '.']- return $ Scheme $ encodeUtf8 $ pack (a:b)--instance Arbitrary Authority where- arbitrary = Authority <$> arbitrary <*> arbitrary <*> arbitrary- shrink = genericShrink--instance Arbitrary UserInfo where- arbitrary = UserInfo <$> (encodeUtf8 . pack <$> listOf1 alphaNum)- <*> (encodeUtf8 . pack <$> listOf1 alphaNum)--instance Arbitrary Host where- arbitrary = Host <$> (encodeUtf8 . pack <$> listOf1 alphaNum)--instance Arbitrary Port where- arbitrary = Port <$> (getPositive <$> arbitrary)--instance Arbitrary Query where- arbitrary = Query <$> listOf ((,) <$> (encodeUtf8 . pack <$> listOf1 alphaNum) <*> (encodeUtf8 . pack <$> listOf1 alphaNum))--instance Arbitrary URI where- arbitrary = URI <$> arbitrary- <*> arbitrary- <*> (encodeUtf8 . pack . ('/' :) <$> listOf1 alphaNum)- <*> arbitrary- <*> oneof [pure Nothing, Just <$> (encodeUtf8 . pack <$> listOf1 alphaNum)]--instance Arbitrary AtomURI where- arbitrary = oneof [AtomURI <$> (arbitrary :: Gen (URIRef Absolute)), AtomURI <$> (arbitrary :: Gen (URIRef Relative))]--instance Arbitrary RelativeRef where- arbitrary = RelativeRef <$> arbitrary- <*> (encodeUtf8 . pack . ('/' :) <$> listOf1 alphaNum)- <*> arbitrary- <*> oneof [pure Nothing, Just <$> (encodeUtf8 . pack <$> listOf1 alphaNum)]--instance Arbitrary TextType where- arbitrary = elements [TypeText, TypeHTML]--instance Arbitrary AtomText where- arbitrary = oneof- [ AtomPlainText <$> arbitrary <*> (pack <$> listOf1 alphaNum)- , AtomXHTMLText <$> (pack <$> listOf1 alphaNum)- ]- shrink = genericShrink--instance Arbitrary AtomPerson where- arbitrary = AtomPerson <$> arbitrary <*> arbitrary <*> arbitrary--instance Arbitrary AtomCategory where- arbitrary = AtomCategory <$> arbitrary <*> arbitrary <*> arbitrary--instance Arbitrary AtomLink where- arbitrary = AtomLink <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary--instance Arbitrary AtomGenerator where- arbitrary = do- ~(Right content) <- refine . pack <$> listOf1 alphaNum- AtomGenerator <$> arbitrary <*> arbitrary <*> pure content- shrink = genericShrink--instance Arbitrary AtomSource where- arbitrary = do- updated <- oneof [return Nothing, Just <$> genUtcTime]- AtomSource <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> pure updated--instance Arbitrary AtomContent where- arbitrary = oneof- [ AtomContentInlineText <$> arbitrary <*> arbitrary- , AtomContentInlineXHTML <$> (pack <$> listOf1 alphaNum)- , AtomContentInlineOther <$> arbitrary <*> arbitrary- , AtomContentOutOfLine <$> arbitrary <*> arbitrary- ]- shrink = genericShrink--instance Arbitrary AtomEntry where- arbitrary = do- published <- oneof [return Nothing, Just <$> genUtcTime]- AtomEntry <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> pure published <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> genUtcTime--instance Arbitrary AtomFeed where- arbitrary = AtomFeed <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> genUtcTime---- | Generates 'UTCTime' with rounded seconds.-genUtcTime = do- (UTCTime d s) <- arbitrary- return $ UTCTime d (fromIntegral (round s :: Int))
+ test/Prelude.hs view
@@ -0,0 +1,4 @@+module Prelude (module Relude, module Relude.Extra.Map) where++import Relude hiding (Predicate, force, many)+import Relude.Extra.Map (lookup)
+ test/QuickCheck.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+import Control.Monad+import Data.Char+import Data.Conduit+import Data.Text as Text (Text, pack, null)+import Data.Time.Clock+import Data.Void+import Data.XML.Types as XML+import Generic.Random+import Refined+import Test.QuickCheck.Instances+import Test.QuickCheck.Modifiers+import Test.Tasty+import Test.Tasty.QuickCheck+import Text.Atom.Conduit.Parse as Parser+import Text.Atom.Conduit.Render as Renderer+import Text.Atom.Types+import URI.ByteString++main :: IO ()+main = defaultMain $ testGroup "Properties"+ [ roundtripProperty "AtomText" (renderAtomText "test") (atomText "test")+ , roundtripProperty "AtomPerson" (renderAtomPerson "test") (atomPerson "test")+ , roundtripProperty "AtomCategory" renderAtomCategory atomCategory+ , roundtripProperty "AtomLink" renderAtomLink atomLink+ , roundtripProperty "AtomGenerator" renderAtomGenerator atomGenerator+ , roundtripProperty "AtomSource" renderAtomSource atomSource+ , roundtripProperty "AtomContent" renderAtomContent atomContent+ , roundtripProperty "AtomEntry" renderAtomEntry atomEntry+ , roundtripProperty "AtomFeed" renderAtomFeed atomFeed+ ]+++roundtripProperty :: Eq a => Arbitrary a => Show a+ => TestName -> (a -> ConduitT () Event Maybe ()) -> ConduitM Event Void Maybe (Maybe a) -> TestTree+roundtripProperty name render parse = testProperty ("parse . render = id (" <> name <> ")") $ \input -> Just input === join (runConduit $ render input .| parse)+++newtype Letter = Letter { getLetter :: Char } deriving (Eq, Ord, Read, Show)++instance Arbitrary Letter where+ arbitrary = Letter <$> choose ('a', 'z')+++newtype Digit = Digit { getDigit :: Char } deriving (Eq, Ord, Read, Show)++instance Arbitrary Digit where+ arbitrary = Digit <$> (arbitrary `suchThat` isDigit)+++newtype NonEmptyText = NonEmptyText { getNonEmptyText :: Text } deriving(Eq, Ord, Read, Show)++instance Arbitrary NonEmptyText where+ arbitrary = NonEmptyText . Text.pack <$> (map getAlphaNumChar <$> listOf1 arbitrary)+++newtype AlphaNumChar = AlphaNumChar { getAlphaNumChar :: Char } deriving(Eq, Ord, Read, Show)++instance Arbitrary AlphaNumChar where+ arbitrary = AlphaNumChar <$> oneof [getLetter <$> arbitrary, getDigit <$> arbitrary]+++-- | 'UTCTime' with rounded seconds.+newtype RoundedUTCTime = RoundedUTCTime { getRoundedUtcTime :: UTCTime } deriving(Eq, Ord, Read, Show)++instance Arbitrary RoundedUTCTime where+ arbitrary = RoundedUTCTime <$> do+ (UTCTime d s) <- arbitrary+ return $ UTCTime d (fromIntegral (round s :: Int))+++instance Arbitrary (Refined (Not Null) Text) where+ arbitrary = do+ ~(Right text) <- refine <$> arbitrary `suchThat` (not . Text.null)+ return text++instance Arbitrary Scheme where+ arbitrary = do+ a <- getLetter <$> arbitrary+ b <- listOf $ frequency [(10, getAlphaNumChar <$> arbitrary), (1, pure '+'), (1, pure '-'), (1, pure '.')]+ return $ Scheme $ encodeUtf8 $ pack (a:b)++instance Arbitrary Authority where+ arbitrary = genericArbitrary uniform+ shrink = genericShrink++instance Arbitrary UserInfo where+ arbitrary = UserInfo <$> (encodeUtf8 . getNonEmptyText <$> arbitrary)+ <*> (encodeUtf8 . getNonEmptyText <$> arbitrary)++instance Arbitrary Host where+ arbitrary = Host <$> (encodeUtf8 . getNonEmptyText <$> arbitrary)++instance Arbitrary Port where+ arbitrary = Port <$> (getPositive <$> arbitrary)++instance Arbitrary Query where+ arbitrary = Query <$> listOf ((,) <$> (encodeUtf8 . getNonEmptyText <$> arbitrary) <*> (encodeUtf8 . getNonEmptyText <$> arbitrary))++instance Arbitrary URI where+ arbitrary = URI <$> arbitrary+ <*> arbitrary+ <*> (encodeUtf8 . ("/" <>) . getNonEmptyText <$> arbitrary)+ <*> arbitrary+ <*> (fmap (encodeUtf8 . getNonEmptyText) <$> arbitrary)++instance Arbitrary AtomURI where+ arbitrary = oneof [AtomURI <$> (arbitrary :: Gen (URIRef Absolute)), AtomURI <$> (arbitrary :: Gen (URIRef Relative))]++instance Arbitrary RelativeRef where+ arbitrary = RelativeRef <$> arbitrary+ <*> (encodeUtf8 . ("/" <>) . getNonEmptyText <$> arbitrary)+ <*> arbitrary+ <*> (fmap (encodeUtf8 . getNonEmptyText) <$> arbitrary)++instance Arbitrary TextType where+ arbitrary = genericArbitrary uniform+ shrink = genericShrink++instance Arbitrary XML.Document where+ arbitrary = genericArbitrary uniform+ shrink = genericShrink++instance Arbitrary XML.Prologue where+ arbitrary = genericArbitrary uniform+ shrink = genericShrink++instance Arbitrary XML.Miscellaneous where+ arbitrary = genericArbitrary uniform+ shrink = genericShrink++instance Arbitrary XML.Instruction where+ arbitrary = XML.Instruction <$> (getNonEmptyText <$> arbitrary) <*> (getNonEmptyText <$> arbitrary)++instance Arbitrary XML.Doctype where+ arbitrary = XML.Doctype+ <$> (getNonEmptyText <$> arbitrary)+ <*> arbitrary++instance Arbitrary XML.ExternalID where+ arbitrary = oneof+ [ XML.SystemID <$> (getNonEmptyText <$> arbitrary)+ , XML.PublicID <$> (getNonEmptyText <$> arbitrary) <*> (getNonEmptyText <$> arbitrary)+ ]++instance Arbitrary XML.Element where+ arbitrary = scale (`div` 6) $ sized genElement++instance Arbitrary XML.Node where+ arbitrary = scale (`div` 5) $ sized genNode++instance Arbitrary XML.Name where+ arbitrary = XML.Name+ <$> (getNonEmptyText <$> arbitrary)+ <*> (fmap getNonEmptyText <$> arbitrary)+ <*> arbitrary++instance Arbitrary XML.Content where+ arbitrary = frequency [(10, ContentText <$> (getNonEmptyText <$> arbitrary)), (1, ContentEntity <$> (getNonEmptyText <$> arbitrary))]++genElement :: Int -> Gen XML.Element+genElement 0 = XML.Element <$> arbitrary <*> arbitrary <*> pure []+genElement n = XML.Element <$> arbitrary <*> arbitrary <*> (mergeNodes <$> listOf (genNode $ n `div` 2))++genNode :: Int -> Gen XML.Node+genNode 0 = oneof [XML.NodeInstruction <$> arbitrary, XML.NodeContent <$> arbitrary, XML.NodeComment <$> arbitrary]+genNode n = oneof [XML.NodeElement <$> genElement n, XML.NodeInstruction <$> arbitrary, XML.NodeContent <$> arbitrary, XML.NodeComment <$> arbitrary]++mergeNodes :: [Node] -> [Node]+mergeNodes (NodeContent (ContentText a):NodeContent (ContentText b):t) = mergeNodes $ (NodeContent $ ContentText $ a <> b):t+mergeNodes (node:t) = node:mergeNodes t+mergeNodes [] = []++instance Arbitrary AtomText where+ arbitrary = genericArbitrary uniform+ shrink = genericShrink++instance Arbitrary AtomPerson where+ arbitrary = genericArbitrary uniform+ shrink = genericShrink++instance Arbitrary AtomCategory where+ arbitrary = genericArbitrary uniform+ shrink = genericShrink++instance Arbitrary AtomLink where+ arbitrary = genericArbitrary uniform+ shrink = genericShrink++instance Arbitrary AtomGenerator where+ arbitrary = genericArbitrary uniform+ shrink = genericShrink++instance Arbitrary AtomSource where+ arbitrary = scale (`div` 5) $ AtomSource+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> (fmap getRoundedUtcTime <$> arbitrary)++instance Arbitrary AtomContent where+ arbitrary = genericArbitrary uniform+ shrink = genericShrink++instance Arbitrary AtomEntry where+ arbitrary = scale (`div` 5) $ AtomEntry+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> (fmap getRoundedUtcTime <$> arbitrary)+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> (getRoundedUtcTime <$> arbitrary)++instance Arbitrary AtomFeed where+ arbitrary = scale (`div` 5) $ AtomFeed <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> (getRoundedUtcTime <$> arbitrary)
+ test/UnitTests.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+import Control.Monad.Trans.Resource+import Data.Conduit+import Data.Conduit.Combinators as Conduit (yieldMany)+import Data.Default+import Data.Time.Clock+import Data.XML.Types+import Lens.Simple+import Refined+import Test.Tasty+import Test.Tasty.HUnit+import Text.Atom.Conduit.Parse as Parser+import Text.Atom.Conduit.Render as Renderer+import Text.Atom.Lens+import Text.Atom.Types+import qualified Text.XML.Stream.Parse as XML+import URI.ByteString++main :: IO ()+main = defaultMain $ testGroup "Unit tests"+ [ linkCase+ , personCase+ , generatorCase+ , sourceCase+ , textConstructCase+ ]++linkCase :: TestTree+linkCase = testCase "Link element" $ do+ result <- runResourceT . runConduit $ yieldMany input .| XML.parseText def .| XML.force "Invalid <link>" atomLink+ result ^. linkHrefL @?= AtomURI (RelativeRef Nothing "/feed" (Query []) Nothing)+ (result ^. linkRelL) @?= "self"+ where input = ["<link xmlns=\"http://www.w3.org/2005/Atom\" rel=\"self\" href=\"/feed\" />"]++personCase :: TestTree+personCase = testCase "Person construct" $ do+ result <- runResourceT . runConduit $ yieldMany input .| XML.parseText def .| XML.force "Invalid <author>" (atomPerson "author")+ unrefine (result ^. personNameL) @?= "John Doe"+ result ^. personEmailL @?= "JohnDoe@example.com"+ result ^. personUriL @?= Just (AtomURI $ URI (Scheme "http") (Just $ Authority Nothing (Host "example.com") Nothing) "/~johndoe" (Query []) Nothing)+ where input =+ [ "<author xmlns=\"http://www.w3.org/2005/Atom\">"+ , "<name>John Doe</name>"+ , "<email>JohnDoe@example.com</email>"+ , "<uri>http://example.com/~johndoe</uri>"+ , "</author>"+ ]++generatorCase :: TestTree+generatorCase = testCase "Generator element" $ do+ result <- runResourceT . runConduit $ yieldMany input .| XML.parseText def .| XML.force "Invalid <generator>" atomGenerator+ result ^. generatorUriL @?= Just (AtomURI $ RelativeRef Nothing "/myblog.php" (Query []) Nothing)+ (result ^. generatorVersionL) @?= "1.0"+ unrefine (result ^. generatorContentL) @?= "Example Toolkit"+ where input =+ [ "<generator xmlns=\"http://www.w3.org/2005/Atom\" uri=\"/myblog.php\" version=\"1.0\">"+ , "Example Toolkit"+ , "</generator>"+ ]++sourceCase :: TestTree+sourceCase = testCase "Source element" $ do+ result <- runResourceT . runConduit $ yieldMany input .| XML.parseText def .| XML.force "Invalid <source>" atomSource+ (result ^. sourceIdL) @?= "http://example.org/"+ (result ^. sourceTitleL) @?= Just (AtomPlainText TypeText "Fourty-Two")+ show <$> (result ^. sourceUpdatedL) @?= Just "2003-12-13 18:30:02 UTC"+ (result ^. sourceRightsL) @?= Just (AtomPlainText TypeText "© 2005 Example, Inc.")+ where input =+ [ "<source xmlns=\"http://www.w3.org/2005/Atom\">"+ , "<id>http://example.org/</id>"+ , "<title>Fourty-Two</title>"+ , "<updated>2003-12-13T18:30:02Z</updated>"+ , "<rights>© 2005 Example, Inc.</rights>"+ , "</source>"+ ]++textConstructCase :: TestTree+textConstructCase = testCase "Text construct" $ do+ a:b:c:_ <- runResourceT . runConduit $ yieldMany input .| XML.parseText def .| XML.many (atomText "title")+ a @?= AtomPlainText TypeText "AT&T bought by SBC!"+ b @?= AtomPlainText TypeHTML "AT&T bought <b>by SBC</b>!"+ c @?= AtomXHTMLText (Element "{http://www.w3.org/1999/xhtml}div" []+ [ NodeContent (ContentText "AT&T bought ")+ , NodeElement (Element "{http://www.w3.org/1999/xhtml}b" [] [ NodeElement (Element "{http://www.w3.org/1999/xhtml}em" [] [NodeContent (ContentText "by SBC")]) ])+ , NodeContent (ContentText "!")+ ] )+ where input =+ [ "<title xmlns=\"http://www.w3.org/2005/Atom\" type=\"text\">AT&T bought by SBC!</title>"+ , "<title xmlns=\"http://www.w3.org/2005/Atom\" type=\"html\">"+ , "AT&amp;T bought <b>by SBC</b>!"+ , "</title>"+ , "<title xmlns=\"http://www.w3.org/2005/Atom\" type=\"xhtml\">"+ , "<div xmlns=\"http://www.w3.org/1999/xhtml\">"+ , "AT&T bought <b><em>by SBC</em></b>!"+ , "</div>"+ , "</title>"+ ]