~singpolyma/network-protocol-xmpp

ref: 16af081c574a5527d5a77be254d69e877528d11c network-protocol-xmpp/Network/Protocol/XMPP/Component.hs -rw-r--r-- 4.0 KiB
16af081c — John Millikin Implement converting stanzas to/from XML trees 13 years ago
                                                                                
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
16af081c John Millikin
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
-- 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/>.

{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Component
	( Component
	, componentJID
	, componentStreamID
	, connectComponent
	) where

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 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 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 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
	, componentHandle   :: H.Handle
	, componentParser   :: SAX.Parser
	, componentStreamID :: T.Text
	}

instance S.Stream Component where
	streamNamespace _ = "jabber:component:accept"
	getTree s = getTree (componentHandle s) (componentParser s)
	putTree s = putTree (componentHandle s)

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

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'

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 ()

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