~singpolyma/network-protocol-xmpp

ref: 905f1032527759b10409471df7b6218a4c385d54 network-protocol-xmpp/lib/Network/Protocol/XMPP/Component.hs -rw-r--r-- 3.2 KiB
905f1032 — John Millikin If auth fails, include the error element in AuthenticationFailure. 9 years ago
                                                                                
6ac34f1c John Millikin
fbf0f0b1 John Millikin
6ac34f1c John Millikin
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
fbf0f0b1 John Millikin
92b4b6e3 John Millikin
46192ec0 Stephan Maka
6ac34f1c John Millikin
1eb63b40 John Millikin
1ab0aa09 John Millikin
1eb63b40 John Millikin
6ac34f1c John Millikin
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
57a89320 John Millikin
92b4b6e3 John Millikin
fa4477d2 John Millikin
6ac34f1c John Millikin
46192ec0 Stephan Maka
92b4b6e3 John Millikin
1eb63b40 John Millikin
92b4b6e3 John Millikin
fbf0f0b1 John Millikin
2969f4f9 John Millikin
92b4b6e3 John Millikin
46192ec0 Stephan Maka
1eb63b40 John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
46192ec0 Stephan Maka
3a40e58a John Millikin
1eb63b40 John Millikin
fbf0f0b1 John Millikin
46192ec0 Stephan Maka
1eb63b40 John Millikin
92b4b6e3 John Millikin
f804d361 John Millikin
fa4477d2 John Millikin
bd96ff0c John Millikin
905f1032 John Millikin
46192ec0 Stephan Maka
1eb63b40 John Millikin
f393f02c John Millikin
1eb63b40 John Millikin
f804d361 John Millikin
f393f02c 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
{-# LANGUAGE OverloadedStrings #-}

-- Copyright (C) 2010 Stephan Maka <stephan@spaceboyz.net>
-- 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.Component
	( runComponent
	) where

import           Control.Monad (when)
import           Control.Monad.Error (throwError)
import           Data.Bits (shiftR, (.&.))
import           Data.Char (intToDigit)
import qualified Data.ByteString
import           Data.ByteString (ByteString)
import qualified Data.Text
import           Data.Text (Text)
import           Data.Text.Encoding (encodeUtf8)
import           Network (connectTo)
import           Network.Protocol.SASL.GNU (sha1)
import qualified System.IO as IO

import qualified Network.Protocol.XMPP.Connections as C
import qualified Network.Protocol.XMPP.Handle as H
import qualified Network.Protocol.XMPP.Monad as M
import qualified Network.Protocol.XMPP.XML as X
import           Network.Protocol.XMPP.JID (JID)

runComponent :: C.Server
             -> Text -- ^ Server secret
             -> M.XMPP a
             -> IO (Either M.Error a)
runComponent server password xmpp = do
	let C.Server jid host port = server
	rawHandle <- connectTo host port
	IO.hSetBuffering rawHandle IO.NoBuffering
	let handle = H.PlainHandle rawHandle
	M.startXMPP handle "jabber:component:accept" $ do
		streamID <- beginStream jid
		authenticate streamID password
		xmpp

beginStream :: JID -> M.XMPP Text
beginStream jid = do
	M.putBytes $ C.xmlHeader "jabber:component:accept" jid
	events <- M.readEvents C.startOfStream
	case parseStreamID $ last events of
		Nothing -> throwError M.NoComponentStreamID
		Just x -> return x

parseStreamID :: X.Event -> Maybe Text
parseStreamID (X.EventBeginElement name attrs) = X.attributeText
	"{jabber:component:accept}jid"
	(X.Element name attrs [])
parseStreamID _ = Nothing

authenticate :: Text -> Text -> M.XMPP ()
authenticate streamID password = do
	let bytes = buildSecret streamID password
	let digest = showDigest (sha1 bytes)
	M.putElement (X.element "handshake" [] [X.NodeContent (X.ContentText digest)])
	result <- M.getElement
	let nameHandshake = "{jabber:component:accept}handshake"
	when (null (X.isNamed nameHandshake result)) (throwError (M.AuthenticationFailure result))

buildSecret :: Text -> Text -> ByteString
buildSecret sid password = encodeUtf8 (X.escape (Data.Text.append sid password))

showDigest :: ByteString -> Text
showDigest = Data.Text.pack . concatMap wordToHex . Data.ByteString.unpack where
	wordToHex x = [hexDig (shiftR x 4), hexDig (x .&. 0xF)]
	hexDig = intToDigit . fromIntegral