M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +9 -6
@@ 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
M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +8 -3
@@ 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
M Network/Protocol/XMPP/Client/Features.hs => Network/Protocol/XMPP/Client/Features.hs +2 -2
@@ 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
M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +2 -2
@@ 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)) $
M Network/Protocol/XMPP/XML.hs => Network/Protocol/XMPP/XML.hs +22 -6
@@ 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 _) = ""