diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE Version 2, December 2004 -Copyright (C) 2015 koral +Copyright (C) 2016 koral Everyone is permitted to copy and distribute verbatim or modified copies of this license document, and changing it is allowed as long diff --git a/Text/OPML/Conduit/Parse.hs b/Text/OPML/Conduit/Parse.hs --- a/Text/OPML/Conduit/Parse.hs +++ b/Text/OPML/Conduit/Parse.hs @@ -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 @\@ 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 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 @\@ 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 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 @\@ element. -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." +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 + ] diff --git a/Text/OPML/Conduit/Render.hs b/Text/OPML/Conduit/Render.hs --- a/Text/OPML/Conduit/Render.hs +++ b/Text/OPML/Conduit/Render.hs @@ -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 diff --git a/opml-conduit.cabal b/opml-conduit.cabal --- a/opml-conduit.cabal +++ b/opml-conduit.cabal @@ -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 () as a 'conduit' parser/renderer. homepage: https://github.com/k0ral/opml-conduit -license: OtherLicense +license: PublicDomain license-file: LICENSE author: koral maintainer: koral @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 " 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)