diff options
-rw-r--r-- | xmppServer.hs | 28 |
1 files changed, 24 insertions, 4 deletions
diff --git a/xmppServer.hs b/xmppServer.hs index 30d6b2c4..8fdb4f78 100644 --- a/xmppServer.hs +++ b/xmppServer.hs | |||
@@ -206,16 +206,19 @@ tellClientHisName state k = forClient state k fallback go | |||
206 | 206 | ||
207 | toMapUnit xs = Map.fromList $ map (,()) xs | 207 | toMapUnit xs = Map.fromList $ map (,()) xs |
208 | 208 | ||
209 | resolveAllPeers :: [Text] -> IO (Map SockAddr ()) | ||
209 | resolveAllPeers hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer) hosts | 210 | resolveAllPeers hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer) hosts |
210 | 211 | ||
212 | configText what u = | ||
213 | fmap (map lazyByteStringToText) | ||
214 | $ what (textToLazyByteString u) | ||
215 | |||
211 | rosterGetStuff | 216 | rosterGetStuff |
212 | :: (L.ByteString -> IO [L.ByteString]) | 217 | :: (L.ByteString -> IO [L.ByteString]) |
213 | -> PresenceState -> ConnectionKey -> IO [Text] | 218 | -> PresenceState -> ConnectionKey -> IO [Text] |
214 | rosterGetStuff what state k = forClient state k (return []) | 219 | rosterGetStuff what state k = forClient state k (return []) |
215 | $ \client -> do | 220 | $ \client -> do |
216 | jids <- | 221 | jids <- configText what (clientUser client) |
217 | fmap (map lazyByteStringToText) | ||
218 | $ what (textToLazyByteString $ clientUser client) | ||
219 | let hosts = map ((\(_,h,_)->h) . splitJID) jids | 222 | let hosts = map ((\(_,h,_)->h) . splitJID) jids |
220 | addrs <- resolveAllPeers hosts | 223 | addrs <- resolveAllPeers hosts |
221 | peers <- atomically $ readTVar (associatedPeers state) | 224 | peers <- atomically $ readTVar (associatedPeers state) |
@@ -417,7 +420,24 @@ informClientPresence state k stanza = do | |||
417 | mb <- fmap (Map.lookup k) $ readTVar (clients state) | 420 | mb <- fmap (Map.lookup k) $ readTVar (clients state) |
418 | flip (maybe $ return ()) mb $ \cstate -> do | 421 | flip (maybe $ return ()) mb $ \cstate -> do |
419 | writeTVar (clientStatus cstate) $ Just dup | 422 | writeTVar (clientStatus cstate) $ Just dup |
420 | -- TODO: inform subscribers | 423 | forClient state k (return ()) $ \client -> do |
424 | jids <- configText ConfigFiles.getSubscribers (clientUser client) | ||
425 | let hosts = map ((\(_,h,_)->h) . splitJID) jids | ||
426 | addrs <- fmap Map.keys $ resolveAllPeers hosts | ||
427 | ktc <- atomically $ readTVar (keyToChan state) | ||
428 | let connected = mapMaybe (flip Map.lookup ktc . PeerKey) addrs | ||
429 | forM_ connected $ \con -> do | ||
430 | let from' = unsplitJID ( Just $ clientUser client | ||
431 | , addrToText $ auxAddr con | ||
432 | , Just $ clientResource client) | ||
433 | mto <- runTraversableT $ do | ||
434 | to <- liftT $ stanzaTo stanza | ||
435 | (to',_) <- liftMT $ rewriteJIDForPeer to | ||
436 | return to' | ||
437 | dup <- cloneStanza stanza | ||
438 | sendModifiedStanzaToPeer dup { stanzaFrom = Just from' | ||
439 | , stanzaTo = mto } | ||
440 | (connChan con) | ||
421 | 441 | ||
422 | informPeerPresence state k stanza = do | 442 | informPeerPresence state k stanza = do |
423 | -- Presence must indicate full JID with resource... | 443 | -- Presence must indicate full JID with resource... |