diff --git a/Text/OPML/Stream/Parse.hs b/Text/OPML/Stream/Parse.hs --- a/Text/OPML/Stream/Parse.hs +++ b/Text/OPML/Stream/Parse.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -- | Streaming parser for the OPML 2.0 standard. -- @@ -10,22 +11,22 @@ parseOpml , parseOpmlHead , parseOpmlOutline - -- * Exceptions - , OpmlException(..) ) where -- {{{ Imports +import Control.Applicative 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.Conduit.Parser +import Data.Conduit.Parser.XML +import Data.Default import Data.List.NonEmpty hiding (filter, map) -import Data.Map (Map) import Data.Maybe +import Data.Monoid import Data.Monoid.Textual hiding (map) import Data.MonoTraversable import Data.NonNull @@ -37,16 +38,13 @@ import Data.Version import Data.XML.Types -import Network.URI (URI) -import qualified Network.URI as N +import Network.URI (URI, parseURI) import Numeric -import Prelude hiding (foldr, lookup) - import Text.OPML.Types +import Text.Parser.Combinators import Text.ParserCombinators.ReadP (readP_to_S) -import Text.XML.Stream.Parse -- }}} data OpmlException = MissingText @@ -66,114 +64,126 @@ 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 +asURI :: (MonadThrow m) => Text -> m URI +asURI t = maybe (throwM $ InvalidURI t) return . parseURI $ unpack t -parseVersion' :: (MonadThrow m) => Text -> m Version -parseVersion' v = case filter (onull . snd) . readP_to_S parseVersion $ unpack v of +asVersion :: (MonadThrow m) => Text -> m Version +asVersion 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 (onull . snd) . readSigned readDec $ unpack t of +asDecimal :: (MonadThrow m, Integral a) => Text -> m a +asDecimal t = case filter (onull . snd) . 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 +asExpansionState :: (MonadThrow m, Integral a) => Text -> m [a] +asExpansionState t = mapM asDecimal . filter (not . onull) . map strip $ split (== ',') t -parseTime :: (MonadThrow m) => Text -> m UTCTime -parseTime t = maybe (throwM $ InvalidTime t) (return . zonedTimeToUTC) $ parseTimeRFC822 t +asTime :: (MonadThrow m) => Text -> m UTCTime +asTime 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 +asBool :: (MonadThrow m) => Text -> m Bool +asBool t | mk t == "true" = return True | mk t == "false" = return False | otherwise = throwM $ InvalidBool t +asNonNull :: (MonoFoldable mono, MonadThrow m) => mono -> m (NonNull mono) +asNonNull = maybe (throwM MissingText) return . fromNullable -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) - ] +asCategories :: Text -> [NonEmpty (NonNull Text)] +asCategories = mapMaybe (nonEmpty . mapMaybe fromNullable . split (== '/')) . split (== ',') + +dateCreated, dateModified :: MonadCatch m => ConduitParser Event m UTCTime +dateCreated = tagName "dateCreated" ignoreAttrs $ \_ -> content asTime +dateModified = tagName "dateModified" ignoreAttrs $ \_ -> content asTime + +docs, ownerId :: MonadCatch m => ConduitParser Event m URI +docs = tagName "docs" ignoreAttrs $ \_ -> content asURI +ownerId = tagName "ownerId" ignoreAttrs $ \_ -> content asURI + +expansionState :: (MonadCatch m, Integral a) => ConduitParser Event m [a] +expansionState = tagName "expansionState" ignoreAttrs $ \_ -> content asExpansionState + +ownerEmail, ownerName, opmlTitle :: MonadCatch m => ConduitParser Event m Text +ownerEmail = tagName "ownerEmail" ignoreAttrs $ const textContent +ownerName = tagName "ownerName" ignoreAttrs $ const textContent +opmlTitle = tagName "title" ignoreAttrs $ const textContent + +vertScrollState, windowBottom, windowLeft, windowRight, windowTop :: (MonadCatch m, Integral a) => ConduitParser Event m a +vertScrollState = tagName "vertScrollState" ignoreAttrs $ \_ -> content asDecimal +windowBottom = tagName "windowBottom" ignoreAttrs $ \_ -> content asDecimal +windowLeft = tagName "windowLeft" ignoreAttrs $ \_ -> content asDecimal +windowRight = tagName "windowRight" ignoreAttrs $ \_ -> content asDecimal +windowTop = tagName "windowTop" ignoreAttrs $ \_ -> content asDecimal + + +opmlHeadBuilders :: MonadCatch m => [ConduitParser Event m (Endo OpmlHead)] +opmlHeadBuilders = [ liftM (Endo . set opmlCreated_ . Just) dateCreated + , liftM (Endo . set modified_ . Just) dateModified + , liftM (Endo . set docs_ . Just) docs + , liftM (Endo . set expansionState_) expansionState + , liftM (Endo . set ownerEmail_) ownerEmail + , liftM (Endo . set ownerId_ . Just) ownerId + , liftM (Endo . set ownerName_) ownerName + , liftM (Endo . set opmlTitle_) opmlTitle + , liftM (Endo . set vertScrollState_ . Just) vertScrollState + , liftM (Endo . set (window_.at Bottom') . Just) windowBottom + , liftM (Endo . set (window_.at Left') . Just) windowLeft + , liftM (Endo . set (window_.at Right') . Just) windowRight + , liftM (Endo . set (window_.at Top') . Just) windowTop + , unknown >> return mempty + ] + where unknown = tagPredicate (const True) ignoreAttrs $ \_ -> return () + -- | Parse the @\@ section. -- This function is more lenient than what the standard 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 -> [NonEmpty (NonNull Text)] -parseCategories = mapMaybe (nonEmpty . mapMaybe fromNullable . split (== '/')) . split (== ',') +parseOpmlHead :: (MonadCatch m) => ConduitParser Event m OpmlHead +parseOpmlHead = named "OPML section" $ tagName "head" ignoreAttrs $ \_ -> do + builders <- many $ choice opmlHeadBuilders + return $ (appEndo $ mconcat builders) def -- | 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) = do - text <- maybe (throwM MissingText) return $ fromNullable t - return $ OutlineBase text - (parseBool =<< comment) - (parseBool =<< breakpoint) - (parseTime =<< created) - (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) +parseOpmlOutline :: (MonadCatch m) => ConduitParser Event m (Tree OpmlOutline) +parseOpmlOutline = tagName "outline" attributes handler "OPML section" where + attributes = do + otype <- optional $ textAttr "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 = (,,,,) <$> attr "text" asNonNull + <*> optional (attr "isComment" asBool) + <*> optional (attr "isBreakpoint" asBool) + <*> optional (attr "created" asTime) + <*> optional (attr "category" (Just . asCategories)) + linkAttr = textAttr "url" + subscriptionAttr = (,,,,,) <$> attr "xmlUrl" asURI + <*> optional (attr "htmlUrl" asURI) + <*> optional (textAttr "description") + <*> optional (textAttr "language") + <*> optional (textAttr "title") + <*> optional (textAttr "version") + handler (_, b, Just s, _) = Node <$> (OpmlOutlineSubscription <$> baseHandler b <*> pure (subscriptionHandler s)) <*> pure [] + handler (_, b, _, Just l) = Node <$> (OpmlOutlineLink <$> baseHandler b <*> asURI l) <*> pure [] + handler (otype, b, _, _) = Node <$> (OpmlOutlineGeneric <$> baseHandler b <*> pure (fromMaybe mempty otype)) + <*> many parseOpmlOutline + baseHandler (text, comment, breakpoint, created, category) = return $ OutlineBase text comment breakpoint created (fromMaybe mempty category) + subscriptionHandler (uri, html, description, language, title, version) = OutlineSubscription uri html (fromMaybe mempty description) (fromMaybe mempty language) (fromMaybe mempty title) (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) +parseOpml :: (MonadCatch m) => ConduitParser Event m Opml +parseOpml = tagName "opml" attributes handler " section" where + attributes = attr "version" asVersion <* ignoreAttrs + handler version = Opml version + <$> parseOpmlHead + <*> tagName "body" ignoreAttrs (const $ many parseOpmlOutline) " section." diff --git a/opml-conduit.cabal b/opml-conduit.cabal --- a/opml-conduit.cabal +++ b/opml-conduit.cabal @@ -1,5 +1,5 @@ name: opml-conduit -version: 0.2.0.1 +version: 0.3.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. @@ -34,6 +34,7 @@ base >= 4.8 && < 5 , case-insensitive , conduit + , conduit-parse , containers , data-default , exceptions @@ -43,6 +44,7 @@ , monoid-subclasses , mono-traversable , network-uri >= 2.6 + , parsers , QuickCheck , quickcheck-instances , semigroups @@ -50,7 +52,8 @@ , time >= 1.5 , timerep >= 2.0.0 , unordered-containers - , xml-conduit >= 1.2.5 + , xml-conduit >= 1.3 + , xml-conduit-parse >= 0.2.0.0 , xml-types default-language: Haskell2010 ghc-options: -Wall -fno-warn-unused-do-bind @@ -64,17 +67,20 @@ base >= 4.8 , conduit , conduit-combinators + , conduit-parse , containers + , data-default , exceptions , hlint , lens , mtl , network-uri >= 2.6 , opml-conduit + , parsers , resourcet , tasty , tasty-hunit , tasty-quickcheck - , xml-conduit >= 1.2.5 + , xml-conduit-parse default-language: Haskell2010 ghc-options: -Wall diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -9,6 +9,9 @@ import Data.Conduit import Data.Conduit.Combinators as Conduit hiding (length, map, null) +import Data.Conduit.Parser +import Data.Conduit.Parser.XML as XML +import Data.Default import Data.String import Data.Tree import Data.Version @@ -19,11 +22,11 @@ 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 () @@ -46,7 +49,7 @@ properties :: TestTree properties = testGroup "Properties" [ inverseHeadProperty - , inverseProperty + -- , inverseProperty ] @@ -59,7 +62,7 @@ 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 <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml (result ^. opmlVersion_) @?= Version [2,0] [] (result ^. head_ . opmlTitle_) @?= "Illustrating the category attribute" @@ -71,7 +74,7 @@ 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 <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml (result ^. opmlVersion_) @?= Version [2,0] [] (result ^. head_ . opmlTitle_) @?= "scriptingNewsDirectory.opml" @@ -89,7 +92,7 @@ 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 <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml (result ^. opmlVersion_) @?= Version [2,0] [] (result ^. head_ . opmlTitle_) @?= "placesLived.opml" @@ -108,7 +111,7 @@ 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 <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml (result ^. opmlVersion_) @?= Version [2,0] [] (result ^. head_ . opmlTitle_) @?= "workspace.userlandsamples.doSomeUpstreaming" @@ -126,7 +129,7 @@ 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 <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml (result ^. opmlVersion_) @?= Version [2,0] [] (result ^. head_ . opmlTitle_) @?= "states.opml" @@ -144,7 +147,7 @@ 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 <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml (result ^. opmlVersion_) @?= Version [2,0] [] (result ^. head_ . opmlTitle_) @?= "mySubscriptions.opml" @@ -157,7 +160,7 @@ 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) +inverseHeadProperty = testProperty "parse . render = id (on OpmlHead)" $ \opmlHead -> either (const False) (opmlHead ==) (runIdentity . runCatchT . runConduit $ renderOpmlHead opmlHead =$= runConduitParser parseOpmlHead) inverseProperty :: TestTree -inverseProperty = testProperty "parse . render = id" $ \opml -> either (const False) (opml ==) (runIdentity . runCatchT . runConduit $ renderOpml opml =$= force "Invalid OPML" parseOpml) +inverseProperty = testProperty "parse . render = id" $ \opml -> either (const False) (opml ==) (runIdentity . runCatchT . runConduit $ renderOpml opml =$= runConduitParser parseOpml)