atom-conduit 0.1.0.0 → 0.2.0.0
raw patch · 6 files changed
+472/−379 lines, 6 filesdep +foldldep +totaldep +uri-bytestringdep −containersdep −network-uri
Dependencies added: foldl, total, uri-bytestring
Dependencies removed: containers, network-uri
Files
- README.md +10/−0
- Text/Atom/Conduit/Parse.hs +259/−202
- Text/Atom/Conduit/Render.hs +18/−19
- Text/Atom/Types.hs +100/−97
- atom-conduit.cabal +8/−10
- test/Main.hs +77/−51
+ README.md view
@@ -0,0 +1,10 @@+# atom-conduit++This [Haskell][hsk] library implements a streaming parser/renderer for the [Atom 1.0 syndication format][atom], based on [conduit][cdt]s.++Parsers are as much lenient as possible. E.g. unexpected tags are simply ignored.+++[atom]: http://tools.ietf.org/html/rfc4287+[cdt]: https://hackage.haskell.org/package/conduit+[hsk]: https://haskell.org
Text/Atom/Conduit/Parse.hs view
@@ -5,8 +5,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} -- | Streaming parsers for the Atom 1.0 standard. module Text.Atom.Conduit.Parse ( -- * Top-level@@ -27,134 +27,132 @@ import Text.Atom.Types import Control.Applicative-import Control.Lens.Cons-import Control.Lens.Getter-import Control.Lens.Setter+import Control.Foldl hiding (mconcat, set) import Control.Lens.TH-import Control.Lens.Tuple-import Control.Monad+import Control.Monad hiding (foldM) import Control.Monad.Catch -import Data.Conduit import Data.Conduit.Parser import Data.Conduit.Parser.XML-import Data.Containers import Data.Maybe import Data.Monoid import Data.MonoTraversable-import Data.NonNull-import Data.Text as Text hiding (cons, map, snoc)+import Data.NonNull (NonNull, fromNullable, toNullable)+import Data.Text as Text (Text)+import Data.Text.Encoding import Data.Time.Clock import Data.Time.LocalTime import Data.Time.RFC3339 import Data.XML.Types -import GHC.Generics+import Prelude hiding (last, lookup) -import Prelude hiding (lookup)+import Text.Parser.Combinators -import Network.URI+import URI.ByteString+-- }}} -import Text.Parser.Combinators-import Text.XML+-- {{{ Util+data AtomException = InvalidURI URIParseError+ | NullElement++deriving instance Eq AtomException+instance Show AtomException where+ show (InvalidURI e) = "Invalid URI reference: " ++ show e+ show NullElement = "Null element."+instance Exception AtomException++asUriReference :: (MonadThrow m) => Text -> m UriReference+asUriReference t = case (parseURI' t, parseRelativeRef' t) of+ (Right u, _) -> return $ UriReferenceUri u+ (_, Right u) -> return $ UriReferenceRelativeRef u+ (Left _, Left e) -> throwM $ InvalidURI e+ where parseURI' = parseURI laxURIParserOptions . encodeUtf8+ parseRelativeRef' = parseRelativeRef laxURIParserOptions . encodeUtf8++asNonNull :: (MonoFoldable a, MonadThrow m) => a -> m (NonNull a)+asNonNull = maybe (throwM NullElement) return . fromNullable++-- | Like 'tagName' but ignores the namespace.+tagName' :: (MonadCatch m) => Text -> AttrParser a -> (a -> ConduitParser Event m b) -> ConduitParser Event m b+tagName' t = tagPredicate (\n -> nameLocalName n == t)++-- | Tag which content is a date-time that follows RFC 3339 format.+tagDate :: (MonadCatch m) => Text -> ConduitParser Event m UTCTime+tagDate name = tagIgnoreAttrs' name $ content (fmap zonedTimeToUTC . parseTimeRFC3339)++-- | Like 'tagName'' but ignores all attributes.+tagIgnoreAttrs' :: (MonadCatch m) => Text -> ConduitParser Event m a -> ConduitParser Event m a+tagIgnoreAttrs' name handler = tagName' name ignoreAttrs $ const handler++unknownTag :: (MonadCatch m) => ConduitParser Event m ()+unknownTag = anyTag $ \_ _ -> void $ many (void unknownTag <|> void textContent)++atomId :: (MonadCatch m) => ConduitParser Event m (NonNull Text)+atomId = tagIgnoreAttrs' "id" $ content asNonNull++atomIcon, atomLogo :: (MonadCatch m) => ConduitParser Event m UriReference+atomIcon = tagIgnoreAttrs' "icon" $ content asUriReference+atomLogo = tagIgnoreAttrs' "logo" $ content asUriReference++lastRequired :: (Monad m, Parsing m) => String -> FoldM m a a+lastRequired e = FoldM (\_ a -> return $ Right a) (return $ Left e) (either unexpected return) -- }}} --- | Parse an @atom:feed@ element.-atomFeed :: (MonadCatch m) => ConduitParser Event m AtomFeed-atomFeed = named "Atom <feed> element" $ tagIgnoreAttrs "feed" $ do- builders <- many $ choice atomFeedBuilders- let result = (appEndo $ mconcat builders) dummy- when (checkDummy result) $ unexpected "Missing sub-elements in <feed>."- return result- where atomFeedBuilders :: (MonadCatch m) => [ConduitParser Event m (Endo AtomFeed)]- atomFeedBuilders = [ liftM (Endo . over feedAuthors_ . cons) (atomPerson "author")- , liftM (Endo . over feedCategories_ . cons) atomCategory- , liftM (Endo . over feedContributors_ . cons) (atomPerson "contributor")- , liftM (Endo . over feedEntries_ . cons) atomEntry- , liftM (Endo . set feedGenerator_ . Just) atomGenerator- , liftM (Endo . set feedIcon_ . Just) atomIcon- , liftM (Endo . set feedId_) atomId- , liftM (Endo . over feedLinks_ . cons) atomLink- , liftM (Endo . set feedLogo_ . Just) atomLogo- , liftM (Endo . set feedRights_ . Just) (atomText "rights")- , liftM (Endo . set feedSubtitle_ . Just) (atomText "subtitle")- , liftM (Endo . set feedTitle_) (atomText "title")- , liftM (Endo . set feedUpdated_) (tagDate "updated")- , unknownTag- ] --- | Parse an @atom:entry@ element.-atomEntry :: (MonadCatch m) => ConduitParser Event m AtomEntry-atomEntry = named "Atom <entry> element" $ tagIgnoreAttrs "entry" $ do- builders <- many $ choice atomEntryBuilders- let result = (appEndo $ mconcat builders) dummy- when (checkDummy result) $ unexpected "Missing sub-elements in <entry>."- return result- where atomEntryBuilders :: (MonadCatch m) => [ConduitParser Event m (Endo AtomEntry)]- atomEntryBuilders = [ liftM (Endo . over entryAuthors_ . cons) (atomPerson "author")- , liftM (Endo . over entryCategories_ . cons) atomCategory- , liftM (Endo . set entryContent_ . Just) atomContent- , liftM (Endo . over entryContributors_ . cons) (atomPerson "contributor")- , liftM (Endo . set entryId_) atomId- , liftM (Endo . over entryLinks_ . cons) atomLink- , liftM (Endo . set entryPublished_ . Just) (tagDate "published")- , liftM (Endo . set entryRights_ . Just) (atomText "rights")- , liftM (Endo . set entrySource_ . Just) atomSource- , liftM (Endo . set entrySummary_ . Just) (atomText "summary")- , liftM (Endo . set entryTitle_) (atomText "title")- , liftM (Endo . set entryUpdated_) (tagDate "updated")- , unknownTag- ]+data PersonPiece = PersonName (NonNull Text)+ | PersonEmail Text+ | PersonUri UriReference+ | PersonUnknown +makePrisms ''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 :: (MonadCatch m) => Text -> ConduitParser Event m AtomPerson+atomPerson name = named ("Atom person construct <" <> name <> ">") $ tagIgnoreAttrs' name $ do+ p <- many piece+ flip foldM p $ AtomPerson+ <$> handlesM _PersonName (lastRequired "Missing or invalid <name> element.")+ <*> generalize (handles _PersonEmail $ lastDef "")+ <*> generalize (handles _PersonUri last)+ where piece :: (MonadCatch m) => ConduitParser Event m PersonPiece+ piece = choice [ PersonName <$> tagIgnoreAttrs' "name" (content asNonNull)+ , PersonEmail <$> tagIgnoreAttrs' "email" textContent+ , PersonUri <$> tagIgnoreAttrs' "uri" (content asUriReference)+ , PersonUnknown <$ unknownTag+ ]+++-- | Parse an @atom:category@ element.+-- Example:+--+-- > <category term="sports"/>+atomCategory :: (MonadCatch m) => ConduitParser Event m AtomCategory+atomCategory = tagName' "category" categoryAttrs $ \(t, s, l) -> do+ term <- asNonNull t+ return $ AtomCategory term s l+ where categoryAttrs = (,,) <$> textAttr "term"+ <*> (textAttr "scheme" <|> pure mempty)+ <*> (textAttr "label" <|> pure mempty)+ <* ignoreAttrs+ -- | Parse an @atom:content@ element. atomContent :: (MonadCatch m) => ConduitParser Event m AtomContent atomContent = tagName' "content" contentAttrs handler- where contentAttrs = (,) <$> optional (textAttr "type") <*> optional (attr "src" asURI) <* ignoreAttrs- handler (Just "xhtml", _) = AtomContentInlineXHTML <$> tagIgnoreAttrs "div" textContent+ where contentAttrs = (,) <$> optional (textAttr "type") <*> optional (attr "src" asUriReference) <* ignoreAttrs+ handler (Just "xhtml", _) = AtomContentInlineXHTML <$> tagIgnoreAttrs' "div" textContent handler (ctype, Just uri) = return $ AtomContentOutOfLine (fromMaybe mempty ctype) uri handler (Just "html", _) = AtomContentInlineText TypeHTML <$> textContent handler (Nothing, _) = AtomContentInlineText TypeText <$> textContent handler (Just ctype, _) = AtomContentInlineOther ctype <$> textContent --- | 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 :: (MonadCatch m) => ConduitParser Event m AtomSource-atomSource = named "Atom <source> element" $ tagIgnoreAttrs "source" $ do- builders <- many $ choice atomSourceBuilders- return $ (appEndo $ mconcat builders) dummy- where atomSourceBuilders :: (MonadCatch m) => [ConduitParser Event m (Endo AtomSource)]- atomSourceBuilders = [ liftM (Endo . over sourceAuthors_ . cons) (atomPerson "author")- , liftM (Endo . over sourceCategories_ . cons) atomCategory- , liftM (Endo . over sourceContributors_ . cons) (atomPerson "contributor")- , liftM (Endo . set sourceGenerator_ . Just) atomGenerator- , liftM (Endo . set sourceIcon_ . Just) atomIcon- , liftM (Endo . set sourceId_ . toNullable) atomId- , liftM (Endo . over sourceLinks_ . cons) atomLink- , liftM (Endo . set sourceLogo_ . Just) atomLogo- , liftM (Endo . set sourceRights_ . Just) (atomText "rights")- , liftM (Endo . set sourceSubtitle_ . Just) (atomText "subtitle")- , liftM (Endo . set sourceTitle_ . Just) (atomText "title")- , liftM (Endo . set sourceUpdated_ . Just) (tagDate "updated")- , unknownTag- ]---- | Parse an @atom:generator@ element.--- Example:------ > <generator uri="/myblog.php" version="1.0">--- > Example Toolkit--- > </generator>-atomGenerator :: (MonadCatch m) => ConduitParser Event m AtomGenerator-atomGenerator = tagName' "generator" generatorAttrs $ \(uri, version) -> AtomGenerator uri version <$> (asNonNull =<< textContent)- where generatorAttrs = (,) <$> optional (attr "uri" asURI) <*> (textAttr "version" <|> pure mempty) <* ignoreAttrs- -- | Parse an @atom:link@ element. -- Examples: --@@ -164,7 +162,7 @@ atomLink :: (MonadCatch m) => ConduitParser Event m AtomLink atomLink = tagName' "link" linkAttrs $ \(href, rel, ltype, lang, title, length') -> return $ AtomLink href rel ltype lang title length'- where linkAttrs = (,,,,,) <$> attr "href" asURI+ where linkAttrs = (,,,,,) <$> attr "href" asUriReference <*> (textAttr "rel" <|> pure mempty) <*> (textAttr "type" <|> pure mempty) <*> (textAttr "hreflang" <|> pure mempty)@@ -172,49 +170,6 @@ <*> (textAttr "length" <|> pure mempty) <* ignoreAttrs --- | Parse an @atom:category@ element.--- Example:------ > <category term="sports"/>-atomCategory :: (MonadCatch m) => ConduitParser Event m AtomCategory-atomCategory = tagName "category" categoryAttrs $ \(t, s, l) -> do- term <- asNonNull t- return $ AtomCategory term s l- where categoryAttrs = (,,) <$> textAttr "term"- <*> (textAttr "scheme" <|> pure mempty)- <*> (textAttr "label" <|> pure mempty)- <* ignoreAttrs---- | Parse an Atom person construct.--- Example:------ > <author>--- > <name>John Doe</name>--- > <email>JohnDoe@example.com</email>--- > <uri>http://example.com/~johndoe</uri>--- > </author>-atomPerson :: (MonadCatch m) => Text -> ConduitParser Event m AtomPerson-atomPerson name = named ("Atom person construct <" <> name <> ">") $ tagIgnoreAttrs name $ do- builders <- many $ choice atomPersonBuilders- case (appEndo $ mconcat builders) (Nothing, "", Nothing) of- (Just n, e, u) -> return $ AtomPerson n e u- _ -> unexpected "Missing person name."- where atomPersonBuilders :: (MonadCatch m) => [ConduitParser Event m (Endo (Maybe (NonNull Text), Text, Maybe URI))]- atomPersonBuilders = [ liftM (Endo . set _1 . Just) personName- , liftM (Endo . set _2) personEmail- , liftM (Endo . set _3 . Just) personURI- , unknownTag- ]-- personName :: MonadCatch m => ConduitParser Event m (NonNull Text)- personName = tagIgnoreAttrs "name" (content asNonNull)-- personEmail :: MonadCatch m => ConduitParser Event m Text- personEmail = tagIgnoreAttrs "email" textContent-- personURI :: MonadCatch m => ConduitParser Event m URI- personURI = tagIgnoreAttrs "uri" $ content asURI- -- | Parse an Atom text construct. -- Examples: --@@ -231,7 +186,7 @@ -- > </title> atomText :: (MonadCatch m) => Text -> ConduitParser Event m AtomText atomText name = named ("Atom text construct <" <> name <> ">") $ tagName' name (optional (textAttr "type") <* ignoreAttrs) handler- where handler (Just "xhtml") = AtomXHTMLText <$> tagIgnoreAttrs "div" xhtmlContent+ where handler (Just "xhtml") = AtomXHTMLText <$> tagIgnoreAttrs' "div" xhtmlContent handler (Just "html") = AtomPlainText TypeHTML <$> textContent handler _ = AtomPlainText TypeText <$> textContent xhtmlContent :: MonadCatch m => ConduitParser Event m Text@@ -242,71 +197,173 @@ renderContent (ContentText t) = t renderContent (ContentEntity t) = t +-- | Parse an @atom:generator@ element.+-- Example:+--+-- > <generator uri="/myblog.php" version="1.0">+-- > Example Toolkit+-- > </generator>+atomGenerator :: (MonadCatch m) => ConduitParser Event m AtomGenerator+atomGenerator = tagName' "generator" generatorAttrs $ \(uri, version) -> AtomGenerator uri version <$> (asNonNull =<< textContent)+ where generatorAttrs = (,) <$> optional (attr "uri" asUriReference) <*> (textAttr "version" <|> pure mempty) <* ignoreAttrs -data AtomException = InvalidURI Text- | MissingEntryTitle- | MissingEntryUpdated- | NullElement- | EmptyList -deriving instance Eq AtomException-instance Show AtomException where- show (InvalidURI t) = "Invalid URI: " ++ unpack t- show MissingEntryTitle = "Missing entry title."- show MissingEntryUpdated = "Missing entry's last update."- show NullElement = "Null element."- show EmptyList = "Empty list."-instance Exception AtomException+data SourcePiece = SourceAuthor AtomPerson+ | SourceCategory AtomCategory+ | SourceContributor AtomPerson+ | SourceGenerator AtomGenerator+ | SourceIcon UriReference+ | SourceId Text+ | SourceLink AtomLink+ | SourceLogo UriReference+ | SourceRights AtomText+ | SourceSubtitle AtomText+ | SourceTitle AtomText+ | SourceUpdated UTCTime+ | SourceUnknown +makePrisms ''SourcePiece -asURI :: (MonadThrow m) => Text -> m URI-asURI t = maybe (throwM $ InvalidURI t) return . parseURIReference $ unpack t+-- | 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 :: (MonadCatch m) => ConduitParser Event m AtomSource+atomSource = named "Atom <source> element" $ tagIgnoreAttrs' "source" $ do+ p <- many piece+ flip foldM p $ AtomSource+ <$> generalize (handles _SourceAuthor list)+ <*> generalize (handles _SourceCategory list)+ <*> generalize (handles _SourceContributor list)+ <*> generalize (handles _SourceGenerator last)+ <*> generalize (handles _SourceIcon last)+ <*> generalize (handles _SourceId $ lastDef "")+ <*> generalize (handles _SourceLink list)+ <*> generalize (handles _SourceLogo last)+ <*> generalize (handles _SourceRights last)+ <*> generalize (handles _SourceSubtitle last)+ <*> generalize (handles _SourceTitle last)+ <*> generalize (handles _SourceUpdated last)+ where piece :: (MonadCatch m) => ConduitParser Event m SourcePiece+ piece = choice [ SourceAuthor <$> atomPerson "author"+ , SourceCategory <$> atomCategory+ , SourceContributor <$> atomPerson "contributor"+ , SourceGenerator <$> atomGenerator+ , SourceIcon <$> atomIcon+ , SourceId . toNullable <$> atomId+ , SourceLink <$> atomLink+ , SourceLogo <$> atomLogo+ , SourceRights <$> atomText "rights"+ , SourceSubtitle <$> atomText "subtitle"+ , SourceTitle <$> atomText "title"+ , SourceUpdated <$> tagDate "updated"+ , SourceUnknown <$ unknownTag+ ] -asNonNull :: (MonoFoldable a, MonadThrow m) => a -> m (NonNull a)-asNonNull = maybe (throwM NullElement) return . fromNullable --- | Like 'tagName' but ignores the namespace.-tagName' :: (MonadCatch m) => Text -> AttrParser a -> (a -> ConduitParser Event m b) -> ConduitParser Event m b-tagName' t = tagPredicate (\n -> nameLocalName n == t)+data EntryPiece = EntryAuthor AtomPerson+ | EntryCategory AtomCategory+ | EntryContent AtomContent+ | EntryContributor AtomPerson+ | EntryId (NonNull Text)+ | EntryLink AtomLink+ | EntryPublished UTCTime+ | EntryRights AtomText+ | EntrySource AtomSource+ | EntrySummary AtomText+ | EntryTitle AtomText+ | EntryUpdated UTCTime+ | EntryUnknown --- | Tag which content is a date-time that follows RFC 3339 format.-tagDate :: (MonadCatch m) => Text -> ConduitParser Event m UTCTime-tagDate name = tagIgnoreAttrs name $ content (fmap zonedTimeToUTC . parseTimeRFC3339)+makePrisms ''EntryPiece --- | Like 'tagName'' but ignores all attributes.-tagIgnoreAttrs :: (MonadCatch m) => Text -> ConduitParser Event m a -> ConduitParser Event m a-tagIgnoreAttrs name handler = tagName' name ignoreAttrs $ const handler+-- | Parse an @atom:entry@ element.+atomEntry :: (MonadCatch m) => ConduitParser Event m AtomEntry+atomEntry = named "Atom <entry> element" $ tagIgnoreAttrs' "entry" $ do+ p <- many piece+ flip foldM p $ AtomEntry+ <$> generalize (handles _EntryAuthor list)+ <*> generalize (handles _EntryCategory list)+ <*> generalize (handles _EntryContent last)+ <*> generalize (handles _EntryContributor list)+ <*> handlesM _EntryId (lastRequired "Missing or invalid <id> element.")+ <*> generalize (handles _EntryLink list)+ <*> generalize (handles _EntryPublished last)+ <*> generalize (handles _EntryRights last)+ <*> generalize (handles _EntrySource last)+ <*> generalize (handles _EntrySummary last)+ <*> handlesM _EntryTitle (lastRequired "Missing or invalid <title> element.")+ <*> handlesM _EntryUpdated (lastRequired "Missing or invalid <updated> element.")+ where piece :: (MonadCatch m) => ConduitParser Event m EntryPiece+ piece = choice [ EntryAuthor <$> atomPerson "author"+ , EntryCategory <$> atomCategory+ , EntryContent <$> atomContent+ , EntryContributor <$> atomPerson "contributor"+ , EntryId <$> atomId+ , EntryLink <$> atomLink+ , EntryPublished <$> tagDate "published"+ , EntryRights <$> atomText "rights"+ , EntrySource <$> atomSource+ , EntrySummary <$> atomText "summary"+ , EntryTitle <$> atomText "title"+ , EntryUpdated <$> tagDate "updated"+ , EntryUnknown <$ unknownTag+ ] -atomId :: (MonadCatch m) => ConduitParser Event m (NonNull Text)-atomId = tagIgnoreAttrs "id" $ content asNonNull--atomIcon, atomLogo :: (MonadCatch m) => ConduitParser Event m URI-atomIcon = tagIgnoreAttrs "icon" $ content asURI-atomLogo = tagIgnoreAttrs "logo" $ content asURI--unknownTag :: (MonadCatch m) => ConduitParser Event m (Endo a)-unknownTag = anyTag $ \_ _ -> many (void unknownTag <|> void textContent) >> return mempty-+data FeedPiece = FeedAuthor AtomPerson+ | FeedCategory AtomCategory+ | FeedContributor AtomPerson+ | FeedEntry AtomEntry+ | FeedGenerator AtomGenerator+ | FeedIcon UriReference+ | FeedId (NonNull Text)+ | FeedLink AtomLink+ | FeedLogo UriReference+ | FeedRights AtomText+ | FeedSubtitle AtomText+ | FeedTitle AtomText+ | FeedUpdated UTCTime+ | FeedUnknown -class (Eq a) => Dummy a where- dummy :: a- checkDummy :: a -> Bool- checkDummy = (== dummy)+makePrisms ''FeedPiece -instance Dummy UTCTime where- dummy = UTCTime (toEnum 0) (secondsToDiffTime 0)-instance Dummy Text where- dummy = " "-instance Dummy AtomText where- dummy = AtomPlainText TypeText dummy-instance Dummy (NonNull Text) where- dummy = nonNull dummy-instance Dummy AtomSource where- dummy = AtomSource mzero mzero mzero mzero mzero mempty mzero mzero mzero mzero mzero mzero-instance Dummy AtomEntry where- dummy = AtomEntry mzero mzero mzero mzero dummy mzero mzero mzero mzero mzero dummy dummy- checkDummy (AtomEntry _ _ _ _ i _ _ _ _ _ t u) = checkDummy i && checkDummy t && checkDummy u-instance Dummy AtomFeed where- dummy = AtomFeed mzero mzero mzero mzero mzero mzero dummy mzero mzero mzero mzero dummy dummy- checkDummy (AtomFeed _ _ _ _ _ _ i _ _ _ _ t u) = checkDummy i && checkDummy t && checkDummy u+-- | Parse an @atom:feed@ element.+atomFeed :: (MonadCatch m) => ConduitParser Event m AtomFeed+atomFeed = named "Atom <feed> element" $ tagIgnoreAttrs' "feed" $ do+ p <- many piece+ flip foldM p $ AtomFeed+ <$> generalize (handles _FeedAuthor list)+ <*> generalize (handles _FeedCategory list)+ <*> generalize (handles _FeedContributor list)+ <*> generalize (handles _FeedEntry list)+ <*> generalize (handles _FeedGenerator last)+ <*> generalize (handles _FeedIcon last)+ <*> handlesM _FeedId (lastRequired "Missing or empty <id> element.")+ <*> generalize (handles _FeedLink list)+ <*> generalize (handles _FeedLogo last)+ <*> generalize (handles _FeedRights last)+ <*> generalize (handles _FeedSubtitle last)+ <*> handlesM _FeedTitle (lastRequired "Missing <title> element.")+ <*> handlesM _FeedUpdated (lastRequired "Missing <updated> element.")+ where piece :: MonadCatch m => ConduitParser Event m FeedPiece+ piece = choice [ FeedAuthor <$> atomPerson "author"+ , FeedCategory <$> atomCategory+ , FeedContributor <$> atomPerson "contributor"+ , FeedEntry <$> atomEntry+ , FeedGenerator <$> atomGenerator+ , FeedIcon <$> atomIcon+ , FeedId <$> atomId+ , FeedLink <$> atomLink+ , FeedLogo <$> atomLogo+ , FeedRights <$> atomText "rights"+ , FeedSubtitle <$> atomText "subtitle"+ , FeedTitle <$> atomText "title"+ , FeedUpdated <$> tagDate "updated"+ , FeedUnknown <$ unknownTag+ ]
Text/Atom/Conduit/Render.hs view
@@ -24,17 +24,18 @@ import Control.Monad import Data.Conduit-import Data.Foldable import Data.Monoid import Data.NonNull import Data.Text as Text+import Data.Text.Encoding import Data.Time.Clock import Data.Time.LocalTime import Data.Time.RFC3339-import Data.Traversable import Data.XML.Types import Text.XML.Stream.Render++import URI.ByteString -- }}} -- | Render the top-level @atom:feed@ element.@@ -45,10 +46,10 @@ forM_ (f^.feedContributors_) $ renderAtomPerson "contributor" forM_ (f^.feedEntries_) renderAtomEntry forM_ (f^.feedGenerator_) renderAtomGenerator- forM_ (f^.feedIcon_) $ tag "icon" mempty . content . tshow+ forM_ (f^.feedIcon_) $ tag "icon" mempty . content . decodeUtf8 . serializeUriReference' tag "id" mempty . content . toNullable $ f^.feedId_ forM_ (f^.feedLinks_) renderAtomLink- forM_ (f^.feedLogo_) $ tag "logo" mempty . content . tshow+ forM_ (f^.feedLogo_) $ tag "logo" mempty . content . decodeUtf8 . serializeUriReference' forM_ (f^.feedRights_) $ renderAtomText "rights" forM_ (f^.feedSubtitle_) $ renderAtomText "subtitle" renderAtomText "title" $ f^.feedTitle_@@ -74,13 +75,10 @@ renderAtomContent :: (Monad m) => AtomContent -> Source m Event renderAtomContent (AtomContentInlineXHTML t) = tag "content" (attr "type" "xhtml") . tag "div" mempty $ content t-renderAtomContent (AtomContentOutOfLine ctype uri) = tag "content" (nonEmptyAttr "type" ctype <> attr "src" (tshow uri)) $ return ()-renderAtomContent (AtomContentInlineText TypeHTML t) = tag "content" (attr "type" "html")- $ content t-renderAtomContent (AtomContentInlineText TypeText t) = tag "content" mempty- $ content t-renderAtomContent (AtomContentInlineOther ctype t) = tag "content" (attr "type" ctype)- $ content t+renderAtomContent (AtomContentOutOfLine ctype uri) = tag "content" (nonEmptyAttr "type" ctype <> attr "src" (decodeUtf8 $ serializeUriReference' uri)) $ return ()+renderAtomContent (AtomContentInlineText TypeHTML t) = tag "content" (attr "type" "html") $ content t+renderAtomContent (AtomContentInlineText TypeText t) = tag "content" mempty $ content t+renderAtomContent (AtomContentInlineOther ctype t) = tag "content" (attr "type" ctype) $ content t -- | Render an @atom:source@ element. renderAtomSource :: (Monad m) => AtomSource -> Source m Event@@ -89,10 +87,10 @@ forM_ (s^.sourceCategories_) renderAtomCategory forM_ (s^.sourceContributors_) $ renderAtomPerson "contributor" forM_ (s^.sourceGenerator_) renderAtomGenerator- forM_ (s^.sourceIcon_) $ tag "icon" mempty . content . tshow+ forM_ (s^.sourceIcon_) $ tag "icon" mempty . content . decodeUtf8 . serializeUriReference' unless (Text.null $ s^.sourceId_) . tag "id" mempty . content $ s^.sourceId_ forM_ (s^.sourceLinks_) renderAtomLink- forM_ (s^.sourceLogo_) $ tag "logo" mempty . content . tshow+ forM_ (s^.sourceLogo_) $ tag "logo" mempty . content . decodeUtf8 . serializeUriReference' forM_ (s^.sourceRights_) $ renderAtomText "rights" forM_ (s^.sourceSubtitle_) $ renderAtomText "subtitle" forM_ (s^.sourceTitle_) $ renderAtomText "title"@@ -101,13 +99,13 @@ -- | Render an @atom:generator@ element. renderAtomGenerator :: (Monad m) => AtomGenerator -> Source m Event renderAtomGenerator g = tag "generator" attributes . content . toNullable $ g^.generatorContent_- where attributes = optionalAttr "uri" (tshow <$> g^.generatorUri_)+ where attributes = optionalAttr "uri" (decodeUtf8 . serializeUriReference' <$> g^.generatorUri_) <> nonEmptyAttr "version" (g^.generatorVersion_) -- | Render an @atom:link@ element. renderAtomLink :: (Monad m) => AtomLink -> Source m Event renderAtomLink l = tag "link" linkAttrs $ return ()- where linkAttrs = attr "href" (tshow $ l^.linkHref_)+ where linkAttrs = attr "href" (decodeUtf8 . serializeUriReference' $ l^.linkHref_) <> nonEmptyAttr "rel" (l^.linkRel_) <> nonEmptyAttr "type" (l^.linkType_) <> nonEmptyAttr "hreflang" (l^.linkLang_)@@ -126,7 +124,7 @@ renderAtomPerson name p = tag name mempty $ do tag "name" mempty . content . toNullable $ p^.personName_ unless (Text.null $ p^.personEmail_) $ tag "email" mempty . content $ p^.personEmail_- forM_ (p^.personUri_) $ tag "uri" mempty . content . tshow+ forM_ (p^.personUri_) $ tag "uri" mempty . content . decodeUtf8 . serializeUriReference' -- | Render an atom text construct. renderAtomText :: (Monad m) => Name -> AtomText -> Source m Event@@ -136,9 +134,6 @@ renderAtomText name (AtomPlainText TypeText t) = tag name mempty $ content t -tshow :: (Show a) => a -> Text-tshow = pack . show- dateTag :: (Monad m) => Name -> UTCTime -> Source m Event dateTag name = tag name mempty . content . formatTimeRFC3339 . utcToZonedTime utc @@ -146,3 +141,7 @@ nonEmptyAttr name value | value == mempty = mempty | otherwise = attr name value++-- serializeUriReference' :: UriReference -> ByteString+serializeUriReference' (UriReferenceUri u) = serializeURI' u+serializeUriReference' (UriReferenceRelativeRef r) = serializeRelativeRef' r
Text/Atom/Types.hs view
@@ -31,161 +31,164 @@ module Text.Atom.Types where -- {{{ Imports-import Control.Lens.TH+import Control.Lens.Combinators import Data.NonNull-import Data.Text hiding (map)+import Data.Text hiding (map) import Data.Time.Clock-import Data.Time.LocalTime-import Data.XML.Types+import Data.Time.LocalTime () import GHC.Generics -import Network.URI+import URI.ByteString -- }}} -data TextType = TypeText | TypeHTML deriving(Eq, Generic, Show)+data TextType = TypeText | TypeHTML+ deriving(Eq, Generic, Show) +-- | Either a 'URI', or a 'RelativeRef' (as defined by RFC 3986)+data UriReference = UriReferenceUri URI | UriReferenceRelativeRef RelativeRef+ deriving(Eq, Generic, Show)+ -- | An atom text construct.-declarePrisms [d|- data AtomText = AtomPlainText { atomPlainTextType_ :: TextType, atomPlainTextText_ :: Text }- | AtomXHTMLText { atomXHTMLTextDiv_ :: Text }- |]+data AtomText = AtomPlainText TextType Text+ | AtomXHTMLText Text +makePrisms ''AtomText+ deriving instance Eq AtomText deriving instance Generic AtomText deriving instance Show AtomText -- | An atom person construct.-declareLenses [d|- data AtomPerson = AtomPerson- { personName_ :: NonNull Text- , personEmail_ :: Text- , personUri_ :: Maybe URI- }- |]+data AtomPerson = AtomPerson+ { _personName_ :: NonNull Text+ , _personEmail_ :: Text+ , _personUri_ :: Maybe UriReference+ } +makeLenses ''AtomPerson+ deriving instance Eq AtomPerson deriving instance Generic AtomPerson deriving instance Show AtomPerson -- | The @atom:category@ element.-declareLenses [d|- data AtomCategory = AtomCategory- { categoryTerm_ :: NonNull Text- , categoryScheme_ :: Text- , categoryLabel_ :: Text- }- |]+data AtomCategory = AtomCategory+ { _categoryTerm_ :: NonNull Text+ , _categoryScheme_ :: Text+ , _categoryLabel_ :: Text+ } +makeLenses ''AtomCategory+ deriving instance Eq AtomCategory deriving instance Generic AtomCategory deriving instance Show AtomCategory -- | The @atom:link@ element.-declareLenses [d|- data AtomLink = AtomLink- { linkHref_ :: URI- , linkRel_ :: Text- , linkType_ :: Text- , linkLang_ :: Text- , linkTitle_ :: Text- , linkLength_ :: Text- }- |]+data AtomLink = AtomLink+ { _linkHref_ :: UriReference+ , _linkRel_ :: Text+ , _linkType_ :: Text+ , _linkLang_ :: Text+ , _linkTitle_ :: Text+ , _linkLength_ :: Text+ } +makeLenses ''AtomLink+ deriving instance Eq AtomLink deriving instance Generic AtomLink deriving instance Show AtomLink -- | The @atom:generator@ element.-declareLenses [d|- data AtomGenerator = AtomGenerator- { generatorUri_ :: Maybe URI- , generatorVersion_ :: Text- , generatorContent_ :: NonNull Text- }- |]+data AtomGenerator = AtomGenerator+ { _generatorUri_ :: Maybe UriReference+ , _generatorVersion_ :: Text+ , _generatorContent_ :: NonNull Text+ } +makeLenses ''AtomGenerator+ deriving instance Eq AtomGenerator deriving instance Generic AtomGenerator deriving instance Show AtomGenerator -- | The @atom:source@ element.-declareLenses [d|- data AtomSource = AtomSource- { sourceAuthors_ :: [AtomPerson]- , sourceCategories_ :: [AtomCategory]- , sourceContributors_ :: [AtomPerson]- , sourceGenerator_ :: Maybe AtomGenerator- , sourceIcon_ :: Maybe URI- , sourceId_ :: Text- , sourceLinks_ :: [AtomLink]- , sourceLogo_ :: Maybe URI- , sourceRights_ :: Maybe AtomText- , sourceSubtitle_ :: Maybe AtomText- , sourceTitle_ :: Maybe AtomText- , sourceUpdated_ :: Maybe UTCTime- }- |]+data AtomSource = AtomSource+ { _sourceAuthors_ :: [AtomPerson]+ , _sourceCategories_ :: [AtomCategory]+ , _sourceContributors_ :: [AtomPerson]+ , _sourceGenerator_ :: Maybe AtomGenerator+ , _sourceIcon_ :: Maybe UriReference+ , _sourceId_ :: Text+ , _sourceLinks_ :: [AtomLink]+ , _sourceLogo_ :: Maybe UriReference+ , _sourceRights_ :: Maybe AtomText+ , _sourceSubtitle_ :: Maybe AtomText+ , _sourceTitle_ :: Maybe AtomText+ , _sourceUpdated_ :: Maybe UTCTime+ } +makeLenses ''AtomSource+ deriving instance Eq AtomSource deriving instance Generic AtomSource deriving instance Show AtomSource +type Type = Text+ -- | The @atom:content@ element.-declareLenses [d|- data AtomContent- = AtomContentInlineText { atomContentInlineTextType_ :: TextType, atomContentInlineTextText_ :: Text }- | AtomContentInlineXHTML { atomContentInlineXHTMLDiv_ :: Text }- | AtomContentInlineOther { atomContentInlineOtherType_ :: Text, atomContentInlineOtherText_ :: Text }- | AtomContentOutOfLine { atomContentOutOfLineType_ :: Text, atomContentOutOfLineUri_ :: URI }- |]+data AtomContent = AtomContentInlineText TextType Text+ | AtomContentInlineXHTML Text+ | AtomContentInlineOther Type Text+ | AtomContentOutOfLine Type UriReference deriving instance Eq AtomContent deriving instance Generic AtomContent deriving instance Show AtomContent -- | The @atom:entry@ element.-declareLenses [d|- data AtomEntry = AtomEntry- { entryAuthors_ :: [AtomPerson]- , entryCategories_ :: [AtomCategory]- , entryContent_ :: Maybe AtomContent- , entryContributors_ :: [AtomPerson]- , entryId_ :: NonNull Text- , entryLinks_ :: [AtomLink]- , entryPublished_ :: Maybe UTCTime- , entryRights_ :: Maybe AtomText- , entrySource_ :: Maybe AtomSource- , entrySummary_ :: Maybe AtomText- , entryTitle_ :: AtomText- , entryUpdated_ :: UTCTime- }- |]+data AtomEntry = AtomEntry+ { _entryAuthors_ :: [AtomPerson]+ , _entryCategories_ :: [AtomCategory]+ , _entryContent_ :: Maybe AtomContent+ , _entryContributors_ :: [AtomPerson]+ , _entryId_ :: NonNull Text+ , _entryLinks_ :: [AtomLink]+ , _entryPublished_ :: Maybe UTCTime+ , _entryRights_ :: Maybe AtomText+ , _entrySource_ :: Maybe AtomSource+ , _entrySummary_ :: Maybe AtomText+ , _entryTitle_ :: AtomText+ , _entryUpdated_ :: UTCTime+ } +makeLenses ''AtomEntry+ deriving instance Eq AtomEntry deriving instance Generic AtomEntry deriving instance Show AtomEntry -- | The @atom:feed@ element.-declareLenses [d|- data AtomFeed = AtomFeed- { feedAuthors_ :: [AtomPerson]- , feedCategories_ :: [AtomCategory]- , feedContributors_ :: [AtomPerson]- , feedEntries_ :: [AtomEntry]- , feedGenerator_ :: Maybe AtomGenerator- , feedIcon_ :: Maybe URI- , feedId_ :: NonNull Text- , feedLinks_ :: [AtomLink]- , feedLogo_ :: Maybe URI- , feedRights_ :: Maybe AtomText- , feedSubtitle_ :: Maybe AtomText- , feedTitle_ :: AtomText- , feedUpdated_ :: UTCTime- }- |]+data AtomFeed = AtomFeed+ { _feedAuthors_ :: [AtomPerson]+ , _feedCategories_ :: [AtomCategory]+ , _feedContributors_ :: [AtomPerson]+ , _feedEntries_ :: [AtomEntry]+ , _feedGenerator_ :: Maybe AtomGenerator+ , _feedIcon_ :: Maybe UriReference+ , _feedId_ :: NonNull Text+ , _feedLinks_ :: [AtomLink]+ , _feedLogo_ :: Maybe UriReference+ , _feedRights_ :: Maybe AtomText+ , _feedSubtitle_ :: Maybe AtomText+ , _feedTitle_ :: AtomText+ , _feedUpdated_ :: UTCTime+ }++makeLenses ''AtomFeed deriving instance Eq AtomFeed deriving instance Generic AtomFeed
atom-conduit.cabal view
@@ -1,16 +1,14 @@ name: atom-conduit-version: 0.1.0.0+version: 0.2.0.0 synopsis: Streaming parser/renderer for the Atom 1.0 standard (RFC 4287).-description:- This library implements the Atom 1.0 syndication format (<http://tools.ietf.org/html/rfc4287>) as a 'conduit' parser/renderer.+-- description: license: OtherLicense license-file: LICENSE author: koral maintainer: koral att mailoo dott org--- copyright: category: XML, Conduit build-type: Simple--- extra-source-files:+extra-source-files: README.md cabal-version: >=1.10 source-repository head@@ -27,15 +25,16 @@ base >= 4.8 && < 5 , conduit , conduit-parse- , containers , exceptions+ , foldl , lens , mono-traversable- , network-uri , parsers , text , time >= 1.5 , timerep >= 2.0+ , total+ , uri-bytestring >= 0.1.9 , xml-conduit >= 1.3 , xml-conduit-parse >= 0.3 , xml-types@@ -46,7 +45,7 @@ hs-source-dirs: test main-is: Main.hs build-depends: atom-conduit,- base >=4.8,+ base >= 4.8, conduit, conduit-parse, data-default,@@ -54,9 +53,7 @@ hlint, lens, mono-traversable,- network-uri, parsers,- -- QuickCheck, quickcheck-instances, resourcet, tasty,@@ -64,6 +61,7 @@ tasty-quickcheck, time >= 1.5, text,+ uri-bytestring >= 0.1.9, xml-conduit >= 1.3, xml-conduit-parse >= 0.3, xml-types
test/Main.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} import Control.Lens.Getter+import Control.Lens.Operators+import Control.Lens.Setter import Control.Monad import Control.Monad.Catch.Pure import Control.Monad.Trans.Resource@@ -17,11 +19,10 @@ import Data.MonoTraversable import Data.NonNull import Data.Text as Text+import Data.Text.Encoding as Text import Data.Time.Clock import Data.XML.Types -import Network.URI- import qualified Language.Haskell.HLint as HLint (hlint) import Test.QuickCheck.Instances import Test.Tasty@@ -33,6 +34,7 @@ import Text.Atom.Types import Text.Parser.Combinators +import URI.ByteString main :: IO () main = defaultMain $ testGroup "Tests"@@ -53,21 +55,21 @@ properties :: TestTree properties = testGroup "Properties"- [ inverseAtomTextProperty- , inverseAtomPersonProperty- , inverseAtomCategoryProperty- , inverseAtomLinkProperty- , inverseAtomGeneratorProperty- , inverseAtomSourceProperty- , inverseAtomContentProperty- , inverseAtomEntryProperty- -- , inverseAtomFeedProperty+ [ roundtripAtomTextProperty+ , roundtripAtomPersonProperty+ , roundtripAtomCategoryProperty+ , roundtripAtomLinkProperty+ , roundtripAtomGeneratorProperty+ , roundtripAtomSourceProperty+ , roundtripAtomContentProperty+ , roundtripAtomEntryProperty+ -- , roundtripAtomFeedProperty ] linkCase :: TestTree linkCase = testCase "Link element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomLink- show (result ^. linkHref_) @?= "/feed"+ result ^. linkHref_ @?= UriReferenceRelativeRef (RelativeRef Nothing "/feed" (Query []) Nothing) (result ^. linkRel_) @?= "self" where input = ["<link rel=\"self\" href=\"/feed\" />"] @@ -76,7 +78,7 @@ result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser (atomPerson "author") toNullable (result ^. personName_) @?= "John Doe" result ^. personEmail_ @?= "JohnDoe@example.com"- show <$> (result ^. personUri_) @?= Just "http://example.com/~johndoe"+ result ^. personUri_ @?= Just (UriReferenceUri $ URI (Scheme "http") (Just $ Authority Nothing (Host "example.com") Nothing) "/~johndoe" (Query []) Nothing) where input = [ "<author>" , "<name>John Doe</name>"@@ -88,7 +90,7 @@ generatorCase :: TestTree generatorCase = testCase "Generator element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomGenerator- show <$> (result ^. generatorUri_) @?= Just "/myblog.php"+ result ^. generatorUri_ @?= Just (UriReferenceRelativeRef $ RelativeRef Nothing "/myblog.php" (Query []) Nothing) (result ^. generatorVersion_) @?= "1.0" toNullable (result ^. generatorContent_) @?= "Example Toolkit" where input =@@ -162,69 +164,92 @@ Prelude.null result @?= True -inverseAtomTextProperty :: TestTree-inverseAtomTextProperty = testProperty "parse . render = id (AtomText)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomText "test" i =$= runConduitParser (atomText "test"))+roundtripAtomTextProperty :: TestTree+roundtripAtomTextProperty = testProperty "parse . render = id (AtomText)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomText "test" i =$= runConduitParser (atomText "test")) -inverseAtomPersonProperty :: TestTree-inverseAtomPersonProperty = testProperty "parse . render = id (AtomPerson)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomPerson "test" i =$= runConduitParser (atomPerson "test"))+roundtripAtomPersonProperty :: TestTree+roundtripAtomPersonProperty = testProperty "parse . render = id (AtomPerson)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomPerson "test" i =$= runConduitParser (atomPerson "test")) -inverseAtomCategoryProperty :: TestTree-inverseAtomCategoryProperty = testProperty "parse . render = id (AtomCategory)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomCategory i =$= runConduitParser atomCategory)+roundtripAtomCategoryProperty :: TestTree+roundtripAtomCategoryProperty = testProperty "parse . render = id (AtomCategory)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomCategory i =$= runConduitParser atomCategory) -inverseAtomLinkProperty :: TestTree-inverseAtomLinkProperty = testProperty "parse . render = id (AtomLink)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomLink i =$= runConduitParser atomLink)+roundtripAtomLinkProperty :: TestTree+roundtripAtomLinkProperty = testProperty "parse . render = id (AtomLink)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomLink i =$= runConduitParser atomLink) -inverseAtomGeneratorProperty :: TestTree-inverseAtomGeneratorProperty = testProperty "parse . render = id (AtomGenerator)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomGenerator i =$= runConduitParser atomGenerator)+roundtripAtomGeneratorProperty :: TestTree+roundtripAtomGeneratorProperty = testProperty "parse . render = id (AtomGenerator)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomGenerator i =$= runConduitParser atomGenerator) -inverseAtomSourceProperty :: TestTree-inverseAtomSourceProperty = testProperty "parse . render = id (AtomSource)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomSource i =$= runConduitParser atomSource)+roundtripAtomSourceProperty :: TestTree+roundtripAtomSourceProperty = testProperty "parse . render = id (AtomSource)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomSource i =$= runConduitParser atomSource) -inverseAtomContentProperty :: TestTree-inverseAtomContentProperty = testProperty "parse . render = id (AtomContent)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomContent i =$= runConduitParser atomContent)+roundtripAtomContentProperty :: TestTree+roundtripAtomContentProperty = testProperty "parse . render = id (AtomContent)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomContent i =$= runConduitParser atomContent) -inverseAtomFeedProperty :: TestTree-inverseAtomFeedProperty = testProperty "parse . render = id (AtomFeed)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomFeed i =$= runConduitParser atomFeed)+roundtripAtomFeedProperty :: TestTree+roundtripAtomFeedProperty = testProperty "parse . render = id (AtomFeed)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomFeed i =$= runConduitParser atomFeed) -inverseAtomEntryProperty :: TestTree-inverseAtomEntryProperty = testProperty "parse . render = id (AtomEntry)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomEntry i =$= runConduitParser atomEntry)+roundtripAtomEntryProperty :: TestTree+roundtripAtomEntryProperty = testProperty "parse . render = id (AtomEntry)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomEntry i =$= runConduitParser atomEntry) -alphaNum = oneof [choose('a', 'z'), suchThat arbitrary isDigit]+letter = choose ('a', 'z')+digit = arbitrary `suchThat` isDigit+alphaNum = oneof [letter, digit] instance (MonoFoldable a, Arbitrary a) => Arbitrary (MinLen (Succ Zero) a) where arbitrary = nonNull <$> arbitrary `suchThat` (not . onull) -instance Arbitrary URIAuth where+instance Arbitrary Scheme where arbitrary = do- userInfo <- oneof [return "", (++ "@") <$> listOf1 alphaNum]- regName <- listOf1 alphaNum- port <- oneof [return "", (":" ++) . show <$> choose(1 :: Int, 65535)]- return $ URIAuth userInfo regName port+ 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 = do- scheme <- (++ ":") <$> listOf1 (choose('a', 'z'))- path <- ("/" ++) <$> listOf1 alphaNum- query <- oneof [return "", ("?" ++) <$> listOf1 alphaNum]- fragment <- oneof [return "", ("#" ++) <$> listOf1 alphaNum]- authority <- arbitrary- return $ URI scheme authority path query fragment+ arbitrary = URI <$> arbitrary+ <*> arbitrary+ <*> (encodeUtf8 . pack . ('/' :) <$> listOf1 alphaNum)+ <*> arbitrary+ <*> oneof [pure Nothing, Just <$> (encodeUtf8 . pack <$> listOf1 alphaNum)] +instance Arbitrary UriReference where+ arbitrary = oneof [UriReferenceUri <$> arbitrary, UriReferenceRelativeRef <$> arbitrary]++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]- -- shrink = genericShrink instance Arbitrary AtomText where arbitrary = oneof- [ AtomPlainText <$> arbitrary <*> arbitrary- , AtomXHTMLText <$> arbitrary+ [ AtomPlainText <$> arbitrary <*> (pack <$> listOf1 alphaNum)+ , AtomXHTMLText <$> (pack <$> listOf1 alphaNum) ] shrink = genericShrink instance Arbitrary AtomPerson where arbitrary = AtomPerson <$> arbitrary <*> arbitrary <*> arbitrary- -- shrink = genericShrink instance Arbitrary AtomCategory where arbitrary = AtomCategory <$> arbitrary <*> arbitrary <*> arbitrary@@ -233,14 +258,15 @@ arbitrary = AtomLink <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary AtomGenerator where- arbitrary = AtomGenerator <$> arbitrary <*> arbitrary <*> arbitrary+ arbitrary = do+ Just content <- fromNullable . 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- -- shrink = genericShrink instance Arbitrary AtomContent where arbitrary = oneof