~singpolyma/network-protocol-xmpp

fbf0f0b1d51638c3a4ffcb70c97b8e3294af058d — John Millikin 13 years ago 82b00c6
Cleaned up the 'Component' module
M Network/Protocol/XMPP.hs => Network/Protocol/XMPP.hs +9 -1
@@ 15,11 15,19 @@


module Network.Protocol.XMPP
	( module Network.Protocol.XMPP.JID
	( module Network.Protocol.XMPP.Client
	, module Network.Protocol.XMPP.Component
	, module Network.Protocol.XMPP.JID
	, module Network.Protocol.XMPP.Stanza
	, module Network.Protocol.XMPP.Stream
	, Server (..)
	) where

import Network.Protocol.XMPP.Client
import Network.Protocol.XMPP.Component
import Network.Protocol.XMPP.JID
import Network.Protocol.XMPP.Stanza
import Network.Protocol.XMPP.Stream


import Network.Protocol.XMPP.Internal.Connections

M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +18 -46
@@ 16,42 16,34 @@
{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Client
	( Client
	, Server (..)
	, clientJID
	, connectClient
	, bindClient
	) where
import Network (HostName, PortID, connectTo)
import Network (connectTo)
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified System.IO as IO
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Text.XML.LibXML.SAX as SAX

import qualified Network.Protocol.XMPP.Internal.Authentication as A
import qualified Network.Protocol.XMPP.Internal.Connections as C
import qualified Network.Protocol.XMPP.Internal.Features as F
import qualified Network.Protocol.XMPP.Internal.Handle as H
import qualified Network.Protocol.XMPP.Internal.Stream as S
import qualified Network.Protocol.XMPP.Stream as S
import Network.Protocol.XMPP.Internal.XML ( getTree, putTree
                                          , element, qname
                                          , readEventsUntil, convertQName
                                          )
                                                 , element, qname
                                                 , readEventsUntil
                                                 )
import qualified Network.Protocol.XMPP.JID as J
import Network.Protocol.XMPP.Stanza

data Server = Server
	{ serverJID      :: J.JID
	, serverHostname :: HostName
	, serverPort     :: PortID
	}

data Client = Client
	{ clientJID    :: J.JID
	, clientServer :: Server
	, clientStream :: ClientStream
	}



@@ 70,18 62,22 @@ instance S.Stream ClientStream where
	getTree s = getTree (streamHandle s) (streamParser s)
	putTree s = putTree (streamHandle s)

connectClient :: Server -> J.JID -> T.Text -> T.Text -> IO Client
connectClient :: C.Server
              -> J.JID -- ^ Client JID
              -> T.Text -- ^ Username
              -> T.Text -- ^ Password
              -> IO Client
connectClient server jid username password = do
	-- Open a TCP connection
	let Server sjid host port = server
	let C.Server sjid host port = server
	rawHandle <- connectTo host port
	IO.hSetBuffering rawHandle IO.NoBuffering
	let handle = H.PlainHandle rawHandle
	
	-- Open the initial stream and authenticate
	stream <- beginClientStream server handle
	stream <- beginStream sjid handle
	authedStream <- authenticate stream jid sjid username password
	return $ Client jid server authedStream
	return $ Client jid authedStream

authenticate :: ClientStream -> J.JID -> J.JID -> T.Text -> T.Text -> IO ClientStream
authenticate stream jid sjid username password = do


@@ 148,9 144,8 @@ sessionStanza = emptyIQ IQSet $ element ("", "session")
	[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-session")]
	[]

beginClientStream :: Server -> H.Handle -> IO ClientStream
beginClientStream server handle = do
	let jid = serverJID server
beginStream :: J.JID -> H.Handle -> IO ClientStream
beginStream jid handle = do
	plain <- newStream jid handle
	if streamSupportsTLS plain
		then do


@@ 164,14 159,9 @@ restartStream s = newStream (streamJID s) (streamHandle s)

newStream :: J.JID -> H.Handle -> IO ClientStream
newStream jid h = do
	let startOfStream depth event = case (depth, event) of
		(1, (SAX.BeginElement elemName _)) ->
			qnameStream == convertQName elemName
		_ -> False
	
	parser <- SAX.mkParser
	H.hPutBytes h $ xmlHeader "jabber:client" jid
	readEventsUntil startOfStream h parser
	H.hPutBytes h $ C.xmlHeader "jabber:client" jid
	readEventsUntil C.startOfStream h parser
	features <- F.parseFeatures `fmap` getTree h parser
	
	return $ ClientStream jid h features parser


@@ 185,21 175,3 @@ xmlStartTLS :: DOM.XmlTree
xmlStartTLS = element ("", "starttls")
	[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-tls")]
	[]

-- Since only the opening tag should be written, normal XML
-- serialization cannot be used. Be careful to escape any embedded
-- attributes.
xmlHeader :: T.Text -> J.JID -> B.ByteString
xmlHeader ns jid = TE.encodeUtf8 header where
	escape = T.pack . DOM.attrEscapeXml . T.unpack -- TODO: optimize?
	attr x = T.concat ["\"", escape x, "\""]
	header = T.concat
		[ "<?xml version='1.0'?>\n"
		, "<stream:stream xmlns=" , attr ns
		, " to=", attr (J.formatJID jid)
		, " version=\"1.0\""
		, " xmlns:stream=\"http://etherx.jabber.org/streams\">"
		]

qnameStream :: DOM.QName
qnameStream = qname "http://etherx.jabber.org/streams" "stream"

M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +95 -60
@@ 1,77 1,112 @@
{- 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/>.
-}
-- Copyright (C) 2010 Stephan Maka <stephan@spaceboyz.net>
-- Copyright (C) 2010 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.Component (
	 ConnectedComponent
	,Component
	,componentConnect
	,componentAuthenticate
	,componentJID
{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Component
	( Component
	, componentJID
	, componentStreamID
	, connectComponent
	) where

import Control.Monad (when)
import Network (HostName, PortID, connectTo)
import Network (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.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Data.Digest.Pure.SHA as SHA
import qualified System.IO as IO
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Text.XML.LibXML.SAX as SAX

import Network.Protocol.XMPP.JID (JID, jidParse, jidResource)
import qualified Network.Protocol.XMPP.SASL as SASL
import qualified Network.Protocol.XMPP.Internal.Connections as C
import qualified Network.Protocol.XMPP.Internal.Handle as H
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
import qualified Network.Protocol.XMPP.Internal.Stream as S
import Network.Protocol.XMPP.Internal.XML ( getTree, putTree
                                                 , element, qname
                                                 , readEventsUntil
                                                 )
import Network.Protocol.XMPP.JID (JID)

data Component = Component {
	 componentJID :: JID
	,componentStream :: S.Stream
data Component = Component
	{ componentJID      :: JID
	, componentHandle   :: H.Handle
	, componentParser   :: SAX.Parser
	, componentStreamID :: T.Text
	}

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
instance S.Stream Component where
	getTree s = getTree (componentHandle s) (componentParser s)
	putTree s = putTree (componentHandle s)

         let S.XMPPStreamID sid = S.streamID stream
             hash = SHA.showDigest . SHA.sha1 . B.pack $ sid ++ password
         putTree c $ mkElement ("", "handshake") [] [XN.mkText hash]
connectComponent :: C.Server
                  -> T.Text -- ^ Password
                  -> IO Component
connectComponent server password = do
	let C.Server jid host port = server
	rawHandle <- connectTo host port
	IO.hSetBuffering rawHandle IO.NoBuffering
	let handle = H.PlainHandle rawHandle
	
	stream <- beginStream jid handle
	authenticate stream password
	return stream

         result <- getTree c
         when (A.runLA (A.getChildren
                        >>> A.hasQName (mkQName "jabber:component:accept" "handshake")
                       ) result == []) $
             error "Component handshake failed"
beginStream :: JID -> H.Handle -> IO Component
beginStream jid h = do
	parser <- SAX.mkParser
	H.hPutBytes h $ C.xmlHeader "jabber:component:accept" jid
	events <- readEventsUntil C.startOfStream h parser
	let streamID' = case parseStreamID $ last events of
		Nothing -> error "No component stream ID defined"
		Just x -> x
	return $ Component jid h parser streamID'

         return c
parseStreamID :: SAX.Event -> Maybe T.Text
parseStreamID (SAX.BeginElement _ attrs) = sid where
	sid = case idAttrs of
		(x:_) -> Just . T.pack . SAX.attributeValue $ x
		_ -> Nothing
	idAttrs = filter (matchingName . SAX.attributeName) attrs
	matchingName n = and
		[ SAX.qnameNamespace n == "jabber:component:accept"
		, SAX.qnameLocalName n == "id"
		]
parseStreamID _ = Nothing

-------------------------------------------------------------------------------
authenticate :: Component -> T.Text -> IO ()
authenticate stream password = do
	let bytes = buildSecret (componentStreamID stream) password
	let digest = SHA.showDigest $ SHA.sha1 $ BL.fromChunks [bytes]
	S.putTree stream $ element ("", "handshake") [] [XN.mkText digest]
	result <- S.getTree stream
	let accepted = A.runLA $
		A.getChildren
		>>> A.hasQName (qname "jabber:component:accept" "handshake")
	if null (accepted result)
		then error "Component handshake failed" -- TODO: throwIO
		else return ()

instance Connection Component where
    getTree = S.getTree . componentStream
    putTree = S.putTree . componentStream
buildSecret :: T.Text -> T.Text -> B.ByteString
buildSecret sid password = bytes where
	bytes = TE.encodeUtf8 $ T.pack escaped
	escaped = DOM.attrEscapeXml $ sid' ++ password'
	sid' = T.unpack sid
	password' = T.unpack password

A Network/Protocol/XMPP/Internal/Connections.hs => Network/Protocol/XMPP/Internal/Connections.hs +61 -0
@@ 0,0 1,61 @@
-- Copyright (C) 2010 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/>.

{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Internal.Connections
	( Server (..)
	, xmlHeader
	, startOfStream
	, qnameStream
	) where
import Network (HostName, PortID)
import Data.ByteString (ByteString)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.LibXML.SAX as SAX

import Network.Protocol.XMPP.JID (JID, formatJID)
import Network.Protocol.XMPP.Internal.XML (qname, convertQName)

data Server = Server
	{ serverJID      :: JID
	, serverHostname :: HostName
	, serverPort     :: PortID
	}

-- Since only the opening tag should be written, normal XML
-- serialization cannot be used. Be careful to escape any embedded
-- attributes.
xmlHeader :: T.Text -> JID -> ByteString
xmlHeader ns jid = encodeUtf8 header where
	escape = T.pack . DOM.attrEscapeXml . T.unpack -- TODO: optimize?
	attr x = T.concat ["\"", escape x, "\""]
	header = T.concat
		[ "<?xml version='1.0'?>\n"
		, "<stream:stream xmlns=" , attr ns
		, " to=", attr (formatJID jid)
		, " version=\"1.0\""
		, " xmlns:stream=\"http://etherx.jabber.org/streams\">"
		]

startOfStream :: Int -> SAX.Event -> Bool
startOfStream depth event = case (depth, event) of
	(1, (SAX.BeginElement elemName _)) ->
		qnameStream == convertQName elemName
	_ -> False

qnameStream :: DOM.QName
qnameStream = qname "http://etherx.jabber.org/streams" "stream"

M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +3 -0
@@ 30,16 30,19 @@ library
    , libxml-sax >= 0.3 && < 0.4
    , gsasl >= 0.2 && < 0.3
    , network >= 2.2 && < 2.3
    , SHA >= 1.4 && < 1.5

  exposed-modules:
    Network.Protocol.XMPP
    Network.Protocol.XMPP.Client
    Network.Protocol.XMPP.Component
    Network.Protocol.XMPP.JID
    Network.Protocol.XMPP.Stanza
    Network.Protocol.XMPP.Stream

  other-modules:
    Network.Protocol.XMPP.Internal.Authentication
    Network.Protocol.XMPP.Internal.Connections
    Network.Protocol.XMPP.Internal.Features
    Network.Protocol.XMPP.Internal.Handle
    Network.Protocol.XMPP.Internal.Stanza