~singpolyma/network-protocol-xmpp

43e263d7b43ec59d9ab4535b419ab623d0a3e4b0 — John Millikin 12 years ago 32f143c
Moved some of the utility functions in 'Network.Protocol.XMPP.XML' into the 'xml-types' package.
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +1 -1
@@ 93,7 93,7 @@ bindJID jid = do
	bindResult <- M.getStanza
	let getJID e =
		X.elementChildren e
		>>= X.named (X.Name "jid" (Just "urn:ietf:params:xml:ns:xmpp-bind") Nothing)
		>>= X.isNamed (X.Name "jid" (Just "urn:ietf:params:xml:ns:xmpp-bind") Nothing)
		>>= X.elementNodes
		>>= X.isText
	

M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +5 -9
@@ 20,7 20,7 @@ module Network.Protocol.XMPP.Client.Authentication
	, authenticate
	) where
import qualified Control.Exception as Exc
import Control.Monad (when)
import Control.Monad (when, (>=>))
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Monad.Error as E
import qualified Data.ByteString.Char8 as B


@@ 92,11 92,8 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
saslLoop :: M.Context -> SASL.Session Result
saslLoop ctx = do
	elemt <- getElement ctx
	let challengeText =
		return elemt
		>>= X.named (X.Name "challenge" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing)
		>>= X.elementNodes
		>>= X.isText
	let name = X.Name "challenge" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing
	let challengeText = X.isNamed name >=> X.elementNodes >=> X.isText $ elemt
	when (null challengeText) $ saslError "Received empty challenge"
	
	(b64text, rc) <- SASL.step64 . B.pack . concatMap TL.unpack $ challengeText


@@ 109,9 106,8 @@ saslLoop ctx = do
saslFinish :: M.Context -> SASL.Session Result
saslFinish ctx = do
	elemt <- getElement ctx
	let success =
		return elemt
		>>= X.named (X.Name "success" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing)
	let name = X.Name "success" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing
	let success = X.isNamed name elemt
	return $ if null success then Failure else Success

putElement :: M.Context -> X.Element -> SASL.Session ()

M Network/Protocol/XMPP/Client/Features.hs => Network/Protocol/XMPP/Client/Features.hs +2 -2
@@ 35,7 35,7 @@ data Feature =

parseFeatures :: X.Element -> [Feature]
parseFeatures e =
	X.named nameFeatures e
	X.isNamed nameFeatures e
	>>= X.elementChildren
	>>= return . parseFeature



@@ 56,7 56,7 @@ parseFeatureTLS _ = FeatureStartTLS True -- TODO: detect whether or not required
parseFeatureSASL :: X.Element -> Feature
parseFeatureSASL e = FeatureSASL $
	X.elementChildren e
	>>= X.named nameMechanism
	>>= X.isNamed nameMechanism
	>>= X.elementNodes
	>>= X.isText
	>>= return . B.pack . TL.unpack

M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +1 -1
@@ 75,7 75,7 @@ authenticate streamID password = do
	M.putElement $ X.element "handshake" [] [X.NodeText digest]
	result <- M.getElement
	let nameHandshake = X.Name "handshake" (Just "jabber:component:accept") Nothing
	when (null (X.named nameHandshake result)) $
	when (null (X.isNamed nameHandshake result)) $
		throwError M.AuthenticationFailure

buildSecret :: T.Text -> T.Text -> B.ByteString

M Network/Protocol/XMPP/XML.hs => Network/Protocol/XMPP/XML.hs +2 -22
@@ 16,12 16,6 @@
{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.XML
	( module Data.XML.Types
	-- * Filters
	, isElement
	, isText
	, elementChildren
	, named
	, getattr
	
	-- * Constructors
	, name


@@ 30,32 24,18 @@ module Network.Protocol.XMPP.XML
	, nselement
	
	-- * Misc
	, getattr
	, escape
	, serialiseElement
	, readEvents
	, SAX.eventsToElement
	) where
import Control.Monad ((>=>))
import qualified Data.Text.Lazy as T
import Data.XML.Types
import qualified Text.XML.LibXML.SAX as SAX

isElement :: Node -> [Element]
isElement (NodeElement e) = [e]
isElement _ = []

isText :: Node -> [T.Text]
isText (NodeText t) = [t]
isText _ = []

elementChildren :: Element -> [Element]
elementChildren = elementNodes >=> isElement

named :: Named a => Name -> a -> [a]
named n x = [x | getName x == n]

getattr :: Name -> Element -> Maybe T.Text
getattr n e = case elementAttributes e >>= named n of
getattr n e = case elementAttributes e >>= isNamed n of
	[] -> Nothing
	attr:_ -> Just $ attributeValue attr