packages feed

opml-conduit 0.2.0.1 → 0.3.0.0

raw patch · 3 files changed

+126/−107 lines, 3 filesdep +conduit-parsedep +parsersdep +xml-conduit-parsedep ~xml-conduit

Dependencies added: conduit-parse, parsers, xml-conduit-parse

Dependency ranges changed: xml-conduit

Files

Text/OPML/Stream/Parse.hs view
@@ -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 @\<head\>@ 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 <head> section" $ tagName "head" ignoreAttrs $ \_ -> do+  builders <- many $ choice opmlHeadBuilders+  return $ (appEndo $ mconcat builders) def  -- | 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) = 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 <outline> 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 @\<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)+parseOpml :: (MonadCatch m) => ConduitParser Event m Opml+parseOpml = tagName "opml" attributes handler <?> "<opml> section" where+  attributes = attr "version" asVersion <* ignoreAttrs+  handler version = Opml version+                      <$> parseOpmlHead+                      <*> tagName "body" ignoreAttrs (const $ many parseOpmlOutline) <?> "<body> section."
opml-conduit.cabal view
@@ -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 (<http://dev.opml.org/spec2.html>) 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
test/Main.hs view
@@ -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)