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 @@ -24,20 +24,21 @@ ) where -- {{{ Imports -import Text.Atom.Types +import Blaze.ByteString.Builder (toByteString) -import Control.Applicative -import Control.Foldl hiding (mconcat, set) -import Control.Monad hiding (foldM) -import Control.Monad.Catch +import Conduit (foldC, headC, headDefC, sinkList) -import Data.Conduit.Parser -import Data.Conduit.Parser.XML +import Control.Applicative hiding (many) +import Control.Exception.Safe as Exception +import Control.Monad hiding (foldM) +import Control.Monad.Fix + +import Data.Conduit import Data.Maybe import Data.Monoid import Data.MonoTraversable -import Data.NonNull (NonNull, fromNullable, toNullable) -import Data.Text as Text (Text) +import Data.NonNull (NonNull, fromNullable, toNullable) +import Data.Text as Text (Text, unpack) import Data.Text.Encoding import Data.Time.Clock import Data.Time.LocalTime @@ -46,66 +47,85 @@ import Lens.Simple -import Prelude hiding (last, lookup) +import Prelude hiding (last, lookup) -import Text.Parser.Combinators +import Text.Atom.Types +import Text.XML.Stream.Parse +import qualified Text.XML.Stream.Render as Render import URI.ByteString -- }}} -- {{{ Util -data AtomException = InvalidURI URIParseError +data AtomException = InvalidDate Text + | InvalidURI URIParseError + | MissingElement Text | NullElement deriving instance Eq AtomException deriving instance Show AtomException instance Exception AtomException where - displayException (InvalidURI e) = "Invalid URI reference: " ++ show e - displayException NullElement = "Null element" + displayException (InvalidDate t) = "Invalid date: " ++ unpack t + displayException (InvalidURI e) = "Invalid URI reference: " ++ show e + displayException (MissingElement t) = "Missing element: " ++ unpack t + displayException NullElement = "Null element" -asURIReference :: (MonadThrow m) => Text -> m AtomURI +asURIReference :: MonadThrow m => Text -> m AtomURI asURIReference t = case (parseURI' t, parseRelativeRef' t) of - (Right u, _) -> return $ AtomURI u - (_, Right u) -> return $ AtomURI u + (Right u, _) -> return $ AtomURI u + (_, Right u) -> return $ AtomURI 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 +asNonNull = liftMaybe NullElement . fromNullable +liftMaybe :: (MonadThrow m, Exception e) => e -> Maybe a -> m a +liftMaybe e = maybe (throw e) return + -- | 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) +tagName' :: MonadThrow m => Text -> AttrParser a -> (a -> ConduitM Event o m b) -> ConduitM Event o m (Maybe b) +tagName' t = tagPredicate (\n -> nameLocalName n == t && nameNamespace n == Just "http://www.w3.org/2005/Atom") -- | Tag which content is a date-time that follows RFC 3339 format. -tagDate :: (MonadCatch m) => Text -> ConduitParser Event m UTCTime -tagDate name = tagIgnoreAttrs' name $ content (fmap zonedTimeToUTC . parseTimeRFC3339) +tagDate :: MonadThrow m => Text -> ConduitM Event o m (Maybe UTCTime) +tagDate name = tagIgnoreAttrs' name $ do + text <- content + zonedTimeToUTC <$> liftMaybe (InvalidDate text) (parseTimeRFC3339 text) -- | Like 'tagName'' but ignores all attributes. -tagIgnoreAttrs' :: (MonadCatch m) => Text -> ConduitParser Event m a -> ConduitParser Event m a +tagIgnoreAttrs' :: MonadThrow m => Text -> ConduitM Event o m a -> ConduitM Event o m (Maybe a) tagIgnoreAttrs' name handler = tagName' name ignoreAttrs $ const handler -unknownTag :: (MonadCatch m) => ConduitParser Event m () -unknownTag = anyTag $ \_ _ -> void $ many (void unknownTag <|> void textContent) +xhtmlContent :: MonadThrow m => ConduitM Event o m Text +xhtmlContent = fmap (decodeUtf8 . toByteString) $ takeAllTreesContent =$= Render.renderBuilder def =$= foldC -atomId :: (MonadCatch m) => ConduitParser Event m (NonNull Text) -atomId = tagIgnoreAttrs' "id" $ content asNonNull -atomIcon, atomLogo :: (MonadCatch m) => ConduitParser Event m AtomURI -atomIcon = tagIgnoreAttrs' "icon" $ content asURIReference -atomLogo = tagIgnoreAttrs' "logo" $ content asURIReference +projectC :: Monad m => Fold a a' b b' -> Conduit a m b +projectC prism = fix $ \recurse -> do + item <- await + case (item, item ^? (_Just . prism)) of + (_, Just a) -> yield a >> recurse + (Just _, _) -> recurse + _ -> return () -lastRequired :: (Monad m, Parsing m) => String -> FoldM m a a -lastRequired e = FoldM (\_ a -> return $ Right a) (return $ Left e) (either unexpected return) +headRequiredC :: MonadThrow m => Text -> Consumer a m a +headRequiredC e = liftMaybe (MissingElement e) =<< headC + +atomId :: MonadThrow m => ConduitM Event o m (Maybe Text) +atomId = tagIgnoreAttrs' "id" content + +atomIcon, atomLogo :: MonadThrow m => ConduitM Event o m (Maybe AtomURI) +atomIcon = tagIgnoreAttrs' "icon" $ content >>= asURIReference +atomLogo = tagIgnoreAttrs' "logo" $ content >>= asURIReference -- }}} data PersonPiece = PersonName (NonNull Text) | PersonEmail Text | PersonUri AtomURI - | PersonUnknown makeTraversals ''PersonPiece @@ -117,43 +137,40 @@ -- > 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 - ] +atomPerson :: MonadThrow m => Text -> ConduitM Event o m (Maybe AtomPerson) +atomPerson name = tagIgnoreAttrs' name $ (manyYield' (choose piece) =$= parser) <* many ignoreAllTreesContent where + parser = getZipConduit $ AtomPerson + <$> ZipConduit (projectC _PersonName =$= headRequiredC "Missing or invalid element") + <*> ZipConduit (projectC _PersonEmail =$= headDefC "") + <*> ZipConduit (projectC _PersonUri =$= headC) + piece = [ fmap PersonName <$> tagIgnoreAttrs' "name" (content >>= asNonNull) + , fmap PersonEmail <$> tagIgnoreAttrs' "email" content + , fmap PersonUri <$> tagIgnoreAttrs' "uri" (content >>= asURIReference) + ] -- | Parse an @atom:category@ element. -- Example: -- -- > -atomCategory :: (MonadCatch m) => ConduitParser Event m AtomCategory +atomCategory :: MonadThrow m => ConduitM Event o m (Maybe 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) + where categoryAttrs = (,,) <$> requireAttr "term" + <*> (requireAttr "scheme" <|> pure mempty) + <*> (requireAttr "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" 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 +atomContent :: MonadThrow m => ConduitM Event o m (Maybe AtomContent) +atomContent = tagName' "content" contentAttrs handler where + contentAttrs = (,) <$> optional (requireAttr "type") <*> optional (requireAttr "src" >>= asURIReference) <* ignoreAttrs + handler (Just "xhtml", _) = AtomContentInlineXHTML <$> force "
" (tagIgnoreAttrs "{http://www.w3.org/1999/xhtml}div" xhtmlContent) + handler (ctype, Just uri) = return $ AtomContentOutOfLine (fromMaybe mempty ctype) uri + handler (Just "html", _) = AtomContentInlineText TypeHTML <$> content + handler (Nothing, _) = AtomContentInlineText TypeText <$> content + handler (Just ctype, _) = AtomContentInlineOther ctype <$> content -- | Parse an @atom:link@ element. -- Examples: @@ -161,15 +178,15 @@ -- > -- -- > -atomLink :: (MonadCatch m) => ConduitParser Event m AtomLink +atomLink :: MonadThrow m => ConduitM Event o m (Maybe AtomLink) atomLink = tagName' "link" linkAttrs $ \(href, rel, ltype, lang, title, length') -> return $ AtomLink href rel ltype lang title length' - where linkAttrs = (,,,,,) <$> attr "href" asURIReference - <*> (textAttr "rel" <|> pure mempty) - <*> (textAttr "type" <|> pure mempty) - <*> (textAttr "hreflang" <|> pure mempty) - <*> (textAttr "title" <|> pure mempty) - <*> (textAttr "length" <|> pure mempty) + where linkAttrs = (,,,,,) <$> (requireAttr "href" >>= asURIReference) + <*> (requireAttr "rel" <|> pure mempty) + <*> (requireAttr "type" <|> pure mempty) + <*> (requireAttr "hreflang" <|> pure mempty) + <*> (requireAttr "title" <|> pure mempty) + <*> (requireAttr "length" <|> pure mempty) <* ignoreAttrs -- | Parse an Atom text construct. @@ -186,18 +203,11 @@ -- > AT&T bought by SBC! -- >
-- > -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 - handler (Just "html") = AtomPlainText TypeHTML <$> textContent - handler _ = AtomPlainText TypeText <$> textContent - xhtmlContent :: MonadCatch m => ConduitParser Event m Text - xhtmlContent = mconcat <$> many (textContent <|> anyTag (\name attrs -> renderTag name attrs <$> xhtmlContent)) - renderTag name attrs content = "<" <> nameLocalName name <> renderAttrs attrs <> ">" <> content <> " nameLocalName name <> ">" - renderAttrs [] = "" - renderAttrs ((name, content):t) = " " <> nameLocalName name <> "=\"" <> mconcat (renderContent <$> content) <> "\"" <> renderAttrs t - renderContent (ContentText t) = t - renderContent (ContentEntity t) = t +atomText :: MonadThrow m => Text -> ConduitM Event o m (Maybe AtomText) +atomText name = tagName' name (optional (requireAttr "type") <* ignoreAttrs) handler + where handler (Just "xhtml") = AtomXHTMLText <$> force "
" (tagIgnoreAttrs' "div" xhtmlContent) + handler (Just "html") = AtomPlainText TypeHTML <$> content + handler _ = AtomPlainText TypeText <$> content -- | Parse an @atom:generator@ element. -- Example: @@ -205,9 +215,9 @@ -- > -- > 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 +atomGenerator :: MonadThrow m => ConduitM Event o m (Maybe AtomGenerator) +atomGenerator = tagName' "generator" generatorAttrs $ \(uri, version) -> AtomGenerator uri version <$> (asNonNull =<< content) + where generatorAttrs = (,) <$> optional (requireAttr "uri" >>= asURIReference) <*> (requireAttr "version" <|> pure mempty) <* ignoreAttrs data SourcePiece = SourceAuthor AtomPerson @@ -222,7 +232,6 @@ | SourceSubtitle AtomText | SourceTitle AtomText | SourceUpdated UTCTime - | SourceUnknown makeTraversals ''SourcePiece @@ -235,44 +244,41 @@ -- > 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 - ] +atomSource :: MonadThrow m => ConduitM Event o m (Maybe AtomSource) +atomSource = tagIgnoreAttrs' "source" $ manyYield' (choose piece) =$= zipConduit where + zipConduit = getZipConduit $ AtomSource + <$> ZipConduit (projectC _SourceAuthor =$= sinkList) + <*> ZipConduit (projectC _SourceCategory =$= sinkList) + <*> ZipConduit (projectC _SourceContributor =$= sinkList) + <*> ZipConduit (projectC _SourceGenerator =$= headC) + <*> ZipConduit (projectC _SourceIcon =$= headC) + <*> ZipConduit (projectC _SourceId =$= headDefC "") + <*> ZipConduit (projectC _SourceLink =$= sinkList) + <*> ZipConduit (projectC _SourceLogo =$= headC) + <*> ZipConduit (projectC _SourceRights =$= headC) + <*> ZipConduit (projectC _SourceSubtitle =$= headC) + <*> ZipConduit (projectC _SourceTitle =$= headC) + <*> ZipConduit (projectC _SourceUpdated =$= headC) + piece = [ fmap SourceAuthor <$> atomPerson "author" + , fmap SourceCategory <$> atomCategory + , fmap SourceContributor <$> atomPerson "contributor" + , fmap SourceGenerator <$> atomGenerator + , fmap SourceIcon <$> atomIcon + , fmap SourceId <$> atomId + , fmap SourceLink <$> atomLink + , fmap SourceLogo <$> atomLogo + , fmap SourceRights <$> atomText "rights" + , fmap SourceSubtitle <$> atomText "subtitle" + , fmap SourceTitle <$> atomText "title" + , fmap SourceUpdated <$> tagDate "updated" + ] data EntryPiece = EntryAuthor AtomPerson | EntryCategory AtomCategory | EntryContent AtomContent | EntryContributor AtomPerson - | EntryId (NonNull Text) + | EntryId Text | EntryLink AtomLink | EntryPublished UTCTime | EntryRights AtomText @@ -280,42 +286,38 @@ | EntrySummary AtomText | EntryTitle AtomText | EntryUpdated UTCTime - | EntryUnknown makeTraversals ''EntryPiece -- | 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 - ] +atomEntry :: MonadThrow m => ConduitM Event o m (Maybe AtomEntry) +atomEntry = tagIgnoreAttrs' "entry" $ manyYield' (choose piece) =$= zipConduit where + zipConduit = getZipConduit $ AtomEntry + <$> ZipConduit (projectC _EntryAuthor =$= sinkList) + <*> ZipConduit (projectC _EntryCategory =$= sinkList) + <*> ZipConduit (projectC _EntryContent =$= headC) + <*> ZipConduit (projectC _EntryContributor =$= sinkList) + <*> ZipConduit (projectC _EntryId =$= headRequiredC "Missing <id> element") + <*> ZipConduit (projectC _EntryLink =$= sinkList) + <*> ZipConduit (projectC _EntryPublished =$= headC) + <*> ZipConduit (projectC _EntryRights =$= headC) + <*> ZipConduit (projectC _EntrySource =$= headC) + <*> ZipConduit (projectC _EntrySummary =$= headC) + <*> ZipConduit (projectC _EntryTitle =$= headRequiredC "Missing or invalid <title> element.") + <*> ZipConduit (projectC _EntryUpdated =$= headRequiredC "Missing or invalid <updated> element.") + piece = [ fmap EntryAuthor <$> atomPerson "author" + , fmap EntryCategory <$> atomCategory + , fmap EntryContent <$> atomContent + , fmap EntryContributor <$> atomPerson "contributor" + , fmap EntryId <$> atomId + , fmap EntryLink <$> atomLink + , fmap EntryPublished <$> tagDate "published" + , fmap EntryRights <$> atomText "rights" + , fmap EntrySource <$> atomSource + , fmap EntrySummary <$> atomText "summary" + , fmap EntryTitle <$> atomText "title" + , fmap EntryUpdated <$> tagDate "updated" + ] data FeedPiece = FeedAuthor AtomPerson @@ -324,48 +326,44 @@ | FeedEntry AtomEntry | FeedGenerator AtomGenerator | FeedIcon AtomURI - | FeedId (NonNull Text) + | FeedId Text | FeedLink AtomLink | FeedLogo AtomURI | FeedRights AtomText | FeedSubtitle AtomText | FeedTitle AtomText | FeedUpdated UTCTime - | FeedUnknown makeTraversals ''FeedPiece -- | 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 - ] +atomFeed :: MonadThrow m => ConduitM Event o m (Maybe AtomFeed) +atomFeed = tagIgnoreAttrs' "feed" $ manyYield' (choose piece) =$= zipConduit where + zipConduit = getZipConduit $ AtomFeed + <$> ZipConduit (projectC _FeedAuthor =$= sinkList) + <*> ZipConduit (projectC _FeedCategory =$= sinkList) + <*> ZipConduit (projectC _FeedContributor =$= sinkList) + <*> ZipConduit (projectC _FeedEntry =$= sinkList) + <*> ZipConduit (projectC _FeedGenerator =$= headC) + <*> ZipConduit (projectC _FeedIcon =$= headC) + <*> ZipConduit (projectC _FeedId =$= headRequiredC "Missing <id> element") + <*> ZipConduit (projectC _FeedLink =$= sinkList) + <*> ZipConduit (projectC _FeedLogo =$= headC) + <*> ZipConduit (projectC _FeedRights =$= headC) + <*> ZipConduit (projectC _FeedSubtitle =$= headC) + <*> ZipConduit (projectC _FeedTitle =$= headRequiredC "Missing <title> element.") + <*> ZipConduit (projectC _FeedUpdated =$= headRequiredC "Missing <updated> element.") + piece = [ fmap FeedAuthor <$> atomPerson "author" + , fmap FeedCategory <$> atomCategory + , fmap FeedContributor <$> atomPerson "contributor" + , fmap FeedEntry <$> atomEntry + , fmap FeedGenerator <$> atomGenerator + , fmap FeedIcon <$> atomIcon + , fmap FeedId <$> atomId + , fmap FeedLink <$> atomLink + , fmap FeedLogo <$> atomLogo + , fmap FeedRights <$> atomText "rights" + , fmap FeedSubtitle <$> atomText "subtitle" + , fmap FeedTitle <$> atomText "title" + , fmap FeedUpdated <$> tagDate "updated" + ] diff --git a/Text/Atom/Conduit/Render.hs b/Text/Atom/Conduit/Render.hs --- a/Text/Atom/Conduit/Render.hs +++ b/Text/Atom/Conduit/Render.hs @@ -49,7 +49,7 @@ forM_ (f^.feedEntriesL) renderAtomEntry forM_ (f^.feedGeneratorL) renderAtomGenerator forM_ (feedIcon f) $ tag "icon" mempty . content . decodeUtf8 . withAtomURI serializeURIRef' - tag "id" mempty . content . toNullable $ f^.feedIdL + tag "id" mempty . content $ f^.feedIdL forM_ (f^.feedLinksL) renderAtomLink forM_ (feedLogo f) $ tag "logo" mempty . content . decodeUtf8 . withAtomURI serializeURIRef' forM_ (f^.feedRightsL) $ renderAtomText "rights" @@ -64,7 +64,7 @@ forM_ (e^.entryCategoriesL) renderAtomCategory forM_ (e^.entryContentL) renderAtomContent forM_ (e^.entryContributorsL) $ renderAtomPerson "contributor" - tag "id" mempty . content . toNullable $ e^.entryIdL + tag "id" mempty . content $ e^.entryIdL forM_ (e^.entryLinksL) renderAtomLink forM_ (e^.entryPublishedL) $ dateTag "published" forM_ (e^.entryRightsL) $ renderAtomText "rights" diff --git a/Text/Atom/Types.hs b/Text/Atom/Types.hs --- a/Text/Atom/Types.hs +++ b/Text/Atom/Types.hs @@ -62,7 +62,7 @@ -- | An atom text construct. data AtomText = AtomPlainText TextType Text - | AtomXHTMLText Text + | AtomXHTMLText Text -- ^ XHTML special characters will be in encoded form deriving instance Eq AtomText deriving instance Generic AtomText @@ -153,7 +153,7 @@ , entryCategories :: [AtomCategory] , entryContent :: Maybe AtomContent , entryContributors :: [AtomPerson] - , entryId :: NonNull Text + , entryId :: Text , entryLinks :: [AtomLink] , entryPublished :: Maybe UTCTime , entryRights :: Maybe AtomText @@ -175,7 +175,7 @@ , feedEntries :: [AtomEntry] , feedGenerator :: Maybe AtomGenerator , feedIcon :: Maybe AtomURI - , feedId :: NonNull Text + , feedId :: Text , feedLinks :: [AtomLink] , feedLogo :: Maybe AtomURI , feedRights :: Maybe AtomText diff --git a/atom-conduit.cabal b/atom-conduit.cabal --- a/atom-conduit.cabal +++ b/atom-conduit.cabal @@ -1,8 +1,8 @@ name: atom-conduit -version: 0.3.1.2 +version: 0.4.0.0 synopsis: Streaming parser/renderer for the Atom 1.0 standard (RFC 4287). description: Please refer to README. -license: OtherLicense +license: PublicDomain license-file: LICENSE author: koral maintainer: koral att mailoo dott org @@ -24,10 +24,10 @@ -- other-modules: build-depends: base >= 4.8 && < 5 + , blaze-builder , conduit - , conduit-parse - , exceptions - , foldl + , conduit-combinators >= 1.0.5 + , safe-exceptions , lens-simple , mono-traversable >= 1.0.0.1 , parsers @@ -35,8 +35,7 @@ , time >= 1.5 , timerep >= 2.0 , uri-bytestring >= 0.2 - , xml-conduit >= 1.3 - , xml-conduit-parse >= 0.3 + , xml-conduit >= 1.4 , xml-types default-language: Haskell2010 @@ -47,9 +46,8 @@ build-depends: atom-conduit, base >= 4.8, conduit, - conduit-parse, data-default, - exceptions, + safe-exceptions, hlint, lens-simple, mono-traversable >= 1.0.0.1, @@ -62,7 +60,6 @@ time >= 1.5, text, uri-bytestring >= 0.2, - xml-conduit >= 1.3, - xml-conduit-parse >= 0.3, + xml-conduit >= 1.4, xml-types default-language: Haskell2010 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,14 +1,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} import Control.Monad -import Control.Monad.Catch.Pure import Control.Monad.Trans.Resource import Data.Char import Data.Conduit import Data.Conduit.List -import Data.Conduit.Parser -import Data.Conduit.Parser.XML as XML import Data.Default import Data.Functor.Identity import Data.Monoid @@ -22,6 +19,7 @@ import Lens.Simple import qualified Language.Haskell.HLint as HLint (hlint) + import Test.QuickCheck.Instances import Test.Tasty import Test.Tasty.HUnit @@ -32,13 +30,14 @@ import Text.Atom.Lens import Text.Atom.Types import Text.Parser.Combinators +import qualified Text.XML.Stream.Parse as XML import URI.ByteString main :: IO () main = defaultMain $ testGroup "Tests" [ unitTests - , properties +-- , properties , hlint ] @@ -67,14 +66,14 @@ linkCase :: TestTree linkCase = testCase "Link element" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomLink + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= XML.force "Invalid <link>" atomLink result ^. linkHrefL @?= AtomURI (RelativeRef Nothing "/feed" (Query []) Nothing) (result ^. linkRelL) @?= "self" where input = ["<link rel=\"self\" href=\"/feed\" />"] personCase :: TestTree personCase = testCase "Person construct" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser (atomPerson "author") + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= XML.force "Invalid <author>" (atomPerson "author") toNullable (result ^. personNameL) @?= "John Doe" result ^. personEmailL @?= "JohnDoe@example.com" result ^. personUriL @?= Just (AtomURI $ URI (Scheme "http") (Just $ Authority Nothing (Host "example.com") Nothing) "/~johndoe" (Query []) Nothing) @@ -88,7 +87,7 @@ generatorCase :: TestTree generatorCase = testCase "Generator element" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomGenerator + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= XML.force "Invalid <generator>" atomGenerator result ^. generatorUriL @?= Just (AtomURI $ RelativeRef Nothing "/myblog.php" (Query []) Nothing) (result ^. generatorVersionL) @?= "1.0" toNullable (result ^. generatorContentL) @?= "Example Toolkit" @@ -100,7 +99,7 @@ sourceCase :: TestTree sourceCase = testCase "Source element" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomSource + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= XML.force "Invalid <source>" atomSource (result ^. sourceIdL) @?= "http://example.org/" (result ^. sourceTitleL) @?= Just (AtomPlainText TypeText "Fourty-Two") show <$> (result ^. sourceUpdatedL) @?= Just "2003-12-13 18:30:02 UTC" @@ -116,30 +115,30 @@ textConstructCase :: TestTree textConstructCase = testCase "Text construct" $ do - (a, b, c) <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser ((,,) <$> atomText "title1" <*> atomText "title2" <*> atomText "title3") + a:b:c:_ <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= XML.many (atomText "title") a @?= AtomPlainText TypeText "AT&T bought by SBC!" b @?= AtomPlainText TypeHTML "AT&T bought <b>by SBC</b>!" - c @?= AtomXHTMLText "AT&T bought <b>by SBC</b>!" + c @?= AtomXHTMLText "AT&T bought <b xmlns=\"http://www.w3.org/1999/xhtml\"><em>by SBC</em></b>!" where input = - [ "<title1 type=\"text\">AT&T bought by SBC!</title1>" - , "<title2 type=\"html\">" + [ "<title type=\"text\">AT&T bought by SBC!" + , "" , "AT&amp;T bought <b>by SBC</b>!" - , "</title2>" - , "<title3 type=\"xhtml\">" + , "" + , "" , "<div xmlns=\"http://www.w3.org/1999/xhtml\">" - , "AT&T bought <b>by SBC</b>!" + , "AT&T bought <b><em>by SBC</em></b>!" , "</div>" - , "</title3>" + , "" ] simpleCase :: TestTree simpleCase = testCase "Simple case" $ do - result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomFeed + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= XML.force "Invalid " atomFeed return () where input = [ "" , "" - , "Example Feed" + , "<em>Example</em> Feed" , "" , "2003-12-13T18:30:02Z" , "" @@ -164,31 +163,31 @@ roundtripAtomTextProperty :: TestTree -roundtripAtomTextProperty = testProperty "parse . render = id (AtomText)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomText "test" i =$= runConduitParser (atomText "test")) +roundtripAtomTextProperty = testProperty "parse . render = id (AtomText)" $ \i -> either (const False) (Just i ==) (runConduit $ renderAtomText "test" i =$= atomText "test") roundtripAtomPersonProperty :: TestTree -roundtripAtomPersonProperty = testProperty "parse . render = id (AtomPerson)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomPerson "test" i =$= runConduitParser (atomPerson "test")) +roundtripAtomPersonProperty = testProperty "parse . render = id (AtomPerson)" $ \i -> either (const False) (i ==) (runConduit $ renderAtomPerson "test" i =$= XML.force "Invalid " (atomPerson "test")) roundtripAtomCategoryProperty :: TestTree -roundtripAtomCategoryProperty = testProperty "parse . render = id (AtomCategory)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomCategory i =$= runConduitParser atomCategory) +roundtripAtomCategoryProperty = testProperty "parse . render = id (AtomCategory)" $ \i -> either (const False) (i ==) (runConduit $ renderAtomCategory i =$= XML.force "Invalid " atomCategory) roundtripAtomLinkProperty :: TestTree -roundtripAtomLinkProperty = testProperty "parse . render = id (AtomLink)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomLink i =$= runConduitParser atomLink) +roundtripAtomLinkProperty = testProperty "parse . render = id (AtomLink)" $ \i -> either (const False) (i ==) (runConduit $ renderAtomLink i =$= XML.force "Invalid " atomLink) roundtripAtomGeneratorProperty :: TestTree -roundtripAtomGeneratorProperty = testProperty "parse . render = id (AtomGenerator)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomGenerator i =$= runConduitParser atomGenerator) +roundtripAtomGeneratorProperty = testProperty "parse . render = id (AtomGenerator)" $ \i -> either (const False) (i ==) (runConduit $ renderAtomGenerator i =$= XML.force "Invalid " atomGenerator) roundtripAtomSourceProperty :: TestTree -roundtripAtomSourceProperty = testProperty "parse . render = id (AtomSource)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomSource i =$= runConduitParser atomSource) +roundtripAtomSourceProperty = testProperty "parse . render = id (AtomSource)" $ \i -> either (const False) (i ==) (runConduit $ renderAtomSource i =$= XML.force "Invalid " atomSource) roundtripAtomContentProperty :: TestTree -roundtripAtomContentProperty = testProperty "parse . render = id (AtomContent)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomContent i =$= runConduitParser atomContent) +roundtripAtomContentProperty = testProperty "parse . render = id (AtomContent)" $ \i -> either (const False) (i ==) (runConduit $ renderAtomContent i =$= XML.force "Invalid content" atomContent) roundtripAtomFeedProperty :: TestTree -roundtripAtomFeedProperty = testProperty "parse . render = id (AtomFeed)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomFeed i =$= runConduitParser atomFeed) +roundtripAtomFeedProperty = testProperty "parse . render = id (AtomFeed)" $ \i -> either (const False) (i ==) (runConduit $ renderAtomFeed i =$= XML.force "Invalid " atomFeed) roundtripAtomEntryProperty :: TestTree -roundtripAtomEntryProperty = testProperty "parse . render = id (AtomEntry)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomEntry i =$= runConduitParser atomEntry) +roundtripAtomEntryProperty = testProperty "parse . render = id (AtomEntry)" $ \i -> either (const False) (i ==) (runConduit $ renderAtomEntry i =$= XML.force "Invalid " atomEntry) letter = choose ('a', 'z')