~singpolyma/network-protocol-xmpp

1445ab423a7707cb628416c1f0bf2d203f4ec3b5 — John Millikin 13 years ago 83cb1cf
Cleaned up clientBind a bit, and allow put/getTree operations on authenticated clients.
3 files changed, 53 insertions(+), 57 deletions(-)

M Network/Protocol/XMPP.hs
M Network/Protocol/XMPP/Client.hs
D Network/Protocol/XMPP/Stanzas.hs
M Network/Protocol/XMPP.hs => Network/Protocol/XMPP.hs +0 -4
@@ 17,11 17,7 @@
module Network.Protocol.XMPP (
	 module Network.Protocol.XMPP.JID
	,module Network.Protocol.XMPP.Client
	,module Network.Protocol.XMPP.Stream
	,module Network.Protocol.XMPP.Stanzas
	) where

import Network.Protocol.XMPP.JID
import Network.Protocol.XMPP.Client
import Network.Protocol.XMPP.Stream
import Network.Protocol.XMPP.Stanzas

M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +53 -14
@@ 19,7 19,9 @@ module Network.Protocol.XMPP.Client (
	,AuthenticatedClient
	,clientConnect
	,clientAuthenticate
	,clientSend
	,clientBind
	,putTree
	,getTree
	) where

import System.IO (hSetBuffering, BufferMode(NoBuffering), Handle)


@@ 27,6 29,7 @@ import Codec.Binary.Base64.String (encode)
import Network (HostName, PortID, connectTo)
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import Text.XML.HXT.DOM.TypeDefs (XmlTree)
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Text.XML.HXT.DOM.QualifiedName as QN



@@ 60,33 63,49 @@ clientAuthenticate (ConnectedClient serverJID stream h) jid username password = 
		Nothing -> error "No supported SASL mechanism"
		Just m -> m
	in do
		putStrLn $ "mechanism = " ++ (show saslMechanism)
		
		-- TODO: use detected mechanism
		
		let saslText = concat [(show jid), "\x00", username, "\x00", password]
		let b64Text = encode saslText
		
		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"]
			]
		S.putTree stream $ mkElement ("", "auth")
			[ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")
			 ,("", "mechanism", "PLAIN")]
			[XN.mkText b64Text]
		
		response <- S.getTree stream
		putStrLn $ "response:"
		A.runX (A.constA response >>> A.putXmlTree "-")
		
		-- TODO: check if response is success or failure
		
		newStream <- S.beginStream serverJID h
		putStrLn $ "features = " ++ (show . S.streamFeatures) newStream
		return $ AuthenticatedClient serverJID jid newStream h

clientSend :: (Stanza s) => AuthenticatedClient -> s -> IO ()
clientSend = undefined
clientBind :: AuthenticatedClient -> IO ()
clientBind c@(AuthenticatedClient _ _ stream h) = do
	-- Bind
	-- TODO: request specific resource
	-- TODO: set ID to random value, and check bind result for JID
	-- TODO: return JID from server
	putTree c $ mkElement ("", "iq")
		[("", "type", "set")]
		[ mkElement ("", "bind")
		  	[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-bind")]
		  	[]]
	
	bindResult <- getTree c
	
	-- Session
	putTree c $ mkElement ("", "iq")
		[("", "type", "set")]
		[mkElement ("", "session")
			[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-session")]
			[]]
	
	sessionResult <- getTree c
	
	putTree c $ mkElement ("", "presence") [] []
	getTree c
	return ()

advertisedMechanisms :: [S.StreamFeature] -> [Mechanism]
advertisedMechanisms [] = []


@@ 94,3 113,23 @@ advertisedMechanisms (f:fs) = case f of
	(S.FeatureSASL ms) -> ms
	otherwise -> advertisedMechanisms fs

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

putTree :: AuthenticatedClient -> XmlTree -> IO ()
putTree (AuthenticatedClient _ _ s _) = S.putTree s

getTree :: AuthenticatedClient -> IO XmlTree
getTree (AuthenticatedClient _ _ s _) = S.getTree s

-- Utility function for building XML trees
mkElement :: (String, String) -> [(String, String, String)] -> [XmlTree] -> XmlTree
mkElement (ns, localpart) attrs children = let
	qname = mkQname ns localpart
	attrs' = [mkAttr ans alp text | (ans, alp, text) <- attrs]
	in XN.mkElement qname attrs' children

mkAttr ns localpart text = XN.mkAttr (mkQname ns localpart) [XN.mkText text]

mkQname ns localpart = case ns of
	"" -> QN.mkName localpart
	otherwise -> QN.mkNsName ns localpart

D Network/Protocol/XMPP/Stanzas.hs => Network/Protocol/XMPP/Stanzas.hs +0 -39
@@ 1,39 0,0 @@
{- 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.Stanzas (
	 Stanza
	) where

import Text.XML.HXT.DOM.TypeDefs (XmlTree)

class Stanza a where
	stanzaXML :: a -> XmlTree

data Message = Message

data Presence = Presence

data IQ = IQ

instance Stanza Message where
	stanzaXML s = undefined

instance Stanza Presence where
	stanzaXML s = undefined

instance Stanza IQ where
	stanzaXML s = undefined