~singpolyma/network-protocol-xmpp

400c78ab723552f7eef134481413b841f4a221c5 — John Millikin 13 years ago 8e2d91e
Re-open the stream after authentication.
2 files changed, 15 insertions(+), 18 deletions(-)

M Network/Protocol/XMPP/Client.hs
M Network/Protocol/XMPP/Stream.hs
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +11 -7
@@ 22,7 22,7 @@ module Network.Protocol.XMPP.Client (
	,clientSend
	) where

import System.IO (Handle)
import System.IO (hSetBuffering, BufferMode(NoBuffering), Handle)
import Codec.Binary.Base64.String (encode)
import Network (HostName, PortID, connectTo)
import Text.XML.HXT.Arrow ((>>>))


@@ 35,9 35,9 @@ 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 S.Stream
data ConnectedClient = ConnectedClient JID S.Stream Handle

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

type Username = String
type Password = String


@@ 45,14 45,16 @@ type Password = String
clientConnect :: JID -> HostName -> PortID -> IO ConnectedClient
clientConnect jid host port = do
	handle <- connectTo host port
	stream <- S.beginStream jid host handle
	hSetBuffering handle NoBuffering
	
	stream <- S.beginStream jid handle
	
	-- TODO: TLS support
	
	return $ ConnectedClient jid stream
	return $ ConnectedClient jid stream handle

clientAuthenticate :: ConnectedClient -> JID -> Username -> Password -> IO AuthenticatedClient
clientAuthenticate (ConnectedClient _ stream) jid username password = let
clientAuthenticate (ConnectedClient serverJID stream h) jid username password = let
	mechanisms = (advertisedMechanisms . S.streamFeatures) stream
	saslMechanism = case bestMechanism mechanisms of
		Nothing -> error "No supported SASL mechanism"


@@ 79,7 81,9 @@ clientAuthenticate (ConnectedClient _ stream) jid username password = let
		
		-- TODO: check if response is success or failure
		
		return $ AuthenticatedClient jid stream
		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

M Network/Protocol/XMPP/Stream.hs => Network/Protocol/XMPP/Stream.hs +4 -11
@@ 16,8 16,7 @@

module Network.Protocol.XMPP.Stream (
	 Stream (
	 	 streamHostName
	 	,streamLanguage
	 	 streamLanguage
	 	,streamVersion
	 	,streamFeatures
	 	)


@@ 32,7 31,6 @@ module Network.Protocol.XMPP.Stream (
	) where

import qualified System.IO as IO
import Network (HostName, PortID, connectTo)
import qualified Network.Protocol.XMPP.IncrementalXML as XML
import Data.AssocList (lookupDef)
import qualified Text.XML.HXT.DOM.QualifiedName as QN


@@ 46,7 44,6 @@ 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)

maxXMPPVersion = XMPPVersion 1 0


@@ 55,7 52,6 @@ data Stream = Stream
	{
		 streamHandle :: IO.Handle
		,streamParser :: XML.Parser
		,streamHostName :: HostName
		,streamLanguage :: XMLLanguage
		,streamVersion :: XMPPVersion
		,streamFeatures :: [StreamFeature]


@@ 77,12 73,10 @@ data XMPPVersion = XMPPVersion Int Int

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

beginStream :: JID -> HostName -> IO.Handle -> IO Stream
beginStream jid host handle = do
beginStream :: JID -> IO.Handle -> IO Stream
beginStream jid handle = do
	parser <- XML.newParser
	
	IO.hSetBuffering handle IO.NoBuffering
	
	-- Since only the opening tag should be written, normal XML
	-- serialization cannot be used. Be careful to escape any embedded
	-- attributes.


@@ 105,7 99,6 @@ beginStream jid host handle = do

beginStream' handle parser streamStart featureTree = let
	-- TODO: parse from streamStart
	host = "localhost"
	language = XMLLanguage "en"
	version = XMPPVersion 1 0
	


@@ 118,7 111,7 @@ beginStream' handle parser streamStart featureTree = let
		[] -> []
		(t:_) -> map parseFeature (A.runLA A.getChildren t)
	
	in Stream handle parser host language version features
	in Stream handle parser language version features

parseFeature :: XmlTree -> StreamFeature
parseFeature t = lookupDef FeatureUnknown qname [