~singpolyma/network-protocol-xmpp

ref: 57a8932024bc67e6759cefc5be86329b4a849bff network-protocol-xmpp/Network/Protocol/XMPP/Component.hs -rw-r--r-- 4.1 KiB
57a89320 — John Millikin Merged public API into a single exposed module, 'Network.Protocol.XMPP'. 12 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
-- 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
	( Component
	, componentJID
	, componentStreamID
	, connectComponent
	) where
import Data.Bits (shiftR, (.&.))
import Data.Char (intToDigit)
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Network (connectTo)
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
import Network.Protocol.SASL.GNU (sha1)
import qualified System.IO as IO
import qualified Text.XML.LibXML.SAX as SAX

import qualified Network.Protocol.XMPP.Connections as C
import qualified Network.Protocol.XMPP.Handle as H
import qualified Network.Protocol.XMPP.Stream as S
import Network.Protocol.XMPP.XML ( getTree, putTree
                                       , element, qname
                                       , readEventsUntil
                                       )
import Network.Protocol.XMPP.JID (JID)

data Component = Component
	{ componentJID      :: JID
	, componentHandle   :: H.Handle
	, componentParser   :: SAX.Parser
	, componentStreamID :: T.Text
	}

instance S.Stream Component where
	streamNamespace _ = "jabber:component:accept"
	getTree s = getTree (componentHandle s) (componentParser s)
	putTree s = putTree (componentHandle s)

connectComponent :: C.Server
                  -> T.Text -- ^ Password
                  -> IO Component
connectComponent server password = do
	let C.Server jid host port = server
	rawHandle <- connectTo host port
	IO.hSetBuffering rawHandle IO.NoBuffering
	let handle = H.PlainHandle rawHandle
	
	stream <- beginStream jid handle
	authenticate stream password
	return stream

beginStream :: JID -> H.Handle -> IO Component
beginStream jid h = do
	parser <- SAX.mkParser
	H.hPutBytes h $ C.xmlHeader "jabber:component:accept" jid
	events <- readEventsUntil C.startOfStream h parser
	let streamID' = case parseStreamID $ last events of
		Nothing -> error "No component stream ID defined"
		Just x -> x
	return $ Component jid h parser streamID'

parseStreamID :: SAX.Event -> Maybe T.Text
parseStreamID (SAX.BeginElement _ attrs) = sid where
	sid = case idAttrs of
		(x:_) -> Just . T.pack . SAX.attributeValue $ x
		_ -> Nothing
	idAttrs = filter (matchingName . SAX.attributeName) attrs
	matchingName n = and
		[ SAX.qnameNamespace n == "jabber:component:accept"
		, SAX.qnameLocalName n == "id"
		]
parseStreamID _ = Nothing

authenticate :: Component -> T.Text -> IO ()
authenticate stream password = do
	let bytes = buildSecret (componentStreamID stream) password
	let digest = showDigest $ sha1 bytes
	S.putTree stream $ element ("", "handshake") [] [XN.mkText digest]
	result <- S.getTree stream
	let accepted = A.runLA $
		A.getChildren
		>>> A.hasQName (qname "jabber:component:accept" "handshake")
	if null (accepted result)
		then error "Component handshake failed" -- TODO: throwIO
		else return ()

buildSecret :: T.Text -> T.Text -> B.ByteString
buildSecret sid password = bytes where
	bytes = TE.encodeUtf8 $ T.pack escaped
	escaped = DOM.attrEscapeXml $ sid' ++ password'
	sid' = T.unpack sid
	password' = T.unpack password

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