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
{-# 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.Applicative ((<|>))
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) = withNS <|> withoutNS
where
-- Hack to allow for global namespace without implementing full handling
withoutNS = X.attributeText "id" (X.Element name attrs [])
withNS = X.attributeText "{jabber:component:accept}id" (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