diff --git a/Text/OPML.hs b/Text/OPML.hs --- a/Text/OPML.hs +++ b/Text/OPML.hs @@ -1,10 +1,7 @@ --- | This module re-exports commonly used modules: --- --- - 'Text.OPML.Stream.Parse' --- - 'Text.OPML.Stream.Render' --- - 'Text.OPML.Types' +-- | This module re-exports all the package modules. module Text.OPML (module X) where -import Text.OPML.Stream.Parse as X -import Text.OPML.Stream.Render as X -import Text.OPML.Types as X +import Text.OPML.Conduit.Parse as X +import Text.OPML.Conduit.Render as X +import Text.OPML.Lens as X +import Text.OPML.Types as X diff --git a/Text/OPML/Arbitrary.hs b/Text/OPML/Arbitrary.hs deleted file mode 100644 --- a/Text/OPML/Arbitrary.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# 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.List.NonEmpty -import Data.Maybe -import Data.MonoTraversable (Element) -import Data.NonNull -import Data.Sequences (SemiSequence) -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 - --- | 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 = (++ ":") <$> listOf1 (choose('a', 'z')) - -- shrink = genericShrink - --- | Reasonable enough 'URIAuth' generator. -instance Arbitrary (OpmlGen URIAuth) where - arbitrary = do - userInfo <- oneof [return "", (++ "@") <$> 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 [NonEmpty (NonNull Text)]) where - arbitrary = OpmlGen <$> listOf genCategoryPath - where genCategory = genNonNull `suchThat` (isNothing . find (\c -> c == ',' || c == '/') . toNullable) - genCategoryPath = (:|) <$> genCategory <*> listOf genCategory - -- shrink = genericShrink - --- | Alpha-numeric generator. -genAlphaNum :: Gen Char -genAlphaNum = oneof [choose('a', 'z'), suchThat arbitrary isDigit] - --- | Non-empty mono-foldable -genNonNull :: (SemiSequence a, Arbitrary (Element a), Arbitrary a) => Gen (NonNull a) -genNonNull = ncons <$> arbitrary <*> arbitrary diff --git a/Text/OPML/Conduit/Parse.hs b/Text/OPML/Conduit/Parse.hs new file mode 100644 --- /dev/null +++ b/Text/OPML/Conduit/Parse.hs @@ -0,0 +1,220 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# 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.Conduit.Parse + ( -- * Parsers + parseOpml + , parseOpmlHead + , parseOpmlOutline + -- * Exceptions + , OpmlException(..) + ) where + +-- {{{ Imports +import Control.Applicative +import Control.Foldl as Fold +import Control.Monad +import Control.Monad.Catch + +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 +import Data.Monoid.Textual hiding (map) +import Data.MonoTraversable +import Data.NonNull (NonNull, fromNullable) +import Data.Text (Text, strip, unpack) +import Data.Text.Encoding +import Data.Time.Clock +import Data.Time.LocalTime +import Data.Time.RFC822 +import Data.Tree +import Data.Version +import Data.XML.Types + +import Lens.Simple + +import Numeric + +import Prelude hiding (last) + +import Text.OPML.Types +import Text.Parser.Combinators +import Text.ParserCombinators.ReadP (readP_to_S) + +import URI.ByteString +-- }}} + +data OpmlException = MissingText + | InvalidBool Text + | InvalidDecimal Text + | InvalidTime Text + | InvalidURI URIParseError + | InvalidVersion Text + +deriving instance Eq OpmlException +deriving instance Show OpmlException + +instance Exception OpmlException where + displayException MissingText = "An outline is missing the 'text' attribute." + displayException (InvalidBool t) = "Invalid boolean: " ++ unpack t + displayException (InvalidDecimal t) = "Invalid decimal: " ++ unpack t + displayException (InvalidURI e) = "Invalid URI: " ++ show e + displayException (InvalidTime t) = "Invalid time: " ++ unpack t + displayException (InvalidVersion t) = "Invalid version: " ++ unpack t + +asURI :: (MonadThrow m) => Text -> m URI +asURI t = either (throwM . InvalidURI) return . parseURI laxURIParserOptions $ encodeUtf8 t + +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 + +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 + +asExpansionState :: (MonadThrow m, Integral a) => Text -> m [a] +asExpansionState t = mapM asDecimal . filter (not . onull) . map strip $ split (== ',') 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 +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 + +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 + +uriTag :: (MonadCatch m) => Name -> ConduitParser Event m URI +uriTag name = tagName name ignoreAttrs $ \_ -> content asURI + +expansionStateTag :: (MonadCatch m, Integral a) => ConduitParser Event m [a] +expansionStateTag = tagName "expansionState" ignoreAttrs $ \_ -> content asExpansionState + +textTag :: (MonadCatch m) => Name -> ConduitParser Event m Text +textTag name = tagName name ignoreAttrs $ const textContent + +decimalTag :: (Integral a, MonadCatch m) => Name -> ConduitParser Event m a +decimalTag name = tagName name ignoreAttrs $ const $ content asDecimal + +unknownTag :: (MonadCatch m) => ConduitParser Event m () +unknownTag = tagPredicate (const True) ignoreAttrs $ \_ -> return () + + +data HeadPiece = HeadCreated UTCTime + | HeadModified UTCTime + | HeadDocs URI + | HeadExpansionState [Int] + | HeadOwnerEmail Text + | HeadOwnerId URI + | HeadOwnerName Text + | HeadTitle Text + | HeadVertScrollState Int + | HeadWindowBottom Int + | HeadWindowLeft Int + | HeadWindowRight Int + | HeadWindowTop Int + | HeadUnknown + +makeTraversals ''HeadPiece + + +-- | 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 :: (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 + ] + + +-- | 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 + 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 (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) + +-- | 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." diff --git a/Text/OPML/Conduit/Render.hs b/Text/OPML/Conduit/Render.hs new file mode 100644 --- /dev/null +++ b/Text/OPML/Conduit/Render.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +-- | Streaming renderer for the OPML 2.0 standard. +module Text.OPML.Conduit.Render + ( -- * Renderers + renderOpmlHead + , renderOpmlOutline + , renderOpml + ) where + +-- {{{ Imports +import Control.Monad + +import Data.Conduit +import Data.List.NonEmpty hiding (filter, map) +import Data.Monoid +import Data.NonNull +import Data.Text (Text, intercalate, pack, toLower) +import Data.Text.Encoding +import Data.Time.Clock +import Data.Time.LocalTime +import Data.Time.RFC822 +import Data.Tree +import Data.Version +import Data.XML.Types + +import Lens.Simple + +import Prelude hiding (foldr, lookup) + +import Text.OPML.Lens +import Text.OPML.Types +import Text.XML.Stream.Render + +import URI.ByteString +-- }}} + +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 :: [NonEmpty (NonNull Text)] -> Maybe Text +formatCategories = toMaybe . intercalate "," . map (intercalate "/" . toList . fmap toNullable) + +formatBool :: Bool -> Text +formatBool = toLower . tshow + +formatURI :: URI -> Text +formatURI = decodeUtf8 . serializeURI' + +-- | Render the @\@ section. +renderOpmlHead :: (Monad m) => OpmlHead -> Source m Event +renderOpmlHead input = tag "head" mempty $ do + 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 (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 + where es = input ^.. expansionStateL + email = input ^. ownerEmailL + name = input ^. ownerNameL + title = input ^. opmlTitleL + +-- | 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" (formatURI uri) + OpmlOutlineSubscription b s -> baseAttr b <> subscriptionAttr s + baseAttr b = attr "text" (toNullable $ b^.textL) + <> optionalAttr "isComment" (formatBool <$> b^.isCommentL) + <> optionalAttr "isBreakpoint" (formatBool <$> b^.isBreakpointL) + <> optionalAttr "created" (formatTime <$> b^.outlineCreatedL) + <> optionalAttr "category" (formatCategories $ b^.categoriesL) + subscriptionAttr s = attr "type" "rss" + <> attr "xmlUrl" (formatURI $ s^.xmlUriL) + <> optionalAttr "htmlUrl" (formatURI <$> s^.htmlUriL) + <> optionalAttr "description" (toMaybe $ s^.descriptionL) + <> optionalAttr "language" (toMaybe $ s^.languageL) + <> optionalAttr "title" (toMaybe $ s^.subscriptionTitleL) + <> optionalAttr "version" (toMaybe $ s^.subscriptionVersionL) + +-- | Render the top-level @\@ section. +renderOpml :: (Monad m) => Opml -> Source m Event +renderOpml opml = tag "opml" (attr "version" . pack . showVersion $ opml^.opmlVersionL) $ do + renderOpmlHead $ opml^.opmlHeadL + tag "body" mempty . mapM_ renderOpmlOutline $ opml^.opmlOutlinesL diff --git a/Text/OPML/Lens.hs b/Text/OPML/Lens.hs new file mode 100644 --- /dev/null +++ b/Text/OPML/Lens.hs @@ -0,0 +1,61 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +module Text.OPML.Lens where + +-- {{{ Imports +import Lens.Simple + +import Text.OPML.Types +-- }}} + +-- * 'Opml' lenses +makeLensesFor + [ ("opmlVersion", "opmlVersionL") + , ("opmlHead", "opmlHeadL") + , ("opmlOutlines", "opmlOutlinesL") + ] ''Opml + +-- * 'OpmlHead' lenses +makeLensesFor + [ ("opmlTitle", "opmlTitleL") + , ("opmlCreated", "opmlCreatedL") + , ("modified", "modifiedL") + , ("ownerName", "ownerNameL") + , ("ownerEmail", "ownerEmailL") + , ("ownerId", "ownerIdL") + , ("docs", "docsL") + -- , ("expansionState", "expansionStateL") + , ("vertScrollState", "vertScrollStateL") + , ("windowBottom", "windowBottomL") + , ("windowLeft", "windowLeftL") + , ("windowRight", "windowRightL") + , ("windowTop", "windowTopL") + ] ''OpmlHead + +expansionStateL :: Traversal' OpmlHead Int +expansionStateL inj a@OpmlHead { expansionState = es } = (\x -> a { expansionState = x }) <$> sequenceA (map inj es) +{-# INLINE expansionStateL #-} + +-- * 'OutlineSubscription' lenses +makeLensesFor + [ ("xmlUri", "xmlUriL") + , ("htmlUri", "htmlUriL") + , ("description", "descriptionL") + , ("language", "languageL") + , ("subscriptionTitle", "subscriptionTitleL") + , ("subscriptionVersion", "subscriptionVersionL") + ] ''OutlineSubscription + +-- * 'OutlineBase' lenses +makeLensesFor + [ ("text", "textL") + , ("isComment", "isCommentL") + , ("isBreakpoint", "isBreakpointL") + , ("outlineCreated", "outlineCreatedL") + , ("categories", "categoriesL") + ] ''OutlineBase + + +-- * 'OpmlOutline' traversals +makeTraversals ''OpmlOutline diff --git a/Text/OPML/Stream/Parse.hs b/Text/OPML/Stream/Parse.hs deleted file mode 100644 --- a/Text/OPML/Stream/Parse.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# 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 - ) 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.Parser -import Data.Conduit.Parser.XML -import Data.Default -import Data.List.NonEmpty hiding (filter, map) -import Data.Maybe -import Data.Monoid -import Data.Monoid.Textual hiding (map) -import Data.MonoTraversable -import Data.NonNull -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, parseURI) - -import Numeric - -import Text.OPML.Types -import Text.Parser.Combinators -import Text.ParserCombinators.ReadP (readP_to_S) --- }}} - -data OpmlException = MissingText - | InvalidBool Text - | InvalidDecimal Text - | InvalidTime Text - | InvalidURI Text - | InvalidVersion Text - -deriving instance Eq OpmlException -instance Show OpmlException where - show MissingText = "An outline is missing the 'text' attribute." - 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 - -asURI :: (MonadThrow m) => Text -> m URI -asURI t = maybe (throwM $ InvalidURI t) return . parseURI $ unpack t - -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 - -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 - -asExpansionState :: (MonadThrow m, Integral a) => Text -> m [a] -asExpansionState t = mapM asDecimal . filter (not . onull) . map strip $ split (== ',') 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 -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 - -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 :: (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 :: (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 :: (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/Text/OPML/Stream/Render.hs b/Text/OPML/Stream/Render.hs deleted file mode 100644 --- a/Text/OPML/Stream/Render.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# 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.List.NonEmpty hiding (filter, map) -import Data.Monoid -import Data.NonNull -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 :: [NonEmpty (NonNull Text)] -> Maybe Text -formatCategories = toMaybe . intercalate "," . map (intercalate "/" . toList . fmap toNullable) - -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" (toNullable $ 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 --- a/Text/OPML/Types.hs +++ b/Text/OPML/Types.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} -- | OPML is an XML format for outlines. -- -- Example: @@ -22,54 +20,23 @@ module Text.OPML.Types ( -- * Top-level OPML structure Opml(..) - , opmlVersion_ - , head_ - , outlines_ + , mkOpml -- * OPML header , OpmlHead(..) - , Direction(..) - , opmlTitle_ - , opmlCreated_ - , modified_ - , ownerName_ - , ownerEmail_ - , ownerId_ - , docs_ - , expansionState_ - , vertScrollState_ - , window_ + , mkOpmlHead -- * 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.Hashable -import Data.Hashable.Time () -import Data.HashMap.Lazy import Data.List.NonEmpty import Data.NonNull import Data.Text @@ -80,127 +47,64 @@ import GHC.Generics -import Network.URI - -import Test.QuickCheck -import Text.OPML.Arbitrary +import URI.ByteString -- }}} --- Orphan instance -instance (Hashable a) => Hashable (NonNull a) where - hashWithSalt s = hashWithSalt s . toNullable - -data Direction = Top' | Left' | Bottom' | Right' deriving(Eq, Generic, Show) - -instance Hashable Direction - -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_ :: HashMap Direction Int - } - |] +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 + , windowBottom :: Maybe Int + , windowLeft :: Maybe Int + , windowRight :: Maybe Int + , windowTop :: Maybe Int + } deriving instance Eq OpmlHead deriving instance Generic OpmlHead deriving instance Show OpmlHead --- instance Hashable 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 +-- | Bare 'OpmlHead', all fields are set to 'mempty'. +mkOpmlHead :: OpmlHead +mkOpmlHead = OpmlHead mempty mzero mzero mempty mempty mzero mzero mzero mzero mzero mzero mzero mzero -declareLenses [d| - data OutlineBase = OutlineBase - { text_ :: NonNull Text - , isComment_ :: Maybe Bool - , isBreakpoint_ :: Maybe Bool - , outlineCreated_ :: Maybe UTCTime - , categories_ :: [NonEmpty (NonNull Text)] -- ^ - } - |] +data OutlineBase = OutlineBase + { text :: NonNull Text + , isComment :: Maybe Bool + , isBreakpoint :: Maybe Bool + , outlineCreated :: Maybe UTCTime + , categories :: [NonEmpty (NonNull Text)] -- ^ + } deriving instance Eq OutlineBase deriving instance Generic OutlineBase deriving instance Show OutlineBase -instance Hashable OutlineBase -instance Arbitrary OutlineBase where - arbitrary = OutlineBase <$> genNonNull - <*> arbitrary - <*> arbitrary - <*> (unwrap <$> arbitrary) - <*> (unwrap <$> arbitrary) - shrink (OutlineBase _ b c d e) = OutlineBase <$> [] - <*> shrink b - <*> shrink c - <*> shrink d - <*> (unwrap <$> shrink (OpmlGen e)) -- | Smart constructor for 'OutlineBase'. mkOutlineBase :: NonNull 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 - } - |] +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 Hashable 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 @@ -208,58 +112,24 @@ -- | Outlines are the main payload of an OPML document. -declarePrisms [d| - data OpmlOutline = OpmlOutlineGeneric OutlineBase Text - | OpmlOutlineLink OutlineBase URI - | OpmlOutlineSubscription OutlineBase OutlineSubscription - |] +data OpmlOutline = OpmlOutlineGeneric OutlineBase Text + | OpmlOutlineLink OutlineBase URI + | OpmlOutlineSubscription OutlineBase OutlineSubscription deriving instance Eq OpmlOutline deriving instance Generic OpmlOutline deriving instance Show OpmlOutline --- instance Hashable 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 - } - |] +data Opml = Opml + { opmlVersion :: Version + , opmlHead :: OpmlHead + , opmlOutlines :: Forest OpmlOutline + } deriving instance Eq Opml deriving instance Generic Opml deriving instance Show Opml --- instance Hashable Opml -instance Default Opml where - def = Opml (makeVersion [2, 0]) def mempty - -instance Arbitrary Opml where - arbitrary = do - degree <- choose (0, 100) - Opml <$> (unwrap <$> arbitrary) - <*> arbitrary - <*> vectorOf degree (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 - degree <- choose (0, 100) - case (n > 1, root) of - (True, OpmlOutlineGeneric _ _) -> Node <$> pure root <*> vectorOf degree (genOutlineTree (n-1)) - (False, OpmlOutlineGeneric _ _) -> return $ Node root [] - _ -> return $ Node root [] +-- | Bare 'Opml'. Version is set to @2.0@. +mkOpml :: Opml +mkOpml = Opml (makeVersion [2, 0]) mkOpmlHead mempty 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.3.0.0 +version: 0.4.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. @@ -26,9 +26,9 @@ library exposed-modules: Text.OPML - Text.OPML.Arbitrary - Text.OPML.Stream.Parse - Text.OPML.Stream.Render + Text.OPML.Lens + Text.OPML.Conduit.Parse + Text.OPML.Conduit.Render Text.OPML.Types build-depends: base >= 4.8 && < 5 @@ -36,22 +36,17 @@ , conduit , conduit-parse , containers - , data-default , exceptions - , hashable - , hashable-time - , lens + , foldl + , lens-simple , monoid-subclasses , mono-traversable - , network-uri >= 2.6 , parsers - , QuickCheck - , quickcheck-instances , semigroups , text , time >= 1.5 , timerep >= 2.0.0 - , unordered-containers + , uri-bytestring >= 0.1.9 , xml-conduit >= 1.3 , xml-conduit-parse >= 0.2.0.0 , xml-types @@ -62,9 +57,12 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs - other-modules: Paths_opml_conduit + other-modules: + Paths_opml_conduit + Arbitrary build-depends: - base >= 4.8 + base >= 4.8 && < 5 + , bytestring , conduit , conduit-combinators , conduit-parse @@ -72,15 +70,21 @@ , data-default , exceptions , hlint - , lens + , lens-simple + , mono-traversable , mtl - , network-uri >= 2.6 , opml-conduit , parsers + , QuickCheck + , quickcheck-instances , resourcet + , semigroups , tasty , tasty-hunit , tasty-quickcheck + , text + , time >= 1.5 + , uri-bytestring >= 0.1.9 , xml-conduit-parse - default-language: Haskell2010 - ghc-options: -Wall + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-orphans diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Arbitrary.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +-- | External 'Arbitrary' instances used by OPML types. +-- All instances are defined through the 'OpmlGen' wrapper to avoid conflicts. +module Arbitrary where + +-- {{{ Imports +import Data.ByteString (ByteString) +import Data.Char +import Data.List.NonEmpty +import Data.Maybe +import Data.MonoTraversable (Element) +import Data.NonNull +import Data.Sequences (SemiSequence) +import Data.Text (Text, find, pack) +import Data.Text.Encoding +import Data.Time.Clock +import Data.Tree +import Data.Version + +import GHC.Generics + +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import Text.OPML.Types + +import URI.ByteString +-- }}} + +deriving instance Generic Version + +-- | OPML version may only be @1.0@, @1.1@ or @2.0@ +instance Arbitrary Version where + arbitrary = Version <$> elements [ [1, 0], [1, 1], [2, 0] ] <*> pure [] + shrink = genericShrink + +-- | Reasonable enough 'URI' generator. +instance Arbitrary URI where + arbitrary = URI <$> arbitrary <*> arbitrary <*> genPath <*> arbitrary <*> (Just <$> genFragment) + shrink = genericShrink + +-- | Reasonable enough 'Authority' generator. +instance Arbitrary Authority where + arbitrary = Authority <$> arbitrary <*> arbitrary <*> arbitrary + shrink = genericShrink + +genFragment :: Gen ByteString +genFragment = encodeUtf8 . pack <$> listOf1 genAlphaNum + +instance Arbitrary Host where + arbitrary = Host . encodeUtf8 . pack <$> listOf1 genAlphaNum + shrink = genericShrink + +genPath :: Gen ByteString +genPath = encodeUtf8 . pack . ("/" ++) <$> listOf1 genAlphaNum + +instance Arbitrary Port where + arbitrary = do + Positive port <- arbitrary + return $ Port port + +instance Arbitrary Query where + arbitrary = do + a <- listOf1 (encodeUtf8 . pack <$> listOf1 genAlphaNum) + b <- listOf1 (encodeUtf8 . pack <$> listOf1 genAlphaNum) + return $ Query $ Prelude.zip a b + shrink = genericShrink + +instance Arbitrary Scheme where + arbitrary = Scheme . encodeUtf8 . pack <$> listOf1 (choose('a', 'z')) + shrink = genericShrink + +instance Arbitrary UserInfo where + arbitrary = do + a <- encodeUtf8 . pack <$> listOf1 genAlphaNum + b <- encodeUtf8 . pack <$> listOf1 genAlphaNum + return $ UserInfo a b + shrink = genericShrink + + +-- | Generates 'UTCTime' with rounded seconds. +genTime :: Gen UTCTime +genTime = do + (UTCTime d s) <- arbitrary + return $ UTCTime d $ fromIntegral (round s :: Int) + +-- | Generates 'OutlineBase''s categories. +-- This generator makes sure that the result has no @,@ nor @/@ characters, since those are used as separators. +instance Arbitrary [NonEmpty (NonNull Text)] where + arbitrary = listOf genCategoryPath + where genCategory = genNonNull `suchThat` (isNothing . find (\c -> c == ',' || c == '/') . toNullable) + genCategoryPath = (:|) <$> genCategory <*> listOf genCategory + -- shrink = genericShrink + +-- | Alpha-numeric generator. +genAlphaNum :: Gen Char +genAlphaNum = oneof [choose('a', 'z'), suchThat arbitrary isDigit] + +-- | Non-empty mono-foldable +genNonNull :: (SemiSequence a, Arbitrary (Element a), Arbitrary a) => Gen (NonNull a) +genNonNull = ncons <$> arbitrary <*> arbitrary + + +instance Arbitrary OpmlHead where + arbitrary = OpmlHead <$> arbitrary + <*> (Just <$> genTime) + <*> (Just <$> genTime) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + shrink = genericShrink + +instance Arbitrary OutlineBase where + arbitrary = OutlineBase <$> genNonNull + <*> arbitrary + <*> arbitrary + <*> (Just <$> genTime) + <*> arbitrary + -- shrink = genericShrink + shrink (OutlineBase _ b c d e) = OutlineBase <$> [] + <*> shrink b + <*> shrink c + <*> shrink d + <*> shrink e + +instance Arbitrary OutlineSubscription where + arbitrary = OutlineSubscription <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + shrink = genericShrink + +instance Arbitrary OpmlOutline where + arbitrary = oneof [ OpmlOutlineGeneric <$> arbitrary <*> arbitrary + , OpmlOutlineLink <$> arbitrary <*> arbitrary + , OpmlOutlineSubscription <$> arbitrary <*> arbitrary + ] + shrink = genericShrink + +instance Arbitrary Opml where + arbitrary = do + degree <- choose (0, 100) + Opml <$> arbitrary + <*> arbitrary + <*> vectorOf degree (genOutlineTree 1) + shrink = genericShrink + +-- | 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 + degree <- choose (0, 100) + case (n > 1, root) of + (True, OpmlOutlineGeneric _ _) -> Node <$> pure root <*> vectorOf degree (genOutlineTree (n-1)) + (False, OpmlOutlineGeneric _ _) -> return $ Node root [] + _ -> return $ Node root [] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,33 +1,36 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Lens.Fold -import Control.Lens.Getter +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 hiding (length, map, - null) +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 import Data.Tree import Data.Version import Paths_opml_conduit import qualified Language.Haskell.HLint as HLint (hlint) + +import Lens.Simple + 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.OPML.Conduit.Parse +import Text.OPML.Conduit.Render +import Text.OPML.Lens +import URI.ByteString main :: IO () main = defaultMain $ testGroup "Tests" @@ -64,11 +67,11 @@ dataFile <- fromString <$> getDataFileName "data/category.opml" result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser 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]] + (result ^. opmlVersionL) @?= Version [2,0] [] + (result ^. opmlHeadL . opmlTitleL) @?= "Illustrating the category attribute" + show (result ^. opmlHeadL . opmlCreatedL) @?= "Just 2005-10-31 19:23:00 UTC" + length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineGeneric) @?= 1 + map (map length .levels) (result ^. opmlOutlinesL) @?= [[1]] directoryCase :: TestTree @@ -76,17 +79,20 @@ dataFile <- fromString <$> getDataFileName "data/directory.opml" result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser 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]] + (result ^. opmlVersionL) @?= Version [2,0] [] + (result ^. opmlHeadL . opmlTitleL) @?= "scriptingNewsDirectory.opml" + show (result ^. opmlHeadL . opmlCreatedL) @?= "Just 2005-10-13 15:34:07 UTC" + show (result ^. opmlHeadL . modifiedL) @?= "Just 2005-10-25 21:33:57 UTC" + (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer" + (result ^. opmlHeadL . ownerEmailL) @?= "dwiner@yahoo.com" + (result ^.. opmlHeadL . expansionStateL) @?= [] + (result ^. opmlHeadL . vertScrollStateL) @?= Just 1 + (result ^. opmlHeadL . windowBottomL) @?= Just 386 + (result ^. opmlHeadL . windowLeftL) @?= Just 466 + (result ^. opmlHeadL . windowRightL) @?= Just 964 + (result ^. opmlHeadL . windowTopL) @?= Just 105 + length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineLink) @?= 8 + map (map length .levels) (result ^. opmlOutlinesL) @?= [[1], [1], [1], [1], [1], [1], [1], [1]] placesCase :: TestTree @@ -94,18 +100,21 @@ dataFile <- fromString <$> getDataFileName "data/placesLived.opml" result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser 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]] + (result ^. opmlVersionL) @?= Version [2,0] [] + (result ^. opmlHeadL . opmlTitleL) @?= "placesLived.opml" + show (result ^. opmlHeadL . opmlCreatedL) @?= "Just 2006-02-27 12:09:48 UTC" + show (result ^. opmlHeadL . modifiedL) @?= "Just 2006-02-27 12:11:44 UTC" + (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer" + fmap (decodeUtf8 . serializeURI') (result ^. opmlHeadL . ownerIdL) @?= Just "http://www.opml.org/profiles/sendMail?usernum=1" + (result ^.. opmlHeadL . expansionStateL) @?= [1,2,5,10,13,15] + (result ^. opmlHeadL . vertScrollStateL) @?= Just 1 + (result ^. opmlHeadL . windowBottomL) @?= Just 665 + (result ^. opmlHeadL . windowLeftL) @?= Just 329 + (result ^. opmlHeadL . windowRightL) @?= Just 547 + (result ^. opmlHeadL . windowTopL) @?= Just 242 + length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineGeneric) @?= 18 + length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineLink) @?= 1 + map (map length .levels) (result ^. opmlOutlinesL) @?= [[1,6,12]] scriptCase :: TestTree @@ -113,17 +122,20 @@ dataFile <- fromString <$> getDataFileName "data/simpleScript.opml" result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser 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]] + (result ^. opmlVersionL) @?= Version [2,0] [] + (result ^. opmlHeadL . opmlTitleL) @?= "workspace.userlandsamples.doSomeUpstreaming" + show (result ^. opmlHeadL . opmlCreatedL) @?= "Just 2002-02-11 22:48:02 UTC" + show (result ^. opmlHeadL . modifiedL) @?= "Just 2005-10-30 03:30:17 UTC" + (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer" + (result ^. opmlHeadL . ownerEmailL) @?= "dwiner@yahoo.com" + (result ^.. opmlHeadL . expansionStateL) @?= [1, 2, 4] + (result ^. opmlHeadL . vertScrollStateL) @?= Just 1 + (result ^. opmlHeadL . windowBottomL) @?= Just 314 + (result ^. opmlHeadL . windowLeftL) @?= Just 41 + (result ^. opmlHeadL . windowRightL) @?= Just 475 + (result ^. opmlHeadL . windowTopL) @?= Just 74 + length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineGeneric) @?= 11 + map (map length .levels) (result ^. opmlOutlinesL) @?= [[1,2,2], [1,2], [1], [1,1]] statesCase :: TestTree @@ -131,17 +143,20 @@ dataFile <- fromString <$> getDataFileName "data/states.opml" result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser 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]] + (result ^. opmlVersionL) @?= Version [2,0] [] + (result ^. opmlHeadL . opmlTitleL) @?= "states.opml" + show (result ^. opmlHeadL . opmlCreatedL) @?= "Just 2005-03-15 16:35:45 UTC" + show (result ^. opmlHeadL . modifiedL) @?= "Just 2005-07-14 23:41:05 UTC" + (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer" + (result ^. opmlHeadL . ownerEmailL) @?= "dave@scripting.com" + (result ^.. opmlHeadL . expansionStateL) @?= [1, 6, 13, 16, 18, 20] + (result ^. opmlHeadL . vertScrollStateL) @?= Just 1 + (result ^. opmlHeadL . windowBottomL) @?= Just 558 + (result ^. opmlHeadL . windowLeftL) @?= Just 106 + (result ^. opmlHeadL . windowRightL) @?= Just 479 + (result ^. opmlHeadL . windowTopL) @?= Just 106 + length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineGeneric) @?= 63 + map (map length .levels) (result ^. opmlOutlinesL) @?= [[1, 8, 50, 4]] subscriptionsCase :: TestTree @@ -149,18 +164,21 @@ dataFile <- fromString <$> getDataFileName "data/subscriptionList.opml" result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser 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 + (result ^. opmlVersionL) @?= Version [2,0] [] + (result ^. opmlHeadL . opmlTitleL) @?= "mySubscriptions.opml" + show (result ^. opmlHeadL . opmlCreatedL) @?= "Just 2005-06-18 12:11:52 UTC" + show (result ^. opmlHeadL . modifiedL) @?= "Just 2005-08-02 21:42:48 UTC" + (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer" + (result ^. opmlHeadL . ownerEmailL) @?= "dave@scripting.com" + (result ^. opmlHeadL . vertScrollStateL) @?= Just 1 + (result ^. opmlHeadL . windowBottomL) @?= Just 562 + (result ^. opmlHeadL . windowLeftL) @?= Just 304 + (result ^. opmlHeadL . windowRightL) @?= Just 842 + (result ^. opmlHeadL . windowTopL) @?= Just 61 + 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) -inverseProperty :: TestTree -inverseProperty = testProperty "parse . render = id" $ \opml -> either (const False) (opml ==) (runIdentity . runCatchT . runConduit $ renderOpml opml =$= runConduitParser parseOpml) +-- inverseProperty :: TestTree +-- inverseProperty = testProperty "parse . render = id" $ \opml -> either (const False) (opml ==) (runIdentity . runCatchT . runConduit $ renderOpml opml =$= runConduitParser parseOpml)