diff options
-rw-r--r-- | Presence/XMPPServer.hs | 10 | ||||
-rw-r--r-- | xmppServer.hs | 34 |
2 files changed, 38 insertions, 6 deletions
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index a61601ef..02dd5134 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs | |||
@@ -23,6 +23,7 @@ module XMPPServer | |||
23 | , presenceProbe | 23 | , presenceProbe |
24 | , presenceSolicitation | 24 | , presenceSolicitation |
25 | , makePresenceStanza | 25 | , makePresenceStanza |
26 | , makeInformSubscription | ||
26 | , JabberShow(..) | 27 | , JabberShow(..) |
27 | ) where | 28 | ) where |
28 | 29 | ||
@@ -759,6 +760,15 @@ grokStanza "jabber:client" stanzaTag = | |||
759 | mkname :: Text -> Text -> XML.Name | 760 | mkname :: Text -> Text -> XML.Name |
760 | mkname namespace name = (Name name (Just namespace) Nothing) | 761 | mkname namespace name = (Name name (Just namespace) Nothing) |
761 | 762 | ||
763 | makeInformSubscription namespace from to approved = | ||
764 | stanzaFromList (PresenceInformSubscription approved) | ||
765 | $ [ EventBeginElement (mkname namespace "presence") | ||
766 | [ attr "from" from | ||
767 | , attr "to" to | ||
768 | , attr "type" $ if approved then "subscribed" | ||
769 | else "unsubscribed" ] | ||
770 | , EventEndElement (mkname namespace "presence")] | ||
771 | |||
762 | makePresenceStanza namespace mjid pstat = do | 772 | makePresenceStanza namespace mjid pstat = do |
763 | stanzaFromList PresenceStatus { presenceShow = pstat | 773 | stanzaFromList PresenceStatus { presenceShow = pstat |
764 | , presencePriority = Nothing | 774 | , presencePriority = Nothing |
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" |