diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/Text/Atom/Conduit/Parse.hs b/Text/Atom/Conduit/Parse.hs deleted file mode 100644 --- a/Text/Atom/Conduit/Parse.hs +++ /dev/null @@ -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: --- --- > --- > John Doe --- > JohnDoe@example.com --- > http://example.com/~johndoe --- > -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 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: --- --- > -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 "
" (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: --- --- > --- --- > -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: --- --- > AT&T bought by SBC! --- --- > --- > AT&amp;T bought <b>by SBC</b>! --- > --- --- > --- > <div xmlns="http://www.w3.org/1999/xhtml"> --- > AT&T bought <b>by SBC</b>! --- > </div> --- > -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 "
" (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: --- --- > --- > Example Toolkit --- > -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: --- --- > --- > http://example.org/ --- > Fourty-Two --- > 2003-12-13T18:30:02Z --- > © 2005 Example, Inc. --- > -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 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 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" - ] diff --git a/Text/Atom/Conduit/Render.hs b/Text/Atom/Conduit/Render.hs deleted file mode 100644 --- a/Text/Atom/Conduit/Render.hs +++ /dev/null @@ -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 diff --git a/Text/Atom/Lens.hs b/Text/Atom/Lens.hs deleted file mode 100644 --- a/Text/Atom/Lens.hs +++ /dev/null @@ -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 diff --git a/Text/Atom/Types.hs b/Text/Atom/Types.hs deleted file mode 100644 --- a/Text/Atom/Types.hs +++ /dev/null @@ -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 --- > --- > 2003-12-13T18:30:02Z --- > --- > John Doe --- > --- > urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6 --- > --- > --- > Atom-Powered Robots Run Amok --- > --- > urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a --- > 2003-12-13T18:30:02Z --- > Some text. --- > --- > --- > -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 diff --git a/atom-conduit.cabal b/atom-conduit.cabal --- a/atom-conduit.cabal +++ b/atom-conduit.cabal @@ -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 diff --git a/src/Prelude.hs b/src/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Prelude.hs @@ -0,0 +1,4 @@ +module Prelude (module Relude, module Relude.Extra.Map) where + +import Relude hiding (Predicate, force, many) +import Relude.Extra.Map (lookup) diff --git a/src/Text/Atom/Conduit/Parse.hs b/src/Text/Atom/Conduit/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Text/Atom/Conduit/Parse.hs @@ -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: +-- +-- > +-- > John Doe +-- > JohnDoe@example.com +-- > http://example.com/~johndoe +-- > +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 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: +-- +-- > +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: +-- +-- > +-- +-- > +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: +-- +-- > AT&T bought by SBC! +-- +-- > +-- > AT&amp;T bought <b>by SBC</b>! +-- > +-- +-- > +-- > <div xmlns="http://www.w3.org/1999/xhtml"> +-- > AT&T bought <b>by SBC</b>! +-- > </div> +-- > +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: +-- +-- > +-- > Example Toolkit +-- > +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: +-- +-- > +-- > http://example.org/ +-- > Fourty-Two +-- > 2003-12-13T18:30:02Z +-- > © 2005 Example, Inc. +-- > +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 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 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" + ] diff --git a/src/Text/Atom/Conduit/Render.hs b/src/Text/Atom/Conduit/Render.hs new file mode 100644 --- /dev/null +++ b/src/Text/Atom/Conduit/Render.hs @@ -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 diff --git a/src/Text/Atom/Lens.hs b/src/Text/Atom/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Text/Atom/Lens.hs @@ -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 diff --git a/src/Text/Atom/Types.hs b/src/Text/Atom/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/Atom/Types.hs @@ -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 +-- > +-- > 2003-12-13T18:30:02Z +-- > +-- > John Doe +-- > +-- > urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6 +-- > +-- > +-- > Atom-Powered Robots Run Amok +-- > +-- > urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a +-- > 2003-12-13T18:30:02Z +-- > Some text. +-- > +-- > +-- > +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 diff --git a/test/GoldenTests.hs b/test/GoldenTests.hs new file mode 100644 --- /dev/null +++ b/test/GoldenTests.hs @@ -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 " atomFeed + return $ goldenVsString xmlFile goldenFile $ f xmlFile diff --git a/test/HLint.hs b/test/HLint.hs --- a/test/HLint.hs +++ b/test/HLint.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -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 " 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 " atomLink - result ^. linkHrefL @?= AtomURI (RelativeRef Nothing "/feed" (Query []) Nothing) - (result ^. linkRelL) @?= "self" - where input = [""] - -personCase :: TestTree -personCase = testCase "Person construct" $ do - result <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.force "Invalid " (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 = - [ "" - , "John Doe" - , "JohnDoe@example.com" - , "http://example.com/~johndoe" - , "" - ] - -generatorCase :: TestTree -generatorCase = testCase "Generator element" $ do - result <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.force "Invalid " atomGenerator - result ^. generatorUriL @?= Just (AtomURI $ RelativeRef Nothing "/myblog.php" (Query []) Nothing) - (result ^. generatorVersionL) @?= "1.0" - unrefine (result ^. generatorContentL) @?= "Example Toolkit" - where input = - [ "" - , "Example Toolkit" - , "" - ] - -sourceCase :: TestTree -sourceCase = testCase "Source element" $ do - result <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.force "Invalid " 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 = - [ "" - , "http://example.org/" - , "Fourty-Two" - , "2003-12-13T18:30:02Z" - , "© 2005 Example, Inc." - , "" - ] - -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 by SBC!" - c @?= AtomXHTMLText "AT&T bought by SBC<!" - where input = - [ "AT&T bought by SBC!" - , "" - , "AT&amp;T bought <b>by SBC</b>!" - , "" - , "" - , "<div xmlns=\"http://www.w3.org/1999/xhtml\">" - , "AT&T bought <b><em>by SBC</em></b><!" - , "</div>" - , "" - ] - - -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)) diff --git a/test/Prelude.hs b/test/Prelude.hs new file mode 100644 --- /dev/null +++ b/test/Prelude.hs @@ -0,0 +1,4 @@ +module Prelude (module Relude, module Relude.Extra.Map) where + +import Relude hiding (Predicate, force, many) +import Relude.Extra.Map (lookup) diff --git a/test/QuickCheck.hs b/test/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/test/QuickCheck.hs @@ -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) diff --git a/test/UnitTests.hs b/test/UnitTests.hs new file mode 100644 --- /dev/null +++ b/test/UnitTests.hs @@ -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 " atomLink + result ^. linkHrefL @?= AtomURI (RelativeRef Nothing "/feed" (Query []) Nothing) + (result ^. linkRelL) @?= "self" + where input = [""] + +personCase :: TestTree +personCase = testCase "Person construct" $ do + result <- runResourceT . runConduit $ yieldMany input .| XML.parseText def .| XML.force "Invalid " (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 = + [ "" + , "John Doe" + , "JohnDoe@example.com" + , "http://example.com/~johndoe" + , "" + ] + +generatorCase :: TestTree +generatorCase = testCase "Generator element" $ do + result <- runResourceT . runConduit $ yieldMany input .| XML.parseText def .| XML.force "Invalid " atomGenerator + result ^. generatorUriL @?= Just (AtomURI $ RelativeRef Nothing "/myblog.php" (Query []) Nothing) + (result ^. generatorVersionL) @?= "1.0" + unrefine (result ^. generatorContentL) @?= "Example Toolkit" + where input = + [ "" + , "Example Toolkit" + , "" + ] + +sourceCase :: TestTree +sourceCase = testCase "Source element" $ do + result <- runResourceT . runConduit $ yieldMany input .| XML.parseText def .| XML.force "Invalid " 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 = + [ "" + , "http://example.org/" + , "Fourty-Two" + , "2003-12-13T18:30:02Z" + , "© 2005 Example, Inc." + , "" + ] + +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 by SBC!" + 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 = + [ "AT&T bought by SBC!" + , "" + , "AT&amp;T bought <b>by SBC</b>!" + , "" + , "" + , "<div xmlns=\"http://www.w3.org/1999/xhtml\">" + , "AT&T bought <b><em>by SBC</em></b>!" + , "</div>" + , "" + ]