1 files changed, 9 insertions, 5 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 4db055ea..55aab3d4 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -646,10 +646,12 @@ handlePeer st src snk = do
     debugL $ "(P) connected " <++> name
     session <- newPeerSession session_factory sock
 
-    finally ( src $= parseBytes def $$ fromPeer sock session )
+    didClose <- newTVarIO False
+    finally ( src $= parseBytes def $$ fromPeer sock session didClose )
         $ do 
             debugL $ "(P) disconnected " <++> name
-            closePeerSession session
+            didc <- readTVarIO didClose
+            when (not didc) $ closePeerSession session
 
 
 handlePeerPresence session stanza False = do
@@ -912,8 +914,8 @@ handlePeerIQGet session tag = do
         req -> unhandledGet req
 
 fromPeer :: (MonadThrow m,MonadIO m, JabberPeerSession session) => 
-    RestrictedSocket -> session -> Sink XML.Event m ()
-fromPeer sock session = doNestingXML $ do
+    RestrictedSocket -> session -> TVar Bool -> Sink XML.Event m ()
+fromPeer sock session didClose = doNestingXML $ do
     let log  = liftIO . debugL . ("(P) " <++>)
     withXML $ \begindoc -> do
     when (begindoc==EventBeginDocument) $ do
@@ -922,7 +924,9 @@ fromPeer sock session = doNestingXML $ do
     withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
     log $ "stream atributes: " <++> bshow stream_attrs
 
-    let doTimeout = Thunk (closePeerSession session)
+    let doTimeout = Thunk $ do 
+                        atomically $ writeTVar didClose True
+                        closePeerSession session
 
     fix $ \loop -> do
         log "waiting for stanza."