M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +4 -4
@@ 96,7 96,7 @@ bindJID jid = do
bindResult <- M.getStanza
let getJID =
X.elementChildren
- >=> X.isNamed (X.Name "jid" (Just "urn:ietf:params:xml:ns:xmpp-bind") Nothing)
+ >=> X.isNamed "{urn:ietf:params:xml:ns:xmpp-bind}jid"
>=> X.elementNodes
>=> X.isContent
>=> return . X.contentText
@@ 126,7 126,7 @@ bindJID jid = do
bindStanza :: Maybe J.Resource -> IQ
bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where
- payload = X.nselement "urn:ietf:params:xml:ns:xmpp-bind" "bind" [] requested
+ payload = X.element "{urn:ietf:params:xml:ns:xmpp-bind}bind" [] requested
requested = case fmap J.strResource resource of
Nothing -> []
Just x -> [X.NodeElement $ X.element "resource" []
@@ 134,7 134,7 @@ bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where
sessionStanza :: IQ
sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where
- payload = X.nselement "urn:ietf:params:xml:ns:xmpp-session" "session" [] []
+ payload = X.element "{urn:ietf:params:xml:ns:xmpp-session}session" [] []
streamSupportsTLS :: [F.Feature] -> Bool
streamSupportsTLS = any isStartTLS where
@@ 142,7 142,7 @@ streamSupportsTLS = any isStartTLS where
isStartTLS _ = False
xmlStartTLS :: X.Element
-xmlStartTLS = X.nselement "urn:ietf:params:xml:ns:xmpp-tls" "starttls" [] []
+xmlStartTLS = X.element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
void :: Monad m => m a -> m ()
void m = m >> return ()
M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +4 -4
@@ 79,7 79,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
SASL.setProperty SASL.PropertyHostname $ utf8 hostname
(b64text, rc) <- SASL.step64 $ B.pack ""
- putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "auth"
+ putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
[("mechanism", TL.pack $ B.unpack mechBytes)]
[X.NodeContent $ X.ContentText $ T.pack $ B.unpack b64text]
@@ 94,7 94,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
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 name = "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"
let getChallengeText =
X.isNamed name
>=> X.elementNodes
@@ 104,7 104,7 @@ saslLoop ctx = do
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"
+ putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
[] [X.NodeContent $ X.ContentText $ T.pack $ B.unpack b64text]
case rc of
SASL.Complete -> saslFinish ctx
@@ 113,7 113,7 @@ saslLoop ctx = do
saslFinish :: M.Session -> SASL.Session Result
saslFinish ctx = do
elemt <- getElement ctx
- let name = X.Name "success" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing
+ let name = "{urn:ietf:params:xml:ns:xmpp-sasl}success"
let success = X.isNamed name elemt
return $ if null success then Failure else Success
M Network/Protocol/XMPP/Client/Features.hs => Network/Protocol/XMPP/Client/Features.hs +2 -2
@@ 64,7 64,7 @@ parseFeatureSASL e = FeatureSASL $
>>= return . B.pack . TL.unpack . X.contentText
nameMechanism :: X.Name
-nameMechanism = X.Name "mechanism" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing
+nameMechanism = "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism"
nameFeatures :: X.Name
-nameFeatures = X.Name "features" (Just "http://etherx.jabber.org/streams") Nothing
+nameFeatures = "{http://etherx.jabber.org/streams}features"
M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +2 -2
@@ 67,7 67,7 @@ parseStreamID (X.BeginElement _ attrs) = sid where
(x:_) -> Just . X.attributeText $ x
_ -> Nothing
idAttrs = filter (matchingName . X.attributeName) attrs
- matchingName = (== X.Name "jid" (Just "jabber:component:accept") Nothing)
+ matchingName = (== "{jabber:component:accept}jid")
parseStreamID _ = Nothing
authenticate :: T.Text -> T.Text -> M.XMPP ()
@@ 76,7 76,7 @@ authenticate streamID password = do
let digest = showDigest $ sha1 bytes
M.putElement $ X.element "handshake" [] [X.NodeContent $ X.ContentText digest]
result <- M.getElement
- let nameHandshake = X.Name "handshake" (Just "jabber:component:accept") Nothing
+ let nameHandshake = "{jabber:component:accept}handshake"
when (null (X.isNamed nameHandshake result)) $
throwError M.AuthenticationFailure
M Network/Protocol/XMPP/Connections.hs => Network/Protocol/XMPP/Connections.hs +1 -1
@@ 56,4 56,4 @@ startOfStream depth event = case (depth, event) of
_ -> False
qnameStream :: X.Name
-qnameStream = X.Name "stream" (Just "http://etherx.jabber.org/streams") Nothing
+qnameStream = "{http://etherx.jabber.org/streams}stream"
M Network/Protocol/XMPP/Stanza.hs => Network/Protocol/XMPP/Stanza.hs +12 -12
@@ 184,7 184,7 @@ emptyIQ t = IQ
, iqPayload = Nothing
}
-stanzaToElement' :: Stanza a => a -> T.Text -> T.Text -> X.Element
+stanzaToElement' :: Stanza a => a -> X.Name -> T.Text -> X.Element
stanzaToElement' stanza name typeStr = X.element name attrs payloads where
payloads = map X.NodeElement $ stanzaPayloads stanza
attrs = concat
@@ 212,7 212,7 @@ elementToStanza ns elemt = do
parseMessage :: X.Element -> Maybe Message
parseMessage elemt = do
- typeStr <- X.getattr (X.name "type") elemt
+ typeStr <- X.getattr "type" elemt
msgType <- case typeStr of
"normal" -> Just MessageNormal
"chat" -> Just MessageChat
@@ 222,14 222,14 @@ parseMessage elemt = do
_ -> Nothing
msgTo <- xmlJID "to" elemt
msgFrom <- xmlJID "from" elemt
- let msgID = X.getattr (X.name "id") elemt
- let msgLang = X.getattr (X.name "lang") elemt
+ let msgID = X.getattr "id" elemt
+ let msgLang = X.getattr "lang" elemt
let payloads = X.elementChildren elemt
return $ Message msgType msgTo msgFrom msgID msgLang payloads
parsePresence :: X.Element -> Maybe Presence
parsePresence elemt = do
- let typeStr = maybe "" id $ X.getattr (X.name "type") elemt
+ let typeStr = maybe "" id $ X.getattr "type" elemt
pType <- case typeStr of
"" -> Just PresenceAvailable
"unavailable" -> Just PresenceUnavailable
@@ 243,14 243,14 @@ parsePresence elemt = do
msgTo <- xmlJID "to" elemt
msgFrom <- xmlJID "from" elemt
- let msgID = X.getattr (X.name "id") elemt
- let msgLang = X.getattr (X.name "lang") elemt
+ let msgID = X.getattr "id" elemt
+ let msgLang = X.getattr "lang" elemt
let payloads = X.elementChildren elemt
return $ Presence pType msgTo msgFrom msgID msgLang payloads
parseIQ :: X.Element -> Maybe IQ
parseIQ elemt = do
- typeStr <- X.getattr (X.name "type") elemt
+ typeStr <- X.getattr "type" elemt
iqType <- case typeStr of
"get" -> Just IQGet
"set" -> Just IQSet
@@ 260,15 260,15 @@ parseIQ elemt = do
msgTo <- xmlJID "to" elemt
msgFrom <- xmlJID "from" elemt
- let msgID = X.getattr (X.name "id") elemt
- let msgLang = X.getattr (X.name "lang") elemt
+ let msgID = X.getattr "id" elemt
+ let msgLang = X.getattr "lang" elemt
let payload = case X.elementChildren elemt of
[] -> Nothing
child:_ -> Just child
return $ IQ iqType msgTo msgFrom msgID msgLang payload
-xmlJID :: T.Text -> X.Element -> Maybe (Maybe JID)
-xmlJID name elemt = case X.getattr (X.name name) elemt of
+xmlJID :: X.Name -> X.Element -> Maybe (Maybe JID)
+xmlJID name elemt = case X.getattr name elemt of
Nothing -> Just Nothing
Just raw -> case parseJID raw of
Just jid -> Just (Just jid)
M Network/Protocol/XMPP/XML.hs => Network/Protocol/XMPP/XML.hs +4 -17
@@ 29,10 29,7 @@ module Network.Protocol.XMPP.XML
, Network.Protocol.XMPP.XML.attributeText
-- * Constructors
- , name
- , nsname
, element
- , nselement
-- * Misc
, getattr
@@ 65,12 62,6 @@ contentText :: Content -> TL.Text
contentText (ContentText t) = TL.fromStrict t
contentText (ContentEntity e) = TL.concat ["&", TL.fromStrict e, ";"]
-name :: TL.Text -> Name
-name t = Name (TL.toStrict t) Nothing Nothing
-
-nsname :: TL.Text -> TL.Text -> Name
-nsname ns n = Name (TL.toStrict n) (Just (TL.toStrict ns)) Nothing
-
escape :: TL.Text -> TL.Text
escape = TL.concatMap escapeChar where
escapeChar c = case c of
@@ 85,16 76,12 @@ escapeContent :: Content -> TL.Text
escapeContent (ContentText t) = escape (TL.fromStrict t)
escapeContent (ContentEntity e) = TL.concat ["&", escape (TL.fromStrict e), ";"]
-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 :: TL.Text -> TL.Text -> [(TL.Text, TL.Text)] -> [Node] -> Element
-nselement ns ln attrs children = Element (nsname ns ln) attrs' children where
+element :: Name -> [(Name, TL.Text)] -> [Node] -> Element
+element name attrs children = Element name attrs' children where
attrs' = map (uncurry mkattr) attrs
-mkattr :: TL.Text -> TL.Text -> (Name, [Content])
-mkattr n val = (name n, [ContentText (TL.toStrict val)])
+mkattr :: Name -> TL.Text -> (Name, [Content])
+mkattr n val = (n, [ContentText (TL.toStrict val)])
-- A somewhat primitive serialisation function
--