~singpolyma/network-protocol-xmpp

ref: fa4477d23aacb9745b349aaa063892c705861346 network-protocol-xmpp/Network/Protocol/XMPP/Client.hs -rw-r--r-- 4.3 KiB
fa4477d2 — John Millikin Use 'xml-types' instead of HXT for basic XML processing. 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
-- 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
	( runClient
	, bindJID
	) where
import Control.Monad.Error (throwError)
import Control.Monad.Trans (liftIO)
import Data.ByteString (ByteString)
import qualified Data.Text.Lazy as T
import Network (connectTo)
import qualified System.IO as IO

import qualified Network.Protocol.XMPP.Client.Authentication as A
import qualified Network.Protocol.XMPP.Connections as C
import qualified Network.Protocol.XMPP.Client.Features as F
import qualified Network.Protocol.XMPP.Handle as H
import qualified Network.Protocol.XMPP.JID as J
import qualified Network.Protocol.XMPP.Monad as M
import qualified Network.Protocol.XMPP.XML as X
import Network.Protocol.XMPP.ErrorT
import Network.Protocol.XMPP.Stanza

runClient :: C.Server
          -> J.JID -- ^ Client JID
          -> T.Text -- ^ Username
          -> T.Text -- ^ Password
          -> M.XMPP a
          -> IO (Either M.Error a)
runClient server jid username password xmpp = do
	-- Open a TCP connection
	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
	M.startXMPP handle "jabber:client" $ do
		features <- newStream sjid
		tryTLS sjid features $ \tlsFeatures -> do
			let mechanisms = authenticationMechanisms tlsFeatures
			A.authenticate mechanisms jid sjid username password
			M.restartXMPP Nothing (newStream sjid >> xmpp)

newStream :: J.JID -> M.XMPP [F.Feature]
newStream jid = do
	M.putBytes $ C.xmlHeader "jabber:client" jid
	M.readEvents C.startOfStream
	F.parseFeatures `fmap` M.getElement

tryTLS :: J.JID -> [F.Feature] -> ([F.Feature] -> M.XMPP a) -> M.XMPP a
tryTLS sjid features m
	| not (streamSupportsTLS features) = m features
	| otherwise = do
		M.putElement xmlStartTLS
		M.getElement
		h <- M.getHandle
		eitherTLS <- liftIO $ runErrorT $ H.startTLS h
		case eitherTLS of
			Left err -> throwError $ M.TransportError err
			Right tls -> M.restartXMPP (Just tls) $ newStream sjid >>= m

authenticationMechanisms :: [F.Feature] -> [ByteString]
authenticationMechanisms = step where
	step [] = []
	step (f:fs) = case f of
		(F.FeatureSASL ms) -> ms
		_ -> step fs

bindJID :: J.JID -> M.XMPP J.JID
bindJID jid = do
	-- Bind
	M.putStanza . bindStanza . J.jidResource $ jid
	bindResult <- M.getStanza
	let getJID e =
		X.elementChildren e
		>>= X.hasName (X.Name "jid" (Just "urn:ietf:params:xml:ns:xmpp-bind") Nothing)
		>>= X.elementNodes
		>>= X.getText
	
	let maybeJID = do
		iq <- case bindResult of
			ReceivedIQ x -> Just x
			_ -> Nothing
		payload <- iqPayload iq
		
		case getJID payload of
			[] -> Nothing
			(str:_) -> J.parseJID str
	
	returnedJID <- case maybeJID of
		Just x -> return x
		Nothing -> throwError $ M.InvalidBindResult bindResult
	
	-- Session
	M.putStanza sessionStanza
	M.getStanza
	
	M.putStanza $ emptyPresence PresenceAvailable
	M.getStanza
	
	return returnedJID

bindStanza :: Maybe J.Resource -> IQ
bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where
	payload = X.nselement "urn:ietf:params:xml:ns:xmpp-bind" "bind" [] requested
	requested = case fmap J.strResource resource of
		Nothing -> []
		Just x -> [X.NodeElement $ X.element "resource" [] [X.NodeText x]]

sessionStanza :: IQ
sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where
	payload = X.nselement "urn:ietf:params:xml:ns:xmpp-session" "session" [] []

streamSupportsTLS :: [F.Feature] -> Bool
streamSupportsTLS = any isStartTLS where
	isStartTLS (F.FeatureStartTLS _) = True
	isStartTLS _                     = False

xmlStartTLS :: X.Element
xmlStartTLS = X.nselement "urn:ietf:params:xml:ns:xmpp-tls" "starttls" [] []