diff options
| -rw-r--r-- | Data/NotEmpty.hs | 43 | ||||
| -rw-r--r-- | LICENSE | 13 | ||||
| -rw-r--r-- | Setup.hs | 2 | ||||
| -rw-r--r-- | Text/OPML.hs | 10 | ||||
| -rw-r--r-- | Text/OPML/Arbitrary.hs | 72 | ||||
| -rw-r--r-- | Text/OPML/Stream/Parse.hs | 175 | ||||
| -rw-r--r-- | Text/OPML/Stream/Render.hs | 100 | ||||
| -rw-r--r-- | Text/OPML/Types.hs | 244 | ||||
| -rw-r--r-- | data/category.opml | 1 | ||||
| -rw-r--r-- | data/directory.opml | 1 | ||||
| -rw-r--r-- | data/placesLived.opml | 1 | ||||
| -rw-r--r-- | data/simpleScript.opml | 1 | ||||
| -rw-r--r-- | data/states.opml | 1 | ||||
| -rw-r--r-- | data/subscriptionList.opml | 31 | ||||
| -rw-r--r-- | opml-conduit.cabal | 77 | ||||
| -rw-r--r-- | test/Main.hs | 151 |
16 files changed, 923 insertions, 0 deletions
diff --git a/Data/NotEmpty.hs b/Data/NotEmpty.hs new file mode 100644 index 0000000..be89ae5 --- /dev/null +++ b/Data/NotEmpty.hs @@ -0,0 +1,43 @@ +module Data.NotEmpty + ( NE() + , notEmpty + , original + , NotEmptyException(..) + ) where + +-- {{{ Imports +import Control.Monad.Catch + +import Data.Semigroup + +import Test.QuickCheck +-- }}} + +-- | For a monoid @s@, @NE s@ is @s@ without its neutral element 'mempty'. +newtype NE s = NE s + +instance (Eq s) => Eq (NE s) where + (NE a) == (NE b) = a == b + +-- | @NE s@ is the semigroup derived from the monoid type @s@. +instance (Monoid s) => Semigroup (NE s) where + (NE a) <> (NE b) = NE (a `mappend` b) + +instance (Show s) => Show (NE s) where + show (NE s) = show s + +instance (Eq s, Monoid s, Arbitrary s) => Arbitrary (NE s) where + arbitrary = NE <$> arbitrary `suchThat` (/= mempty) + +-- | Smart constructor. +notEmpty :: (MonadThrow m, Eq s, Monoid s) => s -> m (NE s) +notEmpty s | s == mempty = throwM EmptyValue + | otherwise = return $ NE s + +-- | Unwrap the underlying value. +original :: NE s -> s +original (NE s) = s + + +data NotEmptyException = EmptyValue deriving(Eq, Show) +instance Exception NotEmptyException @@ -0,0 +1,13 @@ +DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE +Version 2, December 2004 + +Copyright (C) 2015 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/OPML.hs b/Text/OPML.hs new file mode 100644 index 0000000..6ca3ee1 --- /dev/null +++ b/Text/OPML.hs @@ -0,0 +1,10 @@ +-- | This module re-exports commonly used modules. +module Text.OPML + ( module Text.OPML.Stream.Parse + , module Text.OPML.Stream.Render + , module Text.OPML.Types + ) where + +import Text.OPML.Stream.Parse +import Text.OPML.Stream.Render +import Text.OPML.Types diff --git a/Text/OPML/Arbitrary.hs b/Text/OPML/Arbitrary.hs new file mode 100644 index 0000000..da75845 --- /dev/null +++ b/Text/OPML/Arbitrary.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +-- | External 'Arbitrary' instances used by OPML types. +-- All instances are defined through the 'OpmlGen' wrapper to avoid conflicts. +module Text.OPML.Arbitrary where + +-- {{{ Imports +import Data.Char +import Data.Maybe +import Data.NotEmpty +import Data.Text (Text, find) +import Data.Time.Clock +import Data.Version + +import GHC.Generics + +import Network.URI + +import Test.QuickCheck +import Test.QuickCheck.Instances () +-- }}} + +newtype OpmlGen a = OpmlGen { unwrap :: a } +deriving instance (Generic a) => Generic (OpmlGen a) +instance (Arbitrary (OpmlGen a)) => Arbitrary (OpmlGen (Maybe a)) where + arbitrary = do + a <- arbitrary :: Gen (Maybe ()) + (OpmlGen result) <- arbitrary + return . OpmlGen $ maybe Nothing (const $ Just result) a + +-- | Alpha-numeric generator. +genAlphaNum :: Gen Char +genAlphaNum = oneof [choose('a', 'z'), suchThat arbitrary isDigit] + +-- | OPML version may only be @1.0@, @1.1@ or @2.0@ +instance Arbitrary (OpmlGen Version) where + arbitrary = OpmlGen <$> (Version <$> elements [ [1, 0], [1, 1], [2, 0] ] <*> pure []) + shrink (OpmlGen (Version a b)) = OpmlGen <$> (Version <$> shrink a <*> shrink b) + +-- | Reasonable enough 'URI' generator. +instance Arbitrary (OpmlGen URI) where + arbitrary = OpmlGen <$> (URI <$> genUriScheme <*> (unwrap <$> arbitrary) <*> genUriPath <*> genUriQuery <*> genUriFragment) + where genUriPath = ("/" ++) <$> listOf1 genAlphaNum + genUriQuery = oneof [return "", ("?" ++) <$> listOf1 genAlphaNum] + genUriFragment = oneof [return "", ("#" ++) <$> listOf1 genAlphaNum] + genUriScheme = (\x -> x ++ ":") <$> listOf1 (choose('a', 'z')) + -- shrink = genericShrink + +-- | Reasonable enough 'URIAuth' generator. +instance Arbitrary (OpmlGen URIAuth) where + arbitrary = do + userInfo <- oneof [return "", fmap (\x -> x ++ "@") $ listOf1 genAlphaNum] + regName <- listOf1 genAlphaNum + port <- oneof [return "", (\x -> ":" ++ x) . show <$> choose(1 :: Int, 65535)] + return . OpmlGen $ URIAuth userInfo regName port + -- shrink = genericShrink + + +-- | Generates 'UTCTime' with rounded seconds. +instance Arbitrary (OpmlGen UTCTime) where + arbitrary = do + (UTCTime d s) <- arbitrary + return . OpmlGen $ UTCTime d (fromIntegral (round s :: Int)) + -- shrink = genericShrink + +-- | Generates 'OutlineBase''s categories. +-- This generator makes sure that the result has no @,@ nor @/@ characters, since those are used as separators. +instance Arbitrary (OpmlGen [[NE Text]]) where + arbitrary = OpmlGen <$> listOf (listOf1 $ arbitrary `suchThat` (isNothing . find (\c -> c == ',' || c == '/') . original)) + shrink = genericShrink diff --git a/Text/OPML/Stream/Parse.hs b/Text/OPML/Stream/Parse.hs new file mode 100644 index 0000000..9fa5f7f --- /dev/null +++ b/Text/OPML/Stream/Parse.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | Streaming parser for the OPML 2.0 standard. +-- +-- The parser tries to be as lenient as possible. All functions may throw an 'OpmlException'. +module Text.OPML.Stream.Parse + ( -- * Parsers + parseOpml + , parseOpmlHead + , parseOpmlOutline + -- * Exceptions + , OpmlException(..) + ) where + +-- {{{ Imports +import Control.Lens.At +import Control.Lens.Setter +import Control.Monad +import Control.Monad.Catch + +import Data.CaseInsensitive hiding (map) +import Data.Conduit +import Data.Containers +import Data.Map (Map) +import Data.Maybe +import Data.Monoid.Textual hiding (map) +import Data.MonoTraversable +import Data.NotEmpty +import Data.Text (Text, strip, unpack) +import Data.Time.Clock +import Data.Time.LocalTime +import Data.Time.RFC822 +import Data.Tree +import Data.Version +import Data.XML.Types + +import Network.URI (URI) +import qualified Network.URI as N + +import Numeric + +import Prelude hiding (foldr, lookup) + +import Text.OPML.Types +import Text.ParserCombinators.ReadP (readP_to_S) +import Text.XML.Stream.Parse +-- }}} + +data OpmlException = InvalidBool Text + | InvalidDecimal Text + | InvalidTime Text + | InvalidURI Text + | InvalidVersion Text + +deriving instance Eq OpmlException +instance Show OpmlException where + show (InvalidBool t) = "Invalid boolean: " ++ unpack t + show (InvalidDecimal t) = "Invalid decimal: " ++ unpack t + show (InvalidURI t) = "Invalid URI: " ++ unpack t + show (InvalidTime t) = "Invalid time: " ++ unpack t + show (InvalidVersion t) = "Invalid version: " ++ unpack t +instance Exception OpmlException + +-- | Generic version of 'Network.URI.parseURI'. +parseURI :: (MonadThrow m) => Text -> m URI +parseURI t = maybe (throwM $ InvalidURI t) return . N.parseURI $ unpack t + +parseVersion' :: (MonadThrow m) => Text -> m Version +parseVersion' v = case filter (onull . snd) . readP_to_S parseVersion $ unpack v of + [(a, "")] -> return a + _ -> throwM $ InvalidVersion v + +parseDecimal :: (MonadThrow m, Integral a) => Text -> m a +parseDecimal t = case (filter (\(_, b) -> onull b) . readSigned readDec $ unpack t) of + (result, _):_ -> return result + _ -> throwM $ InvalidDecimal t + +parseExpansionState :: (MonadThrow m, Integral a) => Text -> m [a] +parseExpansionState t = mapM parseDecimal . filter (not . onull) . map strip $ split (== ',') t + +parseTime :: (MonadThrow m) => Text -> m UTCTime +parseTime t = maybe (throwM $ InvalidTime t) (return . zonedTimeToUTC) $ parseTimeRFC822 t + +-- The standard only accepts "true", and "false", +-- but it doesn't hurt to be more lenient +parseBool :: (MonadThrow m) => Text -> m Bool +parseBool t + | mk t == "true" = return True + | mk t == "false" = return False + | otherwise = throwM $ InvalidBool t + + +opmlHeadBuilder :: (MonadThrow m) => Map Text (Text -> OpmlHead -> m OpmlHead) +opmlHeadBuilder = [ ("dateCreated", \v h -> set opmlCreated_ <$> (Just <$> parseTime v) <*> pure h) + , ("dateModified", \v h -> set modified_ <$> (Just <$> parseTime v) <*> pure h) + , ("docs", \v h -> set docs_ <$> (Just <$> parseURI v) <*> pure h) + , ("expansionState", \v h -> set expansionState_ <$> parseExpansionState v <*> pure h) + , ("ownerEmail", \v -> return . set ownerEmail_ v) + , ("ownerId", \v h -> set ownerId_ <$> (Just <$> parseURI v) <*> pure h) + , ("ownerName", \v -> return . set ownerName_ v) + , ("title", \v -> return . set opmlTitle_ v) + , ("vertScrollState", \v h -> set vertScrollState_ <$> (Just <$> parseDecimal v) <*> pure h) + , ("windowBottom", \v h -> set (window_.at Bottom') <$> (Just <$> parseDecimal v) <*> pure h) + , ("windowLeft", \v h -> set (window_.at Left') <$> (Just <$> parseDecimal v) <*> pure h) + , ("windowRight", \v h -> set (window_.at Right') <$> (Just <$> parseDecimal v) <*> pure h) + , ("windowTop", \v h -> set (window_.at Top') <$> (Just <$> parseDecimal v) <*> pure h) + ] + +-- | Parse the @\<head\>@ section. +-- This function is more lenient than what the standards demands on the following points: +-- +-- - each sub-element may be repeated, in which case only the last occurrence is taken into account; +-- - each unknown sub-element is ignored. +parseOpmlHead :: (MonadThrow m) => Consumer Event m (Maybe OpmlHead) +parseOpmlHead = tagName "head" ignoreAttrs $ \_ -> foldM (\a f' -> f' a) def =<< many (tagHead `orE` unknownTag) + where tagHead, unknownTag :: (MonadThrow m, MonadThrow m') => ConduitM Event o m (Maybe (OpmlHead -> m' OpmlHead)) + tagHead = tag ((`lookup` opmlHeadBuilder) . nameLocalName) (\f -> ignoreAttrs *> pure f) $ \f -> do + c <- content + return $ f c + unknownTag = tagPredicate (const True) ignoreAttrs $ \_ -> return return + + +parseCategories :: Text -> [[NE Text]] +parseCategories = filter (not . onull) . map (catMaybes . map notEmpty . split (== '/')) . split (== ',') + +-- | Parse an @\<outline\>@ section. +-- The value of type attributes are not case-sensitive, that is @type=\"LINK\"@ has the same meaning as @type="link"@. +parseOpmlOutline :: (MonadThrow m) => Consumer Event m (Maybe (Tree OpmlOutline)) +parseOpmlOutline = tagName "outline" attributes handler + where attributes = do + otype <- optionalAttr "type" + case mk <$> otype of + Just "include" -> (,,,) otype <$> baseAttr <*> pure Nothing <*> (Just <$> linkAttr) <* ignoreAttrs + Just "link" -> (,,,) otype <$> baseAttr <*> pure Nothing <*> (Just <$> linkAttr) <* ignoreAttrs + Just "rss" -> (,,,) otype <$> baseAttr <*> (Just <$> subscriptionAttr) <*> pure Nothing <* ignoreAttrs + _ -> (,,,) otype <$> baseAttr <*> pure Nothing <*> pure Nothing <* ignoreAttrs + baseAttr = (,,,,) <$> requireAttr "text" + <*> optionalAttr "isComment" + <*> optionalAttr "isBreakpoint" + <*> optionalAttr "created" + <*> optionalAttr "category" + linkAttr = requireAttr "url" + subscriptionAttr = (,,,,,) <$> requireAttr "xmlUrl" + <*> optionalAttr "htmlUrl" + <*> optionalAttr "description" + <*> optionalAttr "language" + <*> optionalAttr "title" + <*> optionalAttr "version" + handler (_, b, Just s, _) = Node <$> (OpmlOutlineSubscription <$> baseHandler b <*> subscriptionHandler s) <*> pure [] + handler (_, b, _, Just l) = Node <$> (OpmlOutlineLink <$> baseHandler b <*> parseURI l) <*> pure [] + handler (otype, b, _, _) = Node <$> (OpmlOutlineGeneric <$> baseHandler b <*> pure (fromMaybe mempty otype)) + <*> many parseOpmlOutline + baseHandler (t, comment, breakpoint, created, category) = + OutlineBase <$> notEmpty t + <*> pure (parseBool =<< comment) + <*> pure (parseBool =<< breakpoint) + <*> pure (parseTime =<< created) + <*> pure (parseCategories =<< otoList category) + subscriptionHandler (uri, html, description, language, title, version) = + OutlineSubscription <$> parseURI uri + <*> pure (parseURI =<< html) + <*> pure (fromMaybe mempty description) + <*> pure (fromMaybe mempty language) + <*> pure (fromMaybe mempty title) + <*> pure (fromMaybe mempty version) + +-- | Parse the top-level @\<opml\>@ element. +parseOpml :: (MonadThrow m) => Consumer Event m (Maybe Opml) +parseOpml = tagName "opml" attributes handler + where attributes = requireAttr "version" <* ignoreAttrs + handler version = Opml <$> parseVersion' version + <*> force "Missing <head>." parseOpmlHead + <*> force "Missing <body>." (tagName "body" ignoreAttrs $ \_ -> many parseOpmlOutline) diff --git a/Text/OPML/Stream/Render.hs b/Text/OPML/Stream/Render.hs new file mode 100644 index 0000000..339d6e9 --- /dev/null +++ b/Text/OPML/Stream/Render.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +-- | Streaming renderer for the OPML 2.0 standard. +module Text.OPML.Stream.Render + ( -- * Renderers + renderOpmlHead + , renderOpmlOutline + , renderOpml + ) where + +-- {{{ Imports +import Control.Lens.At +import Control.Lens.Getter +import Control.Monad + +import Data.Conduit +import Data.Monoid +import Data.MonoTraversable +import Data.NotEmpty +import Data.Text (Text, intercalate, pack, toLower) +import Data.Time.Clock +import Data.Time.LocalTime +import Data.Time.RFC822 +import Data.Tree +import Data.Version +import Data.XML.Types + +import Prelude hiding (foldr, lookup) + +import Text.OPML.Types +import Text.XML.Stream.Render +-- }}} + +tshow :: (Show a) => a -> Text +tshow = pack . show + +empty :: (Eq s, Monoid s) => s -> Bool +empty t = t == mempty + +toMaybe :: (Eq s, Monoid s) => s -> Maybe s +toMaybe s | s == mempty = mempty + | otherwise = Just s + +formatTime :: UTCTime -> Text +formatTime = formatTimeRFC822 . utcToZonedTime utc + +formatCategories :: [[NE Text]] -> Maybe Text +formatCategories = toMaybe . intercalate "," . map (intercalate "/") . filter (not . onull) . map (map original) + +formatBool :: Bool -> Text +formatBool = toLower . tshow + +-- | Render the @\<head\>@ section. +renderOpmlHead :: (Monad m) => OpmlHead -> Source m Event +renderOpmlHead input = tag "head" mempty $ do + forM_ (input^.opmlCreated_) $ tag "dateCreated" mempty . content . formatTime + forM_ (input^.modified_) $ tag "dateModified" mempty . content . formatTime + forM_ (input^.docs_) $ tag "docs" mempty . content . tshow + unless (null es) . tag "expansionState" mempty . content . intercalate "," $ tshow <$> es + unless (empty email) $ tag "ownerEmail" mempty $ content email + forM_ (input^.ownerId_) $ tag "ownerId" mempty . content . tshow + unless (empty name) $ tag "ownerName" mempty $ content name + unless (empty title) $ tag "title" mempty $ content title + forM_ (input^.vertScrollState_) $ tag "vertScrollState" mempty . content . tshow + forM_ (input^.window_.at Bottom') $ tag "windowBottom" mempty . content . tshow + forM_ (input^.window_.at Left') $ tag "windowLeft" mempty . content . tshow + forM_ (input^.window_.at Right') $ tag "windowRight" mempty . content . tshow + forM_ (input^.window_.at Top') $ tag "windowTop" mempty . content . tshow + where es = input ^. expansionState_ + email = input ^. ownerEmail_ + name = input ^. ownerName_ + title = input ^. opmlTitle_ + +-- | Render an @\<outline\>@ section. +renderOpmlOutline :: (Monad m) => Tree OpmlOutline -> Source m Event +renderOpmlOutline (Node outline subOutlines) = tag "outline" attributes $ mapM_ renderOpmlOutline subOutlines + where attributes = case outline of + OpmlOutlineGeneric b t -> baseAttr b <> optionalAttr "type" (toMaybe t) + OpmlOutlineLink b uri -> baseAttr b <> attr "type" "link" <> attr "url" (tshow uri) + OpmlOutlineSubscription b s -> baseAttr b <> subscriptionAttr s + baseAttr b = attr "text" (original $ b^.text_) + <> optionalAttr "isComment" (formatBool <$> b^.isComment_) + <> optionalAttr "isBreakpoint" (formatBool <$> b^.isBreakpoint_) + <> optionalAttr "created" (formatTime <$> b^.outlineCreated_) + <> optionalAttr "category" (formatCategories $ b^.categories_) + subscriptionAttr s = attr "type" "rss" + <> attr "xmlUrl" (tshow $ s^.xmlUri_) + <> optionalAttr "htmlUrl" (tshow <$> s^.htmlUri_) + <> optionalAttr "description" (toMaybe $ s^.description_) + <> optionalAttr "language" (toMaybe $ s^.language_) + <> optionalAttr "title" (toMaybe $ s^.subscriptionTitle_) + <> optionalAttr "version" (toMaybe $ s^.subscriptionVersion_) + +-- | Render the top-level @\<opml\>@ section. +renderOpml :: (Monad m) => Opml -> Source m Event +renderOpml opml = tag "opml" (attr "version" . pack . showVersion $ opml^.opmlVersion_) $ do + renderOpmlHead $ opml^.head_ + tag "body" mempty . mapM_ renderOpmlOutline $ opml^.outlines_ diff --git a/Text/OPML/Types.hs b/Text/OPML/Types.hs new file mode 100644 index 0000000..2de5f64 --- /dev/null +++ b/Text/OPML/Types.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +-- | OPML is an XML format for outlines. +-- +-- Example: +-- +-- > <opml version="2.0"> +-- > <head> +-- > <title>OPML title</title> +-- > <dateCreated>Mon, 31 Oct 2005 19:23:00 GMT</dateCreated> +-- > </head> +-- > <body> +-- > <outline text="Outline 1" created="Mon, 31 Oct 2005 18:21:33 GMT"/> +-- > <outline text="Outline 2" created="Mon, 31 Oct 2005 18:21:33 GMT"/> +-- > </body> +-- > </opml> +module Text.OPML.Types + ( -- * Top-level OPML structure + Opml(..) + , opmlVersion_ + , head_ + , outlines_ + -- * OPML header + , OpmlHead(..) + , Direction(..) + , opmlTitle_ + , opmlCreated_ + , modified_ + , ownerName_ + , ownerEmail_ + , ownerId_ + , docs_ + , expansionState_ + , vertScrollState_ + , window_ + -- * OPML outlines + , OpmlOutline(..) + , _OpmlOutlineGeneric + , _OpmlOutlineLink + , _OpmlOutlineSubscription + -- ** Generic outlines + , OutlineBase(..) + , mkOutlineBase + , text_ + , isComment_ + , isBreakpoint_ + , outlineCreated_ + , categories_ + -- ** Subscription outlines + , OutlineSubscription(..) + , mkOutlineSubscription + , xmlUri_ + , htmlUri_ + , description_ + , language_ + , subscriptionTitle_ + , subscriptionVersion_ + ) where + +-- {{{ Imports +import Control.Lens.TH +import Control.Monad + +import Data.Default +import Data.Map +import Data.NotEmpty +import Data.Text +import Data.Time.Clock +import Data.Time.LocalTime () +import Data.Tree +import Data.Version + +import GHC.Generics + +import Network.URI + +import Test.QuickCheck +import Text.OPML.Arbitrary +-- }}} + +data Direction = Top' | Left' | Bottom' | Right' deriving(Eq, Generic, Ord, Show) + +instance Arbitrary Direction where + arbitrary = elements [Top', Left', Right', Bottom'] + shrink = genericShrink + + +declareLenses [d| + data OpmlHead = OpmlHead + { opmlTitle_ :: Text + , opmlCreated_ :: Maybe UTCTime + , modified_ :: Maybe UTCTime + , ownerName_ :: Text + , ownerEmail_ :: Text + , ownerId_ :: Maybe URI + , docs_ :: Maybe URI + , expansionState_ :: [Int] + , vertScrollState_ :: Maybe Int + , window_ :: Map Direction Int + } + |] + +deriving instance Eq OpmlHead +deriving instance Generic OpmlHead +deriving instance Show OpmlHead + +-- | Use 'def' as a smart constructor. All fields are set to 'mempty'. +instance Default OpmlHead where + def = OpmlHead mempty mzero mzero mempty mempty mzero mzero mzero mzero mempty + +instance Arbitrary OpmlHead where + arbitrary = OpmlHead <$> arbitrary + <*> (unwrap <$> arbitrary) + <*> (unwrap <$> arbitrary) + <*> arbitrary + <*> arbitrary + <*> (unwrap <$> arbitrary) + <*> (unwrap <$> arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + shrink (OpmlHead a b c d e f g h i j) = OpmlHead <$> shrink a + <*> (unwrap <$> shrink (OpmlGen b)) + <*> (unwrap <$> shrink (OpmlGen c)) + <*> shrink d + <*> shrink e + <*> (unwrap <$> shrink (OpmlGen f)) + <*> (unwrap <$> shrink (OpmlGen g)) + <*> shrink h + <*> shrink i + <*> shrink j + +declareLenses [d| + data OutlineBase = OutlineBase + { text_ :: NE Text + , isComment_ :: Maybe Bool + , isBreakpoint_ :: Maybe Bool + , outlineCreated_ :: Maybe UTCTime + , categories_ :: [[NE Text]] + } + |] + +deriving instance Eq OutlineBase +deriving instance Generic OutlineBase +deriving instance Show OutlineBase + +instance Arbitrary OutlineBase where + arbitrary = OutlineBase <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> (unwrap <$> arbitrary) + <*> (unwrap <$> arbitrary) + shrink = genericShrink + +-- | Smart constructor for 'OutlineBase'. +mkOutlineBase :: NE Text -> OutlineBase +mkOutlineBase t = OutlineBase t mzero mzero mzero mzero + + +declareLenses [d| + data OutlineSubscription = OutlineSubscription + { xmlUri_ :: URI + , htmlUri_ :: Maybe URI + , description_ :: Text + , language_ :: Text + , subscriptionTitle_ :: Text + , subscriptionVersion_ :: Text + } + |] + +deriving instance Eq OutlineSubscription +deriving instance Generic OutlineSubscription +deriving instance Show OutlineSubscription + +instance Arbitrary OutlineSubscription where + arbitrary = OutlineSubscription <$> (unwrap <$> arbitrary) + <*> (unwrap <$> arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + shrink (OutlineSubscription a b c d e f) = OutlineSubscription <$> (unwrap <$> shrink (OpmlGen a)) <*> (unwrap <$> shrink (OpmlGen b)) <*> shrink c <*> shrink d <*> shrink e <*> shrink f + +-- | Smart constructor for 'OutlineSubscription' +mkOutlineSubscription :: URI -> OutlineSubscription +mkOutlineSubscription uri = OutlineSubscription uri mzero mempty mempty mempty mempty + + +-- | Outlines are the main payload of an OPML document. +declarePrisms [d| + data OpmlOutline = OpmlOutlineGeneric OutlineBase Text + | OpmlOutlineLink OutlineBase URI + | OpmlOutlineSubscription OutlineBase OutlineSubscription + |] + +deriving instance Eq OpmlOutline +deriving instance Generic OpmlOutline +deriving instance Show OpmlOutline + +instance Arbitrary OpmlOutline where + arbitrary = oneof [ OpmlOutlineGeneric <$> arbitrary <*> arbitrary + , OpmlOutlineLink <$> arbitrary <*> (unwrap <$> arbitrary) + , OpmlOutlineSubscription <$> arbitrary <*> arbitrary + ] + shrink (OpmlOutlineGeneric a b) = OpmlOutlineGeneric <$> shrink a <*> shrink b + shrink (OpmlOutlineLink a b) = OpmlOutlineLink <$> shrink a <*> (unwrap <$> shrink (OpmlGen b)) + shrink (OpmlOutlineSubscription a b) = OpmlOutlineSubscription <$> shrink a <*> shrink b + + +declareLenses [d| + data Opml = Opml + { opmlVersion_ :: Version + , head_ :: OpmlHead + , outlines_ :: Forest OpmlOutline + } + |] + +deriving instance Eq Opml +deriving instance Generic Opml +deriving instance Show Opml + +instance Default Opml where + def = Opml (makeVersion [2, 0]) def mempty + +instance Arbitrary Opml where + arbitrary = Opml <$> (unwrap <$> arbitrary) + <*> arbitrary + <*> listOf (genOutlineTree 1) + shrink (Opml a b c) = Opml <$> (unwrap <$> shrink (OpmlGen a)) <*> shrink b <*> shrink c + +-- | Generate a tree of outlines with the given maximum depth. +-- This generator makes sure that only 'OpmlOutlineGeneric' may have children. +genOutlineTree :: Int -> Gen (Tree OpmlOutline) +genOutlineTree n = do + root <- arbitrary + case (n > 1, root) of + (True, OpmlOutlineGeneric _ _) -> Node <$> pure root <*> listOf (genOutlineTree (n-1)) + (False, OpmlOutlineGeneric _ _) -> return $ Node root [] + _ -> return $ Node root [] diff --git a/data/category.opml b/data/category.opml new file mode 100644 index 0000000..2d68d0c --- /dev/null +++ b/data/category.opml @@ -0,0 +1 @@ +<?xml version="1.0" encoding="ISO-8859-1"?>
<opml version="2.0">
<head>
<title>Illustrating the category attribute</title>
<dateCreated>Mon, 31 Oct 2005 19:23:00 GMT</dateCreated>
</head>
<body>
<outline text="The Mets are the best team in baseball." category="/Philosophy/Baseball/Mets,/Tourism/New York" created="Mon, 31 Oct 2005 18:21:33 GMT"/>
</body>
</opml>
\ No newline at end of file diff --git a/data/directory.opml b/data/directory.opml new file mode 100644 index 0000000..e7ee1ff --- /dev/null +++ b/data/directory.opml @@ -0,0 +1 @@ +<?xml version="1.0" encoding="ISO-8859-1"?>
<opml version="2.0">
<head>
<title>scriptingNewsDirectory.opml</title>
<dateCreated>Thu, 13 Oct 2005 15:34:07 GMT</dateCreated>
<dateModified>Tue, 25 Oct 2005 21:33:57 GMT</dateModified>
<ownerName>Dave Winer</ownerName>
<ownerEmail>dwiner@yahoo.com</ownerEmail>
<expansionState></expansionState>
<vertScrollState>1</vertScrollState>
<windowTop>105</windowTop>
<windowLeft>466</windowLeft>
<windowBottom>386</windowBottom>
<windowRight>964</windowRight>
</head>
<body>
<outline text="Scripting News sites" created="Sun, 16 Oct 2005 05:56:10 GMT" type="link" url="http://hosting.opml.org/dave/mySites.opml"/>
<outline text="News.Com top 100 OPML" created="Tue, 25 Oct 2005 21:33:28 GMT" type="link" url="http://news.com.com/html/ne/blogs/CNETNewsBlog100.opml"/>
<outline text="BloggerCon III Blogroll" created="Mon, 24 Oct 2005 05:23:52 GMT" type="link" url="http://static.bloggercon.org/iii/blogroll.opml"/>
<outline text="TechCrunch reviews" type="link" url="http://hosting.opml.org/techcrunch.opml.org/TechCrunch.opml"/>
<outline text="Tod Maffin's directory of Public Radio podcasts" type="link" url="http://todmaffin.com/radio.opml"/>
<outline text="Adam Curry's iPodder.org directory" type="link" url="http://homepage.mac.com/dailysourcecode/DSC/ipodderDirectory.opml"/>
<outline text="Memeorandum" created="Thu, 13 Oct 2005 15:19:05 GMT" type="link" url="http://tech.memeorandum.com/index.opml"/>
<outline text="DaveNet archive" created="Wed, 12 Oct 2005 01:39:56 GMT" type="link" url="http://davenet.opml.org/index.opml"/>
</body>
</opml>
\ No newline at end of file diff --git a/data/placesLived.opml b/data/placesLived.opml new file mode 100644 index 0000000..70ecd1f --- /dev/null +++ b/data/placesLived.opml @@ -0,0 +1 @@ +<?xml version="1.0" encoding="ISO-8859-1"?>
<opml version="2.0">
<head>
<title>placesLived.opml</title>
<dateCreated>Mon, 27 Feb 2006 12:09:48 GMT</dateCreated>
<dateModified>Mon, 27 Feb 2006 12:11:44 GMT</dateModified>
<ownerName>Dave Winer</ownerName>
<ownerId>http://www.opml.org/profiles/sendMail?usernum=1</ownerId>
<expansionState>1, 2, 5, 10, 13, 15</expansionState>
<vertScrollState>1</vertScrollState>
<windowTop>242</windowTop>
<windowLeft>329</windowLeft>
<windowBottom>665</windowBottom>
<windowRight>547</windowRight>
</head>
<body>
<outline text="Places I've lived">
<outline text="Boston">
<outline text="Cambridge"/>
<outline text="West Newton"/>
</outline>
<outline text="Bay Area">
<outline text="Mountain View"/>
<outline text="Los Gatos"/>
<outline text="Palo Alto"/>
<outline text="Woodside"/>
</outline>
<outline text="New Orleans">
<outline text="Uptown"/>
<outline text="Metairie"/>
</outline>
<outline text="Wisconsin">
<outline text="Madison"/>
</outline>
<outline text="Florida" type="include" url="http://hosting.opml.org/dave/florida.opml"/>
<outline text="New York">
<outline text="Jackson Heights"/>
<outline text="Flushing"/>
<outline text="The Bronx"/>
</outline>
</outline>
</body>
</opml>
\ No newline at end of file diff --git a/data/simpleScript.opml b/data/simpleScript.opml new file mode 100644 index 0000000..8f15f96 --- /dev/null +++ b/data/simpleScript.opml @@ -0,0 +1 @@ +<?xml version="1.0" encoding="ISO-8859-1"?>
<opml version="2.0">
<head>
<title>workspace.userlandsamples.doSomeUpstreaming</title>
<dateCreated>Mon, 11 Feb 2002 22:48:02 GMT</dateCreated>
<dateModified>Sun, 30 Oct 2005 03:30:17 GMT</dateModified>
<ownerName>Dave Winer</ownerName>
<ownerEmail>dwiner@yahoo.com</ownerEmail>
<expansionState>1, 2, 4</expansionState>
<vertScrollState>1</vertScrollState>
<windowTop>74</windowTop>
<windowLeft>41</windowLeft>
<windowBottom>314</windowBottom>
<windowRight>475</windowRight>
</head>
<body>
<outline text="Changes" isComment="true">
<outline text="1/3/02; 4:54:25 PM by DW">
<outline text="Change "playlist" to "radio"."/>
</outline>
<outline text="2/12/01; 1:49:33 PM by DW" isComment="true">
<outline text="Test upstreaming by sprinkling a few files in a nice new test folder."/>
</outline>
</outline>
<outline text="on writetestfile (f, size)">
<outline text="file.surefilepath (f)" isBreakpoint="true"/>
<outline text="file.writewholefile (f, string.filledstring ("x", size))"/>
</outline>
<outline text="local (folder = user.radio.prefs.wwwfolder + "test\\largefiles\\")"/>
<outline text="for ch = 'a' to 'z'">
<outline text="writetestfile (folder + ch + ".html", random (1000, 16000))"/>
</outline>
</body>
</opml>
\ No newline at end of file diff --git a/data/states.opml b/data/states.opml new file mode 100644 index 0000000..28901ff --- /dev/null +++ b/data/states.opml @@ -0,0 +1 @@ +<?xml version="1.0" encoding="ISO-8859-1"?>
<opml version="2.0">
<head>
<title>states.opml</title>
<dateCreated>Tue, 15 Mar 2005 16:35:45 GMT</dateCreated>
<dateModified>Thu, 14 Jul 2005 23:41:05 GMT</dateModified>
<ownerName>Dave Winer</ownerName>
<ownerEmail>dave@scripting.com</ownerEmail>
<expansionState>1, 6, 13, 16, 18, 20</expansionState>
<vertScrollState>1</vertScrollState>
<windowTop>106</windowTop>
<windowLeft>106</windowLeft>
<windowBottom>558</windowBottom>
<windowRight>479</windowRight>
</head>
<body>
<outline text="United States">
<outline text="Far West">
<outline text="Alaska"/>
<outline text="California"/>
<outline text="Hawaii"/>
<outline text="Nevada">
<outline text="Reno" created="Tue, 12 Jul 2005 23:56:35 GMT"/>
<outline text="Las Vegas" created="Tue, 12 Jul 2005 23:56:37 GMT"/>
<outline text="Ely" created="Tue, 12 Jul 2005 23:56:39 GMT"/>
<outline text="Gerlach" created="Tue, 12 Jul 2005 23:56:47 GMT"/>
</outline>
<outline text="Oregon"/>
<outline text="Washington"/>
</outline>
<outline text="Great Plains">
<outline text="Kansas"/>
<outline text="Nebraska"/>
<outline text="North Dakota"/>
<outline text="Oklahoma"/>
<outline text="South Dakota"/>
</outline>
<outline text="Mid-Atlantic">
<outline text="Delaware"/>
<outline text="Maryland"/>
<outline text="New Jersey"/>
<outline text="New York"/>
<outline text="Pennsylvania"/>
</outline>
<outline text="Midwest">
<outline text="Illinois"/>
<outline text="Indiana"/>
<outline text="Iowa"/>
<outline text="Kentucky"/>
<outline text="Michigan"/>
<outline text="Minnesota"/>
<outline text="Missouri"/>
<outline text="Ohio"/>
<outline text="West Virginia"/>
<outline text="Wisconsin"/>
</outline>
<outline text="Mountains">
<outline text="Colorado"/>
<outline text="Idaho"/>
<outline text="Montana"/>
<outline text="Utah"/>
<outline text="Wyoming"/>
</outline>
<outline text="New England">
<outline text="Connecticut"/>
<outline text="Maine"/>
<outline text="Massachusetts"/>
<outline text="New Hampshire"/>
<outline text="Rhode Island"/>
<outline text="Vermont"/>
</outline>
<outline text="South">
<outline text="Alabama"/>
<outline text="Arkansas"/>
<outline text="Florida"/>
<outline text="Georgia"/>
<outline text="Louisiana"/>
<outline text="Mississippi"/>
<outline text="North Carolina"/>
<outline text="South Carolina"/>
<outline text="Tennessee"/>
<outline text="Virginia"/>
</outline>
<outline text="Southwest">
<outline text="Arizona"/>
<outline text="New Mexico"/>
<outline text="Texas"/>
</outline>
</outline>
</body>
</opml>
\ No newline at end of file diff --git a/data/subscriptionList.opml b/data/subscriptionList.opml new file mode 100644 index 0000000..8f60639 --- /dev/null +++ b/data/subscriptionList.opml @@ -0,0 +1,31 @@ +<?xml version="1.0" encoding="ISO-8859-1"?> +<opml version="2.0"> + <head> + <title>mySubscriptions.opml</title> + <dateCreated>Sat, 18 Jun 2005 12:11:52 GMT</dateCreated> + <dateModified>Tue, 02 Aug 2005 21:42:48 GMT</dateModified> + <ownerName>Dave Winer</ownerName> + <ownerEmail>dave@scripting.com</ownerEmail> + <expansionState></expansionState> + <vertScrollState>1</vertScrollState> + <windowTop>61</windowTop> + <windowLeft>304</windowLeft> + <windowBottom>562</windowBottom> + <windowRight>842</windowRight> + </head> + <body> + <outline text="CNET News.com" description="Tech news and business reports by CNET News.com. Focused on information technology, core topics include computers, hardware, software, networking, and Internet media." htmlUrl="http://news.com.com/" language="unknown" title="CNET News.com" type="rss" version="RSS2" xmlUrl="http://news.com.com/2547-1_3-0-5.xml"/> + <outline text="washingtonpost.com - Politics" description="Politics" htmlUrl="http://www.washingtonpost.com/wp-dyn/politics?nav=rss_politics" language="unknown" title="washingtonpost.com - Politics" type="rss" version="RSS2" xmlUrl="http://www.washingtonpost.com/wp-srv/politics/rssheadlines.xml"/> + <outline text="Scobleizer: Microsoft Geek Blogger" description="Robert Scoble's look at geek and Microsoft life." htmlUrl="http://radio.weblogs.com/0001011/" language="unknown" title="Scobleizer: Microsoft Geek Blogger" type="rss" version="RSS2" xmlUrl="http://radio.weblogs.com/0001011/rss.xml"/> + <outline text="Yahoo! News: Technology" description="Technology" htmlUrl="http://news.yahoo.com/news?tmpl=index&cid=738" language="unknown" title="Yahoo! News: Technology" type="rss" version="RSS2" xmlUrl="http://rss.news.yahoo.com/rss/tech"/> + <outline text="Workbench" description="Programming and publishing news and comment" htmlUrl="http://www.cadenhead.org/workbench/" language="unknown" title="Workbench" type="rss" version="RSS2" xmlUrl="http://www.cadenhead.org/workbench/rss.xml"/> + <outline text="Christian Science Monitor | Top Stories" description="Read the front page stories of csmonitor.com." htmlUrl="http://csmonitor.com" language="unknown" title="Christian Science Monitor | Top Stories" type="rss" version="RSS" xmlUrl="http://www.csmonitor.com/rss/top.rss"/> + <outline text="Dictionary.com Word of the Day" description="A new word is presented every day with its definition and example sentences from actual published works." htmlUrl="http://dictionary.reference.com/wordoftheday/" language="unknown" title="Dictionary.com Word of the Day" type="rss" version="RSS" xmlUrl="http://www.dictionary.com/wordoftheday/wotd.rss"/> + <outline text="The Motley Fool" description="To Educate, Amuse, and Enrich" htmlUrl="http://www.fool.com" language="unknown" title="The Motley Fool" type="rss" version="RSS" xmlUrl="http://www.fool.com/xml/foolnews_rss091.xml"/> + <outline text="InfoWorld: Top News" description="The latest on Top News from InfoWorld" htmlUrl="http://www.infoworld.com/news/index.html" language="unknown" title="InfoWorld: Top News" type="rss" version="RSS2" xmlUrl="http://www.infoworld.com/rss/news.xml"/> + <outline text="NYT > Business" description="Find breaking news & business news on Wall Street, media & advertising, international business, banking, interest rates, the stock market, currencies & funds." htmlUrl="http://www.nytimes.com/pages/business/index.html?partner=rssnyt" language="unknown" title="NYT > Business" type="rss" version="RSS2" xmlUrl="http://www.nytimes.com/services/xml/rss/nyt/Business.xml"/> + <outline text="NYT > Technology" description="" htmlUrl="http://www.nytimes.com/pages/technology/index.html?partner=rssnyt" language="unknown" title="NYT > Technology" type="rss" version="RSS2" xmlUrl="http://www.nytimes.com/services/xml/rss/nyt/Technology.xml"/> + <outline text="Scripting News" description="It's even worse than it appears." htmlUrl="http://www.scripting.com/" language="unknown" title="Scripting News" type="rss" version="RSS2" xmlUrl="http://www.scripting.com/rss.xml"/> + <outline text="Wired News" description="Technology, and the way we do business, is changing the world we know. Wired News is a technology - and business-oriented news service feeding an intelligent, discerning audience. What role does technology play in the day-to-day living of your life? Wired News tells you. How has evolving technology changed the face of the international business world? Wired News puts you in the picture." htmlUrl="http://www.wired.com/" language="unknown" title="Wired News" type="rss" version="RSS" xmlUrl="http://www.wired.com/news_drop/netcenter/netcenter.rdf"/> + </body> +</opml> diff --git a/opml-conduit.cabal b/opml-conduit.cabal new file mode 100644 index 0000000..d0a163f --- /dev/null +++ b/opml-conduit.cabal @@ -0,0 +1,77 @@ +name: opml-conduit +version: 0.1.0.0 +synopsis: Streaming parser/renderer for the OPML 2.0 format. +description: + This library implements the OPML 2.0 standard (<http://dev.opml.org/spec2.html>) as a 'conduit' parser/renderer. +homepage: https://github.com/k0ral/opml-conduit +license: OtherLicense +license-file: LICENSE +author: koral <koral@mailoo.org> +maintainer: koral <koral@mailoo.org> +category: Conduit, Text, XML +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 +data-files: + data/category.opml + data/directory.opml + data/placesLived.opml + data/simpleScript.opml + data/states.opml + data/subscriptionList.opml + +source-repository head + type: git + location: git://github.com/k0ral/opml-conduit.git + +library + exposed-modules: Data.NotEmpty + , Text.OPML + , Text.OPML.Arbitrary + , Text.OPML.Stream.Parse + , Text.OPML.Stream.Render + , Text.OPML.Types + build-depends: + base >= 4.8 && < 5 + , case-insensitive + , conduit + , containers + , data-default + , exceptions + , lens + , monoid-subclasses + , mono-traversable + , network-uri + , QuickCheck + , quickcheck-instances + , semigroups + , text + , time >= 1.5 + , timerep >= 2.0.0 + , xml-conduit >= 1.2.5 + , xml-types + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-unused-do-bind + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: Paths_opml_conduit + build-depends: + base >= 4.8 + , conduit + , conduit-combinators + , containers + , exceptions + , lens + , mtl + , network-uri + , opml-conduit + , resourcet + , tasty + , tasty-hunit + , tasty-quickcheck + , xml-conduit >= 1.2.5 + default-language: Haskell2010 + ghc-options: -Wall diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..1ac9e7e --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +import Control.Lens.Fold +import Control.Lens.Getter +import Control.Monad.Catch.Pure +import Control.Monad.Identity +import Control.Monad.Trans.Resource + +import Data.Conduit +import Data.Conduit.Combinators as Conduit hiding (length, map) +import Data.String +import Data.Tree +import Data.Version + +import Paths_opml_conduit + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Text.OPML.Arbitrary () +import Text.OPML.Stream.Parse +import Text.OPML.Stream.Render +import Text.OPML.Types +import Text.XML.Stream.Parse as XML + + +main :: IO () +main = defaultMain $ testGroup "Tests" + [ unitTests + , properties + ] + +unitTests :: TestTree +unitTests = testGroup "Unit tests" + [ categoriesCase + , directoryCase + , placesCase + , scriptCase + , statesCase + , subscriptionsCase + ] + +properties :: TestTree +properties = testGroup "Properties" + [ inverseHeadProperty + , inverseProperty + ] + +categoriesCase :: TestTree +categoriesCase = testCase "Parse categories list" $ do + dataFile <- fromString <$> getDataFileName "data/category.opml" + result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml + + (result ^. opmlVersion_) @?= Version [2,0] [] + (result ^. head_ . opmlTitle_) @?= "Illustrating the category attribute" + show (result ^. head_ . opmlCreated_) @?= "Just 2005-10-31 19:23:00 UTC" + length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineGeneric) @?= 1 + map (map length .levels) (result ^. outlines_) @?= [[1]] + +directoryCase :: TestTree +directoryCase = testCase "Parse directory tree" $ do + dataFile <- fromString <$> getDataFileName "data/directory.opml" + result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml + + (result ^. opmlVersion_) @?= Version [2,0] [] + (result ^. head_ . opmlTitle_) @?= "scriptingNewsDirectory.opml" + show (result ^. head_ . opmlCreated_) @?= "Just 2005-10-13 15:34:07 UTC" + show (result ^. head_ . modified_) @?= "Just 2005-10-25 21:33:57 UTC" + (result ^. head_ . ownerName_) @?= "Dave Winer" + (result ^. head_ . ownerEmail_) @?= "dwiner@yahoo.com" + (result ^. head_ . expansionState_) @?= [] + (result ^. head_ . vertScrollState_) @?= Just 1 + (result ^. head_ . window_) @?= [(Top',105), (Left',466), (Bottom',386), (Right',964)] + length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineLink) @?= 8 + map (map length .levels) (result ^. outlines_) @?= [[1], [1], [1], [1], [1], [1], [1], [1]] + +placesCase :: TestTree +placesCase = testCase "Parse places list" $ do + dataFile <- fromString <$> getDataFileName "data/placesLived.opml" + result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml + + (result ^. opmlVersion_) @?= Version [2,0] [] + (result ^. head_ . opmlTitle_) @?= "placesLived.opml" + show (result ^. head_ . opmlCreated_) @?= "Just 2006-02-27 12:09:48 UTC" + show (result ^. head_ . modified_) @?= "Just 2006-02-27 12:11:44 UTC" + (result ^. head_ . ownerName_) @?= "Dave Winer" + show (result ^. head_ . ownerId_) @?= "Just http://www.opml.org/profiles/sendMail?usernum=1" + (result ^. head_ . expansionState_) @?= [1,2,5,10,13,15] + (result ^. head_ . vertScrollState_) @?= Just 1 + (result ^. head_ . window_) @?= [(Top',242), (Left',329), (Bottom',665), (Right',547)] + length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineGeneric) @?= 18 + length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineLink) @?= 1 + map (map length .levels) (result ^. outlines_) @?= [[1,6,12]] + + +scriptCase :: TestTree +scriptCase = testCase "Parse script" $ do + dataFile <- fromString <$> getDataFileName "data/simpleScript.opml" + result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml + + (result ^. opmlVersion_) @?= Version [2,0] [] + (result ^. head_ . opmlTitle_) @?= "workspace.userlandsamples.doSomeUpstreaming" + show (result ^. head_ . opmlCreated_) @?= "Just 2002-02-11 22:48:02 UTC" + show (result ^. head_ . modified_) @?= "Just 2005-10-30 03:30:17 UTC" + (result ^. head_ . ownerName_) @?= "Dave Winer" + (result ^. head_ . ownerEmail_) @?= "dwiner@yahoo.com" + (result ^. head_ . expansionState_) @?= [1, 2, 4] + (result ^. head_ . vertScrollState_) @?= Just 1 + (result ^. head_ . window_) @?= [(Top', 74), (Left', 41), (Bottom', 314), (Right', 475)] + length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineGeneric) @?= 11 + map (map length .levels) (result ^. outlines_) @?= [[1,2,2], [1,2], [1], [1,1]] + + +statesCase :: TestTree +statesCase = testCase "Parse states list" $ do + dataFile <- fromString <$> getDataFileName "data/states.opml" + result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml + + (result ^. opmlVersion_) @?= Version [2,0] [] + (result ^. head_ . opmlTitle_) @?= "states.opml" + show (result ^. head_ . opmlCreated_) @?= "Just 2005-03-15 16:35:45 UTC" + show (result ^. head_ . modified_) @?= "Just 2005-07-14 23:41:05 UTC" + (result ^. head_ . ownerName_) @?= "Dave Winer" + (result ^. head_ . ownerEmail_) @?= "dave@scripting.com" + (result ^. head_ . expansionState_) @?= [1, 6, 13, 16, 18, 20] + (result ^. head_ . vertScrollState_) @?= Just 1 + (result ^. head_ . window_) @?= [(Top', 106), (Left', 106), (Bottom', 558), (Right', 479)] + length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineGeneric) @?= 63 + map (map length .levels) (result ^. outlines_) @?= [[1, 8, 50, 4]] + + +subscriptionsCase :: TestTree +subscriptionsCase = testCase "Parse subscriptions list" $ do + dataFile <- fromString <$> getDataFileName "data/subscriptionList.opml" + result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml + + (result ^. opmlVersion_) @?= Version [2,0] [] + (result ^. head_ . opmlTitle_) @?= "mySubscriptions.opml" + show (result ^. head_ . opmlCreated_) @?= "Just 2005-06-18 12:11:52 UTC" + show (result ^. head_ . modified_) @?= "Just 2005-08-02 21:42:48 UTC" + (result ^. head_ . ownerName_) @?= "Dave Winer" + (result ^. head_ . ownerEmail_) @?= "dave@scripting.com" + (result ^. head_ . vertScrollState_) @?= Just 1 + (result ^. head_ . window_) @?= [(Top', 61), (Left', 304), (Bottom', 562), (Right',842)] + length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineSubscription) @?= 13 + +inverseHeadProperty :: TestTree +inverseHeadProperty = testProperty "parse . render = id (on OpmlHead)" $ \opmlHead -> either (const False) (opmlHead ==) (runIdentity . runCatchT . runConduit $ renderOpmlHead opmlHead =$= force "Invalid OPML head" parseOpmlHead) + +inverseProperty :: TestTree +inverseProperty = testProperty "parse . render = id" $ \opml -> either (const False) (opml ==) (runIdentity . runCatchT . runConduit $ renderOpml opml =$= force "Invalid OPML" parseOpml) |