diff options
-rw-r--r-- | xmppServer.hs | 29 |
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 | ||
213 | newConn state k addr outchan = | 213 | newConn 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 | ||
218 | eofConn state k = atomically $ modifyTVar' (writeTos state) $ Map.delete k | 218 | eofConn state k = atomically $ modifyTVar' (keyToChan state) $ Map.delete k |
219 | 219 | ||
220 | rewriteJIDForClient1:: Text -> IO (Maybe ((Maybe Text,Text,Maybe Text),SockAddr)) | 220 | rewriteJIDForClient1:: Text -> IO (Maybe ((Maybe Text,Text,Maybe Text),SockAddr)) |
221 | rewriteJIDForClient1 jid = do | 221 | rewriteJIDForClient1 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 |