{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.XML
( module Data.XML.Types
, element
, contentText
, escape
, serialiseElement
, readEvents
, Parser
, newParser
, parse
, eventsToElement
) where
import Control.Monad (when)
import Data.ByteString (ByteString)
import qualified Data.Text
import Data.Text (Text)
import Data.XML.Types
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import qualified Text.XML.LibXML.SAX as SAX
contentText :: Content -> Text
contentText (ContentText t) = t
contentText (ContentEntity e) = Data.Text.concat ["&", e, ";"]
escape :: Text -> Text
escape = Data.Text.concatMap escapeChar where
escapeChar c = case c of
'&' -> "&"
'<' -> "<"
'>' -> ">"
'"' -> """
'\'' -> "'"
_ -> Data.Text.singleton c
escapeContent :: Content -> Text
escapeContent (ContentText t) = escape t
escapeContent (ContentEntity e) = Data.Text.concat ["&", escape e, ";"]
element :: Name -> [(Name, Text)] -> [Node] -> Element
element name attrs children = Element name attrs' children where
attrs' = map (uncurry mkattr) attrs
mkattr :: Name -> Text -> (Name, [Content])
mkattr n val = (n, [ContentText val])
serialiseElement :: Element -> Text
serialiseElement e = text where
text = Data.Text.concat ["<", eName, " ", attrs, ">", contents, "</", eName, ">"]
eName = formatName (elementName e)
formatName = escape . nameLocalName
attrs = Data.Text.intercalate " " (map attr (elementAttributes e ++ nsattr))
attr (n, c) = Data.Text.concat ([formatName n, "=\""] ++ map escapeContent c ++ ["\""])
nsattr = case nameNamespace $ elementName e of
Nothing -> []
Just ns -> [mkattr "xmlns" ns]
contents = Data.Text.concat (map serialiseNode (elementNodes e))
serialiseNode (NodeElement e') = serialiseElement e'
serialiseNode (NodeContent c) = escape (contentText c)
serialiseNode (NodeComment _) = ""
serialiseNode (NodeInstruction _) = ""
data Parser = Parser (SAX.Parser IO) (IORef (Either Text [Event]))
newParser :: IO Parser
newParser = do
ref <- newIORef (Right [])
p <- SAX.newParserIO Nothing
let addEvent e = do
x <- readIORef ref
case x of
Left _ -> return ()
Right es -> writeIORef ref (Right (e:es))
return True
SAX.setCallback p SAX.parsedBeginElement (\name attrs -> addEvent (EventBeginElement name attrs))
SAX.setCallback p SAX.parsedEndElement (addEvent . EventEndElement)
SAX.setCallback p SAX.parsedCharacters (addEvent . EventContent . ContentText)
SAX.setCallback p SAX.parsedComment (addEvent . EventComment)
SAX.setCallback p SAX.parsedInstruction (addEvent . EventInstruction)
SAX.setCallback p SAX.reportError (\err -> writeIORef ref (Left err) >> return False)
return (Parser p ref)
parse :: Parser -> ByteString -> Bool -> IO (Either Text [Event])
parse (Parser p ref) bytes finish = do
writeIORef ref (Right [])
SAX.parseBytes p bytes
when finish (SAX.parseComplete p)
eitherEvents <- readIORef ref
return $ case eitherEvents of
Left err -> Left err
Right events -> Right (reverse events)
readEvents :: Monad m
=> (Integer -> Event -> Bool)
-> m [Event]
-> m [Event]
readEvents done nextEvents = readEvents' 0 [] where
readEvents' depth acc = do
events <- nextEvents
let (done', depth', acc') = step events depth acc
if done'
then return acc'
else readEvents' depth' acc'
step [] depth acc = (False, depth, acc)
step (e:es) depth acc = let
depth' = depth + case e of
(EventBeginElement _ _) -> 1
(EventEndElement _) -> (- 1)
_ -> 0
acc' = e : acc
in if done depth' e
then (True, depth', reverse acc')
else step es depth' acc'
eventsToElement :: [Event] -> Maybe Element
eventsToElement es = case eventsToNodes es >>= isElement of
(e:_) -> Just e
_ -> Nothing
eventsToNodes :: [Event] -> [Node]
eventsToNodes = concatMap blockToNodes . splitBlocks
splitBlocks :: [Event] -> [[Event]]
splitBlocks es = ret where
(_, _, ret) = foldl splitBlocks' (0, [], []) es
splitBlocks' (depth, accum, allAccum) e = split where
split = if depth' == 0
then (depth', [], allAccum ++ [accum'])
else (depth', accum', allAccum)
accum' = accum ++ [e]
depth' :: Integer
depth' = depth + case e of
(EventBeginElement _ _) -> 1
(EventEndElement _) -> (- 1)
_ -> 0
blockToNodes :: [Event] -> [Node]
blockToNodes [] = []
blockToNodes (begin:rest) = nodes where
end = last rest
nodes = case (begin, end) of
(EventBeginElement name attrs, EventEndElement _) -> [node name attrs]
(EventContent c, _) -> [NodeContent c]
_ -> []
node n as = NodeElement (Element n as (eventsToNodes (init rest)))