{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- {{{ Imports import Text.RSS.Conduit.Parse as Parser import Text.RSS.Conduit.Render as Renderer import Text.RSS.Extensions import Text.RSS.Extensions.Atom import Text.RSS.Extensions.Content import Text.RSS.Extensions.DublinCore import Text.RSS.Extensions.Syndication import Text.RSS.Lens import Text.RSS.Types import Text.RSS1.Conduit.Parse as Parser import Arbitrary import Conduit import Control.Exception.Safe as Exception import Control.Monad import Control.Monad.Trans.Resource import Data.Char import Data.Conduit import Data.Conduit.List import Data.Default import Data.Singletons.Prelude.List import Data.Text (Text) import Data.Time.Calendar import Data.Time.LocalTime import Data.Version import Data.Vinyl.Core import Data.XML.Types import qualified Language.Haskell.HLint as HLint (hlint) import Lens.Simple import System.IO import System.Timeout import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Text.Atom.Conduit.Parse import Text.Atom.Types import Text.XML.Stream.Parse as XML hiding (choose) import Text.XML.Stream.Render import URI.ByteString -- }}} main :: IO () main = defaultMain $ testGroup "Tests" [ unitTests , properties , hlint ] unitTests :: TestTree unitTests = testGroup "Unit tests" [ skipHoursCase , skipDaysCase , rss1TextInputCase , rss2TextInputCase , rss1ImageCase , rss2ImageCase , categoryCase , cloudCase , guidCase , enclosureCase , sourceCase , rss1ItemCase , rss2ItemCase , rss1ChannelItemsCase , rss1DocumentCase , rss2DocumentCase , dublinCoreChannelCase , dublinCoreItemCase , contentItemCase , syndicationChannelCase , atomChannelCase , multipleExtensionsCase ] properties :: TestTree properties = testGroup "Properties" [ roundtripTextInputProperty , roundtripImageProperty , roundtripCategoryProperty , roundtripEnclosureProperty , roundtripSourceProperty , roundtripGuidProperty , roundtripItemProperty ] skipHoursCase :: TestTree skipHoursCase = testCase " element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssSkipHours result @?= [Hour 0, Hour 9, Hour 18, Hour 21] where input = [ "" , "21" , "9" , "0" , "18" , "9" , "" ] skipDaysCase :: TestTree skipDaysCase = testCase " element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssSkipDays result @?= [Monday, Saturday, Friday] where input = [ "" , "Monday" , "Monday" , "Friday" , "Saturday" , "" ] rss1TextInputCase :: TestTree rss1TextInputCase = testCase "RSS1 element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rss1TextInput result^.textInputTitleL @?= "Search XML.com" result^.textInputDescriptionL @?= "Search XML.com's XML collection" result^.textInputNameL @?= "s" result^.textInputLinkL @=? RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "search.xml.com") Nothing)) "" (Query []) Nothing) where input = [ "" , "Search XML.com" , "Search XML.com's XML collection" , "s" , "http://search.xml.com" , "" ] rss2TextInputCase :: TestTree rss2TextInputCase = testCase "RSS2 element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssTextInput result^.textInputTitleL @?= "Title" result^.textInputDescriptionL @?= "Description" result^.textInputNameL @?= "Name" result^.textInputLinkL @=? RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "link.ext") Nothing)) "" (Query []) Nothing) where input = [ "" , "Title" , "Description" , "Name" , "http://link.ext" , "" ] rss1ImageCase :: TestTree rss1ImageCase = testCase "RSS1 element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rss1Image result^.imageUriL @?= RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "xml.com") Nothing)) "/universal/images/xml_tiny.gif" (Query []) Nothing) result^.imageTitleL @?= "XML.com" result^.imageLinkL @?= RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.xml.com") Nothing)) "" (Query []) Nothing) where input = [ "" , "http://xml.com/universal/images/xml_tiny.gif" , "XML.com" , "Ignored" , "http://www.xml.com" , "Ignored" , "" ] rss2ImageCase :: TestTree rss2ImageCase = testCase "RSS2 element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssImage result^.imageUriL @?= RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "image.ext") Nothing)) "" (Query []) Nothing) result^.imageTitleL @?= "Title" result^.imageLinkL @?= RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "link.ext") Nothing)) "" (Query []) Nothing) result^.imageWidthL @?= Just 100 result^.imageHeightL @?= Just 200 result^.imageDescriptionL @?= "Description" where input = [ "" , "http://image.ext" , "Title" , "Ignored" , "http://link.ext" , "100" , "200" , "Description" , "Ignored" , "" ] categoryCase :: TestTree categoryCase = testCase " element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssCategory result @?= RssCategory "Domain" "Name" where input = [ "" , "Name" , "" ] cloudCase :: TestTree cloudCase = testCase " element" $ do result1:result2:_ <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= XML.many rssCloud result1 @?= RssCloud uri "pingMe" ProtocolSoap result2 @?= RssCloud uri "myCloud.rssPleaseNotify" ProtocolXmlRpc where input = [ "" , "" ] uri = RssURI (RelativeRef (Just (Authority Nothing (Host "rpc.sys.com") (Just $ Port 80))) "/RPC2" (Query []) Nothing) guidCase :: TestTree guidCase = testCase " element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= XML.many rssGuid result @?= [GuidUri uri, GuidText "1", GuidText "2"] where input = [ "//guid.ext" , "1" , "2" ] uri = RssURI (RelativeRef (Just (Authority Nothing (Host "guid.ext") Nothing)) "" (Query []) Nothing) enclosureCase :: TestTree enclosureCase = testCase " element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssEnclosure result @?= RssEnclosure uri 12216320 "audio/mpeg" where input = [ "" ] uri = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.scripting.com") Nothing)) "/mp3s/weatherReportSuite.mp3" (Query []) Nothing) sourceCase :: TestTree sourceCase = testCase " element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssSource result @?= RssSource uri "Tomalak's Realm" where input = [ "Tomalak's Realm" ] uri = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.tomalak.org") Nothing)) "/links2.xml" (Query []) Nothing) rss1ItemCase :: TestTree rss1ItemCase = testCase "RSS1 element" $ do Just result <- runResourceT $ runConduit $ sourceList input =$= XML.parseText' def =$= rss1Item result^.itemTitleL @?= "Processing Inclusions with XSLT" result^.itemLinkL @?= Just link result^.itemDescriptionL @?= "Processing document inclusions with general XML tools can be problematic. This article proposes a way of preserving inclusion information through SAX-based processing." result^.itemExtensionsL @?= RssItemExtensions RNil where input = [ "" , "Processing Inclusions with XSLT" , "Processing document inclusions with general XML tools can be" , " problematic. This article proposes a way of preserving inclusion" , " information through SAX-based processing." , "" , "http://xml.com/pub/2000/08/09/xslt/xslt.html" , "Some content in unknown tag, should be ignored." , "" ] link = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "xml.com") Nothing)) "/pub/2000/08/09/xslt/xslt.html" (Query []) Nothing) rss2ItemCase :: TestTree rss2ItemCase = testCase "RSS2 element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rssItem result^.itemTitleL @?= "Example entry" result^.itemLinkL @?= Just link result^.itemDescriptionL @?= "Here is some text containing an interesting description." result^.itemGuidL @?= Just (GuidText "7bd204c6-1655-4c27-aeee-53f933c5395f") result^.itemExtensionsL @?= RssItemExtensions RNil -- isJust (result^.itemPubDate_) @?= True where input = [ "" , "Example entry" , "Here is some text containing an interesting description." , "http://www.example.com/blog/post/1" , "7bd204c6-1655-4c27-aeee-53f933c5395f" , "Sun, 06 Sep 2009 16:20:00 +0000" , "Some content in unknown tag, should be ignored." , "" ] link = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.example.com") Nothing)) "/blog/post/1" (Query []) Nothing) rss1ChannelItemsCase :: TestTree rss1ChannelItemsCase = testCase "RSS1 element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= force "ERROR" rss1ChannelItems result @?= [resource1, resource2] where input = [ "" , "" , "" , "" , "" , "" ] resource1 = "http://xml.com/pub/2000/08/09/xslt/xslt.html" resource2 = "http://xml.com/pub/2000/08/09/rdfdb/index.html" rss1DocumentCase :: TestTree rss1DocumentCase = testCase " element" $ do Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rss1Document result^.documentVersionL @?= Version [1] [] result^.channelTitleL @?= "XML.com" result^.channelDescriptionL @?= "XML.com features a rich mix of information and services for the XML community." result^.channelLinkL @?= link result^?channelImageL._Just.imageTitleL @?= Just "XML.com" result^?channelImageL._Just.imageLinkL @?= Just imageLink result^?channelImageL._Just.imageUriL @?= Just imageUri length (result^..channelItemsL) @?= 2 result^?channelTextInputL._Just.textInputTitleL @?= Just "Search XML.com" result^?channelTextInputL._Just.textInputDescriptionL @?= Just "Search XML.com's XML collection" result^?channelTextInputL._Just.textInputNameL @?= Just "s" result^?channelTextInputL._Just.textInputLinkL @?= Just textInputLink result^.channelExtensionsL @?= RssChannelExtensions RNil where input = [ "" , "" , "" , "XML.com" , "http://xml.com/pub" , "XML.com features a rich mix of information and services for the XML community." , "" , "" , "" , "" , "" , "" , "" , "" , "" , "XML.com" , "http://www.xml.com" , "http://xml.com/universal/images/xml_tiny.gif" , "" , "" , "Processing Inclusions with XSLT" , "http://xml.com/pub/2000/08/09/xslt/xslt.html" , "Processing document inclusions with general XML tools can be problematic. This article proposes a way of preserving inclusion information through SAX-based processing." , "" , "" , "Putting RDF to Work" , "http://xml.com/pub/2000/08/09/rdfdb/index.html" , "Tool and API support for the Resource Description Framework is slowly coming of age. Edd Dumbill takes a look at RDFDB, one of the most exciting new RDF toolkits." , "" , "" , "Search XML.com" , "Search XML.com's XML collection" , "s" , "http://search.xml.com" , "" , "" ] link = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "xml.com") Nothing)) "/pub" (Query []) Nothing) imageLink = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.xml.com") Nothing)) "" (Query []) Nothing) imageUri = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "xml.com") Nothing)) "/universal/images/xml_tiny.gif" (Query []) Nothing) textInputLink = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "search.xml.com") Nothing)) "" (Query []) Nothing) rss2DocumentCase :: TestTree rss2DocumentCase = testCase " element" $ do Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rssDocument result^.documentVersionL @?= Version [2] [] result^.channelTitleL @?= "RSS Title" result^.channelDescriptionL @?= "This is an example of an RSS feed" result^.channelLinkL @?= link result^.channelTtlL @?= Just 1800 result^.channelExtensionsL @?= RssChannelExtensions RNil length (result^..channelItemsL) @?= 1 where input = [ "" , "" , "" , "RSS Title" , "This is an example of an RSS feed" , "http://www.example.com/main.html" , "Mon, 06 Sep 2010 00:01:00 +0000 " , "Sun, 06 Sep 2009 16:20:00 +0000" , "1800" , "" , "Example entry" , "Here is some text containing an interesting description." , "http://www.example.com/blog/post/1" , "7bd204c6-1655-4c27-aeee-53f933c5395f" , "Sun, 06 Sep 2009 16:20:00 +0000" , "" , "" , "" ] link = RssURI (URI (Scheme "http") (Just (Authority Nothing (Host "www.example.com") Nothing)) "/main.html" (Query []) Nothing) dublinCoreChannelCase :: TestTree dublinCoreChannelCase = testCase "Dublin Core extension" $ do Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rssDocument result^.channelExtensionsL @?= RssChannelExtensions (DublinCoreChannel dublinCoreElement :& RNil) where input = [ "" , "" , "" , "RSS Title" , "http://xml.com/pub/2000/08/09/xslt/xslt.html" , "The O'Reilly Network" , "Rael Dornfest (mailto:rael@oreilly.com)" , "2000-01-01T12:00:00+00:00" , "EN" , "Copyright © 2000 O'Reilly & Associates, Inc." , "XML" , "" , "" ] dublinCoreElement = mkDcMetaData { elementCreator = "Rael Dornfest (mailto:rael@oreilly.com)" , elementDate = Just date , elementLanguage = "EN" , elementPublisher = "The O'Reilly Network" , elementRights = "Copyright © 2000 O'Reilly & Associates, Inc." , elementSubject = "XML" } date = localTimeToUTC utc $ LocalTime (fromGregorian 2000 1 1) (TimeOfDay 12 0 0) dublinCoreItemCase :: TestTree dublinCoreItemCase = testCase "Dublin Core extension" $ do Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rssItem result^.itemExtensionsL @?= RssItemExtensions (DublinCoreItem dublinCoreElement :& RNil) where input = [ "" , "Example entry" , "XML is placing increasingly heavy loads on the existing technical " , "infrastructure of the Internet." , "EN" , "The O'Reilly Network" , "Simon St.Laurent (mailto:simonstl@simonstl.com)" , "2000-01-01T12:00:00+00:00" , "Copyright © 2000 O'Reilly & Associates, Inc." , "XML" , "" ] dublinCoreElement = mkDcMetaData { elementCreator = "Simon St.Laurent (mailto:simonstl@simonstl.com)" , elementDate = Just date , elementLanguage = "EN" , elementDescription = "XML is placing increasingly heavy loads on the existing technical infrastructure of the Internet." , elementPublisher = "The O'Reilly Network" , elementRights = "Copyright © 2000 O'Reilly & Associates, Inc." , elementSubject = "XML" } date = localTimeToUTC utc $ LocalTime (fromGregorian 2000 1 1) (TimeOfDay 12 0 0) contentItemCase :: TestTree contentItemCase = testCase "Content extension" $ do Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rssItem result^.itemExtensionsL @?= RssItemExtensions (ContentItem "

What a beautiful day!

" :& RNil) where input = [ "" , "Example entry" , "What a beautiful day!

]]>
" , "
" ] syndicationChannelCase :: TestTree syndicationChannelCase = testCase "Syndication extension" $ do Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rssDocument result^.channelExtensionsL @?= RssChannelExtensions (SyndicationChannel syndicationInfo :& RNil) where input = [ "" , "" , "" , "RSS Title" , "http://xml.com/pub/2000/08/09/xslt/xslt.html" , "hourly" , "2" , "2000-01-01T12:00:00+00:00" , "" , "" ] syndicationInfo = mkSyndicationInfo { updatePeriod = Just Hourly , updateFrequency = Just 2 , updateBase = Just date } date = localTimeToUTC utc $ LocalTime (fromGregorian 2000 1 1) (TimeOfDay 12 0 0) atomChannelCase :: TestTree atomChannelCase = testCase "Atom extension" $ do Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rssDocument result^.channelExtensionsL @?= RssChannelExtensions (AtomChannel (Just link) :& RNil) where input = [ "" , "" , "" , "RSS Title" , "http://xml.com/pub/2000/08/09/xslt/xslt.html" , "" , "" , "" ] uri = AtomURI (URI (Scheme "http") (Just (Authority Nothing (Host "dallas.example.com") Nothing)) "/rss.xml" (Query []) Nothing) link = AtomLink uri "self" "application/rss+xml" mempty mempty mempty multipleExtensionsCase :: TestTree multipleExtensionsCase = testCase "Multiple extensions" $ do Just result <- runResourceT . runConduit $ sourceList input =$= XML.parseText' def =$= rssItem result^.itemExtensionsL @?= RssItemExtensions (ContentItem "

What a beautiful day!

" :& AtomItem (Just link) :& RNil) where input = [ "" , "Example entry" , "" , "What a beautiful day!

]]>
" , "
" ] uri = AtomURI (URI (Scheme "http") (Just (Authority Nothing (Host "dallas.example.com") Nothing)) "/rss.xml" (Query []) Nothing) link = AtomLink uri "self" "application/rss+xml" mempty mempty mempty hlint :: TestTree hlint = testCase "HLint check" $ do result <- HLint.hlint [ "test/", "Text/" ] Prelude.null result @?= True roundtripTextInputProperty :: TestTree roundtripTextInputProperty = testProperty "parse . render = id (RssTextInput)" $ \t -> either (const False) (t ==) (runConduit $ renderRssTextInput t =$= force "ERROR" rssTextInput) roundtripImageProperty :: TestTree roundtripImageProperty = testProperty "parse . render = id (RssImage)" $ \t -> either (const False) (t ==) (runConduit $ renderRssImage t =$= force "ERROR" rssImage) roundtripCategoryProperty :: TestTree roundtripCategoryProperty = testProperty "parse . render = id (RssCategory)" $ \t -> either (const False) (t ==) (runConduit $ renderRssCategory t =$= force "ERROR" rssCategory) roundtripEnclosureProperty :: TestTree roundtripEnclosureProperty = testProperty "parse . render = id (RssEnclosure)" $ \t -> either (const False) (t ==) (runConduit $ renderRssEnclosure t =$= force "ERROR" rssEnclosure) roundtripSourceProperty :: TestTree roundtripSourceProperty = testProperty "parse . render = id (RssSource)" $ \t -> either (const False) (t ==) (runConduit $ renderRssSource t =$= force "ERROR" rssSource) roundtripGuidProperty :: TestTree roundtripGuidProperty = testProperty "parse . render = id (RssGuid)" $ \t -> either (const False) (t ==) (runConduit $ renderRssGuid t =$= force "ERROR" rssGuid) roundtripItemProperty :: TestTree roundtripItemProperty = testProperty "parse . render = id (RssItem)" $ \(t :: RssItem '[]) -> either (const False) (t ==) (runConduit $ renderRssItem t =$= force "ERROR" rssItem) letter = choose ('a', 'z') digit = arbitrary `suchThat` isDigit alphaNum = oneof [letter, digit]