~singpolyma/network-protocol-xmpp

46192ec08aac10379d4dea726a51dc483f5bd3be — Stephan Maka 12 years ago 4292e71
Component support
M Network/Protocol/XMPP.hs => Network/Protocol/XMPP.hs +2 -0
@@ 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

M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +1 -1
@@ 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

A Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +80 -0
@@ 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

M Network/Protocol/XMPP/Stream.hs => Network/Protocol/XMPP/Stream.hs +57 -26
@@ 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