opml-conduit 0.5.0.1 → 0.6.0.0

raw patch · 5 files changed

+118/−108 lines, 5 filesdep +safe-exceptionsdep −conduit-parsedep −exceptionsdep −foldlPVP ok

version bump matches the API change (PVP)

Dependencies added: safe-exceptions

Dependencies removed: conduit-parse, exceptions, foldl, xml-conduit-parse

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• Text/OPML/Conduit/Parse.hs +89/−75
• Text/OPML/Conduit/Render.hs +12/−10
• opml-conduit.cabal +5/−10
• test/Main.hs +11/−12

@@ -1,7 +1,7 @@ DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE Version 2, December 2004 -Copyright (C) 2015 koral <koral at mailoo dot org>+Copyright (C) 2016 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

@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE OverloadedLists    #-} {-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RankNTypes         #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell    #-} {-# LANGUAGE TupleSections      #-}@@ -18,14 +19,14 @@   ) where  -- {{{ Imports-import           Control.Applicative-import           Control.Foldl                as Fold+import           Conduit                      hiding (throwM)++import           Control.Applicative          hiding(many)+import           Control.Exception.Safe       as Exception import           Control.Monad-import           Control.Monad.Catch+import           Control.Monad.Fix  import           Data.CaseInsensitive         hiding (map)-import           Data.Conduit.Parser-import           Data.Conduit.Parser.XML import           Data.List.NonEmpty           (NonEmpty, nonEmpty) import           Data.Maybe import           Data.Monoid@@ -48,8 +49,8 @@ import           Prelude                      hiding (last)  import           Text.OPML.Types-import           Text.Parser.Combinators import           Text.ParserCombinators.ReadP (readP_to_S)+import           Text.XML.Stream.Parse  import           URI.ByteString -- }}}@@ -78,7 +79,7 @@ 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+  _         -> throwM $ InvalidVersion v  asDecimal :: (MonadThrow m, Integral a) => Text -> m a asDecimal t = case filter (onull . snd) . readSigned readDec $ unpack t of@@ -105,23 +106,28 @@ asCategories :: Text -> [NonEmpty (NonNull Text)] asCategories = mapMaybe (nonEmpty . mapMaybe fromNullable . split (== '/')) . split (== ',') -dateTag :: (MonadCatch m) => Name -> ConduitParser Event m UTCTime-dateTag name = tagName name ignoreAttrs $ \_ -> content asTime+dateTag :: (MonadThrow m) => Name -> ConduitM Event o m (Maybe UTCTime)+dateTag name = tagIgnoreAttrs name $ content >>= asTime -uriTag :: (MonadCatch m) => Name -> ConduitParser Event m URI-uriTag name = tagName name ignoreAttrs $ \_ -> content asURI+uriTag :: (MonadThrow m) => Name -> ConduitM Event o m (Maybe URI)+uriTag name = tagIgnoreAttrs name $ content >>= asURI -expansionStateTag :: (MonadCatch m, Integral a) => ConduitParser Event m [a]-expansionStateTag = tagName "expansionState" ignoreAttrs $ \_ -> content asExpansionState+expansionStateTag :: (MonadThrow m, Integral a) => ConduitM Event o m (Maybe [a])+expansionStateTag = tagIgnoreAttrs "expansionState" $ content >>= asExpansionState -textTag :: (MonadCatch m) => Name -> ConduitParser Event m Text-textTag name = tagName name ignoreAttrs $ const textContent+textTag :: (MonadThrow m) => Name -> ConduitM Event o m (Maybe Text)+textTag name = tagIgnoreAttrs name content -decimalTag :: (Integral a, MonadCatch m) => Name -> ConduitParser Event m a-decimalTag name = tagName name ignoreAttrs $ const $ content asDecimal+decimalTag :: (Integral a, MonadThrow m) => Name -> ConduitM Event o m (Maybe a)+decimalTag name = tagIgnoreAttrs name $ content >>= asDecimal -unknownTag :: (MonadCatch m) => ConduitParser Event m ()-unknownTag = tagPredicate (const True) ignoreAttrs $ \_ -> return ()+projectC :: Monad m => Fold a a' b b' -> Conduit a m b+projectC prism = fix $ \recurse -> do+  item <- await+  case (item, item ^? (_Just . prism)) of+    (_, Just a) -> yield a >> recurse+    (Just _, _) -> recurse+    _           -> return ()   data HeadPiece = HeadCreated UTCTime@@ -137,7 +143,6 @@                | HeadWindowLeft Int                | HeadWindowRight Int                | HeadWindowTop Int-               | HeadUnknown  makeTraversals ''HeadPiece @@ -145,76 +150,85 @@ -- | 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 sub-element may be repeated, in which case only the first occurrence is taken into account; -- - each unknown sub-element is ignored.-parseOpmlHead :: (MonadCatch m) => ConduitParser Event m OpmlHead-parseOpmlHead = named "OPML <head> section" $ tagName "head" ignoreAttrs $ \_ -> do-  p <- many $ choice piece-  return $ flip fold p $ OpmlHead-    <$> handles _HeadTitle (lastDef mempty)-    <*> handles _HeadCreated last-    <*> handles _HeadModified last-    <*> handles _HeadOwnerName (lastDef mempty)-    <*> handles _HeadOwnerEmail (lastDef mempty)-    <*> handles _HeadOwnerId last-    <*> handles _HeadDocs last-    <*> handles _HeadExpansionState Fold.mconcat-    <*> handles _HeadVertScrollState last-    <*> handles _HeadWindowBottom last-    <*> handles _HeadWindowLeft last-    <*> handles _HeadWindowRight last-    <*> handles _HeadWindowTop last-  where piece = [ HeadCreated <$> dateTag "dateCreated"-                , HeadModified <$> dateTag "dateModified"-                , HeadDocs <$> uriTag "docs"-                , HeadExpansionState <$> expansionStateTag-                , HeadOwnerEmail <$> textTag "ownerEmail"-                , HeadOwnerId <$> uriTag "ownerId"-                , HeadOwnerName <$> textTag "ownerName"-                , HeadTitle <$> textTag "title"-                , HeadVertScrollState <$> decimalTag "vertScrollState"-                , HeadWindowBottom <$> decimalTag "windowBottom"-                , HeadWindowLeft <$> decimalTag "windowLeft"-                , HeadWindowRight <$> decimalTag "windowRight"-                , HeadWindowTop <$> decimalTag "windowTop"-                , HeadUnknown <$ unknownTag-                ]+parseOpmlHead :: (MonadCatch m) => ConduitM Event o m (Maybe OpmlHead)+parseOpmlHead = tagIgnoreAttrs "head" $ (manyYield' (choose piece) <* many ignoreAllTreesContent) =$= zipConduit where+  zipConduit = getZipConduit $ OpmlHead+    <$> ZipConduit (projectC _HeadTitle =$= headDefC mempty)+    <*> ZipConduit (projectC _HeadCreated =$= headC)+    <*> ZipConduit (projectC _HeadModified =$= headC)+    <*> ZipConduit (projectC _HeadOwnerName =$= headDefC mempty)+    <*> ZipConduit (projectC _HeadOwnerEmail =$= headDefC mempty)+    <*> ZipConduit (projectC _HeadOwnerId =$= headC)+    <*> ZipConduit (projectC _HeadDocs =$= headC)+    <*> ZipConduit (projectC _HeadExpansionState =$= concatC =$= sinkList)+    <*> ZipConduit (projectC _HeadVertScrollState =$= headC)+    <*> ZipConduit (projectC _HeadWindowBottom =$= headC)+    <*> ZipConduit (projectC _HeadWindowLeft =$= headC)+    <*> ZipConduit (projectC _HeadWindowRight =$= headC)+    <*> ZipConduit (projectC _HeadWindowTop =$= headC)+  piece = [ fmap HeadCreated <$> dateTag "dateCreated"+          , fmap HeadModified <$> dateTag "dateModified"+          , fmap HeadDocs <$> uriTag "docs"+          , fmap HeadExpansionState <$> expansionStateTag+          , fmap HeadOwnerEmail <$> textTag "ownerEmail"+          , fmap HeadOwnerId <$> uriTag "ownerId"+          , fmap HeadOwnerName <$> textTag "ownerName"+          , fmap HeadTitle <$> textTag "title"+          , fmap HeadVertScrollState <$> decimalTag "vertScrollState"+          , fmap HeadWindowBottom <$> decimalTag "windowBottom"+          , fmap HeadWindowLeft <$> decimalTag "windowLeft"+          , fmap HeadWindowRight <$> decimalTag "windowRight"+          , fmap HeadWindowTop <$> decimalTag "windowTop"+          ]   -- | 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 :: (MonadCatch m) => ConduitParser Event m (Tree OpmlOutline)-parseOpmlOutline = tagName "outline" attributes handler <?> "OPML <outline> section" where+parseOpmlOutline :: (MonadCatch m) => ConduitM Event o m (Maybe (Tree OpmlOutline))+parseOpmlOutline = tagName "outline" attributes handler where   attributes = do-    otype <- optional $ textAttr "type"+    otype <- optional $ requireAttr "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")+  baseAttr = (,,,,) <$> (requireAttr "text" >>= asNonNull)+                    <*> optional (requireAttr "isComment" >>= asBool)+                    <*> optional (requireAttr "isBreakpoint" >>= asBool)+                    <*> optional (requireAttr "created" >>= asTime)+                    <*> optional (asCategories <$> requireAttr "category")+  linkAttr = requireAttr "url"+  subscriptionAttr = (,,,,,) <$> (requireAttr "xmlUrl" >>= asURI)+                             <*> optional (requireAttr "htmlUrl" >>= asURI)+                             <*> optional (requireAttr "description")+                             <*> optional (requireAttr "language")+                             <*> optional (requireAttr "title")+                             <*> optional (requireAttr "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+                                  <*> (manyYield' parseOpmlOutline =$= sinkList)   baseHandler (txt, comment, breakpoint, created, category) = return $ OutlineBase txt comment breakpoint created (fromMaybe mempty category)   subscriptionHandler (uri, html, desc, lang, title, version) = OutlineSubscription uri html (fromMaybe mempty desc) (fromMaybe mempty lang) (fromMaybe mempty title) (fromMaybe mempty version) ++data OpmlDocPiece = DocHead OpmlHead | DocBody [Tree OpmlOutline]++makeTraversals ''OpmlDocPiece++ -- | Parse the top-level @\<opml\>@ element.-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."+parseOpml :: (MonadCatch m) => ConduitM Event o m (Maybe Opml)+parseOpml = tagName "opml" attributes handler where+  attributes = (requireAttr "version" >>= asVersion) <* ignoreAttrs+  handler version = (manyYield' (choose piece) <* many ignoreAllTreesContent) =$= zipConduit version+  zipConduit version = getZipConduit $ Opml version+    <$> ZipConduit (projectC _DocHead =$= headDefC mkOpmlHead)+    <*> ZipConduit (projectC _DocBody =$= headDefC mempty)+  parseOpmlBody = tagIgnoreAttrs "body" $ manyYield' parseOpmlOutline =$= sinkList+  piece = [ fmap DocHead <$> parseOpmlHead+          , fmap DocBody <$> parseOpmlBody+          ]

@@ -17,6 +17,7 @@ import           Data.List.NonEmpty     hiding (filter, map) import           Data.Monoid import           Data.NonNull+import           Data.String import           Data.Text              (Text, intercalate, pack, toLower) import           Data.Text.Encoding import           Data.Time.Clock@@ -28,7 +29,8 @@  import           Lens.Simple -import           Prelude                hiding (foldr, lookup)+import           Prelude                hiding (foldr, lookup, show)+import qualified Prelude                (show)  import           Text.OPML.Lens import           Text.OPML.Types@@ -37,8 +39,8 @@ import           URI.ByteString -- }}} -tshow :: (Show a) => a -> Text-tshow = pack . show+show :: (Show a, IsString t) => a -> t+show = fromString . Prelude.show  empty :: (Eq s, Monoid s) => s -> Bool empty t = t == mempty@@ -54,7 +56,7 @@ formatCategories = toMaybe . intercalate "," . map (intercalate "/" . toList . fmap toNullable)  formatBool :: Bool -> Text-formatBool = toLower . tshow+formatBool = toLower . show  formatURI :: URI -> Text formatURI = decodeUtf8 . serializeURIRef'@@ -65,16 +67,16 @@   forM_ (input^.opmlCreatedL)       $ tag "dateCreated" mempty . content . formatTime   forM_ (input^.modifiedL)          $ tag "dateModified" mempty . content . formatTime   forM_ (input^.docsL)              $ tag "docs" mempty . content . formatURI-  unless (null es)                  $ tag "expansionState" mempty . content . intercalate "," $ tshow <$> es+  unless (null es)                  $ tag "expansionState" mempty . content . intercalate "," $ show <$> es   unless (empty email)              $ tag "ownerEmail" mempty $ content email   forM_ (input^.ownerIdL)           $ tag "ownerId" mempty . content . formatURI   unless (empty name)               $ tag "ownerName" mempty $ content name   unless (empty title)              $ tag "title" mempty $ content title-  forM_ (input^.vertScrollStateL)   $ tag "vertScrollState" mempty . content . tshow-  forM_ (input^.windowBottomL)      $ tag "windowBottom" mempty . content . tshow-  forM_ (input^.windowLeftL)        $ tag "windowLeft" mempty . content . tshow-  forM_ (input^.windowRightL)       $ tag "windowRight" mempty . content . tshow-  forM_ (input^.windowTopL)         $ tag "windowTop" mempty . content . tshow+  forM_ (input^.vertScrollStateL)   $ tag "vertScrollState" mempty . content . show+  forM_ (input^.windowBottomL)      $ tag "windowBottom" mempty . content . show+  forM_ (input^.windowLeftL)        $ tag "windowLeft" mempty . content . show+  forM_ (input^.windowRightL)       $ tag "windowRight" mempty . content . show+  forM_ (input^.windowTopL)         $ tag "windowTop" mempty . content . show   where es = input ^.. expansionStateL         email = input ^. ownerEmailL         name = input ^. ownerNameL

@@ -1,10 +1,10 @@ name:                opml-conduit-version:             0.5.0.1+version:             0.6.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:             PublicDomain license-file:        LICENSE author:              koral <koral@mailoo.org> maintainer:          koral <koral@mailoo.org>@@ -34,21 +34,18 @@       base >= 4.8 && < 5     , case-insensitive     , conduit-    , conduit-parse+    , conduit-combinators     , containers-    , exceptions-    , foldl+    , safe-exceptions     , lens-simple     , monoid-subclasses     , mono-traversable-    , parsers     , semigroups     , text     , time >= 1.5     , timerep >= 2.0.0     , uri-bytestring >= 0.2     , xml-conduit >= 1.3-    , xml-conduit-parse >= 0.2.0.0     , xml-types   default-language: Haskell2010   ghc-options: -Wall -fno-warn-unused-do-bind@@ -65,10 +62,8 @@     , bytestring     , conduit     , conduit-combinators-    , conduit-parse     , containers     , data-default-    , exceptions     , hlint     , lens-simple     , mono-traversable@@ -85,6 +80,6 @@     , text     , time >= 1.5     , uri-bytestring >= 0.1.9-    , xml-conduit-parse+    , xml-conduit >= 1.3   default-language: Haskell2010   ghc-options: -Wall -fno-warn-orphans

@@ -1,15 +1,12 @@ {-# LANGUAGE OverloadedLists   #-} {-# LANGUAGE OverloadedStrings #-}+-- {{{ Imports import           Arbitrary                    () -import           Control.Monad.Catch.Pure-import           Control.Monad.Identity import           Control.Monad.Trans.Resource  import           Data.Conduit import           Data.Conduit.Combinators     as Conduit (sourceFile)-import           Data.Conduit.Parser-import           Data.Conduit.Parser.XML      as XML import           Data.Default import           Data.String import           Data.Text.Encoding@@ -29,8 +26,10 @@ import           Text.OPML.Conduit.Parse import           Text.OPML.Conduit.Render import           Text.OPML.Lens+import           Text.XML.Stream.Parse        as XML  import           URI.ByteString+-- }}}  main :: IO () main = defaultMain $ testGroup "Tests"@@ -65,7 +64,7 @@ categoriesCase :: TestTree categoriesCase = testCase "Parse categories list" $ do   dataFile <- fromString <$> getDataFileName "data/category.opml"-  result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml+  result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml    (result ^. opmlVersionL) @?= Version [2,0] []   (result ^. opmlHeadL . opmlTitleL) @?= "Illustrating the category attribute"@@ -77,7 +76,7 @@ directoryCase :: TestTree directoryCase = testCase "Parse directory tree" $ do   dataFile <- fromString <$> getDataFileName "data/directory.opml"-  result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml+  result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml    (result ^. opmlVersionL) @?= Version [2,0] []   (result ^. opmlHeadL . opmlTitleL) @?= "scriptingNewsDirectory.opml"@@ -98,7 +97,7 @@ placesCase :: TestTree placesCase = testCase "Parse places list" $ do   dataFile <- fromString <$> getDataFileName "data/placesLived.opml"-  result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml+  result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml    (result ^. opmlVersionL) @?= Version [2,0] []   (result ^. opmlHeadL . opmlTitleL) @?= "placesLived.opml"@@ -120,7 +119,7 @@ scriptCase :: TestTree scriptCase = testCase "Parse script" $ do   dataFile <- fromString <$> getDataFileName "data/simpleScript.opml"-  result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml+  result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml    (result ^. opmlVersionL) @?= Version [2,0] []   (result ^. opmlHeadL . opmlTitleL) @?= "workspace.userlandsamples.doSomeUpstreaming"@@ -141,7 +140,7 @@ statesCase :: TestTree statesCase = testCase "Parse states list" $ do   dataFile <- fromString <$> getDataFileName "data/states.opml"-  result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml+  result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml    (result ^. opmlVersionL) @?= Version [2,0] []   (result ^. opmlHeadL . opmlTitleL) @?= "states.opml"@@ -162,7 +161,7 @@ subscriptionsCase :: TestTree subscriptionsCase = testCase "Parse subscriptions list" $ do   dataFile <- fromString <$> getDataFileName "data/subscriptionList.opml"-  result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml+  result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml    (result ^. opmlVersionL) @?= Version [2,0] []   (result ^. opmlHeadL . opmlTitleL) @?= "mySubscriptions.opml"@@ -178,7 +177,7 @@   length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineSubscription) @?= 13  inverseHeadProperty :: TestTree-inverseHeadProperty = testProperty "parse . render = id (on OpmlHead)" $ \opmlHead -> either (const False) (opmlHead ==) (runIdentity . runCatchT . runConduit $ renderOpmlHead opmlHead =$= runConduitParser parseOpmlHead)+inverseHeadProperty = testProperty "parse . render = id (on OpmlHead)" $ \opmlHead -> either (const False) (opmlHead ==) (runConduit $ renderOpmlHead opmlHead =$= force "Invalid <head>" parseOpmlHead)  -- inverseProperty :: TestTree--- inverseProperty = testProperty "parse . render = id" $ \opml -> either (const False) (opml ==) (runIdentity . runCatchT . runConduit $ renderOpml opml =$= runConduitParser parseOpml)+-- inverseProperty = testProperty "parse . render = id" $ \opml -> either (const False) (opml ==) (runIdentity . runCatchT . runConduit $ renderOpml opml =$= force "Invalid OPML" parseOpml)