~singpolyma/network-protocol-xmpp

ref: 3f30f380adb4c6eedf3c919590359c9746f5d8b3 network-protocol-xmpp/lib/Network/Protocol/XMPP/Client.hs -rw-r--r-- 4.8 KiB
3f30f380Stephen Paul Weber Call TLS.getBytes again on EAGAIN 2 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
-- 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
import           Network.Protocol.XMPP.String (s)

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 (s"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 (s"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 (s"{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 (s"{urn:ietf:params:xml:ns:xmpp-bind}bind") [] requested
	requested = case fmap J.strResource resource of
		Nothing -> []
		Just x -> [X.NodeElement (X.element (s"resource") [] [X.NodeContent (X.ContentText x)])]

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

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