~singpolyma/network-protocol-xmpp

ref: 57a8932024bc67e6759cefc5be86329b4a849bff network-protocol-xmpp/Network/Protocol/XMPP/Authentication.hs -rw-r--r-- 3.6 KiB
57a89320 — John Millikin Merged public API into a single exposed module, 'Network.Protocol.XMPP'. 12 years ago
                                                                                
78b7d475 John Millikin
27bee8c4 John Millikin
57a89320 John Millikin
78b7d475 John Millikin
27bee8c4 John Millikin
f393f02c John Millikin
78b7d475 John Millikin
f393f02c John Millikin
27bee8c4 John Millikin
22b56df3 John Millikin
30ee97bf John Millikin
f393f02c John Millikin
30ee97bf John Millikin
78b7d475 John Millikin
57a89320 John Millikin
27bee8c4 John Millikin
30ee97bf John Millikin
78b7d475 John Millikin
f393f02c John Millikin
78b7d475 John Millikin
f393f02c John Millikin
30ee97bf John Millikin
f393f02c John Millikin
b78487a0 John Millikin
f393f02c John Millikin
b78487a0 John Millikin
22b56df3 John Millikin
f393f02c John Millikin
22b56df3 John Millikin
82b00c68 John Millikin
22b56df3 John Millikin
f393f02c John Millikin
22b56df3 John Millikin
f393f02c John Millikin
22b56df3 John Millikin
f393f02c John Millikin
22b56df3 John Millikin
f393f02c John Millikin
22b56df3 John Millikin
78b7d475 John Millikin
22b56df3 John Millikin
30ee97bf John Millikin
22b56df3 John Millikin
82b00c68 John Millikin
30ee97bf John Millikin
22b56df3 John Millikin
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
-- Copyright (C) 2009-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/>.

module Network.Protocol.XMPP.Authentication
	( Result(..)
	, authenticate
	) where
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE

import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Network.Protocol.SASL.GNU as SASL

import Network.Protocol.XMPP.JID (JID, formatJID)
import Network.Protocol.XMPP.XML (element, qname)
import qualified Network.Protocol.XMPP.Stream as S

data Result = Success | Failure
	deriving (Show, Eq)

authenticate :: S.Stream stream => stream
             -> [B.ByteString] -- ^ Mechanisms
             -> JID -- ^ User JID
             -> JID -- ^ Server JID
             -> T.Text -- ^ Username
             -> T.Text -- ^ Password
             -> IO Result
authenticate stream mechanisms userJID serverJID username password = do
	let authz = formatJID userJID
	let hostname = formatJID serverJID
	let utf8 = TE.encodeUtf8
	
	SASL.runSASL $ do
		suggested <- SASL.clientSuggestMechanism $ map SASL.Mechanism mechanisms
		mechanism <- case suggested of
			Just m -> return m
			Nothing -> error "No supported SASL mechanisms advertised"
		let (SASL.Mechanism mechBytes) = mechanism
		result <- SASL.runClient mechanism $ do
			SASL.setProperty SASL.PropertyAuthzID $ utf8 authz
			SASL.setProperty SASL.PropertyAuthID $ utf8 username
			SASL.setProperty SASL.PropertyPassword $ utf8 password
			SASL.setProperty SASL.PropertyService $ B.pack "xmpp"
			SASL.setProperty SASL.PropertyHostname $ utf8 hostname
			
			(b64text, rc) <- SASL.step64 $ B.pack ""
			liftIO $ S.putTree stream $ element ("", "auth")
				[ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")
				, ("", "mechanism", B.unpack mechBytes)]
				[XN.mkText $ B.unpack b64text]
			
			case rc of
				SASL.Complete -> liftIO $ saslFinish stream
				SASL.NeedsMore -> saslLoop stream
		case result of
			Right x -> return x
			Left err -> error $ show err

saslLoop :: S.Stream s => s -> SASL.Session Result
saslLoop stream = do
	challengeText <- liftIO $ A.runX (
		A.arrIO (\_ -> S.getTree stream)
		>>> A.getChildren
		>>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "challenge")
		>>> A.getChildren >>> A.getText)
	
	if null challengeText
		then return Failure
		else do
			(b64text, rc) <- SASL.step64 $ B.pack $ concat challengeText
			liftIO $ S.putTree stream $ element ("", "response")
				[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")]
				[XN.mkText $ B.unpack b64text]
			case rc of
				SASL.Complete -> liftIO $ saslFinish stream
				SASL.NeedsMore -> saslLoop stream

saslFinish :: S.Stream s => s -> IO Result
saslFinish stream = do
	successElem <- A.runX (
		A.arrIO (\_ -> S.getTree stream)
		>>> A.getChildren
		>>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "success"))
	
	return $ if null successElem then Failure else Success