diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,41 @@ +#### 1.3.2.1 +* text 2.0 support, thanks to Alexander Batischev. +* Moved the repository to https://github.com/haskell-party/ + +### 1.3.2.0 +* Expose RSS/Atom item content through queries by using `getItemContent`. + +### 1.3.0.1 +* Add a test to check that validation works on a simple entry. +* Change attribute handling when validating so that type attribute is recognised properly on content. + +#### 1.3.0.0 +* Reverted changes to `EntryContent` that came in 1.2.0.0. Thanks to Tomas Janousek. + +#### 1.2.0.1 + +* Get rid of xmlns:ns and ns:-prefixed attributes that confused some applications, thanks to Tomas Janousek. +* GHC 8.8 support + +## 1.2.0.0 + +Updated `EntryContent`'s `HTMLContent` to wrap an `XML.Element` instead of `Text`. Thanks to Jake Keuhlen. + +## 1.1.0.0 + +* `parseFeedFromFile` now returns `IO (Maybe Feed)` instead of `IO Feed` to distinguish IO exceptions from parse failures. Thanks to Jake Keuhlen. + +#### 1.0.1.0 + +* Support for GHC 8.6.x libraries + +* Add `textFeed` and `textRSS` helpers (thanks to Francesco Ariis) + +# 1.0.0.0 + +* Thanks to Dmitry Dzhus feed has been modernized to use the `text`, + `xml-types` and `xml-conduit` libraries. + ### 0.3.12.0 * Adds support for some fallback parsing of atom feeds to XMLFeed (thanks to Joey Hess) diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,204 @@ +# Feed + +[![feed](https://img.shields.io/hackage/v/feed.svg)](http://hackage.haskell.org/package/feed) +![Build Status](https://github.com/haskell-party/feed/actions/workflows/haskell-ci.yml/badge.svg) + + +## Goal + +Interfacing with *RSS* (v 0.9x, 2.x, 1.0) + *Atom* feeds. + +- Parsers +- Constructors +- Rendering +- Querying + +To help working with the multiple feed formats we've ended up with +this set of modules providing parsers, printers and some utility +code for querying and just generally working with a concrete +representation of feeds in Haskell. + +For basic reading and editing of feeds, consult the documentation of +the Text.Feed.* hierarchy. + +## Usage + +Building an Atom feed is similar to building an RSS feed, but we'll +arbitrarily pick Atom here: + +We'd like to generate the XML for a minimal working example. +Constructing our base `Feed` can use the smart constructor called `nullFeed`: + +*This is a pattern the library maintains for smart constructors. If you want the +minimum viable 'X', use the 'nullX' constructor.* + + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Prelude.Compat hiding (take) +import Data.Maybe +import Data.Text +import Data.XML.Types as XML +import qualified Data.Text.Lazy as Lazy +import Text.Feed.Types + +import Text.XML (def, rsPretty) +import qualified Text.Atom.Feed as Atom +import qualified Text.Feed.Export as Export (textFeedWith) + +myFeed :: Atom.Feed +myFeed = Atom.nullFeed + "http://example.com/atom.xml" + (Atom.TextString "Example Website") + "2017-08-01" +``` + +Now we can export the feed to `Text`. + +```haskell +renderFeed :: Atom.Feed -> Lazy.Text +renderFeed = fromJust . Export.textFeedWith def{rsPretty = True} . AtomFeed +``` + +We can now render our feed: + +```haskell +-- | +-- $setup +-- >>> import qualified Data.Text.Lazy.IO as Lazy +-- +-- >>> Lazy.putStr $ renderFeed myFeed +-- +-- +-- +-- Example Website +-- +-- +-- http://example.com/atom.xml +-- +-- +-- 2017-08-01 +-- +-- +``` + +The `TextContent` sum type allows us to specify which type of text we're providing. + +```haskell +data TextContent + = TextString Text + | HTMLString Text + | XHTMLString XML.Element + deriving (Show) +``` + +A feed isn't very useful without some content though, so we'll need to build up an `Entry`. + +```haskell +data Post + = Post + { _postedOn :: Text + , _url :: Text + , _content :: Text + } + +examplePosts :: [Post] +examplePosts = + [ Post "2000-02-02T18:30:00Z" "http://example.com/2" "Bar." + , Post "2000-01-01T18:30:00Z" "http://example.com/1" "Foo." + ] +``` + +Our `Post` data type will need to be converted into an `Entry` in order to use it in the top level `Feed`. The required fields for an entry are an url "id" from which an entry's presence can be validated, a title for the entry, and a posting date. In this example we'll also add authors, link, and the entries actual content, since we have all of this available in the `Post` provided. + +```haskell +toEntry :: Post -> Atom.Entry +toEntry (Post date url content) = + (Atom.nullEntry + url -- The ID field. Must be a link to validate. + (Atom.TextString (take 20 content)) -- Title + date) + { Atom.entryAuthors = [Atom.nullPerson {Atom.personName = "J. Smith"}] + , Atom.entryLinks = [Atom.nullLink url] + , Atom.entryContent = Just (Atom.HTMLContent content) + } +``` + +From the base feed we created earlier, we can add further details (`Link` and `Entry` content) as well as map our `toEntry` function over the posts we'd like to include in the feed. + +```haskell +feed :: Atom.Feed +feed = + myFeed { Atom.feedEntries = fmap toEntry examplePosts + , Atom.feedLinks = [Atom.nullLink "http://example.com/"] + } +``` + +```haskell +-- | +-- >>> Lazy.putStr $ renderFeed feed +-- +-- +-- +-- Example Website +-- +-- +-- http://example.com/atom.xml +-- +-- +-- 2017-08-01 +-- +-- +-- +-- +-- http://example.com/2 +-- +-- +-- Bar. +-- +-- +-- 2000-02-02T18:30:00Z +-- +-- +-- +-- J. Smith +-- +-- +-- +-- Bar. +-- +-- +-- +-- +-- +-- http://example.com/1 +-- +-- +-- Foo. +-- +-- +-- 2000-01-01T18:30:00Z +-- +-- +-- +-- J. Smith +-- +-- +-- +-- Foo. +-- +-- +-- +-- +``` + +See [here](https://github.com/haskell-party/feed/blob/master/tests/Example/CreateAtom.hs) for this content as an uninterrupted running example. + +```haskell +-- Dummy main needed to compile this file with markdown-unlit +main :: IO () +main = return () +``` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,15 +1,204 @@ -[![feed](https://budueba.com/hackage/feed)](https://hackage.haskell.org/package/feed) -[![Build Status](https://travis-ci.org/bergmark/feed.svg?branch=master)](https://travis-ci.org/bergmark/feed) +# Feed -Interfacing with RSS (v 0.9x, 2.x, 1.0) + Atom feeds. +[![feed](https://img.shields.io/hackage/v/feed.svg)](http://hackage.haskell.org/package/feed) +![Build Status](https://github.com/haskell-party/feed/actions/workflows/haskell-ci.yml/badge.svg) -To help working with the multiple feed formats we've ended up with, -this set of modules provides parsers, pretty printers and some utility + +## Goal + +Interfacing with *RSS* (v 0.9x, 2.x, 1.0) + *Atom* feeds. + +- Parsers +- Constructors +- Rendering +- Querying + +To help working with the multiple feed formats we've ended up with +this set of modules providing parsers, printers and some utility code for querying and just generally working with a concrete representation of feeds in Haskell. -See [here](https://github.com/bergmark/feed/blob/master/tests/Example/CreateAtom.hs) for an example -of how to create an Atom feed. - For basic reading and editing of feeds, consult the documentation of the Text.Feed.* hierarchy. + +## Usage + +Building an Atom feed is similar to building an RSS feed, but we'll +arbitrarily pick Atom here: + +We'd like to generate the XML for a minimal working example. +Constructing our base `Feed` can use the smart constructor called `nullFeed`: + +*This is a pattern the library maintains for smart constructors. If you want the +minimum viable 'X', use the 'nullX' constructor.* + + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Prelude.Compat hiding (take) +import Data.Maybe +import Data.Text +import Data.XML.Types as XML +import qualified Data.Text.Lazy as Lazy +import Text.Feed.Types + +import Text.XML (def, rsPretty) +import qualified Text.Atom.Feed as Atom +import qualified Text.Feed.Export as Export (textFeedWith) + +myFeed :: Atom.Feed +myFeed = Atom.nullFeed + "http://example.com/atom.xml" + (Atom.TextString "Example Website") + "2017-08-01" +``` + +Now we can export the feed to `Text`. + +```haskell +renderFeed :: Atom.Feed -> Lazy.Text +renderFeed = fromJust . Export.textFeedWith def{rsPretty = True} . AtomFeed +``` + +We can now render our feed: + +```haskell +-- | +-- $setup +-- >>> import qualified Data.Text.Lazy.IO as Lazy +-- +-- >>> Lazy.putStr $ renderFeed myFeed +-- +-- +-- +-- Example Website +-- +-- +-- http://example.com/atom.xml +-- +-- +-- 2017-08-01 +-- +-- +``` + +The `TextContent` sum type allows us to specify which type of text we're providing. + +```haskell +data TextContent + = TextString Text + | HTMLString Text + | XHTMLString XML.Element + deriving (Show) +``` + +A feed isn't very useful without some content though, so we'll need to build up an `Entry`. + +```haskell +data Post + = Post + { _postedOn :: Text + , _url :: Text + , _content :: Text + } + +examplePosts :: [Post] +examplePosts = + [ Post "2000-02-02T18:30:00Z" "http://example.com/2" "Bar." + , Post "2000-01-01T18:30:00Z" "http://example.com/1" "Foo." + ] +``` + +Our `Post` data type will need to be converted into an `Entry` in order to use it in the top level `Feed`. The required fields for an entry are an url "id" from which an entry's presence can be validated, a title for the entry, and a posting date. In this example we'll also add authors, link, and the entries actual content, since we have all of this available in the `Post` provided. + +```haskell +toEntry :: Post -> Atom.Entry +toEntry (Post date url content) = + (Atom.nullEntry + url -- The ID field. Must be a link to validate. + (Atom.TextString (take 20 content)) -- Title + date) + { Atom.entryAuthors = [Atom.nullPerson {Atom.personName = "J. Smith"}] + , Atom.entryLinks = [Atom.nullLink url] + , Atom.entryContent = Just (Atom.HTMLContent content) + } +``` + +From the base feed we created earlier, we can add further details (`Link` and `Entry` content) as well as map our `toEntry` function over the posts we'd like to include in the feed. + +```haskell +feed :: Atom.Feed +feed = + myFeed { Atom.feedEntries = fmap toEntry examplePosts + , Atom.feedLinks = [Atom.nullLink "http://example.com/"] + } +``` + +```haskell +-- | +-- >>> Lazy.putStr $ renderFeed feed +-- +-- +-- +-- Example Website +-- +-- +-- http://example.com/atom.xml +-- +-- +-- 2017-08-01 +-- +-- +-- +-- +-- http://example.com/2 +-- +-- +-- Bar. +-- +-- +-- 2000-02-02T18:30:00Z +-- +-- +-- +-- J. Smith +-- +-- +-- +-- Bar. +-- +-- +-- +-- +-- +-- http://example.com/1 +-- +-- +-- Foo. +-- +-- +-- 2000-01-01T18:30:00Z +-- +-- +-- +-- J. Smith +-- +-- +-- +-- Foo. +-- +-- +-- +-- +``` + +See [here](https://github.com/haskell-party/feed/blob/master/tests/Example/CreateAtom.hs) for this content as an uninterrupted running example. + +```haskell +-- Dummy main needed to compile this file with markdown-unlit +main :: IO () +main = return () +``` diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -2,6 +2,5 @@ import Distribution.Simple - main :: IO () main = defaultMain diff --git a/feed.cabal b/feed.cabal --- a/feed.cabal +++ b/feed.cabal @@ -1,5 +1,5 @@ name: feed -version: 0.3.12.0 +version: 1.3.2.1 license: BSD3 license-file: LICENSE category: Text @@ -13,30 +13,45 @@ of feeds in Haskell. . See here for an example of how to create an Atom feed: - + . For basic reading and editing of feeds, consult the documentation of the Text.Feed.* hierarchy. author: Sigbjorn Finne maintainer: Adam Bergmark -homepage: https://github.com/bergmark/feed -bug-reports: https://github.com/bergmark/feed/issues -cabal-version: >= 1.8 +homepage: https://github.com/haskell-party/feed +bug-reports: https://github.com/haskell-party/feed/issues +cabal-version: 2.0 build-type: Simple +tested-with: + GHC == 7.6.3 + , GHC == 7.8.4 + , GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.1 + , GHC == 9.2.1 data-files: - tests/files/rss20.xml - tests/files/atom.xml + tests/files/*.xml extra-source-files: README.md CHANGELOG.md source-repository head type: git - location: https://github.com/bergmark/feed.git + location: https://github.com/haskell-party/feed.git library ghc-options: -Wall hs-source-dirs: src + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings exposed-modules: Text.Atom.Feed Text.Atom.Feed.Export @@ -60,25 +75,41 @@ Text.RSS1.Import Text.RSS1.Syntax Text.RSS1.Utils + other-modules: + Data.Text.Util + Data.XML.Compat build-depends: - base >= 4 && < 4.10 + base >= 4 && < 4.17 + , base-compat >= 0.9 && < 0.13 + , bytestring >= 0.9 && < 0.12 , old-locale == 1.0.* , old-time >= 1 && < 1.2 - , time < 1.7 + , safe == 0.3.* + , text < 1.3 || ==2.0.* + , time < 1.12 , time-locale-compat == 0.1.* , utf8-string < 1.1 - , xml >= 1.2.6 && < 1.3.15 + , xml-types >= 0.3.6 && < 0.4 + , xml-conduit >= 1.3 && < 1.10 test-suite tests ghc-options: -Wall hs-source-dirs: tests main-is: Main.hs type: exitcode-stdio-1.0 + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + autogen-modules: + Paths_feed other-modules: Paths_feed Example Example.CreateAtom + ImportExport Text.Atom.Tests + Text.Atom.Validate.Tests Text.Feed.Util.Tests Text.RSS.Equals Text.RSS.Export.Tests @@ -86,14 +117,49 @@ Text.RSS.Tests Text.RSS.Utils build-depends: - base >= 4 && < 4.10 - , HUnit >= 1.2 && < 1.6 + base >= 4.6 && < 4.17 + , base-compat >= 0.9 && < 0.13 + , HUnit >= 1.2 && < 1.7 , feed - , old-locale == 1.0.* , old-time >= 1 && < 1.2 + , syb , test-framework == 0.8.* , test-framework-hunit == 0.3.* - , time < 1.7 - , time-locale-compat == 0.1.* - , utf8-string < 1.1 - , xml >= 1.2.6 && < 1.4 + , text < 1.3 || ==2.0.* + , time < 1.12 + , xml-types >= 0.3.6 && < 0.4 + , xml-conduit >= 1.3 && < 1.10 + +test-suite readme + ghc-options: -Wall -pgmL markdown-unlit + main-is: README.lhs + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + type: exitcode-stdio-1.0 + build-depends: + base >= 4.6 + , base-compat >= 0.9 && < 0.13 + , text + , feed + , xml-conduit + , xml-types + build-tool-depends: + markdown-unlit:markdown-unlit >= 0.4 && < 0.6 + +test-suite readme-doctests + hs-source-dirs: tests + main-is: doctest-driver.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + if impl(ghc < 8) + buildable: False + build-depends: + base >= 4.6 + , doctest + , doctest-driver-gen + , feed + build-tool-depends: + markdown-unlit:markdown-unlit >= 0.4 && < 0.6 + , doctest-driver-gen:doctest-driver-gen diff --git a/src/Data/Text/Util.hs b/src/Data/Text/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Util.hs @@ -0,0 +1,36 @@ +module Data.Text.Util + ( readInt + , renderFeed + , renderFeedWith + ) where + +import Prelude.Compat + +import Data.Text +import Data.Text.Read + +import qualified Data.Text.Lazy as TL +import qualified Data.XML.Types as XT -- from xml-types +import qualified Text.XML as XC -- from xml-conduit + +readInt :: Text -> Maybe Integer +readInt s = + case decimal s of + Right (x, _) -> Just x + _ -> Nothing + +renderFeed :: (a -> XT.Element) -> a -> Maybe TL.Text +renderFeed = renderFeedWith XC.def + +renderFeedWith :: XC.RenderSettings -> (a -> XT.Element) -> a -> Maybe TL.Text +renderFeedWith opts cf f = + let e = cf f + d = elToDoc e + in XC.renderText opts <$> d + +-- Ancillaries -- +elToDoc :: XT.Element -> Maybe XC.Document +elToDoc el = + let txd = XT.Document (XC.Prologue [] Nothing []) el [] + cxd = XC.fromXMLDocument txd + in either (const Nothing) Just cxd diff --git a/src/Data/XML/Compat.hs b/src/Data/XML/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/XML/Compat.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleInstances #-} + +-- | Compatibility interface between `xml` and `xml-types`. +module Data.XML.Compat where + +import Prelude.Compat + +import Data.Text (Text) +import qualified Data.Text as T +import Data.XML.Types + +import Safe + +type Attr = (Name, [Content]) + +mkAttr :: Text -> Text -> Attr +mkAttr k = mkNAttr (Name k Nothing Nothing) + +mkNAttr :: Name -> Text -> Attr +mkNAttr k v = (k, [ContentText v]) + +attrKey :: Attr -> Name +attrKey = fst + +strContent :: Element -> Text +strContent = T.concat . elementText + +class ToNode t where + unode :: Name -> t -> Element + +instance ToNode [Attr] where + unode n as = Element n as [] + +instance ToNode [Element] where + unode n = Element n [] . map NodeElement + +instance ToNode ([Attr], Text) where + unode n (as, t) = Element n as [NodeContent $ ContentText t] + +instance ToNode Text where + unode n t = unode n ([] :: [Attr], t) + +findChildren :: Name -> Element -> [Element] +findChildren n el = filter ((n ==) . elementName) $ elementChildren el + +findChild :: Name -> Element -> Maybe Element +findChild = (headMay .) <$> findChildren + +findElements :: Name -> Element -> [Element] +findElements n e + | n == elementName e = [e] + | otherwise = concatMap (findElements n) $ elementChildren e + +findElement :: Name -> Element -> Maybe Element +findElement = (headMay .) <$> findElements diff --git a/src/Text/Atom/Feed.hs b/src/Text/Atom/Feed.hs --- a/src/Text/Atom/Feed.hs +++ b/src/Text/Atom/Feed.hs @@ -10,24 +10,24 @@ -- Portability: portable -- -------------------------------------------------------------------- - module Text.Atom.Feed ( URI , NCName , Date , MediaType - , Feed (..) - , Entry (..) - , EntryContent (..) - , Category (..) - , Generator (..) - , Link (..) - , TextContent (..) + , Attr + , Feed(..) + , Entry(..) + , EntryContent(..) + , Category(..) + , Generator(..) + , Link(..) + , TextContent(..) , txtToString - , Source (..) - , Person (..) - , InReplyTo (..) - , InReplyTotal (..) + , Source(..) + , Person(..) + , InReplyTo(..) + , InReplyTotal(..) , newCategory , nullFeed , nullEntry @@ -37,252 +37,249 @@ , nullPerson ) where -import qualified Text.XML.Light as XML +import Prelude.Compat --- *Core types +import Data.Text (Text, unpack) +import Data.XML.Compat +import Data.XML.Types as XML +-- *Core types -- NOTE: In the future we may want to have more structured -- types for these. -type URI = String -type NCName = String -type Date = String -type MediaType = String +type URI = Text -data Feed - = Feed - { feedId :: String - , feedTitle :: TextContent - , feedUpdated :: Date - , feedAuthors :: [Person] - , feedCategories :: [Category] - , feedContributors :: [Person] - , feedGenerator :: Maybe Generator - , feedIcon :: Maybe URI - , feedLinks :: [Link] - , feedLogo :: Maybe URI - , feedRights :: Maybe TextContent - , feedSubtitle :: Maybe TextContent - , feedEntries :: [Entry] - , feedAttrs :: [XML.Attr] - , feedOther :: [XML.Element] - } - deriving (Show) +type NCName = Text -data Entry - = Entry - { entryId :: String - , entryTitle :: TextContent - , entryUpdated :: Date - , entryAuthors :: [Person] - , entryCategories :: [Category] - , entryContent :: Maybe EntryContent - , entryContributor :: [Person] - , entryLinks :: [Link] - , entryPublished :: Maybe Date - , entryRights :: Maybe TextContent - , entrySource :: Maybe Source - , entrySummary :: Maybe TextContent - , entryInReplyTo :: Maybe InReplyTo - , entryInReplyTotal :: Maybe InReplyTotal - , entryAttrs :: [XML.Attr] - , entryOther :: [XML.Element] - } - deriving (Show) +type Date = Text -data EntryContent - = TextContent String - | HTMLContent String - | XHTMLContent XML.Element - | MixedContent (Maybe String) [XML.Content] - | ExternalContent (Maybe MediaType) URI - deriving (Show) +type MediaType = Text -data Category - = Category - { catTerm :: String -- ^ the tag\/term of the category. - , catScheme :: Maybe URI -- ^ optional URL for identifying the categorization scheme. - , catLabel :: Maybe String -- ^ human-readable label of the category - , catOther :: [XML.Element] -- ^ unknown elements, for extensibility. - } - deriving (Show) +data Feed = + Feed + { feedId :: URI + , feedTitle :: TextContent + , feedUpdated :: Date + , feedAuthors :: [Person] + , feedCategories :: [Category] + , feedContributors :: [Person] + , feedGenerator :: Maybe Generator + , feedIcon :: Maybe URI + , feedLinks :: [Link] + , feedLogo :: Maybe URI + , feedRights :: Maybe TextContent + , feedSubtitle :: Maybe TextContent + , feedEntries :: [Entry] + , feedAttrs :: [Attr] + , feedOther :: [XML.Element] + } + deriving (Show) +data Entry = + Entry + { entryId :: URI + , entryTitle :: TextContent + , entryUpdated :: Date + , entryAuthors :: [Person] + , entryCategories :: [Category] + , entryContent :: Maybe EntryContent + , entryContributor :: [Person] + , entryLinks :: [Link] + , entryPublished :: Maybe Date + , entryRights :: Maybe TextContent + , entrySource :: Maybe Source + , entrySummary :: Maybe TextContent + , entryInReplyTo :: Maybe InReplyTo + , entryInReplyTotal :: Maybe InReplyTotal + , entryAttrs :: [Attr] + , entryOther :: [XML.Element] + } + deriving (Show) -data Generator - = Generator - { genURI :: Maybe URI - , genVersion :: Maybe String - , genText :: String - } - deriving (Eq, Show) +data EntryContent + = TextContent Text + | HTMLContent Text + | XHTMLContent XML.Element + | MixedContent (Maybe Text) [XML.Node] + | ExternalContent (Maybe MediaType) URI + deriving (Show) -data Link - = Link - { linkHref :: URI +data Category = + Category + { catTerm :: Text -- ^ the tag\/term of the category. + , catScheme :: Maybe URI -- ^ optional URL for identifying the categorization scheme. + , catLabel :: Maybe Text -- ^ human-readable label of the category + , catOther :: [XML.Element] -- ^ unknown elements, for extensibility. + } + deriving (Show) + +data Generator = + Generator + { genURI :: Maybe URI + , genVersion :: Maybe Text + , genText :: Text + } + deriving (Eq, Show) + +data Link = + Link + { linkHref :: URI -- ToDo: make the switch over to using the Atom.Feed.Link relation type. - , linkRel :: Maybe (Either NCName URI) - , linkType :: Maybe MediaType - , linkHrefLang :: Maybe String - , linkTitle :: Maybe String - , linkLength :: Maybe String - , linkAttrs :: [XML.Attr] - , linkOther :: [XML.Element] - } - deriving (Show) + , linkRel :: Maybe (Either NCName URI) + , linkType :: Maybe MediaType + , linkHrefLang :: Maybe Text + , linkTitle :: Maybe Text + , linkLength :: Maybe Text + , linkAttrs :: [Attr] + , linkOther :: [XML.Element] + } + deriving (Show) data TextContent - = TextString String - | HTMLString String - | XHTMLString XML.Element - deriving (Show) + = TextString Text + | HTMLString Text + | XHTMLString XML.Element + deriving (Show) txtToString :: TextContent -> String -txtToString (TextString s) = s -txtToString (HTMLString s) = s +txtToString (TextString s) = unpack s +txtToString (HTMLString s) = unpack s txtToString (XHTMLString x) = show x -data Source - = Source - { sourceAuthors :: [Person] - , sourceCategories :: [Category] - , sourceGenerator :: Maybe Generator - , sourceIcon :: Maybe URI - , sourceId :: Maybe String - , sourceLinks :: [Link] - , sourceLogo :: Maybe URI - , sourceRights :: Maybe TextContent - , sourceSubtitle :: Maybe TextContent - , sourceTitle :: Maybe TextContent - , sourceUpdated :: Maybe Date - , sourceOther :: [XML.Element] - } - deriving (Show) - +data Source = + Source + { sourceAuthors :: [Person] + , sourceCategories :: [Category] + , sourceGenerator :: Maybe Generator + , sourceIcon :: Maybe URI + , sourceId :: Maybe URI + , sourceLinks :: [Link] + , sourceLogo :: Maybe URI + , sourceRights :: Maybe TextContent + , sourceSubtitle :: Maybe TextContent + , sourceTitle :: Maybe TextContent + , sourceUpdated :: Maybe Date + , sourceOther :: [XML.Element] + } + deriving (Show) -data Person - = Person - { personName :: String - , personURI :: Maybe URI - , personEmail :: Maybe String - , personOther :: [XML.Element] - } - deriving (Show) +data Person = + Person + { personName :: Text + , personURI :: Maybe URI + , personEmail :: Maybe Text + , personOther :: [XML.Element] + } + deriving (Show) -data InReplyTo - = InReplyTo - { replyToRef :: URI - , replyToHRef :: Maybe URI - , replyToType :: Maybe MediaType - , replyToSource :: Maybe URI - , replyToOther :: [XML.Attr] - , replyToContent :: [XML.Content] - } - deriving (Show) +data InReplyTo = + InReplyTo + { replyToRef :: URI + , replyToHRef :: Maybe URI + , replyToType :: Maybe MediaType + , replyToSource :: Maybe URI + , replyToOther :: [Attr] + , replyToContent :: [Node] + } + deriving (Show) -data InReplyTotal - = InReplyTotal - { replyToTotal :: Integer -- non-negative :) - , replyToTotalOther :: [XML.Attr] - } - deriving (Show) +data InReplyTotal = + InReplyTotal + { replyToTotal :: Integer -- non-negative :) + , replyToTotalOther :: [Attr] + } + deriving (Show) -- *Smart Constructors - -newCategory :: String -- ^catTerm - -> Category -newCategory t = Category - { catTerm = t - , catScheme = Nothing - , catLabel = Just t - , catOther = [] - } - -nullFeed :: String -- ^feedId - -> TextContent -- ^feedTitle - -> Date -- ^feedUpdated - -> Feed -nullFeed i t u = Feed - { feedId = i - , feedTitle = t - , feedUpdated = u - , feedAuthors = [] - , feedCategories = [] - , feedContributors = [] - , feedGenerator = Nothing - , feedIcon = Nothing - , feedLinks = [] - , feedLogo = Nothing - , feedRights = Nothing - , feedSubtitle = Nothing - , feedEntries = [] - , feedAttrs = [] - , feedOther = [] - } +newCategory :: + Text -- ^catTerm + -> Category +newCategory t = Category {catTerm = t, catScheme = Nothing, catLabel = Just t, catOther = []} -nullEntry :: String -- ^entryId - -> TextContent -- ^entryTitle - -> Date -- ^entryUpdated - -> Entry -nullEntry i t u = Entry - { entryId = i - , entryTitle = t - , entryUpdated = u - , entryAuthors = [] - , entryCategories = [] - , entryContent = Nothing - , entryContributor = [] - , entryLinks = [] - , entryPublished = Nothing - , entryRights = Nothing - , entrySource = Nothing - , entrySummary = Nothing - , entryInReplyTo = Nothing - , entryInReplyTotal = Nothing - , entryAttrs = [] - , entryOther = [] - } +nullFeed :: + URI -- ^feedId + -> TextContent -- ^feedTitle + -> Date -- ^feedUpdated + -> Feed +nullFeed i t u = + Feed + { feedId = i + , feedTitle = t + , feedUpdated = u + , feedAuthors = [] + , feedCategories = [] + , feedContributors = [] + , feedGenerator = Nothing + , feedIcon = Nothing + , feedLinks = [] + , feedLogo = Nothing + , feedRights = Nothing + , feedSubtitle = Nothing + , feedEntries = [] + , feedAttrs = [] + , feedOther = [] + } +nullEntry :: + URI -- ^entryId + -> TextContent -- ^entryTitle + -> Date -- ^entryUpdated + -> Entry +nullEntry i t u = + Entry + { entryId = i + , entryTitle = t + , entryUpdated = u + , entryAuthors = [] + , entryCategories = [] + , entryContent = Nothing + , entryContributor = [] + , entryLinks = [] + , entryPublished = Nothing + , entryRights = Nothing + , entrySource = Nothing + , entrySummary = Nothing + , entryInReplyTo = Nothing + , entryInReplyTotal = Nothing + , entryAttrs = [] + , entryOther = [] + } -nullGenerator :: String -- ^genText - -> Generator -nullGenerator t = Generator - { genURI = Nothing - , genVersion = Nothing - , genText = t - } +nullGenerator :: + Text -- ^genText + -> Generator +nullGenerator t = Generator {genURI = Nothing, genVersion = Nothing, genText = t} -nullLink :: URI -- ^linkHref - -> Link -nullLink uri = Link - { linkHref = uri - , linkRel = Nothing - , linkType = Nothing - , linkHrefLang = Nothing - , linkTitle = Nothing - , linkLength = Nothing - , linkAttrs = [] - , linkOther = [] - } +nullLink :: + URI -- ^linkHref + -> Link +nullLink uri = + Link + { linkHref = uri + , linkRel = Nothing + , linkType = Nothing + , linkHrefLang = Nothing + , linkTitle = Nothing + , linkLength = Nothing + , linkAttrs = [] + , linkOther = [] + } nullSource :: Source -nullSource = Source - { sourceAuthors = [] - , sourceCategories = [] - , sourceGenerator = Nothing - , sourceIcon = Nothing - , sourceId = Nothing - , sourceLinks = [] - , sourceLogo = Nothing - , sourceRights = Nothing - , sourceSubtitle = Nothing - , sourceTitle = Nothing - , sourceUpdated = Nothing - , sourceOther = [] - } +nullSource = + Source + { sourceAuthors = [] + , sourceCategories = [] + , sourceGenerator = Nothing + , sourceIcon = Nothing + , sourceId = Nothing + , sourceLinks = [] + , sourceLogo = Nothing + , sourceRights = Nothing + , sourceSubtitle = Nothing + , sourceTitle = Nothing + , sourceUpdated = Nothing + , sourceOther = [] + } nullPerson :: Person -nullPerson = Person - { personName = "" - , personURI = Nothing - , personEmail = Nothing - , personOther = [] - } +nullPerson = Person {personName = "", personURI = Nothing, personEmail = Nothing, personOther = []} diff --git a/src/Text/Atom/Feed/Export.hs b/src/Text/Atom/Feed/Export.hs --- a/src/Text/Atom/Feed/Export.hs +++ b/src/Text/Atom/Feed/Export.hs @@ -13,8 +13,6 @@ -- Convert from Atom to XML -- -------------------------------------------------------------------- - - module Text.Atom.Feed.Export ( atom_prefix , atom_thr_prefix @@ -31,6 +29,7 @@ , atomThreadNode , atomThreadLeaf , xmlFeed + , textFeed , xmlEntry , xmlContent , xmlCategory @@ -55,190 +54,172 @@ , mb ) where -import Text.XML.Light as XML +import Prelude.Compat + +import Data.Text (Text, pack) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Util as U +import Data.XML.Types as XML import Text.Atom.Feed -atom_prefix :: Maybe String +atom_prefix :: Maybe Text atom_prefix = Nothing -- Just "atom" -atom_thr_prefix :: Maybe String +atom_thr_prefix :: Maybe Text atom_thr_prefix = Just "thr" -atomNS :: String +atomNS :: Text atomNS = "http://www.w3.org/2005/Atom" -atomThreadNS :: String +atomThreadNS :: Text atomThreadNS = "http://purl.org/syndication/thread/1.0" +blank_element :: Name -> [Node] -> XML.Element +blank_element name = XML.Element name [] + xmlns_atom :: Attr -xmlns_atom = Attr qn atomNS - where - qn = case atom_prefix of - Nothing -> QName { qName = "xmlns" - , qURI = Nothing - , qPrefix = Nothing - } - Just s -> QName { qName = s - , qURI = Nothing -- XXX: is this ok? - , qPrefix = Just "xmlns" - } +xmlns_atom = (qn, [ContentText atomNS]) + where + qn = + case atom_prefix of + Nothing -> Name {nameLocalName = "xmlns", nameNamespace = Nothing, namePrefix = Nothing} + Just s -> + Name + { nameLocalName = s + , nameNamespace = Nothing -- XXX: is this ok? + , namePrefix = Just "xmlns" + } xmlns_atom_thread :: Attr -xmlns_atom_thread = Attr qn atomThreadNS - where - qn = case atom_prefix of - Nothing -> QName { qName = "xmlns" - , qURI = Nothing - , qPrefix = Nothing - } - Just s -> QName { qName = s - , qURI = Nothing -- XXX: is this ok? - , qPrefix = Just "xmlns" - } +xmlns_atom_thread = (qn, [ContentText atomThreadNS]) + where + qn = + case atom_prefix of + Nothing -> Name {nameLocalName = "xmlns", nameNamespace = Nothing, namePrefix = Nothing} + Just s -> + Name + { nameLocalName = s + , nameNamespace = Nothing -- XXX: is this ok? + , namePrefix = Just "xmlns" + } -atomName :: String -> QName -atomName nc = QName { qName = nc - , qURI = Just atomNS - , qPrefix = atom_prefix - } +atomName :: Text -> Name +atomName nc = Name {nameLocalName = nc, nameNamespace = Just atomNS, namePrefix = atom_prefix} -atomAttr :: String -> String -> Attr -atomAttr x y = Attr (atomName x) y +atomAttr :: Text -> Text -> Attr +atomAttr x y = + (Name {nameLocalName = x, nameNamespace = Nothing, namePrefix = atom_prefix}, [ContentText y]) -atomNode :: String -> [XML.Content] -> XML.Element -atomNode x xs = blank_element { elName = atomName x, elContent = xs } +atomNode :: Text -> [Node] -> XML.Element +atomNode x = blank_element (atomName x) -atomLeaf :: String -> String -> XML.Element -atomLeaf tag txt = blank_element - { elName = atomName tag - , elContent = [ Text blank_cdata { cdData = txt } ] - } +atomLeaf :: Text -> Text -> XML.Element +atomLeaf tag txt = blank_element (atomName tag) [NodeContent $ ContentText txt] -atomThreadName :: String -> QName +atomThreadName :: Text -> Name atomThreadName nc = - QName { qName = nc - , qURI = Just atomThreadNS - , qPrefix = atom_thr_prefix - } + Name {nameLocalName = nc, nameNamespace = Just atomThreadNS, namePrefix = atom_thr_prefix} -atomThreadAttr :: String -> String -> Attr -atomThreadAttr x y = Attr (atomThreadName x) y +atomThreadAttr :: Text -> Text -> Attr +atomThreadAttr x y = (atomThreadName x, [ContentText y]) -atomThreadNode :: String -> [XML.Content] -> XML.Element -atomThreadNode x xs = - blank_element { elName = atomThreadName x, elContent = xs } +atomThreadNode :: Text -> [Node] -> XML.Element +atomThreadNode x = blank_element (atomThreadName x) -atomThreadLeaf :: String -> String -> XML.Element -atomThreadLeaf tag txt = - blank_element { elName = atomThreadName tag - , elContent = [ Text blank_cdata { cdData = txt } ] - } +atomThreadLeaf :: Text -> Text -> XML.Element +atomThreadLeaf tag txt = blank_element (atomThreadName tag) [NodeContent $ ContentText txt] -------------------------------------------------------------------------------- - xmlFeed :: Feed -> XML.Element -xmlFeed f = ( atomNode "feed" - $ map Elem - $ [ xmlTitle (feedTitle f) ] - ++ [ xmlId (feedId f) ] - ++ [ xmlUpdated (feedUpdated f) ] - ++ map xmlLink (feedLinks f) - ++ map xmlAuthor (feedAuthors f) - ++ map xmlCategory (feedCategories f) - ++ map xmlContributor (feedContributors f) - ++ mb xmlGenerator (feedGenerator f) - ++ mb xmlIcon (feedIcon f) - ++ mb xmlLogo (feedLogo f) - ++ mb xmlRights (feedRights f) - ++ mb xmlSubtitle (feedSubtitle f) - ++ map xmlEntry (feedEntries f) - ++ feedOther f ) - - { elAttribs = [xmlns_atom] } +xmlFeed f = + (atomNode "feed" $ + map NodeElement $ + [xmlTitle (feedTitle f)] ++ + [xmlId (feedId f)] ++ + [xmlUpdated (feedUpdated f)] ++ + map xmlLink (feedLinks f) ++ + map xmlAuthor (feedAuthors f) ++ + map xmlCategory (feedCategories f) ++ + map xmlContributor (feedContributors f) ++ + mb xmlGenerator (feedGenerator f) ++ + mb xmlIcon (feedIcon f) ++ + mb xmlLogo (feedLogo f) ++ + mb xmlRights (feedRights f) ++ + mb xmlSubtitle (feedSubtitle f) ++ map xmlEntry (feedEntries f) ++ feedOther f) + {elementAttributes = [xmlns_atom]} +textFeed :: Feed -> Maybe TL.Text +textFeed = U.renderFeed xmlFeed xmlEntry :: Entry -> XML.Element -xmlEntry e = ( atomNode "entry" - $ map Elem - $ [ xmlId (entryId e) ] - ++ [ xmlTitle (entryTitle e) ] - ++ [ xmlUpdated (entryUpdated e) ] - ++ map xmlAuthor (entryAuthors e) - ++ map xmlCategory (entryCategories e) - ++ mb xmlContent (entryContent e) - ++ map xmlContributor (entryContributor e) - ++ map xmlLink (entryLinks e) - ++ mb xmlPublished (entryPublished e) - ++ mb xmlRights (entryRights e) - ++ mb xmlSource (entrySource e) - ++ mb xmlSummary (entrySummary e) - ++ mb xmlInReplyTo (entryInReplyTo e) - ++ mb xmlInReplyTotal (entryInReplyTotal e) - ++ entryOther e ) - - { elAttribs = entryAttrs e } +xmlEntry e = + (atomNode "entry" $ + map NodeElement $ + [xmlId (entryId e)] ++ + [xmlTitle (entryTitle e)] ++ + [xmlUpdated (entryUpdated e)] ++ + map xmlAuthor (entryAuthors e) ++ + map xmlCategory (entryCategories e) ++ + mb xmlContent (entryContent e) ++ + map xmlContributor (entryContributor e) ++ + map xmlLink (entryLinks e) ++ + mb xmlPublished (entryPublished e) ++ + mb xmlRights (entryRights e) ++ + mb xmlSource (entrySource e) ++ + mb xmlSummary (entrySummary e) ++ + mb xmlInReplyTo (entryInReplyTo e) ++ mb xmlInReplyTotal (entryInReplyTotal e) ++ entryOther e) + {elementAttributes = entryAttrs e} xmlContent :: EntryContent -> XML.Element -xmlContent cont = case cont of - - TextContent t -> (atomLeaf "content" t) - { elAttribs = [ atomAttr "type" "text" ] } - - HTMLContent t -> (atomLeaf "content" t) - { elAttribs = [ atomAttr "type" "html" ] } - - XHTMLContent x -> (atomNode "content" [ Elem x ]) - { elAttribs = [ atomAttr "type" "xhtml" ] } - - MixedContent mbTy cs -> (atomNode "content" cs) - { elAttribs = mb (atomAttr "type") mbTy } - - ExternalContent mbTy src -> (atomNode "content" []) - { elAttribs = [ atomAttr "src" src ] - ++ mb (atomAttr "type") mbTy } - +xmlContent cont = + case cont of + TextContent t -> (atomLeaf "content" t) {elementAttributes = [atomAttr "type" "text"]} + HTMLContent t -> (atomLeaf "content" t) {elementAttributes = [atomAttr "type" "html"]} + XHTMLContent x -> + (atomNode "content" [NodeElement x]) {elementAttributes = [atomAttr "type" "xhtml"]} + MixedContent mbTy cs -> (atomNode "content" cs) {elementAttributes = mb (atomAttr "type") mbTy} + ExternalContent mbTy src -> + (atomNode "content" []) {elementAttributes = atomAttr "src" src : mb (atomAttr "type") mbTy} xmlCategory :: Category -> XML.Element -xmlCategory c = (atomNode "category" (map Elem (catOther c))) - { elAttribs = [ atomAttr "term" (catTerm c) ] - ++ mb (atomAttr "scheme") (catScheme c) - ++ mb (atomAttr "label") (catLabel c) - } +xmlCategory c = + (atomNode "category" (map NodeElement (catOther c))) + { elementAttributes = + [atomAttr "term" (catTerm c)] ++ + mb (atomAttr "scheme") (catScheme c) ++ mb (atomAttr "label") (catLabel c) + } xmlLink :: Link -> XML.Element -xmlLink l = (atomNode "link" (map Elem (linkOther l))) - { elAttribs = [ atomAttr "href" (linkHref l) ] - ++ mb (atomAttr "rel" . either id id) (linkRel l) - ++ mb (atomAttr "type") (linkType l) - ++ mb (atomAttr "hreflang") (linkHrefLang l) - ++ mb (atomAttr "title") (linkTitle l) - ++ mb (atomAttr "length") (linkLength l) - ++ linkAttrs l - } +xmlLink l = + (atomNode "link" (map NodeElement (linkOther l))) + { elementAttributes = + [atomAttr "href" (linkHref l)] ++ + mb (atomAttr "rel" . either id id) (linkRel l) ++ + mb (atomAttr "type") (linkType l) ++ + mb (atomAttr "hreflang") (linkHrefLang l) ++ + mb (atomAttr "title") (linkTitle l) ++ mb (atomAttr "length") (linkLength l) ++ linkAttrs l + } xmlSource :: Source -> Element -xmlSource s = atomNode "source" - $ map Elem - $ sourceOther s - ++ map xmlAuthor (sourceAuthors s) - ++ map xmlCategory (sourceCategories s) - ++ mb xmlGenerator (sourceGenerator s) - ++ mb xmlIcon (sourceIcon s) - ++ mb xmlId (sourceId s) - ++ map xmlLink (sourceLinks s) - ++ mb xmlLogo (sourceLogo s) - ++ mb xmlRights (sourceRights s) - ++ mb xmlSubtitle (sourceSubtitle s) - ++ mb xmlTitle (sourceTitle s) - ++ mb xmlUpdated (sourceUpdated s) - +xmlSource s = + atomNode "source" $ + map NodeElement $ + sourceOther s ++ + map xmlAuthor (sourceAuthors s) ++ + map xmlCategory (sourceCategories s) ++ + mb xmlGenerator (sourceGenerator s) ++ + mb xmlIcon (sourceIcon s) ++ + mb xmlId (sourceId s) ++ + map xmlLink (sourceLinks s) ++ + mb xmlLogo (sourceLogo s) ++ + mb xmlRights (sourceRights s) ++ + mb xmlSubtitle (sourceSubtitle s) ++ + mb xmlTitle (sourceTitle s) ++ mb xmlUpdated (sourceUpdated s) xmlGenerator :: Generator -> Element -xmlGenerator g = (atomLeaf "generator" (genText g)) - { elAttribs = mb (atomAttr "uri") (genURI g) - ++ mb (atomAttr "version") (genVersion g) - } - +xmlGenerator g = + (atomLeaf "generator" (genText g)) + {elementAttributes = mb (atomAttr "uri") (genURI g) ++ mb (atomAttr "version") (genVersion g)} xmlAuthor :: Person -> XML.Element xmlAuthor p = atomNode "author" (xmlPerson p) @@ -246,63 +227,61 @@ xmlContributor :: Person -> XML.Element xmlContributor c = atomNode "contributor" (xmlPerson c) -xmlPerson :: Person -> [XML.Content] -xmlPerson p = map Elem $ - [ atomLeaf "name" (personName p) ] - ++ mb (atomLeaf "uri") (personURI p) - ++ mb (atomLeaf "email") (personEmail p) - ++ personOther p +xmlPerson :: Person -> [XML.Node] +xmlPerson p = + map NodeElement $ + [atomLeaf "name" (personName p)] ++ + mb (atomLeaf "uri") (personURI p) ++ mb (atomLeaf "email") (personEmail p) ++ personOther p xmlInReplyTo :: InReplyTo -> XML.Element xmlInReplyTo irt = - (atomThreadNode "in-reply-to" (replyToContent irt)) - { elAttribs = - mb (atomThreadAttr "ref") (Just $ replyToRef irt) - ++ mb (atomThreadAttr "href") (replyToHRef irt) - ++ mb (atomThreadAttr "type") (replyToType irt) - ++ mb (atomThreadAttr "source") (replyToSource irt) - ++ replyToOther irt - } + (atomThreadNode "in-reply-to" (replyToContent irt)) + { elementAttributes = + mb (atomThreadAttr "ref") (Just $ replyToRef irt) ++ + mb (atomThreadAttr "href") (replyToHRef irt) ++ + mb (atomThreadAttr "type") (replyToType irt) ++ + mb (atomThreadAttr "source") (replyToSource irt) ++ replyToOther irt + } xmlInReplyTotal :: InReplyTotal -> XML.Element xmlInReplyTotal irt = - (atomThreadLeaf "total" (show $ replyToTotal irt)) - { elAttribs = replyToTotalOther irt } + (atomThreadLeaf "total" (pack $ show $ replyToTotal irt)) + {elementAttributes = replyToTotalOther irt} -xmlId :: String -> XML.Element -xmlId i = atomLeaf "id" i +xmlId :: Text -> XML.Element +xmlId = atomLeaf "id" xmlIcon :: URI -> XML.Element -xmlIcon i = atomLeaf "icon" i +xmlIcon = atomLeaf "icon" xmlLogo :: URI -> XML.Element -xmlLogo l = atomLeaf "logo" l +xmlLogo = atomLeaf "logo" xmlUpdated :: Date -> XML.Element -xmlUpdated u = atomLeaf "updated" u +xmlUpdated = atomLeaf "updated" xmlPublished :: Date -> XML.Element -xmlPublished p = atomLeaf "published" p +xmlPublished = atomLeaf "published" xmlRights :: TextContent -> XML.Element -xmlRights r = xmlTextContent "rights" r +xmlRights = xmlTextContent "rights" xmlTitle :: TextContent -> XML.Element -xmlTitle r = xmlTextContent "title" r +xmlTitle = xmlTextContent "title" xmlSubtitle :: TextContent -> XML.Element -xmlSubtitle s = xmlTextContent "subtitle" s +xmlSubtitle = xmlTextContent "subtitle" xmlSummary :: TextContent -> XML.Element -xmlSummary s = xmlTextContent "summary" s +xmlSummary = xmlTextContent "summary" -xmlTextContent :: String -> TextContent -> XML.Element +xmlTextContent :: Text -> TextContent -> XML.Element xmlTextContent tg t = case t of - TextString s -> (atomLeaf tg s) { elAttribs = [atomAttr "type" "text"] } - HTMLString s -> (atomLeaf tg s) { elAttribs = [atomAttr "type" "html"] } - XHTMLString e -> (atomNode tg [XML.Elem e]) - { elAttribs = [atomAttr "type" "xhtml"] } + TextString s -> (atomLeaf tg s) {elementAttributes = [atomAttr "type" "text"]} + HTMLString s -> (atomLeaf tg s) {elementAttributes = [atomAttr "type" "html"]} + XHTMLString e -> + (atomNode tg [XML.NodeElement e]) {elementAttributes = [atomAttr "type" "xhtml"]} -------------------------------------------------------------------------------- mb :: (a -> b) -> Maybe a -> [b] diff --git a/src/Text/Atom/Feed/Import.hs b/src/Text/Atom/Feed/Import.hs --- a/src/Text/Atom/Feed/Import.hs +++ b/src/Text/Atom/Feed/Import.hs @@ -13,7 +13,6 @@ -- Convert from XML to Atom -- -------------------------------------------------------------------- - module Text.Atom.Feed.Import ( pNodes , pQNodes @@ -39,248 +38,255 @@ , pInReplyTo ) where -import Data.Maybe (listToMaybe, mapMaybe, isJust) -import Data.List (find) -import Control.Monad (guard,mplus) +import Prelude.Compat +import Control.Monad.Compat (guard, mplus) +import Data.List.Compat (find) +import Data.Maybe (isNothing, listToMaybe, mapMaybe) +import Data.Text (Text) +import Data.Text.Read +import Data.XML.Types as XML + import Text.Atom.Feed import Text.Atom.Feed.Export (atomName, atomThreadName) -import Text.XML.Light as XML -pNodes :: String -> [XML.Element] -> [XML.Element] -pNodes x es = filter ((atomName x ==) . elName) es +import qualified Data.Text as T -pQNodes :: QName -> [XML.Element] -> [XML.Element] -pQNodes x es = filter ((x==) . elName) es +pNodes :: Text -> [XML.Element] -> [XML.Element] +pNodes x = filter ((atomName x ==) . elementName) -pNode :: String -> [XML.Element] -> Maybe XML.Element -pNode x es = listToMaybe (pNodes x es) +pQNodes :: Name -> [XML.Element] -> [XML.Element] +pQNodes x = filter ((x ==) . elementName) -pQNode :: QName -> [XML.Element] -> Maybe XML.Element -pQNode x es = listToMaybe (pQNodes x es) +pNode :: Text -> [XML.Element] -> Maybe XML.Element +pNode x es = listToMaybe (pNodes x es) -pLeaf :: String -> [XML.Element] -> Maybe String -pLeaf x es = strContent `fmap` pNode x es +pQNode :: Name -> [XML.Element] -> Maybe XML.Element +pQNode x es = listToMaybe (pQNodes x es) -pQLeaf :: QName -> [XML.Element] -> Maybe String -pQLeaf x es = strContent `fmap` pQNode x es +pLeaf :: Text -> [XML.Element] -> Maybe Text +pLeaf x es = (T.concat . elementText) `fmap` pNode x es -pAttr :: String -> XML.Element -> Maybe String -pAttr x e = fmap snd $ find sameAttr [ (k,v) | Attr k v <- elAttribs e ] +pQLeaf :: Name -> [XML.Element] -> Maybe Text +pQLeaf x es = (T.concat . elementText) `fmap` pQNode x es + +pAttr :: Text -> XML.Element -> Maybe Text +pAttr x e = (`attributeText` e) =<< find (sameAtomAttr x) (map fst $ elementAttributes e) + +pAttrs :: Text -> XML.Element -> [Text] +pAttrs x e = [t | ContentText t <- cnts] where + cnts = concat [v | (k, v) <- elementAttributes e, sameAtomAttr x k] + +sameAtomAttr :: Text -> Name -> Bool +sameAtomAttr x k = k == ax || (isNothing (nameNamespace k) && nameLocalName k == x) + where ax = atomName x - sameAttr (k,_) = k == ax || (not (isJust (qURI k)) && qName k == x) -pAttrs :: String -> XML.Element -> [String] -pAttrs x e = [ v | Attr k v <- elAttribs e, k == atomName x ] +pQAttr :: Name -> XML.Element -> Maybe Text +pQAttr = attributeText -pQAttr :: QName -> XML.Element -> Maybe String -pQAttr x e = lookup x [ (k,v) | Attr k v <- elAttribs e ] +pMany :: Text -> (XML.Element -> Maybe a) -> [XML.Element] -> [a] +pMany p f es = mapMaybe f (pNodes p es) -pMany :: String -> (XML.Element -> Maybe a) -> [XML.Element] -> [a] -pMany p f es = mapMaybe f (pNodes p es) +children :: XML.Element -> [XML.Element] +children = elementChildren -children :: XML.Element -> [XML.Element] -children e = onlyElems (elContent e) +elementTexts :: Element -> Text +elementTexts = T.concat . elementText -elementFeed :: XML.Element -> Maybe Feed -elementFeed e = - do guard (elName e == atomName "feed") - let es = children e - i <- pLeaf "id" es - t <- pTextContent "title" es `mplus` return (TextString "") - u <- pLeaf "updated" es - return Feed - { feedId = i - , feedTitle = t - , feedSubtitle = pTextContent "subtitle" es - , feedUpdated = u - , feedAuthors = pMany "author" pPerson es - , feedContributors = pMany "contributor" pPerson es - , feedCategories = pMany "category" pCategory es - , feedGenerator = pGenerator `fmap` pNode "generator" es - , feedIcon = pLeaf "icon" es - , feedLogo = pLeaf "logo" es - , feedRights = pTextContent "rights" es - , feedLinks = pMany "link" pLink es - , feedEntries = pMany "entry" pEntry es - , feedOther = other_es es - , feedAttrs = other_as (elAttribs e) - } +elementFeed :: XML.Element -> Maybe Feed +elementFeed e = do + guard (elementName e == atomName "feed") + let es = children e + i <- pLeaf "id" es + t <- pTextContent "title" es `mplus` return (TextString "") + u <- pLeaf "updated" es + return + Feed + { feedId = i + , feedTitle = t + , feedSubtitle = pTextContent "subtitle" es + , feedUpdated = u + , feedAuthors = pMany "author" pPerson es + , feedContributors = pMany "contributor" pPerson es + , feedCategories = pMany "category" pCategory es + , feedGenerator = pGenerator `fmap` pNode "generator" es + , feedIcon = pLeaf "icon" es + , feedLogo = pLeaf "logo" es + , feedRights = pTextContent "rights" es + , feedLinks = pMany "link" pLink es + , feedEntries = pMany "entry" pEntry es + , feedOther = other_es es + , feedAttrs = other_as (elementAttributes e) + } where - other_es es = filter (\ el -> not (elName el `elem` known_elts)) - es - - other_as as = filter (\ a -> not (attrKey a `elem` known_attrs)) - as - + other_es = filter ((`notElem` known_elts) . elementName) + other_as = filter ((`notElem` known_attrs) . fst) -- let's have them all (including xml:base and xml:lang + xmlns: stuff) - known_attrs = [] - known_elts = map atomName - [ "author" - , "category" - , "contributor" - , "generator" - , "icon" - , "id" - , "link" - , "logo" - , "rights" - , "subtitle" - , "title" - , "updated" - , "entry" - ] + known_attrs = [] + known_elts = + map + atomName + [ "author" + , "category" + , "contributor" + , "generator" + , "icon" + , "id" + , "link" + , "logo" + , "rights" + , "subtitle" + , "title" + , "updated" + , "entry" + ] -pTextContent :: String -> [XML.Element] -> Maybe TextContent -pTextContent tag es = - do e <- pNode tag es - case pAttr "type" e of - Nothing -> return (TextString (strContent e)) - Just "text" -> return (TextString (strContent e)) - Just "html" -> return (HTMLString (strContent e)) - Just "xhtml" -> case children e of -- hmm... - [c] -> return (XHTMLString c) - _ -> Nothing -- Multiple XHTML children. - _ -> Nothing -- Unknown text content type. +pTextContent :: Text -> [XML.Element] -> Maybe TextContent +pTextContent tag es = do + e <- pNode tag es + case pAttr "type" e of + Nothing -> return (TextString (elementTexts e)) + Just "text" -> return (TextString (elementTexts e)) + Just "html" -> return (HTMLString (elementTexts e)) + Just "xhtml" -> + case children e -- hmm... + of + [c] -> return (XHTMLString c) + _ -> Nothing -- Multiple XHTML children. + _ -> Nothing -- Unknown text content type. pPerson :: XML.Element -> Maybe Person -pPerson e = - do let es = children e - name <- pLeaf "name" es -- or missing "name" - return Person - { personName = name - , personURI = pLeaf "uri" es - , personEmail = pLeaf "email" es - , personOther = [] -- XXX? - } +pPerson e = do + let es = children e + name <- pLeaf "name" es -- or missing "name" + return + Person + { personName = name + , personURI = pLeaf "uri" es + , personEmail = pLeaf "email" es + , personOther = [] -- XXX? + } pCategory :: XML.Element -> Maybe Category -pCategory e = - do term <- pAttr "term" e -- or missing "term" attribute - return Category - { catTerm = term - , catScheme = pAttr "scheme" e - , catLabel = pAttr "label" e - , catOther = [] -- XXX? - } +pCategory e = do + term <- pAttr "term" e -- or missing "term" attribute + return + Category + { catTerm = term + , catScheme = pAttr "scheme" e + , catLabel = pAttr "label" e + , catOther = [] -- XXX? + } pGenerator :: XML.Element -> Generator -pGenerator e = Generator - { genURI = pAttr "href" e - , genVersion = pAttr "version" e - , genText = strContent e - } +pGenerator e = + Generator {genURI = pAttr "href" e, genVersion = pAttr "version" e, genText = elementTexts e} pSource :: XML.Element -> Source pSource e = let es = children e - in Source - { sourceAuthors = pMany "author" pPerson es - , sourceCategories = pMany "category" pCategory es - , sourceGenerator = pGenerator `fmap` pNode "generator" es - , sourceIcon = pLeaf "icon" es - , sourceId = pLeaf "id" es - , sourceLinks = pMany "link" pLink es - , sourceLogo = pLeaf "logo" es - , sourceRights = pTextContent "rights" es - , sourceSubtitle = pTextContent "subtitle" es - , sourceTitle = pTextContent "title" es - , sourceUpdated = pLeaf "updated" es - , sourceOther = [] -- XXX ? - } + in Source + { sourceAuthors = pMany "author" pPerson es + , sourceCategories = pMany "category" pCategory es + , sourceGenerator = pGenerator `fmap` pNode "generator" es + , sourceIcon = pLeaf "icon" es + , sourceId = pLeaf "id" es + , sourceLinks = pMany "link" pLink es + , sourceLogo = pLeaf "logo" es + , sourceRights = pTextContent "rights" es + , sourceSubtitle = pTextContent "subtitle" es + , sourceTitle = pTextContent "title" es + , sourceUpdated = pLeaf "updated" es + , sourceOther = [] -- XXX ? + } pLink :: XML.Element -> Maybe Link -pLink e = - do uri <- pAttr "href" e - return Link - { linkHref = uri - , linkRel = Right `fmap` pAttr "rel" e - , linkType = pAttr "type" e - , linkHrefLang = pAttr "hreflang" e - , linkTitle = pAttr "title" e - , linkLength = pAttr "length" e - , linkAttrs = other_as (elAttribs e) - , linkOther = [] - } - where - other_as as = filter (\ a -> not (attrKey a `elem` known_attrs)) - as - - known_attrs = map atomName - [ "href", "rel", "type", "hreflang", "title", "length"] - +pLink e = do + uri <- pAttr "href" e + return + Link + { linkHref = uri + , linkRel = Right `fmap` pAttr "rel" e + , linkType = pAttr "type" e + , linkHrefLang = pAttr "hreflang" e + , linkTitle = pAttr "title" e + , linkLength = pAttr "length" e + , linkAttrs = other_as (elementAttributes e) + , linkOther = [] + } + where + other_as = filter ((`notElem` known_attrs) . fst) + known_attrs = map atomName ["href", "rel", "type", "hreflang", "title", "length"] pEntry :: XML.Element -> Maybe Entry -pEntry e = - do let es = children e - i <- pLeaf "id" es - t <- pTextContent "title" es - u <- pLeaf "updated" es `mplus` pLeaf "published" es - return Entry - { entryId = i - , entryTitle = t - , entryUpdated = u - , entryAuthors = pMany "author" pPerson es - , entryContributor = pMany "contributor" pPerson es - , entryCategories = pMany "category" pCategory es - , entryContent = pContent =<< pNode "content" es - , entryLinks = pMany "link" pLink es - , entryPublished = pLeaf "published" es - , entryRights = pTextContent "rights" es - , entrySource = pSource `fmap` pNode "source" es - , entrySummary = pTextContent "summary" es - , entryInReplyTo = pInReplyTo es - , entryInReplyTotal = pInReplyTotal es - , entryAttrs = other_as (elAttribs e) - , entryOther = [] -- ? - } - where - other_as as = filter (\ a -> not (attrKey a `elem` known_attrs)) - as - +pEntry e = do + let es = children e + i <- pLeaf "id" es + t <- pTextContent "title" es + u <- pLeaf "updated" es `mplus` pLeaf "published" es + return + Entry + { entryId = i + , entryTitle = t + , entryUpdated = u + , entryAuthors = pMany "author" pPerson es + , entryContributor = pMany "contributor" pPerson es + , entryCategories = pMany "category" pCategory es + , entryContent = pContent =<< pNode "content" es + , entryLinks = pMany "link" pLink es + , entryPublished = pLeaf "published" es + , entryRights = pTextContent "rights" es + , entrySource = pSource `fmap` pNode "source" es + , entrySummary = pTextContent "summary" es + , entryInReplyTo = pInReplyTo es + , entryInReplyTotal = pInReplyTotal es + , entryAttrs = other_as (elementAttributes e) + , entryOther = [] -- ? + } + where + other_as = filter ((`notElem` known_attrs) . fst) -- let's have them all (including xml:base and xml:lang + xmlns: stuff) - known_attrs = [] + known_attrs = [] pContent :: XML.Element -> Maybe EntryContent pContent e = case pAttr "type" e of - Nothing -> return (TextContent (strContent e)) - Just "text" -> return (TextContent (strContent e)) - Just "html" -> return (HTMLContent (strContent e)) + Nothing -> return (TextContent (elementTexts e)) + Just "text" -> return (TextContent (elementTexts e)) + Just "html" -> return (HTMLContent (elementTexts e)) Just "xhtml" -> case children e of - [] -> return (TextContent "") + [] -> return (TextContent "") [c] -> return (XHTMLContent c) - _ -> Nothing - Just ty -> + _ -> Nothing + Just ty -> case pAttr "src" e of - Nothing -> return (MixedContent (Just ty) (elContent e)) + Nothing -> return (MixedContent (Just ty) (elementNodes e)) Just uri -> return (ExternalContent (Just ty) uri) pInReplyTotal :: [XML.Element] -> Maybe InReplyTotal pInReplyTotal es = do - t <- pQLeaf (atomThreadName "total") es - case reads t of - ((x,_):_) -> do - n <- pQNode (atomThreadName "total") es - return InReplyTotal - { replyToTotal = x - , replyToTotalOther = elAttribs n - } - _ -> fail "no parse" + t <- pQLeaf (atomThreadName "total") es + case decimal t of + Right (x, _) -> do + n <- pQNode (atomThreadName "total") es + return InReplyTotal {replyToTotal = x, replyToTotalOther = elementAttributes n} + _ -> fail "no parse" pInReplyTo :: [XML.Element] -> Maybe InReplyTo pInReplyTo es = do - t <- pQNode (atomThreadName "reply-to") es - case pQAttr (atomThreadName "ref") t of - Just ref -> - return InReplyTo - { replyToRef = ref - , replyToHRef = pQAttr (atomThreadName "href") t - , replyToType = pQAttr (atomThreadName "type") t - , replyToSource = pQAttr (atomThreadName "source") t - , replyToOther = elAttribs t -- ToDo: snip out matched ones. - , replyToContent = elContent t - } - _ -> fail "no parse" + t <- pQNode (atomThreadName "reply-to") es + case pQAttr (atomThreadName "ref") t of + Just ref -> + return + InReplyTo + { replyToRef = ref + , replyToHRef = pQAttr (atomThreadName "href") t + , replyToType = pQAttr (atomThreadName "type") t + , replyToSource = pQAttr (atomThreadName "source") t + , replyToOther = elementAttributes t -- ToDo: snip out matched ones. + , replyToContent = elementNodes t + } + _ -> fail "no parse" diff --git a/src/Text/Atom/Feed/Link.hs b/src/Text/Atom/Feed/Link.hs --- a/src/Text/Atom/Feed/Link.hs +++ b/src/Text/Atom/Feed/Link.hs @@ -10,13 +10,14 @@ -- Portability: portable -- -------------------------------------------------------------------- - module Text.Atom.Feed.Link ( LinkRelation(..) , showLinkRelation , showLinkAttr ) where +import Prelude.Compat + -- | Atom feeds uses typed IRI links to represent -- information \/ metadata that is of interest to the -- consumers (software, in the main) of feeds. For instance, @@ -30,51 +31,51 @@ -- http:\/\/www.iana.org\/assignments\/link-relations.html -- on 2007-10-28] -- -data LinkRelation -- relevant RFC: - = LinkAlternate -- http://www.rfc-editor.org/rfc/rfc4287.txt - | LinkCurrent -- http://www.rfc-editor.org/rfc/rfc5005.txt - | LinkEnclosure -- http://www.rfc-editor.org/rfc/rfc4287.txt - | LinkEdit -- http://www.rfc-editor.org/rfc/rfc5023.txt - | LinkEditMedia -- http://www.rfc-editor.org/rfc/rfc5023.txt - | LinkFirst -- http://www.iana.org/assignments/link-relations/first - | LinkLast -- http://www.iana.org/assignments/link-relations/last - | LinkLicense -- http://www.rfc-editor.org/rfc/rfc4946.txt - | LinkNext -- http://www.rfc-editor.org/rfc/rfc5005.txt - | LinkNextArchive -- http://www.rfc-editor.org/rfc/rfc5005.txt - | LinkPayment -- http://www.iana.org/assignments/link-relations/payment - | LinkPrevArchive -- http://www.rfc-editor.org/rfc/rfc5005.txt - | LinkPrevious -- http://www.rfc-editor.org/rfc/rfc5005.txt - | LinkRelated -- http://www.rfc-editor.org/rfc/rfc4287.txt - | LinkReplies -- http://www.rfc-editor.org/rfc/rfc4685.txt - | LinkSelf -- http://www.rfc-editor.org/rfc/rfc4287.txt - | LinkVia -- http://www.rfc-editor.org/rfc/rfc4287.txt - | LinkOther String - deriving (Eq, Show) +data LinkRelation -- relevant RFC: + = LinkAlternate -- http://www.rfc-editor.org/rfc/rfc4287.txt + | LinkCurrent -- http://www.rfc-editor.org/rfc/rfc5005.txt + | LinkEnclosure -- http://www.rfc-editor.org/rfc/rfc4287.txt + | LinkEdit -- http://www.rfc-editor.org/rfc/rfc5023.txt + | LinkEditMedia -- http://www.rfc-editor.org/rfc/rfc5023.txt + | LinkFirst -- http://www.iana.org/assignments/link-relations/first + | LinkLast -- http://www.iana.org/assignments/link-relations/last + | LinkLicense -- http://www.rfc-editor.org/rfc/rfc4946.txt + | LinkNext -- http://www.rfc-editor.org/rfc/rfc5005.txt + | LinkNextArchive -- http://www.rfc-editor.org/rfc/rfc5005.txt + | LinkPayment -- http://www.iana.org/assignments/link-relations/payment + | LinkPrevArchive -- http://www.rfc-editor.org/rfc/rfc5005.txt + | LinkPrevious -- http://www.rfc-editor.org/rfc/rfc5005.txt + | LinkRelated -- http://www.rfc-editor.org/rfc/rfc4287.txt + | LinkReplies -- http://www.rfc-editor.org/rfc/rfc4685.txt + | LinkSelf -- http://www.rfc-editor.org/rfc/rfc4287.txt + | LinkVia -- http://www.rfc-editor.org/rfc/rfc4287.txt + | LinkOther String + deriving (Eq, Show) showLinkRelation :: LinkRelation -> String showLinkRelation lr = case lr of - LinkAlternate -> "alternate" - LinkCurrent -> "current" - LinkEnclosure -> "enclosure" - LinkEdit -> "edit" - LinkEditMedia -> "edit-media" - LinkFirst -> "first" - LinkLast -> "last" - LinkLicense -> "license" - LinkNext -> "next" - LinkNextArchive -> "next-archive" - LinkPayment -> "payment" - LinkPrevArchive -> "prev-archive" - LinkPrevious -> "previous" - LinkRelated -> "related" - LinkReplies -> "replies" - LinkSelf -> "self" - LinkVia -> "via" - LinkOther s -> s + LinkAlternate -> "alternate" + LinkCurrent -> "current" + LinkEnclosure -> "enclosure" + LinkEdit -> "edit" + LinkEditMedia -> "edit-media" + LinkFirst -> "first" + LinkLast -> "last" + LinkLicense -> "license" + LinkNext -> "next" + LinkNextArchive -> "next-archive" + LinkPayment -> "payment" + LinkPrevArchive -> "prev-archive" + LinkPrevious -> "previous" + LinkRelated -> "related" + LinkReplies -> "replies" + LinkSelf -> "self" + LinkVia -> "via" + LinkOther s -> s -showLinkAttr :: LinkRelation -> String{-URI-} -> String -showLinkAttr lr s = showLinkRelation lr ++ '=':'"':concatMap escQ s ++ "\"" - where - escQ '"' = "&dquot;" - escQ x = [x] +showLinkAttr :: LinkRelation -> String -> String {-URI-} +showLinkAttr lr s = showLinkRelation lr ++ '=' : '"' : concatMap escQ s ++ "\"" + where + escQ '"' = "&dquot;" + escQ x = [x] diff --git a/src/Text/Atom/Feed/Validate.hs b/src/Text/Atom/Feed/Validate.hs --- a/src/Text/Atom/Feed/Validate.hs +++ b/src/Text/Atom/Feed/Validate.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TupleSections #-} + -------------------------------------------------------------------- -- | -- Module : Text.Atom.Feed.Validate @@ -11,7 +13,7 @@ -- -------------------------------------------------------------------- module Text.Atom.Feed.Validate - ( VTree (..) + ( VTree(..) , ValidatorResult , advice , demand @@ -42,29 +44,32 @@ , checkUri ) where +import Prelude.Compat + +import Data.XML.Types import Text.Atom.Feed.Import -import Text.XML.Light.Types -import Text.XML.Light.Proc -import Data.List +import Data.List.Compat import Data.Maybe -data VTree a = VNode [a] [VTree a] | VLeaf [a] - deriving (Eq, Show) +data VTree a + = VNode [a] [VTree a] + | VLeaf [a] + deriving (Eq, Show) -type ValidatorResult = VTree (Bool,String) +type ValidatorResult = VTree (Bool, String) advice :: String -> ValidatorResult -advice s = VLeaf [(False,s)] +advice s = VLeaf [(False, s)] demand :: String -> ValidatorResult -demand s = VLeaf [(True,s)] +demand s = VLeaf [(True, s)] valid :: ValidatorResult valid = VLeaf [] -mkTree :: [(Bool,String)] -> [ValidatorResult] -> ValidatorResult -mkTree as bs = VNode as bs +mkTree :: [(Bool, String)] -> [ValidatorResult] -> ValidatorResult +mkTree = VNode flattenT :: VTree a -> [a] flattenT (VLeaf xs) = xs @@ -72,169 +77,204 @@ validateEntry :: Element -> ValidatorResult validateEntry e = - mkTree [] - [ checkEntryAuthor e - , checkCats e - , checkContents e - , checkContributor e - , checkId e - , checkContentLink e - , checkLinks e - , checkPublished e - , checkRights e - , checkSource e - , checkSummary e - , checkTitle e - , checkUpdated e - ] + mkTree + [] + [ checkEntryAuthor e + , checkCats e + , checkContents e + , checkContributor e + , checkId e + , checkContentLink e + , checkLinks e + , checkPublished e + , checkRights e + , checkSource e + , checkSummary e + , checkTitle e + , checkUpdated e + ] -- Sec 4.1.2, check #1 checkEntryAuthor :: Element -> ValidatorResult checkEntryAuthor e = - case pNodes "author" (elChildren e) of - [] -> -- required - case pNode "summary" (elChildren e) of + case pNodes "author" (elementChildren e) of + [] -- required + -> + case pNode "summary" (elementChildren e) of Nothing -> demand "Required 'author' element missing (no 'summary' either)" Just e1 -> - case pNode "author" (elChildren e1) of + case pNode "author" (elementChildren e1) of Just a -> checkAuthor a _ -> demand "Required 'author' element missing" xs -> mkTree [] $ map checkAuthor xs - -- Sec 4.1.2, check #2 checkCats :: Element -> ValidatorResult -checkCats e = mkTree [] $ map checkCat (pNodes "category" (elChildren e)) +checkCats e = mkTree [] $ map checkCat (pNodes "category" (elementChildren e)) checkContents :: Element -> ValidatorResult checkContents e = - case pNodes "content" (elChildren e) of - [] -> valid - [c] -> mkTree [] $ [checkContent c] - cs -> mkTree (flattenT (demand ("at most one 'content' element expected inside 'entry', found: " ++ show (length cs)))) - (map checkContent cs) - + case pNodes "content" (elementChildren e) of + [] -> valid + [c] -> mkTree [] [checkContent c] + cs -> + mkTree + (flattenT + (demand + ("at most one 'content' element expected inside 'entry', found: " ++ show (length cs)))) + (map checkContent cs) checkContributor :: Element -> ValidatorResult checkContributor _e = valid checkContentLink :: Element -> ValidatorResult checkContentLink e = - case pNodes "content" (elChildren e) of + case pNodes "content" (elementChildren e) of [] -> - case pNodes "link" (elChildren e) of - [] -> demand ("An 'entry' element with no 'content' element must have at least one 'link-rel' element") + case pNodes "link" (elementChildren e) of + [] -> + demand + "An 'entry' element with no 'content' element must have at least one 'link-rel' element" xs -> - case filter (=="alternate") $ mapMaybe (pAttr "rel") xs of - [] -> demand ("An 'entry' element with no 'content' element must have at least one 'link-rel' element") - _ -> valid + case filter (== "alternate") $ mapMaybe (pAttr "rel") xs of + [] -> + demand + "An 'entry' element with no 'content' element must have at least one 'link-rel' element" + _ -> valid _ -> valid checkLinks :: Element -> ValidatorResult checkLinks e = - case pNodes "link" (elChildren e) of + case pNodes "link" (elementChildren e) of xs -> - case map fst $ filter (\ (_,n) -> n =="alternate") $ - mapMaybe (\ ex -> fmap (\x -> (ex,x)) $ pAttr "rel" ex) xs of - xs1 -> - let - jmb (Just x) (Just y) = Just (x,y) - jmb _ _ = Nothing - in - case mapMaybe (\ ex -> pAttr "type" ex `jmb` pAttr "hreflang" ex) xs1 of - xs2 -> - case any (\ x -> length x > 1) (group xs2) of - True -> demand ("An 'entry' element cannot have duplicate 'link-rel-alternate-type-hreflang' elements") - _ -> valid + case map fst $ + filter (\(_, n) -> n == "alternate") $ mapMaybe (\ex -> (ex, ) <$> pAttr "rel" ex) xs of + xs1 -> + let jmb (Just x) (Just y) = Just (x, y) + jmb _ _ = Nothing + in case mapMaybe (\ex -> pAttr "type" ex `jmb` pAttr "hreflang" ex) xs1 of + xs2 -> + if any (\x -> length x > 1) (group xs2) + then demand + "An 'entry' element cannot have duplicate 'link-rel-alternate-type-hreflang' elements" + else valid checkId :: Element -> ValidatorResult checkId e = - case pNodes "id" (elChildren e) of - [] -> demand "required field 'id' missing from 'entry' element" + case pNodes "id" (elementChildren e) of + [] -> demand "required field 'id' missing from 'entry' element" [_] -> valid - xs -> demand ("only one 'id' field expected in 'entry' element, found: " ++ show (length xs)) + xs -> demand ("only one 'id' field expected in 'entry' element, found: " ++ show (length xs)) checkPublished :: Element -> ValidatorResult checkPublished e = - case pNodes "published" (elChildren e) of - [] -> valid + case pNodes "published" (elementChildren e) of + [] -> valid [_] -> valid - xs -> demand ("expected at most one 'published' field in 'entry' element, found: " ++ show (length xs)) + xs -> + demand + ("expected at most one 'published' field in 'entry' element, found: " ++ show (length xs)) checkRights :: Element -> ValidatorResult checkRights e = - case pNodes "rights" (elChildren e) of - [] -> valid + case pNodes "rights" (elementChildren e) of + [] -> valid [_] -> valid - xs -> demand ("expected at most one 'rights' field in 'entry' element, found: " ++ show (length xs)) + xs -> + demand ("expected at most one 'rights' field in 'entry' element, found: " ++ show (length xs)) checkSource :: Element -> ValidatorResult checkSource e = - case pNodes "source" (elChildren e) of - [] -> valid + case pNodes "source" (elementChildren e) of + [] -> valid [_] -> valid - xs -> demand ("expected at most one 'source' field in 'entry' element, found: " ++ show (length xs)) + xs -> + demand ("expected at most one 'source' field in 'entry' element, found: " ++ show (length xs)) checkSummary :: Element -> ValidatorResult checkSummary e = - case pNodes "summary" (elChildren e) of - [] -> valid + case pNodes "summary" (elementChildren e) of + [] -> valid [_] -> valid - xs -> demand ("expected at most one 'summary' field in 'entry' element, found: " ++ show (length xs)) + xs -> + demand + ("expected at most one 'summary' field in 'entry' element, found: " ++ show (length xs)) checkTitle :: Element -> ValidatorResult checkTitle e = - case pNodes "title" (elChildren e) of - [] -> demand "required field 'title' missing from 'entry' element" + case pNodes "title" (elementChildren e) of + [] -> demand "required field 'title' missing from 'entry' element" [_] -> valid - xs -> demand ("only one 'title' field expected in 'entry' element, found: " ++ show (length xs)) + xs -> demand ("only one 'title' field expected in 'entry' element, found: " ++ show (length xs)) checkUpdated :: Element -> ValidatorResult checkUpdated e = - case pNodes "updated" (elChildren e) of - [] -> demand "required field 'updated' missing from 'entry' element" + case pNodes "updated" (elementChildren e) of + [] -> demand "required field 'updated' missing from 'entry' element" [_] -> valid - xs -> demand ("only one 'updated' field expected in 'entry' element, found: " ++ show (length xs)) + xs -> + demand ("only one 'updated' field expected in 'entry' element, found: " ++ show (length xs)) checkCat :: Element -> ValidatorResult -checkCat e = mkTree [] - [ checkTerm e - , checkScheme e - , checkLabel e - ] - where - checkScheme e' = - case pAttrs "scheme" e' of - [] -> valid - (_:xs) - | null xs -> valid - | otherwise -> demand ("Expected at most one 'scheme' attribute, found: " ++ show (1+length xs)) - - checkLabel e' = - case pAttrs "label" e' of - [] -> valid - (_:xs) - | null xs -> valid - | otherwise -> demand ("Expected at most one 'label' attribute, found: " ++ show (1+length xs)) +checkCat e = mkTree [] [checkTerm e, checkScheme e, checkLabel e] + where + checkScheme e' = + case pAttrs "scheme" e' of + [] -> valid + (_:xs) + | null xs -> valid + | otherwise -> + demand ("Expected at most one 'scheme' attribute, found: " ++ show (1 + length xs)) + checkLabel e' = + case pAttrs "label" e' of + [] -> valid + (_:xs) + | null xs -> valid + | otherwise -> + demand ("Expected at most one 'label' attribute, found: " ++ show (1 + length xs)) checkContent :: Element -> ValidatorResult -checkContent e = mkTree (flattenT (mkTree [] [type_valid, src_valid])) - [case ty of - "text" -> - case onlyElems (elContent e) of - [] -> valid - _ -> demand ("content with type 'text' cannot have child elements, text only.") - "html" -> - case onlyElems (elContent e) of +checkContent e = + mkTree + (flattenT (mkTree [] [type_valid, src_valid])) + [ case ty of + "text" -> + case elementChildren e of + [] -> valid + _ -> demand "content with type 'text' cannot have child elements, text only." + "html" -> + case elementChildren e of + [] -> valid + _ -> demand "content with type 'html' cannot have child elements, text only." + "xhtml" -> + case elementChildren e of + [] -> valid + [_] -> valid -- ToDo: check that it is a 'div'. + _ds -> demand "content with type 'xhtml' should only contain one 'div' child." + _ -> valid + ] + where + types = pAttrs "type" e + (ty, type_valid) = + case types of + [] -> ("text", valid) + [t] -> checkTypeA t + (t:ts) -> + (t, demand ("Expected at most one 'type' attribute, found: " ++ show (1 + length ts))) + src_valid = + case pAttrs "src" e of [] -> valid - _ -> demand ("content with type 'html' cannot have child elements, text only.") + [_] -> + case types of + [] -> advice "It is advisable to provide a 'type' along with a 'src' attribute" + (_:_) -> valid + ss -> demand ("Expected at most one 'src' attribute, found: " ++ show (length ss)) + checkTypeA v + | v `elem` std_types = (v, valid) + | otherwise = (v, valid) + where + std_types = ["text", "xhtml", "html"] - "xhtml" -> - case onlyElems (elContent e) of - [] -> valid - [_] -> valid -- ToDo: check that it is a 'div'. - _ds -> demand ("content with type 'xhtml' should only contain one 'div' child.") - _ -> valid] {- case parseMIMEType ty of Nothing -> valid @@ -245,32 +285,11 @@ [] -> valid -- check _ -> demand ("content with MIME type '" ++ ty ++ "' must only contain base64 data")] -} - where - types = pAttrs "type" e - (ty, type_valid) = - case types of - [] -> ("text", valid) - [t] -> checkTypeA t - (t:ts) -> (t, demand ("Expected at most one 'type' attribute, found: " ++ show (1+length ts))) - - src_valid = - case pAttrs "src" e of - [] -> valid - [_] -> - case types of - [] -> advice "It is advisable to provide a 'type' along with a 'src' attribute" - (_:_) -> valid {- case parseMIMEType t of Just{} -> valid _ -> demand "The 'type' attribute must be a valid MIME type" -} - ss -> demand ("Expected at most one 'src' attribute, found: " ++ show (length ss)) - - - checkTypeA v - | v `elem` std_types = (v, valid) - | otherwise = (v,valid) {- case parseMIMEType v of Nothing -> ("text", demand ("Invalid/unknown type value " ++ v)) @@ -279,45 +298,41 @@ Multipart{} -> ("text", demand "Multipart MIME types not a legal 'type'") _ -> (v, valid) -} - where - std_types = [ "text", "xhtml", "html"] - checkTerm :: Element -> ValidatorResult checkTerm e = - case pNodes "term" (elChildren e) of - [] -> demand "required field 'term' missing from 'category' element" + case pNodes "term" (elementChildren e) of + [] -> demand "required field 'term' missing from 'category' element" [_] -> valid - xs -> demand ("only one 'term' field expected in 'category' element, found: " ++ show (length xs)) + xs -> + demand ("only one 'term' field expected in 'category' element, found: " ++ show (length xs)) checkAuthor :: Element -> ValidatorResult -checkAuthor e = checkPerson e +checkAuthor = checkPerson checkPerson :: Element -> ValidatorResult -checkPerson e = - mkTree (flattenT $ checkName e) - [ checkEmail e - , checkUri e - ] +checkPerson e = mkTree (flattenT $ checkName e) [checkEmail e, checkUri e] checkName :: Element -> ValidatorResult checkName e = - case pNodes "name" (elChildren e) of - [] -> demand "required field 'name' missing from 'author' element" + case pNodes "name" (elementChildren e) of + [] -> demand "required field 'name' missing from 'author' element" [_] -> valid - xs -> demand ("only one 'name' expected in 'author' element, found: " ++ show (length xs)) + xs -> demand ("only one 'name' expected in 'author' element, found: " ++ show (length xs)) checkEmail :: Element -> ValidatorResult checkEmail e = - case pNodes "email" (elChildren e) of + case pNodes "email" (elementChildren e) of [] -> valid (_:xs) - | null xs -> valid - | otherwise -> demand ("at most one 'email' expected in 'author' element, found: " ++ show (1+length xs)) + | null xs -> valid + | otherwise -> + demand ("at most one 'email' expected in 'author' element, found: " ++ show (1 + length xs)) checkUri :: Element -> ValidatorResult checkUri e = - case pNodes "email" (elChildren e) of + case pNodes "email" (elementChildren e) of [] -> valid (_:xs) - | null xs -> valid - | otherwise -> demand ("at most one 'uri' expected in 'author' element, found: " ++ show (1+length xs)) + | null xs -> valid + | otherwise -> + demand ("at most one 'uri' expected in 'author' element, found: " ++ show (1 + length xs)) diff --git a/src/Text/Atom/Pub.hs b/src/Text/Atom/Pub.hs --- a/src/Text/Atom/Pub.hs +++ b/src/Text/Atom/Pub.hs @@ -13,41 +13,47 @@ -- -------------------------------------------------------------------- module Text.Atom.Pub - ( Service (..) - , Workspace (..) - , Collection (..) - , Categories (..) - , Accept (..) + ( Service(..) + , Workspace(..) + , Collection(..) + , Categories(..) + , Accept(..) ) where -import Text.XML.Light.Types as XML -import Text.Atom.Feed ( TextContent, Category, URI ) +import Prelude.Compat -data Service - = Service +import Data.Text (Text) +import Data.XML.Types as XML +import Text.Atom.Feed (Category, TextContent, URI) + +data Service = + Service { serviceWorkspaces :: [Workspace] - , serviceOther :: [XML.Element] + , serviceOther :: [XML.Element] } -data Workspace - = Workspace - { workspaceTitle :: TextContent - , workspaceCols :: [Collection] - , workspaceOther :: [XML.Element] +data Workspace = + Workspace + { workspaceTitle :: TextContent + , workspaceCols :: [Collection] + , workspaceOther :: [XML.Element] } -data Collection - = Collection - { collectionURI :: URI - , collectionTitle :: TextContent +data Collection = + Collection + { collectionURI :: URI + , collectionTitle :: TextContent , collectionAccept :: [Accept] - , collectionCats :: [Categories] - , collectionOther :: [XML.Element] + , collectionCats :: [Categories] + , collectionOther :: [XML.Element] } data Categories - = CategoriesExternal URI - | Categories (Maybe Bool) (Maybe URI) [Category] - deriving (Show) + = CategoriesExternal URI + | Categories (Maybe Bool) (Maybe URI) [Category] + deriving (Show) -newtype Accept = Accept { acceptType :: String } +newtype Accept = + Accept + { acceptType :: Text + } diff --git a/src/Text/Atom/Pub/Export.hs b/src/Text/Atom/Pub/Export.hs --- a/src/Text/Atom/Pub/Export.hs +++ b/src/Text/Atom/Pub/Export.hs @@ -14,8 +14,7 @@ -- -------------------------------------------------------------------- module Text.Atom.Pub.Export - ( showServiceDoc - , mkQName + ( mkQName , mkElem , mkLeaf , mkAttr @@ -28,74 +27,74 @@ , xmlAccept ) where -import Text.XML.Light -import Text.Atom.Pub -import Text.Atom.Feed.Export - ( mb, xmlCategory, xmlTitle - , xmlns_atom - ) +import Prelude.Compat -showServiceDoc :: Service -> String -showServiceDoc s = showElement (xmlService s) +import Data.Text (Text) +import Data.XML.Compat +import Data.XML.Types +import Text.Atom.Feed.Export (mb, xmlCategory, xmlTitle, xmlns_atom) +import Text.Atom.Pub -- ToDo: old crud; inline away. -mkQName :: Maybe String -> String -> QName -mkQName a b = blank_name{qPrefix=a,qName=b} - -mkElem :: QName -> [Attr] -> [Element] -> Element -mkElem a b c = node a ((b::[Attr]),(c::[Element])) +mkQName :: Maybe Text -> Text -> Name +mkQName a b = Name b a Nothing -mkLeaf :: QName -> [Attr] -> String -> Element -mkLeaf a b c = node (a::QName) ((b::[Attr]),[Text blank_cdata{cdData=c}]) +mkElem :: Name -> [Attr] -> [Element] -> Element +mkElem a b c = Element a b $ map NodeElement c -mkAttr :: String -> String -> Attr -mkAttr a b = Attr blank_name{qName=a} b +mkLeaf :: Name -> [Attr] -> Text -> Element +mkLeaf a b c = Element a b [NodeContent $ ContentText c] xmlns_app :: Attr -xmlns_app = Attr (mkQName (Just "xmlns") "app") appNS - +xmlns_app = (mkQName (Just "xmlns") "app", [ContentText appNS]) -appNS :: String +appNS :: Text appNS = "http://purl.org/atom/app#" -appName :: String -> QName -appName nc = (mkQName (Just "app") nc){qURI=Just appNS} +appName :: Text -> Name +appName nc = (mkQName (Just "app") nc) {nameNamespace = Just appNS} xmlService :: Service -> Element xmlService s = - mkElem (appName "service") [xmlns_app,xmlns_atom] - (concat [ map xmlWorkspace (serviceWorkspaces s) - , serviceOther s - ]) + mkElem + (appName "service") + [xmlns_app, xmlns_atom] + (map xmlWorkspace (serviceWorkspaces s) ++ serviceOther s) xmlWorkspace :: Workspace -> Element xmlWorkspace w = - mkElem (appName "workspace") - [mkAttr "xml:lang" "en"] - (concat [ [xmlTitle (workspaceTitle w)] - , map xmlCollection (workspaceCols w) - , workspaceOther w - ]) + mkElem + (appName "workspace") + [mkAttr "xml:lang" "en"] + (concat [[xmlTitle (workspaceTitle w)], map xmlCollection (workspaceCols w), workspaceOther w]) xmlCollection :: Collection -> Element xmlCollection c = - mkElem (appName "collection") - [mkAttr "href" (collectionURI c)] - (concat [ [xmlTitle (collectionTitle c)] - , map xmlAccept (collectionAccept c) - , map xmlCategories (collectionCats c) - , collectionOther c - ]) + mkElem + (appName "collection") + [mkAttr "href" (collectionURI c)] + (concat + [ [xmlTitle (collectionTitle c)] + , map xmlAccept (collectionAccept c) + , map xmlCategories (collectionCats c) + , collectionOther c + ]) xmlCategories :: Categories -> Element -xmlCategories (CategoriesExternal u) = - mkElem (appName "categories") [mkAttr "href" u] [] +xmlCategories (CategoriesExternal u) = mkElem (appName "categories") [mkAttr "href" u] [] xmlCategories (Categories mbFixed mbScheme cs) = - mkElem (appName "categories") - (concat [ mb (\ f -> mkAttr "fixed" (if f then "yes" else "no")) mbFixed - , mb (mkAttr "scheme") mbScheme - ]) - (map xmlCategory cs) + mkElem + (appName "categories") + (mb + (\f -> + mkAttr + "fixed" + (if f + then "yes" + else "no")) + mbFixed ++ + mb (mkAttr "scheme") mbScheme) + (map xmlCategory cs) xmlAccept :: Accept -> Element xmlAccept a = mkLeaf (appName "accept") [] (acceptType a) diff --git a/src/Text/DublinCore/Types.hs b/src/Text/DublinCore/Types.hs --- a/src/Text/DublinCore/Types.hs +++ b/src/Text/DublinCore/Types.hs @@ -13,75 +13,79 @@ -- see: -- module Text.DublinCore.Types - ( DCItem (..) - , DCInfo (..) + ( DCItem(..) + , DCInfo(..) , infoToTag , dc_element_names ) where +import Prelude.Compat + +import Data.Text + -- | A DCItem pairs a specific element with its (string) value. -data DCItem - = DCItem - { dcElt :: DCInfo - , dcText :: String - } - deriving (Eq, Show) +data DCItem = + DCItem + { dcElt :: DCInfo + , dcText :: Text + } + deriving (Eq, Show) -- | The Dublin Core Metadata Element Set, all 15 of them (plus an extension constructor.) data DCInfo - = DC_Title -- ^ A name given to the resource. - | DC_Creator -- ^ An entity primarily responsible for making the content of the resource. - | DC_Subject -- ^ The topic of the content of the resource. - | DC_Description -- ^ An account of the content of the resource. - | DC_Publisher -- ^ An entity responsible for making the resource available - | DC_Contributor -- ^ An entity responsible for making contributions to the content of the resource. - | DC_Date -- ^ A date associated with an event in the life cycle of the resource (YYYY-MM-DD) - | DC_Type -- ^ The nature or genre of the content of the resource. - | DC_Format -- ^ The physical or digital manifestation of the resource. - | DC_Identifier -- ^ An unambiguous reference to the resource within a given context. - | DC_Source -- ^ A Reference to a resource from which the present resource is derived. - | DC_Language -- ^ A language of the intellectual content of the resource. - | DC_Relation -- ^ A reference to a related resource. - | DC_Coverage -- ^ The extent or scope of the content of the resource. - | DC_Rights -- ^ Information about rights held in and over the resource. - | DC_Other String -- ^ Other; data type extension mechanism. - deriving (Eq, Show) + = DC_Title -- ^ A name given to the resource. + | DC_Creator -- ^ An entity primarily responsible for making the content of the resource. + | DC_Subject -- ^ The topic of the content of the resource. + | DC_Description -- ^ An account of the content of the resource. + | DC_Publisher -- ^ An entity responsible for making the resource available + | DC_Contributor -- ^ An entity responsible for making contributions to the content of the resource. + | DC_Date -- ^ A date associated with an event in the life cycle of the resource (YYYY-MM-DD) + | DC_Type -- ^ The nature or genre of the content of the resource. + | DC_Format -- ^ The physical or digital manifestation of the resource. + | DC_Identifier -- ^ An unambiguous reference to the resource within a given context. + | DC_Source -- ^ A Reference to a resource from which the present resource is derived. + | DC_Language -- ^ A language of the intellectual content of the resource. + | DC_Relation -- ^ A reference to a related resource. + | DC_Coverage -- ^ The extent or scope of the content of the resource. + | DC_Rights -- ^ Information about rights held in and over the resource. + | DC_Other Text -- ^ Other; data type extension mechanism. + deriving (Eq, Show) -infoToTag :: DCInfo -> String +infoToTag :: DCInfo -> Text infoToTag i = case i of - DC_Title -> "title" - DC_Creator -> "creator" - DC_Subject -> "subject" + DC_Title -> "title" + DC_Creator -> "creator" + DC_Subject -> "subject" DC_Description -> "description" - DC_Publisher -> "publisher" + DC_Publisher -> "publisher" DC_Contributor -> "contributor" - DC_Date -> "date" - DC_Type -> "type" - DC_Format -> "format" - DC_Identifier -> "identifier" - DC_Source -> "source" - DC_Language -> "language" - DC_Relation -> "relation" - DC_Coverage -> "coverage" - DC_Rights -> "rights" - DC_Other o -> o + DC_Date -> "date" + DC_Type -> "type" + DC_Format -> "format" + DC_Identifier -> "identifier" + DC_Source -> "source" + DC_Language -> "language" + DC_Relation -> "relation" + DC_Coverage -> "coverage" + DC_Rights -> "rights" + DC_Other o -> o -dc_element_names :: [String] -dc_element_names - = [ "title" - , "creator" - , "subject" - , "description" - , "publisher" - , "contributor" - , "date" - , "type" - , "format" - , "identifier" - , "source" - , "language" - , "relation" - , "coverage" - , "rights" - ] +dc_element_names :: [Text] +dc_element_names = + [ "title" + , "creator" + , "subject" + , "description" + , "publisher" + , "contributor" + , "date" + , "type" + , "format" + , "identifier" + , "source" + , "language" + , "relation" + , "coverage" + , "rights" + ] diff --git a/src/Text/Feed/Constructor.hs b/src/Text/Feed/Constructor.hs --- a/src/Text/Feed/Constructor.hs +++ b/src/Text/Feed/Constructor.hs @@ -1,726 +1,803 @@ --------------------------------------------------------------------- --- | --- Module : Text.Feed.Constructor --- Copyright : (c) Galois, Inc. 2008, --- (c) Sigbjorn Finne 2009- --- License : BSD3 --- --- Maintainer: Sigbjorn Finne --- Stability : provisional --- Description: Module for an abstraction layer between different kinds of feeds. --- --------------------------------------------------------------------- - -module Text.Feed.Constructor - ( FeedKind(..) - , newFeed -- :: FeedKind -> Feed - , feedFromRSS -- :: RSS -> Feed - , feedFromAtom -- :: Atom.Feed -> Feed - , feedFromRDF -- :: RSS1.Feed -> Feed - , feedFromXML -- :: Element -> Feed - , getFeedKind -- :: Feed -> FeedKind - - , FeedSetter -- type _ a = a -> Feed -> Feed - , addItem -- :: FeedSetter Item - - , withFeedTitle -- :: FeedSetter String - , withFeedHome -- :: FeedSetter URLString - , withFeedHTML -- :: FeedSetter URLString - , withFeedDescription -- :: FeedSetter String - , withFeedPubDate -- :: FeedSetter DateString - , withFeedLastUpdate -- :: FeedSetter DateString - , withFeedDate -- :: FeedSetter DateString - , withFeedLogoLink -- :: FeedSetter URLString - , withFeedLanguage -- :: FeedSetter String - , withFeedCategories -- :: FeedSetter [(String,Maybe String)] - , withFeedGenerator -- :: FeedSetter String - , withFeedItems -- :: FeedSetter [Item] - - , newItem -- :: FeedKind -> Item - , getItemKind -- :: Item -> FeedKind - , atomEntryToItem -- :: Atom.Entry -> Item - , rssItemToItem -- :: RSS.Item -> Item - , rdfItemToItem -- :: RSS1.Item -> Item - - , ItemSetter -- type _ a = a -> Item -> Item - , withItemTitle -- :: ItemSetter String - , withItemLink -- :: ItemSetter URLString - , withItemPubDate -- :: ItemSetter DateString - , withItemDate -- :: ItemSetter DateString - , withItemAuthor -- :: ItemSetter String - , withItemCommentLink -- :: ItemSetter String - , withItemEnclosure -- :: String -> Maybe String -> ItemSetter Integer - , withItemFeedLink -- :: String -> ItemSetter String - , withItemId -- :: Bool -> ItemSetter String - , withItemCategories -- :: ItemSetter [(String, Maybe String)] - , withItemDescription -- :: ItemSetter String - , withItemRights -- :: ItemSetter String - ) where - -import Text.Feed.Types as Feed.Types - -import Text.Atom.Feed as Atom -import Text.RSS.Syntax as RSS -import Text.RSS1.Syntax as RSS1 -import Text.DublinCore.Types -import Text.XML.Light as XML hiding ( filterChildren ) - -import Data.Maybe ( fromMaybe, mapMaybe ) -import Data.Char ( toLower ) - --- ToDo: --- --- - complete set of constructors over feeds --- - provide a unified treatment of date string reps. --- (i.e., I know they differ across formats, but ignorant what --- the constraints are at the moment.) - - --- | Construct an empty feed document, intending to output it in --- the 'fk' feed format. -newFeed :: FeedKind -> Feed.Types.Feed -newFeed fk = - case fk of - AtomKind -> AtomFeed (Atom.nullFeed "feed-id-not-filled-in" - (TextString "dummy-title") - "dummy-and-bogus-update-date") - RSSKind mbV -> - let def = (RSS.nullRSS "dummy-title" "default-channel-url") in - RSSFeed $ fromMaybe def $ fmap (\ v -> def{RSS.rssVersion=v}) mbV - RDFKind mbV -> - let def = (RSS1.nullFeed "default-channel-url" "dummy-title") in - RSS1Feed $ fromMaybe def $ fmap (\ v -> def{RSS1.feedVersion=v}) mbV - - -feedFromRSS :: RSS.RSS -> Feed.Types.Feed -feedFromRSS r = RSSFeed r - -feedFromAtom :: Atom.Feed -> Feed.Types.Feed -feedFromAtom f = AtomFeed f - -feedFromRDF :: RSS1.Feed -> Feed.Types.Feed -feedFromRDF f = RSS1Feed f - -feedFromXML :: XML.Element -> Feed.Types.Feed -feedFromXML f = XMLFeed f - -getFeedKind :: Feed.Types.Feed -> FeedKind -getFeedKind f = - case f of - Feed.Types.AtomFeed{} -> AtomKind - Feed.Types.RSSFeed r -> RSSKind (case RSS.rssVersion r of { "2.0" -> Nothing; v -> Just v}) - Feed.Types.RSS1Feed r -> RDFKind (case RSS1.feedVersion r of { "1.0" -> Nothing; v -> Just v}) - Feed.Types.XMLFeed{} -> RSSKind (Just "2.0") -- for now, just a hunch.. - -addItem :: Feed.Types.Item -> Feed.Types.Feed -> Feed.Types.Feed -addItem it f = - case (it,f) of - (Feed.Types.AtomItem e, Feed.Types.AtomFeed fe) -> - Feed.Types.AtomFeed fe{Atom.feedEntries=e:Atom.feedEntries fe} - (Feed.Types.RSSItem e, Feed.Types.RSSFeed r) -> - Feed.Types.RSSFeed r{RSS.rssChannel=(RSS.rssChannel r){RSS.rssItems=e:RSS.rssItems (RSS.rssChannel r)}} - (Feed.Types.RSS1Item e, Feed.Types.RSS1Feed r) -> - -- note: do not update the channel item URIs at this point; - -- will delay doing so until serialization. - Feed.Types.RSS1Feed r{RSS1.feedItems=e:RSS1.feedItems r} - _ -> error "addItem: currently unable to automatically convert items from one feed type to another" - -withFeedItems :: FeedSetter [Feed.Types.Item] -withFeedItems is fe = - foldr addItem - (case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed - f{Atom.feedEntries=[]} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){rssItems=[]}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed - f{feedItems=[]}) - is - -newItem :: FeedKind -> Feed.Types.Item -newItem fk = - case fk of - AtomKind -> Feed.Types.AtomItem $ - Atom.nullEntry "entry-id-not-filled-in" - (TextString "dummy-entry-title") - "dummy-and-bogus-entry-update-date" - RSSKind{} -> Feed.Types.RSSItem $ - RSS.nullItem "dummy-rss-item-title" - RDFKind{} -> Feed.Types.RSS1Item $ - RSS1.nullItem "dummy-item-uri" - "dummy-item-title" - "dummy-item-link" - -getItemKind :: Feed.Types.Item -> FeedKind -getItemKind f = - case f of - Feed.Types.AtomItem{} -> AtomKind - Feed.Types.RSSItem{} -> RSSKind (Just "2.0") -- good guess.. - Feed.Types.RSS1Item{} -> RDFKind (Just "1.0") - Feed.Types.XMLItem{} -> RSSKind (Just "2.0") - -type FeedSetter a = a -> Feed.Types.Feed -> Feed.Types.Feed - -withFeedTitle :: FeedSetter String -withFeedTitle tit fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedTitle=TextString tit} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssTitle=tit}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedChannel=(feedChannel f){channelTitle=tit}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "title") - then Just (unode "title" tit) - else Nothing) e) - else Nothing) f - -withFeedHome :: FeedSetter URLString -withFeedHome url fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedLinks=newSelf:Atom.feedLinks f} - -- ToDo: fix, the element is for the HTML home of the channel, not the - -- location of the feed itself. Struggling to find if there is a common way - -- to represent this outside of RSS 2.0 standard elements.. - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssLink=url}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedChannel=(feedChannel f){channelURI=url}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "link") - then Just (unode "link" url) - else Nothing) e) - else Nothing) f - where - newSelf = (nullLink url){ linkRel=Just (Left "self") - , linkType=Just "application/atom+xml" - } - --- | 'withFeedHTML' sets the URL where an HTML version of the --- feed is published. -withFeedHTML :: FeedSetter URLString -withFeedHTML url fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedLinks=newAlt:Atom.feedLinks f} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssLink=url}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedChannel=(feedChannel f){channelLink=url}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "link") - then Just (unode "link" url) - else Nothing) e) - else Nothing) f - where - newAlt = (nullLink url){ linkRel=Just (Left "alternate") - , linkType=Just "text/html" - } - --- | 'withFeedHTML' sets the URL where an HTML version of the --- feed is published. -withFeedDescription :: FeedSetter String -withFeedDescription desc fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed - f{feedSubtitle=Just (TextString desc)} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){rssDescription=desc}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed - f{feedChannel=(feedChannel f){channelDesc=desc}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "description") - then Just (unode "description" desc) - else Nothing) e) - else Nothing) f - -withFeedPubDate :: FeedSetter String -withFeedPubDate dateStr fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed - f{feedUpdated=dateStr} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){rssPubDate=Just dateStr}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ - case break isDate $ RSS1.channelDC (RSS1.feedChannel f) of - (as,(dci:bs)) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC=as++dci{dcText=dateStr}:bs}} - (_,[]) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC= - DCItem{dcElt=DC_Date,dcText=dateStr}: - RSS1.channelDC (RSS1.feedChannel f)}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "pubDate") - then Just (unode "pubDate" dateStr) - else Nothing) e) - else Nothing) f - where - isDate dc = dcElt dc == DC_Date - -withFeedLastUpdate :: FeedSetter DateString -withFeedLastUpdate dateStr fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed - f{feedUpdated=dateStr} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){rssLastUpdate=Just dateStr}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ - case break isDate $ RSS1.channelDC (RSS1.feedChannel f) of - (as,(dci:bs)) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC=as++dci{dcText=dateStr}:bs}} - (_,[]) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC= - DCItem{dcElt=DC_Date,dcText=dateStr}: - RSS1.channelDC (RSS1.feedChannel f)}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "lastUpdate") - then Just (unode "lastUpdate" dateStr) - else Nothing) e) - else Nothing) f - where - isDate dc = dcElt dc == DC_Date - - --- | 'withFeedDate dt' is the composition of 'withFeedPubDate' --- and 'withFeedLastUpdate', setting both publication date and --- last update date to 'dt'. Notice that RSS2.0 is the only format --- supporting both pub and last-update. -withFeedDate :: FeedSetter DateString -withFeedDate dt f = withFeedPubDate dt(withFeedLastUpdate dt f) - - -withFeedLogoLink :: URLString -> FeedSetter URLString -withFeedLogoLink imgURL lnk fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed - f{ feedLogo = Just imgURL - , feedLinks = newSelf:Atom.feedLinks f - } - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{ rssChannel=(rssChannel f) - {rssImage=Just $ - RSS.nullImage imgURL (rssTitle (rssChannel f)) lnk}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ - f{ feedImage = Just $ - RSS1.nullImage imgURL (RSS1.channelTitle (RSS1.feedChannel f)) lnk - , feedChannel = - (feedChannel f){channelImageURI=Just imgURL} - } - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "image") - then Just (unode "image" [ unode "url" imgURL - , unode "title" title - , unode "link" lnk - ]) - else Nothing) e) - else Nothing) f - where - title = - case fmap (findChild (unqual "title")) - (findChild (unqual "channel") f) of - Just (Just e1) -> strContent e1 - _ -> "feed_title" -- shouldn't happen.. - - where - newSelf = (nullLink lnk){ linkRel=Just (Left "self") - , linkType=Just "application/atom+xml" - } - - -withFeedLanguage :: FeedSetter String -withFeedLanguage lang fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed $ - f{Atom.feedAttrs=(XML.Attr (unqual "lang"){qPrefix=Just "xml"} lang):Atom.feedAttrs f} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){rssLanguage=Just lang}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ - case break isLang $ RSS1.channelDC (RSS1.feedChannel f) of - (as,(dci:bs)) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC=as++dci{dcText=lang}:bs}} - (_,[]) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC= - DCItem{dcElt=DC_Language,dcText=lang}: - RSS1.channelDC (RSS1.feedChannel f)}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "language") - then Just (unode "language" lang) - else Nothing) e) - else Nothing) f - where - isLang dc = dcElt dc == DC_Language - -withFeedCategories :: FeedSetter [(String,Maybe String)] -withFeedCategories cats fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed - f{ Atom.feedCategories = - map ( \ (t,mb) -> (Atom.newCategory t){Atom.catScheme=mb}) - cats ++ feedCategories f} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){ - RSS.rssCategories= - map (\ (t,mb) -> (RSS.newCategory t){RSS.rssCategoryDomain=mb}) - cats ++ RSS.rssCategories (rssChannel f)}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed - f{feedChannel=(feedChannel f){ - RSS1.channelDC= - map (\ (t,_) -> DCItem{dcElt=DC_Subject,dcText=t}) - cats ++ RSS1.channelDC (feedChannel f)}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just ( - foldr - (\ (t,mb) acc -> - addChild (unode "category" - (fromMaybe (\x -> [x]) - (fmap (\v -> (\ x -> [Attr (unqual "domain") v,x])) mb) $ - (Attr (unqual "term") t)) - ) acc) - e - cats) - else Nothing) f - - -withFeedGenerator :: FeedSetter (String,Maybe URLString) -withFeedGenerator (gen,mbURI) fe = - case fe of - Feed.Types.AtomFeed f -> Feed.Types.AtomFeed $ - f{Atom.feedGenerator=Just ((Atom.nullGenerator gen){Atom.genURI=mbURI})} - Feed.Types.RSSFeed f -> Feed.Types.RSSFeed - f{rssChannel=(rssChannel f){rssGenerator=Just gen}} - Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ - case break isSource $ RSS1.channelDC (RSS1.feedChannel f) of - (as,(dci:bs)) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC=as++dci{dcText=gen}:bs}} - (_,[]) -> - f{RSS1.feedChannel= - (RSS1.feedChannel f) - {RSS1.channelDC= - DCItem{dcElt=DC_Source,dcText=gen}: - RSS1.channelDC (RSS1.feedChannel f)}} - Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ - mapMaybeChildren (\ e -> - if (elName e == unqual "channel") - then Just (mapMaybeChildren (\ e2 -> - if (elName e2 == unqual "generator") - then Just (unode "generator" gen) - else Nothing) e) - else Nothing) f - where - isSource dc = dcElt dc == DC_Source - - - --- Item constructors (all the way to the end): - -atomEntryToItem :: Atom.Entry -> Feed.Types.Item -atomEntryToItem e = Feed.Types.AtomItem e - -rssItemToItem :: RSS.RSSItem -> Feed.Types.Item -rssItemToItem i = Feed.Types.RSSItem i - -rdfItemToItem :: RSS1.Item -> Feed.Types.Item -rdfItemToItem i = Feed.Types.RSS1Item i - -type ItemSetter a = a -> Feed.Types.Item -> Feed.Types.Item - --- | 'withItemPubDate dt' associates the creation\/ publication date 'dt' --- with a feed item. -withItemPubDate :: ItemSetter DateString -withItemPubDate dt fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryUpdated=dt} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemPubDate=Just dt} - Feed.Types.RSS1Item i -> - case break isDate $ RSS1.itemDC i of - (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=dt}:bs} - (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Date,dcText=dt}:RSS1.itemDC i} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "pubDate" dt) $ - filterChildren (\ e -> elName e /= unqual "pubDate") - i - where - isDate dc = dcElt dc == DC_Date - --- | 'withItemDate' is a synonym for 'withItemPubDate'. -withItemDate :: ItemSetter DateString -withItemDate dt fi = withItemPubDate dt fi - --- | 'withItemTitle myTitle' associates a new title, 'myTitle', --- with a feed item. -withItemTitle :: ItemSetter String -withItemTitle tit fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryTitle=TextString tit} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemTitle=Just tit} - Feed.Types.RSS1Item i -> - Feed.Types.RSS1Item i{RSS1.itemTitle=tit} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "title" tit) $ - filterChildren (\ e -> elName e /= unqual "title") - i - --- | 'withItemAuthor auStr' associates new author info --- with a feed item. -withItemAuthor :: ItemSetter String -withItemAuthor au fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryAuthors=[nullPerson{personName=au,personURI=Just au}]} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemAuthor=Just au} - Feed.Types.RSS1Item i -> - case break isAuthor $ RSS1.itemDC i of - (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=au}:bs} - (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Creator,dcText=au}:RSS1.itemDC i} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "author" au) $ - filterChildren (\ e -> elName e /= unqual "author") - i - where - isAuthor dc = dcElt dc == DC_Creator - --- | 'withItemFeedLink name myFeed' associates the parent feed URL 'myFeed' --- with a feed item. It is labelled as 'name'. -withItemFeedLink :: String -> ItemSetter String -withItemFeedLink tit url fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entrySource=Just Atom.nullSource{sourceId=Just url,sourceTitle=Just (TextString tit)}} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemSource=Just (RSS.nullSource url tit)} - Feed.Types.RSS1Item i -> - Feed.Types.RSS1Item i{RSS1.itemTitle=tit} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "source" (Attr (unqual "url") url,tit)) $ - filterChildren (\ e -> elName e /= unqual "source") - i - - - --- | 'withItemCommentLink url' sets the URL reference to the comment page to 'url'. -withItemCommentLink :: ItemSetter String -withItemCommentLink url fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryLinks=((nullLink url){linkRel=Just (Left "replies")}):Atom.entryLinks e} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemComments=Just url} - Feed.Types.RSS1Item i -> - case break isRel $ RSS1.itemDC i of - (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=url}:bs} - (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Relation,dcText=url}:RSS1.itemDC i} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "comments" url) $ - filterChildren (\ e -> elName e /= unqual "comments") - i - where - isRel dc = dcElt dc == DC_Relation - --- | 'withItemEnclosure url mbTy len' sets the URL reference to the comment page to 'url'. -withItemEnclosure :: String -> Maybe String -> ItemSetter (Maybe Integer) -withItemEnclosure url ty mb_len fi = - case fi of - Feed.Types.AtomItem e -> Feed.Types.AtomItem - e{Atom.entryLinks=((nullLink url){linkRel=Just (Left "enclosure") - ,linkType=ty - ,linkLength=fmap show mb_len - }):Atom.entryLinks e} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemEnclosure=Just (nullEnclosure url mb_len (fromMaybe "text/html" ty))} - Feed.Types.RSS1Item i -> Feed.Types.RSS1Item - i{RSS1.itemContent=nullContentInfo{ contentURI=Just url - , contentFormat=ty - }:RSS1.itemContent i} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild ((unode "enclosure" url) - {elAttribs= [ Attr (unqual "length") "0" - , Attr (unqual "type") (fromMaybe "text/html" ty) - ]}) $ - filterChildren (\ e -> elName e /= unqual "enclosure") - i - - --- | 'withItemId isURL id' associates new unique identifier with a feed item. --- If 'isURL' is 'True', then the id is assumed to point to a valid web resource. -withItemId :: Bool -> ItemSetter String -withItemId isURL idS fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryId=idS} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemGuid=Just (nullGuid idS){rssGuidPermanentURL=Just isURL}} - Feed.Types.RSS1Item i -> - case break isId $ RSS1.itemDC i of - (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=idS}:bs} - (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Identifier,dcText=idS}:RSS1.itemDC i} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "guid" (Attr (unqual "isPermaLink") (showBool isURL),idS)) $ - filterChildren (\ e -> elName e /= unqual "guid") - i - where - showBool x = map toLower (show x) - isId dc = dcElt dc == DC_Identifier - --- | 'withItemDescription desc' associates a new descriptive string (aka summary) --- with a feed item. -withItemDescription :: ItemSetter String -withItemDescription desc fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entrySummary=Just (TextString desc)} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemDescription=Just desc} - Feed.Types.RSS1Item i -> - Feed.Types.RSS1Item i{RSS1.itemDesc=Just desc} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "description" desc) $ - filterChildren (\ e -> elName e /= unqual "description") - i - --- | 'withItemRights rightStr' associates the rights information 'rightStr' --- with a feed item. -withItemRights :: ItemSetter String -withItemRights desc fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryRights=Just (TextString desc)} - -- Note: per-item copyright information isn't supported by RSS2.0 (and earlier editions), - -- you can only attach this at the feed/channel level. So, there's not much we can do - -- except dropping the information on the floor here. (Rolling our own attribute or - -- extension element is an option, but would prefer if someone else had started that - -- effort already. - Feed.Types.RSSItem{} -> fi - Feed.Types.RSS1Item i -> - case break ((==DC_Rights).dcElt) $ RSS1.itemDC i of - (as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=desc}:bs} - (_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Rights,dcText=desc}:RSS1.itemDC i} - -- Since we're so far assuming that a shallow XML rep. of an item - -- is of RSS2.0 ilk, pinning on the rights info is hard (see above.) - Feed.Types.XMLItem{} -> fi - --- | 'withItemTitle myLink' associates a new URL, 'myLink', --- with a feed item. -withItemLink :: ItemSetter URLString -withItemLink url fi = - case fi of - Feed.Types.AtomItem e -> - Feed.Types.AtomItem e{Atom.entryLinks=replaceAlternate url (Atom.entryLinks e)} - Feed.Types.RSSItem i -> - Feed.Types.RSSItem i{RSS.rssItemLink=Just url} - Feed.Types.RSS1Item i -> - Feed.Types.RSS1Item i{RSS1.itemLink=url} - Feed.Types.XMLItem i -> - Feed.Types.XMLItem $ - addChild (unode "link" url) $ - filterChildren (\ e -> elName e /= unqual "link") - i - where - replaceAlternate _ [] = [] - replaceAlternate x (lr:xs) - | toStr (Atom.linkRel lr) == "alternate" = lr{Atom.linkHref=x} : xs - | otherwise = lr : replaceAlternate x xs - - toStr Nothing = "" - toStr (Just (Left x)) = x - toStr (Just (Right x)) = x - -withItemCategories :: ItemSetter [(String,Maybe String)] -withItemCategories cats fi = - case fi of - Feed.Types.AtomItem e -> Feed.Types.AtomItem - e{ Atom.entryCategories = - map ( \ (t,mb) -> (Atom.newCategory t){Atom.catScheme=mb}) - cats ++ entryCategories e} - Feed.Types.RSSItem i -> Feed.Types.RSSItem - i{RSS.rssItemCategories= - map (\ (t,mb) -> (RSS.newCategory t){RSS.rssCategoryDomain=mb}) - cats ++ rssItemCategories i} - Feed.Types.RSS1Item i -> Feed.Types.RSS1Item - i{RSS1.itemDC= - map (\ (t,_) -> DCItem{dcElt=DC_Subject,dcText=t}) - cats ++ RSS1.itemDC i} - Feed.Types.XMLItem i -> Feed.Types.XMLItem $ - foldr (\ (t,mb) acc -> - addChild (unode "category" - (fromMaybe (\x -> [x]) - (fmap (\v -> (\ x -> [Attr (unqual "domain") v,x])) mb) $ - (Attr (unqual "term") t)) - ) acc) - i - cats - --- helpers.. - -filterChildren :: (XML.Element -> Bool) -> XML.Element -> XML.Element -filterChildren pre e = - case elContent e of - [] -> e - cs -> e { elContent = mapMaybe filterElt cs } - where - filterElt xe@(XML.Elem el) - | pre el = Just xe - | otherwise = Nothing - filterElt xe = Just xe - -addChild :: XML.Element -> XML.Element -> XML.Element -addChild a b = b { elContent = XML.Elem a : elContent b } - -mapMaybeChildren :: (XML.Element -> Maybe XML.Element) - -> XML.Element - -> XML.Element -mapMaybeChildren f e = - case elContent e of - [] -> e - cs -> e { elContent = map procElt cs } - where - procElt xe@(XML.Elem el) = - case f el of - Nothing -> xe - Just el1 -> XML.Elem el1 - procElt xe = xe +{-# OPTIONS -fno-warn-incomplete-patterns #-} + +-------------------------------------------------------------------- +-- | +-- Module : Text.Feed.Constructor +-- Copyright : (c) Galois, Inc. 2008, +-- (c) Sigbjorn Finne 2009- +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Description: Module for an abstraction layer between different kinds of feeds. +-- +-------------------------------------------------------------------- +module Text.Feed.Constructor + ( FeedKind(..) + , newFeed -- :: FeedKind -> Feed + , feedFromRSS -- :: RSS -> Feed + , feedFromAtom -- :: Atom.Feed -> Feed + , feedFromRDF -- :: RSS1.Feed -> Feed + , feedFromXML -- :: Element -> Feed + , getFeedKind -- :: Feed -> FeedKind + , FeedSetter -- type _ a = a -> Feed -> Feed + , addItem -- :: FeedSetter Item + , withFeedTitle -- :: FeedSetter Text + , withFeedHome -- :: FeedSetter URLString + , withFeedHTML -- :: FeedSetter URLString + , withFeedDescription -- :: FeedSetter Text + , withFeedPubDate -- :: FeedSetter DateString + , withFeedLastUpdate -- :: FeedSetter DateString + , withFeedDate -- :: FeedSetter DateString + , withFeedLogoLink -- :: FeedSetter URLString + , withFeedLanguage -- :: FeedSetter Text + , withFeedCategories -- :: FeedSetter [(Text, Maybe Text)] + , withFeedGenerator -- :: FeedSetter Text + , withFeedItems -- :: FeedSetter [Item] + , newItem -- :: FeedKind -> Item + , getItemKind -- :: Item -> FeedKind + , atomEntryToItem -- :: Atom.Entry -> Item + , rssItemToItem -- :: RSS.Item -> Item + , rdfItemToItem -- :: RSS1.Item -> Item + , ItemSetter -- type _ a = a -> Item -> Item + , withItemTitle -- :: ItemSetter Text + , withItemLink -- :: ItemSetter URLString + , withItemPubDate -- :: ItemSetter DateString + , withItemDate -- :: ItemSetter DateString + , withItemAuthor -- :: ItemSetter Text + , withItemCommentLink -- :: ItemSetter Text + , withItemEnclosure -- :: Text -> Maybe Text -> ItemSetter Integer + , withItemFeedLink -- :: Text -> ItemSetter Text + , withItemId -- :: Bool -> ItemSetter Text + , withItemCategories -- :: ItemSetter [(Text, Maybe Text)] + , withItemDescription -- :: ItemSetter Text + , withItemRights -- :: ItemSetter Text + ) where + +import Prelude.Compat + +import Text.Feed.Types as Feed.Types + +import Text.Atom.Feed as Atom +import Text.DublinCore.Types +import Text.RSS.Syntax as RSS +import Text.RSS1.Syntax as RSS1 + +import Data.XML.Compat +import Data.XML.Types as XML + +import Data.Char (toLower) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text, pack) + +-- ToDo: +-- +-- - complete set of constructors over feeds +-- - provide a unified treatment of date string reps. +-- (i.e., I know they differ across formats, but ignorant what +-- the constraints are at the moment.) +-- | Construct an empty feed document, intending to output it in +-- the 'fk' feed format. +newFeed :: FeedKind -> Feed.Types.Feed +newFeed fk = + case fk of + AtomKind -> + AtomFeed + (Atom.nullFeed + "feed-id-not-filled-in" + (TextString "dummy-title") + "dummy-and-bogus-update-date") + RSSKind mbV -> + let def = RSS.nullRSS "dummy-title" "default-channel-url" + in RSSFeed $ maybe def (\v -> def {RSS.rssVersion = v}) mbV + RDFKind mbV -> + let def = RSS1.nullFeed "default-channel-url" "dummy-title" + in RSS1Feed $ maybe def (\v -> def {RSS1.feedVersion = v}) mbV + +feedFromRSS :: RSS.RSS -> Feed.Types.Feed +feedFromRSS = RSSFeed + +feedFromAtom :: Atom.Feed -> Feed.Types.Feed +feedFromAtom = AtomFeed + +feedFromRDF :: RSS1.Feed -> Feed.Types.Feed +feedFromRDF = RSS1Feed + +feedFromXML :: XML.Element -> Feed.Types.Feed +feedFromXML = XMLFeed + +getFeedKind :: Feed.Types.Feed -> FeedKind +getFeedKind f = + case f of + Feed.Types.AtomFeed {} -> AtomKind + Feed.Types.RSSFeed r -> + RSSKind + (case RSS.rssVersion r of + "2.0" -> Nothing + v -> Just v) + Feed.Types.RSS1Feed r -> + RDFKind + (case RSS1.feedVersion r of + "1.0" -> Nothing + v -> Just v) + Feed.Types.XMLFeed {} -> RSSKind (Just "2.0") -- for now, just a hunch.. + +addItem :: Feed.Types.Item -> Feed.Types.Feed -> Feed.Types.Feed +addItem it f = + case (it, f) of + (Feed.Types.AtomItem e, Feed.Types.AtomFeed fe) -> + Feed.Types.AtomFeed fe {Atom.feedEntries = e : Atom.feedEntries fe} + (Feed.Types.RSSItem e, Feed.Types.RSSFeed r) -> + Feed.Types.RSSFeed + r {RSS.rssChannel = (RSS.rssChannel r) {RSS.rssItems = e : RSS.rssItems (RSS.rssChannel r)}} + (Feed.Types.RSS1Item e, Feed.Types.RSS1Feed r) + -- note: do not update the channel item URIs at this point; + -- will delay doing so until serialization. + -> Feed.Types.RSS1Feed r {RSS1.feedItems = e : RSS1.feedItems r} + _ -> + error "addItem: currently unable to automatically convert items from one feed type to another" + +withFeedItems :: FeedSetter [Feed.Types.Item] +withFeedItems is fe = + foldr + addItem + (case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f {Atom.feedEntries = []} + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f {rssChannel = (rssChannel f) {rssItems = []}} + Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f {feedItems = []}) + is + +newItem :: FeedKind -> Feed.Types.Item +newItem fk = + case fk of + AtomKind -> + Feed.Types.AtomItem $ + Atom.nullEntry + "entry-id-not-filled-in" + (TextString "dummy-entry-title") + "dummy-and-bogus-entry-update-date" + RSSKind {} -> Feed.Types.RSSItem $ RSS.nullItem "dummy-rss-item-title" + RDFKind {} -> + Feed.Types.RSS1Item $ RSS1.nullItem "dummy-item-uri" "dummy-item-title" "dummy-item-link" + +getItemKind :: Feed.Types.Item -> FeedKind +getItemKind f = + case f of + Feed.Types.AtomItem {} -> AtomKind + Feed.Types.RSSItem {} -> RSSKind (Just "2.0") -- good guess.. + Feed.Types.RSS1Item {} -> RDFKind (Just "1.0") + Feed.Types.XMLItem {} -> RSSKind (Just "2.0") + +type FeedSetter a = a -> Feed.Types.Feed -> Feed.Types.Feed + +withFeedTitle :: FeedSetter Text +withFeedTitle tit fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f {feedTitle = TextString tit} + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f {rssChannel = (rssChannel f) {rssTitle = tit}} + Feed.Types.RSS1Feed f -> + Feed.Types.RSS1Feed f {feedChannel = (feedChannel f) {channelTitle = tit}} + Feed.Types.XMLFeed f -> + Feed.Types.XMLFeed $ + mapMaybeChildren + (\e -> + if elementName e == "channel" + then Just + (mapMaybeChildren + (\e2 -> + if elementName e2 == "title" + then Just (unode "title" tit) + else Nothing) + e) + else Nothing) + f + +withFeedHome :: FeedSetter URLString +withFeedHome url fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f {feedLinks = newSelf : Atom.feedLinks f} + -- ToDo: fix, the element is for the HTML home of the channel, not the + -- location of the feed itself. Struggling to find if there is a common way + -- to represent this outside of RSS 2.0 standard elements.. + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f {rssChannel = (rssChannel f) {rssLink = url}} + Feed.Types.RSS1Feed f -> + Feed.Types.RSS1Feed f {feedChannel = (feedChannel f) {channelURI = url}} + Feed.Types.XMLFeed f -> + Feed.Types.XMLFeed $ + mapMaybeChildren + (\e -> + if elementName e == "channel" + then Just + (mapMaybeChildren + (\e2 -> + if elementName e2 == "link" + then Just (unode "link" url) + else Nothing) + e) + else Nothing) + f + where + newSelf = (nullLink url) {linkRel = Just (Left "self"), linkType = Just "application/atom+xml"} + +-- | 'withFeedHTML' sets the URL where an HTML version of the +-- feed is published. +withFeedHTML :: FeedSetter URLString +withFeedHTML url fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f {feedLinks = newAlt : Atom.feedLinks f} + Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f {rssChannel = (rssChannel f) {rssLink = url}} + Feed.Types.RSS1Feed f -> + Feed.Types.RSS1Feed f {feedChannel = (feedChannel f) {channelLink = url}} + Feed.Types.XMLFeed f -> + Feed.Types.XMLFeed $ + mapMaybeChildren + (\e -> + if elementName e == "channel" + then Just + (mapMaybeChildren + (\e2 -> + if elementName e2 == "link" + then Just (unode "link" url) + else Nothing) + e) + else Nothing) + f + where + newAlt = (nullLink url) {linkRel = Just (Left "alternate"), linkType = Just "text/html"} + +-- | 'withFeedHTML' sets the URL where an HTML version of the +-- feed is published. +withFeedDescription :: FeedSetter Text +withFeedDescription desc fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f {feedSubtitle = Just (TextString desc)} + Feed.Types.RSSFeed f -> + Feed.Types.RSSFeed f {rssChannel = (rssChannel f) {rssDescription = desc}} + Feed.Types.RSS1Feed f -> + Feed.Types.RSS1Feed f {feedChannel = (feedChannel f) {channelDesc = desc}} + Feed.Types.XMLFeed f -> + Feed.Types.XMLFeed $ + mapMaybeChildren + (\e -> + if elementName e == "channel" + then Just + (mapMaybeChildren + (\e2 -> + if elementName e2 == "description" + then Just (unode "description" desc) + else Nothing) + e) + else Nothing) + f + +withFeedPubDate :: FeedSetter Text +withFeedPubDate dateStr fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f {feedUpdated = dateStr} + Feed.Types.RSSFeed f -> + Feed.Types.RSSFeed f {rssChannel = (rssChannel f) {rssPubDate = Just dateStr}} + Feed.Types.RSS1Feed f -> + Feed.Types.RSS1Feed $ + case break isDate $ RSS1.channelDC (RSS1.feedChannel f) of + (as, dci:bs) -> + f + { RSS1.feedChannel = + (RSS1.feedChannel f) {RSS1.channelDC = as ++ dci {dcText = dateStr} : bs} + } + (_, []) -> + f + { RSS1.feedChannel = + (RSS1.feedChannel f) + { RSS1.channelDC = + DCItem {dcElt = DC_Date, dcText = dateStr} : + RSS1.channelDC (RSS1.feedChannel f) + } + } + Feed.Types.XMLFeed f -> + Feed.Types.XMLFeed $ + mapMaybeChildren + (\e -> + if elementName e == "channel" + then Just + (mapMaybeChildren + (\e2 -> + if elementName e2 == "pubDate" + then Just (unode "pubDate" dateStr) + else Nothing) + e) + else Nothing) + f + where + isDate dc = dcElt dc == DC_Date + +withFeedLastUpdate :: FeedSetter DateString +withFeedLastUpdate dateStr fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f {feedUpdated = dateStr} + Feed.Types.RSSFeed f -> + Feed.Types.RSSFeed f {rssChannel = (rssChannel f) {rssLastUpdate = Just dateStr}} + Feed.Types.RSS1Feed f -> + Feed.Types.RSS1Feed $ + case break isDate $ RSS1.channelDC (RSS1.feedChannel f) of + (as, dci:bs) -> + f + { RSS1.feedChannel = + (RSS1.feedChannel f) {RSS1.channelDC = as ++ dci {dcText = dateStr} : bs} + } + (_, []) -> + f + { RSS1.feedChannel = + (RSS1.feedChannel f) + { RSS1.channelDC = + DCItem {dcElt = DC_Date, dcText = dateStr} : + RSS1.channelDC (RSS1.feedChannel f) + } + } + Feed.Types.XMLFeed f -> + Feed.Types.XMLFeed $ + mapMaybeChildren + (\e -> + if elementName e == "channel" + then Just + (mapMaybeChildren + (\e2 -> + if elementName e2 == "lastUpdate" + then Just (unode "lastUpdate" dateStr) + else Nothing) + e) + else Nothing) + f + where + isDate dc = dcElt dc == DC_Date + +-- | 'withFeedDate dt' is the composition of 'withFeedPubDate' +-- and 'withFeedLastUpdate', setting both publication date and +-- last update date to 'dt'. Notice that RSS2.0 is the only format +-- supporting both pub and last-update. +withFeedDate :: FeedSetter DateString +withFeedDate dt f = withFeedPubDate dt (withFeedLastUpdate dt f) + +withFeedLogoLink :: URLString -> FeedSetter URLString +withFeedLogoLink imgURL lnk fe = + case fe of + Feed.Types.AtomFeed f -> + Feed.Types.AtomFeed f {feedLogo = Just imgURL, feedLinks = newSelf : Atom.feedLinks f} + Feed.Types.RSSFeed f -> + Feed.Types.RSSFeed + f + { rssChannel = + (rssChannel f) {rssImage = Just $ RSS.nullImage imgURL (rssTitle (rssChannel f)) lnk} + } + Feed.Types.RSS1Feed f -> + Feed.Types.RSS1Feed $ + f + { feedImage = Just $ RSS1.nullImage imgURL (RSS1.channelTitle (RSS1.feedChannel f)) lnk + , feedChannel = (feedChannel f) {channelImageURI = Just imgURL} + } + Feed.Types.XMLFeed f -> + Feed.Types.XMLFeed $ + mapMaybeChildren + (\e -> + if elementName e == "channel" + then Just + (mapMaybeChildren + (\e2 -> + if elementName e2 == "image" + then Just + (unode + "image" + [unode "url" imgURL, unode "title" title, unode "link" lnk]) + else Nothing) + e) + else Nothing) + f + where title = + case fmap (findChild "title") (findChild "channel" f) of + Just (Just e1) -> strContent e1 + _ -> "feed_title" -- shouldn't happen.. + where + newSelf = (nullLink lnk) {linkRel = Just (Left "self"), linkType = Just "application/atom+xml"} + +withFeedLanguage :: FeedSetter Text +withFeedLanguage lang fe = + case fe of + Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f {Atom.feedAttrs = langAttr : Atom.feedAttrs f} + where langAttr = (name, [ContentText lang]) + name = Name {nameLocalName = "lang", nameNamespace = Nothing, namePrefix = Just "xml"} + Feed.Types.RSSFeed f -> + Feed.Types.RSSFeed f {rssChannel = (rssChannel f) {rssLanguage = Just lang}} + Feed.Types.RSS1Feed f -> + Feed.Types.RSS1Feed $ + case break isLang $ RSS1.channelDC (RSS1.feedChannel f) of + (as, dci:bs) -> + f + { RSS1.feedChannel = + (RSS1.feedChannel f) {RSS1.channelDC = as ++ dci {dcText = lang} : bs} + } + (_, []) -> + f + { RSS1.feedChannel = + (RSS1.feedChannel f) + { RSS1.channelDC = + DCItem {dcElt = DC_Language, dcText = lang} : + RSS1.channelDC (RSS1.feedChannel f) + } + } + Feed.Types.XMLFeed f -> + Feed.Types.XMLFeed $ + mapMaybeChildren + (\e -> + if elementName e == "channel" + then Just + (mapMaybeChildren + (\e2 -> + if elementName e2 == "language" + then Just (unode "language" lang) + else Nothing) + e) + else Nothing) + f + where + isLang dc = dcElt dc == DC_Language + +withFeedCategories :: FeedSetter [(Text, Maybe Text)] +withFeedCategories cats fe = + case fe of + Feed.Types.AtomFeed f -> + Feed.Types.AtomFeed + f + { Atom.feedCategories = + map (\(t, mb) -> (Atom.newCategory t) {Atom.catScheme = mb}) cats ++ feedCategories f + } + Feed.Types.RSSFeed f -> + Feed.Types.RSSFeed + f + { rssChannel = + (rssChannel f) + { RSS.rssCategories = + map (\(t, mb) -> (RSS.newCategory t) {RSS.rssCategoryDomain = mb}) cats ++ + RSS.rssCategories (rssChannel f) + } + } + Feed.Types.RSS1Feed f -> + Feed.Types.RSS1Feed + f + { feedChannel = + (feedChannel f) + { RSS1.channelDC = + map (\(t, _) -> DCItem {dcElt = DC_Subject, dcText = t}) cats ++ + RSS1.channelDC (feedChannel f) + } + } + Feed.Types.XMLFeed f -> + Feed.Types.XMLFeed $ + mapMaybeChildren + (\e -> + if elementName e == "channel" + then Just + (foldr + (\(t, mb) acc -> + addChild + (unode + "category" + (maybe (: []) (\v x -> [mkAttr "domain" v, x]) mb (mkAttr "term" t))) + acc) + e + cats) + else Nothing) + f + +withFeedGenerator :: FeedSetter (Text, Maybe URLString) +withFeedGenerator (gen, mbURI) fe = + case fe of + Feed.Types.AtomFeed f -> + Feed.Types.AtomFeed $ + f {Atom.feedGenerator = Just ((Atom.nullGenerator gen) {Atom.genURI = mbURI})} + Feed.Types.RSSFeed f -> + Feed.Types.RSSFeed f {rssChannel = (rssChannel f) {rssGenerator = Just gen}} + Feed.Types.RSS1Feed f -> + Feed.Types.RSS1Feed $ + case break isSource $ RSS1.channelDC (RSS1.feedChannel f) of + (as, dci:bs) -> + f + { RSS1.feedChannel = + (RSS1.feedChannel f) {RSS1.channelDC = as ++ dci {dcText = gen} : bs} + } + (_, []) -> + f + { RSS1.feedChannel = + (RSS1.feedChannel f) + { RSS1.channelDC = + DCItem {dcElt = DC_Source, dcText = gen} : RSS1.channelDC (RSS1.feedChannel f) + } + } + Feed.Types.XMLFeed f -> + Feed.Types.XMLFeed $ + mapMaybeChildren + (\e -> + if elementName e == "channel" + then Just + (mapMaybeChildren + (\e2 -> + if elementName e2 == "generator" + then Just (unode "generator" gen) + else Nothing) + e) + else Nothing) + f + where + isSource dc = dcElt dc == DC_Source + +-- Item constructors (all the way to the end): +atomEntryToItem :: Atom.Entry -> Feed.Types.Item +atomEntryToItem = Feed.Types.AtomItem + +rssItemToItem :: RSS.RSSItem -> Feed.Types.Item +rssItemToItem = Feed.Types.RSSItem + +rdfItemToItem :: RSS1.Item -> Feed.Types.Item +rdfItemToItem = Feed.Types.RSS1Item + +type ItemSetter a = a -> Feed.Types.Item -> Feed.Types.Item + +-- | 'withItemPubDate dt' associates the creation\/ publication date 'dt' +-- with a feed item. +withItemPubDate :: ItemSetter DateString +withItemPubDate dt fi = + case fi of + Feed.Types.AtomItem e -> Feed.Types.AtomItem e {Atom.entryUpdated = dt} + Feed.Types.RSSItem i -> Feed.Types.RSSItem i {RSS.rssItemPubDate = Just dt} + Feed.Types.RSS1Item i -> + case break isDate $ RSS1.itemDC i of + (as, dci:bs) -> Feed.Types.RSS1Item i {RSS1.itemDC = as ++ dci {dcText = dt} : bs} + (_, []) -> + Feed.Types.RSS1Item + i {RSS1.itemDC = DCItem {dcElt = DC_Date, dcText = dt} : RSS1.itemDC i} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "pubDate" dt) $ filterChildren (\e -> elementName e /= "pubDate") i + where + isDate dc = dcElt dc == DC_Date + +-- | 'withItemDate' is a synonym for 'withItemPubDate'. +withItemDate :: ItemSetter DateString +withItemDate = withItemPubDate + +-- | 'withItemTitle myTitle' associates a new title, 'myTitle', +-- with a feed item. +withItemTitle :: ItemSetter Text +withItemTitle tit fi = + case fi of + Feed.Types.AtomItem e -> Feed.Types.AtomItem e {Atom.entryTitle = TextString tit} + Feed.Types.RSSItem i -> Feed.Types.RSSItem i {RSS.rssItemTitle = Just tit} + Feed.Types.RSS1Item i -> Feed.Types.RSS1Item i {RSS1.itemTitle = tit} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "title" tit) $ filterChildren (\e -> elementName e /= "title") i + +-- | 'withItemAuthor auStr' associates new author info +-- with a feed item. +withItemAuthor :: ItemSetter Text +withItemAuthor au fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem + e {Atom.entryAuthors = [nullPerson {personName = au, personURI = Just au}]} + Feed.Types.RSSItem i -> Feed.Types.RSSItem i {RSS.rssItemAuthor = Just au} + Feed.Types.RSS1Item i -> + case break isAuthor $ RSS1.itemDC i of + (as, dci:bs) -> Feed.Types.RSS1Item i {RSS1.itemDC = as ++ dci {dcText = au} : bs} + (_, []) -> + Feed.Types.RSS1Item + i {RSS1.itemDC = DCItem {dcElt = DC_Creator, dcText = au} : RSS1.itemDC i} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "author" au) $ filterChildren (\e -> elementName e /= "author") i + where + isAuthor dc = dcElt dc == DC_Creator + +-- | 'withItemFeedLink name myFeed' associates the parent feed URL 'myFeed' +-- with a feed item. It is labelled as 'name'. +withItemFeedLink :: Text -> ItemSetter Text +withItemFeedLink tit url fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem + e + { Atom.entrySource = + Just Atom.nullSource {sourceId = Just url, sourceTitle = Just (TextString tit)} + } + Feed.Types.RSSItem i -> Feed.Types.RSSItem i {RSS.rssItemSource = Just (RSS.nullSource url tit)} + Feed.Types.RSS1Item i -> Feed.Types.RSS1Item i {RSS1.itemTitle = tit} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "source" ([mkAttr "url" url], tit)) $ + filterChildren (\e -> elementName e /= "source") i + +-- | 'withItemCommentLink url' sets the URL reference to the comment page to 'url'. +withItemCommentLink :: ItemSetter Text +withItemCommentLink url fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem + e {Atom.entryLinks = ((nullLink url) {linkRel = Just (Left "replies")}) : Atom.entryLinks e} + Feed.Types.RSSItem i -> Feed.Types.RSSItem i {RSS.rssItemComments = Just url} + Feed.Types.RSS1Item i -> + case break isRel $ RSS1.itemDC i of + (as, dci:bs) -> Feed.Types.RSS1Item i {RSS1.itemDC = as ++ dci {dcText = url} : bs} + (_, []) -> + Feed.Types.RSS1Item + i {RSS1.itemDC = DCItem {dcElt = DC_Relation, dcText = url} : RSS1.itemDC i} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "comments" url) $ filterChildren (\e -> elementName e /= "comments") i + where + isRel dc = dcElt dc == DC_Relation + +-- | 'withItemEnclosure url mbTy len' sets the URL reference to the comment page to 'url'. +withItemEnclosure :: Text -> Maybe Text -> ItemSetter (Maybe Integer) +withItemEnclosure url ty mb_len fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem + e + { Atom.entryLinks = + ((nullLink url) + { linkRel = Just (Left "enclosure") + , linkType = ty + , linkLength = fmap (pack . show) mb_len + }) : + Atom.entryLinks e + } + Feed.Types.RSSItem i -> + Feed.Types.RSSItem + i {RSS.rssItemEnclosure = Just (nullEnclosure url mb_len (fromMaybe "text/html" ty))} + Feed.Types.RSS1Item i -> + Feed.Types.RSS1Item + i + { RSS1.itemContent = + nullContentInfo {contentURI = Just url, contentFormat = ty} : RSS1.itemContent i + } + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild + ((unode "enclosure" url) + {elementAttributes = [mkAttr "length" "0", mkAttr "type" (fromMaybe "text/html" ty)]}) $ + filterChildren (\e -> elementName e /= "enclosure") i + +-- | 'withItemId isURL id' associates new unique identifier with a feed item. +-- If 'isURL' is 'True', then the id is assumed to point to a valid web resource. +withItemId :: Bool -> ItemSetter Text +withItemId isURL idS fi = + case fi of + Feed.Types.AtomItem e -> Feed.Types.AtomItem e {Atom.entryId = idS} + Feed.Types.RSSItem i -> + Feed.Types.RSSItem + i {RSS.rssItemGuid = Just (nullGuid idS) {rssGuidPermanentURL = Just isURL}} + Feed.Types.RSS1Item i -> + case break isId $ RSS1.itemDC i of + (as, dci:bs) -> Feed.Types.RSS1Item i {RSS1.itemDC = as ++ dci {dcText = idS} : bs} + (_, []) -> + Feed.Types.RSS1Item + i {RSS1.itemDC = DCItem {dcElt = DC_Identifier, dcText = idS} : RSS1.itemDC i} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "guid" ([mkAttr "isPermaLink" (showBool isURL)], idS)) $ + filterChildren (\e -> elementName e /= "guid") i + where + showBool x = pack $ map toLower (show x) + isId dc = dcElt dc == DC_Identifier + +-- | 'withItemDescription desc' associates a new descriptive string (aka summary) +-- with a feed item. +withItemDescription :: ItemSetter Text +withItemDescription desc fi = + case fi of + Feed.Types.AtomItem e -> Feed.Types.AtomItem e {Atom.entrySummary = Just (TextString desc)} + Feed.Types.RSSItem i -> Feed.Types.RSSItem i {RSS.rssItemDescription = Just desc} + Feed.Types.RSS1Item i -> Feed.Types.RSS1Item i {RSS1.itemDesc = Just desc} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "description" desc) $ filterChildren (\e -> elementName e /= "description") i + +-- | 'withItemRights rightStr' associates the rights information 'rightStr' +-- with a feed item. +withItemRights :: ItemSetter Text +withItemRights desc fi = + case fi of + Feed.Types.AtomItem e -> Feed.Types.AtomItem e {Atom.entryRights = Just (TextString desc)} + -- Note: per-item copyright information isn't supported by RSS2.0 (and earlier editions), + -- you can only attach this at the feed/channel level. So, there's not much we can do + -- except dropping the information on the floor here. (Rolling our own attribute or + -- extension element is an option, but would prefer if someone else had started that + -- effort already. + Feed.Types.RSSItem {} -> fi + Feed.Types.RSS1Item i -> + case break ((== DC_Rights) . dcElt) $ RSS1.itemDC i of + (as, dci:bs) -> Feed.Types.RSS1Item i {RSS1.itemDC = as ++ dci {dcText = desc} : bs} + (_, []) -> + Feed.Types.RSS1Item + i {RSS1.itemDC = DCItem {dcElt = DC_Rights, dcText = desc} : RSS1.itemDC i} + -- Since we're so far assuming that a shallow XML rep. of an item + -- is of RSS2.0 ilk, pinning on the rights info is hard (see above.) + Feed.Types.XMLItem {} -> fi + +-- | 'withItemTitle myLink' associates a new URL, 'myLink', +-- with a feed item. +withItemLink :: ItemSetter URLString +withItemLink url fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem e {Atom.entryLinks = replaceAlternate url (Atom.entryLinks e)} + Feed.Types.RSSItem i -> Feed.Types.RSSItem i {RSS.rssItemLink = Just url} + Feed.Types.RSS1Item i -> Feed.Types.RSS1Item i {RSS1.itemLink = url} + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + addChild (unode "link" url) $ filterChildren (\e -> elementName e /= "link") i + where + replaceAlternate _ [] = [] + replaceAlternate x (lr:xs) + | toStr (Atom.linkRel lr) == "alternate" = lr {Atom.linkHref = x} : xs + | otherwise = lr : replaceAlternate x xs + toStr Nothing = "" + toStr (Just (Left x)) = x + toStr (Just (Right x)) = x + +withItemCategories :: ItemSetter [(Text, Maybe Text)] +withItemCategories cats fi = + case fi of + Feed.Types.AtomItem e -> + Feed.Types.AtomItem + e + { Atom.entryCategories = + map (\(t, mb) -> (Atom.newCategory t) {Atom.catScheme = mb}) cats ++ entryCategories e + } + Feed.Types.RSSItem i -> + Feed.Types.RSSItem + i + { RSS.rssItemCategories = + map (\(t, mb) -> (RSS.newCategory t) {RSS.rssCategoryDomain = mb}) cats ++ + rssItemCategories i + } + Feed.Types.RSS1Item i -> + Feed.Types.RSS1Item + i + { RSS1.itemDC = + map (\(t, _) -> DCItem {dcElt = DC_Subject, dcText = t}) cats ++ RSS1.itemDC i + } + Feed.Types.XMLItem i -> + Feed.Types.XMLItem $ + foldr + (\(t, mb) acc -> + addChild + (unode "category" (maybe (: []) (\v x -> [mkAttr "domain" v, x]) mb (mkAttr "term" t))) + acc) + i + cats + +-- helpers.. +filterChildren :: (XML.Element -> Bool) -> XML.Element -> XML.Element +filterChildren pre e = + case elementNodes e of + [] -> e + cs -> e {elementNodes = mapMaybe filterElt cs} + where + filterElt xe@(XML.NodeElement el) + | pre el = Just xe + | otherwise = Nothing + filterElt xe = Just xe + +addChild :: XML.Element -> XML.Element -> XML.Element +addChild a b = b {elementNodes = XML.NodeElement a : elementNodes b} + +mapMaybeChildren :: (XML.Element -> Maybe XML.Element) -> XML.Element -> XML.Element +mapMaybeChildren f e = + case elementNodes e of + [] -> e + cs -> e {elementNodes = map procElt cs} + where + procElt xe@(XML.NodeElement el) = + case f el of + Nothing -> xe + Just el1 -> XML.NodeElement el1 + procElt xe = xe diff --git a/src/Text/Feed/Export.hs b/src/Text/Feed/Export.hs --- a/src/Text/Feed/Export.hs +++ b/src/Text/Feed/Export.hs @@ -11,26 +11,37 @@ -- Convert from Feeds to XML. -- -------------------------------------------------------------------- - - module Text.Feed.Export - ( Text.Feed.Export.xmlFeed -- :: Feed -> XML.Element - ) where + ( Text.Feed.Export.xmlFeed -- :: Feed -> XML.Element + , Text.Feed.Export.textFeed -- :: Feed -> TL.Text + , Text.Feed.Export.textFeedWith + ) where +import Prelude.Compat + import Text.Feed.Types +import qualified Data.Text.Util as U import Text.Atom.Feed.Export as Atom import Text.RSS.Export as RSS import Text.RSS1.Export as RSS1 -import Text.XML.Light as XML +import qualified Data.Text.Lazy as TL +import Data.XML.Types as XML +import Text.XML (RenderSettings) -- | 'xmlFeed f' serializes a @Feed@ document into a conforming -- XML toplevel element. xmlFeed :: Feed -> XML.Element xmlFeed fe = case fe of - AtomFeed f -> Atom.xmlFeed f - RSSFeed f -> RSS.xmlRSS f - RSS1Feed f -> RSS1.xmlFeed f - XMLFeed e -> e -- that was easy! + AtomFeed f -> Atom.xmlFeed f + RSSFeed f -> RSS.xmlRSS f + RSS1Feed f -> RSS1.xmlFeed f + XMLFeed e -> e -- that was easy! + +textFeed :: Feed -> Maybe TL.Text +textFeed = U.renderFeed Text.Feed.Export.xmlFeed + +textFeedWith :: RenderSettings -> Feed -> Maybe TL.Text +textFeedWith settings = U.renderFeedWith settings Text.Feed.Export.xmlFeed diff --git a/src/Text/Feed/Import.hs b/src/Text/Feed/Import.hs --- a/src/Text/Feed/Import.hs +++ b/src/Text/Feed/Import.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE CPP #-} + -------------------------------------------------------------------- -- | -- Module : Text.Feed.Import @@ -12,63 +15,72 @@ -- Convert from XML to Feeds. -- -------------------------------------------------------------------- - module Text.Feed.Import - ( parseFeedFromFile -- :: FilePath -> IO Feed - , parseFeedString -- :: String -> Maybe Feed - , parseFeedSource -- :: XmlSource s => s -> Maybe Feed - + ( parseFeedFromFile -- :: FilePath -> IO Feed + , parseFeedString -- :: String -> Maybe Feed + , parseFeedSource -- :: FeedSource s => s -> Maybe Feed + , FeedSource -- if you know your format, use these directly: - , readRSS2 -- :: XML.Element -> Maybe Feed - , readRSS1 -- :: XML.Element -> Maybe Feed - , readAtom -- :: XML.Element -> Maybe Feed - ) where + , readRSS2 -- :: XML.Element -> Maybe Feed + , readRSS1 -- :: XML.Element -> Maybe Feed + , readAtom -- :: XML.Element -> Maybe Feed + ) where +import Prelude.Compat + +import Control.Exception +import Data.ByteString.Lazy (ByteString) +import Data.Text.Lazy (Text, pack) +import Data.XML.Types as XML + import Text.Atom.Feed.Import as Atom -import Text.RSS.Import as RSS -import Text.RSS1.Import as RSS1 import Text.Feed.Types -import Text.XML.Light as XML -import Text.XML.Light.Lexer ( XmlSource ) +import Text.RSS.Import as RSS +import Text.RSS1.Import as RSS1 -import Control.Monad +import Control.Monad.Compat +import qualified Text.XML as C #if MIN_VERSION_utf8_string(1,0,0) import Codec.Binary.UTF8.String (decodeString) -import System.IO (IOMode(..), hGetContents, openBinaryFile ) +import System.IO (IOMode(..), hGetContents, openBinaryFile) + utf8readFile :: FilePath -> IO String utf8readFile fp = fmap decodeString (hGetContents =<< openBinaryFile fp ReadMode) #else -import System.IO.UTF8 as UTF8 ( readFile ) +import System.IO.UTF8 as UTF8 (readFile) + utf8readFile :: FilePath -> IO String utf8readFile = UTF8.readFile #endif +class FeedSource s where + parseFeedSourceXML :: s -> Either SomeException C.Document +instance FeedSource ByteString where + parseFeedSourceXML = C.parseLBS C.def +instance FeedSource Text where + parseFeedSourceXML = C.parseText C.def +instance FeedSource String where + parseFeedSourceXML = parseFeedSourceXML . pack + -- | 'parseFeedFromFile fp' reads in the contents of the file at @fp@; -- the assumed encoding is UTF-8. -parseFeedFromFile :: FilePath -> IO Feed -parseFeedFromFile fp = do - ls <- utf8readFile fp - case parseFeedString ls of - Nothing -> fail ("parseFeedFromFile: not a well-formed XML content in: " ++ fp) - Just f -> return f +parseFeedFromFile :: FilePath -> IO (Maybe Feed) +parseFeedFromFile fp = parseFeedString <$> utf8readFile fp -- | 'parseFeedWithParser tries to parse the string @str@ -- as one of the feed formats. First as Atom, then RSS2 before -- giving RSS1 a try. @Nothing@ is, rather unhelpfully, returned -- as an indication of error. -parseFeedWithParser :: XmlSource s => (s -> Maybe Element) -> s -> Maybe Feed +parseFeedWithParser :: FeedSource s => (s -> Either e C.Document) -> s -> Maybe Feed parseFeedWithParser parser str = case parser str of - Nothing -> Nothing - Just e -> - readAtom e `mplus` - readRSS2 e `mplus` - readRSS1 e `mplus` - Just (XMLFeed e) + Left _ -> Nothing + Right d -> readAtom e `mplus` readRSS2 e `mplus` readRSS1 e `mplus` Just (XMLFeed e) + where e = C.toXMLElement $ C.documentRoot d parseFeedString :: String -> Maybe Feed parseFeedString = parseFeedSource @@ -77,20 +89,20 @@ -- one of the feed formats. First as Atom, then RSS2 before giving -- RSS1 a try. @Nothing@ is, rather unhelpfully, returned as an -- indication of error. -parseFeedSource :: XmlSource s => s -> Maybe Feed -parseFeedSource = parseFeedWithParser parseXMLDoc +parseFeedSource :: FeedSource s => s -> Maybe Feed +parseFeedSource = parseFeedWithParser parseFeedSourceXML -- | 'readRSS2 elt' tries to derive an RSS2.x, RSS-0.9x feed document -- from the XML element @e@. readRSS2 :: XML.Element -> Maybe Feed -readRSS2 e = fmap RSSFeed $ RSS.elementToRSS e +readRSS2 e = RSSFeed <$> RSS.elementToRSS e -- | 'readRSS1 elt' tries to derive an RSS1.0 feed document -- from the XML element @e@. readRSS1 :: XML.Element -> Maybe Feed -readRSS1 e = fmap RSS1Feed $ RSS1.elementToFeed e +readRSS1 e = RSS1Feed <$> RSS1.elementToFeed e -- | 'readAtom elt' tries to derive an Atom feed document -- from the XML element @e@. readAtom :: XML.Element -> Maybe Feed -readAtom e = fmap AtomFeed $ Atom.elementFeed e +readAtom e = AtomFeed <$> Atom.elementFeed e diff --git a/src/Text/Feed/Query.hs b/src/Text/Feed/Query.hs --- a/src/Text/Feed/Query.hs +++ b/src/Text/Feed/Query.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + -------------------------------------------------------------------- -- | -- Module : Text.Feed.Query @@ -11,72 +12,77 @@ -- Portability: portable -- -------------------------------------------------------------------- - - module Text.Feed.Query - ( Text.Feed.Query.feedItems -- :: Feed.Feed -> [Feed.Item] - - , FeedGetter -- type _ a = Feed -> a - , getFeedTitle -- :: FeedGetter String - , getFeedAuthor -- :: FeedGetter String - , getFeedHome -- :: FeedGetter URLString - , getFeedHTML -- :: FeedGetter URLString - , getFeedDescription -- :: FeedGetter String - , getFeedPubDate -- :: FeedGetter DateString - , getFeedLastUpdate -- :: FeedGetter (Maybe String) - , getFeedDate -- :: FeedGetter DateString - , getFeedLogoLink -- :: FeedGetter URLString - , getFeedLanguage -- :: FeedGetter String - , getFeedCategories -- :: FeedGetter [(String, Maybe String)] - , getFeedGenerator -- :: FeedGetter String - , getFeedItems -- :: FeedGetter [Item] - - , ItemGetter -- type _ a = Item -> Maybe a - , getItemTitle -- :: ItemGetter (String) - , getItemLink -- :: ItemGetter (String) - , getItemPublishDate -- :: Data.Time.ParseTime t => ItemGetter (Maybe t) - , getItemPublishDateString -- :: ItemGetter (DateString) - , getItemDate -- :: ItemGetter (DateString) - , getItemAuthor -- :: ItemGetter (String) - , getItemCommentLink -- :: ItemGetter (URLString) - , getItemEnclosure -- :: ItemGetter (String,Maybe String,Integer) - , getItemFeedLink -- :: ItemGetter (URLString) - , getItemId -- :: ItemGetter (Bool,String) - , getItemCategories -- :: ItemGetter [String] - , getItemRights -- :: ItemGetter String - , getItemSummary -- :: ItemGetter String - , getItemDescription -- :: ItemGetter String (synonym of previous.) + ( Text.Feed.Query.feedItems -- :: Feed.Feed -> [Feed.Item] + , FeedGetter -- type _ a = Feed -> a + , getFeedTitle -- :: FeedGetter Text + , getFeedAuthor -- :: FeedGetter Text + , getFeedHome -- :: FeedGetter URLString + , getFeedHTML -- :: FeedGetter URLString + , getFeedDescription -- :: FeedGetter Text + , getFeedPubDate -- :: FeedGetter DateString + , getFeedLastUpdate -- :: FeedGetter Text + , getFeedDate -- :: FeedGetter DateString + , getFeedLogoLink -- :: FeedGetter URLString + , getFeedLanguage -- :: FeedGetter Text + , getFeedCategories -- :: FeedGetter [(Text, Maybe Text)] + , getFeedGenerator -- :: FeedGetter Text + , getFeedItems -- :: FeedGetter [Item] + , ItemGetter -- type _ a = Item -> Maybe a + , getItemTitle -- :: ItemGetter Text + , getItemLink -- :: ItemGetter Text + , getItemPublishDate -- :: Data.Time.ParseTime t => ItemGetter (Maybe t) + , getItemPublishDateString -- :: ItemGetter (DateString) + , getItemDate -- :: ItemGetter (DateString) + , getItemAuthor -- :: ItemGetter Text + , getItemCommentLink -- :: ItemGetter (URLString) + , getItemEnclosure -- :: ItemGetter (URI, Maybe Text, Integer) + , getItemFeedLink -- :: ItemGetter (URLString) + , getItemId -- :: ItemGetter (Bool, Text) + , getItemCategories -- :: ItemGetter [Text] + , getItemRights -- :: ItemGetter Text + , getItemSummary -- :: ItemGetter Text + , getItemContent -- :: ItemGetter Text + , getItemDescription -- :: ItemGetter Text (synonym of previous.) + ) where - ) where +import Prelude.Compat import Text.Feed.Types as Feed -import Text.RSS.Syntax as RSS -import Text.Atom.Feed as Atom +import Data.XML.Types as XML +import Text.Atom.Feed as Atom import Text.Atom.Feed.Export (atomName) +import Text.RSS.Syntax as RSS import Text.RSS1.Syntax as RSS1 -import Text.XML.Light as XML +import Data.XML.Compat + import Text.DublinCore.Types -import Control.Monad ( mplus ) import Control.Applicative ((<|>)) -import Data.List +import Control.Arrow ((&&&)) +import Control.Monad.Compat (mplus) import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Read --- for getItemPublishDate rfc822 date parsing. -import Data.Time.Locale.Compat ( defaultTimeLocale, rfc822DateFormat, iso8601DateFormat ) -import Data.Time.Format ( ParseTime ) +import Data.Time.Format (ParseTime) import qualified Data.Time.Format as F +-- for getItemPublishDate rfc822 date parsing. +import Data.Time.Locale.Compat (defaultTimeLocale, iso8601DateFormat, rfc822DateFormat) + feedItems :: Feed.Feed -> [Feed.Item] feedItems fe = case fe of AtomFeed f -> map Feed.AtomItem (Atom.feedEntries f) - RSSFeed f -> map Feed.RSSItem (RSS.rssItems $ RSS.rssChannel f) + RSSFeed f -> map Feed.RSSItem (RSS.rssItems $ RSS.rssChannel f) RSS1Feed f -> map Feed.RSS1Item (RSS1.feedItems f) - XMLFeed f -> case XML.findElements (XML.unqual "item") f of - [] -> map Feed.XMLItem $ XML.findElements (atomName "entry") f + XMLFeed f -> + case findElements "item" f of + [] -> map Feed.XMLItem $ findElements (atomName "entry") f l -> map Feed.XMLItem l getFeedItems :: Feed.Feed -> [Feed.Item] @@ -84,195 +90,193 @@ type FeedGetter a = Feed.Feed -> Maybe a -getFeedAuthor :: FeedGetter String +getFeedAuthor :: FeedGetter Text getFeedAuthor ft = case ft of Feed.AtomFeed f -> fmap Atom.personName $ listToMaybe $ Atom.feedAuthors f - Feed.RSSFeed f -> RSS.rssEditor (RSS.rssChannel f) - Feed.RSS1Feed f -> fmap dcText $ listToMaybe $ filter isAuthor $ RSS1.channelDC (RSS1.feedChannel f) - Feed.XMLFeed f -> - case findElement (unqual "channel") f of - Just e1 -> fmap XML.strContent $ findElement (unqual "editor") e1 - Nothing -> fmap XML.strContent $ - findElement (atomName "name") - =<< findChild (atomName "author") f - where - isAuthor dc = dcElt dc == DC_Creator + Feed.RSSFeed f -> RSS.rssEditor (RSS.rssChannel f) + Feed.RSS1Feed f -> + fmap dcText $ listToMaybe $ filter isAuthor $ RSS1.channelDC (RSS1.feedChannel f) + Feed.XMLFeed f -> + case findElement "channel" f of + Just e1 -> strContent <$> findElement "editor" e1 + Nothing -> + fmap strContent $ findElement (atomName "name") =<< findChild (atomName "author") f + where + isAuthor dc = dcElt dc == DC_Creator -getFeedTitle :: Feed.Feed -> String +getFeedTitle :: Feed.Feed -> Text getFeedTitle ft = case ft of Feed.AtomFeed f -> contentToStr $ Atom.feedTitle f - Feed.RSSFeed f -> RSS.rssTitle (RSS.rssChannel f) + Feed.RSSFeed f -> RSS.rssTitle (RSS.rssChannel f) Feed.RSS1Feed f -> RSS1.channelTitle (RSS1.feedChannel f) - Feed.XMLFeed f -> - case findElement (unqual "channel") f of - Just e1 -> fromMaybe "" (fmap XML.strContent $ findElement (unqual "title") e1) - Nothing -> fromMaybe "" (fmap XML.strContent $ findChild (atomName "title") f) + Feed.XMLFeed f -> + case findElement "channel" f of + Just e1 -> maybe "" strContent (findElement "title" e1) + Nothing -> maybe "" strContent (findChild (atomName "title") f) -getFeedHome :: FeedGetter URLString +getFeedHome :: FeedGetter URLString getFeedHome ft = case ft of Feed.AtomFeed f -> fmap Atom.linkHref $ listToMaybe $ filter isSelf (Atom.feedLinks f) - Feed.RSSFeed f -> Just (RSS.rssLink (RSS.rssChannel f)) + Feed.RSSFeed f -> Just (RSS.rssLink (RSS.rssChannel f)) Feed.RSS1Feed f -> Just (RSS1.channelURI (RSS1.feedChannel f)) - Feed.XMLFeed f -> - case findElement (unqual "channel") f of - Just e1 -> fmap XML.strContent $ findElement (unqual "link") e1 - Nothing -> XML.findAttr (unqual "href") - =<< findChild (atomName "link") f - where - isSelf lr = toStr (Atom.linkRel lr) == "self" + Feed.XMLFeed f -> + case findElement "channel" f of + Just e1 -> strContent <$> findElement "link" e1 + Nothing -> attributeText "href" =<< findChild (atomName "link") f + where + isSelf lr = toStr (Atom.linkRel lr) == "self" -getFeedHTML :: FeedGetter URLString +getFeedHTML :: FeedGetter URLString getFeedHTML ft = case ft of Feed.AtomFeed f -> fmap Atom.linkHref $ listToMaybe $ filter isSelf (Atom.feedLinks f) - Feed.RSSFeed f -> Just (RSS.rssLink (RSS.rssChannel f)) + Feed.RSSFeed f -> Just (RSS.rssLink (RSS.rssChannel f)) Feed.RSS1Feed f -> Just (RSS1.channelURI (RSS1.feedChannel f)) - Feed.XMLFeed f -> - case findElement (unqual "channel") f of - Just e1 -> fmap XML.strContent $ findElement (unqual "link") e1 + Feed.XMLFeed f -> + case findElement "channel" f of + Just e1 -> strContent <$> findElement "link" e1 Nothing -> Nothing -- ToDo parse atom like tags - where - isSelf lr = - let rel = Atom.linkRel lr - in (isNothing rel || toStr rel == "alternate") && isHTMLType (linkType lr) - - isHTMLType (Just str) = "lmth" `isPrefixOf` (reverse str) - isHTMLType _ = True -- if none given, assume html. + where + isSelf lr = + let rel = Atom.linkRel lr + in (isNothing rel || toStr rel == "alternate") && isHTMLType (linkType lr) + isHTMLType (Just str) = "html" `T.isSuffixOf` str + isHTMLType _ = True -- if none given, assume html. -getFeedDescription :: FeedGetter String +getFeedDescription :: FeedGetter Text getFeedDescription ft = case ft of Feed.AtomFeed f -> fmap contentToStr (Atom.feedSubtitle f) - Feed.RSSFeed f -> Just $ RSS.rssDescription (RSS.rssChannel f) + Feed.RSSFeed f -> Just $ RSS.rssDescription (RSS.rssChannel f) Feed.RSS1Feed f -> Just (RSS1.channelDesc (RSS1.feedChannel f)) - Feed.XMLFeed f -> - case findElement (unqual "channel") f of - Just e1 -> fmap XML.strContent $ findElement (unqual "description") e1 - Nothing -> fmap XML.strContent $ findChild (atomName "subtitle") f + Feed.XMLFeed f -> + case findElement "channel" f of + Just e1 -> strContent <$> findElement "description" e1 + Nothing -> strContent <$> findChild (atomName "subtitle") f -getFeedPubDate :: FeedGetter DateString +getFeedPubDate :: FeedGetter DateString getFeedPubDate ft = case ft of Feed.AtomFeed f -> Just $ Atom.feedUpdated f - Feed.RSSFeed f -> RSS.rssPubDate (RSS.rssChannel f) - Feed.RSS1Feed f -> fmap dcText $ listToMaybe $ filter isDate (RSS1.channelDC $ RSS1.feedChannel f) - Feed.XMLFeed f -> - case findElement (unqual "channel") f of - Just e1 -> fmap XML.strContent $ findElement (unqual "pubDate") e1 - Nothing -> fmap XML.strContent $ findChild (atomName "published") f - where - isDate dc = dcElt dc == DC_Date + Feed.RSSFeed f -> RSS.rssPubDate (RSS.rssChannel f) + Feed.RSS1Feed f -> + fmap dcText $ listToMaybe $ filter isDate (RSS1.channelDC $ RSS1.feedChannel f) + Feed.XMLFeed f -> + case findElement "channel" f of + Just e1 -> strContent <$> findElement "pubDate" e1 + Nothing -> strContent <$> findChild (atomName "published") f + where + isDate dc = dcElt dc == DC_Date -getFeedLastUpdate :: FeedGetter (String) +getFeedLastUpdate :: FeedGetter Text getFeedLastUpdate ft = case ft of Feed.AtomFeed f -> Just $ Atom.feedUpdated f - Feed.RSSFeed f -> RSS.rssPubDate (RSS.rssChannel f) - Feed.RSS1Feed f -> fmap dcText $ listToMaybe $ filter isDate (RSS1.channelDC $ RSS1.feedChannel f) - Feed.XMLFeed f -> - case findElement (unqual "channel") f of - Just e1 -> fmap XML.strContent $ findElement (unqual "pubDate") e1 - Nothing -> fmap XML.strContent $ findChild (atomName "updated") f - where - isDate dc = dcElt dc == DC_Date + Feed.RSSFeed f -> RSS.rssPubDate (RSS.rssChannel f) + Feed.RSS1Feed f -> + fmap dcText $ listToMaybe $ filter isDate (RSS1.channelDC $ RSS1.feedChannel f) + Feed.XMLFeed f -> + case findElement "channel" f of + Just e1 -> strContent <$> findElement "pubDate" e1 + Nothing -> strContent <$> findChild (atomName "updated") f + where + isDate dc = dcElt dc == DC_Date -getFeedDate :: FeedGetter DateString -getFeedDate ft = getFeedPubDate ft +getFeedDate :: FeedGetter DateString +getFeedDate = getFeedPubDate -getFeedLogoLink :: FeedGetter URLString +getFeedLogoLink :: FeedGetter URLString getFeedLogoLink ft = case ft of Feed.AtomFeed f -> Atom.feedLogo f - Feed.RSSFeed f -> fmap RSS.rssImageURL (RSS.rssImage $ RSS.rssChannel f) - Feed.RSS1Feed f -> (fmap RSS1.imageURI $ RSS1.feedImage f) - Feed.XMLFeed f -> - case findElement (unqual "channel") f of + Feed.RSSFeed f -> fmap RSS.rssImageURL (RSS.rssImage $ RSS.rssChannel f) + Feed.RSS1Feed f -> RSS1.imageURI <$> RSS1.feedImage f + Feed.XMLFeed f -> + case findElement "channel" f of Just ch -> do - e1 <- findElement (unqual "image") ch - v <- findElement (unqual "url") e1 - return (XML.strContent v) - Nothing -> fmap XML.strContent $ findChild (atomName "logo") f + e1 <- findElement "image" ch + v <- findElement "url" e1 + return (strContent v) + Nothing -> strContent <$> findChild (atomName "logo") f -getFeedLanguage :: FeedGetter String +getFeedLanguage :: FeedGetter Text getFeedLanguage ft = case ft of - Feed.AtomFeed f -> - lookupAttr (unqual "lang"){qPrefix=Just "xml"} (Atom.feedAttrs f) - Feed.RSSFeed f -> RSS.rssLanguage (RSS.rssChannel f) - Feed.RSS1Feed f -> fmap dcText $ listToMaybe $ filter isLang (RSS1.channelDC $ RSS1.feedChannel f) - Feed.XMLFeed f -> do - ch <- findElement (unqual "channel") f - e1 <- findElement (unqual "language") ch - return (XML.strContent e1) + Feed.AtomFeed f -> attributeText "lang" $ unode "" (Atom.feedAttrs f) + Feed.RSSFeed f -> RSS.rssLanguage (RSS.rssChannel f) + Feed.RSS1Feed f -> + fmap dcText $ listToMaybe $ filter isLang (RSS1.channelDC $ RSS1.feedChannel f) + Feed.XMLFeed f -> do + ch <- findElement "channel" f + e1 <- findElement "language" ch + return (strContent e1) -- ToDo parse atom like tags too - where - isLang dc = dcElt dc == DC_Language - + where + isLang dc = dcElt dc == DC_Language -getFeedCategories :: Feed.Feed -> [(String, Maybe String)] +getFeedCategories :: Feed.Feed -> [(Text, Maybe Text)] getFeedCategories ft = case ft of - Feed.AtomFeed f -> map (\ c -> (Atom.catTerm c, Atom.catScheme c)) (Atom.feedCategories f) - Feed.RSSFeed f -> map (\ c -> (RSS.rssCategoryValue c, RSS.rssCategoryDomain c)) (RSS.rssCategories (RSS.rssChannel f)) + Feed.AtomFeed f -> map (Atom.catTerm &&& Atom.catScheme) (Atom.feedCategories f) + Feed.RSSFeed f -> + map (RSS.rssCategoryValue &&& RSS.rssCategoryDomain) (RSS.rssCategories (RSS.rssChannel f)) Feed.RSS1Feed f -> - case filter isCat (RSS1.channelDC $ RSS1.feedChannel f) of - ls -> map (\ l -> (dcText l,Nothing)) ls - Feed.XMLFeed f -> - case fromMaybe [] $ fmap (XML.findElements (XML.unqual "category")) (findElement (unqual "channel") f) of - ls -> map (\ l -> (fromMaybe "" (fmap XML.strContent $ findElement (unqual "term") l), findAttr (unqual "domain") l)) ls + case filter isCat (RSS1.channelDC $ RSS1.feedChannel f) of + ls -> map (\l -> (dcText l, Nothing)) ls + Feed.XMLFeed f -> + case maybe [] (findElements "category") (findElement "channel" f) of + ls -> map (\l -> (maybe "" strContent (findElement "term" l), attributeText "domain" l)) ls -- ToDo parse atom like tags too - where - isCat dc = dcElt dc == DC_Subject + where + isCat dc = dcElt dc == DC_Subject -getFeedGenerator :: FeedGetter String +getFeedGenerator :: FeedGetter Text getFeedGenerator ft = case ft of Feed.AtomFeed f -> do gen <- Atom.feedGenerator f Atom.genURI gen - Feed.RSSFeed f -> RSS.rssGenerator (RSS.rssChannel f) - Feed.RSS1Feed f -> fmap dcText $ listToMaybe $ filter isSource (RSS1.channelDC (RSS1.feedChannel f)) - Feed.XMLFeed f -> case findElement (unqual "channel") f of - Just e1 -> fmap XML.strContent $ findElement (unqual "generator") e1 - Nothing -> XML.findAttr (unqual "uri") - =<< findChild (atomName "generator") f - where - isSource dc = dcElt dc == DC_Source + Feed.RSSFeed f -> RSS.rssGenerator (RSS.rssChannel f) + Feed.RSS1Feed f -> + fmap dcText $ listToMaybe $ filter isSource (RSS1.channelDC (RSS1.feedChannel f)) + Feed.XMLFeed f -> + case findElement "channel" f of + Just e1 -> strContent <$> findElement "generator" e1 + Nothing -> attributeText "uri" =<< findChild (atomName "generator") f + where + isSource dc = dcElt dc == DC_Source type ItemGetter a = Feed.Item -> Maybe a -getItemTitle :: ItemGetter String +getItemTitle :: ItemGetter Text getItemTitle it = case it of Feed.AtomItem i -> Just (contentToStr $ Atom.entryTitle i) - Feed.RSSItem i -> RSS.rssItemTitle i + Feed.RSSItem i -> RSS.rssItemTitle i Feed.RSS1Item i -> Just (RSS1.itemTitle i) - Feed.XMLItem e -> fmap XML.strContent $ - findElement (unqual "title") e - <|> findChild (atomName "title") e + Feed.XMLItem e -> fmap strContent $ findElement "title" e <|> findChild (atomName "title") e -getItemLink :: ItemGetter String +getItemLink :: ItemGetter Text getItemLink it = - case it of + case it -- look up the 'alternate' HTML link relation on the entry, or one -- without link relation since that is equivalent to 'alternate': + of Feed.AtomItem i -> fmap Atom.linkHref $ listToMaybe $ filter isSelf $ Atom.entryLinks i - Feed.RSSItem i -> RSS.rssItemLink i + Feed.RSSItem i -> RSS.rssItemLink i Feed.RSS1Item i -> Just (RSS1.itemLink i) - Feed.XMLItem i -> - fmap XML.strContent (findElement (unqual "link") i) - <|> (findChild (atomName "link") i >>= XML.findAttr (unqual "href")) - where - isSelf lr = - let rel = Atom.linkRel lr - in (isNothing rel || toStr rel == "alternate") && isHTMLType (linkType lr) - - isHTMLType (Just str) = "lmth" `isPrefixOf` (reverse str) - isHTMLType _ = True -- if none given, assume html. - + Feed.XMLItem i -> + fmap strContent (findElement "link" i) <|> + (findChild (atomName "link") i >>= attributeText "href") + where + isSelf lr = + let rel = Atom.linkRel lr + in (isNothing rel || toStr rel == "alternate") && isHTMLType (linkType lr) + isHTMLType (Just str) = "html" `T.isSuffixOf` str + isHTMLType _ = True -- if none given, assume html. -- | 'getItemPublishDate item' returns the publication date of the item, -- but first parsed per the supported RFC 822 and RFC 3339 formats. @@ -285,178 +289,185 @@ -- see 'Data.Time.Format'. getItemPublishDate :: ParseTime t => ItemGetter (Maybe t) getItemPublishDate it = do - ds <- getItemPublishDateString it - let - rfc3339DateFormat1 = iso8601DateFormat (Just "%H:%M:%S%Z") - rfc3339DateFormat2 = iso8601DateFormat (Just "%H:%M:%S%Q%Z") - - formats = [ rfc3339DateFormat1, rfc3339DateFormat2, rfc822DateFormat ] + ds <- getItemPublishDateString it + let rfc3339DateFormat1 = iso8601DateFormat (Just "%H:%M:%S%Z") + rfc3339DateFormat2 = iso8601DateFormat (Just "%H:%M:%S%Q%Z") + formats = [rfc3339DateFormat1, rfc3339DateFormat2, rfc822DateFormat] + date = foldl1 mplus (map (\fmt -> parseTime defaultTimeLocale fmt $ T.unpack ds) formats) + return date + where - date = foldl1 mplus (map (\ fmt -> parseTime defaultTimeLocale fmt ds) formats) - return date - where #if MIN_VERSION_time(1,5,0) parseTime = F.parseTimeM True #else parseTime = F.parseTime #endif - getItemPublishDateString :: ItemGetter DateString getItemPublishDateString it = case it of Feed.AtomItem i -> Just $ Atom.entryUpdated i - Feed.RSSItem i -> RSS.rssItemPubDate i + Feed.RSSItem i -> RSS.rssItemPubDate i Feed.RSS1Item i -> fmap dcText $ listToMaybe $ filter isDate $ RSS1.itemDC i - Feed.XMLItem e -> fmap XML.strContent $ - findElement (unqual "pubDate") e - <|> findElement (atomName "published") e - where - isDate dc = dcElt dc == DC_Date + Feed.XMLItem e -> + fmap strContent $ findElement "pubDate" e <|> findElement (atomName "published") e + where + isDate dc = dcElt dc == DC_Date getItemDate :: ItemGetter DateString -getItemDate it = getItemPublishDateString it +getItemDate = getItemPublishDateString -- | 'getItemAuthor f' returns the optional author of the item. -getItemAuthor :: ItemGetter String +getItemAuthor :: ItemGetter Text getItemAuthor it = case it of Feed.AtomItem i -> fmap Atom.personName $ listToMaybe $ Atom.entryAuthors i - Feed.RSSItem i -> RSS.rssItemAuthor i + Feed.RSSItem i -> RSS.rssItemAuthor i Feed.RSS1Item i -> fmap dcText $ listToMaybe $ filter isAuthor $ RSS1.itemDC i - Feed.XMLItem e -> fmap XML.strContent $ - findElement (unqual "author") e - <|> (findElement (atomName "author") e >>= findElement (atomName "name")) - where - isAuthor dc = dcElt dc == DC_Creator + Feed.XMLItem e -> + fmap strContent $ + findElement "author" e <|> + (findElement (atomName "author") e >>= findElement (atomName "name")) + where + isAuthor dc = dcElt dc == DC_Creator getItemCommentLink :: ItemGetter URLString getItemCommentLink it = - case it of + case it -- look up the 'replies' HTML link relation on the entry: + of Feed.AtomItem e -> fmap Atom.linkHref $ listToMaybe $ filter isReplies $ Atom.entryLinks e - Feed.RSSItem i -> RSS.rssItemComments i + Feed.RSSItem i -> RSS.rssItemComments i Feed.RSS1Item i -> fmap dcText $ listToMaybe $ filter isRel $ RSS1.itemDC i - Feed.XMLItem i -> - fmap XML.strContent (findElement (unqual "comments") i) - <|> (findElement (atomName "link") i >>= XML.findAttr (unqual "href")) - where - isReplies lr = toStr (Atom.linkRel lr) == "replies" - isRel dc = dcElt dc == DC_Relation + Feed.XMLItem i -> + fmap strContent (findElement "comments" i) <|> + (findElement (atomName "link") i >>= attributeText "href") + where + isReplies lr = toStr (Atom.linkRel lr) == "replies" + isRel dc = dcElt dc == DC_Relation -getItemEnclosure :: ItemGetter (String, Maybe String, Maybe Integer) +getItemEnclosure :: ItemGetter (URI, Maybe Text, Maybe Integer) getItemEnclosure it = case it of Feed.AtomItem e -> - case filter isEnc $ Atom.entryLinks e of - (l:_) -> Just (Atom.linkHref l, - Atom.linkType l, - readLength (Atom.linkLength l)) - _ -> Nothing - Feed.RSSItem i -> - fmap (\ e -> (RSS.rssEnclosureURL e, Just (RSS.rssEnclosureType e), RSS.rssEnclosureLength e)) - (RSS.rssItemEnclosure i) + case filter isEnc $ Atom.entryLinks e of + (l:_) -> Just (Atom.linkHref l, Atom.linkType l, readLength (Atom.linkLength l)) + _ -> Nothing + Feed.RSSItem i -> + fmap + (\e -> (RSS.rssEnclosureURL e, Just (RSS.rssEnclosureType e), RSS.rssEnclosureLength e)) + (RSS.rssItemEnclosure i) Feed.RSS1Item i -> - case RSS1.itemContent i of - [] -> Nothing - (c:_) -> Just (fromMaybe "" (RSS1.contentURI c), RSS1.contentFormat c, Nothing) - Feed.XMLItem e -> fmap xmlToEnclosure $ - findElement (unqual "enclosure") e - <|> findElement (atomName "enclosure") e - where - isEnc lr = toStr (Atom.linkRel lr) == "enclosure" - - readLength Nothing = Nothing - readLength (Just str) = - case reads str of - [] -> Nothing - ((v,_):_) -> Just v - - xmlToEnclosure e = - ( fromMaybe "" (findAttr (unqual "url") e) - , findAttr (unqual "type") e - , readLength $ findAttr (unqual "length") e - ) + case RSS1.itemContent i of + [] -> Nothing + (c:_) -> Just (fromMaybe "" (RSS1.contentURI c), RSS1.contentFormat c, Nothing) + Feed.XMLItem e -> + fmap xmlToEnclosure $ findElement "enclosure" e <|> findElement (atomName "enclosure") e + where + isEnc lr = toStr (Atom.linkRel lr) == "enclosure" + readLength Nothing = Nothing + readLength (Just str) = + case decimal str of + Right (v, _) -> Just v + _ -> Nothing + xmlToEnclosure e = + ( fromMaybe "" (attributeText "url" e) + , attributeText "type" e + , readLength $ attributeText "length" e) -getItemFeedLink :: ItemGetter URLString +getItemFeedLink :: ItemGetter URLString getItemFeedLink it = case it of Feed.AtomItem e -> - case (Atom.entrySource e) of - Nothing -> Nothing - Just s -> Atom.sourceId s + case Atom.entrySource e of + Nothing -> Nothing + Just s -> Atom.sourceId s Feed.RSSItem i -> - case (RSS.rssItemSource i) of - Nothing -> Nothing - Just s -> Just (RSS.rssSourceURL s) + case RSS.rssItemSource i of + Nothing -> Nothing + Just s -> Just (RSS.rssSourceURL s) Feed.RSS1Item _ -> Nothing Feed.XMLItem e -> - case findElement (unqual "source") e of + case findElement "source" e of Nothing -> Nothing - Just s -> fmap XML.strContent (findElement (unqual "url") s) + Just s -> fmap strContent (findElement "url" s) -- ToDo parse atom like tags too -getItemId :: ItemGetter (Bool,String) +getItemId :: ItemGetter (Bool, Text) getItemId it = case it of Feed.AtomItem e -> Just (True, Atom.entryId e) - Feed.RSSItem i -> + Feed.RSSItem i -> case RSS.rssItemGuid i of Nothing -> Nothing Just ig -> Just (fromMaybe True (RSS.rssGuidPermanentURL ig), RSS.rssGuidValue ig) Feed.RSS1Item i -> case filter isId (RSS1.itemDC i) of - (l:_) -> Just (True,dcText l) + (l:_) -> Just (True, dcText l) _ -> Nothing Feed.XMLItem e -> - fmap (\ e1 -> (True,XML.strContent e1)) $ - findElement (unqual "guid") e - <|> findElement (atomName "id") e - where - isId dc = dcElt dc == DC_Identifier + fmap (\e1 -> (True, strContent e1)) $ findElement "guid" e <|> findElement (atomName "id") e + where + isId dc = dcElt dc == DC_Identifier -getItemCategories :: Feed.Item -> [String] +getItemCategories :: Feed.Item -> [Text] getItemCategories it = case it of Feed.AtomItem i -> map Atom.catTerm $ Atom.entryCategories i - Feed.RSSItem i -> map RSS.rssCategoryValue $ RSS.rssItemCategories i + Feed.RSSItem i -> map RSS.rssCategoryValue $ RSS.rssItemCategories i Feed.RSS1Item i -> concat $ getCats1 i -- ToDo parse atom like tags too - Feed.XMLItem i -> map XML.strContent $ XML.findElements (XML.unqual "category") i - where + Feed.XMLItem i -> map strContent $ findElements "category" i -- get RSS1 categories; either via DublinCore's subject (or taxonomy topics...not yet.) - getCats1 i1 = - map (words.dcText) $ filter (\ dc -> dcElt dc == DC_Subject) $ RSS1.itemDC i1 + where + getCats1 i1 = map (T.words . dcText) $ filter (\dc -> dcElt dc == DC_Subject) $ RSS1.itemDC i1 -getItemRights :: ItemGetter String +getItemRights :: ItemGetter Text getItemRights it = case it of - Feed.AtomItem e -> fmap contentToStr $ Atom.entryRights e - Feed.RSSItem _ -> Nothing + Feed.AtomItem e -> contentToStr <$> Atom.entryRights e + Feed.RSSItem _ -> Nothing Feed.RSS1Item i -> fmap dcText $ listToMaybe $ filter isRights (RSS1.itemDC i) - Feed.XMLItem i -> fmap XML.strContent $ XML.findElement (atomName "rights") i - where - isRights dc = dcElt dc == DC_Rights + Feed.XMLItem i -> strContent <$> findElement (atomName "rights") i + where + isRights dc = dcElt dc == DC_Rights -getItemSummary :: ItemGetter String -getItemSummary it = getItemDescription it +getItemContent :: ItemGetter Text +getItemContent it = + case it of + Feed.AtomItem e -> atomContentToStr <$> Atom.entryContent e + Feed.RSSItem e -> RSS.rssItemContent e + Feed.RSS1Item _ -> Nothing + Feed.XMLItem i -> strContent <$> findElement (atomName "content") i -getItemDescription :: ItemGetter String +getItemSummary :: ItemGetter Text +getItemSummary = getItemDescription + +getItemDescription :: ItemGetter Text getItemDescription it = case it of - Feed.AtomItem e -> fmap contentToStr $ Atom.entrySummary e - Feed.RSSItem e -> RSS.rssItemDescription e + Feed.AtomItem e -> contentToStr <$> Atom.entrySummary e + Feed.RSSItem e -> RSS.rssItemDescription e Feed.RSS1Item i -> itemDesc i - Feed.XMLItem i -> fmap XML.strContent $ XML.findElement (atomName "summary") i - + Feed.XMLItem i -> strContent <$> findElement (atomName "summary") i -- strip away -toStr :: Maybe (Either String String) -> String + +toStr :: Maybe (Either Text Text) -> Text toStr Nothing = "" toStr (Just (Left x)) = x toStr (Just (Right x)) = x -contentToStr :: TextContent -> String +atomContentToStr :: EntryContent -> Text +atomContentToStr entry = + case entry of + HTMLContent e -> e + XHTMLContent e -> T.unlines $ elementText e + MixedContent text _ -> fromMaybe "" text + ExternalContent _ b -> b + TextContent text -> text + +contentToStr :: TextContent -> Text contentToStr x = case x of - Atom.TextString s -> s - Atom.HTMLString s -> s - Atom.XHTMLString s -> XML.strContent s + Atom.TextString s -> s + Atom.HTMLString s -> s + Atom.XHTMLString s -> strContent s diff --git a/src/Text/Feed/Translate.hs b/src/Text/Feed/Translate.hs --- a/src/Text/Feed/Translate.hs +++ b/src/Text/Feed/Translate.hs @@ -12,12 +12,15 @@ -- Translating between RSS formats; work in progress. -- module Text.Feed.Translate - ( translateItemTo -- :: FeedKind -> Item -> Item - , withAtomEntry -- :: (Atom.Entry -> Atom.Entry) -> Item -> Item - , withRSSItem -- :: (RSS.RSSItem -> RSS.RSSItem) -> Item -> Item - , withRSS1Item -- :: (RSS1.Item -> RSS1.Item) -> Item -> Item - ) where + ( translateItemTo -- :: FeedKind -> Item -> Item + , withAtomEntry -- :: (Atom.Entry -> Atom.Entry) -> Item -> Item + , withRSSItem -- :: (RSS.RSSItem -> RSS.RSSItem) -> Item -> Item + , withRSS1Item -- :: (RSS1.Item -> RSS1.Item) -> Item -> Item + ) where +import Prelude.Compat + +import Control.Arrow ((&&&)) import Text.Atom.Feed as Atom import Text.Feed.Constructor import Text.Feed.Types as Feed @@ -25,13 +28,13 @@ import qualified Text.RSS1.Syntax as RSS1 import Data.Maybe (fromMaybe) +import Data.Text (Text) -- functions for performing format-specific transformations. -- If the item isn't in the of-interest format, no transformation -- is performed (i.e., no on-the-fly translation into the requested -- format is performed; the caller is responsible -- - withAtomEntry :: (Atom.Entry -> Atom.Entry) -> Item -> Item withAtomEntry f it = case it of @@ -53,55 +56,50 @@ translateItemTo :: FeedKind -> Item -> Item translateItemTo fk it = case fk of - AtomKind -> toAtomItem it + AtomKind -> toAtomItem it RSSKind v -> toRSSItem v it RDFKind v -> toRDFItem v it -toRSSItem :: Maybe String -> Item -> Item +toRSSItem :: Maybe Text -> Item -> Item toRSSItem = error "toRSSItem: unimplemented" -toRDFItem :: Maybe String -> Item -> Item +toRDFItem :: Maybe Text -> Item -> Item toRDFItem = error "toRDFItem: unimplemented" toAtomItem :: Item -> Item toAtomItem it = case it of - AtomItem{} -> it - RSS1Item{} -> error "toAtomItem: unimplemented (from RSS1 item rep.)" - XMLItem{} -> error "toAtomItem: unimplemented (from shallow XML rep.)" - Feed.RSSItem ri -> foldl (\ oi f -> f oi) outIt pipeline_rss_atom - where - outIt = - (flip withAtomEntry) (newItem AtomKind) - (\ e -> e{ Atom.entryOther = RSS.rssItemOther ri - , Atom.entryAttrs = RSS.rssItemAttrs ri - }) - - pipeline_rss_atom = - [ mb withItemTitle (rssItemTitle ri) - , mb withItemLink (rssItemLink ri) - , mb withItemDescription (rssItemDescription ri) - , mb withItemAuthor (rssItemAuthor ri) - , ls withItemCategories (rssItemCategories ri) - , mb withItemId' (rssItemGuid ri) - , mb withItemCommentLink (rssItemComments ri) - , mb withItemEnclosure' (rssItemEnclosure ri) - , mb withItemPubDate (rssItemPubDate ri) - ] - - withItemEnclosure' e = - withItemEnclosure (rssEnclosureURL e) - (Just $ rssEnclosureType e) - (rssEnclosureLength e) - withItemId' g = withItemId (fromMaybe True (rssGuidPermanentURL g)) (rssGuidValue g) - - mb _ Nothing = id - mb f (Just v) = f v - - ls _ [] = id + AtomItem {} -> it + RSS1Item {} -> error "toAtomItem: unimplemented (from RSS1 item rep.)" + XMLItem {} -> error "toAtomItem: unimplemented (from shallow XML rep.)" + Feed.RSSItem ri -> foldl (\oi f -> f oi) outIt pipeline_rss_atom + where outIt = + withAtomEntry + (\e -> + e {Atom.entryOther = RSS.rssItemOther ri, Atom.entryAttrs = RSS.rssItemAttrs ri}) + (newItem AtomKind) + pipeline_rss_atom = + [ mb withItemTitle (rssItemTitle ri) + , mb withItemLink (rssItemLink ri) + , mb withItemDescription (rssItemDescription ri) + , mb withItemAuthor (rssItemAuthor ri) + , ls withItemCategories (rssItemCategories ri) + , mb withItemId' (rssItemGuid ri) + , mb withItemCommentLink (rssItemComments ri) + , mb withItemEnclosure' (rssItemEnclosure ri) + , mb withItemPubDate (rssItemPubDate ri) + ] + withItemEnclosure' e = + withItemEnclosure + (rssEnclosureURL e) + (Just $ rssEnclosureType e) + (rssEnclosureLength e) + withItemId' g = withItemId (fromMaybe True (rssGuidPermanentURL g)) (rssGuidValue g) + mb _ Nothing = id + mb f (Just v) = f v + ls _ [] = id -- hack, only used for cats, so specialize: - ls f xs = f (map (\ c -> (rssCategoryValue c, rssCategoryDomain c)) xs) - + ls f xs = f (map (rssCategoryValue &&& rssCategoryDomain) xs) {- pipeline_rss_atom = [ withItemTitle (rssItemTitle ri) diff --git a/src/Text/Feed/Types.hs b/src/Text/Feed/Types.hs --- a/src/Text/Feed/Types.hs +++ b/src/Text/Feed/Types.hs @@ -10,43 +10,46 @@ -- Portability: portable -- -------------------------------------------------------------------- - module Text.Feed.Types - ( Feed (..) - , Item (..) - , FeedKind (..) + ( Feed(..) + , Item(..) + , FeedKind(..) ) where -import qualified Text.RSS.Syntax as RSS -import qualified Text.Atom.Feed as Atom +import Prelude.Compat + +import Data.Text + +import qualified Data.XML.Types as XML +import qualified Text.Atom.Feed as Atom +import qualified Text.RSS.Syntax as RSS import qualified Text.RSS1.Syntax as RSS1 -import qualified Text.XML.Light as XML -- | The abstract type of feed documents. The internal representation -- is as whatever feed variant type the document was either imported or -- has now been translated to. data Feed - = AtomFeed Atom.Feed - | RSSFeed RSS.RSS - | RSS1Feed RSS1.Feed + = AtomFeed Atom.Feed + | RSSFeed RSS.RSS + | RSS1Feed RSS1.Feed -- if we're unable to correctly the well-formed XML as a feed, -- keep it as an untyped document. - | XMLFeed XML.Element - deriving (Show) + | XMLFeed XML.Element + deriving (Show) -- | The abstract type of feed items. Like the 'Text.Feed.Types.Feed' type, the -- representation of a value is as one of the different RSS item\/entry -- variants. data Item - = AtomItem Atom.Entry - | RSSItem RSS.RSSItem - | RSS1Item RSS1.Item - | XMLItem XML.Element - deriving (Show) + = AtomItem Atom.Entry + | RSSItem RSS.RSSItem + | RSS1Item RSS1.Item + | XMLItem XML.Element + deriving (Show) -- | The kinds of feed documents supported. data FeedKind - = AtomKind - | RSSKind (Maybe String) -- Nothing => default version (2.0) - | RDFKind (Maybe String) -- Nothing => default version (1.0) - deriving (Eq, Show) + = AtomKind + | RSSKind (Maybe Text) -- Nothing => default version (2.0) + | RDFKind (Maybe Text) -- Nothing => default version (1.0) + deriving (Eq, Show) diff --git a/src/Text/Feed/Util.hs b/src/Text/Feed/Util.hs --- a/src/Text/Feed/Util.hs +++ b/src/Text/Feed/Util.hs @@ -11,39 +11,39 @@ -- -------------------------------------------------------------------- module Text.Feed.Util - ( toFeedDateString - , toFeedDateStringUTC - ) where + ( toFeedDateString + , toFeedDateStringUTC + ) where -import Text.Feed.Types +import Prelude.Compat + import Data.Time (UTCTime, formatTime) import qualified Data.Time.Locale.Compat import qualified System.Locale import System.Time (ClockTime, formatCalendarTime, toUTCTime) +import Text.Feed.Types -- | 'toFeedDateString' translates a calendar time into -- the format expected by the feed kind. -toFeedDateString :: FeedKind -> ClockTime -> {-Date-}String -toFeedDateString fk ct = - formatCalendarTime System.Locale.defaultTimeLocale fmt ut +toFeedDateString :: FeedKind -> ClockTime -> String {-Date-} +toFeedDateString fk ct = formatCalendarTime System.Locale.defaultTimeLocale fmt ut where fmt = feedKindTimeFormat fk ut = toUTCTime ct -- | 'toFeedDateStringUTC' translates a UTC time into -- the format expected by the feed kind. -toFeedDateStringUTC :: FeedKind -> UTCTime -> {-Date-}String -toFeedDateStringUTC fk = - formatTime Data.Time.Locale.Compat.defaultTimeLocale fmt +toFeedDateStringUTC :: FeedKind -> UTCTime -> String {-Date-} +toFeedDateStringUTC fk = formatTime Data.Time.Locale.Compat.defaultTimeLocale fmt where fmt = feedKindTimeFormat fk -- | Time format expected by the feed kind. feedKindTimeFormat :: FeedKind -> String feedKindTimeFormat fk = - case fk of - AtomKind{} -> atomRdfTimeFormat - RSSKind{} -> "%a, %d %b %Y %H:%M:%S GMT" - RDFKind{} -> atomRdfTimeFormat + case fk of + AtomKind {} -> atomRdfTimeFormat + RSSKind {} -> "%a, %d %b %Y %H:%M:%S GMT" + RDFKind {} -> atomRdfTimeFormat where atomRdfTimeFormat = "%Y-%m-%dT%H:%M:%SZ" diff --git a/src/Text/RSS/Export.hs b/src/Text/RSS/Export.hs --- a/src/Text/RSS/Export.hs +++ b/src/Text/RSS/Export.hs @@ -10,12 +10,11 @@ -- Description: Convert from RSS to XML -- -------------------------------------------------------------------- - - module Text.RSS.Export ( qualNode , qualName , xmlRSS + , textRSS , xmlChannel , xmlItem , xmlSource @@ -32,158 +31,163 @@ , mb ) where -import Text.XML.Light as XML +import Prelude.Compat + +import qualified Data.Text.Util as U +import Data.XML.Compat +import Data.XML.Types as XML import Text.RSS.Syntax -import Data.Maybe +import Data.Text (Text, pack) +import qualified Data.Text.Lazy as TL -qualNode :: String -> [XML.Content] -> XML.Element -qualNode n cs = - blank_element - { elName = qualName n - , elContent = cs - } +qualName :: Text -> XML.Name +qualName n = Name n Nothing Nothing -qualName :: String -> QName -qualName n = QName{qName=n,qURI=Nothing,qPrefix=Nothing} +qualNode :: Text -> [XML.Node] -> XML.Element +qualNode n = Element (Name n Nothing Nothing) [] --- xmlRSS :: RSS -> XML.Element xmlRSS r = - (qualNode "rss" $ map Elem $ - ( [ xmlChannel (rssChannel r) ] - ++ rssOther r)) - { elAttribs = (Attr (qualName "version") (rssVersion r)):rssAttrs r } + (qualNode "rss" $ map NodeElement (xmlChannel (rssChannel r) : rssOther r)) + {elementAttributes = mkAttr "version" (rssVersion r) : rssAttrs r} +textRSS :: RSS -> Maybe TL.Text +textRSS = U.renderFeed xmlRSS + xmlChannel :: RSSChannel -> XML.Element xmlChannel ch = - (qualNode "channel" $ map Elem $ - ( [ xmlLeaf "title" (rssTitle ch) - , xmlLeaf "link" (rssLink ch) - , xmlLeaf "description" (rssDescription ch) - ] - ++ map xmlItem (rssItems ch) - ++ mb (xmlLeaf "language") (rssLanguage ch) - ++ mb (xmlLeaf "copyright") (rssCopyright ch) - ++ mb (xmlLeaf "managingEditor") (rssEditor ch) - ++ mb (xmlLeaf "webMaster") (rssWebMaster ch) - ++ mb (xmlLeaf "pubDate") (rssPubDate ch) - ++ mb (xmlLeaf "lastBuildDate") (rssLastUpdate ch) - ++ map xmlCategory (rssCategories ch) - ++ mb (xmlLeaf "generator") (rssGenerator ch) - ++ mb (xmlLeaf "docs") (rssDocs ch) - ++ mb xmlCloud (rssCloud ch) - ++ mb ((xmlLeaf "ttl") . show) (rssTTL ch) - ++ mb xmlImage (rssImage ch) - ++ mb (xmlLeaf "rating") (rssRating ch) - ++ mb xmlTextInput (rssTextInput ch) - ++ mb xmlSkipHours (rssSkipHours ch) - ++ mb xmlSkipDays (rssSkipDays ch) - ++ rssChannelOther ch)) + qualNode "channel" $ + map + NodeElement + ([ xmlLeaf "title" (rssTitle ch) + , xmlLeaf "link" (rssLink ch) + , xmlLeaf "description" (rssDescription ch) + ] ++ + map xmlItem (rssItems ch) ++ + mb (xmlLeaf "language") (rssLanguage ch) ++ + mb (xmlLeaf "copyright") (rssCopyright ch) ++ + mb (xmlLeaf "managingEditor") (rssEditor ch) ++ + mb (xmlLeaf "webMaster") (rssWebMaster ch) ++ + mb (xmlLeaf "pubDate") (rssPubDate ch) ++ + mb (xmlLeaf "lastBuildDate") (rssLastUpdate ch) ++ + map xmlCategory (rssCategories ch) ++ + mb (xmlLeaf "generator") (rssGenerator ch) ++ + mb (xmlLeaf "docs") (rssDocs ch) ++ + mb xmlCloud (rssCloud ch) ++ + mb (xmlLeaf "ttl" . pack . show) (rssTTL ch) ++ + mb xmlImage (rssImage ch) ++ + mb (xmlLeaf "rating") (rssRating ch) ++ + mb xmlTextInput (rssTextInput ch) ++ + mb xmlSkipHours (rssSkipHours ch) ++ mb xmlSkipDays (rssSkipDays ch) ++ rssChannelOther ch) xmlItem :: RSSItem -> XML.Element xmlItem it = - (qualNode "item" $ map Elem $ - ( mb (xmlLeaf "title") (rssItemTitle it) - ++ mb (xmlLeaf "link") (rssItemLink it) - ++ mb (xmlLeaf "description") (rssItemDescription it) - ++ mb (xmlLeaf "author") (rssItemAuthor it) - ++ map xmlCategory (rssItemCategories it) - ++ mb (xmlLeaf "comments") (rssItemComments it) - ++ mb xmlEnclosure (rssItemEnclosure it) - ++ mb xmlGuid (rssItemGuid it) - ++ mb (xmlLeaf "pubDate") (rssItemPubDate it) - ++ mb xmlSource (rssItemSource it) - ++ rssItemOther it)) - { elAttribs = rssItemAttrs it } + (qualNode "item" $ + map + NodeElement + (mb (xmlLeaf "title") (rssItemTitle it) ++ + mb (xmlLeaf "link") (rssItemLink it) ++ + mb (xmlLeaf "description") (rssItemDescription it) ++ + mb (xmlLeaf "author") (rssItemAuthor it) ++ + map xmlCategory (rssItemCategories it) ++ + mb (xmlLeaf "comments") (rssItemComments it) ++ + mb xmlEnclosure (rssItemEnclosure it) ++ + mb xmlGuid (rssItemGuid it) ++ + mb (xmlLeaf "pubDate") (rssItemPubDate it) ++ + mb xmlSource (rssItemSource it) ++ rssItemOther it)) + {elementAttributes = rssItemAttrs it} xmlSource :: RSSSource -> XML.Element xmlSource s = - (xmlLeaf "source" (rssSourceTitle s)) - { elAttribs = (Attr (qualName "url") (rssSourceURL s)) : - rssSourceAttrs s } + (xmlLeaf "source" (rssSourceTitle s)) + {elementAttributes = mkAttr "url" (rssSourceURL s) : rssSourceAttrs s} xmlEnclosure :: RSSEnclosure -> XML.Element xmlEnclosure e = - (xmlLeaf "enclosure" "") - { elAttribs = - (Attr (qualName "url") (rssEnclosureURL e)) : - (Attr (qualName "type") (rssEnclosureType e)) : - mb (Attr (qualName "length") . show) (rssEnclosureLength e) ++ - rssEnclosureAttrs e } + (xmlLeaf "enclosure" "") + { elementAttributes = + mkAttr "url" (rssEnclosureURL e) : + mkAttr "type" (rssEnclosureType e) : + mb (mkAttr "length" . pack . show) (rssEnclosureLength e) ++ rssEnclosureAttrs e + } xmlCategory :: RSSCategory -> XML.Element xmlCategory c = - (xmlLeaf "category" (rssCategoryValue c)) - { elAttribs = - (fromMaybe id (fmap (\ n -> ((Attr (qualName "domain") n):)) - (rssCategoryDomain c))) $ - (rssCategoryAttrs c) } + (xmlLeaf "category" (rssCategoryValue c)) + { elementAttributes = + maybe id (\n -> (mkAttr "domain" n :)) (rssCategoryDomain c) (rssCategoryAttrs c) + } xmlGuid :: RSSGuid -> XML.Element xmlGuid g = - (xmlLeaf "guid" (rssGuidValue g)) - { elAttribs = - (fromMaybe id (fmap (\ n -> ((Attr (qualName "isPermaLink") (toBool n)):)) - (rssGuidPermanentURL g))) $ - (rssGuidAttrs g) } - where - toBool False = "false" - toBool _ = "true" + (xmlLeaf "guid" (rssGuidValue g)) + { elementAttributes = + maybe + id + (\n -> (mkAttr "isPermaLink" (toBool n) :)) + (rssGuidPermanentURL g) + (rssGuidAttrs g) + } + where + toBool False = "false" + toBool _ = "true" xmlImage :: RSSImage -> XML.Element xmlImage im = - (qualNode "image" $ map Elem $ - ( [ xmlLeaf "url" (rssImageURL im) - , xmlLeaf "title" (rssImageTitle im) - , xmlLeaf "link" (rssImageLink im) - ] - ++ mb ((xmlLeaf "width") . show) (rssImageWidth im) - ++ mb ((xmlLeaf "height") . show) (rssImageHeight im) - ++ mb (xmlLeaf "description") (rssImageDesc im) - ++ rssImageOther im)) + qualNode "image" $ + map + NodeElement + ([ xmlLeaf "url" (rssImageURL im) + , xmlLeaf "title" (rssImageTitle im) + , xmlLeaf "link" (rssImageLink im) + ] ++ + mb (xmlLeaf "width" . pack . show) (rssImageWidth im) ++ + mb (xmlLeaf "height" . pack . show) (rssImageHeight im) ++ + mb (xmlLeaf "description") (rssImageDesc im) ++ rssImageOther im) xmlCloud :: RSSCloud -> XML.Element xmlCloud cl = - (xmlLeaf "cloud" "") - { elAttribs = - ( mb (Attr (qualName "domain")) (rssCloudDomain cl) - ++ mb (Attr (qualName "port")) (rssCloudPort cl) - ++ mb (Attr (qualName "path")) (rssCloudPath cl) - ++ mb (Attr (qualName "registerProcedure")) (rssCloudRegisterProcedure cl) - ++ mb (Attr (qualName "protocol")) (rssCloudProtocol cl) - ++ rssCloudAttrs cl) } + (xmlLeaf "cloud" "") + { elementAttributes = + mb (mkAttr "domain") (rssCloudDomain cl) ++ + mb (mkAttr "port") (rssCloudPort cl) ++ + mb (mkAttr "path") (rssCloudPath cl) ++ + mb (mkAttr "registerProcedure") (rssCloudRegisterProcedure cl) ++ + mb (mkAttr "protocol") (rssCloudProtocol cl) ++ rssCloudAttrs cl + } xmlTextInput :: RSSTextInput -> XML.Element xmlTextInput ti = - (qualNode "textInput" $ map Elem $ - ( [ xmlLeaf "title" (rssTextInputTitle ti) - , xmlLeaf "description" (rssTextInputDesc ti) - , xmlLeaf "name" (rssTextInputName ti) - , xmlLeaf "link" (rssTextInputLink ti) - ] ++ rssTextInputOther ti)) - { elAttribs = rssTextInputAttrs ti } + (qualNode "textInput" $ + map + NodeElement + ([ xmlLeaf "title" (rssTextInputTitle ti) + , xmlLeaf "description" (rssTextInputDesc ti) + , xmlLeaf "name" (rssTextInputName ti) + , xmlLeaf "link" (rssTextInputLink ti) + ] ++ + rssTextInputOther ti)) + {elementAttributes = rssTextInputAttrs ti} xmlSkipHours :: [Integer] -> XML.Element xmlSkipHours hs = - (qualNode "skipHours" $ map Elem $ - (map (\ n -> xmlLeaf "hour" (show n)) hs)) - -xmlSkipDays :: [String] -> XML.Element -xmlSkipDays hs = - (qualNode "skipDays" $ map Elem $ - (map (\ n -> xmlLeaf "day" n) hs)) + qualNode "skipHours" $ map (NodeElement . (\n -> xmlLeaf "hour" (pack $ show n))) hs --- +xmlSkipDays :: [Text] -> XML.Element +xmlSkipDays hs = qualNode "skipDays" $ map (NodeElement . xmlLeaf "day") hs -xmlAttr :: String -> String -> XML.Attr -xmlAttr k v = Attr (qualName k) v +xmlAttr :: Text -> Text -> Attr +xmlAttr k = mkNAttr (qualName k) -xmlLeaf :: String -> String -> XML.Element +xmlLeaf :: Text -> Text -> XML.Element xmlLeaf tg txt = - blank_element{ elName = qualName tg - , elContent = [ Text blank_cdata { cdData = txt } ] - } + Element + { elementAttributes = [] + , elementName = Name tg Nothing Nothing + , elementNodes = [NodeContent (ContentText txt)] + } --- mb :: (a -> b) -> Maybe a -> [b] diff --git a/src/Text/RSS/Import.hs b/src/Text/RSS/Import.hs --- a/src/Text/RSS/Import.hs +++ b/src/Text/RSS/Import.hs @@ -11,7 +11,6 @@ -- Converting from XML to RSS -- -------------------------------------------------------------------- - module Text.RSS.Import ( pNodes , pQNodes @@ -40,263 +39,291 @@ , readBool ) where +import Prelude.Compat + +import Data.XML.Compat +import Data.XML.Types as XML + import Text.RSS.Syntax -import Text.RSS1.Utils ( dcNS, dcPrefix ) -import Text.XML.Light as XML +import Text.RSS1.Utils (dcNS, dcPrefix) +import Control.Monad.Compat (guard, mplus) +import Data.Char (isSpace) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) -import Data.Char (isSpace ) -import Control.Monad (guard,mplus) +import Data.Text (Text, dropWhile) +import Data.Text.Util -pNodes :: String -> [XML.Element] -> [XML.Element] -pNodes x es = filter ((qualName x ==) . elName) es +pNodes :: Text -> [XML.Element] -> [XML.Element] +pNodes x = filter ((qualName x ==) . elementName) -pQNodes :: QName -> [XML.Element] -> [XML.Element] -pQNodes x es = filter ((x==) . elName) es +pQNodes :: Name -> [XML.Element] -> [XML.Element] +pQNodes x = filter ((x ==) . elementName) -pNode :: String -> [XML.Element] -> Maybe XML.Element -pNode x es = listToMaybe (pNodes x es) +pNode :: Text -> [XML.Element] -> Maybe XML.Element +pNode x es = listToMaybe (pNodes x es) -pQNode :: QName -> [XML.Element] -> Maybe XML.Element -pQNode x es = listToMaybe (pQNodes x es) +pQNode :: Name -> [XML.Element] -> Maybe XML.Element +pQNode x es = listToMaybe (pQNodes x es) -pLeaf :: String -> [XML.Element] -> Maybe String -pLeaf x es = strContent `fmap` pNode x es +pLeaf :: Text -> [XML.Element] -> Maybe Text +pLeaf x es = strContent `fmap` pNode x es -pQLeaf :: QName -> [XML.Element] -> Maybe String -pQLeaf x es = strContent `fmap` (pQNode x es) +pQLeaf :: Name -> [XML.Element] -> Maybe Text +pQLeaf x es = strContent `fmap` pQNode x es -pAttr :: String -> XML.Element -> Maybe String -pAttr x e = lookup (qualName x) [ (k,v) | Attr k v <- elAttribs e ] +pAttr :: Text -> XML.Element -> Maybe Text +pAttr x = attributeText (qualName x) -pMany :: String -> (XML.Element -> Maybe a) -> [XML.Element] -> [a] -pMany p f es = mapMaybe f (pNodes p es) +pMany :: Text -> (XML.Element -> Maybe a) -> [XML.Element] -> [a] +pMany p f es = mapMaybe f (pNodes p es) -children :: XML.Element -> [XML.Element] -children e = onlyElems (elContent e) +children :: XML.Element -> [XML.Element] +children = elementChildren -qualName :: String -> QName -qualName x = QName{qName=x,qURI=Nothing,qPrefix=Nothing} +qualName :: Text -> Name +qualName x = Name x Nothing Nothing -dcName :: String -> QName -dcName x = blank_name{qName=x,qURI=dcNS,qPrefix=dcPrefix} +dcName :: Text -> Name +dcName x = Name x (Just dcNS) (Just dcPrefix) elementToRSS :: XML.Element -> Maybe RSS elementToRSS e = do - guard (elName e == qualName "rss") + guard (elementName e == qualName "rss") let es = children e - let as = elAttribs e - v <- pAttr "version" e + let as = elementAttributes e + v <- pAttr "version" e ch <- pNode "channel" es >>= elementToChannel - return RSS - { rssVersion = v - , rssAttrs = filter (\ a -> not (qName (attrKey a) `elem` known_attrs)) as - , rssChannel = ch - , rssOther = filter (\ e1 -> elName e1 /= qualName "channel") es - } - where - known_attrs = ["version"] + return + RSS + { rssVersion = v + , rssAttrs = filter ((`notElem` known_attrs) . fst) as + , rssChannel = ch + , rssOther = filter (\e1 -> elementName e1 /= qualName "channel") es + } + where + known_attrs = ["version"] elementToChannel :: XML.Element -> Maybe RSSChannel elementToChannel e = do - guard (elName e == qualName "channel") + guard (elementName e == qualName "channel") let es = children e title <- pLeaf "title" es - link <- pLeaf "link" es - return RSSChannel - { rssTitle = title - , rssLink = link + link <- pLeaf "link" es + return + RSSChannel + { rssTitle = title + , rssLink = link -- being liberal, is a required channel element. - , rssDescription = fromMaybe title (pLeaf "description" es) - , rssItems = pMany "item" elementToItem es - , rssLanguage = pLeaf "language" es `mplus` pQLeaf (dcName "lang") es - , rssCopyright = pLeaf "copyright" es - , rssEditor = pLeaf "managingEditor" es `mplus` pQLeaf (dcName "creator") es - , rssWebMaster = pLeaf "webMaster" es - , rssPubDate = pLeaf "pubDate" es `mplus` pQLeaf (dcName "date") es - , rssLastUpdate = pLeaf "lastBuildDate" es `mplus` pQLeaf (dcName "date") es - , rssCategories = pMany "category" elementToCategory es - , rssGenerator = pLeaf "generator" es `mplus` pQLeaf (dcName "source") es - , rssDocs = pLeaf "docs" es - , rssCloud = pNode "cloud" es >>= elementToCloud - , rssTTL = pLeaf "ttl" es >>= readInt - , rssImage = pNode "image" es >>= elementToImage - , rssRating = pLeaf "rating" es - , rssTextInput = pNode "textInput" es >>= elementToTextInput - , rssSkipHours = pNode "skipHours" es >>= elementToSkipHours - , rssSkipDays = pNode "skipDays" es >>= elementToSkipDays - , rssChannelOther = filter (\ e1 -> not (elName e1 `elem` known_channel_elts)) es - } - where - known_channel_elts = map qualName - [ "title", "link", "description" - , "item", "language", "copyright" - , "managingEditor", "webMaster" - , "pubDate", "lastBuildDate" - , "category", "generator", "docs" - , "cloud", "ttl", "image" - , "rating", "textInput" - , "skipHours", "skipDays" - ] + , rssDescription = fromMaybe title (pLeaf "description" es) + , rssItems = pMany "item" elementToItem es + , rssLanguage = pLeaf "language" es `mplus` pQLeaf (dcName "lang") es + , rssCopyright = pLeaf "copyright" es + , rssEditor = pLeaf "managingEditor" es `mplus` pQLeaf (dcName "creator") es + , rssWebMaster = pLeaf "webMaster" es + , rssPubDate = pLeaf "pubDate" es `mplus` pQLeaf (dcName "date") es + , rssLastUpdate = pLeaf "lastBuildDate" es `mplus` pQLeaf (dcName "date") es + , rssCategories = pMany "category" elementToCategory es + , rssGenerator = pLeaf "generator" es `mplus` pQLeaf (dcName "source") es + , rssDocs = pLeaf "docs" es + , rssCloud = pNode "cloud" es >>= elementToCloud + , rssTTL = pLeaf "ttl" es >>= readInt + , rssImage = pNode "image" es >>= elementToImage + , rssRating = pLeaf "rating" es + , rssTextInput = pNode "textInput" es >>= elementToTextInput + , rssSkipHours = pNode "skipHours" es >>= elementToSkipHours + , rssSkipDays = pNode "skipDays" es >>= elementToSkipDays + , rssChannelOther = filter ((`notElem` known_channel_elts) . elementName) es + } + where + known_channel_elts = + map + qualName + [ "title" + , "link" + , "description" + , "item" + , "language" + , "copyright" + , "managingEditor" + , "webMaster" + , "pubDate" + , "lastBuildDate" + , "category" + , "generator" + , "docs" + , "cloud" + , "ttl" + , "image" + , "rating" + , "textInput" + , "skipHours" + , "skipDays" + ] elementToImage :: XML.Element -> Maybe RSSImage elementToImage e = do - guard (elName e == qualName "image") + guard (elementName e == qualName "image") let es = children e - url <- pLeaf "url" es + url <- pLeaf "url" es title <- pLeaf "title" es - link <- pLeaf "link" es - return RSSImage - { rssImageURL = url - , rssImageTitle = title - , rssImageLink = link - , rssImageWidth = pLeaf "width" es >>= readInt - , rssImageHeight = pLeaf "height" es >>= readInt - , rssImageDesc = pLeaf "description" es - , rssImageOther = filter (\ e1 -> not (elName e1 `elem` known_image_elts)) es - } - where - known_image_elts = map qualName - [ "url", "title", "link" - , "width", "height", "description" - ] + link <- pLeaf "link" es + return + RSSImage + { rssImageURL = url + , rssImageTitle = title + , rssImageLink = link + , rssImageWidth = pLeaf "width" es >>= readInt + , rssImageHeight = pLeaf "height" es >>= readInt + , rssImageDesc = pLeaf "description" es + , rssImageOther = filter ((`notElem` known_image_elts) . elementName) es + } + where + known_image_elts = map qualName ["url", "title", "link", "width", "height", "description"] elementToCategory :: XML.Element -> Maybe RSSCategory elementToCategory e = do - guard (elName e == qualName "category") - let as = elAttribs e - return RSSCategory - { rssCategoryDomain = pAttr "domain" e - , rssCategoryAttrs = filter (\ a -> not (qName (attrKey a) `elem` known_attrs)) as - , rssCategoryValue = strContent e - } - where - known_attrs = ["domain"] + guard (elementName e == qualName "category") + let as = elementAttributes e + return + RSSCategory + { rssCategoryDomain = pAttr "domain" e + , rssCategoryAttrs = filter ((`notElem` known_attrs) . nameLocalName . attrKey) as + , rssCategoryValue = strContent e + } + where + known_attrs = ["domain"] elementToCloud :: XML.Element -> Maybe RSSCloud elementToCloud e = do - guard (elName e == qualName "cloud") - let as = elAttribs e - return RSSCloud - { rssCloudDomain = pAttr "domain" e - , rssCloudPort = pAttr "port" e - , rssCloudPath = pAttr "path" e - , rssCloudRegisterProcedure = pAttr "registerProcedure" e - , rssCloudProtocol = pAttr "protocol" e - , rssCloudAttrs = filter (\ a -> not (qName (attrKey a) `elem` known_attrs)) as - } - where - known_attrs = [ "domain", "port", "path", "registerProcedure", "protocol" ] + guard (elementName e == qualName "cloud") + let as = elementAttributes e + return + RSSCloud + { rssCloudDomain = pAttr "domain" e + , rssCloudPort = pAttr "port" e + , rssCloudPath = pAttr "path" e + , rssCloudRegisterProcedure = pAttr "registerProcedure" e + , rssCloudProtocol = pAttr "protocol" e + , rssCloudAttrs = filter ((`notElem` known_attrs) . nameLocalName . attrKey) as + } + where + known_attrs = ["domain", "port", "path", "registerProcedure", "protocol"] elementToItem :: XML.Element -> Maybe RSSItem elementToItem e = do - guard (elName e == qualName "item") + guard (elementName e == qualName "item") let es = children e - return RSSItem - { rssItemTitle = pLeaf "title" es - , rssItemLink = pLeaf "link" es - , rssItemDescription = pLeaf "description" es - , rssItemAuthor = pLeaf "author" es `mplus` pQLeaf (dcName "creator") es - , rssItemCategories = pMany "category" elementToCategory es - , rssItemComments = pLeaf "comments" es - , rssItemEnclosure = pNode "enclosure" es >>= elementToEnclosure - , rssItemGuid = pNode "guid" es >>= elementToGuid - , rssItemPubDate = pLeaf "pubDate" es `mplus` pQLeaf (dcName "date") es - , rssItemSource = pNode "source" es >>= elementToSource - , rssItemAttrs = elAttribs e - , rssItemOther = filter (\ e1 -> not (elName e1 `elem` known_item_elts)) es - } - where - known_item_elts = map qualName - [ "title", "link", "description" - , "author", "category", "comments" - , "enclosure", "guid", "pubDate" - , "source" - ] + return + RSSItem + { rssItemTitle = pLeaf "title" es + , rssItemLink = pLeaf "link" es + , rssItemDescription = pLeaf "description" es + , rssItemAuthor = pLeaf "author" es `mplus` pQLeaf (dcName "creator") es + , rssItemCategories = pMany "category" elementToCategory es + , rssItemComments = pLeaf "comments" es + , rssItemContent = pLeaf "content" es + , rssItemEnclosure = pNode "enclosure" es >>= elementToEnclosure + , rssItemGuid = pNode "guid" es >>= elementToGuid + , rssItemPubDate = pLeaf "pubDate" es `mplus` pQLeaf (dcName "date") es + , rssItemSource = pNode "source" es >>= elementToSource + , rssItemAttrs = elementAttributes e + , rssItemOther = filter ((`notElem` known_item_elts) . elementName) es + } + where + known_item_elts = + map + qualName + [ "title" + , "link" + , "description" + , "author" + , "category" + , "comments" + , "enclosure" + , "guid" + , "pubDate" + , "source" + ] elementToSource :: XML.Element -> Maybe RSSSource elementToSource e = do - guard (elName e == qualName "source") - let as = elAttribs e + guard (elementName e == qualName "source") + let as = elementAttributes e url <- pAttr "url" e - return RSSSource - { rssSourceURL = url - , rssSourceAttrs = filter (\ a -> not (qName (attrKey a) `elem` known_attrs)) as - , rssSourceTitle = strContent e - } - where - known_attrs = [ "url" ] + return + RSSSource + { rssSourceURL = url + , rssSourceAttrs = filter ((`notElem` known_attrs) . nameLocalName . attrKey) as + , rssSourceTitle = strContent e + } + where + known_attrs = ["url"] elementToEnclosure :: XML.Element -> Maybe RSSEnclosure elementToEnclosure e = do - guard (elName e == qualName "enclosure") - let as = elAttribs e + guard (elementName e == qualName "enclosure") + let as = elementAttributes e url <- pAttr "url" e - ty <- pAttr "type" e - return RSSEnclosure - { rssEnclosureURL = url - , rssEnclosureType = ty - , rssEnclosureLength = pAttr "length" e >>= readInt - , rssEnclosureAttrs = filter (\ a -> not (qName (attrKey a) `elem` known_attrs)) as - } - where - known_attrs = [ "url", "type", "length" ] + ty <- pAttr "type" e + return + RSSEnclosure + { rssEnclosureURL = url + , rssEnclosureType = ty + , rssEnclosureLength = pAttr "length" e >>= readInt + , rssEnclosureAttrs = filter ((`notElem` known_attrs) . nameLocalName . attrKey) as + } + where + known_attrs = ["url", "type", "length"] elementToGuid :: XML.Element -> Maybe RSSGuid elementToGuid e = do - guard (elName e == qualName "guid") - let as = elAttribs e - return RSSGuid - { rssGuidPermanentURL = pAttr "isPermaLink" e >>= readBool - , rssGuidAttrs = filter (\ a -> not (qName (attrKey a) `elem` known_attrs)) as - , rssGuidValue = strContent e - } - where - known_attrs = ["isPermaLink"] + guard (elementName e == qualName "guid") + let as = elementAttributes e + return + RSSGuid + { rssGuidPermanentURL = pAttr "isPermaLink" e >>= readBool + , rssGuidAttrs = filter ((`notElem` known_attrs) . nameLocalName . attrKey) as + , rssGuidValue = strContent e + } + where + known_attrs = ["isPermaLink"] elementToTextInput :: XML.Element -> Maybe RSSTextInput elementToTextInput e = do - guard (elName e == qualName "textInput") + guard (elementName e == qualName "textInput") let es = children e title <- pLeaf "title" es - desc <- pLeaf "description" es - name <- pLeaf "name" es - link <- pLeaf "link" es - return RSSTextInput - { rssTextInputTitle = title - , rssTextInputDesc = desc - , rssTextInputName = name - , rssTextInputLink = link - , rssTextInputAttrs = elAttribs e - , rssTextInputOther = filter (\ e1 -> not (elName e1 `elem` known_ti_elts)) es - } - where - known_ti_elts = map qualName - ["title", "description", "name", "link"] + desc <- pLeaf "description" es + name <- pLeaf "name" es + link <- pLeaf "link" es + return + RSSTextInput + { rssTextInputTitle = title + , rssTextInputDesc = desc + , rssTextInputName = name + , rssTextInputLink = link + , rssTextInputAttrs = elementAttributes e + , rssTextInputOther = filter ((`notElem` known_ti_elts) . elementName) es + } + where + known_ti_elts = map qualName ["title", "description", "name", "link"] elementToSkipHours :: XML.Element -> Maybe [Integer] elementToSkipHours e = do - guard (elName e == qualName "skipHours") + guard (elementName e == qualName "skipHours") -- don't bother checking that this is below limit ( <= 24) - return (pMany "hour" (readInt.strContent) (children e)) + return (pMany "hour" (readInt . strContent) (children e)) -elementToSkipDays :: XML.Element -> Maybe [String] +elementToSkipDays :: XML.Element -> Maybe [Text] elementToSkipDays e = do - guard (elName e == qualName "skipDays") + guard (elementName e == qualName "skipDays") -- don't bother checking that this is below limit ( <= 7) return (pMany "day" (return . strContent) (children e)) ---- - -readInt :: String -> Maybe Integer -readInt s = - case reads s of - ((x,_):_) -> Just x - _ -> Nothing - -readBool :: String -> Maybe Bool +readBool :: Text -> Maybe Bool readBool s = - case dropWhile isSpace s of - 't':'r':'u':'e':_ -> Just True - 'f':'a':'l':'s':'e':_ -> Just False + case Data.Text.dropWhile isSpace s of + "true" -> Just True + "false" -> Just False _ -> Nothing diff --git a/src/Text/RSS/Syntax.hs b/src/Text/RSS/Syntax.hs --- a/src/Text/RSS/Syntax.hs +++ b/src/Text/RSS/Syntax.hs @@ -12,23 +12,20 @@ -- -- For instance, to create a feed with a single item item: -- (nullRSS \"rss title\" \"link\") {rssChannel=(nullChannel \"channel title\" \"link\") {rssItems=[(nullItem \"item title\")]}} - -------------------------------------------------------------------- - - module Text.RSS.Syntax - ( RSS (..) + ( RSS(..) , URLString , DateString - , RSSChannel (..) - , RSSItem (..) - , RSSSource (..) - , RSSEnclosure (..) - , RSSCategory (..) - , RSSGuid (..) - , RSSImage (..) - , RSSCloud (..) - , RSSTextInput (..) + , RSSChannel(..) + , RSSItem(..) + , RSSSource(..) + , RSSEnclosure(..) + , RSSCategory(..) + , RSSGuid(..) + , RSSImage(..) + , RSSCloud(..) + , RSSTextInput(..) , nullRSS , nullChannel , nullItem @@ -42,275 +39,270 @@ , nullTextInput ) where -import Text.XML.Light as XML +import Prelude.Compat --- * Core Types +import Data.Text (Text) +import Data.XML.Compat +import Data.XML.Types as XML +-- * Core Types -- ^The Radio Userland version of RSS documents\/feeds. -- (versions 0.9x, 2.x) -data RSS - = RSS - { rssVersion :: String - , rssAttrs :: [XML.Attr] - , rssChannel :: RSSChannel - , rssOther :: [XML.Element] - } - deriving (Show) +data RSS = + RSS + { rssVersion :: Text + , rssAttrs :: [Attr] + , rssChannel :: RSSChannel + , rssOther :: [XML.Element] + } + deriving (Show) -type URLString = String --- | RFC 822 conforming. -type DateString = String +type URLString = Text -data RSSChannel - = RSSChannel - { rssTitle :: String - , rssLink :: URLString - , rssDescription :: String - , rssItems :: [RSSItem] - , rssLanguage :: Maybe String - , rssCopyright :: Maybe String - , rssEditor :: Maybe String - , rssWebMaster :: Maybe String - , rssPubDate :: Maybe DateString -- ^ rfc 822 conforming. - , rssLastUpdate :: Maybe DateString -- ^ rfc 822 conforming. - , rssCategories :: [RSSCategory] - , rssGenerator :: Maybe String - , rssDocs :: Maybe URLString - , rssCloud :: Maybe RSSCloud - , rssTTL :: Maybe Integer - , rssImage :: Maybe RSSImage - , rssRating :: Maybe String - , rssTextInput :: Maybe RSSTextInput - , rssSkipHours :: Maybe [Integer] - , rssSkipDays :: Maybe [String] - , rssChannelOther :: [XML.Element] - } - deriving (Show) +-- | RFC 822 conforming. +type DateString = Text -data RSSItem - = RSSItem - { rssItemTitle :: Maybe String - , rssItemLink :: Maybe URLString - , rssItemDescription :: Maybe String -- ^if not present, the title is. (per spec, at least.) - , rssItemAuthor :: Maybe String - , rssItemCategories :: [RSSCategory] - , rssItemComments :: Maybe URLString - , rssItemEnclosure :: Maybe RSSEnclosure - , rssItemGuid :: Maybe RSSGuid - , rssItemPubDate :: Maybe DateString - , rssItemSource :: Maybe RSSSource - , rssItemAttrs :: [XML.Attr] - , rssItemOther :: [XML.Element] - } - deriving (Show) +data RSSChannel = + RSSChannel + { rssTitle :: Text + , rssLink :: URLString + , rssDescription :: Text + , rssItems :: [RSSItem] + , rssLanguage :: Maybe Text + , rssCopyright :: Maybe Text + , rssEditor :: Maybe Text + , rssWebMaster :: Maybe Text + , rssPubDate :: Maybe DateString -- ^ rfc 822 conforming. + , rssLastUpdate :: Maybe DateString -- ^ rfc 822 conforming. + , rssCategories :: [RSSCategory] + , rssGenerator :: Maybe Text + , rssDocs :: Maybe URLString + , rssCloud :: Maybe RSSCloud + , rssTTL :: Maybe Integer + , rssImage :: Maybe RSSImage + , rssRating :: Maybe Text + , rssTextInput :: Maybe RSSTextInput + , rssSkipHours :: Maybe [Integer] + , rssSkipDays :: Maybe [Text] + , rssChannelOther :: [XML.Element] + } + deriving (Show) -data RSSSource - = RSSSource - { rssSourceURL :: URLString - , rssSourceAttrs :: [XML.Attr] - , rssSourceTitle :: String - } - deriving (Show) +data RSSItem = + RSSItem + { rssItemTitle :: Maybe Text + , rssItemLink :: Maybe URLString + , rssItemDescription :: Maybe Text -- ^if not present, the title is. (per spec, at least.) + , rssItemAuthor :: Maybe Text + , rssItemCategories :: [RSSCategory] + , rssItemComments :: Maybe URLString + , rssItemContent :: Maybe Text + , rssItemEnclosure :: Maybe RSSEnclosure + , rssItemGuid :: Maybe RSSGuid + , rssItemPubDate :: Maybe DateString + , rssItemSource :: Maybe RSSSource + , rssItemAttrs :: [Attr] + , rssItemOther :: [XML.Element] + } + deriving (Show) -data RSSEnclosure - = RSSEnclosure - { rssEnclosureURL :: URLString - , rssEnclosureLength :: Maybe Integer - , rssEnclosureType :: String - , rssEnclosureAttrs :: [XML.Attr] - } - deriving (Show) +data RSSSource = + RSSSource + { rssSourceURL :: URLString + , rssSourceAttrs :: [Attr] + , rssSourceTitle :: Text + } + deriving (Show) -data RSSCategory - = RSSCategory - { rssCategoryDomain :: Maybe String - , rssCategoryAttrs :: [XML.Attr] - , rssCategoryValue :: String - } - deriving (Show) +data RSSEnclosure = + RSSEnclosure + { rssEnclosureURL :: URLString + , rssEnclosureLength :: Maybe Integer + , rssEnclosureType :: Text + , rssEnclosureAttrs :: [Attr] + } + deriving (Show) -data RSSGuid - = RSSGuid - { rssGuidPermanentURL :: Maybe Bool - , rssGuidAttrs :: [XML.Attr] - , rssGuidValue :: String - } - deriving (Show) +data RSSCategory = + RSSCategory + { rssCategoryDomain :: Maybe Text + , rssCategoryAttrs :: [Attr] + , rssCategoryValue :: Text + } + deriving (Show) +data RSSGuid = + RSSGuid + { rssGuidPermanentURL :: Maybe Bool + , rssGuidAttrs :: [Attr] + , rssGuidValue :: Text + } + deriving (Show) -data RSSImage - = RSSImage - { rssImageURL :: URLString -- the URL to the image resource. - , rssImageTitle :: String - , rssImageLink :: URLString -- URL that the image resource should be an href to. - , rssImageWidth :: Maybe Integer - , rssImageHeight :: Maybe Integer - , rssImageDesc :: Maybe String - , rssImageOther :: [XML.Element] - } - deriving (Show) +data RSSImage = + RSSImage + { rssImageURL :: URLString -- the URL to the image resource. + , rssImageTitle :: Text + , rssImageLink :: URLString -- URL that the image resource should be an href to. + , rssImageWidth :: Maybe Integer + , rssImageHeight :: Maybe Integer + , rssImageDesc :: Maybe Text + , rssImageOther :: [XML.Element] + } + deriving (Show) -data RSSCloud - = RSSCloud - { rssCloudDomain :: Maybe String - , rssCloudPort :: Maybe String -- on purpose (i.e., not an int) - , rssCloudPath :: Maybe String - , rssCloudRegisterProcedure :: Maybe String - , rssCloudProtocol :: Maybe String - , rssCloudAttrs :: [XML.Attr] - } - deriving (Show) +data RSSCloud = + RSSCloud + { rssCloudDomain :: Maybe Text + , rssCloudPort :: Maybe Text -- on purpose (i.e., not an int) + , rssCloudPath :: Maybe Text + , rssCloudRegisterProcedure :: Maybe Text + , rssCloudProtocol :: Maybe Text + , rssCloudAttrs :: [Attr] + } + deriving (Show) -data RSSTextInput - = RSSTextInput - { rssTextInputTitle :: String - , rssTextInputDesc :: String - , rssTextInputName :: String - , rssTextInputLink :: URLString - , rssTextInputAttrs :: [XML.Attr] - , rssTextInputOther :: [XML.Element] - } - deriving (Show) +data RSSTextInput = + RSSTextInput + { rssTextInputTitle :: Text + , rssTextInputDesc :: Text + , rssTextInputName :: Text + , rssTextInputLink :: URLString + , rssTextInputAttrs :: [Attr] + , rssTextInputOther :: [XML.Element] + } + deriving (Show) -- * Default Constructors: - -nullRSS :: String -- ^channel title - -> URLString -- ^channel link - -> RSS +nullRSS :: + Text -- ^channel title + -> URLString -- ^channel link + -> RSS nullRSS title link = - RSS - { rssVersion = "2.0" - , rssAttrs = [] - , rssChannel = nullChannel title link - , rssOther = [] - } + RSS {rssVersion = "2.0", rssAttrs = [], rssChannel = nullChannel title link, rssOther = []} -nullChannel :: String -- ^rssTitle - -> URLString -- ^rssLink - -> RSSChannel +nullChannel :: + Text -- ^rssTitle + -> URLString -- ^rssLink + -> RSSChannel nullChannel title link = RSSChannel - { rssTitle = title - , rssLink = link - , rssDescription = title - , rssItems = [] - , rssLanguage = Nothing - , rssCopyright = Nothing - , rssEditor = Nothing - , rssWebMaster = Nothing - , rssPubDate = Nothing - , rssLastUpdate = Nothing - , rssCategories = [] - , rssGenerator = Nothing - , rssDocs = Nothing - , rssCloud = Nothing - , rssTTL = Nothing - , rssImage = Nothing - , rssRating = Nothing - , rssTextInput = Nothing - , rssSkipHours = Nothing - , rssSkipDays = Nothing - , rssChannelOther = [] - } + { rssTitle = title + , rssLink = link + , rssDescription = title + , rssItems = [] + , rssLanguage = Nothing + , rssCopyright = Nothing + , rssEditor = Nothing + , rssWebMaster = Nothing + , rssPubDate = Nothing + , rssLastUpdate = Nothing + , rssCategories = [] + , rssGenerator = Nothing + , rssDocs = Nothing + , rssCloud = Nothing + , rssTTL = Nothing + , rssImage = Nothing + , rssRating = Nothing + , rssTextInput = Nothing + , rssSkipHours = Nothing + , rssSkipDays = Nothing + , rssChannelOther = [] + } -nullItem :: String -- ^title - -> RSSItem +nullItem :: + Text -- ^title + -> RSSItem nullItem title = - RSSItem - { rssItemTitle = Just title - , rssItemLink = Nothing - , rssItemDescription = Nothing - , rssItemAuthor = Nothing - , rssItemCategories = [] - , rssItemComments = Nothing - , rssItemEnclosure = Nothing - , rssItemGuid = Nothing - , rssItemPubDate = Nothing - , rssItemSource = Nothing - , rssItemAttrs = [] - , rssItemOther = [] - } + RSSItem + { rssItemTitle = Just title + , rssItemLink = Nothing + , rssItemDescription = Nothing + , rssItemAuthor = Nothing + , rssItemCategories = [] + , rssItemComments = Nothing + , rssItemContent = Nothing + , rssItemEnclosure = Nothing + , rssItemGuid = Nothing + , rssItemPubDate = Nothing + , rssItemSource = Nothing + , rssItemAttrs = [] + , rssItemOther = [] + } -nullSource :: URLString -- ^source URL - -> String -- ^title - -> RSSSource -nullSource url title = - RSSSource - { rssSourceURL = url - , rssSourceAttrs = [] - , rssSourceTitle = title - } +nullSource :: + URLString -- ^source URL + -> Text -- ^title + -> RSSSource +nullSource url title = RSSSource {rssSourceURL = url, rssSourceAttrs = [], rssSourceTitle = title} -nullEnclosure :: URLString -- ^enclosure URL - -> Maybe Integer -- ^enclosure length - -> String -- ^enclosure type - -> RSSEnclosure +nullEnclosure :: + URLString -- ^enclosure URL + -> Maybe Integer -- ^enclosure length + -> Text -- ^enclosure type + -> RSSEnclosure nullEnclosure url mb_len ty = RSSEnclosure - { rssEnclosureURL = url - , rssEnclosureLength = mb_len - , rssEnclosureType = ty - , rssEnclosureAttrs = [] - } + { rssEnclosureURL = url + , rssEnclosureLength = mb_len + , rssEnclosureType = ty + , rssEnclosureAttrs = [] + } -newCategory :: String -- ^category Value - -> RSSCategory +newCategory :: + Text -- ^category Value + -> RSSCategory newCategory nm = - RSSCategory - { rssCategoryDomain = Nothing - , rssCategoryAttrs = [] - , rssCategoryValue = nm - } + RSSCategory {rssCategoryDomain = Nothing, rssCategoryAttrs = [], rssCategoryValue = nm} -nullGuid :: String -- ^guid value - -> RSSGuid -nullGuid v = - RSSGuid - { rssGuidPermanentURL = Nothing - , rssGuidAttrs = [] - , rssGuidValue = v - } +nullGuid :: + Text -- ^guid value + -> RSSGuid +nullGuid v = RSSGuid {rssGuidPermanentURL = Nothing, rssGuidAttrs = [], rssGuidValue = v} -nullPermaGuid :: String -- ^guid value - -> RSSGuid -nullPermaGuid v = (nullGuid v){rssGuidPermanentURL=Just True} +nullPermaGuid :: + Text -- ^guid value + -> RSSGuid +nullPermaGuid v = (nullGuid v) {rssGuidPermanentURL = Just True} -nullImage :: URLString -- ^imageURL - -> String -- ^imageTitle - -> URLString -- ^imageLink - -> RSSImage +nullImage :: + URLString -- ^imageURL + -> Text -- ^imageTitle + -> URLString -- ^imageLink + -> RSSImage nullImage url title link = RSSImage - { rssImageURL = url - , rssImageTitle = title - , rssImageLink = link - , rssImageWidth = Nothing - , rssImageHeight = Nothing - , rssImageDesc = Nothing - , rssImageOther = [] - } + { rssImageURL = url + , rssImageTitle = title + , rssImageLink = link + , rssImageWidth = Nothing + , rssImageHeight = Nothing + , rssImageDesc = Nothing + , rssImageOther = [] + } nullCloud :: RSSCloud nullCloud = RSSCloud - { rssCloudDomain = Nothing - , rssCloudPort = Nothing - , rssCloudPath = Nothing - , rssCloudRegisterProcedure = Nothing - , rssCloudProtocol = Nothing - , rssCloudAttrs = [] - } + { rssCloudDomain = Nothing + , rssCloudPort = Nothing + , rssCloudPath = Nothing + , rssCloudRegisterProcedure = Nothing + , rssCloudProtocol = Nothing + , rssCloudAttrs = [] + } -nullTextInput :: String -- ^inputTitle - -> String -- ^inputName - -> URLString -- ^inputLink - -> RSSTextInput +nullTextInput :: + Text -- ^inputTitle + -> Text -- ^inputName + -> URLString -- ^inputLink + -> RSSTextInput nullTextInput title nm link = RSSTextInput - { rssTextInputTitle = title - , rssTextInputDesc = title - , rssTextInputName = nm - , rssTextInputLink = link - , rssTextInputAttrs = [] - , rssTextInputOther = [] - } + { rssTextInputTitle = title + , rssTextInputDesc = title + , rssTextInputName = nm + , rssTextInputLink = link + , rssTextInputAttrs = [] + , rssTextInputOther = [] + } diff --git a/src/Text/RSS1/Export.hs b/src/Text/RSS1/Export.hs --- a/src/Text/RSS1/Export.hs +++ b/src/Text/RSS1/Export.hs @@ -10,181 +10,222 @@ -- Portability: portable -- -------------------------------------------------------------------- +module Text.RSS1.Export + ( xmlFeed + , textFeed + ) where -module Text.RSS1.Export (xmlFeed) where +import Prelude.Compat -import Text.XML.Light as XML +import qualified Data.Text.Util as U +import Text.DublinCore.Types import Text.RSS1.Syntax import Text.RSS1.Utils -import Text.DublinCore.Types -import Data.List -import Data.Maybe +import Data.List.Compat +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.XML.Compat +import Data.XML.Types as XML -qualNode :: (Maybe String,Maybe String) -> String -> [XML.Content] -> XML.Element -qualNode ns n cs = - blank_element - { elName = qualName ns n - , elContent = cs - } +qualNode :: (Maybe Text, Maybe Text) -> Text -> [XML.Node] -> XML.Element +qualNode ns n cs = Element {elementName = qualName ns n, elementAttributes = [], elementNodes = cs} +qualNode' :: (Text, Text) -> Text -> [XML.Node] -> XML.Element +qualNode' (uri, pre) = qualNode (Just uri, Just pre) + --- xmlFeed :: Feed -> XML.Element xmlFeed f = - (qualNode (rdfNS,rdfPrefix) "RDF" $ map Elem $ - (concat [ [xmlChannel (feedChannel f)] - , mb xmlImage (feedImage f) - , map xmlItem (feedItems f) - , mb xmlTextInput (feedTextInput f) - , map xmlTopic (feedTopics f) - , feedOther f - ] )) + (qualNode' (rdfNS, rdfPrefix) "RDF" $ + map + NodeElement + (concat + [ [xmlChannel (feedChannel f)] + , mb xmlImage (feedImage f) + , map xmlItem (feedItems f) + , mb xmlTextInput (feedTextInput f) + , map xmlTopic (feedTopics f) + , feedOther f + ])) -- should we expect these to be derived by the XML pretty printer..? - { elAttribs = nub $ - Attr (qualName (Nothing,Nothing) "xmlns") (fromJust rss10NS) : - Attr (qualName (Nothing,Just "xmlns") (fromJust rdfPrefix)) (fromJust rdfNS) : - Attr (qualName (Nothing,Just "xmlns") (fromJust synPrefix)) (fromJust synNS) : - Attr (qualName (Nothing,Just "xmlns") (fromJust taxPrefix)) (fromJust taxNS) : - Attr (qualName (Nothing,Just "xmlns") (fromJust conPrefix)) (fromJust conNS) : - Attr (qualName (Nothing,Just "xmlns") (fromJust dcPrefix)) (fromJust dcNS) : - feedAttrs f} + { elementAttributes = + nub $ + mkNAttr (qualName (Nothing, Nothing) "xmlns") rss10NS : + mkNAttr (qualName (Nothing, Just "xmlns") rdfPrefix) rdfNS : + mkNAttr (qualName (Nothing, Just "xmlns") synPrefix) synNS : + mkNAttr (qualName (Nothing, Just "xmlns") taxPrefix) taxNS : + mkNAttr (qualName (Nothing, Just "xmlns") conPrefix) conNS : + mkNAttr (qualName (Nothing, Just "xmlns") dcPrefix) dcNS : feedAttrs f + } +textFeed :: Feed -> Maybe TL.Text +textFeed = U.renderFeed xmlFeed + xmlChannel :: Channel -> XML.Element xmlChannel ch = - (qualNode (rss10NS,Nothing) "channel" $ map Elem $ - ([ xmlLeaf (rss10NS,Nothing) "title" (channelTitle ch) - , xmlLeaf (rss10NS,Nothing) "link" (channelLink ch) - , xmlLeaf (rss10NS,Nothing) "description" (channelDesc ch) + (qualNode (Just rss10NS, Nothing) "channel" $ + map + NodeElement + ([ xmlLeaf (rss10NS, Nothing) "title" (channelTitle ch) + , xmlLeaf (rss10NS, Nothing) "link" (channelLink ch) + , xmlLeaf (rss10NS, Nothing) "description" (channelDesc ch) ] ++ mb xmlTextInputURI (channelTextInputURI ch) ++ mb xmlImageURI (channelImageURI ch) ++ - xmlItemURIs (channelItemURIs ch) ++ map xmlDC (channelDC ch) ++ - concat [ mb xmlUpdatePeriod (channelUpdatePeriod ch) - , mb xmlUpdateFreq (channelUpdateFreq ch) - , mb (xmlLeaf (synNS,synPrefix) "updateBase") (channelUpdateBase ch) - ] ++ - xmlContentItems (channelContent ch) ++ - xmlTopics (channelTopics ch) ++ - channelOther ch)) - { elAttribs = ( Attr (qualName (rdfNS,rdfPrefix) "about") (channelURI ch) : - channelAttrs ch)} + xmlItemURIs (channelItemURIs ch) ++ + map xmlDC (channelDC ch) ++ + concat + [ mb xmlUpdatePeriod (channelUpdatePeriod ch) + , mb xmlUpdateFreq (channelUpdateFreq ch) + , mb (xmlLeaf (synNS, Just synPrefix) "updateBase") (channelUpdateBase ch) + ] ++ + xmlContentItems (channelContent ch) ++ xmlTopics (channelTopics ch) ++ channelOther ch)) + { elementAttributes = + mkNAttr (qualName' (rdfNS, rdfPrefix) "about") (channelURI ch) : channelAttrs ch + } xmlImageURI :: URIString -> XML.Element -xmlImageURI u = xmlEmpty (rss10NS,Nothing) "image" [Attr (rdfName "resource") u ] +xmlImageURI u = xmlEmpty (rss10NS, Nothing) "image" [mkNAttr (rdfName "resource") u] xmlImage :: Image -> XML.Element xmlImage i = - (qualNode (rss10NS,Nothing) "image" $ map Elem $ - ([ xmlLeaf (rss10NS,Nothing) "title" (imageTitle i) - , xmlLeaf (rss10NS,Nothing) "url" (imageURL i) - , xmlLeaf (rss10NS,Nothing) "link" (imageLink i) - ] ++ map xmlDC (imageDC i) ++ - imageOther i)) - { elAttribs = ( Attr (qualName (rdfNS,rdfPrefix) "about") (imageURI i) : - imageAttrs i)} + (qualNode (Just rss10NS, Nothing) "image" $ + map + NodeElement + ([ xmlLeaf (rss10NS, Nothing) "title" (imageTitle i) + , xmlLeaf (rss10NS, Nothing) "url" (imageURL i) + , xmlLeaf (rss10NS, Nothing) "link" (imageLink i) + ] ++ + map xmlDC (imageDC i) ++ imageOther i)) + {elementAttributes = mkNAttr (qualName' (rdfNS, rdfPrefix) "about") (imageURI i) : imageAttrs i} xmlItemURIs :: [URIString] -> [XML.Element] xmlItemURIs [] = [] xmlItemURIs xs = - [qualNode (rss10NS, Nothing) "items" $ - [Elem (qualNode (rdfNS,rdfPrefix) "Seq" (map toRes xs))]] - where - toRes u = Elem (xmlEmpty (rdfNS,rdfPrefix) "li" [Attr (rdfName "resource") u]) + [ qualNode + (Just rss10NS, Nothing) + "items" + [NodeElement (qualNode' (rdfNS, rdfPrefix) "Seq" (map toRes xs))] + ] + where + toRes u = NodeElement (xmlEmpty (rdfNS, Just rdfPrefix) "li" [mkNAttr (rdfName "resource") u]) xmlTextInputURI :: URIString -> XML.Element -xmlTextInputURI u = xmlEmpty (rss10NS,Nothing) "textinput" [Attr (rdfName "resource") u ] +xmlTextInputURI u = xmlEmpty (rss10NS, Nothing) "textinput" [mkNAttr (rdfName "resource") u] xmlTextInput :: TextInputInfo -> XML.Element xmlTextInput ti = - (qualNode (rss10NS, Nothing) "textinput" $ map Elem $ - [ xmlLeaf (rss10NS,Nothing) "title" (textInputTitle ti) - , xmlLeaf (rss10NS,Nothing) "description" (textInputDesc ti) - , xmlLeaf (rss10NS,Nothing) "name" (textInputName ti) - , xmlLeaf (rss10NS,Nothing) "link" (textInputLink ti) - ] ++ map xmlDC (textInputDC ti) ++ - textInputOther ti) - {elAttribs=Attr (rdfName "about") (textInputURI ti) : textInputAttrs ti} + (qualNode (Just rss10NS, Nothing) "textinput" $ + map NodeElement $ + [ xmlLeaf (rss10NS, Nothing) "title" (textInputTitle ti) + , xmlLeaf (rss10NS, Nothing) "description" (textInputDesc ti) + , xmlLeaf (rss10NS, Nothing) "name" (textInputName ti) + , xmlLeaf (rss10NS, Nothing) "link" (textInputLink ti) + ] ++ + map xmlDC (textInputDC ti) ++ textInputOther ti) + {elementAttributes = mkNAttr (rdfName "about") (textInputURI ti) : textInputAttrs ti} xmlDC :: DCItem -> XML.Element -xmlDC dc = xmlLeaf (dcNS,dcPrefix) (infoToTag (dcElt dc)) (dcText dc) +xmlDC dc = xmlLeaf (dcNS, Just dcPrefix) (infoToTag (dcElt dc)) (dcText dc) xmlUpdatePeriod :: UpdatePeriod -> XML.Element -xmlUpdatePeriod u = xmlLeaf (synNS,synPrefix) "updatePeriod" (toStr u) - where - toStr ux = - case ux of - Update_Hourly -> "hourly" - Update_Daily -> "daily" - Update_Weekly -> "weekly" - Update_Monthly -> "monthly" - Update_Yearly -> "yearly" +xmlUpdatePeriod u = xmlLeaf (synNS, Just synPrefix) "updatePeriod" (toStr u) + where + toStr ux = + case ux of + Update_Hourly -> "hourly" + Update_Daily -> "daily" + Update_Weekly -> "weekly" + Update_Monthly -> "monthly" + Update_Yearly -> "yearly" xmlUpdateFreq :: Integer -> XML.Element -xmlUpdateFreq f = xmlLeaf (synNS,synPrefix) "updateFrequency" (show f) +xmlUpdateFreq f = xmlLeaf (synNS, Just synPrefix) "updateFrequency" (T.pack $ show f) xmlContentItems :: [ContentInfo] -> [XML.Element] xmlContentItems [] = [] xmlContentItems xs = - [qualNode (conNS,conPrefix) "items" - [Elem $ qualNode (rdfNS,rdfPrefix) "Bag" - (map (\ e -> Elem (qualNode (rdfNS,rdfPrefix) "li" [Elem (xmlContentInfo e)])) - xs)]] + [ qualNode' + (conNS, conPrefix) + "items" + [ NodeElement $ + qualNode' + (rdfNS, rdfPrefix) + "Bag" + (map + (\e -> NodeElement (qualNode' (rdfNS, rdfPrefix) "li" [NodeElement (xmlContentInfo e)])) + xs) + ] + ] xmlContentInfo :: ContentInfo -> XML.Element xmlContentInfo ci = - (qualNode (conNS,conPrefix) "item" $ map Elem $ - (concat [ mb (rdfResource (conNS,conPrefix) "format") (contentFormat ci) - , mb (rdfResource (conNS,conPrefix) "encoding") (contentEncoding ci) - , mb (rdfValue []) (contentValue ci) - ])) - {elAttribs=mb (Attr (rdfName "about")) (contentURI ci)} + (qualNode' (conNS, conPrefix) "item" $ + map + NodeElement + (concat + [ mb (rdfResource (conNS, conPrefix) "format") (contentFormat ci) + , mb (rdfResource (conNS, conPrefix) "encoding") (contentEncoding ci) + , mb (rdfValue []) (contentValue ci) + ])) + {elementAttributes = mb (mkNAttr (rdfName "about")) (contentURI ci)} -rdfResource :: (Maybe String,Maybe String) -> String -> String -> XML.Element -rdfResource ns t v = xmlEmpty ns t [Attr (rdfName "resource") v ] +rdfResource :: (Text, Text) -> Text -> Text -> XML.Element +rdfResource (uri, pre) t v = xmlEmpty (uri, Just pre) t [mkNAttr (rdfName "resource") v] -rdfValue :: [XML.Attr] -> String -> XML.Element -rdfValue as s = (xmlLeaf (rdfNS,rdfPrefix) "value" s){elAttribs=as} +rdfValue :: [Attr] -> Text -> XML.Element +rdfValue as s = (xmlLeaf (rdfNS, Just rdfPrefix) "value" s) {elementAttributes = as} xmlTopics :: [URIString] -> [XML.Element] xmlTopics [] = [] xmlTopics xs = - [qualNode (taxNS,taxPrefix) "topics" - [Elem (qualNode (rdfNS,rdfPrefix) "Bag" $ - (map (Elem . rdfResource (rdfNS,rdfPrefix) "li") xs))]] + [ qualNode' + (taxNS, taxPrefix) + "topics" + [ NodeElement + (qualNode' + (rdfNS, rdfPrefix) + "Bag" + (map (NodeElement . rdfResource (rdfNS, rdfPrefix) "li") xs)) + ] + ] xmlTopic :: TaxonomyTopic -> XML.Element xmlTopic tt = - (qualNode (taxNS,taxPrefix) "topic" $ map Elem $ - (xmlLeaf (rss10NS,Nothing) "link" (taxonomyLink tt): - mb (xmlLeaf (rss10NS,Nothing) "title") (taxonomyTitle tt) ++ - mb (xmlLeaf (rss10NS,Nothing) "description") (taxonomyDesc tt) ++ - xmlTopics (taxonomyTopics tt) ++ - map xmlDC (taxonomyDC tt) ++ - taxonomyOther tt)) - {elAttribs=[Attr (rdfName "about") (taxonomyURI tt)]} + (qualNode' (taxNS, taxPrefix) "topic" $ + map + NodeElement + (xmlLeaf (rss10NS, Nothing) "link" (taxonomyLink tt) : + mb (xmlLeaf (rss10NS, Nothing) "title") (taxonomyTitle tt) ++ + mb (xmlLeaf (rss10NS, Nothing) "description") (taxonomyDesc tt) ++ + xmlTopics (taxonomyTopics tt) ++ map xmlDC (taxonomyDC tt) ++ taxonomyOther tt)) + {elementAttributes = [mkNAttr (rdfName "about") (taxonomyURI tt)]} xmlItem :: Item -> XML.Element xmlItem i = - (qualNode (rss10NS,Nothing) "item" $ map Elem $ - ([ xmlLeaf (rss10NS,Nothing) "title" (itemTitle i) - , xmlLeaf (rss10NS,Nothing) "link" (itemLink i) - ] ++ - mb (xmlLeaf (rss10NS,Nothing) "description") (itemDesc i) ++ - map xmlDC (itemDC i) ++ - xmlTopics (itemTopics i) ++ - map xmlContentInfo (itemContent i) ++ - itemOther i)) - { elAttribs = ( Attr (qualName (rdfNS,rdfPrefix) "about") (itemURI i) : - itemAttrs i)} + (qualNode (Just rss10NS, Nothing) "item" $ + map + NodeElement + ([ xmlLeaf (rss10NS, Nothing) "title" (itemTitle i) + , xmlLeaf (rss10NS, Nothing) "link" (itemLink i) + ] ++ + mb (xmlLeaf (rss10NS, Nothing) "description") (itemDesc i) ++ + map xmlDC (itemDC i) ++ + xmlTopics (itemTopics i) ++ map xmlContentInfo (itemContent i) ++ itemOther i)) + {elementAttributes = mkNAttr (qualName' (rdfNS, rdfPrefix) "about") (itemURI i) : itemAttrs i} -xmlLeaf :: (Maybe String,Maybe String) -> String -> String -> XML.Element -xmlLeaf ns tg txt = - blank_element{ elName = qualName ns tg - , elContent = [ Text blank_cdata { cdData = txt } ] - } +xmlLeaf :: (Text, Maybe Text) -> Text -> Text -> XML.Element +xmlLeaf (ns, pre) tg txt = + Element + { elementName = qualName (Just ns, pre) tg + , elementAttributes = [] + , elementNodes = [NodeContent $ ContentText txt] + } -xmlEmpty :: (Maybe String,Maybe String) -> String -> [XML.Attr] -> XML.Element -xmlEmpty ns t as = (qualNode ns t []){elAttribs=as} +xmlEmpty :: (Text, Maybe Text) -> Text -> [Attr] -> XML.Element +xmlEmpty (uri, pre) t as = (qualNode (Just uri, pre) t []) {elementAttributes = as} --- mb :: (a -> b) -> Maybe a -> [b] diff --git a/src/Text/RSS1/Import.hs b/src/Text/RSS1/Import.hs --- a/src/Text/RSS1/Import.hs +++ b/src/Text/RSS1/Import.hs @@ -10,236 +10,244 @@ -- Portability: portable -- -------------------------------------------------------------------- +module Text.RSS1.Import + ( elementToFeed + ) where -module Text.RSS1.Import (elementToFeed) where +import Prelude.Compat +import Data.XML.Compat +import Data.XML.Types as XML +import Text.DublinCore.Types import Text.RSS1.Syntax import Text.RSS1.Utils -import Text.XML.Light as XML -import Text.DublinCore.Types -import Data.Maybe (mapMaybe, fromMaybe) -import Control.Monad (guard,mplus) +import Control.Monad.Compat (guard, mplus) +import Data.Maybe (mapMaybe) +import Data.Text.Util --- elementToFeed :: XML.Element -> Maybe Feed elementToFeed e = do - guard (elName e == rdfName "RDF") - ver <- pAttr (Nothing,Nothing) "xmlns" e `mplus` rss10NS - ch <- pNode "channel" e >>= elementToChannel + guard (elementName e == rdfName "RDF") + ver <- pAttr (Nothing, Nothing) "xmlns" e `mplus` Just rss10NS + ch <- pNode "channel" e >>= elementToChannel let mbImg = pNode "image" e >>= elementToImage - let is = fromMaybe [] $ fmap elementToItems $ pNode "items" e + let is = maybe [] elementToItems $ pNode "items" e let mbTI = pNode "textinput" e >>= elementToTextInput - let ch1 = ch{channelItemURIs = is} - let its = pMany (rss10NS,Nothing) "item" elementToItem e - + let ch1 = ch {channelItemURIs = is} + let its = pMany (Just rss10NS, Nothing) "item" elementToItem e let es_rest = removeKnownElts e let as_rest = removeKnownAttrs e - return Feed - { feedVersion = ver - , feedChannel = ch1 - , feedImage = mbImg - , feedItems = its - , feedTextInput = mbTI - , feedTopics = mapMaybe elementToTaxonomyTopic $ pQNodes (qualName (taxNS,taxPrefix) "topic") e - , feedOther = es_rest - , feedAttrs = as_rest - } + return + Feed + { feedVersion = ver + , feedChannel = ch1 + , feedImage = mbImg + , feedItems = its + , feedTextInput = mbTI + , feedTopics = + mapMaybe elementToTaxonomyTopic $ pQNodes (qualName' (taxNS, taxPrefix) "topic") e + , feedOther = es_rest + , feedAttrs = as_rest + } elementToItems :: XML.Element -> [URIString] -elementToItems e = seqLeaves e +elementToItems = seqLeaves elementToTextInput :: XML.Element -> Maybe TextInputInfo elementToTextInput e = do let es = children e - uri <- pAttr (rdfNS,rdfPrefix) "about" e - ti <- pQLeaf (rss10NS,Nothing) "title" e - desc <- pQLeaf (rss10NS,Nothing) "description" e - na <- pQLeaf (rss10NS,Nothing) "name" e - li <- pQLeaf (rss10NS,Nothing) "link" e + uri <- pAttr' (rdfNS, rdfPrefix) "about" e + ti <- pQLeaf (rss10NS, Nothing) "title" e + desc <- pQLeaf (rss10NS, Nothing) "description" e + na <- pQLeaf (rss10NS, Nothing) "name" e + li <- pQLeaf (rss10NS, Nothing) "link" e let dcs = mapMaybe elementToDC es - return $ TextInputInfo - { textInputURI = uri - , textInputTitle = ti - , textInputDesc = desc - , textInputName = na - , textInputLink = li - , textInputDC = dcs - , textInputOther = es - , textInputAttrs = elAttribs e - } + return + TextInputInfo + { textInputURI = uri + , textInputTitle = ti + , textInputDesc = desc + , textInputName = na + , textInputLink = li + , textInputDC = dcs + , textInputOther = es + , textInputAttrs = elementAttributes e + } elementToItem :: XML.Element -> Maybe Item elementToItem e = do - guard (elName e == qualName (rss10NS,Nothing) "item") + guard (elementName e == qualName (Just rss10NS, Nothing) "item") let es = children e - uri <- pAttr (rdfNS,rdfPrefix) "about" e - ti <- pQLeaf (rss10NS,Nothing) "title" e - li <- pQLeaf (rss10NS,Nothing) "link" e - let desc= pQLeaf (rss10NS,Nothing) "description" e + uri <- pAttr' (rdfNS, rdfPrefix) "about" e + ti <- pQLeaf (rss10NS, Nothing) "title" e + li <- pQLeaf (rss10NS, Nothing) "link" e + let desc = pQLeaf (rss10NS, Nothing) "description" e let dcs = mapMaybe elementToDC es - let tos = fromMaybe [] (fmap bagLeaves $ pQNode (qualName (taxNS,taxPrefix) "topics") e) - let cs = mapMaybe elementToContent es + let tos = maybe [] bagLeaves $ pQNode (qualName' (taxNS, taxPrefix) "topics") e + let cs = mapMaybe elementToContent es let es_other = removeKnownElts e let as_other = removeKnownAttrs e - return Item - { itemURI = uri - , itemTitle = ti - , itemLink = li - , itemDesc = desc - , itemDC = dcs - , itemTopics = tos - , itemContent = cs - , itemOther = es_other - , itemAttrs = as_other - } + return + Item + { itemURI = uri + , itemTitle = ti + , itemLink = li + , itemDesc = desc + , itemDC = dcs + , itemTopics = tos + , itemContent = cs + , itemOther = es_other + , itemAttrs = as_other + } elementToImage :: XML.Element -> Maybe Image elementToImage e = do let es = children e - let as = elAttribs e - uri <- pAttr (rdfNS,rdfPrefix) "about" e - ti <- pLeaf "title" e - ur <- pLeaf "url" e - li <- pLeaf "link" e + let as = elementAttributes e + uri <- pAttr' (rdfNS, rdfPrefix) "about" e + ti <- pLeaf "title" e + ur <- pLeaf "url" e + li <- pLeaf "link" e let dcs = mapMaybe elementToDC es - return Image - { imageURI = uri - , imageTitle = ti - , imageURL = ur - , imageLink = li - , imageDC = dcs - , imageOther = es - , imageAttrs = as - } + return + Image + { imageURI = uri + , imageTitle = ti + , imageURL = ur + , imageLink = li + , imageDC = dcs + , imageOther = es + , imageAttrs = as + } elementToChannel :: XML.Element -> Maybe Channel elementToChannel e = do let es = children e - uri <- pAttr (rdfNS,rdfPrefix) "about" e - ti <- pLeaf "title" e - li <- pLeaf "link" e - de <- pLeaf "description" e + uri <- pAttr' (rdfNS, rdfPrefix) "about" e + ti <- pLeaf "title" e + li <- pLeaf "link" e + de <- pLeaf "description" e let mbImg = pLeaf "image" e - let is = - case fmap seqLeaves $ pNode "items" e of - Nothing -> [] - Just ss -> ss - let tinp = pLeaf "textinput" e - let dcs = mapMaybe elementToDC es - let tos = fromMaybe [] (fmap bagLeaves $ pQNode (qualName (taxNS,taxPrefix) "topics") e) - let cs = mapMaybe elementToContent es + let is = maybe [] seqLeaves $ pNode "items" e + let tinp = pLeaf "textinput" e + let dcs = mapMaybe elementToDC es + let tos = maybe [] bagLeaves $ pQNode (qualName' (taxNS, taxPrefix) "topics") e + let cs = mapMaybe elementToContent es let es_other = removeKnownElts e let as_other = removeKnownAttrs e let def_chan = Channel - { channelURI = uri - , channelTitle = ti - , channelLink = li - , channelDesc = de - , channelImageURI = mbImg - , channelItemURIs = is + { channelURI = uri + , channelTitle = ti + , channelLink = li + , channelDesc = de + , channelImageURI = mbImg + , channelItemURIs = is , channelTextInputURI = tinp - , channelDC = dcs + , channelDC = dcs , channelUpdatePeriod = Nothing - , channelUpdateFreq = Nothing - , channelUpdateBase = Nothing - , channelContent = cs - , channelTopics = tos - , channelOther = es_other - , channelAttrs = as_other + , channelUpdateFreq = Nothing + , channelUpdateBase = Nothing + , channelContent = cs + , channelTopics = tos + , channelOther = es_other + , channelAttrs = as_other } return (addSyndication e def_chan) addSyndication :: XML.Element -> Channel -> Channel addSyndication e ch = - ch{ channelUpdatePeriod = fmap toUpdatePeriod $ pQLeaf (synNS,synPrefix) "updatePeriod" e - , channelUpdateFreq = fmap read $ pQLeaf (synNS,synPrefix) "updateFrequency" e - , channelUpdateBase = pQLeaf (synNS,synPrefix) "updateBase" e + ch + { channelUpdatePeriod = toUpdatePeriod <$> pQLeaf' (synNS, synPrefix) "updatePeriod" e + , channelUpdateFreq = readInt =<< pQLeaf' (synNS, synPrefix) "updateFrequency" e + , channelUpdateBase = pQLeaf' (synNS, synPrefix) "updateBase" e } - where - toUpdatePeriod x = - case x of - "hourly" -> Update_Hourly - "daily" -> Update_Daily - "weekly" -> Update_Weekly - "monthly" -> Update_Monthly - "yearly" -> Update_Yearly - _ -> Update_Hourly -- ToDo: whine - + where + toUpdatePeriod x = + case x of + "hourly" -> Update_Hourly + "daily" -> Update_Daily + "weekly" -> Update_Weekly + "monthly" -> Update_Monthly + "yearly" -> Update_Yearly + _ -> Update_Hourly -- ToDo: whine elementToDC :: XML.Element -> Maybe DCItem elementToDC e = do - guard (qURI (elName e) == dcNS) - let dcItem x = DCItem{dcElt=x,dcText=strContent e} - return $ dcItem $ - case qName $ elName e of - "title" -> DC_Title - "creator" -> DC_Creator - "subject" -> DC_Subject - "description" -> DC_Description - "publisher" -> DC_Publisher - "contributor" -> DC_Contributor - "date" -> DC_Date - "type" -> DC_Type - "format" -> DC_Format - "identifier" -> DC_Identifier - "source" -> DC_Source - "language" -> DC_Language - "relation" -> DC_Relation - "coverage" -> DC_Coverage - "rights" -> DC_Rights - oth -> DC_Other oth + guard (nameNamespace (elementName e) == Just dcNS) + let dcItem x = DCItem {dcElt = x, dcText = strContent e} + return $ + dcItem $ + case nameLocalName $ elementName e of + "title" -> DC_Title + "creator" -> DC_Creator + "subject" -> DC_Subject + "description" -> DC_Description + "publisher" -> DC_Publisher + "contributor" -> DC_Contributor + "date" -> DC_Date + "type" -> DC_Type + "format" -> DC_Format + "identifier" -> DC_Identifier + "source" -> DC_Source + "language" -> DC_Language + "relation" -> DC_Relation + "coverage" -> DC_Coverage + "rights" -> DC_Rights + oth -> DC_Other oth elementToTaxonomyTopic :: XML.Element -> Maybe TaxonomyTopic elementToTaxonomyTopic e = do - guard (elName e == qualName (taxNS,taxPrefix) "topic") + guard (elementName e == qualName' (taxNS, taxPrefix) "topic") let es = children e - uri <- pAttr (rdfNS,rdfPrefix) "about" e - li <- pQLeaf (taxNS,taxPrefix) "link" e - return TaxonomyTopic - { taxonomyURI = uri - , taxonomyLink = li - , taxonomyTitle = pLeaf "title" e - , taxonomyDesc = pLeaf "description" e - , taxonomyTopics = fromMaybe [] (fmap bagLeaves $ pQNode (qualName (taxNS,taxPrefix) "topics") e) - , taxonomyDC = mapMaybe elementToDC es - , taxonomyOther = es - } + uri <- pAttr' (rdfNS, rdfPrefix) "about" e + li <- pQLeaf' (taxNS, taxPrefix) "link" e + return + TaxonomyTopic + { taxonomyURI = uri + , taxonomyLink = li + , taxonomyTitle = pLeaf "title" e + , taxonomyDesc = pLeaf "description" e + , taxonomyTopics = maybe [] bagLeaves $ pQNode (qualName' (taxNS, taxPrefix) "topics") e + , taxonomyDC = mapMaybe elementToDC es + , taxonomyOther = es + } elementToContent :: XML.Element -> Maybe ContentInfo elementToContent e = do - guard (elName e == qualName (conNS,conPrefix) "items") - return ContentInfo - { contentURI = pAttr (rdfNS,rdfPrefix) "about" e - , contentFormat = pQLeaf (conNS,conPrefix) "format" e - , contentEncoding = pQLeaf (conNS,conPrefix) "encoding" e - , contentValue = pQLeaf (rdfNS,rdfPrefix) "value" e - } + guard (elementName e == qualName' (conNS, conPrefix) "items") + return + ContentInfo + { contentURI = pAttr' (rdfNS, rdfPrefix) "about" e + , contentFormat = pQLeaf' (conNS, conPrefix) "format" e + , contentEncoding = pQLeaf' (conNS, conPrefix) "encoding" e + , contentValue = pQLeaf' (rdfNS, rdfPrefix) "value" e + } bagLeaves :: XML.Element -> [URIString] bagLeaves be = mapMaybe - (\ e -> do - guard (elName e == qualName (rdfNS,rdfPrefix) "li") - pAttr (rdfNS,rdfPrefix) "resource" e `mplus` - fmap strContent (pQNode (qualName (rdfNS,rdfPrefix) "li") e)) - (fromMaybe [] $ fmap children $ pQNode (qualName (rdfNS,rdfPrefix) "Bag") be) + (\e -> do + guard (elementName e == qualName' (rdfNS, rdfPrefix) "li") + pAttr' (rdfNS, rdfPrefix) "resource" e `mplus` + fmap strContent (pQNode (qualName' (rdfNS, rdfPrefix) "li") e)) + (maybe [] children $ pQNode (qualName' (rdfNS, rdfPrefix) "Bag") be) {- bagElements :: XML.Element -> [XML.Element] bagElements be = mapMaybe (\ e -> do - guard (elName e == rdfName "li") + guard (elementName e == rdfName "li") return e) (fromMaybe [] $ fmap children $ pQNode (rdfName "Bag") be) -} - seqLeaves :: XML.Element -> [URIString] seqLeaves se = mapMaybe - (\ e -> do - guard (elName e == rdfName "li") - return (strContent e)) - (fromMaybe [] $ fmap children $ pQNode (rdfName "Seq") se) + (\e -> do + guard (elementName e == rdfName "li") + return (strContent e)) + (maybe [] children $ pQNode (rdfName "Seq") se) diff --git a/src/Text/RSS1/Syntax.hs b/src/Text/RSS1/Syntax.hs --- a/src/Text/RSS1/Syntax.hs +++ b/src/Text/RSS1/Syntax.hs @@ -10,20 +10,19 @@ -- Portability: portable -- -------------------------------------------------------------------- - module Text.RSS1.Syntax ( URIString , TitleString , TimeString , TextString - , Feed (..) - , Channel (..) - , Image (..) - , Item (..) - , TextInputInfo (..) - , TaxonomyTopic (..) - , UpdatePeriod (..) - , ContentInfo (..) + , Feed(..) + , Channel(..) + , Image(..) + , Item(..) + , TextInputInfo(..) + , TaxonomyTopic(..) + , UpdatePeriod(..) + , ContentInfo(..) , nullFeed , nullChannel , nullImage @@ -33,206 +32,214 @@ , nullContentInfo ) where -import Text.XML.Light.Types as XML +import Prelude.Compat + +import Data.Text +import Data.XML.Compat +import Data.XML.Types as XML import Text.DublinCore.Types -type URIString = String -type TitleString = String -type TimeString = String -type TextString = String +type URIString = Text -data Feed - = Feed { feedVersion :: String - , feedChannel :: Channel - , feedImage :: Maybe Image - , feedItems :: [Item] - , feedTextInput :: Maybe TextInputInfo - , feedTopics :: [TaxonomyTopic] - , feedOther :: [XML.Element] - , feedAttrs :: [XML.Attr] - } - deriving (Show) +type TitleString = Text -data Channel - = Channel - { channelURI :: URIString - , channelTitle :: TitleString - , channelLink :: URIString - , channelDesc :: TextString +type TimeString = Text + +type TextString = Text + +data Feed = + Feed + { feedVersion :: Text + , feedChannel :: Channel + , feedImage :: Maybe Image + , feedItems :: [Item] + , feedTextInput :: Maybe TextInputInfo + , feedTopics :: [TaxonomyTopic] + , feedOther :: [XML.Element] + , feedAttrs :: [Attr] + } + deriving (Show) + +data Channel = + Channel + { channelURI :: URIString + , channelTitle :: TitleString + , channelLink :: URIString + , channelDesc :: TextString -- these are indirect RDF associations to elements declared -- outside the channel element in the RDF \/ feed document. - , channelImageURI :: Maybe URIString - , channelItemURIs :: [URIString] - , channelTextInputURI :: Maybe URIString - , channelDC :: [DCItem] - , channelUpdatePeriod :: Maybe UpdatePeriod - , channelUpdateFreq :: Maybe Integer - , channelUpdateBase :: Maybe TimeString -- format is yyyy-mm-ddThh:mm - , channelContent :: [ContentInfo] - , channelTopics :: [URIString] - , channelOther :: [XML.Element] - , channelAttrs :: [XML.Attr] - } - deriving (Show) - -data Image - = Image - { imageURI :: URIString -- the image resource, most likely. - , imageTitle :: TextString -- the "alt"ernative text. - , imageURL :: URIString - , imageLink :: URIString -- the href of the rendered img resource. - , imageDC :: [DCItem] - , imageOther :: [XML.Element] - , imageAttrs :: [XML.Attr] - } - deriving (Show) + , channelImageURI :: Maybe URIString + , channelItemURIs :: [URIString] + , channelTextInputURI :: Maybe URIString + , channelDC :: [DCItem] + , channelUpdatePeriod :: Maybe UpdatePeriod + , channelUpdateFreq :: Maybe Integer + , channelUpdateBase :: Maybe TimeString -- format is yyyy-mm-ddThh:mm + , channelContent :: [ContentInfo] + , channelTopics :: [URIString] + , channelOther :: [XML.Element] + , channelAttrs :: [Attr] + } + deriving (Show) -data Item - = Item - { itemURI :: URIString - , itemTitle :: TextString - , itemLink :: URIString - , itemDesc :: Maybe TextString - , itemDC :: [DCItem] - , itemTopics :: [URIString] - , itemContent :: [ContentInfo] - , itemOther :: [XML.Element] - , itemAttrs :: [XML.Attr] - } - deriving (Show) +data Image = + Image + { imageURI :: URIString -- the image resource, most likely. + , imageTitle :: TextString -- the "alt"ernative text. + , imageURL :: URIString + , imageLink :: URIString -- the href of the rendered img resource. + , imageDC :: [DCItem] + , imageOther :: [XML.Element] + , imageAttrs :: [Attr] + } + deriving (Show) -data TextInputInfo - = TextInputInfo - { textInputURI :: URIString - , textInputTitle :: TextString - , textInputDesc :: TextString - , textInputName :: TextString - , textInputLink :: URIString - , textInputDC :: [DCItem] - , textInputOther :: [XML.Element] - , textInputAttrs :: [XML.Attr] - } - deriving (Show) +data Item = + Item + { itemURI :: URIString + , itemTitle :: TextString + , itemLink :: URIString + , itemDesc :: Maybe TextString + , itemDC :: [DCItem] + , itemTopics :: [URIString] + , itemContent :: [ContentInfo] + , itemOther :: [XML.Element] + , itemAttrs :: [Attr] + } + deriving (Show) -data TaxonomyTopic - = TaxonomyTopic - { taxonomyURI :: URIString - , taxonomyLink :: URIString - , taxonomyTitle :: Maybe String - , taxonomyDesc :: Maybe String - , taxonomyTopics :: [URIString] - , taxonomyDC :: [DCItem] - , taxonomyOther :: [XML.Element] - } - deriving (Show) +data TextInputInfo = + TextInputInfo + { textInputURI :: URIString + , textInputTitle :: TextString + , textInputDesc :: TextString + , textInputName :: TextString + , textInputLink :: URIString + , textInputDC :: [DCItem] + , textInputOther :: [XML.Element] + , textInputAttrs :: [Attr] + } + deriving (Show) +data TaxonomyTopic = + TaxonomyTopic + { taxonomyURI :: URIString + , taxonomyLink :: URIString + , taxonomyTitle :: Maybe Text + , taxonomyDesc :: Maybe Text + , taxonomyTopics :: [URIString] + , taxonomyDC :: [DCItem] + , taxonomyOther :: [XML.Element] + } + deriving (Show) data UpdatePeriod - = Update_Hourly - | Update_Daily - | Update_Weekly - | Update_Monthly - | Update_Yearly - deriving (Eq, Show) + = Update_Hourly + | Update_Daily + | Update_Weekly + | Update_Monthly + | Update_Yearly + deriving (Eq, Show) -data ContentInfo - = ContentInfo - { contentURI :: Maybe URIString - , contentFormat :: Maybe URIString - , contentEncoding :: Maybe URIString - , contentValue :: Maybe String -- should be: RDFValue - } - deriving (Eq, Show) +data ContentInfo = + ContentInfo + { contentURI :: Maybe URIString + , contentFormat :: Maybe URIString + , contentEncoding :: Maybe URIString + , contentValue :: Maybe Text -- should be: RDFValue + } + deriving (Eq, Show) --default constructors: nullFeed :: URIString -> TitleString -> Feed nullFeed uri title = - Feed { feedVersion = "1.0" - , feedChannel = nullChannel uri title - , feedImage = Nothing - , feedItems = [] - , feedTextInput = Nothing - , feedTopics = [] - , feedOther = [] - , feedAttrs = [] - } + Feed + { feedVersion = "1.0" + , feedChannel = nullChannel uri title + , feedImage = Nothing + , feedItems = [] + , feedTextInput = Nothing + , feedTopics = [] + , feedOther = [] + , feedAttrs = [] + } nullChannel :: URIString -> TitleString -> Channel nullChannel uri title = - Channel - { channelURI = uri - , channelTitle = title - , channelLink = uri - , channelDesc = title - , channelImageURI = Nothing - , channelItemURIs = [] - , channelTextInputURI = Nothing - , channelDC = [] - , channelUpdatePeriod = Nothing - , channelUpdateFreq = Nothing - , channelUpdateBase = Nothing - , channelContent = [] - , channelTopics = [] - , channelOther = [] - , channelAttrs = [] - } + Channel + { channelURI = uri + , channelTitle = title + , channelLink = uri + , channelDesc = title + , channelImageURI = Nothing + , channelItemURIs = [] + , channelTextInputURI = Nothing + , channelDC = [] + , channelUpdatePeriod = Nothing + , channelUpdateFreq = Nothing + , channelUpdateBase = Nothing + , channelContent = [] + , channelTopics = [] + , channelOther = [] + , channelAttrs = [] + } -nullImage :: URIString -> String -> URIString -> Image +nullImage :: URIString -> Text -> URIString -> Image nullImage imguri title link = Image - { imageURI = imguri - , imageTitle = title - , imageURL = imguri - , imageLink = link - , imageDC = [] - , imageOther = [] - , imageAttrs = [] - } + { imageURI = imguri + , imageTitle = title + , imageURL = imguri + , imageLink = link + , imageDC = [] + , imageOther = [] + , imageAttrs = [] + } nullItem :: URIString -> TextString -> URIString -> Item nullItem uri title link = Item - { itemURI = uri - , itemTitle = title - , itemLink = link - , itemDesc = Nothing - , itemDC = [] - , itemTopics = [] - , itemContent = [] - , itemOther = [] - , itemAttrs = [] - } + { itemURI = uri + , itemTitle = title + , itemLink = link + , itemDesc = Nothing + , itemDC = [] + , itemTopics = [] + , itemContent = [] + , itemOther = [] + , itemAttrs = [] + } nullTextInputInfo :: URIString -> TextString -> TextString -> URIString -> TextInputInfo nullTextInputInfo uri title nm link = TextInputInfo - { textInputURI = uri - , textInputTitle = title - , textInputDesc = title - , textInputName = nm - , textInputLink = link - , textInputDC = [] - , textInputOther = [] - , textInputAttrs = [] - } + { textInputURI = uri + , textInputTitle = title + , textInputDesc = title + , textInputName = nm + , textInputLink = link + , textInputDC = [] + , textInputOther = [] + , textInputAttrs = [] + } nullTaxonomyTopic :: URIString -> URIString -> TaxonomyTopic nullTaxonomyTopic uri link = TaxonomyTopic - { taxonomyURI = uri - , taxonomyLink = link - , taxonomyTitle = Nothing - , taxonomyDesc = Nothing - , taxonomyTopics = [] - , taxonomyDC = [] - , taxonomyOther = [] - } + { taxonomyURI = uri + , taxonomyLink = link + , taxonomyTitle = Nothing + , taxonomyDesc = Nothing + , taxonomyTopics = [] + , taxonomyDC = [] + , taxonomyOther = [] + } nullContentInfo :: ContentInfo nullContentInfo = ContentInfo - { contentURI = Nothing - , contentFormat = Nothing - , contentEncoding = Nothing - , contentValue = Nothing - } + { contentURI = Nothing + , contentFormat = Nothing + , contentEncoding = Nothing + , contentValue = Nothing + } diff --git a/src/Text/RSS1/Utils.hs b/src/Text/RSS1/Utils.hs --- a/src/Text/RSS1/Utils.hs +++ b/src/Text/RSS1/Utils.hs @@ -10,18 +10,19 @@ -- Portability: portable -- -------------------------------------------------------------------- - module Text.RSS1.Utils ( pQNodes , pNode , pQNode , pLeaf , pQLeaf + , pQLeaf' , pAttr + , pAttr' , pMany , children , qualName - , rssPrefix + , qualName' , rss10NS , rdfPrefix , rdfNS @@ -45,101 +46,110 @@ , removeKnownAttrs ) where -import Text.XML.Light as XML +import Prelude.Compat + +import Data.XML.Compat +import Data.XML.Types as XML import Text.DublinCore.Types import Data.Maybe (listToMaybe, mapMaybe) +import Data.Text (Text) -pQNodes :: QName -> XML.Element -> [XML.Element] -pQNodes = XML.findChildren +pQNodes :: Name -> XML.Element -> [XML.Element] +pQNodes = findChildren -pNode :: String -> XML.Element -> Maybe XML.Element -pNode x e = listToMaybe (pQNodes (qualName (rss10NS,Nothing) x) e) +pNode :: Text -> XML.Element -> Maybe XML.Element +pNode x e = listToMaybe (pQNodes (qualName (Just rss10NS, Nothing) x) e) -pQNode :: QName -> XML.Element -> Maybe XML.Element -pQNode x e = listToMaybe (pQNodes x e) +pQNode :: Name -> XML.Element -> Maybe XML.Element +pQNode x e = listToMaybe (pQNodes x e) -pLeaf :: String -> XML.Element -> Maybe String -pLeaf x e = strContent `fmap` pQNode (qualName (rss10NS,Nothing) x) e +pLeaf :: Text -> XML.Element -> Maybe Text +pLeaf x e = strContent `fmap` pQNode (qualName (Just rss10NS, Nothing) x) e -pQLeaf :: (Maybe String,Maybe String) -> String -> XML.Element -> Maybe String -pQLeaf ns x e = strContent `fmap` pQNode (qualName ns x) e +pQLeaf' :: (Text, Text) -> Text -> XML.Element -> Maybe Text +pQLeaf' (ns, pre) = pQLeaf (ns, Just pre) -pAttr :: (Maybe String, Maybe String) -> String -> XML.Element -> Maybe String -pAttr ns x e = lookup (qualName ns x) [ (k,v) | Attr k v <- elAttribs e ] +pQLeaf :: (Text, Maybe Text) -> Text -> XML.Element -> Maybe Text +pQLeaf (ns, pre) x e = strContent `fmap` pQNode (qualName (Just ns, pre) x) e -pMany :: (Maybe String,Maybe String) -> String -> (XML.Element -> Maybe a) -> XML.Element -> [a] -pMany ns p f e = mapMaybe f (pQNodes (qualName ns p) e) +pAttr :: (Maybe Text, Maybe Text) -> Text -> XML.Element -> Maybe Text +pAttr ns x = attributeText (qualName ns x) -children :: XML.Element -> [XML.Element] -children e = onlyElems (elContent e) +pAttr' :: (Text, Text) -> Text -> XML.Element -> Maybe Text +pAttr' (ns, pre) = pAttr (Just ns, Just pre) -qualName :: (Maybe String, Maybe String) -> String -> QName -qualName (ns,pre) x = QName{qName=x,qURI=ns,qPrefix=pre} +pMany :: (Maybe Text, Maybe Text) -> Text -> (XML.Element -> Maybe a) -> XML.Element -> [a] +pMany ns p f e = mapMaybe f (pQNodes (qualName ns p) e) -rssPrefix, rss10NS :: Maybe String -rss10NS = Just "http://purl.org/rss/1.0/" -rssPrefix = Nothing +children :: XML.Element -> [XML.Element] +children = elementChildren -rdfPrefix, rdfNS :: Maybe String -rdfNS = Just "http://www.w3.org/1999/02/22-rdf-syntax-ns#" -rdfPrefix = Just "rdf" +qualName :: (Maybe Text, Maybe Text) -> Text -> Name +qualName (ns, pre) x = Name x ns pre -synPrefix, synNS :: Maybe String -synNS = Just "http://purl.org/rss/1.0/modules/syndication/" -synPrefix = Just "sy" +qualName' :: (Text, Text) -> Text -> Name +qualName' (ns, pre) x = Name x (Just ns) (Just pre) -taxPrefix, taxNS :: Maybe String -taxNS = Just "http://purl.org/rss/1.0/modules/taxonomy/" -taxPrefix = Just "taxo" +rss10NS :: Text +rss10NS = "http://purl.org/rss/1.0/" -conPrefix, conNS :: Maybe String -conNS = Just "http://purl.org/rss/1.0/modules/content/" -conPrefix = Just "content" +rdfPrefix, rdfNS :: Text +rdfNS = "http://www.w3.org/1999/02/22-rdf-syntax-ns#" -dcPrefix, dcNS :: Maybe String -dcNS = Just "http://purl.org/dc/elements/1.1/" -dcPrefix = Just "dc" +rdfPrefix = "rdf" -rdfName :: String -> QName -rdfName x = QName{qName=x,qURI=rdfNS,qPrefix=rdfPrefix} +synPrefix, synNS :: Text +synNS = "http://purl.org/rss/1.0/modules/syndication/" -rssName :: String -> QName -rssName x = QName{qName=x,qURI=rss10NS,qPrefix=rssPrefix} +synPrefix = "sy" -synName :: String -> QName -synName x = QName{qName=x,qURI=synNS,qPrefix=synPrefix} +taxPrefix, taxNS :: Text +taxNS = "http://purl.org/rss/1.0/modules/taxonomy/" -known_rss_elts :: [QName] -known_rss_elts = map rssName [ "channel", "item", "image", "textinput" ] +taxPrefix = "taxo" -known_syn_elts :: [QName] -known_syn_elts = map synName [ "updateBase", "updateFrequency", "updatePeriod" ] +conPrefix, conNS :: Text +conNS = "http://purl.org/rss/1.0/modules/content/" -known_dc_elts :: [QName] -known_dc_elts = map (qualName (dcNS,dcPrefix)) dc_element_names +conPrefix = "content" -known_tax_elts :: [QName] -known_tax_elts = map (qualName (taxNS,taxPrefix)) [ "topic", "topics" ] +dcPrefix, dcNS :: Text +dcNS = "http://purl.org/dc/elements/1.1/" -known_con_elts :: [QName] -known_con_elts = map (qualName (conNS,conPrefix)) [ "items", "item", "format", "encoding" ] +dcPrefix = "dc" +rdfName :: Text -> Name +rdfName x = Name x (Just rdfNS) (Just rdfPrefix) + +rssName :: Text -> Name +rssName x = Name x (Just rss10NS) Nothing + +synName :: Text -> Name +synName x = Name x (Just synNS) (Just synPrefix) + +known_rss_elts :: [Name] +known_rss_elts = map rssName ["channel", "item", "image", "textinput"] + +known_syn_elts :: [Name] +known_syn_elts = map synName ["updateBase", "updateFrequency", "updatePeriod"] + +known_dc_elts :: [Name] +known_dc_elts = map (qualName' (dcNS, dcPrefix)) dc_element_names + +known_tax_elts :: [Name] +known_tax_elts = map (qualName' (taxNS, taxPrefix)) ["topic", "topics"] + +known_con_elts :: [Name] +known_con_elts = map (qualName' (conNS, conPrefix)) ["items", "item", "format", "encoding"] + removeKnownElts :: XML.Element -> [XML.Element] -removeKnownElts e = - filter (\ e1 -> not (elName e1 `elem` known_elts)) (children e) - where - known_elts = - concat [ known_rss_elts - , known_syn_elts - , known_dc_elts - , known_con_elts - , known_tax_elts - ] +removeKnownElts e = filter (\e1 -> elementName e1 `notElem` known_elts) (elementChildren e) + where + known_elts = + concat [known_rss_elts, known_syn_elts, known_dc_elts, known_con_elts, known_tax_elts] -removeKnownAttrs :: XML.Element -> [XML.Attr] -removeKnownAttrs e = - filter (\ a -> not (attrKey a `elem` known_attrs)) (elAttribs e) - where - known_attrs = - map rdfName [ "about" ] +removeKnownAttrs :: XML.Element -> [Attr] +removeKnownAttrs e = filter ((`notElem` known_attrs) . fst) (elementAttributes e) + where + known_attrs = map rdfName ["about"] diff --git a/tests/Example.hs b/tests/Example.hs --- a/tests/Example.hs +++ b/tests/Example.hs @@ -1,16 +1,21 @@ -module Example where +module Example + ( exampleTests + ) where -import Example.CreateAtom (createAtom) -import Test.HUnit (Assertion) +import Prelude.Compat + +import Example.CreateAtom (atomFeed) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion) exampleTests :: Test -exampleTests = testGroup "Examples" - [ testCase "example code to create an atom feed typechecks" typeCheckAtom - ] +exampleTests = + testGroup "Examples" [testCase "example code to create an atom feed typechecks" typeCheckAtom] typeCheckAtom :: Assertion -typeCheckAtom = case createAtom of - _:_ -> return () - _ -> error "createAtom returned an empty String" +typeCheckAtom = + case atomFeed of + Just "" -> error "createAtom returned an empty Text" + Just _ -> return () + Nothing -> error "createAtom returned document with unresolved entities" diff --git a/tests/Example/CreateAtom.hs b/tests/Example/CreateAtom.hs --- a/tests/Example/CreateAtom.hs +++ b/tests/Example/CreateAtom.hs @@ -1,40 +1,58 @@ -module Example.CreateAtom (createAtom) where +module Example.CreateAtom + ( atomFeed + ) where +import Prelude.Compat hiding (take) + import qualified Text.Atom.Feed as Atom import qualified Text.Atom.Feed.Export as Export -import qualified Text.XML.Light.Output as XML +import Text.RSS.Utils -createAtom :: String -createAtom = feed examplePosts +import Data.Text +import Data.Text.Lazy (toStrict) +import Text.XML -examplePosts :: [(String, String, String)] -- Date, URL, Content +atomFeed :: Maybe Text +atomFeed = renderFeed examplePosts + +data Post = + Post + { _postedOn :: Text + , _url :: Text + , _content :: Text + } + +examplePosts :: [Post] examplePosts = - [ ("2000-02-02T18:30:00Z", "http://example.com/2", "Bar.") - , ("2000-01-01T18:30:00Z", "http://example.com/1", "Foo.") - ] + [ Post "2000-02-02T18:30:00Z" "http://example.com/2" "Bar." + , Post "2000-01-01T18:30:00Z" "http://example.com/1" "Foo." + ] -feed :: [(String, String, String)] -> String +toEntry :: Post -> Atom.Entry +toEntry (Post date url content) = + (Atom.nullEntry + url -- The ID field. Must be a link to validate. + (Atom.TextString (take 20 content)) -- Title + date) + { Atom.entryAuthors = [Atom.nullPerson {Atom.personName = "J. Smith"}] + , Atom.entryLinks = [Atom.nullLink url] + , Atom.entryContent = Just (Atom.HTMLContent content) + } + +feed :: [Post] -> Atom.Feed feed posts = - XML.ppElement . Export.xmlFeed $ fd - { Atom.feedEntries = fmap toEntry posts - , Atom.feedLinks = [Atom.nullLink "http://example.com/"] - } - where - fd :: Atom.Feed - fd = Atom.nullFeed - "http://example.com/atom.xml" -- ID - (Atom.TextString "Example Website") -- Title - (case posts of -- Updated - (latestPostDate,_,_):_ -> latestPostDate - _ -> "") + Atom.nullFeed + "http://example.com/atom.xml" -- ID + (Atom.TextString "Example Website") -- Title + (case posts -- Updated + of + Post latestPostDate _ _:_ -> latestPostDate + _ -> "") - toEntry :: (String, String, String) -> Atom.Entry - toEntry (date, url, content) = - (Atom.nullEntry - url -- The ID field. Must be a link to validate. - (Atom.TextString (take 20 content)) -- Title - date) - { Atom.entryAuthors = [Atom.nullPerson {Atom.personName = "J. Smith"}] - , Atom.entryLinks = [Atom.nullLink url] - , Atom.entryContent = Just (Atom.HTMLContent content) - } +renderFeed :: [Post] -> Maybe Text +renderFeed posts = + fmap (toStrict . renderText def) $ + elementToDoc $ + Export.xmlFeed $ + (feed posts) + {Atom.feedEntries = fmap toEntry posts, Atom.feedLinks = [Atom.nullLink "http://example.com/"]} diff --git a/tests/ImportExport.hs b/tests/ImportExport.hs new file mode 100644 --- /dev/null +++ b/tests/ImportExport.hs @@ -0,0 +1,44 @@ +module ImportExport + ( importExportTests + ) where + +import Prelude.Compat + +import Data.Generics (everywhere, mkT) +import Data.Text (strip) +import qualified Data.Text.Lazy.IO as T +import qualified Data.XML.Types as XML +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) +import qualified Text.XML as C + +import Text.Feed.Export (xmlFeed) +import Text.Feed.Import (readAtom) +import Text.Feed.Types (Feed) +import Text.RSS.Utils (elementToDoc) + +import Paths_feed + +importExportTests :: Test +importExportTests = + testGroup "ImportExport" [testImportExport readAtom "tests/files/import_export_atom.xml"] + +testImportExport :: (XML.Element -> Maybe Feed) -> FilePath -> Test +testImportExport readFeed fileName = + testCase fileName $ do + input <- T.readFile =<< getDataFileName fileName + let inputXml = C.parseText_ C.def input + let Just feed = readFeed $ C.toXMLElement $ C.documentRoot inputXml + let Just outputXml = elementToDoc $ xmlFeed feed + let output = C.renderText C.def outputXml + let input' = C.renderText C.def $ stripXmlWhitespace inputXml + input' @=? output + +stripXmlWhitespace :: C.Document -> C.Document +stripXmlWhitespace = everywhere (mkT stripWhitespaceNodes) + where + stripWhitespaceNodes e = e {C.elementNodes = filter (not . isWhite) (C.elementNodes e)} + isWhite (C.NodeContent t) = strip t == "" + isWhite (C.NodeComment _) = True + isWhite _ = False diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,15 +1,18 @@ -module Main (main) where +module Main + ( main + ) where +import Prelude.Compat + import Example (exampleTests) +import ImportExport (importExportTests) import Test.Framework (defaultMain) -import Text.RSS.Tests (rssTests) import Text.Atom.Tests (atomTests) +import Text.Atom.Validate.Tests (atomValidateTests) import Text.Feed.Util.Tests (feedUtilTests) +import Text.RSS.Tests (rssTests) main :: IO () -main = defaultMain - [ rssTests - , atomTests - , feedUtilTests - , exampleTests - ] +main = + defaultMain + [rssTests, atomTests, atomValidateTests, feedUtilTests, exampleTests, importExportTests] diff --git a/tests/Text/Atom/Tests.hs b/tests/Text/Atom/Tests.hs --- a/tests/Text/Atom/Tests.hs +++ b/tests/Text/Atom/Tests.hs @@ -1,33 +1,38 @@ -module Text.Atom.Tests where +module Text.Atom.Tests + ( atomTests + ) where +import Prelude.Compat + import Data.Maybe (isJust) import Test.Framework (Test, mutuallyExclusive, testGroup) -import Test.HUnit (Assertion, assertBool) import Test.Framework.Providers.HUnit (testCase) -import Text.Atom.Feed -import Text.Feed.Export -import Text.Feed.Import +import Test.HUnit (Assertion, assertBool) +import Text.XML + +import Text.Atom.Feed (TextContent(TextString), entryLinks, nullEntry, nullLink) +import Text.Feed.Export (xmlFeed) +import Text.Feed.Import (parseFeedFromFile) import Text.Feed.Query import Text.Feed.Types -import Text.XML.Light +import Text.RSS.Utils import Paths_feed atomTests :: Test -atomTests = testGroup "Text.Atom" - [ mutuallyExclusive $ testGroup "Atom" - [ testFullAtomParse - , testAtomAlternate - ] - ] +atomTests = + testGroup + "Text.Atom" + [mutuallyExclusive $ testGroup "Atom" [testFullAtomParse, testAtomAlternate]] testFullAtomParse :: Test testFullAtomParse = testCase "parse a complete atom file" testAtom where testAtom :: Assertion testAtom = do - putStrLn . ppTopElement . xmlFeed =<< parseFeedFromFile =<< getDataFileName "tests/files/atom.xml" - assertBool "OK" True + contents <- parseFeedFromFile =<< getDataFileName "tests/files/atom.xml" + let res = fmap (renderText def) . (>>= elementToDoc) . fmap xmlFeed $ contents + assertBool "Atom Parsing" $ isJust res testAtomAlternate :: Test testAtomAlternate = testCase "*unspecified* link relation means 'alternate'" testAlt @@ -35,5 +40,5 @@ testAlt :: Assertion testAlt = let nullent = nullEntry "" (TextString "") "" - item = AtomItem nullent { entryLinks = [nullLink ""] } - in assertBool "unspecified means alternate" $ isJust $ getItemLink item + item = AtomItem nullent {entryLinks = [nullLink ""]} + in assertBool "unspecified means alternate" $ isJust $ getItemLink item diff --git a/tests/Text/Atom/Validate/Tests.hs b/tests/Text/Atom/Validate/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Atom/Validate/Tests.hs @@ -0,0 +1,34 @@ +module Text.Atom.Validate.Tests + ( atomValidateTests + ) where + +import Prelude.Compat + +import Data.Text (Text) +import Data.Text.Lazy (fromStrict) + +import Data.XML.Types + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assertEqual) + +import Text.Atom.Feed.Validate + +import qualified Text.XML as C + +atomValidateTests :: Test +atomValidateTests = testGroup "Text.Atom.Validate" [testAtomValidate] + +sampleEntryText :: Text +sampleEntryText = + "http://example.comexample2000-01-01T00:00:00ZNobody
This is XHTML content.
" + +testAtomValidate :: Test +testAtomValidate = testCase "simple entry is valid" testValid + where + testValid :: Assertion + testValid = do + let document = C.toXMLDocument $ C.parseText_ C.def $ fromStrict sampleEntryText + let entry = documentRoot document + assertEqual "" [] $ flattenT $ validateEntry entry diff --git a/tests/Text/Feed/Util/Tests.hs b/tests/Text/Feed/Util/Tests.hs --- a/tests/Text/Feed/Util/Tests.hs +++ b/tests/Text/Feed/Util/Tests.hs @@ -1,30 +1,41 @@ -module Text.Feed.Util.Tests where +module Text.Feed.Util.Tests + ( feedUtilTests + ) where +import Prelude.Compat + import Data.Time import Data.Time.Clock.POSIX +import System.Time import Test.Framework (Test, testGroup) -import Test.HUnit (Assertion, assertEqual) import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assertEqual) import Text.Feed.Types import Text.Feed.Util -import System.Time feedUtilTests :: Test -feedUtilTests = testGroup "Text.Feed.Util" - [ testGroup "toFeedDateString[UTC]" +feedUtilTests = + testGroup + "Text.Feed.Util" + [ testGroup + "toFeedDateString[UTC]" [ testToFeedDateString AtomKind (read "2016-01-07 15:33:29 UTC") "2016-01-07T15:33:29Z" - , testToFeedDateString (RSSKind Nothing) (read "2016-01-07 15:33:29 UTC") "Thu, 07 Jan 2016 15:33:29 GMT" - , testToFeedDateString (RDFKind Nothing) (read "2016-01-07 15:33:29 UTC") "2016-01-07T15:33:29Z" + , testToFeedDateString + (RSSKind Nothing) + (read "2016-01-07 15:33:29 UTC") + "Thu, 07 Jan 2016 15:33:29 GMT" + , testToFeedDateString + (RDFKind Nothing) + (read "2016-01-07 15:33:29 UTC") + "2016-01-07T15:33:29Z" ] ] testToFeedDateString :: FeedKind -> UTCTime -> String -> Test -testToFeedDateString kind utct expectResult = - testCase (show kind) testToDateString +testToFeedDateString kind utct expectResult = testCase (show kind) testToDateString where testToDateString :: Assertion testToDateString = do assertEqual "toFeedDateStringUTC" expectResult (toFeedDateStringUTC kind utct) assertEqual "toFeedDateString" expectResult (toFeedDateString kind clockTime) - clockTime = - TOD (truncate $ utcTimeToPOSIXSeconds utct) 0 + clockTime = TOD (truncate $ utcTimeToPOSIXSeconds utct) 0 diff --git a/tests/Text/RSS/Equals.hs b/tests/Text/RSS/Equals.hs --- a/tests/Text/RSS/Equals.hs +++ b/tests/Text/RSS/Equals.hs @@ -1,29 +1,15 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Text.RSS.Equals where -import Text.XML.Light (Element(..), Content(..), CData(..)) -import Text.RSS.Syntax (RSSCloud(..)) - -instance Eq Element where - (Element name1 attribs1 content1 line1) == (Element name2 attribs2 content2 line2) = - (name1 == name2) && (attribs1 == attribs2) && (content1 == content2) && (line1 == line2) +module Text.RSS.Equals where -instance Eq Content where - (Text data1) == (Text data2) = (data1 == data2) - (CRef text1) == (CRef text2) = (text1 == text2) - (Elem elem1) == (Elem elem2) = (elem1 == elem2) - (_) == (_) = False +import Prelude.Compat -instance Eq CData where - (CData verbatim1 data1 line1) == (CData verbatim2 data2 line2) = - (verbatim1 == verbatim2) && (data1 == data2) && (line1 == line2) +import Text.RSS.Syntax (RSSCloud(..)) instance Eq RSSCloud where - (RSSCloud rssCloudDomain1 rssCloudPort1 rssCloudPath1 rssCloudRegisterProcedure1 rssCloudProtocol1 rssCloudAttrs1) == - (RSSCloud rssCloudDomain2 rssCloudPort2 rssCloudPath2 rssCloudRegisterProcedure2 rssCloudProtocol2 rssCloudAttrs2) = - (rssCloudDomain1 == rssCloudDomain2) - && (rssCloudPort1 == rssCloudPort2) - && (rssCloudPath1 == rssCloudPath2) - && (rssCloudRegisterProcedure1 == rssCloudRegisterProcedure2) - && (rssCloudProtocol1 == rssCloudProtocol2) - && (rssCloudAttrs1 == rssCloudAttrs2) + (RSSCloud rssCloudDomain1 rssCloudPort1 rssCloudPath1 rssCloudRegisterProcedure1 rssCloudProtocol1 rssCloudAttrs1) == (RSSCloud rssCloudDomain2 rssCloudPort2 rssCloudPath2 rssCloudRegisterProcedure2 rssCloudProtocol2 rssCloudAttrs2) = + (rssCloudDomain1 == rssCloudDomain2) && + (rssCloudPort1 == rssCloudPort2) && + (rssCloudPath1 == rssCloudPath2) && + (rssCloudRegisterProcedure1 == rssCloudRegisterProcedure2) && + (rssCloudProtocol1 == rssCloudProtocol2) && (rssCloudAttrs1 == rssCloudAttrs2) diff --git a/tests/Text/RSS/Export/Tests.hs b/tests/Text/RSS/Export/Tests.hs --- a/tests/Text/RSS/Export/Tests.hs +++ b/tests/Text/RSS/Export/Tests.hs @@ -1,18 +1,26 @@ -module Text.RSS.Export.Tests where +module Text.RSS.Export.Tests + ( rssExportTests + ) where -import Test.HUnit (Assertion, assertEqual) +import Prelude.Compat + +import Data.Text (pack) +import Data.XML.Types as XML import Test.Framework (Test, mutuallyExclusive, testGroup) import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assertEqual) +import Text.RSS.Equals () import Text.RSS.Export import Text.RSS.Syntax -import Text.XML.Light as XML -import Text.RSS.Utils (createContent, createQName) -import Text.RSS.Equals () - +import Text.RSS.Utils rssExportTests :: Test -rssExportTests = testGroup "Text.RSS.Export" - [ mutuallyExclusive $ testGroup "RSS export" +rssExportTests = + testGroup + "Text.RSS.Export" + [ mutuallyExclusive $ + testGroup + "RSS export" [ testCreateXMLImage , testCreateXMLCloud , testCreateXMLTextInput @@ -25,283 +33,263 @@ ] ] -type String = [Char] - testCreateXMLImage :: Test testCreateXMLImage = testCase "should create image as xml" testImage where testImage :: Assertion testImage = do - let other = XML.Element { - elName = createQName "other" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "image other" ] :: [ Content ] - , elLine = Nothing - } - - let image = RSSImage { - rssImageURL = "image url" - , rssImageTitle = "image title" - , rssImageLink = "image link" - , rssImageWidth = Just 100 - , rssImageHeight = Just 200 - , rssImageDesc = Just "image desc" - , rssImageOther = [ other ] - } - - let expected = XML.Element { - elName = createQName "image" - , elAttribs = [] :: [ Attr ] - , elContent = [ - Elem(XML.Element { - elName = createQName "url" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "image url" ] :: [ Content ] - , elLine = Nothing - }) - , Elem(XML.Element { - elName = createQName "title" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "image title" ] :: [ Content ] - , elLine = Nothing - }) - , Elem(XML.Element { - elName = createQName "link" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "image link" ] :: [ Content ] - , elLine = Nothing - }) - , Elem(XML.Element { - elName = createQName "width" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "100" ] :: [ Content ] - , elLine = Nothing - }) - , Elem(XML.Element { - elName = createQName "height" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "200" ] :: [ Content ] - , elLine = Nothing - }) - , Elem(XML.Element { - elName = createQName "description" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "image desc" ] :: [ Content ] - , elLine = Nothing - }) - , Elem(XML.Element { - elName = createQName "other" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "image other" ] :: [ Content ] - , elLine = Nothing - }) - ] :: [ Content ] - , elLine = Nothing - } - - assertEqual "image" expected (xmlImage image) + let other = + XML.Element + { elementName = createQName "other" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "image other"] + } + let image = + RSSImage + { rssImageURL = "image url" + , rssImageTitle = "image title" + , rssImageLink = "image link" + , rssImageWidth = Just 100 + , rssImageHeight = Just 200 + , rssImageDesc = Just "image desc" + , rssImageOther = [other] + } + let expected = + XML.Element + { elementName = createQName "image" + , elementAttributes = [] :: [Attr] + , elementNodes = + [ NodeElement + XML.Element + { elementName = createQName "url" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "image url"] + } + , NodeElement + XML.Element + { elementName = createQName "title" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "image title"] + } + , NodeElement + XML.Element + { elementName = createQName "link" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "image link"] + } + , NodeElement + XML.Element + { elementName = createQName "width" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "100"] + } + , NodeElement + XML.Element + { elementName = createQName "height" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "200"] + } + , NodeElement + XML.Element + { elementName = createQName "description" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "image desc"] + } + , NodeElement + XML.Element + { elementName = createQName "other" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "image other"] + } + ] + } + assertEqual "image" expected (xmlImage image) testCreateXMLCloud :: Test testCreateXMLCloud = testCase "should create cloud as xml" testCloud where testCloud :: Assertion testCloud = do - let attr = XML.Attr { attrKey = createQName "attr" , attrVal = "text for attr" } - - let cloud = RSSCloud { - rssCloudDomain = Just "domain cloud" - , rssCloudPort = Just "port cloud" - , rssCloudPath = Just "path cloud" - , rssCloudRegisterProcedure = Just "register cloud" - , rssCloudProtocol = Just "protocol cloud" - , rssCloudAttrs = [ attr ] - } - - let expected = XML.Element { - elName = createQName "cloud" - , elAttribs = [ - XML.Attr { attrKey = createQName "domain" , attrVal = "domain cloud" } - , XML.Attr { attrKey = createQName "port" , attrVal = "port cloud" } - , XML.Attr { attrKey = createQName "path" , attrVal = "path cloud" } - , XML.Attr { attrKey = createQName "registerProcedure" , attrVal = "register cloud" } - , XML.Attr { attrKey = createQName "protocol" , attrVal = "protocol cloud" } - , attr - ] :: [ Attr ] - , elContent = [ createContent "" ] - , elLine = Nothing - } - - assertEqual "cloud" expected (xmlCloud cloud) - - + let attr = mkNAttr (createQName "attr") "text for attr" + let cloud = + RSSCloud + { rssCloudDomain = Just "domain cloud" + , rssCloudPort = Just "port cloud" + , rssCloudPath = Just "path cloud" + , rssCloudRegisterProcedure = Just "register cloud" + , rssCloudProtocol = Just "protocol cloud" + , rssCloudAttrs = [attr] + } + let expected = + XML.Element + { elementName = createQName "cloud" + , elementAttributes = + [ mkNAttr (createQName "domain") "domain cloud" + , mkNAttr (createQName "port") "port cloud" + , mkNAttr (createQName "path") "path cloud" + , mkNAttr (createQName "registerProcedure") "register cloud" + , mkNAttr (createQName "protocol") "protocol cloud" + , attr + ] :: [Attr] + , elementNodes = [createContent ""] + } + assertEqual "cloud" expected (xmlCloud cloud) testCreateXMLTextInput :: Test testCreateXMLTextInput = testCase "should create text input as xml" textInput where textInput :: Assertion textInput = do - let attr = XML.Attr { attrKey = createQName "attr" , attrVal = "text for attr" } - - let other = XML.Element { - elName = createQName "leaf" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "text for leaf" ] :: [ Content ] - , elLine = Nothing - } - - let input = RSSTextInput { - rssTextInputTitle = "title" - , rssTextInputDesc = "desc" - , rssTextInputName = "name" - , rssTextInputLink = "http://url.com" - , rssTextInputAttrs = [ attr ] - , rssTextInputOther = [ other ] - } - - let expected = XML.Element { - elName = createQName "textInput" - , elAttribs = [ attr ] :: [ Attr ] - , elContent = [ - Elem(XML.Element { - elName = createQName "title" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "title" ] :: [ Content ] - , elLine = Nothing - }) - , Elem(XML.Element { - elName = createQName "description" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "desc" ] :: [ Content ] - , elLine = Nothing - }) - , Elem(XML.Element { - elName = createQName "name" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "name" ] :: [ Content ] - , elLine = Nothing - }) - , Elem(XML.Element { - elName = createQName "link" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "http://url.com" ] :: [ Content ] - , elLine = Nothing - }) - , Elem(XML.Element { - elName = createQName "leaf" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent "text for leaf" ] :: [ Content ] - , elLine = Nothing - }) - ] :: [ Content ] - , elLine = Nothing - } - - assertEqual "text input" expected (xmlTextInput input) - - + let attr = mkNAttr (createQName "attr") "text for attr" + let other = + XML.Element + { elementName = createQName "leaf" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "text for leaf"] + } + let input = + RSSTextInput + { rssTextInputTitle = "title" + , rssTextInputDesc = "desc" + , rssTextInputName = "name" + , rssTextInputLink = "http://url.com" + , rssTextInputAttrs = [attr] + , rssTextInputOther = [other] + } + let expected = + XML.Element + { elementName = createQName "textInput" + , elementAttributes = [attr] :: [Attr] + , elementNodes = + [ NodeElement + XML.Element + { elementName = createQName "title" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "title"] + } + , NodeElement + XML.Element + { elementName = createQName "description" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "desc"] + } + , NodeElement + XML.Element + { elementName = createQName "name" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "name"] + } + , NodeElement + XML.Element + { elementName = createQName "link" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "http://url.com"] + } + , NodeElement + XML.Element + { elementName = createQName "leaf" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "text for leaf"] + } + ] + } + assertEqual "text input" expected (xmlTextInput input) testCreateEmptyXMLSkipHours :: Test -testCreateEmptyXMLSkipHours = testCase "should create an empty list of skip hours as xml" emptySkipHours +testCreateEmptyXMLSkipHours = + testCase "should create an empty list of skip hours as xml" emptySkipHours where emptySkipHours :: Assertion emptySkipHours = do - let hoursToSkip = [] - let expected = XML.Element { - elName = createQName "skipHours" - , elAttribs = [] :: [ Attr ] - , elContent = [] :: [ Content ] - , elLine = Nothing - } - - assertEqual "empty skip hours" expected (xmlSkipHours hoursToSkip) - - + let hoursToSkip = [] + let expected = + XML.Element + { elementName = createQName "skipHours" + , elementAttributes = [] :: [Attr] + , elementNodes = [] + } + assertEqual "empty skip hours" expected (xmlSkipHours hoursToSkip) testCreateXMLSkipHours :: Test testCreateXMLSkipHours = testCase "should create skip hours as xml" skipHours where skipHours :: Assertion skipHours = do - let hoursToSkip = [ 1, 2, 3 ] - let expected = XML.Element { - elName = createQName "skipHours" - , elAttribs = [] :: [ Attr ] - , elContent = [ hourElem 0, hourElem 1, hourElem 2 ] :: [ Content ] - , elLine = Nothing - } where hourElem ind = Elem(XML.Element { - elName = createQName "hour" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent $ show $ hoursToSkip !! ind ] - , elLine = Nothing - }) - - assertEqual "skip hours" expected (xmlSkipHours hoursToSkip) - - + let hoursToSkip = [1, 2, 3] + let expected = + XML.Element + { elementName = createQName "skipHours" + , elementAttributes = [] :: [Attr] + , elementNodes = [hourElem 0, hourElem 1, hourElem 2] + } + where + hourElem ind = + NodeElement + XML.Element + { elementName = createQName "hour" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent $ pack $ show $ hoursToSkip !! ind] + } + assertEqual "skip hours" expected (xmlSkipHours hoursToSkip) testCreateEmptyXMLSkipDays :: Test -testCreateEmptyXMLSkipDays = testCase "should create an empty list of skip days as xml" emptySkipDays +testCreateEmptyXMLSkipDays = + testCase "should create an empty list of skip days as xml" emptySkipDays where emptySkipDays :: Assertion emptySkipDays = do - let daysToSkip = [] - let expected = XML.Element { - elName = createQName "skipDays" - , elAttribs = [] :: [ Attr ] - , elContent = [] :: [ Content ] - , elLine = Nothing - } - - assertEqual "empty skip days" expected (xmlSkipDays daysToSkip) - - + let daysToSkip = [] + let expected = + XML.Element + { elementName = createQName "skipDays" + , elementAttributes = [] :: [Attr] + , elementNodes = [] + } + assertEqual "empty skip days" expected (xmlSkipDays daysToSkip) testCreateXMLSkipDays :: Test testCreateXMLSkipDays = testCase "should create skip days as xml" skipDays where skipDays :: Assertion skipDays = do - let daysToSkip = [ "first day", "second day", "third day" ] - let expected = XML.Element { - elName = createQName "skipDays" - , elAttribs = [] :: [ Attr ] - , elContent = [ dayElem 0, dayElem 1, dayElem 2 ] :: [ Content ] - , elLine = Nothing - } where dayElem ind = Elem(XML.Element { - elName = createQName "day" - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent $ daysToSkip !! ind ] - , elLine = Nothing - }) - - assertEqual "skip days" expected (xmlSkipDays daysToSkip) - - + let daysToSkip = ["first day", "second day", "third day"] + let expected = + XML.Element + { elementName = createQName "skipDays" + , elementAttributes = [] :: [Attr] + , elementNodes = [dayElem 0, dayElem 1, dayElem 2] + } + where + dayElem ind = + NodeElement + XML.Element + { elementName = createQName "day" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent $ daysToSkip !! ind] + } + assertEqual "skip days" expected (xmlSkipDays daysToSkip) testCreateXMLAttr :: Test testCreateXMLAttr = testCase "should create attr as xml" createXMLAttr where createXMLAttr :: Assertion createXMLAttr = do - let tg = "attr" - let txt = "example of attr value" - let expected = XML.Attr { attrKey = createQName tg, attrVal = txt } - - assertEqual "create a leaf" expected (xmlAttr tg txt) - + let tg = "attr" + let txt = "example of attr value" + let expected = mkNAttr (createQName tg) txt + assertEqual "create a leaf" expected (xmlAttr tg txt) testCreateXMLLeaf :: Test testCreateXMLLeaf = testCase "should create leaf as xml" createXMLLeaf where createXMLLeaf :: Assertion createXMLLeaf = do - let tg = "leaf" - let txt = "example of leaf text" - let expected = XML.Element { - elName = createQName tg - , elAttribs = [] :: [ Attr ] - , elContent = [ createContent txt ] :: [ Content ] - , elLine = Nothing - } - - assertEqual "create a leaf" expected (xmlLeaf tg txt) + let tg = "leaf" + let txt = "example of leaf text" + let expected = + XML.Element + { elementName = createQName tg + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent txt] + } + assertEqual "create a leaf" expected (xmlLeaf tg txt) diff --git a/tests/Text/RSS/Import/Tests.hs b/tests/Text/RSS/Import/Tests.hs --- a/tests/Text/RSS/Import/Tests.hs +++ b/tests/Text/RSS/Import/Tests.hs @@ -1,66 +1,64 @@ -module Text.RSS.Import.Tests where +module Text.RSS.Import.Tests + ( rssImportTests + ) where -import Test.HUnit (Assertion, assertEqual) +import Prelude.Compat + +import Data.XML.Types as XML import Test.Framework (Test, mutuallyExclusive, testGroup) import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assertEqual) +import Text.RSS.Equals () import Text.RSS.Import import Text.RSS.Syntax -import Text.XML.Light as XML -import Text.RSS.Utils (createContent, createQName) -import Text.RSS.Equals () - +import Text.RSS.Utils rssImportTests :: Test -rssImportTests = testGroup "Text.RSS.Import" - [ mutuallyExclusive $ testGroup "RSS import" - [ testElementToCloudIsNotCreated - , testElementToCloud - ] +rssImportTests = + testGroup + "Text.RSS.Import" + [ mutuallyExclusive $ + testGroup "RSS import" [testElementToCloudIsNotCreated, testElementToCloud] ] - - testElementToCloudIsNotCreated :: Test testElementToCloudIsNotCreated = testCase "should not create rss cloud" notCreateRSSCloud where notCreateRSSCloud :: Assertion notCreateRSSCloud = do - let notXmlCloudElement = XML.Element { elName = createQName "notCloud", elAttribs = [], elContent = [], elLine = Nothing} - - let expected = Nothing - - assertEqual "not create rss cloud" expected (elementToCloud notXmlCloudElement) - - + let notXmlCloudElement = + XML.Element + {elementName = createQName "notCloud", elementAttributes = [], elementNodes = []} + let expected = Nothing + assertEqual "not create rss cloud" expected (elementToCloud notXmlCloudElement) testElementToCloud :: Test testElementToCloud = testCase "should create rss cloud" createRSSCloud where createRSSCloud :: Assertion createRSSCloud = do - let attr = XML.Attr { attrKey = createQName "attr" , attrVal = "text for attr" } - - let xmlCloudElement = XML.Element { - elName = createQName "cloud" - , elAttribs = [ - XML.Attr { attrKey = createQName "domain" , attrVal = "domain cloud" } - , XML.Attr { attrKey = createQName "port" , attrVal = "port cloud" } - , XML.Attr { attrKey = createQName "path" , attrVal = "path cloud" } - , XML.Attr { attrKey = createQName "registerProcedure" , attrVal = "register cloud" } - , XML.Attr { attrKey = createQName "protocol" , attrVal = "protocol cloud" } - , attr - ] :: [ Attr ] - , elContent = [ createContent "" ] - , elLine = Nothing - } - - let expected = Just RSSCloud { - rssCloudDomain = Just "domain cloud" - , rssCloudPort = Just "port cloud" - , rssCloudPath = Just "path cloud" - , rssCloudRegisterProcedure = Just "register cloud" - , rssCloudProtocol = Just "protocol cloud" - , rssCloudAttrs = [ attr ] - } - - assertEqual "create rss cloud" expected (elementToCloud xmlCloudElement) + let attr = mkNAttr (createQName "attr") "text for attr" + let xmlCloudElement = + XML.Element + { elementName = createQName "cloud" + , elementAttributes = + [ mkNAttr (createQName "domain") "domain cloud" + , mkNAttr (createQName "port") "port cloud" + , mkNAttr (createQName "path") "path cloud" + , mkNAttr (createQName "registerProcedure") "register cloud" + , mkNAttr (createQName "protocol") "protocol cloud" + , attr + ] :: [Attr] + , elementNodes = [createContent ""] + } + let expected = + Just + RSSCloud + { rssCloudDomain = Just "domain cloud" + , rssCloudPort = Just "port cloud" + , rssCloudPath = Just "path cloud" + , rssCloudRegisterProcedure = Just "register cloud" + , rssCloudProtocol = Just "protocol cloud" + , rssCloudAttrs = [attr] + } + assertEqual "create rss cloud" expected (elementToCloud xmlCloudElement) diff --git a/tests/Text/RSS/Tests.hs b/tests/Text/RSS/Tests.hs --- a/tests/Text/RSS/Tests.hs +++ b/tests/Text/RSS/Tests.hs @@ -1,29 +1,34 @@ -module Text.RSS.Tests where +module Text.RSS.Tests + ( rssTests + ) where +import Prelude.Compat + +import Data.Maybe (isJust) import Test.Framework (Test, mutuallyExclusive, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assertBool) import Text.RSS.Export.Tests (rssExportTests) import Text.RSS.Import.Tests (rssImportTests) -import Test.HUnit (Assertion, assertBool) -import Test.Framework.Providers.HUnit (testCase) +import Text.XML + import Text.Feed.Export import Text.Feed.Import -import Text.XML.Light +import Text.RSS.Utils import Paths_feed rssTests :: Test -rssTests = testGroup "Text.RSS" - [ mutuallyExclusive $ testGroup "RSS" - [ rssExportTests - , rssImportTests - , testFullRss20Parse - ] - ] +rssTests = + testGroup + "Text.RSS" + [mutuallyExclusive $ testGroup "RSS" [rssExportTests, rssImportTests, testFullRss20Parse]] testFullRss20Parse :: Test testFullRss20Parse = testCase "parse a complete rss 2.0 file" testRss20 where testRss20 :: Assertion testRss20 = do - putStrLn . ppTopElement . xmlFeed =<< parseFeedFromFile =<< getDataFileName "tests/files/rss20.xml" - assertBool "OK" True + contents <- parseFeedFromFile =<< getDataFileName "tests/files/rss20.xml" + let res = fmap (renderText def) . (>>= elementToDoc) . fmap xmlFeed $ contents + assertBool "RSS 2.0 Parsing" $ isJust res diff --git a/tests/Text/RSS/Utils.hs b/tests/Text/RSS/Utils.hs --- a/tests/Text/RSS/Utils.hs +++ b/tests/Text/RSS/Utils.hs @@ -1,9 +1,22 @@ module Text.RSS.Utils where -import Text.XML.Light as XML +import Prelude.Compat -createContent :: String -> Content -createContent txt = Text blank_cdata { cdData = txt } +import Data.Text +import Data.XML.Types as XML +import Text.XML as C -createQName :: String -> QName -createQName txt = XML.QName { qName = txt, qURI = Nothing, qPrefix = Nothing } +createContent :: Text -> XML.Node +createContent = XML.NodeContent . ContentText + +createQName :: Text -> Name +createQName txt = XML.Name {nameLocalName = txt, nameNamespace = Nothing, namePrefix = Nothing} + +type Attr = (Name, [Content]) + +mkNAttr :: Name -> Text -> Attr +mkNAttr k v = (k, [ContentText v]) + +elementToDoc :: XML.Element -> Maybe C.Document +elementToDoc el = + either (const Nothing) Just $ fromXMLDocument $ XML.Document (Prologue [] Nothing []) el [] diff --git a/tests/doctest-driver.hs b/tests/doctest-driver.hs new file mode 100644 --- /dev/null +++ b/tests/doctest-driver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF doctest-driver-gen -optF README.lhs -optF -pgmL -optF markdown-unlit -optF -XOverloadedStrings -optF -XNoImplicitPrelude -optF -package -optF text -optF -package -optF xml-types #-} diff --git a/tests/files/import_export_atom.xml b/tests/files/import_export_atom.xml new file mode 100644 --- /dev/null +++ b/tests/files/import_export_atom.xml @@ -0,0 +1,35 @@ + + + Example Feed + urn:uuid:60a76c80-d399-11d9-b91C-0003939e0af6 + 2003-12-13T18:30:02Z + + + A subtitle. + + urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a + Atom-Powered Robots Run Amok + 2003-12-13T18:30:00Z + + John Doe + johndoe@example.com + +

This is the entry content.

 + + + + <div><p>This is the entry content.</p></div> + + + urn:uuid:f5ae72c9-b02e-42bc-957e-bbfe60b2c4a9 + Robot-Powered Atoms Run Amok + 2003-12-13T19:00:00Z + + John Doe + johndoe@example.com + + <div><p>This is the entry content.</p></div> + +

This is the entry content.

 + +