~singpolyma/network-protocol-xmpp

ref: 905f1032527759b10409471df7b6218a4c385d54 network-protocol-xmpp/lib/Network/Protocol/XMPP/Client/Authentication.hs -rw-r--r-- 5.5 KiB
905f1032 — John Millikin If auth fails, include the error element in AuthenticationFailure. 9 years ago
                                                                                
6ac34f1c John Millikin
78b7d475 John Millikin
27bee8c4 John Millikin
bd216cc4 John Millikin
92b4b6e3 John Millikin
78b7d475 John Millikin
27bee8c4 John Millikin
6ac34f1c John Millikin
92b4b6e3 John Millikin
70163d37 John Millikin
6ac34f1c John Millikin
92b4b6e3 John Millikin
f804d361 John Millikin
1eb63b40 John Millikin
6ac34f1c John Millikin
f393f02c John Millikin
30ee97bf John Millikin
92b4b6e3 John Millikin
fa4477d2 John Millikin
6ac34f1c John Millikin
27bee8c4 John Millikin
905f1032 John Millikin
30ee97bf John Millikin
1eb63b40 John Millikin
92b4b6e3 John Millikin
f804d361 John Millikin
78b7d475 John Millikin
1eb63b40 John Millikin
92b4b6e3 John Millikin
f804d361 John Millikin
92b4b6e3 John Millikin
e5a8ce04 John Millikin
f804d361 John Millikin
92b4b6e3 John Millikin
905f1032 John Millikin
92b4b6e3 John Millikin
f804d361 John Millikin
30ee97bf John Millikin
92b4b6e3 John Millikin
f393f02c John Millikin
92b4b6e3 John Millikin
f804d361 John Millikin
f393f02c John Millikin
f804d361 John Millikin
bd96ff0c John Millikin
f804d361 John Millikin
f393f02c John Millikin
92b4b6e3 John Millikin
b78487a0 John Millikin
70163d37 John Millikin
22b56df3 John Millikin
e5a8ce04 John Millikin
92b4b6e3 John Millikin
70163d37 John Millikin
905f1032 John Millikin
70163d37 John Millikin
22b56df3 John Millikin
e5a8ce04 John Millikin
fa4477d2 John Millikin
70163d37 John Millikin
905f1032 John Millikin
92b4b6e3 John Millikin
e5a8ce04 John Millikin
fa4477d2 John Millikin
f804d361 John Millikin
92b4b6e3 John Millikin
f804d361 John Millikin
92b4b6e3 John Millikin
e5a8ce04 John Millikin
fa4477d2 John Millikin
92b4b6e3 John Millikin
f804d361 John Millikin
92b4b6e3 John Millikin
70163d37 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
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 #-}
{-# LANGUAGE DeriveDataTypeable #-}

-- Copyright (C) 2009-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.Authentication
	( Result (..)
	, authenticate
	) where

import qualified Control.Exception as Exc
import           Control.Monad (when)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Monad.Error as E
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8
import qualified Data.Text
import           Data.Text (Text)
import           Data.Text.Encoding (encodeUtf8)
import           Data.Typeable (Typeable)
import qualified Network.Protocol.SASL.GNU as SASL

import qualified Network.Protocol.XMPP.Monad as M
import qualified Network.Protocol.XMPP.XML as X
import           Network.Protocol.XMPP.JID (JID, formatJID, jidResource)

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

data AuthException = XmppError M.Error | SaslError Text
	deriving (Typeable, Show)

instance Exc.Exception AuthException

authenticate :: [ByteString] -- ^ Mechanisms
             -> JID -- ^ User JID
             -> JID -- ^ Server JID
             -> Text -- ^ Username
             -> Text -- ^ Password
             -> M.XMPP ()
authenticate xmppMechanisms userJID serverJID username password = xmpp where
	mechanisms = map SASL.Mechanism xmppMechanisms
	authz = formatJID (userJID { jidResource = Nothing })
	hostname = formatJID serverJID
	
	xmpp = do
		ctx <- M.getSession
		res <- liftIO . Exc.try . SASL.runSASL $ do
			suggested <- SASL.clientSuggestMechanism mechanisms
			case suggested of
				Nothing -> saslError "No supported authentication mechanism"
				Just mechanism -> authSasl ctx mechanism
		case res of
			Right Success -> return ()
			Right (Failure e) -> E.throwError (M.AuthenticationFailure e)
			Left (XmppError err) -> E.throwError err
			Left (SaslError err) -> E.throwError (M.AuthenticationError err)
	
	authSasl ctx mechanism = do
		let (SASL.Mechanism mechBytes) = mechanism
		sessionResult <- SASL.runClient mechanism $ do
			SASL.setProperty SASL.PropertyAuthzID (encodeUtf8 authz)
			SASL.setProperty SASL.PropertyAuthID (encodeUtf8 username)
			SASL.setProperty SASL.PropertyPassword (encodeUtf8 password)
			SASL.setProperty SASL.PropertyService "xmpp"
			SASL.setProperty SASL.PropertyHostname (encodeUtf8 hostname)
			
			(b64text, rc) <- SASL.step64 ""
			putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
				[("mechanism", Data.Text.pack (Data.ByteString.Char8.unpack mechBytes))]
				[X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))]
			
			case rc of
				SASL.Complete -> saslFinish ctx
				SASL.NeedsMore -> saslLoop ctx
			
		case sessionResult of
			Right x -> return x
			Left err -> saslError (show err)

saslLoop :: M.Session -> SASL.Session Result
saslLoop ctx = do
	e <- getElement ctx
	let challengeTexts = X.elementNodes e >>= X.isContent >>= return . X.contentText
	let challenge = concatMap Data.Text.unpack challengeTexts
	case X.elementName e of
		-- The server needs more data before it can authenticate this client.
		n | n == "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" -> do
			when (null challenge) (saslError "Received empty challenge")
			(b64text, rc) <- SASL.step64 (Data.ByteString.Char8.pack challenge)
			putElement ctx (X.element
				"{urn:ietf:params:xml:ns:xmpp-sasl}response"
				[]
				[X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))])
			case rc of
				SASL.Complete -> saslFinish ctx
				SASL.NeedsMore -> saslLoop ctx
		
		-- The server has authenticated this client, but the client-side
		-- SASL protocol wants more data from the server.
		n | n == "{urn:ietf:params:xml:ns:xmpp-sasl}success" -> do
			when (null challenge) (saslError "Received empty challenge")
			(_, rc) <- SASL.step64 (Data.ByteString.Char8.pack challenge)
			case rc of
				SASL.Complete -> return Success
				SASL.NeedsMore -> saslError "Server didn't provide enough SASL data."
		
		-- The server has rejected this client's credentials.
		n | n == "{urn:ietf:params:xml:ns:xmpp-sasl}failure" -> return (Failure e)
		
		_ -> saslError ("Server sent unexpected element during authentication.")

saslFinish :: M.Session -> SASL.Session Result
saslFinish ctx = do
	elemt <- getElement ctx
	return $ if X.elementName elemt == "{urn:ietf:params:xml:ns:xmpp-sasl}success"
		then Success
		else Failure elemt

putElement :: M.Session -> X.Element -> SASL.Session ()
putElement ctx elemt = liftIO $ do
	res <- M.runXMPP ctx (M.putElement elemt)
	case res of
		Left err -> Exc.throwIO (XmppError err)
		Right x -> return x

getElement :: M.Session -> SASL.Session X.Element
getElement ctx = liftIO $ do
	res <- M.runXMPP ctx M.getElement
	case res of
		Left err -> Exc.throwIO (XmppError err)
		Right x -> return x

saslError :: MonadIO m => String -> m a
saslError = liftIO . Exc.throwIO . SaslError . Data.Text.pack