diff --git a/Data/NotEmpty.hs b/Data/NotEmpty.hs new file mode 100644 --- /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 --- /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 + +Everyone is permitted to copy and distribute verbatim or modified +copies of this license document, and changing it is allowed as long +as the name is changed. + +DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE +TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + +0. You just DO WHAT THE FUCK YOU WANT TO. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/OPML.hs b/Text/OPML.hs new file mode 100644 --- /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 --- /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 --- /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 @\@ 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 @\@ 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 @\@ 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 ." parseOpmlHead + <*> force "Missing ." (tagName "body" ignoreAttrs $ \_ -> many parseOpmlOutline) diff --git a/Text/OPML/Stream/Render.hs b/Text/OPML/Stream/Render.hs new file mode 100644 --- /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 @\@ 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 @\@ 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 @\@ 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 --- /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 title +-- > Mon, 31 Oct 2005 19:23:00 GMT +-- > +-- > +-- > +-- > +-- > +-- > +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 --- /dev/null +++ b/data/category.opml @@ -0,0 +1,1 @@ + Illustrating the category attribute Mon, 31 Oct 2005 19:23:00 GMT diff --git a/data/directory.opml b/data/directory.opml new file mode 100644 --- /dev/null +++ b/data/directory.opml @@ -0,0 +1,1 @@ + scriptingNewsDirectory.opml Thu, 13 Oct 2005 15:34:07 GMT Tue, 25 Oct 2005 21:33:57 GMT Dave Winer dwiner@yahoo.com 1 105 466 386 964 diff --git a/data/placesLived.opml b/data/placesLived.opml new file mode 100644 --- /dev/null +++ b/data/placesLived.opml @@ -0,0 +1,1 @@ + placesLived.opml Mon, 27 Feb 2006 12:09:48 GMT Mon, 27 Feb 2006 12:11:44 GMT Dave Winer http://www.opml.org/profiles/sendMail?usernum=1 1, 2, 5, 10, 13, 15 1 242 329 665 547 diff --git a/data/simpleScript.opml b/data/simpleScript.opml new file mode 100644 --- /dev/null +++ b/data/simpleScript.opml @@ -0,0 +1,1 @@ + workspace.userlandsamples.doSomeUpstreaming Mon, 11 Feb 2002 22:48:02 GMT Sun, 30 Oct 2005 03:30:17 GMT Dave Winer dwiner@yahoo.com 1, 2, 4 1 74 41 314 475 diff --git a/data/states.opml b/data/states.opml new file mode 100644 --- /dev/null +++ b/data/states.opml @@ -0,0 +1,1 @@ + states.opml Tue, 15 Mar 2005 16:35:45 GMT Thu, 14 Jul 2005 23:41:05 GMT Dave Winer dave@scripting.com 1, 6, 13, 16, 18, 20 1 106 106 558 479 diff --git a/data/subscriptionList.opml b/data/subscriptionList.opml new file mode 100644 --- /dev/null +++ b/data/subscriptionList.opml @@ -0,0 +1,31 @@ + + + + mySubscriptions.opml + Sat, 18 Jun 2005 12:11:52 GMT + Tue, 02 Aug 2005 21:42:48 GMT + Dave Winer + dave@scripting.com + + 1 + 61 + 304 + 562 + 842 + + + + + + + + + + + + + + + + + diff --git a/opml-conduit.cabal b/opml-conduit.cabal new file mode 100644 --- /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 () as a 'conduit' parser/renderer. +homepage: https://github.com/k0ral/opml-conduit +license: OtherLicense +license-file: LICENSE +author: koral +maintainer: koral +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 --- /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)