diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Text/Atom/Conduit/Parse.hs b/Text/Atom/Conduit/Parse.hs --- a/Text/Atom/Conduit/Parse.hs +++ b/Text/Atom/Conduit/Parse.hs @@ -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 element" $ tagIgnoreAttrs "feed" $ do - builders <- many $ choice atomFeedBuilders - let result = (appEndo $ mconcat builders) dummy - when (checkDummy result) $ unexpected "Missing sub-elements in ." - 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 element" $ tagIgnoreAttrs "entry" $ do - builders <- many $ choice atomEntryBuilders - let result = (appEndo $ mconcat builders) dummy - when (checkDummy result) $ unexpected "Missing sub-elements in ." - 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: +-- +-- > +-- > John Doe +-- > JohnDoe@example.com +-- > http://example.com/~johndoe +-- > +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 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: +-- +-- > +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: --- --- > --- > http://example.org/ --- > Fourty-Two --- > 2003-12-13T18:30:02Z --- > © 2005 Example, Inc. --- > -atomSource :: (MonadCatch m) => ConduitParser Event m AtomSource -atomSource = named "Atom 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: --- --- > --- > Example Toolkit --- > -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: --- --- > -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: --- --- > --- > John Doe --- > JohnDoe@example.com --- > http://example.com/~johndoe --- > -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 @@ -- > 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: +-- +-- > +-- > Example Toolkit +-- > +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: +-- +-- > +-- > http://example.org/ +-- > Fourty-Two +-- > 2003-12-13T18:30:02Z +-- > © 2005 Example, Inc. +-- > +atomSource :: (MonadCatch m) => ConduitParser Event m AtomSource +atomSource = named "Atom 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 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 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 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 + ] diff --git a/Text/Atom/Conduit/Render.hs b/Text/Atom/Conduit/Render.hs --- a/Text/Atom/Conduit/Render.hs +++ b/Text/Atom/Conduit/Render.hs @@ -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 diff --git a/Text/Atom/Types.hs b/Text/Atom/Types.hs --- a/Text/Atom/Types.hs +++ b/Text/Atom/Types.hs @@ -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 diff --git a/atom-conduit.cabal b/atom-conduit.cabal --- a/atom-conduit.cabal +++ b/atom-conduit.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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