diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE +Version 2, December 2004 + +Copyright (C) 2011 koral + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/Atom/Conduit/Parse.hs b/Text/Atom/Conduit/Parse.hs new file mode 100644 --- /dev/null +++ b/Text/Atom/Conduit/Parse.hs @@ -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 element" $ tagIgnoreAttrs "feed" $ do + builders <- many $ choice atomFeedBuilders + let result = (appEndo $ mconcat builders) dummy + when (checkDummy result) $ unexpected "Missing sub-elements in ." + 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 element" $ tagIgnoreAttrs "entry" $ do + builders <- many $ choice atomEntryBuilders + let result = (appEndo $ mconcat builders) dummy + when (checkDummy result) $ unexpected "Missing sub-elements in ." + 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: +-- +-- > +-- > http://example.org/ +-- > Fourty-Two +-- > 2003-12-13T18:30:02Z +-- > © 2005 Example, Inc. +-- > +atomSource :: (MonadCatch m) => ConduitParser Event m AtomSource +atomSource = named "Atom 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: +-- +-- > +-- > Example Toolkit +-- > +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: +-- +-- > +-- +-- > +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: +-- +-- > +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: +-- +-- > +-- > John Doe +-- > JohnDoe@example.com +-- > http://example.com/~johndoe +-- > +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: +-- +-- > AT&T bought by SBC! +-- +-- > +-- > AT&amp;T bought <b>by SBC</b>! +-- > +-- +-- > +-- > <div xmlns="http://www.w3.org/1999/xhtml"> +-- > AT&T bought <b>by SBC</b>! +-- > </div> +-- > +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 diff --git a/Text/Atom/Conduit/Render.hs b/Text/Atom/Conduit/Render.hs new file mode 100644 --- /dev/null +++ b/Text/Atom/Conduit/Render.hs @@ -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 diff --git a/Text/Atom/Types.hs b/Text/Atom/Types.hs new file mode 100644 --- /dev/null +++ b/Text/Atom/Types.hs @@ -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: +-- +-- > +-- > +-- > +-- > Example Feed +-- > +-- > 2003-12-13T18:30:02Z +-- > +-- > John Doe +-- > +-- > urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6 +-- > +-- > +-- > Atom-Powered Robots Run Amok +-- > +-- > urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a +-- > 2003-12-13T18:30:02Z +-- > Some text. +-- > +-- > +-- > +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 diff --git a/atom-conduit.cabal b/atom-conduit.cabal new file mode 100644 --- /dev/null +++ b/atom-conduit.cabal @@ -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 () 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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 = [""] + +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 = + [ "" + , "John Doe" + , "JohnDoe@example.com" + , "http://example.com/~johndoe" + , "" + ] + +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 = + [ "" + , "Example Toolkit" + , "" + ] + +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 = + [ "" + , "http://example.org/" + , "Fourty-Two" + , "2003-12-13T18:30:02Z" + , "© 2005 Example, Inc." + , "" + ] + +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 by SBC!" + c @?= AtomXHTMLText "AT&T bought by SBC!" + where input = + [ "AT&T bought by SBC!" + , "" + , "AT&amp;T bought <b>by SBC</b>!" + , "" + , "" + , "
" + , "AT&T bought by SBC!" + , "
" + , "" + ] + +simpleCase :: TestTree +simpleCase = testCase "Simple case" $ do + result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomFeed + return () + where input = + [ "" + , "" + , "Example Feed" + , "" + , "2003-12-13T18:30:02Z" + , "" + , "John Doe" + , "" + , "urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6" + , "" + , "Atom-Powered Robots Run Amok" + , "" + , "urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a" + , "2003-12-13T18:30:02Z" + , "Some text." + , "" + , "" + ] + + +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))