-- 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 #-}moduleNetwork.Protocol.XMPP.Component(runComponent)whereimportControl.Monad(when)importControl.Monad.Error(throwError)importData.Bits(shiftR,(.&.))importData.Char(intToDigit)importqualifiedData.ByteStringasBimportqualifiedData.ByteString.LazyasBLimportqualifiedData.Text.LazyasTimportqualifiedData.Text.Lazy.EncodingasTEimportNetwork(connectTo)importNetwork.Protocol.SASL.GNU(sha1)importqualifiedSystem.IOasIOimportqualifiedNetwork.Protocol.XMPP.ConnectionsasCimportqualifiedNetwork.Protocol.XMPP.HandleasHimportqualifiedNetwork.Protocol.XMPP.MonadasMimportqualifiedNetwork.Protocol.XMPP.XMLasXimportNetwork.Protocol.XMPP.JID(JID)runComponent::C.Server->T.Text-- ^ Server secret->M.XMPPa->IO(EitherM.Errora)runComponentserverpasswordxmpp=doletC.Serverjidhostport=serverrawHandle<-connectTohostportIO.hSetBufferingrawHandleIO.NoBufferinglethandle=H.PlainHandlerawHandleM.startXMPPhandle"jabber:component:accept"$dostreamID<-beginStreamjidauthenticatestreamIDpasswordxmppbeginStream::JID->M.XMPPT.TextbeginStreamjid=doM.putBytes$C.xmlHeader"jabber:component:accept"jidevents<-M.readEventsC.startOfStreamcaseparseStreamID$lasteventsofNothing->throwErrorM.NoComponentStreamIDJustx->returnxparseStreamID::X.SaxEvent->MaybeT.TextparseStreamID(X.BeginElement_attrs)=sidwheresid=caseidAttrsof(x:_)->Just.X.attributeText$x_->NothingidAttrs=filter(matchingName.X.attributeName)attrsmatchingName=(==X.Name"jid"(Just"jabber:component:accept")Nothing)parseStreamID_=Nothingauthenticate::T.Text->T.Text->M.XMPP()authenticatestreamIDpassword=doletbytes=buildSecretstreamIDpasswordletdigest=showDigest$sha1bytesM.putElement$X.element"handshake"[][X.NodeContent$X.ContentTextdigest]result<-M.getElementletnameHandshake=X.Name"handshake"(Just"jabber:component:accept")Nothingwhen(null(X.isNamednameHandshakeresult))$throwErrorM.AuthenticationFailurebuildSecret::T.Text->T.Text->B.ByteStringbuildSecretsidpassword=B.concat.BL.toChunks$byteswherebytes=TE.encodeUtf8$X.escape$T.appendsidpasswordshowDigest::B.ByteString->T.TextshowDigest=T.pack.concatMapwordToHex.B.unpackwherewordToHexx=[hexDig$shiftRx4,hexDig$x.&.0xF]hexDig=intToDigit.fromIntegral