module Text.XML.Stream.Parse
(
parseBytes
, parseBytesPos
, parseText'
, parseText
, parseTextPos
, detectUtf
, parseFile
, parseLBS
, ParseSettings
, def
, DecodeEntities
, DecodeIllegalCharacters
, psDecodeEntities
, psDecodeIllegalCharacters
, psRetainNamespaces
, decodeXmlEntities
, decodeHtmlEntities
, tag
, tag'
, tagNoAttr
, tagIgnoreAttrs
, content
, contentMaybe
, ignoreTag
, ignoreEmptyTag
, ignoreTree
, ignoreTreeContent
, ignoreAnyTreeContent
, ignoreAllTreesContent
, takeContent
, takeTree
, takeTreeContent
, takeAnyTreeContent
, takeAllTreesContent
, NameMatcher(..)
, matching
, anyOf
, anyName
, AttrParser
, attr
, requireAttr
, optionalAttr
, requireAttrRaw
, optionalAttrRaw
, ignoreAttrs
, orE
, choose
, many
, many_
, manyIgnore
, many'
, force
, manyYield
, manyYield'
, manyIgnoreYield
, XmlException (..)
, PositionRange
, EventPos
) where
import Control.Applicative (Alternative (empty, (<|>)),
Applicative (..), (<$>))
import qualified Control.Applicative as A
import Control.Arrow ((***))
import Control.Exception (Exception (..), SomeException)
import Control.Monad (ap, liftM, void)
import Control.Monad.Fix (fix)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Control.Monad.Trans.Resource (MonadResource, MonadThrow (..),
throwM)
import Data.Attoparsec.Text (Parser, anyChar, char, manyTill,
skipWhile, string, takeWhile,
takeWhile1, try)
import qualified Data.Attoparsec.Text as AT
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Char (isSpace)
import Conduit
import qualified Data.Conduit.Text as CT
import Data.Conduit.Attoparsec (PositionRange, conduitParser)
import Data.Default.Class (Default (..))
import Data.List (intercalate)
import Data.List (foldl')
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isNothing)
import Data.String (IsString (..))
import Data.Text (Text, pack)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Typeable (Typeable)
import Data.XML.Types (Content (..), Event (..),
ExternalID (..),
Instruction (..), Name (..))
import Prelude hiding (takeWhile)
import Text.XML.Stream.Token
type Ents = [(Text, Text)]
tokenToEvent :: ParseSettings -> Ents -> [NSLevel] -> Token -> (Ents, [NSLevel], [Event])
tokenToEvent _ es n (TokenXMLDeclaration _) = (es, n, [])
tokenToEvent _ es n (TokenInstruction i) = (es, n, [EventInstruction i])
tokenToEvent ps es n (TokenBeginElement name as isClosed _) =
(es, n', if isClosed then [begin, end] else [begin])
where
l0 = case n of
[] -> NSLevel Nothing Map.empty
x:_ -> x
(as', l') = foldl' go (id, l0) as
go (front, l) (TName kpref kname, val) =
(addNS front, l'')
where
isPrefixed = kpref == Just "xmlns"
isUnprefixed = isNothing kpref && kname == "xmlns"
addNS
| not (psRetainNamespaces ps) && (isPrefixed || isUnprefixed) = id
| otherwise = (((tname, map resolve val):) .)
where
tname
| isPrefixed = TName Nothing ("xmlns:" `T.append` kname)
| otherwise = TName kpref kname
l''
| isPrefixed =
l { prefixes = Map.insert kname (contentsToText val)
$ prefixes l }
| isUnprefixed =
l { defaultNS = if T.null $ contentsToText val
then Nothing
else Just $ contentsToText val }
| otherwise = l
resolve (ContentEntity e)
| Just t <- lookup e es = ContentText t
resolve c = c
n' = if isClosed then n else l' : n
fixAttName (name', val) = (tnameToName True l' name', val)
elementName = tnameToName False l' name
begin = EventBeginElement elementName $ map fixAttName $ as' []
end = EventEndElement elementName
tokenToEvent _ es n (TokenEndElement name) =
(es, n', [EventEndElement $ tnameToName False l name])
where
(l, n') =
case n of
[] -> (NSLevel Nothing Map.empty, [])
x:xs -> (x, xs)
tokenToEvent _ es n (TokenContent (ContentEntity e))
| Just t <- lookup e es = (es, n, [EventContent $ ContentText t])
tokenToEvent _ es n (TokenContent c) = (es, n, [EventContent c])
tokenToEvent _ es n (TokenComment c) = (es, n, [EventComment c])
tokenToEvent _ es n (TokenDoctype t eid es') = (es ++ es', n, [EventBeginDoctype t eid, EventEndDoctype])
tokenToEvent _ es n (TokenCDATA t) = (es, n, [EventCDATA t])
tnameToName :: Bool -> NSLevel -> TName -> Name
tnameToName _ _ (TName (Just "xml") name) =
Name name (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")
tnameToName isAttr (NSLevel def' _) (TName Nothing name) =
Name name (if isAttr then Nothing else def') Nothing
tnameToName _ (NSLevel _ m) (TName (Just pref) name) =
case Map.lookup pref m of
Just ns -> Name name (Just ns) (Just pref)
Nothing -> Name name Nothing (Just pref)
detectUtf :: MonadThrow m => ConduitT S.ByteString T.Text m ()
detectUtf =
conduit id
where
conduit front = await >>= maybe (return ()) (push front)
push front bss =
either conduit
(uncurry checkXMLDecl)
(getEncoding front bss)
getEncoding front bs'
| S.length bs < 4 =
Left (bs `S.append`)
| otherwise =
Right (bsOut, mcodec)
where
bs = front bs'
bsOut = S.append (S.drop toDrop x) y
(x, y) = S.splitAt 4 bs
(toDrop, mcodec) =
case S.unpack x of
[0x00, 0x00, 0xFE, 0xFF] -> (4, Just CT.utf32_be)
[0xFF, 0xFE, 0x00, 0x00] -> (4, Just CT.utf32_le)
0xFE : 0xFF: _ -> (2, Just CT.utf16_be)
0xFF : 0xFE: _ -> (2, Just CT.utf16_le)
0xEF : 0xBB: 0xBF : _ -> (3, Just CT.utf8)
[0x00, 0x00, 0x00, 0x3C] -> (0, Just CT.utf32_be)
[0x3C, 0x00, 0x00, 0x00] -> (0, Just CT.utf32_le)
[0x00, 0x3C, 0x00, 0x3F] -> (0, Just CT.utf16_be)
[0x3C, 0x00, 0x3F, 0x00] -> (0, Just CT.utf16_le)
_ -> (0, Nothing)
checkXMLDecl :: MonadThrow m
=> S.ByteString
-> Maybe CT.Codec
-> ConduitT S.ByteString T.Text m ()
checkXMLDecl bs (Just codec) = leftover bs >> CT.decode codec
checkXMLDecl bs0 Nothing =
loop [] (AT.parse (parseToken def)) bs0
where
loop chunks0 parser nextChunk =
case parser $ decodeUtf8With lenientDecode nextChunk of
AT.Fail{} -> fallback
AT.Partial f -> await >>= maybe fallback (loop chunks f)
AT.Done _ (TokenXMLDeclaration attrs) -> findEncoding attrs
AT.Done{} -> fallback
where
chunks = nextChunk : chunks0
fallback = complete CT.utf8
complete codec = mapM_ leftover chunks >> CT.decode codec
findEncoding [] = fallback
findEncoding ((TName _ "encoding", [ContentText enc]):_) =
case T.toLower enc of
"iso-8859-1" -> complete CT.iso8859_1
"utf-8" -> complete CT.utf8
_ -> complete CT.utf8
findEncoding (_:xs) = findEncoding xs
type EventPos = (Maybe PositionRange, Event)
parseBytes :: MonadThrow m
=> ParseSettings
-> ConduitT S.ByteString Event m ()
parseBytes = mapOutput snd . parseBytesPos
parseBytesPos :: MonadThrow m
=> ParseSettings
-> ConduitT S.ByteString EventPos m ()
parseBytesPos ps = detectUtf .| parseTextPos ps
dropBOM :: Monad m => ConduitT T.Text T.Text m ()
dropBOM =
await >>= maybe (return ()) push
where
push t =
case T.uncons t of
Nothing -> dropBOM
Just (c, cs) ->
let output
| c == '\xfeef' = cs
| otherwise = t
in yield output >> idConduit
idConduit = await >>= maybe (return ()) (\x -> yield x >> idConduit)
parseText' :: MonadThrow m
=> ParseSettings
-> ConduitT T.Text Event m ()
parseText' = mapOutput snd . parseTextPos
parseText :: MonadThrow m
=> ParseSettings
-> ConduitT T.Text EventPos m ()
parseText = parseTextPos
parseTextPos :: MonadThrow m
=> ParseSettings
-> ConduitT T.Text EventPos m ()
parseTextPos de =
dropBOM
.| tokenize
.| toEventC de
.| addBeginEnd
where
tokenize = conduitToken de
addBeginEnd = yield (Nothing, EventBeginDocument) >> addEnd
addEnd = await >>= maybe
(yield (Nothing, EventEndDocument))
(\e -> yield e >> addEnd)
toEventC :: Monad m => ParseSettings -> ConduitT (PositionRange, Token) EventPos m ()
toEventC ps =
go [] []
where
go !es !levels =
await >>= maybe (return ()) push
where
push (position, token) =
mapM_ (yield . (,) (Just position)) events >> go es' levels'
where
(es', levels', events) = tokenToEvent ps es levels token
type DecodeEntities = Text -> Content
type DecodeIllegalCharacters = Int -> Maybe Char
data ParseSettings = ParseSettings
{ psDecodeEntities :: DecodeEntities
, psRetainNamespaces :: Bool
, psDecodeIllegalCharacters :: DecodeIllegalCharacters
}
instance Default ParseSettings where
def = ParseSettings
{ psDecodeEntities = decodeXmlEntities
, psRetainNamespaces = False
, psDecodeIllegalCharacters = const Nothing
}
conduitToken :: MonadThrow m => ParseSettings -> ConduitT T.Text (PositionRange, Token) m ()
conduitToken = conduitParser . parseToken
parseToken :: ParseSettings -> Parser Token
parseToken settings = (char '<' >> parseLt) <|> TokenContent <$> parseContent settings False False
where
parseLt =
(char '?' >> parseInstr) <|>
(char '!' >> (parseComment <|> parseCdata <|> parseDoctype)) <|>
parseBegin <|>
(char '/' >> parseEnd)
parseInstr = do
name <- parseIdent
if name == "xml"
then do
as <- A.many $ parseAttribute settings
skipSpace
char' '?'
char' '>'
newline <|> return ()
return $ TokenXMLDeclaration as
else do
skipSpace
x <- T.pack <$> manyTill anyChar (try $ string "?>")
return $ TokenInstruction $ Instruction name x
parseComment = do
char' '-'
char' '-'
c <- T.pack <$> manyTill anyChar (string "-->")
return $ TokenComment c
parseCdata = do
_ <- string "[CDATA["
t <- T.pack <$> manyTill anyChar (string "]]>")
return $ TokenCDATA t
parseDoctype = do
_ <- string "DOCTYPE"
skipSpace
name <- parseName
let i =
case name of
TName Nothing x -> x
TName (Just x) y -> T.concat [x, ":", y]
skipSpace
eid <- fmap Just parsePublicID <|>
fmap Just parseSystemID <|>
return Nothing
skipSpace
ents <- (do
char' '['
ents <- parseEntities id
skipSpace
return ents) <|> return []
char' '>'
newline <|> return ()
return $ TokenDoctype i eid ents
parseEntities front =
(char ']' >> return (front [])) <|>
(parseEntity >>= \e -> parseEntities (front . (e:))) <|>
(char '<' >> parseEntities front) <|>
(skipWhile (\t -> t /= ']' && t /= '<') >> parseEntities front)
parseEntity = try $ do
_ <- string "<!ENTITY"
skipSpace
i <- parseIdent
t <- quotedText
skipSpace
char' '>'
return (i, t)
parsePublicID = do
_ <- string "PUBLIC"
x <- quotedText
y <- quotedText
return $ PublicID x y
parseSystemID = do
_ <- string "SYSTEM"
x <- quotedText
return $ SystemID x
quotedText = do
skipSpace
between '"' <|> between '\''
between c = do
char' c
x <- takeWhile (/=c)
char' c
return x
parseEnd = do
skipSpace
n <- parseName
skipSpace
char' '>'
return $ TokenEndElement n
parseBegin = do
skipSpace
n <- parseName
as <- A.many $ parseAttribute settings
skipSpace
isClose <- (char '/' >> skipSpace >> return True) <|> return False
char' '>'
return $ TokenBeginElement n as isClose 0
parseAttribute :: ParseSettings -> Parser TAttribute
parseAttribute settings = do
skipSpace
key <- parseName
skipSpace
char' '='
skipSpace
val <- squoted <|> dquoted
return (key, val)
where
squoted = char '\'' *> manyTill (parseContent settings False True) (char '\'')
dquoted = char '"' *> manyTill (parseContent settings True False) (char '"')
parseName :: Parser TName
parseName =
name <$> parseIdent <*> A.optional (char ':' >> parseIdent)
where
name i1 Nothing = TName Nothing i1
name i1 (Just i2) = TName (Just i1) i2
parseIdent :: Parser Text
parseIdent =
takeWhile1 valid
where
valid '&' = False
valid '<' = False
valid '>' = False
valid ':' = False
valid '?' = False
valid '=' = False
valid '"' = False
valid '\'' = False
valid '/' = False
valid ';' = False
valid '#' = False
valid c = not $ isXMLSpace c
parseContent :: ParseSettings
-> Bool
-> Bool
-> Parser Content
parseContent (ParseSettings decodeEntities _ decodeIllegalCharacters) breakDouble breakSingle = parseReference <|> parseTextContent where
parseReference = do
char' '&'
t <- parseEntityRef <|> parseHexCharRef <|> parseDecCharRef
char' ';'
return t
parseEntityRef = do
TName ma b <- parseName
let name = maybe "" (`T.append` ":") ma `T.append` b
return $ case name of
"lt" -> ContentText "<"
"gt" -> ContentText ">"
"amp" -> ContentText "&"
"quot" -> ContentText "\""
"apos" -> ContentText "'"
_ -> decodeEntities name
parseHexCharRef = do
void $ string "#x"
n <- AT.hexadecimal
case toValidXmlChar n <|> decodeIllegalCharacters n of
Nothing -> fail "Invalid character from hexadecimal character reference."
Just c -> return $ ContentText $ T.singleton c
parseDecCharRef = do
void $ string "#"
n <- AT.decimal
case toValidXmlChar n <|> decodeIllegalCharacters n of
Nothing -> fail "Invalid character from decimal character reference."
Just c -> return $ ContentText $ T.singleton c
parseTextContent = ContentText <$> takeWhile1 valid
valid '"' = not breakDouble
valid '\'' = not breakSingle
valid '&' = False
valid '<' = False
valid _ = True
toValidXmlChar :: Int -> Maybe Char
toValidXmlChar n
| any checkRange ranges = Just (toEnum n)
| otherwise = Nothing
where
ranges :: [(Int, Int)]
ranges =
[ (0x9, 0xA)
, (0xD, 0xD)
, (0x20, 0xD7FF)
, (0xE000, 0xFFFD)
, (0x10000, 0x10FFFF)
]
checkRange (lb, ub) = lb <= n && n <= ub
skipSpace :: Parser ()
skipSpace = skipWhile isXMLSpace
isXMLSpace :: Char -> Bool
isXMLSpace ' ' = True
isXMLSpace '\t' = True
isXMLSpace '\r' = True
isXMLSpace '\n' = True
isXMLSpace _ = False
newline :: Parser ()
newline = void $ (char '\r' >> char '\n') <|> char '\n'
char' :: Char -> Parser ()
char' = void . char
data ContentType = Ignore | IsContent Text | IsError String | NotContent
contentMaybe :: MonadThrow m => ConduitT Event o m (Maybe Text)
contentMaybe = do
x <- peekC
case pc' x of
Ignore -> dropC 1 >> contentMaybe
IsContent t -> dropC 1 >> fmap Just (takeContents (t:))
IsError e -> lift $ throwM $ InvalidEntity e x
NotContent -> return Nothing
where
pc' Nothing = NotContent
pc' (Just x) = pc x
pc (EventContent (ContentText t)) = IsContent t
pc (EventContent (ContentEntity e)) = IsError $ "Unknown entity: " ++ show e
pc (EventCDATA t) = IsContent t
pc EventBeginElement{} = NotContent
pc EventEndElement{} = NotContent
pc EventBeginDocument{} = Ignore
pc EventEndDocument = Ignore
pc EventBeginDoctype{} = Ignore
pc EventEndDoctype = Ignore
pc EventInstruction{} = Ignore
pc EventComment{} = Ignore
takeContents front = do
x <- peekC
case pc' x of
Ignore -> dropC 1 >> takeContents front
IsContent t -> dropC 1 >> takeContents (front . (:) t)
IsError e -> lift $ throwM $ InvalidEntity e x
NotContent -> return $ T.concat $ front []
content :: MonadThrow m => ConduitT Event o m Text
content = fromMaybe T.empty <$> contentMaybe
isWhitespace :: Event -> Bool
isWhitespace EventBeginDocument = True
isWhitespace EventEndDocument = True
isWhitespace EventBeginDoctype{} = True
isWhitespace EventEndDoctype = True
isWhitespace EventInstruction{} = True
isWhitespace (EventContent (ContentText t)) = T.all isSpace t
isWhitespace EventComment{} = True
isWhitespace (EventCDATA t) = T.all isSpace t
isWhitespace _ = False
tag :: MonadThrow m
=> NameMatcher a
-> (a -> AttrParser b)
-> (b -> ConduitT Event o m c)
-> ConduitT Event o m (Maybe c)
tag nameMatcher attrParser f = do
(x, leftovers) <- dropWS []
res <- case x of
Just (EventBeginElement name as) -> case runNameMatcher nameMatcher name of
Just y -> case runAttrParser' (attrParser y) as of
Left _ -> return Nothing
Right z -> do
z' <- f z
(a, _leftovers') <- dropWS []
case a of
Just (EventEndElement name')
| name == name' -> return (Just z')
_ -> lift $ throwM $ InvalidEndElement name a
Nothing -> return Nothing
_ -> return Nothing
case res of
Nothing -> mapM_ leftover leftovers
Just _ -> return ()
return res
where
dropWS leftovers = do
x <- await
let leftovers' = maybe id (:) x leftovers
case isWhitespace <$> x of
Just True -> dropWS leftovers'
_ -> return (x, leftovers')
runAttrParser' p as =
case runAttrParser p as of
Left e -> Left e
Right ([], x) -> Right x
Right (attr', _) -> Left $ toException $ UnparsedAttributes attr'
tag' :: MonadThrow m
=> NameMatcher a -> AttrParser b -> (b -> ConduitT Event o m c)
-> ConduitT Event o m (Maybe c)
tag' a b = tag a (const b)
tagNoAttr :: MonadThrow m
=> NameMatcher a
-> ConduitT Event o m b
-> ConduitT Event o m (Maybe b)
tagNoAttr name f = tag' name (return ()) $ const f
tagIgnoreAttrs :: MonadThrow m
=> NameMatcher a
-> ConduitT Event o m b
-> ConduitT Event o m (Maybe b)
tagIgnoreAttrs name f = tag' name ignoreAttrs $ const f
ignoreEmptyTag :: MonadThrow m
=> NameMatcher a
-> ConduitT Event o m (Maybe ())
ignoreEmptyTag nameMatcher = tagIgnoreAttrs nameMatcher (return ())
ignoreTag :: MonadThrow m
=> NameMatcher a
-> ConduitT Event o m (Maybe ())
ignoreTag = ignoreEmptyTag
ignoreTreeContent :: MonadThrow m
=> NameMatcher a
-> ConduitT Event o m (Maybe ())
ignoreTreeContent namePred = tagIgnoreAttrs namePred (void $ many ignoreAnyTreeContent)
ignoreTree :: MonadThrow m
=> NameMatcher a
-> ConduitT Event o m (Maybe ())
ignoreTree = ignoreTreeContent
ignoreAnyTreeContent :: MonadThrow m => ConduitT Event o m (Maybe ())
ignoreAnyTreeContent = (void <$> contentMaybe) `orE` ignoreTreeContent anyName
ignoreAllTreesContent :: MonadThrow m => ConduitT Event o m (Maybe ())
ignoreAllTreesContent = ignoreAnyTreeContent
orE :: Monad m
=> ConduitT Event o m (Maybe a)
-> ConduitT Event o m (Maybe a)
-> ConduitT Event o m (Maybe a)
orE a b = a >>= \x -> maybe b (const $ return x) x
choose :: Monad m
=> [ConduitT Event o m (Maybe a)]
-> ConduitT Event o m (Maybe a)
choose [] = return Nothing
choose (i:is) = i >>= maybe (choose is) (return . Just)
force :: MonadThrow m
=> String
-> m (Maybe a)
-> m a
force msg i = i >>= maybe (throwM $ XmlException msg Nothing) return
parseFile :: MonadResource m
=> ParseSettings
-> FilePath
-> ConduitT i Event m ()
parseFile ps fp = sourceFile fp .| transPipe liftIO (parseBytes ps)
parseLBS :: MonadThrow m
=> ParseSettings
-> L.ByteString
-> ConduitT i Event m ()
parseLBS ps lbs = sourceLazy lbs .| parseBytes ps
data XmlException = XmlException
{ xmlErrorMessage :: String
, xmlBadInput :: Maybe Event
}
| InvalidEndElement Name (Maybe Event)
| InvalidEntity String (Maybe Event)
| MissingAttribute String
| UnparsedAttributes [(Name, [Content])]
deriving (Show, Typeable)
instance Exception XmlException where
#if MIN_VERSION_base(4, 8, 0)
displayException (XmlException msg (Just event)) = "Error while parsing XML event " ++ show event ++ ": " ++ msg
displayException (XmlException msg _) = "Error while parsing XML: " ++ msg
displayException (InvalidEndElement name (Just event)) = "Error while parsing XML event: expected </" ++ T.unpack (nameLocalName name) ++ ">, got " ++ show event
displayException (InvalidEndElement name _) = "Error while parsing XML event: expected </" ++ show name ++ ">, got nothing"
displayException (InvalidEntity msg (Just event)) = "Error while parsing XML entity " ++ show event ++ ": " ++ msg
displayException (InvalidEntity msg _) = "Error while parsing XML entity: " ++ msg
displayException (MissingAttribute msg) = "Missing required attribute: " ++ msg
displayException (UnparsedAttributes attrs) = show (length attrs) ++ " remaining unparsed attributes: \n" ++ intercalate "\n" (show <$> attrs)
#endif
newtype NameMatcher a = NameMatcher { runNameMatcher :: Name -> Maybe a }
deriving instance Functor NameMatcher
instance Applicative NameMatcher where
pure a = NameMatcher $ const $ pure a
NameMatcher f <*> NameMatcher a = NameMatcher $ \name -> f name <*> a name
instance Alternative NameMatcher where
empty = NameMatcher $ const Nothing
NameMatcher f <|> NameMatcher g = NameMatcher (\a -> f a <|> g a)
instance (a ~ Name) => IsString (NameMatcher a) where
fromString s = matching (== fromString s)
matching :: (Name -> Bool) -> NameMatcher Name
matching f = NameMatcher $ \name -> if f name then Just name else Nothing
anyName :: NameMatcher Name
anyName = matching (const True)
anyOf :: [Name] -> NameMatcher Name
anyOf values = matching (`elem` values)
newtype AttrParser a = AttrParser { runAttrParser :: [(Name, [Content])] -> Either SomeException ([(Name, [Content])], a) }
instance Monad AttrParser where
return a = AttrParser $ \as -> Right (as, a)
(AttrParser f) >>= g = AttrParser $ \as ->
either Left (\(as', f') -> runAttrParser (g f') as') (f as)
instance Functor AttrParser where
fmap = liftM
instance Applicative AttrParser where
pure = return
(<*>) = ap
instance Alternative AttrParser where
empty = AttrParser $ const $ Left $ toException $ XmlException "AttrParser.empty" Nothing
AttrParser f <|> AttrParser g = AttrParser $ \x ->
either (const $ g x) Right (f x)
instance MonadThrow AttrParser where
throwM = AttrParser . const . throwM
optionalAttrRaw :: ((Name, [Content]) -> Maybe b) -> AttrParser (Maybe b)
optionalAttrRaw f =
AttrParser $ go id
where
go front [] = Right (front [], Nothing)
go front (a:as) =
maybe (go (front . (:) a) as)
(\b -> Right (front as, Just b))
(f a)
requireAttrRaw :: String -> ((Name, [Content]) -> Maybe b) -> AttrParser b
requireAttrRaw msg f = optionalAttrRaw f >>=
maybe (AttrParser $ const $ Left $ toException $ MissingAttribute msg)
return
attr :: Name -> AttrParser (Maybe Text)
attr n = optionalAttrRaw
(\(x, y) -> if x == n then Just (contentsToText y) else Nothing)
requireAttr :: Name -> AttrParser Text
requireAttr n = force ("Missing attribute: " ++ show n) $ attr n
optionalAttr :: Name -> AttrParser (Maybe Text)
optionalAttr = attr
contentsToText :: [Content] -> Text
contentsToText = T.concat . map toText where
toText (ContentText t) = t
toText (ContentEntity e) = T.concat ["&", e, ";"]
ignoreAttrs :: AttrParser ()
ignoreAttrs = AttrParser $ const $ Right ([], ())
many :: Monad m
=> ConduitT Event o m (Maybe a)
-> ConduitT Event o m [a]
many i = manyIgnore i $ return Nothing
many_ :: MonadThrow m
=> ConduitT Event o m (Maybe a)
-> ConduitT Event o m ()
many_ consumer = manyIgnoreYield (return Nothing) (void <$> consumer)
manyIgnore :: Monad m
=> ConduitT Event o m (Maybe a)
-> ConduitT Event o m (Maybe b)
-> ConduitT Event o m [a]
manyIgnore i ignored = go id where
go front = i >>= maybe (onFail front) (\y -> go $ front . (:) y)
onFail front = ignored >>= maybe (return $ front []) (const $ go front)
many' :: MonadThrow m
=> ConduitT Event o m (Maybe a)
-> ConduitT Event o m [a]
many' consumer = manyIgnore consumer ignoreAllTreesContent
manyYield :: Monad m
=> ConduitT a b m (Maybe b)
-> ConduitT a b m ()
manyYield consumer = fix $ \loop ->
consumer >>= maybe (return ()) (\x -> yield x >> loop)
manyIgnoreYield :: MonadThrow m
=> ConduitT Event b m (Maybe b)
-> ConduitT Event b m (Maybe ())
-> ConduitT Event b m ()
manyIgnoreYield consumer ignoreParser = fix $ \loop ->
consumer >>= maybe (onFail loop) (\x -> yield x >> loop)
where onFail loop = ignoreParser >>= maybe (return ()) (const loop)
manyYield' :: MonadThrow m
=> ConduitT Event b m (Maybe b)
-> ConduitT Event b m ()
manyYield' consumer = manyIgnoreYield consumer ignoreAllTreesContent
takeContent :: MonadThrow m => ConduitT Event Event m (Maybe ())
takeContent = do
event <- await
case event of
Just e@(EventContent ContentText{}) -> yield e >> return (Just ())
Just e@EventCDATA{} -> yield e >> return (Just ())
Just e -> if isWhitespace e then yield e >> takeContent else leftover e >> return Nothing
_ -> return Nothing
takeTree :: MonadThrow m => NameMatcher a -> AttrParser b -> ConduitT Event Event m (Maybe ())
takeTree nameMatcher attrParser = do
event <- await
case event of
Just e@(EventBeginElement name as) -> case runNameMatcher nameMatcher name of
Just _ -> case runAttrParser attrParser as of
Right _ -> do
yield e
whileJust takeAnyTreeContent
endEvent <- await
case endEvent of
Just e'@(EventEndElement name') | name == name' -> yield e' >> return (Just ())
_ -> lift $ throwM $ InvalidEndElement name endEvent
_ -> leftover e >> return Nothing
_ -> leftover e >> return Nothing
Just e -> if isWhitespace e then yield e >> takeTree nameMatcher attrParser else leftover e >> return Nothing
_ -> return Nothing
where
whileJust f = fix $ \loop -> f >>= maybe (return ()) (const loop)
takeTreeContent :: MonadThrow m
=> NameMatcher a
-> AttrParser b
-> ConduitT Event Event m (Maybe ())
takeTreeContent nameMatcher attrParser = runMaybeT $ MaybeT (takeTree nameMatcher attrParser) <|> MaybeT takeContent
takeAnyTreeContent :: MonadThrow m
=> ConduitT Event Event m (Maybe ())
takeAnyTreeContent = takeTreeContent anyName ignoreAttrs
takeAllTreesContent :: MonadThrow m => ConduitT Event Event m (Maybe ())
takeAllTreesContent = takeAnyTreeContent
decodeXmlEntities :: DecodeEntities
decodeXmlEntities = ContentEntity
decodeHtmlEntities :: DecodeEntities
decodeHtmlEntities t =
maybe (ContentEntity t) ContentText $ Map.lookup t htmlEntities
htmlEntities :: Map.Map T.Text T.Text
htmlEntities = Map.fromList
$ map (pack *** pack)
[ ("nbsp", "\160")
, ("iexcl", "\161")
, ("cent", "\162")
, ("pound", "\163")
, ("curren", "\164")
, ("yen", "\165")
, ("brvbar", "\166")
, ("sect", "\167")
, ("uml", "\168")
, ("copy", "\169")
, ("ordf", "\170")
, ("laquo", "\171")
, ("not", "\172")
, ("shy", "\173")
, ("reg", "\174")
, ("macr", "\175")
, ("deg", "\176")
, ("plusmn", "\177")
, ("sup2", "\178")
, ("sup3", "\179")
, ("acute", "\180")
, ("micro", "\181")
, ("para", "\182")
, ("middot", "\183")
, ("cedil", "\184")
, ("sup1", "\185")
, ("ordm", "\186")
, ("raquo", "\187")
, ("frac14", "\188")
, ("frac12", "\189")
, ("frac34", "\190")
, ("iquest", "\191")
, ("Agrave", "\192")
, ("Aacute", "\193")
, ("Acirc", "\194")
, ("Atilde", "\195")
, ("Auml", "\196")
, ("Aring", "\197")
, ("AElig", "\198")
, ("Ccedil", "\199")
, ("Egrave", "\200")
, ("Eacute", "\201")
, ("Ecirc", "\202")
, ("Euml", "\203")
, ("Igrave", "\204")
, ("Iacute", "\205")
, ("Icirc", "\206")
, ("Iuml", "\207")
, ("ETH", "\208")
, ("Ntilde", "\209")
, ("Ograve", "\210")
, ("Oacute", "\211")
, ("Ocirc", "\212")
, ("Otilde", "\213")
, ("Ouml", "\214")
, ("times", "\215")
, ("Oslash", "\216")
, ("Ugrave", "\217")
, ("Uacute", "\218")
, ("Ucirc", "\219")
, ("Uuml", "\220")
, ("Yacute", "\221")
, ("THORN", "\222")
, ("szlig", "\223")
, ("agrave", "\224")
, ("aacute", "\225")
, ("acirc", "\226")
, ("atilde", "\227")
, ("auml", "\228")
, ("aring", "\229")
, ("aelig", "\230")
, ("ccedil", "\231")
, ("egrave", "\232")
, ("eacute", "\233")
, ("ecirc", "\234")
, ("euml", "\235")
, ("igrave", "\236")
, ("iacute", "\237")
, ("icirc", "\238")
, ("iuml", "\239")
, ("eth", "\240")
, ("ntilde", "\241")
, ("ograve", "\242")
, ("oacute", "\243")
, ("ocirc", "\244")
, ("otilde", "\245")
, ("ouml", "\246")
, ("divide", "\247")
, ("oslash", "\248")
, ("ugrave", "\249")
, ("uacute", "\250")
, ("ucirc", "\251")
, ("uuml", "\252")
, ("yacute", "\253")
, ("thorn", "\254")
, ("yuml", "\255")
, ("OElig", "\338")
, ("oelig", "\339")
, ("Scaron", "\352")
, ("scaron", "\353")
, ("Yuml", "\376")
, ("fnof", "\402")
, ("circ", "\710")
, ("tilde", "\732")
, ("Alpha", "\913")
, ("Beta", "\914")
, ("Gamma", "\915")
, ("Delta", "\916")
, ("Epsilon", "\917")
, ("Zeta", "\918")
, ("Eta", "\919")
, ("Theta", "\920")
, ("Iota", "\921")
, ("Kappa", "\922")
, ("Lambda", "\923")
, ("Mu", "\924")
, ("Nu", "\925")
, ("Xi", "\926")
, ("Omicron", "\927")
, ("Pi", "\928")
, ("Rho", "\929")
, ("Sigma", "\931")
, ("Tau", "\932")
, ("Upsilon", "\933")
, ("Phi", "\934")
, ("Chi", "\935")
, ("Psi", "\936")
, ("Omega", "\937")
, ("alpha", "\945")
, ("beta", "\946")
, ("gamma", "\947")
, ("delta", "\948")
, ("epsilon", "\949")
, ("zeta", "\950")
, ("eta", "\951")
, ("theta", "\952")
, ("iota", "\953")
, ("kappa", "\954")
, ("lambda", "\955")
, ("mu", "\956")
, ("nu", "\957")
, ("xi", "\958")
, ("omicron", "\959")
, ("pi", "\960")
, ("rho", "\961")
, ("sigmaf", "\962")
, ("sigma", "\963")
, ("tau", "\964")
, ("upsilon", "\965")
, ("phi", "\966")
, ("chi", "\967")
, ("psi", "\968")
, ("omega", "\969")
, ("thetasym", "\977")
, ("upsih", "\978")
, ("piv", "\982")
, ("ensp", "\8194")
, ("emsp", "\8195")
, ("thinsp", "\8201")
, ("zwnj", "\8204")
, ("zwj", "\8205")
, ("lrm", "\8206")
, ("rlm", "\8207")
, ("ndash", "\8211")
, ("mdash", "\8212")
, ("lsquo", "\8216")
, ("rsquo", "\8217")
, ("sbquo", "\8218")
, ("ldquo", "\8220")
, ("rdquo", "\8221")
, ("bdquo", "\8222")
, ("dagger", "\8224")
, ("Dagger", "\8225")
, ("bull", "\8226")
, ("hellip", "\8230")
, ("permil", "\8240")
, ("prime", "\8242")
, ("Prime", "\8243")
, ("lsaquo", "\8249")
, ("rsaquo", "\8250")
, ("oline", "\8254")
, ("frasl", "\8260")
, ("euro", "\8364")
, ("image", "\8465")
, ("weierp", "\8472")
, ("real", "\8476")
, ("trade", "\8482")
, ("alefsym", "\8501")
, ("larr", "\8592")
, ("uarr", "\8593")
, ("rarr", "\8594")
, ("darr", "\8595")
, ("harr", "\8596")
, ("crarr", "\8629")
, ("lArr", "\8656")
, ("uArr", "\8657")
, ("rArr", "\8658")
, ("dArr", "\8659")
, ("hArr", "\8660")
, ("forall", "\8704")
, ("part", "\8706")
, ("exist", "\8707")
, ("empty", "\8709")
, ("nabla", "\8711")
, ("isin", "\8712")
, ("notin", "\8713")
, ("ni", "\8715")
, ("prod", "\8719")
, ("sum", "\8721")
, ("minus", "\8722")
, ("lowast", "\8727")
, ("radic", "\8730")
, ("prop", "\8733")
, ("infin", "\8734")
, ("ang", "\8736")
, ("and", "\8743")
, ("or", "\8744")
, ("cap", "\8745")
, ("cup", "\8746")
, ("int", "\8747")
, ("there4", "\8756")
, ("sim", "\8764")
, ("cong", "\8773")
, ("asymp", "\8776")
, ("ne", "\8800")
, ("equiv", "\8801")
, ("le", "\8804")
, ("ge", "\8805")
, ("sub", "\8834")
, ("sup", "\8835")
, ("nsub", "\8836")
, ("sube", "\8838")
, ("supe", "\8839")
, ("oplus", "\8853")
, ("otimes", "\8855")
, ("perp", "\8869")
, ("sdot", "\8901")
, ("lceil", "\8968")
, ("rceil", "\8969")
, ("lfloor", "\8970")
, ("rfloor", "\8971")
, ("lang", "\9001")
, ("rang", "\9002")
, ("loz", "\9674")
, ("spades", "\9824")
, ("clubs", "\9827")
, ("hearts", "\9829")
, ("diams", "\9830")
]