~singpolyma/network-protocol-xmpp

ref: 46192ec08aac10379d4dea726a51dc483f5bd3be network-protocol-xmpp/Network/Protocol/XMPP/Client.hs -rw-r--r-- 3.2 KiB
46192ec0 — Stephan Maka Component support 12 years ago
                                                                                
e17933b3 John Millikin
5055a1d4 John Millikin
e17933b3 John Millikin
1445ab42 John Millikin
2f2cd141 John Millikin
1445ab42 John Millikin
23322af9 John Millikin
e17933b3 John Millikin
27bee8c4 John Millikin
1445ab42 John Millikin
27bee8c4 John Millikin
da21c392 John Millikin
30ee97bf John Millikin
27bee8c4 John Millikin
5055a1d4 John Millikin
6f4c4a10 John Millikin
4292e71f Stephan Maka
e17933b3 John Millikin
055a7bfb John Millikin
e17933b3 John Millikin
5055a1d4 John Millikin
055a7bfb John Millikin
5055a1d4 John Millikin
e17933b3 John Millikin
46192ec0 Stephan Maka
055a7bfb John Millikin
e17933b3 John Millikin
5055a1d4 John Millikin
055a7bfb John Millikin
22b56df3 John Millikin
30ee97bf John Millikin
e17933b3 John Millikin
5055a1d4 John Millikin
1445ab42 John Millikin
b44e8c3b John Millikin
1445ab42 John Millikin
b44e8c3b John Millikin
1445ab42 John Millikin
5055a1d4 John Millikin
2f2cd141 John Millikin
1445ab42 John Millikin
2f2cd141 John Millikin
1445ab42 John Millikin
5055a1d4 John Millikin
e17933b3 John Millikin
4292e71f Stephan Maka
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
{- Copyright (C) 2009 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.Client (
	 ConnectedClient
	,Client
	,clientConnect
	,clientAuthenticate
	,clientBind
	,clientJID
	,clientServerJID
	,putTree
	,getTree
	,putStanza
	) where

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

data ConnectedClient = ConnectedClient JID S.Stream

data Client = Client {
	 clientJID        :: JID
	,clientServerJID  :: JID
	,clientStream     :: S.Stream
	}

type Username = String
type Password = String

clientConnect :: JID -> HostName -> PortID -> IO ConnectedClient
clientConnect jid host port = do
	handle <- connectTo host port
	stream <- S.beginStream jid "jabber:client" handle
	return $ ConnectedClient jid stream

clientAuthenticate :: ConnectedClient -> JID -> Username -> Password -> IO Client
clientAuthenticate (ConnectedClient serverJID stream) jid username password = do
	authed <- SASL.authenticate stream jid serverJID username password
	case authed of
		SASL.Failure -> error "Authentication failure"
		_ -> do
			newStream <- S.restartStream stream
			return $ Client jid serverJID newStream

clientBind :: Client -> IO JID
clientBind c = do
	-- Bind
	let resourceElements = case jidResource . clientJID $ c of
		"" -> []
		resource ->
			[mkElement ("", "resource")
				[]
				[XN.mkText resource]]
	
	putTree c $ mkElement ("", "iq")
		[("", "type", "set")]
		[mkElement ("", "bind")
		 	[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-bind")]
		 	resourceElements]
	
	bindResult <- getTree c
	let [rawJID] = A.runLA (
		A.deep (A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-bind" "jid"))
		>>> A.getChildren
		>>> A.getText) bindResult
	let jid = case jidParse rawJID of
		Just x -> x
		_ -> error "Couldn't parse server's returned JID"
	
	-- Session
	putTree c $ mkElement ("", "iq")
		[("", "type", "set")]
		[mkElement ("", "session")
			[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-session")]
			[]]
	
	getTree c
	
	putTree c $ mkElement ("", "presence") [] []
	getTree c
	return jid

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