feed 0.3.12.0 → 1.3.2.1
raw patch · 43 files changed
Files
- CHANGELOG.md +38/−0
- README.lhs +204/−0
- README.md +197/−8
- Setup.hs +0/−1
- feed.cabal +84/−18
- src/Data/Text/Util.hs +36/−0
- src/Data/XML/Compat.hs +55/−0
- src/Text/Atom/Feed.hs +227/−230
- src/Text/Atom/Feed/Export.hs +158/−179
- src/Text/Atom/Feed/Import.hs +202/−196
- src/Text/Atom/Feed/Link.hs +45/−44
- src/Text/Atom/Feed/Validate.hs +169/−154
- src/Text/Atom/Pub.hs +31/−25
- src/Text/Atom/Pub/Export.hs +47/−48
- src/Text/DublinCore/Types.hs +62/−58
- src/Text/Feed/Constructor.hs +803/−726
- src/Text/Feed/Export.hs +20/−9
- src/Text/Feed/Import.hs +46/−34
- src/Text/Feed/Query.hs +282/−271
- src/Text/Feed/Translate.hs +42/−44
- src/Text/Feed/Types.hs +24/−21
- src/Text/Feed/Util.hs +14/−14
- src/Text/RSS/Export.hs +116/−112
- src/Text/RSS/Import.hs +220/−193
- src/Text/RSS/Syntax.hs +236/−244
- src/Text/RSS1/Export.hs +158/−117
- src/Text/RSS1/Import.hs +166/−158
- src/Text/RSS1/Syntax.hs +180/−173
- src/Text/RSS1/Utils.hs +81/−71
- tests/Example.hs +14/−9
- tests/Example/CreateAtom.hs +49/−31
- tests/ImportExport.hs +44/−0
- tests/Main.hs +11/−8
- tests/Text/Atom/Tests.hs +21/−16
- tests/Text/Atom/Validate/Tests.hs +34/−0
- tests/Text/Feed/Util/Tests.hs +22/−11
- tests/Text/RSS/Equals.hs +9/−23
- tests/Text/RSS/Export/Tests.hs +225/−237
- tests/Text/RSS/Import/Tests.hs +44/−46
- tests/Text/RSS/Tests.hs +18/−13
- tests/Text/RSS/Utils.hs +18/−5
- tests/doctest-driver.hs +1/−0
- tests/files/import_export_atom.xml +35/−0
CHANGELOG.md view
@@ -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)
+ README.lhs view
@@ -0,0 +1,204 @@+# Feed++[](http://hackage.haskell.org/package/feed)++++## 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+-- <?xml version="1.0" encoding="UTF-8"?>+-- <feed xmlns="http://www.w3.org/2005/Atom">+-- <title type="text">+-- Example Website+-- </title>+-- <id>+-- http://example.com/atom.xml+-- </id>+-- <updated>+-- 2017-08-01+-- </updated>+-- </feed>+```++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+-- <?xml version="1.0" encoding="UTF-8"?>+-- <feed xmlns="http://www.w3.org/2005/Atom">+-- <title type="text">+-- Example Website+-- </title>+-- <id>+-- http://example.com/atom.xml+-- </id>+-- <updated>+-- 2017-08-01+-- </updated>+-- <link href="http://example.com/"/>+-- <entry>+-- <id>+-- http://example.com/2+-- </id>+-- <title type="text">+-- Bar.+-- </title>+-- <updated>+-- 2000-02-02T18:30:00Z+-- </updated>+-- <author>+-- <name>+-- J. Smith+-- </name>+-- </author>+-- <content type="html">+-- Bar.+-- </content>+-- <link href="http://example.com/2"/>+-- </entry>+-- <entry>+-- <id>+-- http://example.com/1+-- </id>+-- <title type="text">+-- Foo.+-- </title>+-- <updated>+-- 2000-01-01T18:30:00Z+-- </updated>+-- <author>+-- <name>+-- J. Smith+-- </name>+-- </author>+-- <content type="html">+-- Foo.+-- </content>+-- <link href="http://example.com/1"/>+-- </entry>+-- </feed>+```++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 ()+```
README.md view
@@ -1,15 +1,204 @@-[](https://hackage.haskell.org/package/feed)-[](https://travis-ci.org/bergmark/feed)+# Feed -Interfacing with RSS (v 0.9x, 2.x, 1.0) + Atom feeds.+[](http://hackage.haskell.org/package/feed)+ -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+-- <?xml version="1.0" encoding="UTF-8"?>+-- <feed xmlns="http://www.w3.org/2005/Atom">+-- <title type="text">+-- Example Website+-- </title>+-- <id>+-- http://example.com/atom.xml+-- </id>+-- <updated>+-- 2017-08-01+-- </updated>+-- </feed>+```++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+-- <?xml version="1.0" encoding="UTF-8"?>+-- <feed xmlns="http://www.w3.org/2005/Atom">+-- <title type="text">+-- Example Website+-- </title>+-- <id>+-- http://example.com/atom.xml+-- </id>+-- <updated>+-- 2017-08-01+-- </updated>+-- <link href="http://example.com/"/>+-- <entry>+-- <id>+-- http://example.com/2+-- </id>+-- <title type="text">+-- Bar.+-- </title>+-- <updated>+-- 2000-02-02T18:30:00Z+-- </updated>+-- <author>+-- <name>+-- J. Smith+-- </name>+-- </author>+-- <content type="html">+-- Bar.+-- </content>+-- <link href="http://example.com/2"/>+-- </entry>+-- <entry>+-- <id>+-- http://example.com/1+-- </id>+-- <title type="text">+-- Foo.+-- </title>+-- <updated>+-- 2000-01-01T18:30:00Z+-- </updated>+-- <author>+-- <name>+-- J. Smith+-- </name>+-- </author>+-- <content type="html">+-- Foo.+-- </content>+-- <link href="http://example.com/1"/>+-- </entry>+-- </feed>+```++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 ()+```
Setup.hs view
@@ -2,6 +2,5 @@ import Distribution.Simple - main :: IO () main = defaultMain
feed.cabal view
@@ -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:- <https://github.com/bergmark/feed/blob/master/tests/Example/CreateAtom.hs>+ <https://github.com/haskell-party/feed/blob/master/tests/Example/CreateAtom.hs> . For basic reading and editing of feeds, consult the documentation of the Text.Feed.* hierarchy. author: Sigbjorn Finne <sof@forkIO.com> maintainer: Adam Bergmark <adam@bergmark.nl>-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
+ src/Data/Text/Util.hs view
@@ -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
+ src/Data/XML/Compat.hs view
@@ -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
src/Text/Atom/Feed.hs view
@@ -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 = []}
src/Text/Atom/Feed/Export.hs view
@@ -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]
src/Text/Atom/Feed/Import.hs view
@@ -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 "<no-title>")- 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 "<no-title>")+ 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"
src/Text/Atom/Feed/Link.hs view
@@ -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]
src/Text/Atom/Feed/Validate.hs view
@@ -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))
src/Text/Atom/Pub.hs view
@@ -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+ }
src/Text/Atom/Pub/Export.hs view
@@ -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)
src/Text/DublinCore/Types.hs view
@@ -13,75 +13,79 @@ -- see: <http://dublincore.org/> -- 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"+ ]
src/Text/Feed/Constructor.hs view
@@ -1,726 +1,803 @@------------------------------------------------------------------------ |--- Module : Text.Feed.Constructor--- Copyright : (c) Galois, Inc. 2008,--- (c) Sigbjorn Finne 2009---- License : BSD3------ Maintainer: Sigbjorn Finne <sof@forkIO.com>--- 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 <link> 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 <sof@forkIO.com>+-- 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 <link> 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
src/Text/Feed/Export.hs view
@@ -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
src/Text/Feed/Import.hs view
@@ -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
src/Text/Feed/Query.hs view
@@ -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
src/Text/Feed/Translate.hs view
@@ -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)
src/Text/Feed/Types.hs view
@@ -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)
src/Text/Feed/Util.hs view
@@ -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"
src/Text/RSS/Export.hs view
@@ -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]
src/Text/RSS/Import.hs view
@@ -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, <description/> 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
src/Text/RSS/Syntax.hs view
@@ -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 = []+ }
src/Text/RSS1/Export.hs view
@@ -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]
src/Text/RSS1/Import.hs view
@@ -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)
src/Text/RSS1/Syntax.hs view
@@ -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+ }
src/Text/RSS1/Utils.hs view
@@ -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"]
tests/Example.hs view
@@ -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"
tests/Example/CreateAtom.hs view
@@ -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/"]}
+ tests/ImportExport.hs view
@@ -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
tests/Main.hs view
@@ -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]
tests/Text/Atom/Tests.hs view
@@ -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
+ tests/Text/Atom/Validate/Tests.hs view
@@ -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 =+ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><entry xmlns=\"http://www.w3.org/2005/Atom\"><id>http://example.com</id><title type=\"text\">example</title><updated>2000-01-01T00:00:00Z</updated><author><name>Nobody</name></author><content type=\"xhtml\"><div xmlns=\"http://www.w3.org/1999/xhtml\">This is <b>XHTML</b> content.</div></content></entry>"++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
tests/Text/Feed/Util/Tests.hs view
@@ -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
tests/Text/RSS/Equals.hs view
@@ -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)
tests/Text/RSS/Export/Tests.hs view
@@ -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)
tests/Text/RSS/Import/Tests.hs view
@@ -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)
tests/Text/RSS/Tests.hs view
@@ -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
tests/Text/RSS/Utils.hs view
@@ -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 []
+ tests/doctest-driver.hs view
@@ -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 #-}
+ tests/files/import_export_atom.xml view
@@ -0,0 +1,35 @@+<?xml version="1.0" encoding="UTF-8"?>+<feed xmlns="http://www.w3.org/2005/Atom">+ <title type="text">Example Feed</title>+ <id>urn:uuid:60a76c80-d399-11d9-b91C-0003939e0af6</id>+ <updated>2003-12-13T18:30:02Z</updated>+ <link href="http://example.org/feed/" rel="self"/>+ <link href="http://example.org/"/>+ <subtitle type="text">A subtitle.</subtitle>+ <entry>+ <id>urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a</id>+ <title type="text">Atom-Powered Robots Run Amok</title>+ <updated>2003-12-13T18:30:00Z</updated>+ <author>+ <name>John Doe</name>+ <email>johndoe@example.com</email>+ </author>+ <content type="xhtml"><div xmlns="http://www.w3.org/1999/xhtml"><p>This is the entry content.</p></div></content>+ <link href="http://example.org/2003/12/13/atom03"/>+ <link href="http://example.org/2003/12/13/atom03.html" rel="alternate" type="text/html"/>+ <link href="http://example.org/2003/12/13/atom03/edit" rel="edit"/>+ <summary type="html"><div><p>This is the entry content.</p></div></summary>+ </entry>+ <entry>+ <id>urn:uuid:f5ae72c9-b02e-42bc-957e-bbfe60b2c4a9</id>+ <title type="text">Robot-Powered Atoms Run Amok</title>+ <updated>2003-12-13T19:00:00Z</updated>+ <author>+ <name>John Doe</name>+ <email>johndoe@example.com</email>+ </author>+ <content type="html"><div><p>This is the entry content.</p></div></content>+ <link href="http://example.org/2003/12/13/atom04"/>+ <summary type="xhtml"><div xmlns="http://www.w3.org/1999/xhtml"><p>This is the entry content.</p></div></summary>+ </entry>+</feed>