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 @@ -100,10 +100,10 @@ tagIgnoreAttrs' name handler = tagName' name ignoreAttrs $ const handler xhtmlContent :: MonadThrow m => ConduitM Event o m Text -xhtmlContent = fmap (decodeUtf8 . toByteString) $ many_ takeAnyTreeContent =$= Render.renderBuilder def =$= foldC +xhtmlContent = fmap (decodeUtf8 . toByteString) $ many_ takeAnyTreeContent .| Render.renderBuilder def .| foldC -projectC :: Monad m => Fold a a' b b' -> Conduit a m b +projectC :: Monad m => Fold a a' b b' -> ConduitT a b m () projectC prism = fix $ \recurse -> do item <- await case (item, item ^? (_Just . prism)) of @@ -111,7 +111,7 @@ (Just _, _) -> recurse _ -> return () -headRequiredC :: MonadThrow m => Text -> Consumer a m a +headRequiredC :: MonadThrow m => Text -> ConduitT a o m a headRequiredC e = liftMaybe (MissingElement e) =<< headC atomId :: MonadThrow m => ConduitM Event o m (Maybe Text) @@ -138,11 +138,11 @@ -- > http://example.com/~johndoe -- > atomPerson :: MonadThrow m => Text -> ConduitM Event o m (Maybe AtomPerson) -atomPerson name = tagIgnoreAttrs' name $ (manyYield' (choose piece) =$= parser) <* many ignoreAnyTreeContent where +atomPerson name = tagIgnoreAttrs' name $ (manyYield' (choose piece) .| parser) <* many ignoreAnyTreeContent where parser = getZipConduit $ AtomPerson - <$> ZipConduit (projectC _PersonName =$= headRequiredC "Missing or invalid element") - <*> ZipConduit (projectC _PersonEmail =$= headDefC "") - <*> ZipConduit (projectC _PersonUri =$= headC) + <$> 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) @@ -245,20 +245,20 @@ -- > © 2005 Example, Inc. -- > atomSource :: MonadThrow m => ConduitM Event o m (Maybe AtomSource) -atomSource = tagIgnoreAttrs' "source" $ manyYield' (choose piece) =$= zipConduit where +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) + <$> 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" @@ -291,20 +291,20 @@ -- | Parse an @atom:entry@ element. atomEntry :: MonadThrow m => ConduitM Event o m (Maybe AtomEntry) -atomEntry = tagIgnoreAttrs' "entry" $ manyYield' (choose piece) =$= zipConduit where +atomEntry = tagIgnoreAttrs' "entry" $ manyYield' (choose piece) .| zipConduit where zipConduit = getZipConduit $ AtomEntry - <$> ZipConduit (projectC _EntryAuthor =$= sinkList) - <*> ZipConduit (projectC _EntryCategory =$= sinkList) - <*> ZipConduit (projectC _EntryContent =$= headC) - <*> ZipConduit (projectC _EntryContributor =$= sinkList) - <*> ZipConduit (projectC _EntryId =$= headRequiredC "Missing element") - <*> ZipConduit (projectC _EntryLink =$= sinkList) - <*> ZipConduit (projectC _EntryPublished =$= headC) - <*> ZipConduit (projectC _EntryRights =$= headC) - <*> ZipConduit (projectC _EntrySource =$= headC) - <*> ZipConduit (projectC _EntrySummary =$= headC) - <*> ZipConduit (projectC _EntryTitle =$= headRequiredC "Missing or invalid element.") - <*> ZipConduit (projectC _EntryUpdated =$= headRequiredC "Missing or invalid <updated> element.") + <$> 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 @@ -338,21 +338,21 @@ -- | Parse an @atom:feed@ element. atomFeed :: MonadThrow m => ConduitM Event o m (Maybe AtomFeed) -atomFeed = tagIgnoreAttrs' "feed" $ manyYield' (choose piece) =$= zipConduit where +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.") + <$> 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" 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 @@ -40,7 +40,7 @@ -- }}} -- | Render the top-level @atom:feed@ element. -renderAtomFeed :: (Monad m) => AtomFeed -> Source m Event +renderAtomFeed :: (Monad m) => AtomFeed -> ConduitT () Event m () renderAtomFeed f = atomTag "feed" (attr "xmlns" "http://www.w3.org/2005/Atom") $ do forM_ (f^.feedAuthorsL) $ renderAtomPerson "author" forM_ (f^.feedCategoriesL) renderAtomCategory @@ -57,7 +57,7 @@ dateTag "updated" $ f^.feedUpdatedL -- | Render an @atom:entry@ element. -renderAtomEntry :: (Monad m) => AtomEntry -> Source m Event +renderAtomEntry :: (Monad m) => AtomEntry -> ConduitT () Event m () renderAtomEntry e = atomTag "entry" mempty $ do forM_ (e^.entryAuthorsL) $ renderAtomPerson "author" forM_ (e^.entryCategoriesL) renderAtomCategory @@ -73,7 +73,7 @@ dateTag "updated" (e^.entryUpdatedL) -- | Render an @atom:content@ element. -renderAtomContent :: (Monad m) => AtomContent -> Source m Event +renderAtomContent :: (Monad m) => AtomContent -> ConduitT () Event m () renderAtomContent (AtomContentInlineXHTML t) = atomTag "content" (attr "type" "xhtml") . tag "{http://www.w3.org/1999/xhtml}div" mempty $ content t renderAtomContent (AtomContentOutOfLine ctype uri) = atomTag "content" (nonEmptyAttr "type" ctype <> attr "src" (decodeUtf8 $ withAtomURI serializeURIRef' uri)) $ return () @@ -82,7 +82,7 @@ renderAtomContent (AtomContentInlineOther ctype t) = atomTag "content" (attr "type" ctype) $ content t -- | Render an @atom:source@ element. -renderAtomSource :: (Monad m) => AtomSource -> Source m Event +renderAtomSource :: (Monad m) => AtomSource -> ConduitT () Event m () renderAtomSource s = atomTag "source" mempty $ do forM_ (s^.sourceAuthorsL) $ renderAtomPerson "author" forM_ (s^.sourceCategoriesL) renderAtomCategory @@ -98,13 +98,13 @@ forM_ (s^.sourceUpdatedL) $ dateTag "updated" -- | Render an @atom:generator@ element. -renderAtomGenerator :: (Monad m) => AtomGenerator -> Source m Event +renderAtomGenerator :: (Monad m) => AtomGenerator -> ConduitT () Event m () renderAtomGenerator g = atomTag "generator" attributes . content . toNullable $ g^.generatorContentL where attributes = optionalAttr "uri" (decodeUtf8 . withAtomURI serializeURIRef' <$> generatorUri g) <> nonEmptyAttr "version" (g^.generatorVersionL) -- | Render an @atom:link@ element. -renderAtomLink :: (Monad m) => AtomLink -> Source m Event +renderAtomLink :: (Monad m) => AtomLink -> ConduitT () Event m () renderAtomLink l = atomTag "link" linkAttrs $ return () where linkAttrs = attr "href" (decodeUtf8 . withAtomURI serializeURIRef' $ linkHref l) <> nonEmptyAttr "rel" (l^.linkRelL) @@ -114,30 +114,30 @@ <> nonEmptyAttr "length" (l^.linkLengthL) -- | Render an @atom:category@ element. -renderAtomCategory :: (Monad m) => AtomCategory -> Source m Event +renderAtomCategory :: (Monad m) => AtomCategory -> ConduitT () Event m () renderAtomCategory c = atomTag "category" attributes $ return () where attributes = attr "term" (toNullable $ c^.categoryTermL) <> nonEmptyAttr "scheme" (c^.categorySchemeL) <> nonEmptyAttr "label" (c^.categoryLabelL) -- | Render an atom person construct. -renderAtomPerson :: (Monad m) => Text -> AtomPerson -> Source m Event +renderAtomPerson :: (Monad m) => Text -> AtomPerson -> ConduitT () Event m () renderAtomPerson name p = atomTag name mempty $ do atomTag "name" mempty . content . toNullable $ p^.personNameL unless (Text.null $ p^.personEmailL) $ atomTag "email" mempty . content $ p^.personEmailL forM_ (personUri p) $ atomTag "uri" mempty . content . decodeUtf8 . withAtomURI serializeURIRef' -- | Render an atom text construct. -renderAtomText :: (Monad m) => Text -> AtomText -> Source m Event +renderAtomText :: (Monad m) => Text -> AtomText -> ConduitT () Event m () renderAtomText name (AtomXHTMLText t) = atomTag name (attr "type" "xhtml") . tag "{http://www.w3.org/1999/xhtml}div" mempty $ content t renderAtomText name (AtomPlainText TypeHTML t) = atomTag name (attr "type" "html") $ content t renderAtomText name (AtomPlainText TypeText t) = atomTag name mempty $ content t -atomTag :: Monad m => Text -> Attributes -> Source m Event -> Source m Event +atomTag :: Monad m => Text -> Attributes -> ConduitT () Event m () -> ConduitT () Event m () atomTag name = tag (Name name (Just "http://www.w3.org/2005/Atom") (Just "atom")) -dateTag :: (Monad m) => Text -> UTCTime -> Source m Event +dateTag :: (Monad m) => Text -> UTCTime -> ConduitT () Event m () dateTag name = atomTag name mempty . content . formatTimeRFC3339 . utcToZonedTime utc nonEmptyAttr :: Name -> Text -> Attributes diff --git a/atom-conduit.cabal b/atom-conduit.cabal --- a/atom-conduit.cabal +++ b/atom-conduit.cabal @@ -1,10 +1,10 @@ name: atom-conduit -version: 0.5.0.1 +version: 0.5.0.2 cabal-version: >=1.10 build-type: Simple license: PublicDomain license-file: LICENSE -maintainer: koral att mailoo dott org +maintainer: koral synopsis: Streaming parser/renderer for the Atom 1.0 standard (RFC 4287). description: Please refer to README. @@ -29,10 +29,9 @@ Text.Atom.Lens Text.Atom.Types build-depends: - base >=4.8 && <5, + base >=4.9 && <5, blaze-builder -any, - conduit -any, - conduit-combinators >=1.0.5, + conduit >=1.3, safe-exceptions -any, lens-simple -any, mono-traversable >=1.0.0.1, @@ -50,18 +49,19 @@ main-is: Main.hs build-depends: atom-conduit -any, - base >=4.8, + base >=4.9, blaze-builder -any, - conduit -any, - conduit-combinators >=1.0.5, + conduit >=1.3, data-default -any, - safe-exceptions -any, + filepath -any, lens-simple -any, mono-traversable >=1.0.0.1, parsers -any, quickcheck-instances -any, resourcet -any, + safe-exceptions -any, tasty -any, + tasty-golden -any, tasty-hunit -any, tasty-quickcheck -any, time >=1.5, diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,24 +1,30 @@ +{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} import Blaze.ByteString.Builder (toByteString) -import Conduit (foldC, yieldMany) import Control.Monad import Control.Monad.Trans.Resource import Data.Char import Data.Conduit +import Data.Conduit.Combinators as Conduit (decodeUtf8, fold, + sourceFile, yieldMany) import Data.Default import Data.Functor.Identity import Data.Monoid import Data.MonoTraversable import Data.NonNull +import Data.String import Data.Text as Text import Data.Text.Encoding as Text +import qualified Data.Text.Lazy.Encoding as Lazy import Data.Time.Clock import Data.Void import Data.XML.Types import Lens.Simple +import System.FilePath import Test.QuickCheck.Instances import Test.Tasty +import Test.Tasty.Golden (findByExtension, goldenVsString) import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Text.Atom.Conduit.Parse as Parser @@ -26,15 +32,13 @@ import Text.Atom.Lens import Text.Atom.Types import Text.Parser.Combinators -import Text.XML.Stream.Render (renderBuilder) import qualified Text.XML.Stream.Parse as XML import URI.ByteString main :: IO () -main = defaultMain $ testGroup "Tests" - [ unitTests - , properties - ] +main = do + goldenTests <- genGoldenTests + defaultMain $ testGroup "Tests" [ unitTests, properties, goldenTests ] unitTests :: TestTree unitTests = testGroup "Unit tests" @@ -43,9 +47,18 @@ , generatorCase , sourceCase , textConstructCase - , simpleCase ] +genGoldenTests :: IO TestTree +genGoldenTests = do + xmlFiles <- findByExtension [".xml"] "." + + return $ testGroup "Atom golden tests" $ do + xmlFile <- xmlFiles + let goldenFile = addExtension xmlFile ".golden" + f file = fmap (Lazy.encodeUtf8 . fromString . show) $ runResourceT $ runConduit $ sourceFile file .| Conduit.decodeUtf8 .| XML.parseText' def .| XML.force "Invalid <feed>" atomFeed + return $ goldenVsString xmlFile goldenFile $ f xmlFile + properties :: TestTree properties = testGroup "Properties" [ roundtripProperty "AtomText" (renderAtomText "test") (atomText "test") @@ -61,14 +74,14 @@ linkCase :: TestTree linkCase = testCase "Link element" $ do - result <- runResourceT . runConduit $ yieldMany input =$= XML.parseText' def =$= XML.force "Invalid <link>" atomLink + result <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.force "Invalid <link>" atomLink result ^. linkHrefL @?= AtomURI (RelativeRef Nothing "/feed" (Query []) Nothing) (result ^. linkRelL) @?= "self" where input = ["<link xmlns=\"http://www.w3.org/2005/Atom\" rel=\"self\" href=\"/feed\" />"] personCase :: TestTree personCase = testCase "Person construct" $ do - result <- runResourceT . runConduit $ yieldMany input =$= XML.parseText' def =$= XML.force "Invalid <author>" (atomPerson "author") + result <- runResourceT . runConduit $ yieldMany 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) @@ -82,7 +95,7 @@ generatorCase :: TestTree generatorCase = testCase "Generator element" $ do - result <- runResourceT . runConduit $ yieldMany input =$= XML.parseText' def =$= XML.force "Invalid <generator>" atomGenerator + result <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.force "Invalid <generator>" atomGenerator result ^. generatorUriL @?= Just (AtomURI $ RelativeRef Nothing "/myblog.php" (Query []) Nothing) (result ^. generatorVersionL) @?= "1.0" toNullable (result ^. generatorContentL) @?= "Example Toolkit" @@ -94,7 +107,7 @@ sourceCase :: TestTree sourceCase = testCase "Source element" $ do - result <- runResourceT . runConduit $ yieldMany input =$= XML.parseText' def =$= XML.force "Invalid <source>" atomSource + result <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.force "Invalid <source>" atomSource (result ^. sourceIdL) @?= "http://example.org/" (result ^. sourceTitleL) @?= Just (AtomPlainText TypeText "Fourty-Two") show <$> (result ^. sourceUpdatedL) @?= Just "2003-12-13 18:30:02 UTC" @@ -110,7 +123,7 @@ textConstructCase :: TestTree textConstructCase = testCase "Text construct" $ do - a:b:c:_ <- runResourceT . runConduit $ yieldMany input =$= XML.parseText' def =$= XML.many (atomText "title") + a:b:c:_ <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.many (atomText "title") a @?= AtomPlainText TypeText "AT&T bought by SBC!" b @?= AtomPlainText TypeHTML "AT&T bought <b>by SBC</b>!" c @?= AtomXHTMLText "AT&T bought <b xmlns=\"http://www.w3.org/1999/xhtml\"><em>by SBC</em></b><!" @@ -126,38 +139,13 @@ , "" ] -simpleCase :: TestTree -simpleCase = testCase "Simple case" $ do - result <- runResourceT . runConduit $ yieldMany input =$= XML.parseText' def =$= XML.force "Invalid " atomFeed - return () - where input = - [ "" - , "" - , "<em>Example</em> Feed" - , "" - , "2003-12-13T18:30:02Z" - , "" - , "John Doe" - , "" - , "urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6" - , "" - , "Atom-Powered Robots Run Amok" - , "" - , "urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a" - , "2003-12-13T18:30:02Z" - , "Some text." - , "" - , "" - ] - roundtripProperty :: Eq a => Arbitrary a => Show a - => TestName -> (a -> Source Maybe Event) -> ConduitM Event Void Maybe (Maybe a) -> TestTree + => TestName -> (a -> ConduitT () Event Maybe ()) -> ConduitM Event Void Maybe (Maybe a) -> TestTree roundtripProperty name render parse = testProperty ("parse . render = id (" <> name <> ")") $ do input <- arbitrary - let intermediate = fmap (decodeUtf8 . toByteString) $ runConduit $ render input =$= renderBuilder def =$= foldC - output = join $ runConduit $ render input =$= parse - return $ counterexample (show input <> " | " <> show intermediate <> " | " <> show output) $ Just input == output + let output = join $ runConduit $ render input .| parse + return $ Just input == output letter = choose ('a', 'z')