diff options
Diffstat (limited to 'xmppServer.hs')
-rw-r--r-- | xmppServer.hs | 34 |
1 files changed, 28 insertions, 6 deletions
diff --git a/xmppServer.hs b/xmppServer.hs index 81cbf212..c781baf9 100644 --- a/xmppServer.hs +++ b/xmppServer.hs | |||
@@ -528,8 +528,8 @@ informPeerPresence state k stanza = do | |||
528 | writeTVar (remotesByPeer state) $ Map.insert k umap' rbp | 528 | writeTVar (remotesByPeer state) $ Map.insert k umap' rbp |
529 | -- TODO: Store or delete the stanza (remotesByPeer) | 529 | -- TODO: Store or delete the stanza (remotesByPeer) |
530 | 530 | ||
531 | -- For now, all clients: | 531 | -- all clients, we'll filter available/authorized later |
532 | -- (TODO: interested/auteorized clients only.) | 532 | |
533 | ktc <- readTVar (keyToChan state) | 533 | ktc <- readTVar (keyToChan state) |
534 | runTraversableT $ do | 534 | runTraversableT $ do |
535 | (ck,client) <- liftMT $ fmap Map.toList $ readTVar (clients state) | 535 | (ck,client) <- liftMT $ fmap Map.toList $ readTVar (clients state) |
@@ -537,6 +537,8 @@ informPeerPresence state k stanza = do | |||
537 | return (ck,con,client) | 537 | return (ck,con,client) |
538 | putStrLn $ "xmppInformPeerPresence (length clients="++show (length clients)++")" | 538 | putStrLn $ "xmppInformPeerPresence (length clients="++show (length clients)++")" |
539 | forM_ clients $ \(ck,con,client) -> do | 539 | forM_ clients $ \(ck,con,client) -> do |
540 | -- (TODO: appropriately authorized clients only.) | ||
541 | -- For now, all "available" clients (available = sent initial presence) | ||
540 | when (clientIsAvailable client) $ do | 542 | when (clientIsAvailable client) $ do |
541 | froms <- do | 543 | froms <- do |
542 | let ClientKey laddr = ck | 544 | let ClientKey laddr = ck |
@@ -667,6 +669,12 @@ peerSubscriptionRequest state fail k stanza chan = do | |||
667 | (mfrom_u,from_h,_) = splitJID from | 669 | (mfrom_u,from_h,_) = splitJID from |
668 | to <- return $ unsplitJID (mto_u,h,Nothing) -- delete resource | 670 | to <- return $ unsplitJID (mto_u,h,Nothing) -- delete resource |
669 | from <- return $ unsplitJID (mfrom_u,from_h,Nothing) -- delete resource | 671 | from <- return $ unsplitJID (mfrom_u,from_h,Nothing) -- delete resource |
672 | ktc <- atomically . readTVar $ keyToChan state | ||
673 | flip (maybe fail) (Map.lookup k ktc) | ||
674 | $ \Conn { auxAddr=laddr } -> do | ||
675 | (mine,totup) <- rewriteJIDForClient laddr to | ||
676 | if not mine then fail else do | ||
677 | (_,fromtup) <- rewriteJIDForClient laddr from | ||
670 | flip (maybe fail) mto_u $ \u -> do | 678 | flip (maybe fail) mto_u $ \u -> do |
671 | flip (maybe fail) mfrom_u $ \from_u -> do | 679 | flip (maybe fail) mfrom_u $ \from_u -> do |
672 | subs <- configText ConfigFiles.getSubscribers u | 680 | subs <- configText ConfigFiles.getSubscribers u |
@@ -681,8 +689,10 @@ peerSubscriptionRequest state fail k stanza chan = do | |||
681 | if already_subscribed | 689 | if already_subscribed |
682 | then do | 690 | then do |
683 | -- contact ∈ subscribers --> SHOULD NOT, already handled | 691 | -- contact ∈ subscribers --> SHOULD NOT, already handled |
684 | -- TODO: already subscribed, reply and quit | 692 | -- already subscribed, reply and quit |
685 | return () | 693 | -- (note: swapping to and from for reply) |
694 | reply <- makeInformSubscription "jabber:server" to from True | ||
695 | sendModifiedStanzaToPeer reply chan | ||
686 | else do | 696 | else do |
687 | -- Catch exception in case the user does not exist | 697 | -- Catch exception in case the user does not exist |
688 | handle (\e -> let _ = isDoesNotExistError e in fail) $ do | 698 | handle (\e -> let _ = isDoesNotExistError e in fail) $ do |
@@ -693,8 +703,20 @@ peerSubscriptionRequest state fail k stanza chan = do | |||
693 | -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT | 703 | -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT |
694 | when (not already_pending) $ do | 704 | when (not already_pending) $ do |
695 | -- contact ∉ subscribers & contact ∉ pending --> MUST | 705 | -- contact ∉ subscribers & contact ∉ pending --> MUST |
696 | -- TODO: send to clients | 706 | mlp <- atomically $ do |
697 | return () | 707 | cmap <- readTVar $ clientsByUser state |
708 | return $ Map.lookup u cmap | ||
709 | let ks = do lp <- maybeToList mlp | ||
710 | Map.keys (networkClients lp) | ||
711 | chans = mapMaybe (flip Map.lookup ktc) ks | ||
712 | forM_ chans $ \Conn { connChan=chan } -> do | ||
713 | -- send to clients | ||
714 | -- TODO: interested/available clients only? | ||
715 | dup <- cloneStanza stanza | ||
716 | sendModifiedStanzaToClient dup { stanzaFrom = Just $ unsplitJID fromtup | ||
717 | , stanzaTo = Just $ unsplitJID totup } | ||
718 | chan | ||
719 | |||
698 | 720 | ||
699 | clientInformSubscription state fail k stanza = do | 721 | clientInformSubscription state fail k stanza = do |
700 | putStrLn $ "TODO: clientInformSubscription" | 722 | putStrLn $ "TODO: clientInformSubscription" |