diff options
author | joe <joe@jerkface.net> | 2013-11-17 17:01:13 -0500 |
---|---|---|
committer | joe <joe@jerkface.net> | 2013-11-17 17:01:13 -0500 |
commit | 8ac3eda353868f04d4a2bfb503f3f286b1967476 (patch) | |
tree | fbb762e00cafa6426e84fc106b44fc7b76b5911e /Presence | |
parent | 1f6320c1f8a678cfe58b6327e91fbb5d24cea80d (diff) |
close socket on ping timeout
Diffstat (limited to 'Presence')
-rw-r--r-- | Presence/SendMessage.hs | 2 | ||||
-rw-r--r-- | Presence/ServerC.hs | 4 | ||||
-rw-r--r-- | Presence/SocketLike.hs | 6 | ||||
-rw-r--r-- | 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 | |||
41 | import Network.Socket | 41 | import Network.Socket |
42 | ( connect | 42 | ( connect |
43 | , socketToHandle | 43 | , socketToHandle |
44 | , sClose | 44 | -- , sClose |
45 | , Socket(..) | 45 | , Socket(..) |
46 | , socket | 46 | , socket |
47 | , SocketType(..) | 47 | , 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 | |||
57 | return (ServerHandle sock) | 57 | return (ServerHandle sock) |
58 | 58 | ||
59 | quitListening :: ServerHandle -> IO () | 59 | quitListening :: ServerHandle -> IO () |
60 | quitListening (ServerHandle socket) = sClose socket | 60 | quitListening (ServerHandle socket) = Socket.sClose socket |
61 | 61 | ||
62 | 62 | ||
63 | data AcceptResult = | 63 | data AcceptResult = |
@@ -146,5 +146,5 @@ runConn g st (sock,_) = do | |||
146 | h <- socketToHandle sock ReadWriteMode | 146 | h <- socketToHandle sock ReadWriteMode |
147 | hSetBuffering h NoBuffering | 147 | hSetBuffering h NoBuffering |
148 | let doException (SomeException e) = debugStr ("\n\nexception: " ++ show e ++ "\n\n") | 148 | let doException (SomeException e) = debugStr ("\n\nexception: " ++ show e ++ "\n\n") |
149 | handle doException (g (restrictSocket sock `HCons` st) (packets h) (packetSink h)) | 149 | handle doException (g (restrictHandleSocket h sock `HCons` st) (packets h) (packetSink h)) |
150 | hClose h | 150 | 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 | |||
10 | , sIsListening | 10 | , sIsListening |
11 | , sIsReadable | 11 | , sIsReadable |
12 | , sIsWritable | 12 | , sIsWritable |
13 | , sClose | ||
13 | , RestrictedSocket | 14 | , RestrictedSocket |
14 | , restrictSocket | 15 | , restrictSocket |
16 | , restrictHandleSocket | ||
15 | , PortNumber | 17 | , PortNumber |
16 | , SockAddr(..) | 18 | , SockAddr(..) |
17 | , CUInt | 19 | , CUInt |
@@ -70,5 +72,5 @@ instance SocketLike RestrictedSocket where | |||
70 | restrictSocket :: NS.Socket -> RestrictedSocket | 72 | restrictSocket :: NS.Socket -> RestrictedSocket |
71 | restrictSocket socket = Restricted Nothing socket | 73 | restrictSocket socket = Restricted Nothing socket |
72 | 74 | ||
73 | restrictHandleSocket :: Maybe Handle -> NS.Socket -> RestrictedSocket | 75 | restrictHandleSocket :: Handle -> NS.Socket -> RestrictedSocket |
74 | restrictHandleSocket mb socket = Restricted mb socket | 76 | 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 | |||
1143 | pingref <- liftIO $ do | 1143 | pingref <- liftIO $ do |
1144 | ping_timer <- liftIO $ newDelay five_sec | 1144 | ping_timer <- liftIO $ newDelay five_sec |
1145 | newTVarIO (ping_timer,0::Int) | 1145 | newTVarIO (ping_timer,0::Int) |
1146 | |||
1147 | sockref <- liftIO $ atomically newEmptyTMVar | ||
1146 | let bump fromsock = do | 1148 | let bump fromsock = do |
1147 | timer <- atomically $ do | 1149 | timer <- atomically $ do |
1150 | putTMVar sockref fromsock | ||
1148 | (timer,v) <- readTVar pingref | 1151 | (timer,v) <- readTVar pingref |
1149 | writeTVar pingref (timer,0) | 1152 | writeTVar pingref (timer,0) |
1150 | return timer | 1153 | return timer |
@@ -1168,6 +1171,8 @@ toPeer sock cache chan fail = do | |||
1168 | _ -> do | 1171 | _ -> do |
1169 | remote <- liftIO $ getPeerName sock | 1172 | remote <- liftIO $ getPeerName sock |
1170 | liftIO . debugL $ "PING TIMEOUT: " <++> showPeer (RemotePeer remote) | 1173 | liftIO . debugL $ "PING TIMEOUT: " <++> showPeer (RemotePeer remote) |
1174 | fromsock <- liftIO $ atomically $ readTMVar sockref | ||
1175 | liftIO $ sClose fromsock | ||
1171 | return () -- PING TIMEOUT (loop quits) | 1176 | return () -- PING TIMEOUT (loop quits) |
1172 | where makePing = do | 1177 | where makePing = do |
1173 | addr <- getSocketName sock | 1178 | addr <- getSocketName sock |