atom-conduit (empty) → 0.1.0.0
raw patch · 7 files changed
+1001/−0 lines, 7 filesdep +atom-conduitdep +basedep +conduitsetup-changed
Dependencies added: atom-conduit, base, conduit, conduit-parse, containers, data-default, exceptions, hlint, lens, mono-traversable, network-uri, parsers, quickcheck-instances, resourcet, tasty, tasty-hunit, tasty-quickcheck, text, time, timerep, xml-conduit, xml-conduit-parse, xml-types
Files
- LICENSE +13/−0
- Setup.hs +2/−0
- Text/Atom/Conduit/Parse.hs +312/−0
- Text/Atom/Conduit/Render.hs +148/−0
- Text/Atom/Types.hs +192/−0
- atom-conduit.cabal +70/−0
- test/Main.hs +264/−0
+ LICENSE view
@@ -0,0 +1,13 @@+DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+Version 2, December 2004++Copyright (C) 2011 koral <koral at mailoo dot org>++Everyone is permitted to copy and distribute verbatim or modified+copies of this license document, and changing it is allowed as long+as the name is changed.++DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++0. You just DO WHAT THE FUCK YOU WANT TO.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/Atom/Conduit/Parse.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+-- | Streaming parsers for the Atom 1.0 standard.+module Text.Atom.Conduit.Parse+ ( -- * Top-level+ atomFeed+ -- * Elements+ , atomEntry+ , atomContent+ , atomCategory+ , atomLink+ , atomGenerator+ , atomSource+ -- * Constructs+ , atomPerson+ , atomText+ ) where++-- {{{ Imports+import Text.Atom.Types++import Control.Applicative+import Control.Lens.Cons+import Control.Lens.Getter+import Control.Lens.Setter+import Control.Lens.TH+import Control.Lens.Tuple+import Control.Monad+import Control.Monad.Catch++import Data.Conduit+import Data.Conduit.Parser+import Data.Conduit.Parser.XML+import Data.Containers+import Data.Maybe+import Data.Monoid+import Data.MonoTraversable+import Data.NonNull+import Data.Text as Text hiding (cons, map, snoc)+import Data.Time.Clock+import Data.Time.LocalTime+import Data.Time.RFC3339+import Data.XML.Types++import GHC.Generics++import Prelude hiding (lookup)++import Network.URI++import Text.Parser.Combinators+import Text.XML+-- }}}++-- | Parse an @atom:feed@ element.+atomFeed :: (MonadCatch m) => ConduitParser Event m AtomFeed+atomFeed = named "Atom <feed> element" $ tagIgnoreAttrs "feed" $ do+ builders <- many $ choice atomFeedBuilders+ let result = (appEndo $ mconcat builders) dummy+ when (checkDummy result) $ unexpected "Missing sub-elements in <feed>."+ return result+ where atomFeedBuilders :: (MonadCatch m) => [ConduitParser Event m (Endo AtomFeed)]+ atomFeedBuilders = [ liftM (Endo . over feedAuthors_ . cons) (atomPerson "author")+ , liftM (Endo . over feedCategories_ . cons) atomCategory+ , liftM (Endo . over feedContributors_ . cons) (atomPerson "contributor")+ , liftM (Endo . over feedEntries_ . cons) atomEntry+ , liftM (Endo . set feedGenerator_ . Just) atomGenerator+ , liftM (Endo . set feedIcon_ . Just) atomIcon+ , liftM (Endo . set feedId_) atomId+ , liftM (Endo . over feedLinks_ . cons) atomLink+ , liftM (Endo . set feedLogo_ . Just) atomLogo+ , liftM (Endo . set feedRights_ . Just) (atomText "rights")+ , liftM (Endo . set feedSubtitle_ . Just) (atomText "subtitle")+ , liftM (Endo . set feedTitle_) (atomText "title")+ , liftM (Endo . set feedUpdated_) (tagDate "updated")+ , unknownTag+ ]++-- | Parse an @atom:entry@ element.+atomEntry :: (MonadCatch m) => ConduitParser Event m AtomEntry+atomEntry = named "Atom <entry> element" $ tagIgnoreAttrs "entry" $ do+ builders <- many $ choice atomEntryBuilders+ let result = (appEndo $ mconcat builders) dummy+ when (checkDummy result) $ unexpected "Missing sub-elements in <entry>."+ return result+ where atomEntryBuilders :: (MonadCatch m) => [ConduitParser Event m (Endo AtomEntry)]+ atomEntryBuilders = [ liftM (Endo . over entryAuthors_ . cons) (atomPerson "author")+ , liftM (Endo . over entryCategories_ . cons) atomCategory+ , liftM (Endo . set entryContent_ . Just) atomContent+ , liftM (Endo . over entryContributors_ . cons) (atomPerson "contributor")+ , liftM (Endo . set entryId_) atomId+ , liftM (Endo . over entryLinks_ . cons) atomLink+ , liftM (Endo . set entryPublished_ . Just) (tagDate "published")+ , liftM (Endo . set entryRights_ . Just) (atomText "rights")+ , liftM (Endo . set entrySource_ . Just) atomSource+ , liftM (Endo . set entrySummary_ . Just) (atomText "summary")+ , liftM (Endo . set entryTitle_) (atomText "title")+ , liftM (Endo . set entryUpdated_) (tagDate "updated")+ , unknownTag+ ]++-- | Parse an @atom:content@ element.+atomContent :: (MonadCatch m) => ConduitParser Event m AtomContent+atomContent = tagName' "content" contentAttrs handler+ where contentAttrs = (,) <$> optional (textAttr "type") <*> optional (attr "src" asURI) <* ignoreAttrs+ handler (Just "xhtml", _) = AtomContentInlineXHTML <$> tagIgnoreAttrs "div" textContent+ handler (ctype, Just uri) = return $ AtomContentOutOfLine (fromMaybe mempty ctype) uri+ handler (Just "html", _) = AtomContentInlineText TypeHTML <$> textContent+ handler (Nothing, _) = AtomContentInlineText TypeText <$> textContent+ handler (Just ctype, _) = AtomContentInlineOther ctype <$> textContent++-- | Parse an @atom:source@ element.+-- Example:+--+-- > <source>+-- > <id>http://example.org/</id>+-- > <title>Fourty-Two</title>+-- > <updated>2003-12-13T18:30:02Z</updated>+-- > <rights>© 2005 Example, Inc.</rights>+-- > </source>+atomSource :: (MonadCatch m) => ConduitParser Event m AtomSource+atomSource = named "Atom <source> element" $ tagIgnoreAttrs "source" $ do+ builders <- many $ choice atomSourceBuilders+ return $ (appEndo $ mconcat builders) dummy+ where atomSourceBuilders :: (MonadCatch m) => [ConduitParser Event m (Endo AtomSource)]+ atomSourceBuilders = [ liftM (Endo . over sourceAuthors_ . cons) (atomPerson "author")+ , liftM (Endo . over sourceCategories_ . cons) atomCategory+ , liftM (Endo . over sourceContributors_ . cons) (atomPerson "contributor")+ , liftM (Endo . set sourceGenerator_ . Just) atomGenerator+ , liftM (Endo . set sourceIcon_ . Just) atomIcon+ , liftM (Endo . set sourceId_ . toNullable) atomId+ , liftM (Endo . over sourceLinks_ . cons) atomLink+ , liftM (Endo . set sourceLogo_ . Just) atomLogo+ , liftM (Endo . set sourceRights_ . Just) (atomText "rights")+ , liftM (Endo . set sourceSubtitle_ . Just) (atomText "subtitle")+ , liftM (Endo . set sourceTitle_ . Just) (atomText "title")+ , liftM (Endo . set sourceUpdated_ . Just) (tagDate "updated")+ , unknownTag+ ]++-- | Parse an @atom:generator@ element.+-- Example:+--+-- > <generator uri="/myblog.php" version="1.0">+-- > Example Toolkit+-- > </generator>+atomGenerator :: (MonadCatch m) => ConduitParser Event m AtomGenerator+atomGenerator = tagName' "generator" generatorAttrs $ \(uri, version) -> AtomGenerator uri version <$> (asNonNull =<< textContent)+ where generatorAttrs = (,) <$> optional (attr "uri" asURI) <*> (textAttr "version" <|> pure mempty) <* ignoreAttrs++-- | Parse an @atom:link@ element.+-- Examples:+--+-- > <link rel="self" href="/feed" />+--+-- > <link rel="alternate" href="/blog/1234"/>+atomLink :: (MonadCatch m) => ConduitParser Event m AtomLink+atomLink = tagName' "link" linkAttrs $ \(href, rel, ltype, lang, title, length') ->+ return $ AtomLink href rel ltype lang title length'+ where linkAttrs = (,,,,,) <$> attr "href" asURI+ <*> (textAttr "rel" <|> pure mempty)+ <*> (textAttr "type" <|> pure mempty)+ <*> (textAttr "hreflang" <|> pure mempty)+ <*> (textAttr "title" <|> pure mempty)+ <*> (textAttr "length" <|> pure mempty)+ <* ignoreAttrs++-- | Parse an @atom:category@ element.+-- Example:+--+-- > <category term="sports"/>+atomCategory :: (MonadCatch m) => ConduitParser Event m AtomCategory+atomCategory = tagName "category" categoryAttrs $ \(t, s, l) -> do+ term <- asNonNull t+ return $ AtomCategory term s l+ where categoryAttrs = (,,) <$> textAttr "term"+ <*> (textAttr "scheme" <|> pure mempty)+ <*> (textAttr "label" <|> pure mempty)+ <* ignoreAttrs++-- | Parse an Atom person construct.+-- Example:+--+-- > <author>+-- > <name>John Doe</name>+-- > <email>JohnDoe@example.com</email>+-- > <uri>http://example.com/~johndoe</uri>+-- > </author>+atomPerson :: (MonadCatch m) => Text -> ConduitParser Event m AtomPerson+atomPerson name = named ("Atom person construct <" <> name <> ">") $ tagIgnoreAttrs name $ do+ builders <- many $ choice atomPersonBuilders+ case (appEndo $ mconcat builders) (Nothing, "", Nothing) of+ (Just n, e, u) -> return $ AtomPerson n e u+ _ -> unexpected "Missing person name."+ where atomPersonBuilders :: (MonadCatch m) => [ConduitParser Event m (Endo (Maybe (NonNull Text), Text, Maybe URI))]+ atomPersonBuilders = [ liftM (Endo . set _1 . Just) personName+ , liftM (Endo . set _2) personEmail+ , liftM (Endo . set _3 . Just) personURI+ , unknownTag+ ]++ personName :: MonadCatch m => ConduitParser Event m (NonNull Text)+ personName = tagIgnoreAttrs "name" (content asNonNull)++ personEmail :: MonadCatch m => ConduitParser Event m Text+ personEmail = tagIgnoreAttrs "email" textContent++ personURI :: MonadCatch m => ConduitParser Event m URI+ personURI = tagIgnoreAttrs "uri" $ content asURI++-- | Parse an Atom text construct.+-- Examples:+--+-- > <title type="text">AT&T bought by SBC!</title>+--+-- > <title type="html">+-- > AT&amp;T bought <b>by SBC</b>!+-- > </title>+--+-- > <title type="xhtml">+-- > <div xmlns="http://www.w3.org/1999/xhtml">+-- > AT&T bought <b>by SBC</b>!+-- > </div>+-- > </title>+atomText :: (MonadCatch m) => Text -> ConduitParser Event m AtomText+atomText name = named ("Atom text construct <" <> name <> ">") $ tagName' name (optional (textAttr "type") <* ignoreAttrs) handler+ where handler (Just "xhtml") = AtomXHTMLText <$> tagIgnoreAttrs "div" xhtmlContent+ handler (Just "html") = AtomPlainText TypeHTML <$> textContent+ handler _ = AtomPlainText TypeText <$> textContent+ xhtmlContent :: MonadCatch m => ConduitParser Event m Text+ xhtmlContent = mconcat <$> many (textContent <|> anyTag (\name attrs -> renderTag name attrs <$> xhtmlContent))+ renderTag name attrs content = "<" <> nameLocalName name <> renderAttrs attrs <> ">" <> content <> "</" <> nameLocalName name <> ">"+ renderAttrs [] = ""+ renderAttrs ((name, content):t) = " " <> nameLocalName name <> "=\"" <> mconcat (renderContent <$> content) <> "\"" <> renderAttrs t+ renderContent (ContentText t) = t+ renderContent (ContentEntity t) = t+++data AtomException = InvalidURI Text+ | MissingEntryTitle+ | MissingEntryUpdated+ | NullElement+ | EmptyList++deriving instance Eq AtomException+instance Show AtomException where+ show (InvalidURI t) = "Invalid URI: " ++ unpack t+ show MissingEntryTitle = "Missing entry title."+ show MissingEntryUpdated = "Missing entry's last update."+ show NullElement = "Null element."+ show EmptyList = "Empty list."+instance Exception AtomException+++asURI :: (MonadThrow m) => Text -> m URI+asURI t = maybe (throwM $ InvalidURI t) return . parseURIReference $ unpack t++asNonNull :: (MonoFoldable a, MonadThrow m) => a -> m (NonNull a)+asNonNull = maybe (throwM NullElement) return . fromNullable++-- | Like 'tagName' but ignores the namespace.+tagName' :: (MonadCatch m) => Text -> AttrParser a -> (a -> ConduitParser Event m b) -> ConduitParser Event m b+tagName' t = tagPredicate (\n -> nameLocalName n == t)++-- | Tag which content is a date-time that follows RFC 3339 format.+tagDate :: (MonadCatch m) => Text -> ConduitParser Event m UTCTime+tagDate name = tagIgnoreAttrs name $ content (fmap zonedTimeToUTC . parseTimeRFC3339)++-- | Like 'tagName'' but ignores all attributes.+tagIgnoreAttrs :: (MonadCatch m) => Text -> ConduitParser Event m a -> ConduitParser Event m a+tagIgnoreAttrs name handler = tagName' name ignoreAttrs $ const handler+++atomId :: (MonadCatch m) => ConduitParser Event m (NonNull Text)+atomId = tagIgnoreAttrs "id" $ content asNonNull++atomIcon, atomLogo :: (MonadCatch m) => ConduitParser Event m URI+atomIcon = tagIgnoreAttrs "icon" $ content asURI+atomLogo = tagIgnoreAttrs "logo" $ content asURI++unknownTag :: (MonadCatch m) => ConduitParser Event m (Endo a)+unknownTag = anyTag $ \_ _ -> many (void unknownTag <|> void textContent) >> return mempty+++class (Eq a) => Dummy a where+ dummy :: a+ checkDummy :: a -> Bool+ checkDummy = (== dummy)++instance Dummy UTCTime where+ dummy = UTCTime (toEnum 0) (secondsToDiffTime 0)+instance Dummy Text where+ dummy = " "+instance Dummy AtomText where+ dummy = AtomPlainText TypeText dummy+instance Dummy (NonNull Text) where+ dummy = nonNull dummy+instance Dummy AtomSource where+ dummy = AtomSource mzero mzero mzero mzero mzero mempty mzero mzero mzero mzero mzero mzero+instance Dummy AtomEntry where+ dummy = AtomEntry mzero mzero mzero mzero dummy mzero mzero mzero mzero mzero dummy dummy+ checkDummy (AtomEntry _ _ _ _ i _ _ _ _ _ t u) = checkDummy i && checkDummy t && checkDummy u+instance Dummy AtomFeed where+ dummy = AtomFeed mzero mzero mzero mzero mzero mzero dummy mzero mzero mzero mzero dummy dummy+ checkDummy (AtomFeed _ _ _ _ _ _ i _ _ _ _ t u) = checkDummy i && checkDummy t && checkDummy u
+ Text/Atom/Conduit/Render.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+-- | Streaming renderers for the Atom 1.0 standard.+module Text.Atom.Conduit.Render+ ( -- * Top-level+ renderAtomFeed+ -- * Elements+ , renderAtomEntry+ , renderAtomContent+ , renderAtomSource+ , renderAtomGenerator+ , renderAtomLink+ , renderAtomCategory+ -- * Constructs+ , renderAtomPerson+ , renderAtomText+ ) where++-- {{{ Imports+import Text.Atom.Types++import Control.Lens.Getter+import Control.Monad++import Data.Conduit+import Data.Foldable+import Data.Monoid+import Data.NonNull+import Data.Text as Text+import Data.Time.Clock+import Data.Time.LocalTime+import Data.Time.RFC3339+import Data.Traversable+import Data.XML.Types++import Text.XML.Stream.Render+-- }}}++-- | Render the top-level @atom:feed@ element.+renderAtomFeed :: (Monad m) => AtomFeed -> Source m Event+renderAtomFeed f = tag "feed" (attr "xmlns" "http://www.w3.org/2005/Atom") $ do+ forM_ (f^.feedAuthors_) $ renderAtomPerson "author"+ forM_ (f^.feedCategories_) renderAtomCategory+ forM_ (f^.feedContributors_) $ renderAtomPerson "contributor"+ forM_ (f^.feedEntries_) renderAtomEntry+ forM_ (f^.feedGenerator_) renderAtomGenerator+ forM_ (f^.feedIcon_) $ tag "icon" mempty . content . tshow+ tag "id" mempty . content . toNullable $ f^.feedId_+ forM_ (f^.feedLinks_) renderAtomLink+ forM_ (f^.feedLogo_) $ tag "logo" mempty . content . tshow+ forM_ (f^.feedRights_) $ renderAtomText "rights"+ forM_ (f^.feedSubtitle_) $ renderAtomText "subtitle"+ renderAtomText "title" $ f^.feedTitle_+ dateTag "updated" $ f^.feedUpdated_++-- | Render an @atom:entry@ element.+renderAtomEntry :: (Monad m) => AtomEntry -> Source m Event+renderAtomEntry e = tag "entry" mempty $ do+ forM_ (e^.entryAuthors_) $ renderAtomPerson "author"+ forM_ (e^.entryCategories_) renderAtomCategory+ forM_ (e^.entryContent_) renderAtomContent+ forM_ (e^.entryContributors_) $ renderAtomPerson "contributor"+ tag "id" mempty . content . toNullable $ e^.entryId_+ forM_ (e^.entryLinks_) renderAtomLink+ forM_ (e^.entryPublished_) $ dateTag "published"+ forM_ (e^.entryRights_) $ renderAtomText "rights"+ forM_ (e^.entrySource_) renderAtomSource+ forM_ (e^.entrySummary_) $ renderAtomText "summary"+ renderAtomText "title" (e^.entryTitle_)+ dateTag "updated" (e^.entryUpdated_)++-- | Render an @atom:content@ element.+renderAtomContent :: (Monad m) => AtomContent -> Source m Event+renderAtomContent (AtomContentInlineXHTML t) = tag "content" (attr "type" "xhtml")+ . tag "div" mempty $ content t+renderAtomContent (AtomContentOutOfLine ctype uri) = tag "content" (nonEmptyAttr "type" ctype <> attr "src" (tshow uri)) $ return ()+renderAtomContent (AtomContentInlineText TypeHTML t) = tag "content" (attr "type" "html")+ $ content t+renderAtomContent (AtomContentInlineText TypeText t) = tag "content" mempty+ $ content t+renderAtomContent (AtomContentInlineOther ctype t) = tag "content" (attr "type" ctype)+ $ content t++-- | Render an @atom:source@ element.+renderAtomSource :: (Monad m) => AtomSource -> Source m Event+renderAtomSource s = tag "source" mempty $ do+ forM_ (s^.sourceAuthors_) $ renderAtomPerson "author"+ forM_ (s^.sourceCategories_) renderAtomCategory+ forM_ (s^.sourceContributors_) $ renderAtomPerson "contributor"+ forM_ (s^.sourceGenerator_) renderAtomGenerator+ forM_ (s^.sourceIcon_) $ tag "icon" mempty . content . tshow+ unless (Text.null $ s^.sourceId_) . tag "id" mempty . content $ s^.sourceId_+ forM_ (s^.sourceLinks_) renderAtomLink+ forM_ (s^.sourceLogo_) $ tag "logo" mempty . content . tshow+ forM_ (s^.sourceRights_) $ renderAtomText "rights"+ forM_ (s^.sourceSubtitle_) $ renderAtomText "subtitle"+ forM_ (s^.sourceTitle_) $ renderAtomText "title"+ forM_ (s^.sourceUpdated_) $ dateTag "updated"++-- | Render an @atom:generator@ element.+renderAtomGenerator :: (Monad m) => AtomGenerator -> Source m Event+renderAtomGenerator g = tag "generator" attributes . content . toNullable $ g^.generatorContent_+ where attributes = optionalAttr "uri" (tshow <$> g^.generatorUri_)+ <> nonEmptyAttr "version" (g^.generatorVersion_)++-- | Render an @atom:link@ element.+renderAtomLink :: (Monad m) => AtomLink -> Source m Event+renderAtomLink l = tag "link" linkAttrs $ return ()+ where linkAttrs = attr "href" (tshow $ l^.linkHref_)+ <> nonEmptyAttr "rel" (l^.linkRel_)+ <> nonEmptyAttr "type" (l^.linkType_)+ <> nonEmptyAttr "hreflang" (l^.linkLang_)+ <> nonEmptyAttr "title" (l^.linkTitle_)+ <> nonEmptyAttr "length" (l^.linkLength_)++-- | Render an @atom:category@ element.+renderAtomCategory :: (Monad m) => AtomCategory -> Source m Event+renderAtomCategory c = tag "category" attributes $ return ()+ where attributes = attr "term" (toNullable $ c^.categoryTerm_)+ <> nonEmptyAttr "scheme" (c^.categoryScheme_)+ <> nonEmptyAttr "label" (c^.categoryLabel_)++-- | Render an atom person construct.+renderAtomPerson :: (Monad m) => Name -> AtomPerson -> Source m Event+renderAtomPerson name p = tag name mempty $ do+ tag "name" mempty . content . toNullable $ p^.personName_+ unless (Text.null $ p^.personEmail_) $ tag "email" mempty . content $ p^.personEmail_+ forM_ (p^.personUri_) $ tag "uri" mempty . content . tshow++-- | Render an atom text construct.+renderAtomText :: (Monad m) => Name -> AtomText -> Source m Event+renderAtomText name (AtomXHTMLText t) = tag name (attr "type" "xhtml")+ . tag "div" mempty $ content t+renderAtomText name (AtomPlainText TypeHTML t) = tag name (attr "type" "html") $ content t+renderAtomText name (AtomPlainText TypeText t) = tag name mempty $ content t+++tshow :: (Show a) => a -> Text+tshow = pack . show++dateTag :: (Monad m) => Name -> UTCTime -> Source m Event+dateTag name = tag name mempty . content . formatTimeRFC3339 . utcToZonedTime utc++nonEmptyAttr :: Name -> Text -> Attributes+nonEmptyAttr name value+ | value == mempty = mempty+ | otherwise = attr name value
+ Text/Atom/Types.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+-- | Atom is an XML-based Web content and metadata syndication format.+--+-- Example:+--+-- > <?xml version="1.0" encoding="utf-8"?>+-- > <feed xmlns="http://www.w3.org/2005/Atom">+-- >+-- > <title>Example Feed</title>+-- > <link href="http://example.org/"/>+-- > <updated>2003-12-13T18:30:02Z</updated>+-- > <author>+-- > <name>John Doe</name>+-- > </author>+-- > <id>urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6</id>+-- >+-- > <entry>+-- > <title>Atom-Powered Robots Run Amok</title>+-- > <link href="http://example.org/2003/12/13/atom03"/>+-- > <id>urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a</id>+-- > <updated>2003-12-13T18:30:02Z</updated>+-- > <summary>Some text.</summary>+-- > </entry>+-- >+-- > </feed>+module Text.Atom.Types where++-- {{{ Imports+import Control.Lens.TH++import Data.NonNull+import Data.Text hiding (map)+import Data.Time.Clock+import Data.Time.LocalTime+import Data.XML.Types++import GHC.Generics++import Network.URI+-- }}}++data TextType = TypeText | TypeHTML deriving(Eq, Generic, Show)++-- | An atom text construct.+declarePrisms [d|+ data AtomText = AtomPlainText { atomPlainTextType_ :: TextType, atomPlainTextText_ :: Text }+ | AtomXHTMLText { atomXHTMLTextDiv_ :: Text }+ |]++deriving instance Eq AtomText+deriving instance Generic AtomText+deriving instance Show AtomText++-- | An atom person construct.+declareLenses [d|+ data AtomPerson = AtomPerson+ { personName_ :: NonNull Text+ , personEmail_ :: Text+ , personUri_ :: Maybe URI+ }+ |]++deriving instance Eq AtomPerson+deriving instance Generic AtomPerson+deriving instance Show AtomPerson++-- | The @atom:category@ element.+declareLenses [d|+ data AtomCategory = AtomCategory+ { categoryTerm_ :: NonNull Text+ , categoryScheme_ :: Text+ , categoryLabel_ :: Text+ }+ |]++deriving instance Eq AtomCategory+deriving instance Generic AtomCategory+deriving instance Show AtomCategory++-- | The @atom:link@ element.+declareLenses [d|+ data AtomLink = AtomLink+ { linkHref_ :: URI+ , linkRel_ :: Text+ , linkType_ :: Text+ , linkLang_ :: Text+ , linkTitle_ :: Text+ , linkLength_ :: Text+ }+ |]++deriving instance Eq AtomLink+deriving instance Generic AtomLink+deriving instance Show AtomLink++-- | The @atom:generator@ element.+declareLenses [d|+ data AtomGenerator = AtomGenerator+ { generatorUri_ :: Maybe URI+ , generatorVersion_ :: Text+ , generatorContent_ :: NonNull Text+ }+ |]++deriving instance Eq AtomGenerator+deriving instance Generic AtomGenerator+deriving instance Show AtomGenerator++-- | The @atom:source@ element.+declareLenses [d|+ data AtomSource = AtomSource+ { sourceAuthors_ :: [AtomPerson]+ , sourceCategories_ :: [AtomCategory]+ , sourceContributors_ :: [AtomPerson]+ , sourceGenerator_ :: Maybe AtomGenerator+ , sourceIcon_ :: Maybe URI+ , sourceId_ :: Text+ , sourceLinks_ :: [AtomLink]+ , sourceLogo_ :: Maybe URI+ , sourceRights_ :: Maybe AtomText+ , sourceSubtitle_ :: Maybe AtomText+ , sourceTitle_ :: Maybe AtomText+ , sourceUpdated_ :: Maybe UTCTime+ }+ |]++deriving instance Eq AtomSource+deriving instance Generic AtomSource+deriving instance Show AtomSource++-- | The @atom:content@ element.+declareLenses [d|+ data AtomContent+ = AtomContentInlineText { atomContentInlineTextType_ :: TextType, atomContentInlineTextText_ :: Text }+ | AtomContentInlineXHTML { atomContentInlineXHTMLDiv_ :: Text }+ | AtomContentInlineOther { atomContentInlineOtherType_ :: Text, atomContentInlineOtherText_ :: Text }+ | AtomContentOutOfLine { atomContentOutOfLineType_ :: Text, atomContentOutOfLineUri_ :: URI }+ |]++deriving instance Eq AtomContent+deriving instance Generic AtomContent+deriving instance Show AtomContent++-- | The @atom:entry@ element.+declareLenses [d|+ data AtomEntry = AtomEntry+ { entryAuthors_ :: [AtomPerson]+ , entryCategories_ :: [AtomCategory]+ , entryContent_ :: Maybe AtomContent+ , entryContributors_ :: [AtomPerson]+ , entryId_ :: NonNull Text+ , entryLinks_ :: [AtomLink]+ , entryPublished_ :: Maybe UTCTime+ , entryRights_ :: Maybe AtomText+ , entrySource_ :: Maybe AtomSource+ , entrySummary_ :: Maybe AtomText+ , entryTitle_ :: AtomText+ , entryUpdated_ :: UTCTime+ }+ |]++deriving instance Eq AtomEntry+deriving instance Generic AtomEntry+deriving instance Show AtomEntry++-- | The @atom:feed@ element.+declareLenses [d|+ data AtomFeed = AtomFeed+ { feedAuthors_ :: [AtomPerson]+ , feedCategories_ :: [AtomCategory]+ , feedContributors_ :: [AtomPerson]+ , feedEntries_ :: [AtomEntry]+ , feedGenerator_ :: Maybe AtomGenerator+ , feedIcon_ :: Maybe URI+ , feedId_ :: NonNull Text+ , feedLinks_ :: [AtomLink]+ , feedLogo_ :: Maybe URI+ , feedRights_ :: Maybe AtomText+ , feedSubtitle_ :: Maybe AtomText+ , feedTitle_ :: AtomText+ , feedUpdated_ :: UTCTime+ }+ |]++deriving instance Eq AtomFeed+deriving instance Generic AtomFeed+deriving instance Show AtomFeed
+ atom-conduit.cabal view
@@ -0,0 +1,70 @@+name: atom-conduit+version: 0.1.0.0+synopsis: Streaming parser/renderer for the Atom 1.0 standard (RFC 4287).+description:+ This library implements the Atom 1.0 syndication format (<http://tools.ietf.org/html/rfc4287>) as a 'conduit' parser/renderer.+license: OtherLicense+license-file: LICENSE+author: koral+maintainer: koral att mailoo dott org+-- copyright:+category: XML, Conduit+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/k0ral/atom-conduit.git++library+ exposed-modules:+ Text.Atom.Conduit.Parse+ Text.Atom.Conduit.Render+ Text.Atom.Types+ -- other-modules:+ build-depends:+ base >= 4.8 && < 5+ , conduit+ , conduit-parse+ , containers+ , exceptions+ , lens+ , mono-traversable+ , network-uri+ , parsers+ , text+ , time >= 1.5+ , timerep >= 2.0+ , xml-conduit >= 1.3+ , xml-conduit-parse >= 0.3+ , xml-types+ default-language: Haskell2010++test-suite Tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends: atom-conduit,+ base >=4.8,+ conduit,+ conduit-parse,+ data-default,+ exceptions,+ hlint,+ lens,+ mono-traversable,+ network-uri,+ parsers,+ -- QuickCheck,+ quickcheck-instances,+ resourcet,+ tasty,+ tasty-hunit,+ tasty-quickcheck,+ time >= 1.5,+ text,+ xml-conduit >= 1.3,+ xml-conduit-parse >= 0.3,+ xml-types+ default-language: Haskell2010
+ test/Main.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+import Control.Lens.Getter+import Control.Monad+import Control.Monad.Catch.Pure+import Control.Monad.Trans.Resource++import Data.Char+import Data.Conduit+import Data.Conduit.List+import Data.Conduit.Parser+import Data.Conduit.Parser.XML as XML+import Data.Default+import Data.Functor.Identity+import Data.MinLen+import Data.Monoid+import Data.MonoTraversable+import Data.NonNull+import Data.Text as Text+import Data.Time.Clock+import Data.XML.Types++import Network.URI++import qualified Language.Haskell.HLint as HLint (hlint)+import Test.QuickCheck.Instances+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import Text.Atom.Conduit.Parse as Parser+import Text.Atom.Conduit.Render as Renderer+import Text.Atom.Types+import Text.Parser.Combinators+++main :: IO ()+main = defaultMain $ testGroup "Tests"+ [ unitTests+ , properties+ , hlint+ ]++unitTests :: TestTree+unitTests = testGroup "Unit tests"+ [ linkCase+ , personCase+ , generatorCase+ , sourceCase+ , textConstructCase+ , simpleCase+ ]++properties :: TestTree+properties = testGroup "Properties"+ [ inverseAtomTextProperty+ , inverseAtomPersonProperty+ , inverseAtomCategoryProperty+ , inverseAtomLinkProperty+ , inverseAtomGeneratorProperty+ , inverseAtomSourceProperty+ , inverseAtomContentProperty+ , inverseAtomEntryProperty+ -- , inverseAtomFeedProperty+ ]++linkCase :: TestTree+linkCase = testCase "Link element" $ do+ result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomLink+ show (result ^. linkHref_) @?= "/feed"+ (result ^. linkRel_) @?= "self"+ where input = ["<link rel=\"self\" href=\"/feed\" />"]++personCase :: TestTree+personCase = testCase "Person construct" $ do+ result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser (atomPerson "author")+ toNullable (result ^. personName_) @?= "John Doe"+ result ^. personEmail_ @?= "JohnDoe@example.com"+ show <$> (result ^. personUri_) @?= Just "http://example.com/~johndoe"+ where input =+ [ "<author>"+ , "<name>John Doe</name>"+ , "<email>JohnDoe@example.com</email>"+ , "<uri>http://example.com/~johndoe</uri>"+ , "</author>"+ ]++generatorCase :: TestTree+generatorCase = testCase "Generator element" $ do+ result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomGenerator+ show <$> (result ^. generatorUri_) @?= Just "/myblog.php"+ (result ^. generatorVersion_) @?= "1.0"+ toNullable (result ^. generatorContent_) @?= "Example Toolkit"+ where input =+ [ "<generator uri=\"/myblog.php\" version=\"1.0\">"+ , "Example Toolkit"+ , "</generator>"+ ]++sourceCase :: TestTree+sourceCase = testCase "Source element" $ do+ result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomSource+ (result ^. sourceId_) @?= "http://example.org/"+ (result ^. sourceTitle_) @?= Just (AtomPlainText TypeText "Fourty-Two")+ show <$> (result ^. sourceUpdated_) @?= Just "2003-12-13 18:30:02 UTC"+ (result ^. sourceRights_) @?= Just (AtomPlainText TypeText "© 2005 Example, Inc.")+ where input =+ [ "<source>"+ , "<id>http://example.org/</id>"+ , "<title>Fourty-Two</title>"+ , "<updated>2003-12-13T18:30:02Z</updated>"+ , "<rights>© 2005 Example, Inc.</rights>"+ , "</source>"+ ]++textConstructCase :: TestTree+textConstructCase = testCase "Text construct" $ do+ (a, b, c) <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser ((,,) <$> atomText "title1" <*> atomText "title2" <*> atomText "title3")+ a @?= AtomPlainText TypeText "AT&T bought by SBC!"+ b @?= AtomPlainText TypeHTML "AT&T bought <b>by SBC</b>!"+ c @?= AtomXHTMLText "AT&T bought <b>by SBC</b>!"+ where input =+ [ "<title1 type=\"text\">AT&T bought by SBC!</title1>"+ , "<title2 type=\"html\">"+ , "AT&amp;T bought <b>by SBC</b>!"+ , "</title2>"+ , "<title3 type=\"xhtml\">"+ , "<div xmlns=\"http://www.w3.org/1999/xhtml\">"+ , "AT&T bought <b>by SBC</b>!"+ , "</div>"+ , "</title3>"+ ]++simpleCase :: TestTree+simpleCase = testCase "Simple case" $ do+ result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomFeed+ return ()+ where input =+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>"+ , "<feed xmlns=\"http://www.w3.org/2005/Atom\">"+ , "<title>Example Feed</title>"+ , "<link href=\"http://example.org/\"/>"+ , "<updated>2003-12-13T18:30:02Z</updated>"+ , "<author>"+ , "<name>John Doe</name>"+ , "</author>"+ , "<id>urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6</id>"+ , "<entry>"+ , "<title>Atom-Powered Robots Run Amok</title>"+ , "<link href=\"http://example.org/2003/12/13/atom03\"/>"+ , "<id>urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a</id>"+ , "<updated>2003-12-13T18:30:02Z</updated>"+ , "<summary>Some text.</summary>"+ , "</entry>"+ , "</feed>"+ ]+++hlint :: TestTree+hlint = testCase "HLint check" $ do+ result <- HLint.hlint [ "test/", "Text/" ]+ Prelude.null result @?= True+++inverseAtomTextProperty :: TestTree+inverseAtomTextProperty = testProperty "parse . render = id (AtomText)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomText "test" i =$= runConduitParser (atomText "test"))++inverseAtomPersonProperty :: TestTree+inverseAtomPersonProperty = testProperty "parse . render = id (AtomPerson)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomPerson "test" i =$= runConduitParser (atomPerson "test"))++inverseAtomCategoryProperty :: TestTree+inverseAtomCategoryProperty = testProperty "parse . render = id (AtomCategory)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomCategory i =$= runConduitParser atomCategory)++inverseAtomLinkProperty :: TestTree+inverseAtomLinkProperty = testProperty "parse . render = id (AtomLink)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomLink i =$= runConduitParser atomLink)++inverseAtomGeneratorProperty :: TestTree+inverseAtomGeneratorProperty = testProperty "parse . render = id (AtomGenerator)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomGenerator i =$= runConduitParser atomGenerator)++inverseAtomSourceProperty :: TestTree+inverseAtomSourceProperty = testProperty "parse . render = id (AtomSource)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomSource i =$= runConduitParser atomSource)++inverseAtomContentProperty :: TestTree+inverseAtomContentProperty = testProperty "parse . render = id (AtomContent)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomContent i =$= runConduitParser atomContent)++inverseAtomFeedProperty :: TestTree+inverseAtomFeedProperty = testProperty "parse . render = id (AtomFeed)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomFeed i =$= runConduitParser atomFeed)++inverseAtomEntryProperty :: TestTree+inverseAtomEntryProperty = testProperty "parse . render = id (AtomEntry)" $ \i -> either (const False) (i ==) (runIdentity . runCatchT . runConduit $ renderAtomEntry i =$= runConduitParser atomEntry)+++alphaNum = oneof [choose('a', 'z'), suchThat arbitrary isDigit]++instance (MonoFoldable a, Arbitrary a) => Arbitrary (MinLen (Succ Zero) a) where+ arbitrary = nonNull <$> arbitrary `suchThat` (not . onull)++instance Arbitrary URIAuth where+ arbitrary = do+ userInfo <- oneof [return "", (++ "@") <$> listOf1 alphaNum]+ regName <- listOf1 alphaNum+ port <- oneof [return "", (":" ++) . show <$> choose(1 :: Int, 65535)]+ return $ URIAuth userInfo regName port++instance Arbitrary URI where+ arbitrary = do+ scheme <- (++ ":") <$> listOf1 (choose('a', 'z'))+ path <- ("/" ++) <$> listOf1 alphaNum+ query <- oneof [return "", ("?" ++) <$> listOf1 alphaNum]+ fragment <- oneof [return "", ("#" ++) <$> listOf1 alphaNum]+ authority <- arbitrary+ return $ URI scheme authority path query fragment++instance Arbitrary TextType where+ arbitrary = elements [TypeText, TypeHTML]+ -- shrink = genericShrink++instance Arbitrary AtomText where+ arbitrary = oneof+ [ AtomPlainText <$> arbitrary <*> arbitrary+ , AtomXHTMLText <$> arbitrary+ ]+ shrink = genericShrink++instance Arbitrary AtomPerson where+ arbitrary = AtomPerson <$> arbitrary <*> arbitrary <*> arbitrary+ -- shrink = genericShrink++instance Arbitrary AtomCategory where+ arbitrary = AtomCategory <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary AtomLink where+ arbitrary = AtomLink <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary AtomGenerator where+ arbitrary = AtomGenerator <$> arbitrary <*> arbitrary <*> arbitrary+ shrink = genericShrink++instance Arbitrary AtomSource where+ arbitrary = do+ updated <- oneof [return Nothing, Just <$> genUtcTime]+ AtomSource <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> pure updated+ -- shrink = genericShrink++instance Arbitrary AtomContent where+ arbitrary = oneof+ [ AtomContentInlineText <$> arbitrary <*> arbitrary+ , AtomContentInlineXHTML <$> arbitrary+ , AtomContentInlineOther <$> arbitrary <*> arbitrary+ , AtomContentOutOfLine <$> arbitrary <*> arbitrary+ ]++instance Arbitrary AtomEntry where+ arbitrary = do+ published <- oneof [return Nothing, Just <$> genUtcTime]+ AtomEntry <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> pure published <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> genUtcTime++instance Arbitrary AtomFeed where+ arbitrary = AtomFeed <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> genUtcTime++-- | Generates 'UTCTime' with rounded seconds.+genUtcTime = do+ (UTCTime d s) <- arbitrary+ return $ UTCTime d (fromIntegral (round s :: Int))