5 files changed, 43 insertions(+), 19 deletions(-)

M Network/Protocol/XMPP/Client.hs
M Network/Protocol/XMPP/Client/Authentication.hs
M Network/Protocol/XMPP/Client/Features.hs
M Network/Protocol/XMPP/Component.hs
M Network/Protocol/XMPP/XML.hs

@@ 18,6 18,7 @@ module Network.Protocol.XMPP.Client
 	( runClient
 	, bindJID
 	) where
+import Control.Monad ((>=>))
 import Control.Monad.Error (throwError)
 import Control.Monad.Trans (liftIO)
 import Data.ByteString (ByteString)


@@ 91,11 92,12 @@ bindJID jid = do
 	-- Bind
 	M.putStanza . bindStanza . J.jidResource $ jid
 	bindResult <- M.getStanza
-	let getJID e =
-		X.elementChildren e
-		>>= X.isNamed (X.Name "jid" (Just "urn:ietf:params:xml:ns:xmpp-bind") Nothing)
-		>>= X.elementNodes
-		>>= X.isText
+	let getJID =
+		X.elementChildren
+		>=> X.isNamed (X.Name "jid" (Just "urn:ietf:params:xml:ns:xmpp-bind") Nothing)
+		>=> X.elementNodes
+		>=> X.isContent
+		>=> return . X.contentText
 	
 	let maybeJID = do
 		iq <- case bindResult of


@@ 125,7 127,8 @@ bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where
 	payload = X.nselement "urn:ietf:params:xml:ns:xmpp-bind" "bind" [] requested
 	requested = case fmap J.strResource resource of
 		Nothing -> []
-		Just x -> [X.NodeElement $ X.element "resource" [] [X.NodeText x]]
+		Just x -> [X.NodeElement $ X.element "resource" []
+			[X.NodeContent $ X.ContentText x]]
 
 sessionStanza :: IQ
 sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where

@@ 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.NodeText $ TL.pack $ B.unpack b64text]
+				[X.NodeContent $ X.ContentText $ TL.pack $ B.unpack b64text]
 			
 			case rc of
 				SASL.Complete -> saslFinish ctx


@@ 93,12 93,17 @@ saslLoop :: M.Session -> SASL.Session Result
 saslLoop ctx = do
 	elemt <- getElement ctx
 	let name = X.Name "challenge" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing
-	let challengeText = X.isNamed name >=> X.elementNodes >=> X.isText $ elemt
+	let getChallengeText =
+		X.isNamed name
+		>=> X.elementNodes
+		>=> X.isContent
+		>=> return . X.contentText
+	let challengeText = getChallengeText elemt
 	when (null challengeText) $ saslError "Received empty challenge"
 	
 	(b64text, rc) <- SASL.step64 . B.pack . concatMap TL.unpack $ challengeText
 	putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "response"
-		[] [X.NodeText $ TL.pack $ B.unpack b64text]
+		[] [X.NodeContent $ X.ContentText $ TL.pack $ B.unpack b64text]
 	case rc of
 		SASL.Complete -> saslFinish ctx
 		SASL.NeedsMore -> saslLoop ctx

@@ 58,8 58,8 @@ parseFeatureSASL e = FeatureSASL $
 	X.elementChildren e
 	>>= X.isNamed nameMechanism
 	>>= X.elementNodes
-	>>= X.isText
-	>>= return . B.pack . TL.unpack
+	>>= X.isContent
+	>>= return . B.pack . TL.unpack . X.contentText
 
 nameMechanism :: X.Name
 nameMechanism = X.Name "mechanism" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing

@@ 62,7 62,7 @@ beginStream jid = do
 parseStreamID :: SAX.Event -> Maybe T.Text
 parseStreamID (SAX.BeginElement _ attrs) = sid where
 	sid = case idAttrs of
-		(x:_) -> Just . X.attributeValue $ x
+		(x:_) -> Just . X.attributeText $ x
 		_ -> Nothing
 	idAttrs = filter (matchingName . X.attributeName) attrs
 	matchingName = (== X.Name "jid" (Just "jabber:component:accept") Nothing)


@@ 72,7 72,7 @@ authenticate :: T.Text -> T.Text -> M.XMPP ()
 authenticate streamID password = do
 	let bytes = buildSecret streamID password
 	let digest = showDigest $ sha1 bytes
-	M.putElement $ X.element "handshake" [] [X.NodeText digest]
+	M.putElement $ X.element "handshake" [] [X.NodeContent $ X.ContentText digest]
 	result <- M.getElement
 	let nameHandshake = X.Name "handshake" (Just "jabber:component:accept") Nothing
 	when (null (X.isNamed nameHandshake result)) $

@@ 25,6 25,8 @@ module Network.Protocol.XMPP.XML
 	
 	-- * Misc
 	, getattr
+	, contentText
+	, attributeText
 	, escape
 	, serialiseElement
 	, readEvents


@@ 37,7 39,14 @@ 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 $ attributeValue attr
+	attr:_ -> Just $ attributeText attr
+
+contentText :: Content -> T.Text
+contentText (ContentText t) = t
+contentText (ContentEntity e) = T.concat ["&", e, ";"]
+
+attributeText :: Attribute -> T.Text
+attributeText = T.concat . map contentText . attributeContent
 
 name :: T.Text -> Name
 name t = Name t Nothing Nothing


@@ 55,13 64,20 @@ escape = T.concatMap escapeChar where
 		'\'' -> "'"
 		_ -> T.singleton c
 
+escapeContent :: Content -> T.Text
+escapeContent (ContentText t) = escape t
+escapeContent (ContentEntity e) = T.concat ["&", escape e, ";"]
+
 element :: T.Text -> [(T.Text, T.Text)] -> [Node] -> Element
 element elemName attrs children = Element (name elemName) attrs' children where
-	attrs' = [Attribute (name n) value | (n, value) <- attrs]
+	attrs' = map (uncurry mkattr) attrs
 
 nselement :: T.Text -> T.Text -> [(T.Text, T.Text)] -> [Node] -> Element
 nselement ns ln attrs children = Element (nsname ns ln) attrs' children where
-	attrs' = [Attribute (name n) value | (n, value) <- attrs]
+	attrs' = map (uncurry mkattr) attrs
+
+mkattr :: T.Text -> T.Text -> Attribute
+mkattr n val = Attribute (name n) [ContentText val]
 
 -- A somewhat primitive serialisation function
 --


@@ 72,14 88,14 @@ serialiseElement e = text where
 	eName = formatName $ elementName e
 	formatName = escape . nameLocalName
 	attrs = T.intercalate " " $ map attr $ elementAttributes e ++ nsattr
-	attr (Attribute n v) = T.concat [formatName n, "=\"", escape v, "\""]
+	attr (Attribute n c) = T.concat $ [formatName n, "=\""] ++ map escapeContent c ++ ["\""]
 	nsattr = case nameNamespace $ elementName e of
 		Nothing -> []
-		Just ns -> [Attribute (name "xmlns") ns]
+		Just ns -> [mkattr "xmlns" ns]
 	contents = T.concat $ map serialiseNode $ elementNodes e
 	
 	serialiseNode (NodeElement e') = serialiseElement e'
-	serialiseNode (NodeText t) = escape t
+	serialiseNode (NodeContent c) = escape (contentText c)
 	serialiseNode (NodeComment _) = ""
 	serialiseNode (NodeInstruction _) = ""