From 2969f4f954b2f89766c3614cb8ae157b11392e44 Mon Sep 17 00:00:00 2001
From: John Millikin <jmillikin@gmail.com>
Date: Wed, 21 Apr 2010 23:25:22 +0000
Subject: [PATCH] Expose enough of the 'XMPP' monad internals for clients to
 interleave it with other IO.

---
 Network/Protocol/XMPP.hs                       |  5 +++++
 Network/Protocol/XMPP/Client.hs                |  2 +-
 Network/Protocol/XMPP/Client/Authentication.hs |  4 ++--
 Network/Protocol/XMPP/Component.hs             |  2 +-
 Network/Protocol/XMPP/Monad.hs                 | 14 +++++++-------
 5 files changed, 16 insertions(+), 11 deletions(-)

diff --git a/Network/Protocol/XMPP.hs b/Network/Protocol/XMPP.hs
index b12dd51..73f6c21 100644
--- a/Network/Protocol/XMPP.hs
+++ b/Network/Protocol/XMPP.hs
@@ -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
diff --git a/Network/Protocol/XMPP/Client.hs b/Network/Protocol/XMPP/Client.hs
index 6be1f21..3e13d60 100644
--- a/Network/Protocol/XMPP/Client.hs
+++ b/Network/Protocol/XMPP/Client.hs
@@ -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
diff --git a/Network/Protocol/XMPP/Client/Authentication.hs b/Network/Protocol/XMPP/Client/Authentication.hs
index c7acf29..7b359f4 100644
--- a/Network/Protocol/XMPP/Client/Authentication.hs
+++ b/Network/Protocol/XMPP/Client/Authentication.hs
@@ -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
diff --git a/Network/Protocol/XMPP/Component.hs b/Network/Protocol/XMPP/Component.hs
index 5ad616c..07b5f02 100644
--- a/Network/Protocol/XMPP/Component.hs
+++ b/Network/Protocol/XMPP/Component.hs
@@ -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
diff --git a/Network/Protocol/XMPP/Monad.hs b/Network/Protocol/XMPP/Monad.hs
index cd1e5fb..2120d32 100644
--- a/Network/Protocol/XMPP/Monad.hs
+++ b/Network/Protocol/XMPP/Monad.hs
@@ -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
-- 
2.38.4