~singpolyma/network-protocol-xmpp

92b4b6e3881776844bffc98dd114b252ce248191 — John Millikin 13 years ago 1ac20f9
Define the 'XMPP' monad, so clients don't have to pass a stream around.
M Network/Protocol/XMPP.hs => Network/Protocol/XMPP.hs +8 -19
@@ 50,29 50,18 @@ module Network.Protocol.XMPP
	, emptyPresence
	, emptyIQ
	
	-- * Streams
	, Stream
	-- * The XMPP monad
	, Server (..)
	, XMPP
	, runClient
	, runComponent
	, putStanza
	, getStanza
	
	-- * Connecting to a server
	, Server (..)
	
	-- ** Clients
	, Client
	, connectClient
	, clientJID
	, bindClient
	
	-- ** Components
	, Component
	, connectComponent
	, componentJID
	, componentStreamID
	, bindJID
	) where
import Network.Protocol.XMPP.JID
import Network.Protocol.XMPP.Client
import Network.Protocol.XMPP.Component
import Network.Protocol.XMPP.Connections
import Network.Protocol.XMPP.Stream
import Network.Protocol.XMPP.JID
import Network.Protocol.XMPP.Monad
import Network.Protocol.XMPP.Stanza

M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +56 -90
@@ 15,11 15,11 @@

{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Client
	( Client
	, clientJID
	, connectClient
	, bindClient
	( runClient
	, bindJID
	) where
import Control.Monad.Error (throwError)
import Control.Monad.Trans (liftIO)
import Network (connectTo)
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A


@@ 28,48 28,23 @@ import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified System.IO as IO
import Data.ByteString (ByteString)
import qualified Data.Text as T
import qualified Text.XML.LibXML.SAX as SAX

import qualified Network.Protocol.XMPP.Client.Authentication as A
import qualified Network.Protocol.XMPP.Connections as C
import qualified Network.Protocol.XMPP.Client.Features as F
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 qualified Network.Protocol.XMPP.JID as J
import qualified Network.Protocol.XMPP.Monad as M
import Network.Protocol.XMPP.XML (element, qname, readEventsUntil)
import Network.Protocol.XMPP.Stanza

data Client = Client
	{ clientJID    :: J.JID
	, clientStream :: ClientStream
	}

data ClientStream = ClientStream
	{ streamJID      :: J.JID
	, streamHandle   :: H.Handle
	, streamFeatures :: [F.Feature]
	, streamParser   :: SAX.Parser
	}

instance S.Stream Client where
	streamNamespace _ = "jabber:client"
	getTree = S.getTree . clientStream
	putTree = S.putTree . clientStream

instance S.Stream ClientStream where
	streamNamespace _ = "jabber:client"
	getTree s = getTree (streamHandle s) (streamParser s)
	putTree s = putTree (streamHandle s)

connectClient :: C.Server
              -> J.JID -- ^ Client JID
              -> T.Text -- ^ Username
              -> T.Text -- ^ Password
              -> IO Client
connectClient server jid username password = do
runClient :: C.Server
          -> J.JID -- ^ Client JID
          -> T.Text -- ^ Username
          -> T.Text -- ^ Password
          -> M.XMPP a
          -> IO (Either M.Error a)
runClient server jid username password xmpp = do
	-- Open a TCP connection
	let C.Server sjid host port = server
	rawHandle <- connectTo host port


@@ 77,41 52,50 @@ connectClient server jid username password = do
	let handle = H.PlainHandle rawHandle
	
	-- Open the initial stream and authenticate
	stream <- beginStream sjid handle
	authedStream <- authenticate stream jid sjid username password
	return $ Client jid authedStream

authenticate :: ClientStream -> J.JID -> J.JID -> T.Text -> T.Text -> IO ClientStream
authenticate stream jid sjid username password = do
	let mechanisms = authenticationMechanisms stream
	result <- A.authenticate stream mechanisms jid sjid username password
	case result of
		-- TODO: throwIO some exception type?
		A.Failure -> error "Authentication failure"
		_ -> restartStream stream

authenticationMechanisms :: ClientStream -> [ByteString]
authenticationMechanisms = step . streamFeatures where
	M.runXMPP handle "jabber:client" $ do
		features <- newStream sjid
		let mechanisms = authenticationMechanisms features
		tryTLS features $ do
			A.authenticate mechanisms jid sjid username password
			M.restartXMPP Nothing xmpp

newStream :: J.JID -> M.XMPP [F.Feature]
newStream jid = do
	M.Context h _ sax <- M.getContext
	liftIO $ H.hPutBytes h $ C.xmlHeader "jabber:client" jid
	liftIO $ readEventsUntil C.startOfStream h sax
	F.parseFeatures `fmap` M.getTree

tryTLS :: [F.Feature] -> M.XMPP a -> M.XMPP a
tryTLS features m
	| not (streamSupportsTLS features) = m
	| otherwise = do
		M.putTree xmlStartTLS
		M.getTree
		h <- M.getHandle
		tls <- liftIO $ H.startTLS h
		M.restartXMPP (Just tls) m

authenticationMechanisms :: [F.Feature] -> [ByteString]
authenticationMechanisms = step where
	step [] = []
	step (f:fs) = case f of
		(F.FeatureSASL ms) -> ms
		_ -> step fs

bindClient :: Client -> IO J.JID
bindClient c = do
bindJID :: J.JID -> M.XMPP J.JID
bindJID jid = do
	-- Bind
	S.putStanza c $ bindStanza . J.jidResource . clientJID $ c
	bindResult <- S.getStanza c
	M.putStanza . bindStanza . J.jidResource $ jid
	bindResult <- M.getStanza
	
	let jidArrow =
		A.deep (A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-bind" "jid"))
		>>> A.getChildren
		>>> A.getText
	
	-- TODO: throwIO with exception
	let Just jid = do
		result <- bindResult
		iq <- case result of
	let maybeJID = do
		iq <- case bindResult of
			ReceivedIQ x -> Just x
			_ -> Nothing
		


@@ 119,14 103,18 @@ bindClient c = do
			[] -> Nothing
			(str:_) -> J.parseJID (T.pack str)
	
	returnedJID <- case maybeJID of
		Just x -> return x
		Nothing -> throwError $ M.InvalidBindResult bindResult
	
	-- Session
	S.putStanza c sessionStanza
	S.getStanza c
	M.putStanza sessionStanza
	M.getStanza
	
	S.putStanza c $ emptyPresence PresenceAvailable
	S.getStanza c
	M.putStanza $ emptyPresence PresenceAvailable
	M.getStanza
	
	return jid
	return returnedJID

bindStanza :: Maybe J.Resource -> IQ
bindStanza resource = emptyIQ IQSet payload where


@@ 144,30 132,8 @@ sessionStanza = emptyIQ IQSet $ element ("", "session")
	[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-session")]
	[]

beginStream :: J.JID -> H.Handle -> IO ClientStream
beginStream jid handle = do
	plain <- newStream jid handle
	if streamSupportsTLS plain
		then do
			S.putTree plain xmlStartTLS
			S.getTree plain
			H.startTLS handle >>= newStream jid
		else return plain

restartStream :: ClientStream -> IO ClientStream
restartStream s = newStream (streamJID s) (streamHandle s)

newStream :: J.JID -> H.Handle -> IO ClientStream
newStream jid h = do
	parser <- SAX.mkParser
	H.hPutBytes h $ C.xmlHeader "jabber:client" jid
	readEventsUntil C.startOfStream h parser
	features <- F.parseFeatures `fmap` getTree h parser
	
	return $ ClientStream jid h features parser

streamSupportsTLS :: ClientStream -> Bool
streamSupportsTLS = any isStartTLS . streamFeatures where
streamSupportsTLS :: [F.Feature] -> Bool
streamSupportsTLS = any isStartTLS where
	isStartTLS (F.FeatureStartTLS _) = True
	isStartTLS _                     = False


M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +74 -37
@@ 13,46 13,67 @@
-- 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 #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Network.Protocol.XMPP.Client.Authentication
	( Result(..)
	( Result (..)
	, authenticate
	) where
import Control.Monad.IO.Class (liftIO)
import qualified Control.Exception as Exc
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Monad.Error as E
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Typeable (Typeable)

import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.XmlNode as XN
import Text.XML.HXT.DOM.Interface (XmlTree)
import qualified Network.Protocol.SASL.GNU as SASL

import qualified Network.Protocol.XMPP.Monad as M
import Network.Protocol.XMPP.JID (JID, formatJID)
import Network.Protocol.XMPP.XML (element, qname)
import qualified Network.Protocol.XMPP.Stream as S

data Result = Success | Failure
	deriving (Show, Eq)

authenticate :: S.Stream stream => stream
             -> [B.ByteString] -- ^ Mechanisms
data AuthException = XmppError M.Error | SaslError T.Text
	deriving (Typeable, Show)

instance Exc.Exception AuthException

authenticate :: [B.ByteString] -- ^ Mechanisms
             -> JID -- ^ User JID
             -> JID -- ^ Server JID
             -> T.Text -- ^ Username
             -> T.Text -- ^ Password
             -> IO Result
authenticate stream mechanisms userJID serverJID username password = do
	let authz = formatJID userJID
	let hostname = formatJID serverJID
	let utf8 = TE.encodeUtf8
             -> M.XMPP ()
authenticate xmppMechanisms userJID serverJID username password = xmpp where
	mechanisms = map SASL.Mechanism xmppMechanisms
	authz = formatJID userJID
	hostname = formatJID serverJID
	utf8 = TE.encodeUtf8
	
	xmpp = do
		ctx <- M.getContext
		res <- liftIO $ Exc.try $ SASL.runSASL $ do
			suggested <- SASL.clientSuggestMechanism mechanisms
			case suggested of
				Nothing -> saslError "No supported authentication mechanism"
				Just mechanism -> authSasl ctx mechanism
		case res of
			Right Success -> return ()
			Right Failure -> E.throwError $ M.AuthenticationFailure
			Left (XmppError err) -> E.throwError err
			Left (SaslError err) -> E.throwError $ M.AuthenticationError err
	
	SASL.runSASL $ do
		suggested <- SASL.clientSuggestMechanism $ map SASL.Mechanism mechanisms
		mechanism <- case suggested of
			Just m -> return m
			Nothing -> error "No supported SASL mechanisms advertised"
	authSasl ctx mechanism = do
		let (SASL.Mechanism mechBytes) = mechanism
		result <- SASL.runClient mechanism $ do
		sessionResult <- SASL.runClient mechanism $ do
			SASL.setProperty SASL.PropertyAuthzID $ utf8 authz
			SASL.setProperty SASL.PropertyAuthID $ utf8 username
			SASL.setProperty SASL.PropertyPassword $ utf8 password


@@ 60,42 81,58 @@ authenticate stream mechanisms userJID serverJID username password = do
			SASL.setProperty SASL.PropertyHostname $ utf8 hostname
			
			(b64text, rc) <- SASL.step64 $ B.pack ""
			liftIO $ S.putTree stream $ element ("", "auth")
			putTree ctx $ element ("", "auth")
				[ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")
				, ("", "mechanism", B.unpack mechBytes)]
				[XN.mkText $ B.unpack b64text]
			
			case rc of
				SASL.Complete -> liftIO $ saslFinish stream
				SASL.NeedsMore -> saslLoop stream
		case result of
				SASL.Complete -> saslFinish ctx
				SASL.NeedsMore -> saslLoop ctx
			
		case sessionResult of
			Right x -> return x
			Left err -> error $ show err
			Left err -> saslError $ T.pack $ show err

saslLoop :: S.Stream s => s -> SASL.Session Result
saslLoop stream = do
saslLoop :: M.Context -> SASL.Session Result
saslLoop ctx = do
	challengeText <- liftIO $ A.runX (
		A.arrIO (\_ -> S.getTree stream)
		A.arrIO (\_ -> getTree ctx)
		>>> A.getChildren
		>>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "challenge")
		>>> A.getChildren >>> A.getText)
	when (null challengeText) $ saslError "Received empty challenge"
	
	if null challengeText
		then return Failure
		else do
			(b64text, rc) <- SASL.step64 $ B.pack $ concat challengeText
			liftIO $ S.putTree stream $ element ("", "response")
				[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")]
				[XN.mkText $ B.unpack b64text]
			case rc of
				SASL.Complete -> liftIO $ saslFinish stream
				SASL.NeedsMore -> saslLoop stream
	(b64text, rc) <- SASL.step64 $ B.pack $ concat challengeText
	putTree ctx $ element ("", "response")
		[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")]
		[XN.mkText $ B.unpack b64text]
	case rc of
		SASL.Complete -> saslFinish ctx
		SASL.NeedsMore -> saslLoop ctx

saslFinish :: S.Stream s => s -> IO Result
saslFinish stream = do
saslFinish :: M.Context -> SASL.Session Result
saslFinish ctx = liftIO $ do
	successElem <- A.runX (
		A.arrIO (\_ -> S.getTree stream)
		A.arrIO (\_ -> getTree ctx)
		>>> A.getChildren
		>>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "success"))
	
	return $ if null successElem then Failure else Success

putTree :: M.Context -> XmlTree -> SASL.Session ()
putTree ctx tree = liftIO $ do
	res <- M.continueXMPP ctx $ M.putTree tree
	case res of
		Left err -> Exc.throwIO $ XmppError err
		Right x -> return x

getTree :: M.Context -> IO XmlTree
getTree ctx = do
	res <- M.continueXMPP ctx $ M.getTree
	case res of
		Left err -> Exc.throwIO $ XmppError err
		Right x -> return x

saslError :: MonadIO m => T.Text -> m a
saslError = liftIO . Exc.throwIO . SaslError

M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +28 -44
@@ 16,12 16,11 @@

{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Component
	( Component
	, componentJID
	, componentStreamID
	, connectComponent
	( runComponent
	) where
import Control.Monad (when)
import Control.Monad.Error (throwError)
import Control.Monad.Trans (liftIO)
import Data.Bits (shiftR, (.&.))
import Data.Char (intToDigit)
import qualified Data.ByteString as B


@@ 38,47 37,32 @@ 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 qualified Network.Protocol.XMPP.Monad as M
import Network.Protocol.XMPP.XML (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
runComponent :: C.Server
             -> T.Text -- ^ Password
             -> 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
	
	stream <- beginStream jid handle
	authenticate stream password
	return stream
	M.runXMPP handle "jabber:component:accept" $ do
		streamID <- beginStream jid
		authenticate streamID password
		xmpp

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'
beginStream :: JID -> M.XMPP T.Text
beginStream jid = do
	M.Context h _ sax <- M.getContext
	liftIO $ H.hPutBytes h $ C.xmlHeader "jabber:component:accept" jid
	events <- liftIO $ readEventsUntil C.startOfStream h sax
	case parseStreamID $ last events of
		Nothing -> throwError M.NoComponentStreamID
		Just x -> return x

parseStreamID :: SAX.Event -> Maybe T.Text
parseStreamID (SAX.BeginElement _ attrs) = sid where


@@ 92,17 76,17 @@ parseStreamID (SAX.BeginElement _ attrs) = sid where
		]
parseStreamID _ = Nothing

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

buildSecret :: T.Text -> T.Text -> B.ByteString
buildSecret sid password = bytes where

A Network/Protocol/XMPP/ErrorT.hs => Network/Protocol/XMPP/ErrorT.hs +66 -0
@@ 0,0 1,66 @@
-- 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 TypeFamilies #-}
module Network.Protocol.XMPP.ErrorT
	( ErrorT (..)
	, mapErrorT
	) where

import Control.Monad (liftM)
import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Trans.Class (MonadTrans, lift)
import qualified Control.Monad.Error as E
import qualified Control.Monad.Reader as R

-- A custom version of ErrorT, without the 'Error' class restriction.

newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }

instance Functor m => Functor (ErrorT e m) where
	fmap f = ErrorT . fmap (fmap f) . runErrorT

instance Monad m => Monad (ErrorT e m) where
	return = ErrorT . return . Right
	(>>=) m k = ErrorT $ do
		x <- runErrorT m
		case x of
			Left l -> return $ Left l
			Right r -> runErrorT $ k r

instance Monad m => E.MonadError (ErrorT e m) where
	type E.ErrorType (ErrorT e m) = e
	throwError = ErrorT . return . Left
	catchError m h = ErrorT $ do
		x <- runErrorT m
		case x of
			Left l -> runErrorT $ h l
			Right r -> return $ Right r

instance MonadTrans (ErrorT e) where
	lift = ErrorT . liftM Right

instance R.MonadReader m => R.MonadReader (ErrorT e m) where
	type R.EnvType (ErrorT e m) = R.EnvType m
	ask = lift R.ask
	local = mapErrorT . R.local

instance MonadIO m => MonadIO (ErrorT e m) where
	liftIO = lift . liftIO

mapErrorT :: (m (Either e a) -> n (Either e' b))
           -> ErrorT e m a
           -> ErrorT e' n b
mapErrorT f m = ErrorT $ f (runErrorT m)

A Network/Protocol/XMPP/Monad.hs => Network/Protocol/XMPP/Monad.hs +115 -0
@@ 0,0 1,115 @@
-- 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 TypeFamilies #-}
module Network.Protocol.XMPP.Monad
	( XMPP (..)
	, Error (..)
	, Context (..)
	, runXMPP
	, continueXMPP
	, restartXMPP
	
	, getHandle
	, getContext
	
	, putTree
	, getTree
	
	, putStanza
	, getStanza
	) where
import Control.Monad.Trans (MonadIO, liftIO)
import qualified Control.Monad.Error as E
import qualified Control.Monad.Reader as R
import Data.Text (Text)
import Text.XML.HXT.DOM.Interface (XmlTree)
import qualified Text.XML.LibXML.SAX as SAX
import Network.Protocol.XMPP.ErrorT
import qualified Network.Protocol.XMPP.Handle as H
import qualified Network.Protocol.XMPP.Stanza as S
import qualified Network.Protocol.XMPP.XML as X

data Error
	= InvalidStanza XmlTree
	| InvalidBindResult S.ReceivedStanza
	| AuthenticationFailure
	| AuthenticationError Text
	| NoComponentStreamID
	| ComponentHandshakeFailed
	deriving (Show)

data Context = Context H.Handle Text SAX.Parser

newtype XMPP a = XMPP { unXMPP :: ErrorT Error (R.ReaderT Context IO) a }

instance Functor XMPP where
	fmap f = XMPP . fmap f . unXMPP

instance Monad XMPP where
	return = XMPP . return
	m >>= f = XMPP $ unXMPP m >>= unXMPP . f

instance MonadIO XMPP where
	liftIO = XMPP . liftIO

instance E.MonadError XMPP where
	type E.ErrorType XMPP = Error
	throwError = XMPP . E.throwError
	catchError m h = XMPP $ E.catchError (unXMPP m) (unXMPP . h)

runXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a)
runXMPP h ns xmpp = do
	sax <- SAX.mkParser
	continueXMPP (Context h ns sax) xmpp

continueXMPP :: Context -> XMPP a -> IO (Either Error a)
continueXMPP ctx xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) ctx

restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a
restartXMPP newH xmpp = do
	Context oldH ns _ <- getContext
	sax <- liftIO $ SAX.mkParser
	let ctx = Context (maybe oldH id newH) ns sax
	XMPP $ R.local (const ctx) (unXMPP xmpp)

getContext :: XMPP Context
getContext = XMPP R.ask

getHandle :: XMPP H.Handle
getHandle = do
	Context h _ _ <- getContext
	return h

putTree :: XmlTree -> XMPP ()
putTree t = do
	h <- getHandle
	liftIO $ X.putTree h t

getTree :: XMPP XmlTree
getTree = do
	Context h _ sax <- getContext
	liftIO $ X.getTree h sax

putStanza :: S.Stanza a => a -> XMPP ()
putStanza = putTree . S.stanzaToTree

getStanza :: XMPP S.ReceivedStanza
getStanza = do
	tree <- getTree
	Context _ ns _ <- getContext
	case S.treeToStanza ns tree of
		Just x -> return x
		Nothing -> E.throwError $ InvalidStanza tree

M Network/Protocol/XMPP/Stanza.hs => Network/Protocol/XMPP/Stanza.hs +4 -1
@@ 28,7 28,6 @@ module Network.Protocol.XMPP.Stanza
	, emptyPresence
	, emptyIQ
	
	, stanzaToTree
	, treeToStanza
	) where



@@ 52,6 51,7 @@ data ReceivedStanza
	= ReceivedMessage Message
	| ReceivedPresence Presence
	| ReceivedIQ IQ
	deriving (Show)

data Message = Message
	{ messageType     :: MessageType


@@ 61,6 61,7 @@ data Message = Message
	, messageLang     :: Maybe T.Text
	, messagePayloads :: [XmlTree]
	}
	deriving (Show)

instance Stanza Message where
	stanzaTo = messageTo


@@ 102,6 103,7 @@ data Presence = Presence
	, presenceLang     :: Maybe T.Text
	, presencePayloads :: [XmlTree]
	}
	deriving (Show)

instance Stanza Presence where
	stanzaTo = presenceTo


@@ 149,6 151,7 @@ data IQ = IQ
	, iqLang    :: Maybe T.Text
	, iqPayload :: XmlTree
	}
	deriving (Show)

instance Stanza IQ where
	stanzaTo = iqTo

D Network/Protocol/XMPP/Stream.hs => Network/Protocol/XMPP/Stream.hs +0 -34
@@ 1,34 0,0 @@
-- 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/>.

module Network.Protocol.XMPP.Stream
	( Stream (..)
	, putStanza
	, getStanza
	) where
import qualified Data.Text as T
import Text.XML.HXT.DOM.Interface (XmlTree)
import qualified Network.Protocol.XMPP.Stanza as S

class Stream a where
	streamNamespace :: a -> T.Text
	putTree :: a -> XmlTree -> IO ()
	getTree :: a -> IO XmlTree

putStanza :: (Stream stream, S.Stanza stanza) => stream -> stanza -> IO ()
putStanza stream = putTree stream . S.stanzaToTree

getStanza :: Stream stream => stream -> IO (Maybe S.ReceivedStanza)
getStanza stream = S.treeToStanza (streamNamespace stream) `fmap` getTree stream

M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +3 -1
@@ 31,6 31,7 @@ library
    , gsasl >= 0.3 && < 0.4
    , network >= 2.2 && < 2.3
    , transformers >= 0.2 && < 0.3
    , monads-tf >= 0.1 && < 0.2

  exposed-modules:
    Network.Protocol.XMPP


@@ 41,8 42,9 @@ library
    Network.Protocol.XMPP.Client.Features
    Network.Protocol.XMPP.Component
    Network.Protocol.XMPP.Connections
    Network.Protocol.XMPP.ErrorT
    Network.Protocol.XMPP.Handle
    Network.Protocol.XMPP.JID
    Network.Protocol.XMPP.Monad
    Network.Protocol.XMPP.Stanza
    Network.Protocol.XMPP.Stream
    Network.Protocol.XMPP.XML