summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--xmppServer.hs29
1 files changed, 17 insertions, 12 deletions
diff --git a/xmppServer.hs b/xmppServer.hs
index 8601d72b..11de871d 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -96,7 +96,7 @@ data PresenceState = PresenceState
96 , clientsByUser :: TVar (Map Text PresenceContainer) 96 , clientsByUser :: TVar (Map Text PresenceContainer)
97 , associatedPeers :: TVar (Map SockAddr ()) 97 , associatedPeers :: TVar (Map SockAddr ())
98 , server :: TMVar XMPPServer 98 , server :: TMVar XMPPServer
99 , writeTos :: TVar (Map ConnectionKey Conn) 99 , keyToChan :: TVar (Map ConnectionKey Conn)
100 } 100 }
101 101
102 102
@@ -211,11 +211,11 @@ data Conn = Conn { connChan :: TChan Stanza
211 , auxAddr :: SockAddr } 211 , auxAddr :: SockAddr }
212 212
213newConn state k addr outchan = 213newConn state k addr outchan =
214 atomically $ modifyTVar' (writeTos state) 214 atomically $ modifyTVar' (keyToChan state)
215 $ Map.insert k Conn { connChan = outchan 215 $ Map.insert k Conn { connChan = outchan
216 , auxAddr = addr } 216 , auxAddr = addr }
217 217
218eofConn state k = atomically $ modifyTVar' (writeTos state) $ Map.delete k 218eofConn state k = atomically $ modifyTVar' (keyToChan state) $ Map.delete k
219 219
220rewriteJIDForClient1:: Text -> IO (Maybe ((Maybe Text,Text,Maybe Text),SockAddr)) 220rewriteJIDForClient1:: Text -> IO (Maybe ((Maybe Text,Text,Maybe Text),SockAddr))
221rewriteJIDForClient1 jid = do 221rewriteJIDForClient1 jid = do
@@ -285,7 +285,7 @@ deliverMessage state fail msg =
285 mto 285 mto
286 $ \(to',addr) -> do 286 $ \(to',addr) -> do
287 let k = PeerKey addr 287 let k = PeerKey addr
288 chans <- atomically $ readTVar (writeTos state) 288 chans <- atomically $ readTVar (keyToChan state)
289 flip (maybe fail) (Map.lookup k chans) $ \(Conn { connChan=chan 289 flip (maybe fail) (Map.lookup k chans) $ \(Conn { connChan=chan
290 , auxAddr=laddr }) -> do 290 , auxAddr=laddr }) -> do
291 (n,r) <- forClient state senderk (return (Nothing,Nothing)) 291 (n,r) <- forClient state senderk (return (Nothing,Nothing))
@@ -296,8 +296,8 @@ deliverMessage state fail msg =
296 let dup = (msg { stanzaTo=Just to', stanzaFrom=Just from' }) 296 let dup = (msg { stanzaTo=Just to', stanzaFrom=Just from' })
297 sendModifiedStanzaToPeer dup chan 297 sendModifiedStanzaToPeer dup chan
298 NetworkOrigin senderk@(PeerKey {}) _ -> do 298 NetworkOrigin senderk@(PeerKey {}) _ -> do
299 chans <- atomically $ readTVar (writeTos state) 299 key_to_chan <- atomically $ readTVar (keyToChan state)
300 flip (maybe fail) (Map.lookup senderk chans) 300 flip (maybe fail) (Map.lookup senderk key_to_chan)
301 $ \(Conn { connChan=sender_chan 301 $ \(Conn { connChan=sender_chan
302 , auxAddr=laddr }) -> do 302 , auxAddr=laddr }) -> do
303 flip (maybe fail) (stanzaTo msg) $ \to -> do 303 flip (maybe fail) (stanzaTo msg) $ \to -> do
@@ -312,11 +312,16 @@ deliverMessage state fail msg =
312 flip (maybe fail) n $ \n -> do 312 flip (maybe fail) n $ \n -> do
313 flip (maybe fail) (Map.lookup n cmap) $ \presence_container -> do 313 flip (maybe fail) (Map.lookup n cmap) $ \presence_container -> do
314 let ks = Map.keys (networkClients presence_container) 314 let ks = Map.keys (networkClients presence_container)
315 cs = mapMaybe (flip Map.lookup chans) ks 315 chans = mapMaybe (flip Map.lookup key_to_chan) ks
316 if null cs then fail 316 if null chans then fail else do
317 else do 317 forM_ chans $ \Conn { connChan=chan} -> do
318 forM_ cs $ \Conn { connChan=chan} -> do
319 putStrLn $ "sending "++show (stanzaId msg)++" to clients "++show ks 318 putStrLn $ "sending "++show (stanzaId msg)++" to clients "++show ks
319 -- TODO: Cloning isn't really neccessary unless there are multiple
320 -- destinations and we should probably transition to minimal cloning,
321 -- or else we should distinguish between announcable stanzas and
322 -- consumable stanzas and announcables use write-only broadcast
323 -- channels that must be cloned in order to be consumed.
324 -- For now, we are doing redundant cloning.
320 dup <- cloneStanza (msg { stanzaTo=Just to' 325 dup <- cloneStanza (msg { stanzaTo=Just to'
321 , stanzaFrom=from' }) 326 , stanzaFrom=from' })
322 sendModifiedStanzaToClient dup 327 sendModifiedStanzaToClient dup
@@ -329,12 +334,12 @@ main = runResourceT $ do
329 clientsByUser <- newTVar Map.empty 334 clientsByUser <- newTVar Map.empty
330 associatedPeers <- newTVar Map.empty 335 associatedPeers <- newTVar Map.empty
331 xmpp <- newEmptyTMVar 336 xmpp <- newEmptyTMVar
332 writeTos <- newTVar Map.empty 337 keyToChan <- newTVar Map.empty
333 return PresenceState 338 return PresenceState
334 { clients = clients 339 { clients = clients
335 , clientsByUser = clientsByUser 340 , clientsByUser = clientsByUser
336 , associatedPeers = associatedPeers 341 , associatedPeers = associatedPeers
337 , writeTos = writeTos 342 , keyToChan = keyToChan
338 , server = xmpp 343 , server = xmpp
339 } 344 }
340 sv <- xmppServer 345 sv <- xmppServer