~singpolyma/network-protocol-xmpp: Network/Protocol/XMPP/Component.hs - sourcehut git


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

{-# LANGUAGE OverloadedStrings #-}
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 as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as TE
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
             -> T.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 T.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.SaxEvent -> Maybe T.Text
parseStreamID (X.BeginElement _ attrs) = sid where
	sid = case idAttrs of
		(x:_) -> Just . X.attributeText $ x
		_ -> Nothing
	idAttrs = filter (matchingName . X.attributeName) attrs
	matchingName = (== X.Name "jid" (Just "jabber:component:accept") Nothing)
parseStreamID _ = Nothing

authenticate :: T.Text -> T.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 = X.Name "handshake" (Just "jabber:component:accept") Nothing
	when (null (X.isNamed nameHandshake result)) $
		throwError M.AuthenticationFailure

buildSecret :: T.Text -> T.Text -> B.ByteString
buildSecret sid password = B.concat . BL.toChunks $ bytes where
	bytes = TE.encodeUtf8 $ X.escape $ T.append sid password

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