~singpolyma/network-protocol-xmpp

27bee8c435a42fbe5228e4d188665399429d9d16 — John Millikin 13 years ago e677ead
Started work on authentication support.
3 files changed, 141 insertions(+), 29 deletions(-)

M Network/Protocol/XMPP/Client.hs
A Network/Protocol/XMPP/SASL.hs
M Network/Protocol/XMPP/Stream.hs
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +43 -8
@@ 24,13 24,19 @@ module Network.Protocol.XMPP.Client (

import System.IO (Handle)
import Network (HostName, PortID, connectTo)
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Text.XML.HXT.DOM.QualifiedName as QN

import Network.Protocol.XMPP.JID (JID)
import Network.Protocol.XMPP.Stream (beginStream, streamFeatures)
import Network.Protocol.XMPP.SASL (Mechanism, bestMechanism)
import qualified Network.Protocol.XMPP.Stream as S
import Network.Protocol.XMPP.Stanzas (Stanza)

data ConnectedClient = ConnectedClient JID Handle
data ConnectedClient = ConnectedClient JID S.Stream

data AuthenticatedClient = AuthenticatedClient Handle HostName PortID
data AuthenticatedClient = AuthenticatedClient JID S.Stream

type Username = String
type Password = String


@@ 38,13 44,42 @@ type Password = String
clientConnect :: JID -> HostName -> PortID -> IO ConnectedClient
clientConnect jid host port = do
	handle <- connectTo host port
	stream <- beginStream jid host handle
	putStrLn $ "streamFeatures = " ++ (show (streamFeatures stream))
	return $ ConnectedClient jid handle
	stream <- S.beginStream jid host handle
	
	-- TODO: TLS support
	
	return $ ConnectedClient jid stream

clientAuthenticate :: ConnectedClient -> Username -> Password -> AuthenticatedClient
clientAuthenticate = undefined
clientAuthenticate :: ConnectedClient -> Username -> Password -> IO AuthenticatedClient
clientAuthenticate (ConnectedClient jid stream) username password = let
	mechanisms = (advertisedMechanisms . S.streamFeatures) stream
	saslMechanism = case bestMechanism mechanisms of
		Nothing -> error "No supported SASL mechanism"
		Just m -> m
	in do
		putStrLn $ "mechanism = " ++ (show saslMechanism)
		
		-- TODO: use detected mechanism
		S.putTree stream $ XN.mkElement
			(QN.mkName "auth")
			[
				 XN.mkAttr (QN.mkName "xmlns") [XN.mkText "urn:ietf:params:xml:ns:xmpp-sasl"]
				,XN.mkAttr (QN.mkName "mechanism") [XN.mkText "PLAIN"]
			]
			[XN.mkText "="]
		
		response <- S.getTree stream
		putStrLn $ "response:"
		A.runX (A.constA response >>> A.putXmlTree "-")
		
		return $ AuthenticatedClient jid stream

clientSend :: (Stanza s) => AuthenticatedClient -> s -> IO ()
clientSend = undefined

advertisedMechanisms :: [S.StreamFeature] -> [Mechanism]
advertisedMechanisms [] = []
advertisedMechanisms (f:fs) = case f of
	(S.FeatureSASL ms) -> ms
	otherwise -> advertisedMechanisms fs


A Network/Protocol/XMPP/SASL.hs => Network/Protocol/XMPP/SASL.hs +43 -0
@@ 0,0 1,43 @@
{- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
   
   This program is free software: you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation, either version 3 of the License, or
   any later version.
   
   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
   
   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

module Network.Protocol.XMPP.SASL (
	 Mechanism
	,supportedMechanisms
	,bestMechanism
	,findMechanism
	) where

import Data.List (intersect)
import Data.AssocList (lookupDef)

type Username = String
type Password = String

type Mechanism = String

-- TODO: validation
supportedMechanisms :: [Mechanism]
supportedMechanisms = ["PLAIN"] -- TODO: Digest-MD5

bestMechanism :: [Mechanism] -> Maybe Mechanism
bestMechanism ms = let
	in case intersect supportedMechanisms ms of
		[] -> Nothing
		(m:_) -> Just m

findMechanism :: String -> Mechanism
findMechanism s = s -- TODO: validate

M Network/Protocol/XMPP/Stream.hs => Network/Protocol/XMPP/Stream.hs +55 -21
@@ 21,8 21,14 @@ module Network.Protocol.XMPP.Stream (
	 	,streamVersion
	 	,streamFeatures
	 	)
	,StreamFeature (
		 FeatureStartTLS
		,FeatureSASL
		,FeatureRegister
		)
	,beginStream
	,send
	,getTree
	,putTree
	) where

import qualified System.IO as IO


@@ 37,7 43,9 @@ import Text.XML.HXT.DOM.Util (attrEscapeXml)
import Text.XML.HXT.Arrow ((>>>), (>>.))
import Data.Tree.NTree.TypeDefs (NTree(NTree))
import qualified Text.XML.HXT.Arrow as A

import Network.Protocol.XMPP.JID (JID)
import Network.Protocol.XMPP.SASL (Mechanism, findMechanism)
import Network.Protocol.XMPP.Stanzas (Stanza)
import Network.Protocol.XMPP.XMLBuilder (eventsToTree)



@@ 55,7 63,7 @@ data Stream = Stream

data StreamFeature =
	  FeatureStartTLS Bool
	| FeatureSASL [SASLMechanism]
	| FeatureSASL [Mechanism]
	| FeatureRegister
	| FeatureUnknown XmlTree
	| FeatureDebug String


@@ 64,9 72,6 @@ data StreamFeature =
newtype XMLLanguage = XMLLanguage String
	deriving (Show, Eq)

newtype SASLMechanism = SASLMechanism String
	deriving (Show, Eq)

data XMPPVersion = XMPPVersion Int Int
	deriving (Show, Eq)



@@ 87,12 92,15 @@ beginStream jid host handle = do
		" to='" ++ (attrEscapeXml . show) jid ++ "'" ++
		" version='1.0'" ++
		" xmlns:stream='http://etherx.jabber.org/streams'>"
	
	IO.hFlush handle
	
	xmlChars <- hGetChars handle 100
	events <- (XML.incrementalParse parser xmlChars)
	events <- readEventsUntil endOfFeatures handle parser 1000
	return $ beginStream' handle parser events
	where
		featuresName = QN.mkNsName "features" "http://etherx.jabber.org/streams"
		endOfFeatures depth event = case (depth, event) of
			(1, (XML.EndElement featuresName)) -> True
			otherwise -> False

beginStream' handle parser (streamStart:events) = let
	-- TODO: parse from streamStart


@@ 135,22 143,48 @@ parseFeatureSASL t = let
	
	-- TODO: validate mechanism names according to SASL rules
	-- <20 chars, uppercase, alphanum, etc
	in FeatureSASL [SASLMechanism n | n <- rawMechanisms]
	in FeatureSASL (map findMechanism rawMechanisms)

-------------------------------------------------------------------------------

send :: (Stanza s) => Stream -> s -> IO ()
send = undefined
getTree :: Stream -> IO XmlTree
getTree s = do
	events <- readEventsUntil finished (streamHandle s) (streamParser s) 1000
	return $ eventsToTree events
	where
		finished 0 (XML.EndElement _) = True
		finished _ _ = False

putTree :: Stream -> XmlTree -> IO ()
putTree s t = do
	let root = XN.mkRoot [] [t]
	let h = streamHandle s
	[text] <- A.runX (A.constA root >>> A.writeDocumentToString [
		(A.a_no_xml_pi, "1")
		])
	IO.hPutStr h text
	IO.hFlush h

-------------------------------------------------------------------------------

hGetChars :: IO.Handle -> Int -> IO String
hGetChars h timeout = do
	have_input <- IO.hWaitForInput h timeout
	case have_input of
		False -> return []
		True -> do
			chr <- IO.hGetChar h
			next <- hGetChars h timeout
			return $ chr : next

readEventsUntil :: (Int -> XML.Event -> Bool) -> IO.Handle -> XML.Parser -> Int -> IO [XML.Event]
readEventsUntil done h parser timeout = readEventsUntil' done 0 [] $ do
	char <- IO.hGetChar h
	XML.incrementalParse parser [char]

readEventsUntil' done depth accum getEvents = do
	events <- getEvents
	let (done', depth', accum') = readEventsStep done events depth accum
	if done'
		then return accum'
		else readEventsUntil' done depth' accum' getEvents

readEventsStep _ [] depth accum = (False, depth, accum)
readEventsStep done (e:es) depth accum = let
	depth' = depth + case e of
		(XML.BeginElement _ _) -> 1
		(XML.EndElement _) -> (- 1)
		otherwise -> 0
	accum' = accum ++ [e]
	in if done depth' e then (True, depth', accum')
	else readEventsStep done es depth' accum'