From 8ac3eda353868f04d4a2bfb503f3f286b1967476 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Sun, 17 Nov 2013 17:01:13 -0500
Subject: close socket on ping timeout

---
 Presence/SendMessage.hs | 2 +-
 Presence/ServerC.hs     | 4 ++--
 Presence/SocketLike.hs  | 6 ++++--
 Presence/XMPP.hs        | 5 +++++
 4 files changed, 12 insertions(+), 5 deletions(-)

diff --git a/Presence/SendMessage.hs b/Presence/SendMessage.hs
index 8b4d00f7..71b6a3bd 100644
--- a/Presence/SendMessage.hs
+++ b/Presence/SendMessage.hs
@@ -41,7 +41,7 @@ import Network.BSD
 import Network.Socket 
     ( connect
     , socketToHandle
-    , sClose
+    -- , sClose
     , Socket(..)
     , socket
     , SocketType(..)
diff --git a/Presence/ServerC.hs b/Presence/ServerC.hs
index d8cca897..0acfb20a 100644
--- a/Presence/ServerC.hs
+++ b/Presence/ServerC.hs
@@ -57,7 +57,7 @@ dummyServerHandle = do
     return (ServerHandle sock)
 
 quitListening :: ServerHandle -> IO ()
-quitListening (ServerHandle socket) = sClose socket
+quitListening (ServerHandle socket) = Socket.sClose socket
 
 
 data AcceptResult =
@@ -146,5 +146,5 @@ runConn g st (sock,_) = do
         h <- socketToHandle sock ReadWriteMode
         hSetBuffering h NoBuffering
         let doException (SomeException e) = debugStr ("\n\nexception: " ++ show e ++ "\n\n")
-        handle doException (g (restrictSocket sock `HCons` st) (packets h) (packetSink h))
+        handle doException (g (restrictHandleSocket h sock `HCons` st) (packets h) (packetSink h))
         hClose h
diff --git a/Presence/SocketLike.hs b/Presence/SocketLike.hs
index 89bd2ebc..c2f14460 100644
--- a/Presence/SocketLike.hs
+++ b/Presence/SocketLike.hs
@@ -10,8 +10,10 @@ module SocketLike
     , sIsListening
     , sIsReadable
     , sIsWritable
+    , sClose
     , RestrictedSocket
     , restrictSocket
+    , restrictHandleSocket
     , PortNumber
     , SockAddr(..)
     , CUInt
@@ -70,5 +72,5 @@ instance SocketLike RestrictedSocket where
 restrictSocket :: NS.Socket -> RestrictedSocket
 restrictSocket socket = Restricted Nothing socket
 
-restrictHandleSocket :: Maybe Handle ->  NS.Socket -> RestrictedSocket
-restrictHandleSocket mb socket = Restricted mb socket
+restrictHandleSocket :: Handle ->  NS.Socket -> RestrictedSocket
+restrictHandleSocket h socket = Restricted (Just h) socket
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 7a0bb1a2..be84e221 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -1143,8 +1143,11 @@ toPeer sock cache chan fail = do
     pingref <- liftIO $ do
                     ping_timer <- liftIO $ newDelay five_sec
                     newTVarIO (ping_timer,0::Int)
+
+    sockref <- liftIO $ atomically newEmptyTMVar
     let bump fromsock = do
             timer <- atomically $ do
+                        putTMVar sockref fromsock
                         (timer,v) <-  readTVar pingref
                         writeTVar pingref (timer,0)
                         return timer
@@ -1168,6 +1171,8 @@ toPeer sock cache chan fail = do
                     _ -> do
                             remote <- liftIO $ getPeerName sock
                             liftIO . debugL $ "PING TIMEOUT: " <++> showPeer (RemotePeer remote)
+                            fromsock <- liftIO $ atomically $ readTMVar sockref
+                            liftIO $ sClose fromsock
                             return () -- PING TIMEOUT (loop quits)
               where makePing = do
                         addr <- getSocketName sock
-- 
cgit v1.2.3