@@ 79,7 79,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
(b64text, rc) <- SASL.step64 $ B.pack ""
putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "auth"
[("mechanism", TL.pack $ B.unpack mechBytes)]
- [X.NodeContent $ X.ContentText $ TL.pack $ B.unpack b64text]
+ [X.NodeContent $ X.ContentText $ T.pack $ B.unpack b64text]
case rc of
SASL.Complete -> saslFinish ctx
@@ 103,7 103,7 @@ saslLoop ctx = do
(b64text, rc) <- SASL.step64 . B.pack . concatMap TL.unpack $ challengeText
putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "response"
- [] [X.NodeContent $ X.ContentText $ TL.pack $ B.unpack b64text]
+ [] [X.NodeContent $ X.ContentText $ T.pack $ B.unpack b64text]
case rc of
SASL.Complete -> saslFinish ctx
SASL.NeedsMore -> saslLoop ctx
@@ 15,7 15,17 @@
{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.XML
- ( module Data.XML.Types
+ ( Element(..)
+ , Node(..)
+ , Content(..)
+ , Name(Name)
+ , Network.Protocol.XMPP.XML.nameNamespace
+ , Network.Protocol.XMPP.XML.nameLocalName
+ , isNamed
+ , elementChildren
+ , isContent
+ , attributeName
+ , Network.Protocol.XMPP.XML.attributeText
-- * Constructors
, name
@@ 26,7 36,6 @@ module Network.Protocol.XMPP.XML
-- * Misc
, getattr
, contentText
- , attributeText
, escape
, serialiseElement
, readEvents
@@ 40,85 49,93 @@ module Network.Protocol.XMPP.XML
) where
import Control.Monad (when)
-import qualified Data.ByteString.Lazy as B
-import qualified Data.Text.Lazy as T
-import Data.XML.Types
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text.Lazy as TL
+import Data.XML.Types as X
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import qualified Text.XML.LibXML.SAX as SAX
-getattr :: Name -> Element -> Maybe T.Text
-getattr n e = case elementAttributes e >>= isNamed n of
- [] -> Nothing
- attr:_ -> Just $ attributeText attr
+getattr :: Name -> Element -> Maybe TL.Text
+getattr n e = fmap TL.fromStrict (X.attributeText n e)
-contentText :: Content -> T.Text
-contentText (ContentText t) = t
-contentText (ContentEntity e) = T.concat ["&", e, ";"]
+contentText :: Content -> TL.Text
+contentText (ContentText t) = TL.fromStrict t
+contentText (ContentEntity e) = TL.concat ["&", TL.fromStrict e, ";"]
-attributeText :: Attribute -> T.Text
-attributeText = T.concat . map contentText . attributeContent
+name :: TL.Text -> Name
+name t = Name (TL.toStrict t) Nothing Nothing
-name :: T.Text -> Name
-name t = Name t Nothing Nothing
+nsname :: TL.Text -> TL.Text -> Name
+nsname ns n = Name (TL.toStrict n) (Just (TL.toStrict ns)) Nothing
-nsname :: T.Text -> T.Text -> Name
-nsname ns n = Name n (Just ns) Nothing
-
-escape :: T.Text -> T.Text
-escape = T.concatMap escapeChar where
+escape :: TL.Text -> TL.Text
+escape = TL.concatMap escapeChar where
escapeChar c = case c of
'&' -> "&"
'<' -> "<"
'>' -> ">"
'"' -> """
'\'' -> "'"
- _ -> T.singleton c
+ _ -> TL.singleton c
-escapeContent :: Content -> T.Text
-escapeContent (ContentText t) = escape t
-escapeContent (ContentEntity e) = T.concat ["&", escape e, ";"]
+escapeContent :: Content -> TL.Text
+escapeContent (ContentText t) = escape (TL.fromStrict t)
+escapeContent (ContentEntity e) = TL.concat ["&", escape (TL.fromStrict e), ";"]
-element :: T.Text -> [(T.Text, T.Text)] -> [Node] -> Element
+element :: TL.Text -> [(TL.Text, TL.Text)] -> [Node] -> Element
element elemName attrs children = Element (name elemName) attrs' children where
attrs' = map (uncurry mkattr) attrs
-nselement :: T.Text -> T.Text -> [(T.Text, T.Text)] -> [Node] -> Element
+nselement :: TL.Text -> TL.Text -> [(TL.Text, TL.Text)] -> [Node] -> Element
nselement ns ln attrs children = Element (nsname ns ln) attrs' children where
attrs' = map (uncurry mkattr) attrs
-mkattr :: T.Text -> T.Text -> Attribute
-mkattr n val = Attribute (name n) [ContentText val]
+mkattr :: TL.Text -> TL.Text -> (Name, [Content])
+mkattr n val = (name n, [ContentText (TL.toStrict val)])
-- A somewhat primitive serialisation function
--
-- TODO: better namespace / prefix handling
-serialiseElement :: Element -> T.Text
+serialiseElement :: Element -> TL.Text
serialiseElement e = text where
- text = T.concat ["<", eName, " ", attrs, ">", contents, "</", eName, ">"]
+ text = TL.concat ["<", eName, " ", attrs, ">", contents, "</", eName, ">"]
eName = formatName $ elementName e
- formatName = escape . nameLocalName
- attrs = T.intercalate " " $ map attr $ elementAttributes e ++ nsattr
- attr (Attribute n c) = T.concat $ [formatName n, "=\""] ++ map escapeContent c ++ ["\""]
- nsattr = case nameNamespace $ elementName e of
+ formatName = escape . TL.fromStrict . X.nameLocalName
+ attrs = TL.intercalate " " $ map attr $ elementAttributes e ++ nsattr
+ attr (n, c) = TL.concat $ [formatName n, "=\""] ++ map escapeContent c ++ ["\""]
+ nsattr = case X.nameNamespace $ elementName e of
Nothing -> []
- Just ns -> [mkattr "xmlns" ns]
- contents = T.concat $ map serialiseNode $ elementNodes e
+ Just ns -> [mkattr "xmlns" (TL.fromStrict ns)]
+ contents = TL.concat $ map serialiseNode $ elementNodes e
serialiseNode (NodeElement e') = serialiseElement e'
serialiseNode (NodeContent c) = escape (contentText c)
serialiseNode (NodeComment _) = ""
serialiseNode (NodeInstruction _) = ""
+-- lazy wrappers around strict xml-types; avoids having to break the API just
+-- to use xml-types 0.3
+nameNamespace :: Name -> Maybe TL.Text
+nameNamespace = fmap TL.fromStrict . X.nameNamespace
+
+nameLocalName :: Name -> TL.Text
+nameLocalName = TL.fromStrict . X.nameLocalName
+
+attributeName :: (Name, [Content]) -> Name
+attributeName = fst
+
+attributeText :: (Name, [Content]) -> TL.Text
+attributeText = TL.concat . map contentText . snd
+
-- quick-and-dirty imitation of libxml-sax-0.4 API; later, this should
-- probably be rewritten to use ST and discard the list parsing
-data Parser = Parser (SAX.Parser IO) (IORef (Either T.Text [SaxEvent]))
+data Parser = Parser (SAX.Parser IO) (IORef (Either TL.Text [SaxEvent]))
newParser :: IO Parser
newParser = do
- let toLazy t = T.fromChunks [t]
-
ref <- newIORef (Right [])
- p <- SAX.newParserIO (\err -> writeIORef ref (Left $ toLazy err)) Nothing
+ p <- SAX.newParserIO Nothing
let addEvent e = do
x <- readIORef ref
@@ 129,16 146,17 @@ newParser = do
SAX.setCallback p SAX.parsedBeginElement (\name' attrs -> addEvent $ BeginElement name' attrs)
SAX.setCallback p SAX.parsedEndElement (\name' -> addEvent $ EndElement name')
- SAX.setCallback p SAX.parsedCharacters (\txt -> addEvent $ Characters $ toLazy txt)
- SAX.setCallback p SAX.parsedComment (\txt -> addEvent $ Comment $ toLazy txt)
+ SAX.setCallback p SAX.parsedCharacters (\txt -> addEvent $ Characters $ TL.fromStrict txt)
+ SAX.setCallback p SAX.parsedComment (\txt -> addEvent $ Comment $ TL.fromStrict txt)
SAX.setCallback p SAX.parsedInstruction (\i -> addEvent $ ProcessingInstruction i)
+ SAX.setCallback p SAX.reportError (\err -> writeIORef ref (Left $ TL.fromStrict err) >> return False)
return $ Parser p ref
-parse :: Parser -> B.ByteString -> Bool -> IO (Either T.Text [SaxEvent])
+parse :: Parser -> BL.ByteString -> Bool -> IO (Either TL.Text [SaxEvent])
parse (Parser p ref) bytes finish = do
writeIORef ref (Right [])
- SAX.parseLazyBytes p bytes
+ SAX.parseBytes p (B.concat (BL.toChunks bytes))
when finish $ SAX.parseComplete p
eitherEvents <- readIORef ref
return $ case eitherEvents of
@@ 146,10 164,10 @@ parse (Parser p ref) bytes finish = do
Right events -> Right $ reverse events
data SaxEvent
- = BeginElement Name [Attribute]
+ = BeginElement Name [(Name, [Content])]
| EndElement Name
- | Characters T.Text
- | Comment T.Text
+ | Characters TL.Text
+ | Comment TL.Text
| ProcessingInstruction Instruction
readEvents :: Monad m
@@ 209,7 227,7 @@ blockToNodes (begin:rest) = nodes where
end = last rest
nodes = case (begin, end) of
(BeginElement name' attrs, EndElement _) -> [node name' attrs]
- (Characters t, _) -> [NodeContent (ContentText t)]
+ (Characters t, _) -> [NodeContent (ContentText (TL.toStrict t))]
_ -> []
node n as = NodeElement $ Element n as $ eventsToNodes $ init rest
@@ 1,5 1,5 @@
name: network-protocol-xmpp
-version: 0.3.3
+version: 0.4
synopsis: Client->Server XMPP
license: GPL-3
license-file: License.txt
@@ 31,8 31,8 @@ library
, network >= 2.2 && < 2.4
, transformers >= 0.2 && < 0.3
, monads-tf >= 0.1 && < 0.2
- , libxml-sax >= 0.6 && < 0.7
- , xml-types >= 0.1 && < 0.2
+ , libxml-sax >= 0.7 && < 0.8
+ , xml-types >= 0.3 && < 0.4
exposed-modules:
Network.Protocol.XMPP