~singpolyma/network-protocol-xmpp

ref: 82b00c68cde42b5452a94353c531f39efa1475f7 network-protocol-xmpp/Network/Protocol/XMPP/Client.hs -rw-r--r-- 6.4 KiB
82b00c68 — John Millikin Cleaned up the Client module, which opens streams in the jabber:client namespace. 12 years ago
                                                                                
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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
-- 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.Client
	( Client
	, Server (..)
	, connectClient
	, bindClient
	) where
import Network (HostName, PortID, 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.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
                                          )
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
	}

data ClientStream = ClientStream
	{ streamJID      :: J.JID
	, streamHandle   :: H.Handle
	, streamFeatures :: [F.Feature]
	, streamParser   :: SAX.Parser
	}

instance S.Stream Client where
	getTree = S.getTree . clientStream
	putTree = S.putTree . clientStream

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 server jid username password = do
	-- Open a TCP connection
	let 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
	authedStream <- authenticate stream jid sjid username password
	return $ Client jid server authedStream

authenticate :: ClientStream -> J.JID -> J.JID -> T.Text -> T.Text -> IO ClientStream
authenticate stream jid sjid username password = do
	let mechanisms = authenticationMechanisms stream
	result <- A.authenticate stream mechanisms jid sjid username password
	case result of
		-- TODO: throwIO some exception type?
		A.Failure -> error "Authentication failure"
		_ -> restartStream stream

authenticationMechanisms :: ClientStream -> [T.Text]
authenticationMechanisms = step . streamFeatures where
	step [] = []
	step (f:fs) = case f of
		(F.FeatureSASL ms) -> ms
		_ -> step fs

-- TODO: does it make sense to put this in 'connect'?
-- Can multiple resources be bound to one client?
bindClient :: Client -> IO J.JID
bindClient c = do
	-- Bind
	S.putStanza c $ bindStanza . J.jidResource . clientJID $ c
	bindResult <- S.getStanza c
	
	let jidArrow =
		A.deep (A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-bind" "jid"))
		>>> A.getChildren
		>>> A.getText
	
	-- TODO: throwIO with exception
	let Just jid = do
		result <- bindResult
		iq <- case result of
			ReceivedIQ x -> Just x
			_ -> Nothing
		
		case A.runLA jidArrow (iqPayload iq) of
			[] -> Nothing
			(str:_) -> J.parseJID (T.pack str)
	
	-- Session
	S.putStanza c sessionStanza
	S.getStanza c
	
	S.putStanza c $ emptyPresence PresenceAvailable
	S.getStanza c
	
	return jid

bindStanza :: Maybe J.Resource -> IQ
bindStanza resource = emptyIQ IQSet payload where
	payload = element ("", "bind")
		[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-bind")]
		requested
	requested = case fmap J.strResource resource of
		Nothing -> []
		Just x -> [element ("", "resource")
			[]
			[XN.mkText (T.unpack x)]]

sessionStanza :: IQ
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
	plain <- newStream jid handle
	if streamSupportsTLS plain
		then do
			S.putTree plain xmlStartTLS
			S.getTree plain -- TODO: verify
			H.startTLS handle >>= newStream jid
		else return plain

restartStream :: ClientStream -> IO ClientStream
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
	features <- F.parseFeatures `fmap` getTree h parser
	
	return $ ClientStream jid h features parser

streamSupportsTLS :: ClientStream -> Bool
streamSupportsTLS = any isStartTLS . streamFeatures where
	isStartTLS (F.FeatureStartTLS _) = True
	isStartTLS _                     = False

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"