~singpolyma/network-protocol-xmpp

f393f02c50d1c6927ae58369f2fa8295c19d71b6 — John Millikin 13 years ago 9ae38ff
Quick-n-dirty conversion to version 0.3 of the GNU SASL bindings.
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +2 -1
@@ 26,6 26,7 @@ import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified System.IO as IO
import Data.ByteString (ByteString)
import qualified Data.Text as T
import qualified Text.XML.LibXML.SAX as SAX



@@ 90,7 91,7 @@ authenticate stream jid sjid username password = do
		A.Failure -> error "Authentication failure"
		_ -> restartStream stream

authenticationMechanisms :: ClientStream -> [T.Text]
authenticationMechanisms :: ClientStream -> [ByteString]
authenticationMechanisms = step . streamFeatures where
	step [] = []
	step (f:fs) = case f of

M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +12 -7
@@ 21,18 21,18 @@ module Network.Protocol.XMPP.Component
	, componentStreamID
	, connectComponent
	) where

import Data.Bits (shiftR, (.&.))
import Data.Char (intToDigit)
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Network (connectTo)
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Data.Digest.Pure.SHA as SHA
import Network.Protocol.SASL.GNU (sha1)
import qualified System.IO as IO
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Text.XML.LibXML.SAX as SAX

import qualified Network.Protocol.XMPP.Internal.Connections as C


@@ 95,7 95,7 @@ parseStreamID _ = Nothing
authenticate :: Component -> T.Text -> IO ()
authenticate stream password = do
	let bytes = buildSecret (componentStreamID stream) password
	let digest = SHA.showDigest $ SHA.sha1 $ BL.fromChunks [bytes]
	let digest = showDigest $ sha1 bytes
	S.putTree stream $ element ("", "handshake") [] [XN.mkText digest]
	result <- S.getTree stream
	let accepted = A.runLA $


@@ 111,3 111,8 @@ buildSecret sid password = bytes where
	escaped = DOM.attrEscapeXml $ sid' ++ password'
	sid' = T.unpack sid
	password' = T.unpack password

showDigest :: B.ByteString -> String
showDigest = concatMap wordToHex . B.unpack where
	wordToHex x = [hexDig $ shiftR x 4, hexDig $ x .&. 0xF]
	hexDig = intToDigit . fromIntegral

M Network/Protocol/XMPP/Internal/Authentication.hs => Network/Protocol/XMPP/Internal/Authentication.hs +38 -37
@@ 17,12 17,15 @@ module Network.Protocol.XMPP.Internal.Authentication
	( Result(..)
	, authenticate
	) where
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE

import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Network.Protocol.SASL.GSASL as G
import qualified Network.Protocol.SASL.GNU as SASL

import Network.Protocol.XMPP.JID (JID, formatJID)
import Network.Protocol.XMPP.Internal.XML (element, qname)


@@ 32,7 35,7 @@ data Result = Success | Failure
	deriving (Show, Eq)

authenticate :: S.Stream stream => stream
             -> [T.Text] -- ^ Mechanisms
             -> [B.ByteString] -- ^ Mechanisms
             -> JID -- ^ User JID
             -> JID -- ^ Server JID
             -> T.Text -- ^ Username


@@ 41,51 44,49 @@ authenticate :: S.Stream stream => stream
authenticate stream mechanisms userJID serverJID username password = do
	let authz = formatJID userJID
	let hostname = formatJID serverJID
	let utf8 = TE.encodeUtf8
	
	G.withContext $ \ctxt -> do
	
	suggested <- G.clientSuggestMechanism ctxt (map T.unpack mechanisms)
	mechanism <- case suggested of
		Just m -> return m
		Nothing -> error "No supported SASL mechanisms advertised"
	
	G.withSession (G.clientStart ctxt mechanism) $ \s -> do
	
	G.propertySet s G.GSASL_AUTHZID $ T.unpack authz
	G.propertySet s G.GSASL_AUTHID $ T.unpack username
	G.propertySet s G.GSASL_PASSWORD $ T.unpack password
	G.propertySet s G.GSASL_SERVICE "xmpp"
	G.propertySet s G.GSASL_HOSTNAME $ T.unpack hostname
	
	(b64text, rc) <- G.step64 s ""
	S.putTree stream $ element ("", "auth")
		[ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")
		 ,("", "mechanism", mechanism)]
		[XN.mkText b64text]
	
	case rc of
		G.GSASL_OK -> saslFinish stream
		G.GSASL_NEEDS_MORE -> saslLoop stream s
		_ -> error "Unknown GNU SASL response"
	SASL.runSASL $ do
		suggested <- SASL.clientSuggestMechanism $ map SASL.Mechanism mechanisms
		mechanism <- case suggested of
			Just m -> return m
			Nothing -> error "No supported SASL mechanisms advertised"
		let (SASL.Mechanism mechBytes) = mechanism
		SASL.runClient mechanism $ do
			SASL.setProperty SASL.PropertyAuthzID $ utf8 authz
			SASL.setProperty SASL.PropertyAuthID $ utf8 username
			SASL.setProperty SASL.PropertyPassword $ utf8 password
			SASL.setProperty SASL.PropertyService $ B.pack "xmpp"
			SASL.setProperty SASL.PropertyHostname $ utf8 hostname
			
			(b64text, rc) <- SASL.step64 $ B.pack ""
			liftIO $ S.putTree stream $ element ("", "auth")
				[ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")
				, ("", "mechanism", B.unpack mechBytes)]
				[XN.mkText $ B.unpack b64text]
			
			case rc of
				SASL.Complete -> liftIO $ saslFinish stream
				SASL.NeedsMore -> saslLoop stream

saslLoop :: S.Stream s => s -> G.Session -> IO Result
saslLoop stream session = do
	challengeText <- A.runX (
saslLoop :: S.Stream s => s -> SASL.Session Result
saslLoop stream = do
	challengeText <- liftIO $ A.runX (
		A.arrIO (\_ -> S.getTree stream)
		>>> A.getChildren
		>>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "challenge")
		>>> A.getChildren >>> A.getText)
	
	if null challengeText then return Failure
	if null challengeText
		then return Failure
		else do
			(b64text, rc) <- G.step64 session (concat challengeText)
			S.putTree stream $ element ("", "response")
			(b64text, rc) <- SASL.step64 $ B.pack $ concat challengeText
			liftIO $ S.putTree stream $ element ("", "response")
				[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")]
				[XN.mkText b64text]
				[XN.mkText $ B.unpack b64text]
			case rc of
				G.GSASL_OK -> saslFinish stream
				G.GSASL_NEEDS_MORE -> saslLoop stream session
				_ -> error "Unknown GNU SASL response"
				SASL.Complete -> liftIO $ saslFinish stream
				SASL.NeedsMore -> saslLoop stream

saslFinish :: S.Stream s => s -> IO Result
saslFinish stream = do

M Network/Protocol/XMPP/Internal/Features.hs => Network/Protocol/XMPP/Internal/Features.hs +8 -9
@@ 18,7 18,7 @@ module Network.Protocol.XMPP.Internal.Features
	, parseFeatures
	, parseFeature
	) where
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as B
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM


@@ 27,7 27,7 @@ import Network.Protocol.XMPP.Internal.XML (qname)

data Feature =
	  FeatureStartTLS Bool
	| FeatureSASL [T.Text]
	| FeatureSASL [B.ByteString]
	| FeatureRegister
	| FeatureBind
	| FeatureSession


@@ 56,13 56,12 @@ parseFeatureTLS :: DOM.XmlTree -> Feature
parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required

parseFeatureSASL :: DOM.XmlTree -> Feature
parseFeatureSASL t = FeatureSASL $ map T.toUpper mechanisms where
	mechanisms = A.runLA (
		A.getChildren
		>>> A.hasQName qnameMechanism
		>>> A.getChildren
		>>> A.getText
		>>> A.arr T.pack) t
parseFeatureSASL t = FeatureSASL $ A.runLA (
	A.getChildren
	>>> A.hasQName qnameMechanism
	>>> A.getChildren
	>>> A.getText
	>>> A.arr B.pack) t

qnameMechanism :: DOM.QName
qnameMechanism = qname "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism"

M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +2 -2
@@ 28,9 28,9 @@ library
    , hsgnutls >= 0.2 && < 0.3
    , bytestring >= 0.9 && < 1.0
    , libxml-sax >= 0.3 && < 0.4
    , gsasl >= 0.2 && < 0.3
    , gsasl >= 0.3 && < 0.4
    , network >= 2.2 && < 2.3
    , SHA >= 1.4 && < 1.5
    , transformers >= 0.2 && < 0.3

  exposed-modules:
    Network.Protocol.XMPP