From 2eec39f7eb0f306752fa4223db2c39b517ac353e Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Mon, 18 Nov 2013 18:48:55 -0500
Subject: updates buddy list on ping timeout. TODO: send probe when in-bound
 peer connection re-appears.

---
 Presence/XMPP.hs      | 8 ++++++--
 Presence/XMPPTypes.hs | 7 ++++++-
 2 files changed, 12 insertions(+), 3 deletions(-)

(limited to 'Presence')

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index c7525159..4db055ea 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -922,12 +922,14 @@ fromPeer sock session = doNestingXML $ do
     withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
     log $ "stream atributes: " <++> bshow stream_attrs
 
+    let doTimeout = Thunk (closePeerSession session)
+
     fix $ \loop -> do
         log "waiting for stanza."
         whenJust nextElement $ \stanza -> do
             stanza_lvl <- nesting
 
-            liftIO $ sendPeerMessage session (ActivityBump sock) -- reset ping timer
+            liftIO $ sendPeerMessage session (ActivityBump doTimeout) -- reset ping timer
 
             let unhandledStanza = do
                     xs <- gatherElement stanza Seq.empty
@@ -1181,7 +1183,9 @@ toPeer sock cache chan fail = do
                             remote <- liftIO $ getPeerName sock
                             liftIO . debugL $ "PING TIMEOUT: " <++> showPeer (RemotePeer remote)
                             fromsock <- liftIO $ atomically $ readTMVar sockref
-                            liftIO $ sClose fromsock
+                            -- liftIO $ sClose fromsock
+                            liftIO $ runThunk fromsock
+
                             return () -- PING TIMEOUT (loop quits)
                     x -> error ("What? "++show x)
               where makePing = do
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index f6ffe66e..d9ebbce9 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -284,9 +284,14 @@ data OutBoundMessage = OutBoundPresence Presence
                         | Pong JID JID (Maybe Content)
                         | Unsupported JID JID (Maybe Content) XML.Name
                         | Disconnect
-                        | ActivityBump RestrictedSocket
+                        | ActivityBump Thunk
  deriving Prelude.Show
 
+newtype Thunk = Thunk { runThunk :: IO () }
+
+instance Show Thunk where
+    show s = "thunk"
+
 getNamesForPeer :: Peer -> IO [S.ByteString]
 getNamesForPeer LocalHost = fmap ((:[]) . S.pack) getHostName
 getNamesForPeer peer@(RemotePeer addr) = do
-- 
cgit v1.2.3