Component.hs

-- 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.IO.Class (liftIO)
import qualified Control.Monad.Trans.Except as E
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 qualified System.IO as IO
import qualified Network.Protocol.TLS.GNU as TLS (DigestAlgorithm(SHA1), hash)

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)
import           Network.Protocol.XMPP.String (s)

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 <- C.connectTo host port
	IO.hSetBuffering rawHandle IO.NoBuffering
	let handle = H.PlainHandle rawHandle
	M.startXMPP handle (s"jabber:component:accept") $ do
		streamID <- beginStream jid
		authenticate streamID password
		xmpp

beginStream :: JID -> M.XMPP Text
beginStream jid = do
	M.putBytes $ C.xmlHeader (s"jabber:component:accept") jid
	events <- M.readEvents C.startOfStream
	case parseStreamID $ last events of
		Nothing -> M.throwE 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 (s"id") (X.Element name attrs [])
	withNS = X.attributeText (s"{jabber:component:accept}id") (X.Element name attrs [])
parseStreamID _ = Nothing

authenticate :: Text -> Text -> M.XMPP ()
authenticate streamID password = do
	let bytes = buildSecret streamID password
	msha1 <- liftIO $ E.runExceptT $ TLS.hash TLS.SHA1 bytes
        case msha1 of
		Left e -> M.throwE (M.AuthenticationError (Data.Text.pack $ show e))
                Right sha1 -> do
			let digest = showDigest sha1
			M.putElement (X.element (s"handshake") [] [X.NodeContent (X.ContentText digest)])
			result <- M.getElement
			let nameHandshake = s"{jabber:component:accept}handshake"
			when (null (X.isNamed nameHandshake result)) (M.throwE (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