4 files changed, 140 insertions(+), 27 deletions(-)

M Network/Protocol/XMPP.hs
M Network/Protocol/XMPP/Client.hs
A Network/Protocol/XMPP/Component.hs
M Network/Protocol/XMPP/Stream.hs

@@ 17,9 17,11 @@
 module Network.Protocol.XMPP (
 	 module Network.Protocol.XMPP.JID
 	,module Network.Protocol.XMPP.Client
+	,module Network.Protocol.XMPP.Component
 	,module Network.Protocol.XMPP.Stanzas
 	) where
 
 import Network.Protocol.XMPP.JID
 import Network.Protocol.XMPP.Client
+import Network.Protocol.XMPP.Component
 import Network.Protocol.XMPP.Stanzas

@@ 54,7 54,7 @@ type Password = String
 clientConnect :: JID -> HostName -> PortID -> IO ConnectedClient
 clientConnect jid host port = do
 	handle <- connectTo host port
-	stream <- S.beginStream jid handle
+	stream <- S.beginStream jid "jabber:client" handle
 	return $ ConnectedClient jid stream
 
 clientAuthenticate :: ConnectedClient -> JID -> Username -> Password -> IO Client

@@ 0,0 1,80 @@
+{- Copyright (C) 2010 Stephan Maka <stephan@spaceboyz.net>
+   
+   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.Component (
+	 ConnectedComponent
+	,Component
+	,componentConnect
+	,componentAuthenticate
+	,componentJID
+	,putTree
+	,getTree
+	,putStanza
+	) where
+
+import Control.Monad (when)
+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 Data.Digest.Pure.SHA as SHA
+
+import Network.Protocol.XMPP.JID (JID, jidParse, jidResource)
+import qualified Network.Protocol.XMPP.SASL as SASL
+import qualified Network.Protocol.XMPP.Stream as S
+import Network.Protocol.XMPP.Util (mkElement, mkQName)
+import Network.Protocol.XMPP.Stanzas (Stanza, stanzaToTree)
+import Network.Protocol.XMPP.Connection
+import qualified Data.ByteString.Lazy.Char8 as B (pack)
+
+data ConnectedComponent = ConnectedComponent JID S.Stream
+
+data Component = Component {
+	 componentJID :: JID
+	,componentStream :: S.Stream
+	}
+
+type Password = String
+
+componentConnect :: JID -> HostName -> PortID -> IO ConnectedComponent
+componentConnect jid host port = do
+	handle <- connectTo host port
+	stream <- S.beginStream jid "jabber:component:accept" handle
+	return $ ConnectedComponent jid stream
+
+componentAuthenticate :: ConnectedComponent -> Password -> IO Component
+componentAuthenticate (ConnectedComponent jid stream) password
+    = do let c = Component jid stream
+
+         let S.XMPPStreamID sid = S.streamID stream
+             hash = SHA.showDigest . SHA.sha1 . B.pack $ sid ++ password
+         putTree c $ mkElement ("", "handshake") [] [XN.mkText hash]
+
+         result <- getTree c
+         when (A.runLA (A.getChildren
+                        >>> A.hasQName (mkQName "jabber:component:accept" "handshake")
+                       ) result == []) $
+             error "Component handshake failed"
+
+         return c
+
+-------------------------------------------------------------------------------
+
+instance Connection Component where
+    getTree = S.getTree . componentStream
+    putTree = S.putTree . componentStream

@@ 18,8 18,10 @@ module Network.Protocol.XMPP.Stream (
 	 Stream (
 	 	 streamLanguage
 	 	,streamVersion
+		,streamID
 	 	,streamFeatures
 	 	)
+	,XMPPStreamID(XMPPStreamID)
 	,StreamFeature (
 		 FeatureStartTLS
 		,FeatureSASL


@@ 36,6 38,7 @@ module Network.Protocol.XMPP.Stream (
 import qualified System.IO as IO
 import Data.AssocList (lookupDef)
 import Data.Char (toUpper)
+import Control.Applicative
 
 -- XML Parsing
 import Text.XML.HXT.Arrow ((>>>))


@@ 59,9 62,11 @@ data Stream = Stream
 	{
 		 streamHandle   :: Handle
 		,streamJID      :: JID
+		,streamNS       :: String
 		,streamParser   :: SAX.Parser
 		,streamLanguage :: XMLLanguage
 		,streamVersion  :: XMPPVersion
+		,streamID       :: XMPPStreamID
 		,streamFeatures :: [StreamFeature]
 	}
 


@@ 80,6 85,8 @@ newtype XMLLanguage = XMLLanguage String
 data XMPPVersion = XMPPVersion Int Int
 	deriving (Show, Eq)
 
+newtype XMPPStreamID = XMPPStreamID String
+
 data Handle =
 	  PlainHandle IO.Handle
 	| SecureHandle IO.Handle (GnuTLS.Session GnuTLS.Client)


@@ 87,35 94,40 @@ data Handle =
 ------------------------------------------------------------------------------
 
 restartStream :: Stream -> IO Stream
-restartStream s = beginStream' (streamJID s) (streamHandle s)
+restartStream s = beginStream' (streamJID s) (streamNS s) (streamHandle s)
 
-beginStream :: JID -> IO.Handle -> IO Stream
-beginStream jid rawHandle = do
+beginStream :: JID -> String -> IO.Handle -> IO Stream
+beginStream jid ns rawHandle = do
 	IO.hSetBuffering rawHandle IO.NoBuffering
 	
-	plainStream <- beginStream' jid (PlainHandle rawHandle)
-	
-	putTree plainStream $ Util.mkElement ("", "starttls")
-		[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-tls")]
-		[]
-	getTree plainStream
+	plainStream <- beginStream' jid ns (PlainHandle rawHandle)
+
+	let startTLS = do
+	      putTree plainStream $ Util.mkElement ("", "starttls")
+				    [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-tls")]
+				    []
+	      getTree plainStream
 	
-	session <- GnuTLS.tlsClient [
-		 GnuTLS.handle GnuTLS.:= rawHandle
-		,GnuTLS.priorities GnuTLS.:= [GnuTLS.CrtX509]
-		,GnuTLS.credentials GnuTLS.:= GnuTLS.certificateCredentials
-		]
-	GnuTLS.handshake session
-	beginStream' jid (SecureHandle rawHandle session)
-
-beginStream' :: JID -> Handle -> IO Stream
-beginStream' jid h = do
+	      session <- GnuTLS.tlsClient [
+				GnuTLS.handle GnuTLS.:= rawHandle
+			       ,GnuTLS.priorities GnuTLS.:= [GnuTLS.CrtX509]
+			       ,GnuTLS.credentials GnuTLS.:= GnuTLS.certificateCredentials
+			       ]
+	      GnuTLS.handshake session
+	      beginStream' jid ns (SecureHandle rawHandle session)
+
+	case streamCanTLS plainStream of
+	  True -> startTLS
+	  False -> return plainStream
+
+beginStream' :: JID -> String -> Handle -> IO Stream
+beginStream' jid ns h = do
 	-- Since only the opening tag should be written, normal XML
 	-- serialization cannot be used. Be careful to escape any embedded
 	-- attributes.
 	let xmlHeader =
 		"<?xml version='1.0'?>\n" ++
-		"<stream:stream xmlns='jabber:client'" ++
+		"<stream:stream xmlns='" ++ DOM.attrEscapeXml ns ++ "'" ++
 		" to='" ++ (DOM.attrEscapeXml . jidFormat) jid ++ "'" ++
 		" version='1.0'" ++
 		" xmlns:stream='http://etherx.jabber.org/streams'>"


@@ 123,13 135,17 @@ beginStream' jid h = do
 	parser <- SAX.mkParser
 	hPutStr h xmlHeader
 	initialEvents <- readEventsUntil startOfStream h parser
-	featureTree <- getTree' h parser
 	
 	let startStreamEvent = last initialEvents
-	let (language, version) = parseStartStream startStreamEvent
-	let features = parseFeatures featureTree
+	let (language, version, streamID) = parseStartStream startStreamEvent
+	features <- (case ns of
+		       "jabber:client" ->
+			   parseFeatures <$> getTree' h parser
+		       _ ->
+			   return []
+		    )
 	
-	return $ Stream h jid parser language version features
+	return $ Stream h jid ns parser language version streamID features
 	
 	where
 		streamName = Util.mkQName "http://etherx.jabber.org/streams" "stream"


@@ 139,8 155,15 @@ beginStream' jid h = do
 				streamName == Util.convertQName elemName
 			_ -> False
 
-parseStartStream :: SAX.Event -> (XMLLanguage, XMPPVersion)
-parseStartStream e = (XMLLanguage "en", XMPPVersion 1 0) -- TODO
+parseStartStream :: SAX.Event -> (XMLLanguage, XMPPVersion, XMPPStreamID)
+parseStartStream e = (XMLLanguage lang, XMPPVersion 1 0, XMPPStreamID id)
+    where SAX.BeginElement _ attrs = e
+	  attr name = maybe "" SAX.attributeValue $
+		      m1 $ filter ((name ==) . SAX.qnameLocalName . SAX.attributeName) attrs
+	      where m1 (x:_) = Just x
+		    m1 _ = Nothing
+	  lang = attr "lang"
+	  id = attr "id"
 
 parseFeatures :: DOM.XmlTree -> [StreamFeature]
 parseFeatures t =


@@ 176,6 199,14 @@ parseFeatureSASL t = let
 	
 	in FeatureSASL $ map (map toUpper) mechanisms
 
+streamCanTLS :: Stream -> Bool
+streamCanTLS = (> 0) . length .
+	       filter (\feature ->
+			   case feature of
+			     FeatureStartTLS _ -> True
+			     _ -> False
+		      ) . streamFeatures
+
 -------------------------------------------------------------------------------
 
 getTree :: Stream -> IO DOM.XmlTree