module Text.XML.Stream.Parse
(
parseBytes
, parseText
, detectUtf
, parseFile
, parseFile_
, parseLBS
, parseLBS_
, ParseSettings
, def
, DecodeEntities
, psDecodeEntities
, tag
, tagPredicate
, tagName
, tagNoAttr
, content
, contentMaybe
, AttrParser
, requireAttr
, optionalAttr
, requireAttrRaw
, optionalAttrRaw
, ignoreAttrs
, orE
, choose
, many
, force
, XmlException (..)
) where
import Data.Attoparsec.Text
( char, Parser, takeWhile1, skipWhile, string
, manyTill, takeWhile, try, anyChar, endOfInput
)
import qualified Data.Attoparsec.Text as A
import Data.Attoparsec.Text.Enumerator (iterParser)
import Data.XML.Types
( Name (..), Event (..), Content (..)
, Instruction (..), ExternalID (..)
)
import Control.Applicative (Applicative(..), Alternative(empty,(<|>)), (<$>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Read (Reader, decimal, hexadecimal)
import Data.Text.Encoding (decodeUtf32BEWith)
import Data.Text.Encoding.Error (ignore)
import Data.Word (Word32)
import Blaze.ByteString.Builder (fromWord32be, toByteString)
import Text.XML.Stream.Token
import Prelude hiding (takeWhile)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import Data.Enumerator
( Iteratee, Enumeratee, (>>==), Stream (..), run_, Enumerator, Step (..)
, checkDone, yield, ($$), joinI, run, throwError, returnI, continue
)
import Control.Monad (when)
import qualified Data.Enumerator as E
import qualified Data.Enumerator.List as EL
import qualified Data.Enumerator.Text as ET
import qualified Data.Enumerator.Binary as EB
import Control.Monad (unless, ap, liftM)
import qualified Data.Text as TS
import Data.List (foldl')
import Data.Typeable (Typeable)
import Control.Exception (Exception, throwIO, SomeException)
import Data.Enumerator.Binary (enumFile)
import Control.Monad.IO.Class (liftIO)
import Data.Char (isSpace)
import Data.Default (Default (..))
tokenToEvent :: [NSLevel] -> Token -> ([NSLevel], [Event])
tokenToEvent n (TokenBeginDocument _) = (n, [])
tokenToEvent n (TokenInstruction i) = (n, [EventInstruction i])
tokenToEvent n (TokenBeginElement name as isClosed _) =
(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) a@(TName kpref kname, val)
| kpref == Just "xmlns" =
(front, l { prefixes = Map.insert kname (contentsToText val)
$ prefixes l })
| kpref == Nothing && kname == "xmlns" =
(front, l { defaultNS = if T.null $ contentsToText val
then Nothing
else Just $ contentsToText val })
| otherwise = (front . (:) a, l)
n' = if isClosed then n else l' : n
fixAttName level (name', val) = (tnameToName True level name', val)
begin = EventBeginElement (tnameToName False l' name)
$ map (fixAttName l')
$ as' []
end = EventEndElement $ tnameToName False l' name
tokenToEvent n (TokenEndElement name) =
(n', [EventEndElement $ tnameToName False l name])
where
(l, n') =
case n of
[] -> (NSLevel Nothing Map.empty, [])
x:xs -> (x, xs)
tokenToEvent n (TokenContent c) = (n, [EventContent c])
tokenToEvent n (TokenComment c) = (n, [EventComment c])
tokenToEvent n (TokenDoctype t eid) = (n, [EventBeginDoctype t eid, EventEndDoctype])
tokenToEvent n (TokenCDATA t) = (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 :: Monad m => Enumeratee S.ByteString TS.Text m a
detectUtf step = do
x <- EB.take 4
let (toDrop, codec) =
case L.unpack x of
[0x00, 0x00, 0xFE, 0xFF] -> (4, ET.utf32_be)
[0xFF, 0xFE, 0x00, 0x00] -> (4, ET.utf32_le)
0xFE : 0xFF: _ -> (2, ET.utf16_be)
0xFF : 0xFE: _ -> (2, ET.utf16_le)
0xEF : 0xBB: 0xBF : _ -> (3, ET.utf8)
[0x00, 0x00, 0x00, 0x3C] -> (0, ET.utf32_be)
[0x3C, 0x00, 0x00, 0x00] -> (0, ET.utf32_le)
[0x00, 0x3C, 0x00, 0x3F] -> (0, ET.utf16_be)
[0x3C, 0x00, 0x3F, 0x00] -> (0, ET.utf16_le)
_ -> (0, ET.utf8)
unless (toDrop == 4) $ yield () $ Chunks $ L.toChunks $ L.drop toDrop x
ET.decode codec step
parseBytes :: Monad m => ParseSettings -> Enumeratee S.ByteString Event m a
parseBytes de step = joinI $ detectUtf $$ parseText de step
parseText :: Monad m => ParseSettings -> Enumeratee TS.Text Event m a
parseText de step = do
c <- peek
when (c == Just '\xfeef') $ ET.head >> return ()
(checkDone $ \k -> k (Chunks [EventBeginDocument]) >>== loop []) step
where
loop levels = checkDone $ go levels
go levels k = do
mtoken <- iterToken de
case mtoken of
Nothing -> k (Chunks [EventEndDocument]) >>== return
Just token ->
let (levels', events) = tokenToEvent levels token
in k (Chunks events) >>== loop levels'
peek :: Monad m => Iteratee TS.Text m (Maybe Char)
peek = continue loop where
loop (Chunks xs) = case TL.uncons (TL.fromChunks xs) of
Just (c, _) -> yield (Just c) $ Chunks xs
Nothing -> peek
loop EOF = yield Nothing EOF
data ParseSettings = ParseSettings
{ psDecodeEntities :: DecodeEntities
}
instance Default ParseSettings where
def = ParseSettings
{ psDecodeEntities = decodeEntities
}
iterToken :: Monad m => ParseSettings -> Iteratee TS.Text m (Maybe Token)
iterToken de = iterParser ((endOfInput >> return Nothing) <|> fmap Just (parseToken $ psDecodeEntities de))
parseToken :: DecodeEntities -> Parser Token
parseToken de = (char '<' >> parseLt) <|> TokenContent <$> parseContent de False False
where
parseLt =
(char '?' >> parseInstr) <|>
(char '!' >> (parseComment <|> parseCdata <|> parseDoctype)) <|>
(char '/' >> parseEnd) <|>
parseBegin
parseInstr = do
name <- parseIdent
if name == "xml"
then do
as <- A.many $ parseAttribute de
skipSpace
char' '?'
char' '>'
newline <|> return ()
return $ TokenBeginDocument 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
i <- parseIdent
skipSpace
eid <- fmap Just parsePublicID <|>
fmap Just parseSystemID <|>
return Nothing
skipSpace
(do
char' '['
skipWhile (/= ']')
char' ']'
skipSpace) <|> return ()
char' '>'
newline <|> return ()
return $ TokenDoctype i eid
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 de
skipSpace
isClose <- (char '/' >> skipSpace >> return True) <|> return False
char' '>'
return $ TokenBeginElement n as isClose 0
parseAttribute :: DecodeEntities -> Parser TAttribute
parseAttribute de = do
skipSpace
key <- parseName
skipSpace
char' '='
skipSpace
val <- squoted <|> dquoted
return (key, val)
where
squoted = do
char' '\''
manyTill (parseContent de False True) (char '\'')
dquoted = do
char' '"'
manyTill (parseContent de True False) (char '"')
parseName :: Parser TName
parseName = do
i1 <- parseIdent
mi2 <- (char ':' >> fmap Just parseIdent) <|> return Nothing
return $
case mi2 of
Nothing -> TName Nothing 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 c = not $ isSpace c
parseContent :: DecodeEntities
-> Bool
-> Bool
-> Parser Content
parseContent de breakDouble breakSingle =
parseEntity <|> parseText'
where
parseEntity = do
char' '&'
t <- takeWhile1 (/= ';')
char' ';'
return $ de t
parseText' = do
bs <- takeWhile1 valid
return $ ContentText bs
valid '"' = not breakDouble
valid '\'' = not breakSingle
valid '&' = False
valid '<' = False
valid _ = True
skipSpace :: Parser ()
skipSpace = skipWhile isSpace
newline :: Parser ()
newline = ((char '\r' >> char '\n') <|> char '\n') >> return ()
char' :: Char -> Parser ()
char' c = char c >> return ()
data ContentType =
Ignore | IsContent Text | IsError String | NotContent
contentMaybe :: Monad m => Iteratee Event m (Maybe Text)
contentMaybe = do
x <- E.peek
case pc' x of
Ignore -> EL.drop 1 >> contentMaybe
IsContent t -> EL.drop 1 >> fmap Just (takeContents (t:))
IsError e -> throwError $ XmlException 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 <- E.peek
case pc' x of
Ignore -> EL.drop 1 >> takeContents front
IsContent t -> EL.drop 1 >> takeContents (front . (:) t)
IsError e -> throwError $ XmlException e x
NotContent -> return $ T.concat $ front []
content :: Monad m => Iteratee Event m Text
content = do
x <- contentMaybe
case x of
Nothing -> return T.empty
Just y -> return y
tag :: Monad m
=> (Name -> Maybe a)
-> (a -> AttrParser b)
-> (b -> Iteratee Event m c)
-> Iteratee Event m (Maybe c)
tag checkName attrParser f = do
x <- dropWS
case x of
Just (EventBeginElement name as) ->
case checkName name of
Just y ->
case runAttrParser' (attrParser y) as of
Left e -> throwError e
Right z -> do
EL.drop 1
z' <- f z
a <- dropWS
case a of
Just (EventEndElement name')
| name == name' -> EL.drop 1 >> return (Just z')
_ -> throwError $ XmlException ("Expected end tag for: " ++ show name) a
Nothing -> return Nothing
_ -> return Nothing
where
dropWS = do
x <- E.peek
let isWS =
case x of
Just EventBeginDocument -> True
Just EventEndDocument -> True
Just EventBeginDoctype{} -> True
Just EventEndDoctype -> True
Just EventInstruction{} -> True
Just EventBeginElement{} -> False
Just EventEndElement{} -> False
Just (EventContent (ContentText t))
| T.all isSpace t -> True
| otherwise -> False
Just (EventContent ContentEntity{}) -> False
Just EventComment{} -> True
Just EventCDATA{} -> False
Nothing -> False
if isWS then EL.drop 1 >> dropWS else return x
runAttrParser' p as =
case runAttrParser p as of
Left e -> Left e
Right ([], x) -> Right x
Right (attr, _) -> Left $ UnparsedAttributes attr
tagPredicate :: Monad m => (Name -> Bool) -> AttrParser a -> (a -> Iteratee Event m b) -> Iteratee Event m (Maybe b)
tagPredicate p attrParser = tag (\x -> if p x then Just () else Nothing) (const attrParser)
tagName :: Monad m
=> Name
-> AttrParser a
-> (a -> Iteratee Event m b)
-> Iteratee Event m (Maybe b)
tagName name = tagPredicate (== name)
tagNoAttr :: Monad m => Name -> Iteratee Event m a -> Iteratee Event m (Maybe a)
tagNoAttr name f = tagName name (return ()) $ const f
orE :: Monad m => Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a)
orE a b = do
x <- a
case x of
Nothing -> b
_ -> return x
choose :: Monad m
=> [Iteratee Event m (Maybe a)]
-> Iteratee Event m (Maybe a)
choose [] = return Nothing
choose (i:is) = do
x <- i
case x of
Nothing -> choose is
Just a -> return $ Just a
force :: Monad m
=> String
-> Iteratee Event m (Maybe a)
-> Iteratee Event m a
force msg i = do
x <- i
case x of
Nothing -> throwError $ XmlException msg Nothing
Just a -> return a
parseFile_ :: ParseSettings -> FilePath -> Iteratee Event IO a -> IO a
parseFile_ de fn p =
parseFile de fn p >>= go
where
go (Left e) = liftIO $ throwIO e
go (Right a) = return a
parseFile :: ParseSettings
-> FilePath
-> Iteratee Event IO a
-> IO (Either SomeException a)
parseFile de fn p =
run $ enumFile fn $$ joinI
$ parseBytes de $$ p
parseLBS :: ParseSettings -> L.ByteString -> Iteratee Event IO a -> IO (Either SomeException a)
parseLBS de lbs p =
run $ enumSingle (L.toChunks lbs) $$ joinI
$ parseBytes de $$ p
parseLBS_ :: ParseSettings -> L.ByteString -> Iteratee Event IO a -> IO a
parseLBS_ de lbs p =
run_ $ enumSingle (L.toChunks lbs) $$ joinI
$ parseBytes de $$ p
enumSingle :: Monad m => [a] -> Enumerator a m b
enumSingle as (Continue k) = k $ Chunks as
enumSingle _ step = returnI step
data XmlException = XmlException
{ xmlErrorMessage :: String
, xmlBadInput :: Maybe Event
}
| InvalidEndElement Name
| InvalidEntity Text
| UnparsedAttributes [(Name, [Content])]
deriving (Show, Typeable)
instance Exception XmlException
newtype AttrParser a = AttrParser { runAttrParser :: [(Name, [Content])] -> Either XmlException ([(Name, [Content])], a) }
instance Monad AttrParser where
return a = AttrParser $ \as -> Right (as, a)
(AttrParser f) >>= g = AttrParser $ \as ->
case f as of
Left e -> Left e
Right (as', f') -> runAttrParser (g f') as'
instance Functor AttrParser where
fmap = liftM
instance Applicative AttrParser where
pure = return
(<*>) = ap
instance Alternative AttrParser where
empty = AttrParser $ const $ Left $ XmlException "AttrParser.empty" Nothing
AttrParser f <|> AttrParser g = AttrParser $ \x ->
case f x of
Left _ -> g x
res -> res
optionalAttrRaw :: ((Name, [Content]) -> Maybe b) -> AttrParser (Maybe b)
optionalAttrRaw f =
AttrParser $ go id
where
go front [] = Right (front [], Nothing)
go front (a:as) =
case f a of
Nothing -> go (front . (:) a) as
Just b -> Right (front as, Just b)
requireAttrRaw :: String -> ((Name, [Content]) -> Maybe b) -> AttrParser b
requireAttrRaw msg f = do
x <- optionalAttrRaw f
case x of
Just b -> return b
Nothing -> AttrParser $ const $ Left $ XmlException msg Nothing
requireAttr :: Name -> AttrParser Text
requireAttr n = requireAttrRaw
("Missing attribute: " ++ show n)
(\(x, y) -> if x == n then Just (contentsToText y) else Nothing)
optionalAttr :: Name -> AttrParser (Maybe Text)
optionalAttr n = optionalAttrRaw
(\(x, y) -> if x == n then Just (contentsToText y) else Nothing)
contentsToText :: [Content] -> Text
contentsToText =
T.concat . map toText
where
toText (ContentText t) = t
toText (ContentEntity e) = T.concat ["&", e, ";"]
ignoreAttrs :: AttrParser ()
ignoreAttrs = AttrParser $ \_ -> Right ([], ())
many :: Monad m => Iteratee Event m (Maybe a) -> Iteratee Event m [a]
many i =
go id
where
go front = do
x <- i
case x of
Nothing -> return $ front []
Just y -> go $ front . (:) y
type DecodeEntities = Text -> Content
decodeEntities :: DecodeEntities
decodeEntities "lt" = ContentText "<"
decodeEntities "gt" = ContentText ">"
decodeEntities "amp" = ContentText "&"
decodeEntities "quot" = ContentText "\""
decodeEntities "apos" = ContentText "'"
decodeEntities t = let backup = ContentEntity t in
case T.uncons t of
Just ('#', t') ->
case T.uncons t' of
Just ('x', t'')
| T.length t'' > 6 -> backup
| otherwise -> decodeChar hexadecimal backup t''
_
| T.length t' > 7 -> backup
| otherwise -> decodeChar decimal backup t'
_ -> backup
decodeChar :: Reader Word32 -> Content -> Text -> Content
decodeChar readNum backup = either (const backup) toContent . readNum
where
toContent (num, extra) | T.null extra =
case decodeUtf32BEWith ignore . toByteString $ fromWord32be num of
c | T.length c == 1 -> ContentText c
| otherwise -> backup
toContent _ = backup