summaryrefslogtreecommitdiff
path: root/Presence
diff options
context:
space:
mode:
Diffstat (limited to 'Presence')
-rw-r--r--Presence/XMPP.hs51
1 files changed, 37 insertions, 14 deletions
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 498106b9..84035ea2 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -984,7 +984,7 @@ instance CommandCache CachedMessages where
984 cache { approvals= mmInsert (True,from) to $ approvals cache } 984 cache { approvals= mmInsert (True,from) to $ approvals cache }
985 updateCache (Rejection from to) cache = 985 updateCache (Rejection from to) cache =
986 cache { approvals= mmInsert (False,from) to $ approvals cache } 986 cache { approvals= mmInsert (False,from) to $ approvals cache }
987 updateCache (OutBoundMessage msg) cache = cache -- TODO 987 updateCache (OutBoundMessage msg) cache = cache -- TODO: cache chat?
988 updateCache (Pong _ _ _) cache = cache -- pings are not cached 988 updateCache (Pong _ _ _) cache = cache -- pings are not cached
989 updateCache (Unsupported _ _ _ _) cache = cache -- error messages are not cached 989 updateCache (Unsupported _ _ _ _) cache = cache -- error messages are not cached
990 updateCache ActivityBump cache = cache 990 updateCache ActivityBump cache = cache
@@ -1082,14 +1082,16 @@ toPeer sock cache chan fail = do
1082 sendOrFail (xmlifyPong sock from to mid) 1082 sendOrFail (xmlifyPong sock from to mid)
1083 (Pong from to mid) 1083 (Pong from to mid)
1084 where 1084 where
1085 xmlifyPong sock from to mid = 1085 xmlifyPong sock from to mid = do
1086 fromjid <- peerJidTextLocal sock to
1087 tojid <- peerJidTextRemote sock to
1086 return $ [ EventBeginElement "{jabber:server}iq" 1088 return $ [ EventBeginElement "{jabber:server}iq"
1087 $ (case mid of 1089 $ (case mid of
1088 Just c -> (("id",[c]):) 1090 Just c -> (("id",[c]):)
1089 _ -> id ) 1091 _ -> id )
1090 [ attr "type" "result" 1092 [ attr "type" "result"
1091 , attr "to" (toStrict $ L.decodeUtf8 $ L.show to) -- TODO: should send numeric address 1093 , attr "to" tojid
1092 , attr "from" (toStrict $ L.decodeUtf8 $ L.show from) -- TODO: should send numeric address 1094 , attr "from" fromjid
1093 ] 1095 ]
1094 , EventEndElement "{jabber:server}iq" 1096 , EventEndElement "{jabber:server}iq"
1095 ] 1097 ]
@@ -1097,15 +1099,17 @@ toPeer sock cache chan fail = do
1097 sendOrFail (xmlifyUnsupported sock from to mid tag) 1099 sendOrFail (xmlifyUnsupported sock from to mid tag)
1098 (Unsupported from to mid tag) 1100 (Unsupported from to mid tag)
1099 where 1101 where
1100 xmlifyUnsupported sock from to mid req = 1102 xmlifyUnsupported sock from to mid req = do
1103 fromjid <- peerJidTextLocal sock to
1104 tojid <- peerJidTextRemote sock to
1101 return $ 1105 return $
1102 [ EventBeginElement "{jabber:server}iq" 1106 [ EventBeginElement "{jabber:server}iq"
1103 $ (case mid of 1107 $ (case mid of
1104 Just c -> (("id",[c]):) 1108 Just c -> (("id",[c]):)
1105 _ -> id ) 1109 _ -> id )
1106 [("type",[ContentText "error"]) 1110 [("type",[ContentText "error"])
1107 , attr "to" (toStrict $ L.decodeUtf8 $ L.show to) -- TODO: should send numeric address 1111 , attr "to" tojid
1108 , attr "from" (toStrict $ L.decodeUtf8 $ L.show from) -- TODO: should send numeric address 1112 , attr "from" fromjid
1109 ] 1113 ]
1110 , EventBeginElement req [] 1114 , EventBeginElement req []
1111 , EventEndElement req 1115 , EventEndElement req
@@ -1136,16 +1140,35 @@ toPeer sock cache chan fail = do
1136 1140
1137 1141
1138 let five_sec = 5 * 1000000 :: Int 1142 let five_sec = 5 * 1000000 :: Int
1139 ping_timer <- liftIO $ newDelay five_sec 1143 pingref <- liftIO $ do
1140 let bump = updateDelay ping_timer five_sec 1144 ping_timer <- liftIO $ newDelay five_sec
1145 newTVarIO (ping_timer,0::Int)
1146 let bump = do
1147 timer <- atomically $ do
1148 (timer,v) <- readTVar pingref
1149 writeTVar pingref (timer,0)
1150 return timer
1151 updateDelay timer five_sec
1152 waitPing = do
1153 (timer,v) <- readTVar pingref
1154 waitDelay timer
1155 return v
1141 1156
1142 fix $ \loop -> do 1157 fix $ \loop -> do
1143 event <- lift . atomically $ orElse (Left `fmap` readTChan chan) 1158 event <- lift . atomically $ orElse (Left `fmap` readTChan chan)
1144 (Right `fmap` waitDelay ping_timer) 1159 (Right `fmap` waitPing)
1145 let sendPing () = do 1160 let sendPing n = do
1146 ping <- liftIO makePing 1161 ping_timer <- liftIO $ newDelay five_sec
1147 yield ping 1162 liftIO . atomically $ writeTVar pingref (ping_timer,1)
1148 loop 1163 case n of
1164 0 -> do
1165 ping <- liftIO makePing
1166 yield ping
1167 loop
1168 _ -> do
1169 remote <- liftIO $ getPeerName sock
1170 liftIO . debugL $ "PING TIMEOUT: " <++> showPeer (RemotePeer remote)
1171 return () -- PING TIMEOUT (loop quits)
1149 where makePing = do 1172 where makePing = do
1150 addr <- getSocketName sock 1173 addr <- getSocketName sock
1151 remote <- getPeerName sock 1174 remote <- getPeerName sock