summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Data/NotEmpty.hs43
-rw-r--r--LICENSE13
-rw-r--r--Setup.hs2
-rw-r--r--Text/OPML.hs10
-rw-r--r--Text/OPML/Arbitrary.hs72
-rw-r--r--Text/OPML/Stream/Parse.hs175
-rw-r--r--Text/OPML/Stream/Render.hs100
-rw-r--r--Text/OPML/Types.hs244
-rw-r--r--data/category.opml1
-rw-r--r--data/directory.opml1
-rw-r--r--data/placesLived.opml1
-rw-r--r--data/simpleScript.opml1
-rw-r--r--data/states.opml1
-rw-r--r--data/subscriptionList.opml31
-rw-r--r--opml-conduit.cabal77
-rw-r--r--test/Main.hs151
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
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..9c20de0
--- /dev/null
+++ b/LICENSE
@@ -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 &quot;playlist&quot; to &quot;radio&quot;."/> </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 (&quot;x&quot;, size))"/> </outline> <outline text="local (folder = user.radio.prefs.wwwfolder + &quot;test\\largefiles\\&quot;)"/> <outline text="for ch = 'a' to 'z'"> <outline text="writetestfile (folder + ch + &quot;.html&quot;, 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&amp;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 &gt; Business" description="Find breaking news &amp; business news on Wall Street, media &amp; advertising, international business, banking, interest rates, the stock market, currencies &amp; funds." htmlUrl="http://www.nytimes.com/pages/business/index.html?partner=rssnyt" language="unknown" title="NYT &gt; Business" type="rss" version="RSS2" xmlUrl="http://www.nytimes.com/services/xml/rss/nyt/Business.xml"/>
+ <outline text="NYT &gt; Technology" description="" htmlUrl="http://www.nytimes.com/pages/technology/index.html?partner=rssnyt" language="unknown" title="NYT &gt; 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)