~singpolyma/network-protocol-xmpp

ref: 3a40e58a4ca8b68a71dc907d09298168fd7ec00f network-protocol-xmpp/Network/Protocol/XMPP/Client.hs -rw-r--r-- 4.8 KiB
3a40e58a — John Millikin Replace SaxEvent with plain Event 11 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
{-# LANGUAGE OverloadedStrings #-}

-- Copyright (C) 2010-2011 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
	( runClient
	, bindJID
	) where

import           Control.Monad ((>=>))
import           Control.Monad.Error (throwError)
import           Control.Monad.Trans (liftIO)
import           Data.ByteString (ByteString)
import           Data.Text (Text)
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
          -> Text -- ^ Username
          -> 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
	void (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
		void 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

-- | Send a @\<bind\>@ message for the given 'J.JID', returning the server's reply. In
-- most cases the reply will be the same as the input. However, if the input has no
-- 'J.Resource', the returned 'J.JID' will contain a generated 'J.Resource'.
-- 
-- Clients must bind a 'J.JID' before sending any 'Stanza's.
bindJID :: J.JID -> M.XMPP J.JID
bindJID jid = do
	-- Bind
	M.putStanza . bindStanza . J.jidResource $ jid
	bindResult <- M.getStanza
	let getJID =
		X.elementChildren
		>=> X.isNamed "{urn:ietf:params:xml:ns:xmpp-bind}jid"
		>=> X.elementNodes
		>=> X.isContent
		>=> return . X.contentText
	
	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
	void M.getStanza
	
	M.putStanza $ emptyPresence PresenceAvailable
	void M.getStanza
	
	return returnedJID

bindStanza :: Maybe J.Resource -> IQ
bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where
	payload = X.element "{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.NodeContent $ X.ContentText x]]

sessionStanza :: IQ
sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where
	payload = X.element "{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.element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []

void :: Monad m => m a -> m ()
void m = m >> return ()