~singpolyma/network-protocol-xmpp

2969f4f954b2f89766c3614cb8ae157b11392e44 — John Millikin 12 years ago 7dc0aed
Expose enough of the 'XMPP' monad internals for clients to interleave it with other IO.
M Network/Protocol/XMPP.hs => Network/Protocol/XMPP.hs +5 -0
@@ 59,6 59,11 @@ module Network.Protocol.XMPP
	, putStanza
	, getStanza
	, bindJID
	
	-- ** Context hook
	, Context
	, getContext
	, runXMPP
	) where
import Network.Protocol.XMPP.Client
import Network.Protocol.XMPP.Component

M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +1 -1
@@ 52,7 52,7 @@ runClient server jid username password xmpp = do
	let handle = H.PlainHandle rawHandle
	
	-- Open the initial stream and authenticate
	M.runXMPP handle "jabber:client" $ do
	M.startXMPP handle "jabber:client" $ do
		features <- newStream sjid
		let mechanisms = authenticationMechanisms features
		tryTLS features $ do

M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +2 -2
@@ 122,14 122,14 @@ saslFinish ctx = liftIO $ do

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

M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +1 -1
@@ 50,7 50,7 @@ runComponent server password xmpp = do
	rawHandle <- connectTo host port
	IO.hSetBuffering rawHandle IO.NoBuffering
	let handle = H.PlainHandle rawHandle
	M.runXMPP handle "jabber:component:accept" $ do
	M.startXMPP handle "jabber:component:accept" $ do
		streamID <- beginStream jid
		authenticate streamID password
		xmpp

M Network/Protocol/XMPP/Monad.hs => Network/Protocol/XMPP/Monad.hs +7 -7
@@ 19,7 19,7 @@ module Network.Protocol.XMPP.Monad
	, Error (..)
	, Context (..)
	, runXMPP
	, continueXMPP
	, startXMPP
	, restartXMPP
	
	, getHandle


@@ 70,13 70,13 @@ instance E.MonadError XMPP where
	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
runXMPP :: Context -> XMPP a -> IO (Either Error a)
runXMPP ctx xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) ctx

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

restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a
restartXMPP newH xmpp = do